demounit.dfm

PIC 单片机 PAS SOURCE CODE SAMPLES

object frmDemo: TfrmDemo
  Left = 213
  Top = 134
  Width = 751
  Height = 632
  Caption = 'Demo'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl: TPageControl
    Left = 0
    Top = 0
    Width = 743
    Height = 598
    ActivePage = tsDelphi
    Align = alClient
    TabOrder = 0
    object tsDelphi: TTabSheet
      Caption = 'Delphi'
      object edDelphi: TRichEdit
        Left = 0
        Top = 0
        Width = 735
        Height = 570
        Align = alClient
        Font.Charset = RUSSIAN_CHARSET
        Font.Color = clWindowText
        Font.Height = -13
        Font.Name = 'Courier New'
        Font.Style = []
        Lines.Strings = (
          '{*******************************************************}'
          '{                                                       }'
          '{  idCGIRunner component for Internet Direct (Indy)     }'
          '{                   HTTP Server                         }'
          '{                                                       }'
          '{ Author:                                               }'
          '{ Serhiy Perevoznyk                                     }'
          '{ [e-mail]                          }'
          '{                                                       }'
          '{     Use, modification and distribution is allowed     }'
          '{without limitation, warranty, or liability of any kind.}'
          '{                                                       }'
          '{*******************************************************}'
          ''
          'unit idCGIRunner;'
          ''
          'interface'
          ''
          'uses'
          '  Windows,'
          '  SysUtils,'
          '  Classes,'
          '  idTCPServer,'
          '  idHTTPServer;'
          ''
          'type'
          '  {TidCGIRunner component allows to execute CGI scripts using '
          '   Indy TidHTTPServer component} '
          '  TidCGIRunner = class(TComponent)'
          '   private'
          '     FServer : TidHTTPServer;'
          '     FTimeOut : integer;'
          '     FTimeOutMsg : string;'
          '     FErrorMsg : string;'
          '     FServerAdmin : string;'
          '     FDocumentRoot : string;'
          '     procedure SetServer(const AValue : TIdHTTPServer);'
          '   protected'
          '      //Forwards notification messages to all owned components.'
          
            '      procedure Notification(AComponent: TComponent; Operation: ' +
            'TOperation); override;'
          '   public'
          
            '     //Allocates memory and constructs a safely initialized inst' +
            'ance of a component.'
          '     constructor Create(AOwner : TComponent); override;'
          '     {Execute CGI executable and return result to WebServer'
          '      LocalDoc - the full local path to executable file'
          '      e.g. c:\inetpub\wwwroot\cgi-bin\cgi.exe'
          
            '      RequestInfo - TIdHTTPRequestInfo publishes properties that' +
            ' provide '
          '      access to various information for a HTTP request. '
          
            '      The properties include the HTTP session, authentication pa' +
            'rameters, '
          
            '      the remote computer addresses, HTTP headers, cookies, the ' +
            'HTTP command '
          '      and version, and the document URL for the request.'
          
            '      ResponseInfo - IdHTTPResponseInfo publishes properties tha' +
            't provide '
          '      access to various information for a HTTP response.'
          
            '      These properties include the HTTP session, the authenticat' +
            'ion realm, '
          
            '      Cookies, Headers, and the response content, length, and ty' +
            'pe.'
          
            '      Action - PathInfo of TWebActionItem of your CGI executable' +
            '}'
          '     function Execute(LocalDoc : string;'
          '                      AThread: TIdPeerThread;'
          '                      RequestInfo: TIdHTTPRequestInfo;'
          '                      ResponseInfo: TIdHTTPResponseInfo;'
          '                      Action : string = '#39#39') : integer;'
          '   published'
          '     //Indy TidHTTPServer'
          
            '     property Server : TidHTTPServer read FServer write SetServe' +
            'r;'
          '     //Specifies the time-out interval, in milliseconds'
          
            '     property TimeOut: integer read FTimeOut write FTimeOut defa' +
            'ult 5000;'
          '     //Time-out error message text'
          
            '     property TimeOutMsg : string read FTimeOutMsg write FTimeOu' +
            'tMsg;'
          '     //General error message text'
          '     property ErrorMsg : string read FErrorMsg write FErrorMsg;'
          
            '     {Email address of Server Administator (optional, for compat' +
            'ibility'
          '      with Apache) }'
          
            '     property ServerAdmin : string read FServerAdmin write FServ' +
            'erAdmin;'
          '     //Local path to virtual root of your WebServer'
          
            '     property DocumentRoot : string read FDocumentRoot write FDo' +
            'cumentRoot;'
          '   end;'
          ''
          '//register TidCGIRunner component'
          'procedure Register;'
          ''
          'implementation'
          ''
          'type'
          '  ThreadParams = record'
          '    hReadPipe : THandle;'
          '    s : String;'
          '  end;'
          '  PThreadParams = ^ThreadParams;'
          ''
          'function ThreadRead(Params : Pointer):Dword; stdcall;'
          'var'
          '  Info : PThreadParams;'
          '  Buffer :  array [0..4095] of Char;'
          '  nb: DWord;'
          '  i: Longint;'
          'begin'
          '  Result := 0;'
          '  Info := PThreadParams(Params);'
          '  while ReadFile( Info^.hReadPipe,'
          '                  buffer,'
          '                  SizeOf(buffer),'
          '                  nb,'
          '                  nil) do'
          '     begin'
          '       if nb = 0 then'
          '         Break;'
          '       for i:=0 to nb-1 do'
          '         Info^.s := Info^.s + buffer[i];'
          '      end;'
          ''
          'end;'
          ''
          ''
          'function GetEnv(const Name: string): string;'
          'var'
          '  Buffer: array[0..4095] of Char;'
          'begin'
          
            '  SetString(Result, Buffer, GetEnvironmentVariable(PChar(Name), ' +
            'Buffer, SizeOf(Buffer)));'
          'end;'
          ''
          ''
          ''
          'constructor TidCGIRunner.Create(AOwner: TComponent);'
          'begin'
          '  inherited;'
          
            '  FErrorMsg := '#39'<html><body><h1><center>Internal Server Error</b' +
            'ody></html>'#39'#13#10;'
          
            '  FTimeOutMsg := '#39'<html><body><h1><center>Process is terminated.' +
            '</body></html>'#39'#13#10;'
          '  FServerAdmin := '#39'admin@server'#39';'
          '  FTimeOut := 5000;'
          'end;'
          ''
          
            'function TidCGIRunner.Execute(LocalDoc : string; AThread: TIdPee' +
            'rThread;'
          '                              RequestInfo: TIdHTTPRequestInfo;'
          '                              ResponseInfo: TIdHTTPResponseInfo;'
          '                              Action : string = '#39#39') : integer;'
          'const'
          '  FEnv = '#39'%s=%s'#39'#0;'
          ''
          'var'
          '  ParsLine : string;'
          '  ParsList : TStringList;'
          '  I        : integer;'
          '  hReadPipe,'
          '  hNIReadPipe,'
          '  hWritePipe: THandle;'
          '  saPipe: TSecurityAttributes;'
          '  StartInfo: TStartupInfo;'
          '  ProcInfo: TProcessInformation;'
          '  Params : PThreadParams;'
          '  ReaderID : Dword;'
          '  ReaderHandle : THandle;'
          '  cEnv : String;'
          ''
          'begin'
          '  cEnv := '#39#39';'
          '  if Assigned(FServer) then'
          
            '   cEnv :=        Format(FEnv,['#39'SERVER_SOFTWARE'#39', FServer.Server' +
            'Software ]);'
          '  cEnv := cEnv + Format(FEnv,['#39'SERVER_NAME'#39',RequestInfo.Host]);;'
          
            '  cEnv := cEnv + Format(FEnv,['#39'SERVER_PROTOCOL'#39',RequestInfo.Vers' +
            'ion]);'
          
            '  cEnv := cEnv + Format(FEnv,['#39'SERVER_PORT'#39',IntToStr(AThread.Con' +
            'nection.Binding.Port)]);'
          ''
          '  cEnv := cEnv + Format(FEnv,['#39'GATEWAY_INTERFACE'#39','#39'CGI/1.1'#39']);'
          
            '  cEnv := cEnv + Format(FEnv,['#39'REQUEST_METHOD'#39',RequestInfo.Comma' +
            'nd]);'
          
            '  cEnv := cEnv + Format(FEnv,['#39'SCRIPT_NAME'#39',RequestInfo.Document' +
            ']);'
          
            '  cEnv := cEnv + Format(FEnv,['#39'QUERY_STRING'#39',RequestInfo.Unparse' +
            'dParams]);'
          ''
          
            '  cEnv := cEnv + Format(FEnv,['#39'REMOTE_ADDR'#39',RequestInfo.RemoteIP' +
            ']);'
          ''
          '  //Win32 fields'
          
            '  cEnv := cEnv + Format(FEnv,['#39'SystemRoot'#39',getenv('#39'SystemRoot'#39')]' +
            ');'
          '  cEnv := cEnv + Format(FEnv,['#39'COMSPEC'#39',getenv('#39'COMSPEC'#39')]);'
          '  cEnv := cEnv + Format(FEnv,['#39'WINDIR'#39',getenv('#39'WINDIR'#39')]);'
          '  cEnv := cEnv + Format(FEnv,['#39'PATH'#39',getenv('#39'PATH'#39')]);'
          '  cEnv := cEnv + Format(FEnv,['#39'PATH_INFO'#39', Action]);'
          
            '  cEnv := cEnv + Format(FEnv,['#39'PATH_TRANSLATED'#39',ExpandFileName(D' +
            'ocumentRoot + Action)]);'
          ''
          '  //Add HTTP_ fields'
          '  cEnv := cEnv + Format(FEnv,['#39'HTTP_ACCEPT'#39','#39'*/*'#39']);'
          ''
          '  //Apache fields'
          
            '  cEnv := cEnv + Format(FEnv,['#39'SERVER_ADDR'#39',AThread.Connection.B' +
            'inding.IP]);'
          '  cEnv := cEnv + Format(FEnv,['#39'DOCUMENT_ROOT'#39',DocumentRoot]);'
          '  cEnv := cEnv + Format(FEnv,['#39'SERVER_ADMIN'#39',ServerAdmin]);'
          '  cEnv := cEnv + Format(FEnv,['#39'SCRIPT_FILENAME'#39','#39#39']);'
          ''
          '  cEnv := cEnv + #0;'
          ''
          '  Params := nil;'
          '  ReaderHandle := 0;'
          '  saPipe.bInheritHandle := True;'
          '  saPipe.lpSecurityDescriptor := nil;'
          '  saPipe.nLength := SizeOf(saPipe);'
          ''
          '  if not CreatePipe(hReadPipe,hWritePipe,@saPipe,0) then'
          '    RaiseLastWin32Error;'
          ''
          '  FillChar(StartInfo,SizeOf(StartInfo),0);'
          ''
          '  StartInfo.dwFlags:= STARTF_USESTDHANDLES  or'
          '                      STARTF_USESHOWWINDOW;'
          '  StartInfo.wShowWindow:=SW_HIDE;'
          '  StartInfo.hStdOutput := hWritePipe;'
          '  StartInfo.hStdError  := hWritePipe;'
          '  StartInfo.cb:=SizeOf(StartInfo);'
          ''
          ''
          'try'
          '  if not DuplicateHandle( GetCurrentProcess,'
          '                          hReadPipe,'
          '                          GetCurrentProcess,'
          '                          @hNIReadPipe,'
          '                          0,'
          '                          False,'
          '                          DUPLICATE_SAME_ACCESS) then'
          '       begin'
          '        ResponseInfo.ContentText := FErrorMsg;'
          
            '        ResponseInfo.ContentLength := Length(ResponseInfo.Conten' +
            'tText);'
          '        ResponseInfo.ResponseNo := 500;'
          '        Result :=  ResponseInfo.ContentLength;'
          '        Exit;'
          '       end;'
          ''
          '  CloseHandle(hReadPipe);'
          ''
          '  New(Params);'