dxcgi.pas

Well known and usefull component for delphi 7

         Add('REQUEST_METHOD', HeaderInfo^.Method);
         Add('QUERY_STRING', HeaderInfo^.QueryString);
//         Add('QUERY_STRING', DXString.EscapeEncode(HeaderInfo^.QueryString)); // do I need to re-encode it?
         Add('SERVER_PROTOCOL', HeaderInfo^.Protocol);
         Add('CONTENT_TYPE', HeaderInfo^.ContentType);
         Add('CONTENT_LENGTH', IntegerToString(HeaderInfo^.ContentLength));
         Add('USER_NAME', HeaderInfo^.AuthName);
         Add('USER_PASSWORD', HeaderInfo^.AuthPass);
         Add('AUTH_TYPE', HeaderInfo^.AuthType);
         // DEC 1 added these too:
         Add('HTTP_AUTHORIZATION', HeaderInfo^.AuthType);
         Add('AUTH_PASSWORD', HeaderInfo^.AuthPass);
         Add('AUTH_NAME', HeaderInfo^.AuthName);
         Add('AUTH_USER', HeaderInfo^.AuthName);
         Add('REQUEST_URI', HeaderInfo^.URI);
         Add('INSTANCE_META_DATA',ExtraVariables^.INSTANCE_META_DATA);
         Add('APPL_MD_PATH',ExtraVariables^.APPL_MD_PATH);
         Add('APPL_PHYSICAL_PATH',ExtraVariables^.APPL_PHYSICAL_PATH);
         Add('SERVER_SOFTWARE',ExtraVariables^.SERVER_SOFTWARE);
         Add('SERVER_NAME',ExtraVariables^.SERVER_SOFTWARE);
         Add('SERVER_VERSION',ExtraVariables^.SERVER_VERSION);
         Add('SERVER_PORT',ExtraVariables^.SERVER_PORT);

         AuxS:=StringReplace(HeaderInfo^.All_HTTP,':','=',[rfReplaceAll]);
         AuxS:=StringReplace(AuxS,#10,#0,[rfReplaceAll]);
         AuxS:=StringReplace(AuxS,#13,'',[rfReplaceAll]); // jic I change something later - this covers my butt!
         Result:=Result+AuxS;
      end;
   end;

begin
   Result:=False;
   with Security do begin
      nLength:=SizeOf(TSecurityAttributes);
      lpSecurityDescriptor:=nil;
      bInheritHandle:=True;
   end;
   CreatePipe(StdIn_Read, StdIn_Write, @Security, 0);
   CreatePipe(StdOut_Read, StdOut_Write, @Security, 0);
   CreatePipe(StdErr_Read, StdErr_Write, @Security, 0);
   FillChar2(StartupInfo, SizeOf(StartupInfo), #0);
   with StartupInfo do begin
      CB:=SizeOf(TStartupInfo);
      dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      hStdInput:=StdIn_Read;
      hStdOutput:=StdOut_Write;
      hStdError:=StdErr_Write;
      wShowWindow:=SW_HIDE;
   end;
   Status:=CreateProcess(nil, PChar(CGIProgram), @Security, @Security, True,
      CREATE_SUSPENDED, PChar(GetEnvStr), PChar(PathToCGI), StartupInfo,
      ProcessInformation);
   if Status then begin
      if WaitForInputIdle(ProcessInformation.hProcess, 0)=WAIT_TIMEOUT then begin
         ErrorMsg:=CGIProgram+' is a GUI application!';
         TerminateProcess(ProcessInformation.hProcess, 0);
         CloseHandle(ProcessInformation.hThread);
         CloseHandle(ProcessInformation.hProcess);
      end;
   end
   else begin
      ErrorMsg:=SysErrorMessage(GetLastError);
      CloseHandle(StdIn_Read);
      CloseHandle(StdIn_Write);
      CloseHandle(StdOut_Read);
      CloseHandle(StdOut_Write);
      CloseHandle(StdErr_Read);
      CloseHandle(StdErr_Write);
      Exit;
   end;
   if Assigned(HeaderInfo) then begin
      if HeaderInfo.PostData='' then begin // Dec-1-2003 was QueryString
         PipeWriteStdThread:=nil;
      end
      else begin
         PipeWriteStdThread:=TPipeWriteStdThread.Create(True);
         PipeWriteStdThread.s:=HeaderInfo^.PostData; // Dec-1-2003 was QueryString
         PipeWriteStdThread.HPipe:=Stdin_Write;
         PipeWriteStdThread.Suspended:=False;
      end;
   end
   else begin
      PipeWriteStdThread:=nil;
   end;
   PipeReadErrThread:=TPipeReadErrThread.Create(True);
   PipeReadErrThread.HPipe:=StdErr_Read;
   PipeReadErrThread.Suspended:=False;
   PipeReadStdThread:=TPipeReadStdThread.Create(True);
   PipeReadStdThread.Priority:=tpLower;
   PipeReadStdThread.S:='';
   PipeReadStdThread.HPipe:=StdOut_Read;
   PipeReadStdThread.Suspended:=False;
   ResumeThread(ProcessInformation.hThread);
   WaitForSingleObject(ProcessInformation.hProcess, 50000);
   CloseHandle(ProcessInformation.hThread);
   CloseHandle(ProcessInformation.hProcess);
   CloseHandle(StdIn_Read);
   if PipeWriteStdThread<>nil then begin
      WaitForSingleObject(PipeWriteStdThread.Handle, INFINITE);
      PipeWriteStdThread.Terminate;
      PipeWriteStdThread.Free;
      PipeWriteStdThread:=nil;
   end;
   CloseHandle(StdIn_Write);
   CloseHandle(StdErr_Write);
   PipeReadErrThread.Terminate;
   WaitForSingleObject(PipeReadErrThread.Handle, INFINITE);
   ErrorMsg:=PipeReadErrThread.s;
   PipeReadErrThread.Free;
   PipeReadErrThread:=nil;
   CloseHandle(StdErr_Read);

   PipeReadStdThread.Terminate;
   CloseHandle(StdOut_Write);
   WaitForSingleObject(PipeReadStdThread.Handle, INFINITE);

   while not PipeReadStdThread.Error do begin
      if ReadFile(Stdout_READ, ActualIn[1], 250, Actually, nil) then begin
         ActualIn[0]:=Chr(Actually);
         PipeReadStdThread.s:=PipeReadStdThread.s+ActualIn;
      end
      else
         Break;
   end;
   CloseHandle(Stdout_Read);
   Output:=PipeReadStdThread.s;
   PipeReadStdThread.Free;
   PipeReadStdThread:=nil;
   Result:=True;
end;

function TDXCGI.ExecuteGUIScript(const CGIProgram, PathToCGI:string;
   HeaderInfo:PHeaderInfo;ExtraVariables:PExtraVariables; var Output, ErrorMsg:string):Boolean;
var
   Security:TSecurityAttributes;
   StdIn_Read, StdIn_Write:THandle;
   StdOut_Read, StdOut_Write:THandle;
   StdErr_Read, StdErr_Write:THandle;
   StartupInfo:TStartupInfo;
   Status:Boolean;
   ProcessInformation:TProcessInformation;
   PipeReadStdThread:TPipeReadStdThread;
   PipeWriteStdThread:TPipeWriteStdThread;
   PipeReadErrThread:TPipeReadErrThread;
   Actually:DWORD;
   ActualIn:ShortString;

   function GetEnvStr:string;
   var
      AuxS:string;
      p:PByteArray;
      j:Integer;

      procedure Add(const Name, Value:string);
      begin
         if Value<>'' then Result:=Result+Name+'='+Value+#0;
      end;

   begin
      p:=Pointer(GetEnvironmentStrings);
      j:=0;
      while (p^[j]<>0)or(p^[j+1]<>0) do
         Inc(j);
      Inc(j);
      SetLength(Result, j);
      FastMove(p^, Result[1], j);
      FreeEnvironmentStrings(Pointer(p));
      If Copy(Result,1,6)= '=::=::' then Delete(Result,1,8);
      if Assigned(HeaderInfo) then begin
//         AuxS:=ToUnixSlashes(AddbackSlash(PathToCGI));
         AuxS:=HeaderInfo^.URI; // Dec-1-2003 OZZ
         Add('PATH_INFO', AuxS);
         if AuxS<>'' then AuxS:=AddbackSlash(PathToCGI);
         Add('PATH_TRANSLATED', AuxS);
         Add('REMOTE_HOST', HeaderInfo^.ClientHost);
         Add('REMOTE_ADDR', HeaderInfo^.ClientAddr);
         Add('GATEWAY_INTERFACE', 'CGI/1.2');
         Add('SCRIPT_NAME', HeaderInfo^.URI);
         Add('REQUEST_METHOD', HeaderInfo^.Method);
         Add('QUERY_STRING', HeaderInfo^.QueryString);
//         Add('QUERY_STRING', DXString.EscapeEncode(HeaderInfo^.QueryString)); // do I need to re-encode it?
         Add('SERVER_PROTOCOL', HeaderInfo^.Protocol);
         Add('CONTENT_TYPE', HeaderInfo^.ContentType);
         Add('CONTENT_LENGTH', IntegerToString(HeaderInfo^.ContentLength));
         Add('USER_NAME', HeaderInfo^.AuthName);
         Add('USER_PASSWORD', HeaderInfo^.AuthPass);
         Add('AUTH_TYPE', HeaderInfo^.AuthType);
         // DEC 1 added these too:
         Add('HTTP_AUTHORIZATION', HeaderInfo^.AuthType);
         Add('AUTH_PASSWORD', HeaderInfo^.AuthPass);
         Add('AUTH_NAME', HeaderInfo^.AuthName);
         Add('AUTH_USER', HeaderInfo^.AuthName);
         Add('REQUEST_URI', HeaderInfo^.URI);
         Add('INSTANCE_META_DATA',ExtraVariables^.INSTANCE_META_DATA);
         Add('APPL_MD_PATH',ExtraVariables^.APPL_MD_PATH);
         Add('APPL_PHYSICAL_PATH',ExtraVariables^.APPL_PHYSICAL_PATH);
         Add('SERVER_SOFTWARE',ExtraVariables^.SERVER_SOFTWARE);
         Add('SERVER_NAME',ExtraVariables^.SERVER_SOFTWARE);
         Add('SERVER_VERSION',ExtraVariables^.SERVER_VERSION);
         Add('SERVER_PORT',ExtraVariables^.SERVER_PORT);

         AuxS:=StringReplace(HeaderInfo^.All_HTTP,':','=',[rfReplaceAll]);
         AuxS:=StringReplace(AuxS,#10,#0,[rfReplaceAll]);
         AuxS:=StringReplace(AuxS,#13,'',[rfReplaceAll]); // jic I change something later - this covers my butt!
         Result:=Result+AuxS;

//for php support
//       Add('PHPRC',PHPIniPath);
//       Add('REDIRECT_STATUS','200');
//       Add('HTTP_REDIRECT_STATUS','200');
//       Add('REDIRECT_URL',Document);
//         ShowMessageWindow('',CleanStr(StringReplace(Result,#0,#13,[rfReplaceAll])));
      end;
   end;

begin
   Result:=False;
   with Security do begin
      nLength:=SizeOf(TSecurityAttributes);
      lpSecurityDescriptor:=nil;
      bInheritHandle:=True;
   end;
   CreatePipe(StdIn_Read, StdIn_Write, @Security, 0);
   CreatePipe(StdOut_Read, StdOut_Write, @Security, 0);
   CreatePipe(StdErr_Read, StdErr_Write, @Security, 0);
   FillChar2(StartupInfo, SizeOf(StartupInfo), #0);
   with StartupInfo do begin
      CB:=SizeOf(TStartupInfo);
      dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      hStdInput:=StdIn_Read;
      hStdOutput:=StdOut_Write;
      hStdError:=StdErr_Write;
      wShowWindow:=SW_HIDE;
   end;
   Status:=CreateProcess(nil, PChar(CGIProgram), @Security, @Security, True,
      CREATE_SUSPENDED, PChar(GetEnvStr), PChar(PathToCGI), StartupInfo,
      ProcessInformation);
   if not Status then begin
      ErrorMsg:=SysErrorMessage(GetLastError);
      CloseHandle(StdIn_Read);
      CloseHandle(StdIn_Write);
      CloseHandle(StdOut_Read);
      CloseHandle(StdOut_Write);
      CloseHandle(StdErr_Read);
      CloseHandle(StdErr_Write);
      Exit;
   end;
   if Assigned(HeaderInfo) then begin
      if HeaderInfo.PostData='' then begin // Dec-1-2003 was QueryString
         PipeWriteStdThread:=nil;
      end
      else begin
         PipeWriteStdThread:=TPipeWriteStdThread.Create(True);
         PipeWriteStdThread.s:=HeaderInfo^.PostData; // Dec-1-2003 was QueryString
         PipeWriteStdThread.HPipe:=Stdin_Write;
         PipeWriteStdThread.Suspended:=False;
      end;
   end
   else begin
      PipeWriteStdThread:=nil;
   end;
   PipeReadErrThread:=TPipeReadErrThread.Create(True);
   PipeReadErrThread.HPipe:=StdErr_Read;
   PipeReadErrThread.Suspended:=False;
   PipeReadStdThread:=TPipeReadStdThread.Create(True);
   PipeReadStdThread.Priority:=tpLower;
   PipeReadStdThread.S:='';
   PipeReadStdThread.HPipe:=StdOut_Read;
   PipeReadStdThread.Suspended:=False;
   ResumeThread(ProcessInformation.hThread);
   WaitForSingleObject(ProcessInformation.hProcess, 50000);
   CloseHandle(ProcessInformation.hThread);
   CloseHandle(ProcessInformation.hProcess);
   CloseHandle(StdIn_Read);
   if PipeWriteStdThread<>nil then begin
      WaitForSingleObject(PipeWriteStdThread.Handle, INFINITE);
      PipeWriteStdThread.Terminate;
      PipeWriteStdThread.Free;
      PipeWriteStdThread:=nil;
   end;
   CloseHandle(StdIn_Write);
   CloseHandle(StdErr_Write);
   PipeReadErrThread.Terminate;
   WaitForSingleObject(PipeReadErrThread.Handle, INFINITE);
   ErrorMsg:=PipeReadErrThread.s;
   PipeReadErrThread.Free;
   PipeReadErrThread:=nil;
   CloseHandle(StdErr_Read);
   PipeReadStdThread.Terminate;
   CloseHandle(StdOut_Write);
   WaitForSingleObject(PipeReadStdThread.Handle, INFINITE);
   while not PipeReadStdThread.Error do begin
      if ReadFile(Stdout_READ, ActualIn[1], 250, Actually, nil) then begin
         ActualIn[0]:=Chr(Actually);
         PipeReadStdThread.s:=PipeReadStdThread.s+ActualIn;
      end
      else
         Break;
   end;
   CloseHandle(Stdout_Read);
   Output:=PipeReadStdThread.s;
   PipeReadStdThread.Free;
   PipeReadStdThread:=nil;
   Result:=True;
end;

end.


uses
   libc;

procedure TForm1.Button1Click(Sender: TObject);
var
   iPrg: Integer;
begin
//Execute kcalc - A calculator for KDE
   iPrg := libc.system('kcalc');
   if iPrg = -1 then
      ShowMessage('Error executing your program');
end;