telnetsrvmain.~pas

一个DElphi编写的telnet server源程序

unit telnetsrvmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, IdBaseComponent, IdComponent, IdTCPServer, IdTelnetServer,
  IdAntiFreezeBase, IdAntiFreeze,StrUtils;

type
  TMainForm = class(TForm)
    IdTelnetServer1: TIdTelnetServer;
    IdAntiFreeze1: TIdAntiFreeze;
    buttonExit: TButton;
    Label1: TLabel;
    procedure IdTelnetServer1Authentication(AThread: TIdPeerThread;
      const AUsername, APassword: String; var AAuthenticated: Boolean);
    procedure IdTelnetServer1Execute(AThread: TIdPeerThread);
    procedure buttonExitClick(Sender: TObject);
    function CommandLineProc(AThread:TIdPeerThread;CMDStr:string):string;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;
  TheDir :Array[1..255] of Char;
  ThePDir:PChar;
implementation

{$R *.DFM}

procedure TMainForm.IdTelnetServer1Authentication(AThread: TIdPeerThread;
  const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
AAuthenticated:=true;
AThread.Connection.WriteLn('===============================================================');
AThread.Connection.WriteLn('                 欢迎使用潇湘子的 Telnet Test                  ');
AThread.Connection.WriteLn('===============================================================');
AThread.Connection.WriteLn('');
//初始化目录
SetCurrentDirectory(PChar('C:\winnt\system32\'));
end;

procedure TMainForm.IdTelnetServer1Execute(AThread: TIdPeerThread);
var
  str,str2:widestring;
begin
 with AThread.Connection do
  begin
  	getCurrentDirectory(255,@TheDir);
   	ThePDir:=@TheDir;
    Write(copy(ThePDir,0,length(ThePDir))+'>');
    str:=InputLn('');
    str2:=CommandLineProc(AThread,str);
    WriteLn(str2);
  end;
end;


//====================命令行操作--------------------23
function TMainForm.CommandLineProc(AThread:TIdPeerThread;CMDStr:string):string;
  //----------------------------输出定向
  function GetDosOutput(const CommandLine:string): string;
  var
    SA: TSecurityAttributes;
    SI: TStartupInfo;
    PI: TProcessInformation;
    StdOutPipeRead, StdOutPipeWrite: THandle;
    WasOK: Boolean;
    Buffer: array[0..255] of Char;
    BytesRead: Cardinal;
    WorkDir, Line: String;
  begin
    with SA do
    begin
      nLength := SizeOf(SA);
      bInheritHandle := True;
      lpSecurityDescriptor := nil;
    end;
    CreatePipe(StdOutPipeRead,StdOutPipeWrite,@SA,0);
    try
      with SI do
      begin
      	FillChar(SI, SizeOf(SI), 0);
        cb := SizeOf(SI);
        dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      	wShowWindow := SW_Hide;
      	hStdInput := GetStdHandle(STD_INPUT_HANDLE);
      	hStdOutput := StdOutPipeWrite;
        hStdError := StdOutPipeWrite;
      end;
      WasOK:=CreateProcess(nil,PChar(CommandLine),nil,nil,True,HIGH_PRIORITY_CLASS,nil,nil,SI,PI);
      if CloseHandle(StdOutPipeWrite) then begin end;
      if WasOK then
       try
      	 Line := '';
         repeat
           WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
           if BytesRead > 0 then
           begin
      	      Buffer[BytesRead] := #0;
              Line := Line + Buffer;
           end;
         until not WasOK or (BytesRead = 0);
      	 WaitForSingleObject(PI.hProcess, 15000);
       finally
         CloseHandle(PI.hThread);
         CloseHandle(PI.hProcess);
       end;
    finally
      result:=Line;
      CloseHandle(StdOutPipeRead);
    end;
  end;
		     //----------------------------操作系统识别
  function IsNT: Boolean ;
  var
     OSVersionInfo: TOSVersionInfo;
  begin
     OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
     GetVersionEx(OSVersionInfo);
     if OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
       Result := True
     else
      Result := False;
  end;

var
  EchoStr:String;    //类型只能为string;
  TheStrDir:String;
begin
  cmdstr:=trim(cmdstr);
  if (UpperCase(cmdstr)='exit') or (UpperCase(cmdstr)='quit') then
  begin
    IdTelnetServer1.Active:=false;
  end;
  //直接是目录
  if DirectoryExists(CMDStr) then
  begin
	  EchoStr:=CMDStr;
 	  SetCurrentDirectory(PChar(EchoStr));
    result:='';
    exit;
  end;
  //是退格处理
  if UpperCase(StrUtils.LeftStr(CMDStr,4))=UpperCase('cd..') then
  begin
  	getCurrentDirectory(255,@TheDir);
  	ThePDir:=@TheDir;
  	TheStrDir:=ExtractFilePath(String(ThePDir));
  	EchoStr:=TheStrDir;
  	SetCurrentDirectory(PChar(EchoStr));
    result:='';
  	exit;
  end;

  //进入目录处理
  if (UpperCase(StrUtils.LeftStr(CMDStr,2))=UpperCase('cd')) and (trim(copy(cmdstr,3,length(cmdstr)-2))='\') then
  begin
  	getCurrentDirectory(255,@TheDir);
  	ThePDir:=@TheDir;
    EchoStr:=copy(ThePDir,0,3);
 	  SetCurrentDirectory(PChar(EchoStr));
    result:='';
    exit;
  end;

  if UpperCase(StrUtils.LeftStr(CMDStr,3))=UpperCase('cd ') then
  begin
  	getCurrentDirectory(255,@TheDir);
  	ThePDir:=@TheDir;
  	TheStrDir:=String(ThePDir);
  	CMDStr:=StrUtils.RightStr(CMDStr,Length(CMDStr)-3);
  	if DirectoryExists(CMDStr) then //是完整目录处理--1
  	begin
	    EchoStr:=TheStrDir+CMDStr+'\';
   	end
    else
    begin                           //是子目录处理  --2
	   if TheStrDir[Length(ThestrDir)]='\' then
	      EchoStr:=TheStrDir+CMDStr
     else
  	    EchoStr:=TheStrDir+'\'+CMDStr;
  	end;
  	SetCurrentDirectory(PChar(EchoStr));
    result:='';
    exit;
  end;
  //其它命令
  EchoStr:=GetDosOutput('cmd /c '+CMDStr);
  if IsNT then
  begin
    result:=echostr;
  end
  else
  begin
    result:=echostr;
  end;
end;


procedure TMainForm.buttonExitClick(Sender: TObject);
begin
 if IdTelnetServer1.Active=true then
 begin
   IdTelnetServer1.Active:=true
 end;
 Application.Terminate;
end;

procedure TMainForm.FormShow(Sender: TObject);
var
  parameter:string;
  port:integer;
begin
  parameter:=Paramstr(1);
  if trim(parameter)<>'' then
  begin
    try
      port:=strtoint(parameter);
    finally
      showmessage('参数错误!');
      close;
    end;
    IdTelnetServer1.DefaultPort:=port;
  end;
end;

end.