ADD: TProcessUtf8 class

components/doublecmd/dcprocessutf8.pas

@@ -0,0 +1,291 @@
+{
+  Based on process.inc from the Free Component Library (FCL)
+  Copyright (c) 1999-2008 by the Free Pascal development team
+
+  See the file COPYING.FPC, included in this distribution,
+  for details about the copyright.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+unit DCProcessUtf8;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils
+  {$IF DEFINED(MSWINDOWS)}
+  , Process, Windows, Pipes
+  {$ELSEIF DEFINED(UNIX)}
+  UTF8Process
+  {$ENDIF}
+  ;
+
+type
+  { TProcessUtf8 }
+  {$IF DEFINED(UNIX)}
+  TProcessUtf8 = UTF8Process.TProcessUTF8;
+  {$ELSEIF DEFINED(MSWINDOWS)}
+  TProcessUtf8 = class(TProcess)
+  public
+    procedure Execute; override;
+  end;
+  {$ENDIF}
+
+implementation
+
+{$IF DEFINED(MSWINDOWS)}
+
+{$WARN SYMBOL_DEPRECATED OFF}
+
+resourcestring
+  SNoCommandLine = 'Cannot execute empty command-line';
+  SErrCannotExecute = 'Failed to execute %s : %d';
+
+const
+  PriorityConstants: array [TProcessPriority] of Cardinal =
+    (HIGH_PRIORITY_CLASS, IDLE_PRIORITY_CLASS,
+    NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS);
+
+function GetStartupFlags(P: TProcess): Cardinal;
+begin
+  with P do
+  begin
+    Result := 0;
+    if poUsePipes in Options then
+      Result := Result or Startf_UseStdHandles;
+    if suoUseShowWindow in StartupOptions then
+      Result := Result or startf_USESHOWWINDOW;
+    if suoUSESIZE in StartupOptions then
+      Result := Result or startf_usesize;
+    if suoUsePosition in StartupOptions then
+      Result := Result or startf_USEPOSITION;
+    if suoUSECOUNTCHARS in StartupOptions then
+      Result := Result or startf_usecountchars;
+    if suoUsefIllAttribute in StartupOptions then
+      Result := Result or startf_USEFILLATTRIBUTE;
+  end;
+end;
+
+function GetCreationFlags(P: TProcess): Cardinal;
+begin
+  with P do
+  begin
+    Result := 0;
+    if poNoConsole in Options then
+      Result := Result or Detached_Process;
+    if poNewConsole in Options then
+      Result := Result or Create_new_console;
+    if poNewProcessGroup in Options then
+      Result := Result or CREATE_NEW_PROCESS_GROUP;
+    if poRunSuspended in Options then
+      Result := Result or Create_Suspended;
+    if poDebugProcess in Options then
+      Result := Result or DEBUG_PROCESS;
+    if poDebugOnlyThisProcess in Options then
+      Result := Result or DEBUG_ONLY_THIS_PROCESS;
+    if poDefaultErrorMode in Options then
+      Result := Result or CREATE_DEFAULT_ERROR_MODE;
+    Result := Result or PriorityConstants[Priority];
+  end;
+end;
+
+function StringsToPWideChars(List: TStrings): Pointer;
+var
+  I: Integer;
+  EnvBlock: WideString;
+begin
+  EnvBlock := '';
+  for I := 0 to List.Count - 1 do
+    EnvBlock := EnvBlock + UTF8Decode(List[I]) + #0;
+  EnvBlock := EnvBlock + #0;
+  GetMem(Result, Length(EnvBlock) * SizeOf(Widechar));
+  CopyMemory(Result, @EnvBlock[1], Length(EnvBlock) * SizeOf(Widechar));
+end;
+
+procedure InitProcessAttributes(P: TProcess; var PA: TSecurityAttributes);
+begin
+  FillChar(PA, SizeOf(PA), 0);
+  PA.nLength := SizeOf(PA);
+end;
+
+procedure InitThreadAttributes(P: TProcess; var TA: TSecurityAttributes);
+begin
+  FillChar(TA, SizeOf(TA), 0);
+  TA.nLength := SizeOf(TA);
+end;
+
+procedure InitStartupInfo(P: TProcess; var SI: STARTUPINFO);
+const
+  SWC: array [TShowWindowOptions] of Cardinal =
+    (0, SW_HIDE, SW_Maximize, SW_Minimize, SW_Restore, SW_Show,
+    SW_ShowDefault, SW_ShowMaximized, SW_ShowMinimized,
+    SW_showMinNOActive, SW_ShowNA, SW_ShowNoActivate, SW_ShowNormal);
+begin
+  FillChar(SI, SizeOf(SI), 0);
+  with SI do
+  begin
+    dwFlags := GetStartupFlags(P);
+    if P.ShowWindow <> swoNone then
+      dwFlags := dwFlags or Startf_UseShowWindow
+    else
+      dwFlags := dwFlags and not Startf_UseShowWindow;
+    wShowWindow := SWC[P.ShowWindow];
+    if (poUsePipes in P.Options) then
+    begin
+      dwFlags := dwFlags or Startf_UseStdHandles;
+    end;
+    if P.FillAttribute <> 0 then
+    begin
+      dwFlags := dwFlags or Startf_UseFillAttribute;
+      dwFillAttribute := P.FillAttribute;
+    end;
+    dwXCountChars := P.WindowColumns;
+    dwYCountChars := P.WindowRows;
+    dwYsize := P.WindowHeight;
+    dwXsize := P.WindowWidth;
+    dwy := P.WindowTop;
+    dwX := P.WindowLeft;
+  end;
+end;
+
+{ The handles that are to be passed to the child process must be
+  inheritable. On the other hand, only non-inheritable handles
+  allow the sending of EOF when the write-end is closed. This
+  function is used to duplicate the child process's ends of the
+  handles into inheritable ones, leaving the parent-side handles
+  non-inheritable.
+}
+function DuplicateHandleFP(var Handle: THandle): Boolean;
+var
+  oldHandle: THandle;
+begin
+  oldHandle := Handle;
+  Result := DuplicateHandle(GetCurrentProcess(), oldHandle,
+    GetCurrentProcess(), @Handle, 0, True, DUPLICATE_SAME_ACCESS);
+  if Result then
+    Result := CloseHandle(oldHandle);
+end;
+
+
+procedure CreatePipes(var HI, HO, HE: THandle; var SI: TStartupInfo;
+  CE: Boolean; APipeBufferSize: Cardinal);
+begin
+  CreatePipeHandles(SI.hStdInput, HI, APipeBufferSize);
+  DuplicateHandleFP(SI.hStdInput);
+  CreatePipeHandles(HO, Si.hStdOutput, APipeBufferSize);
+  DuplicateHandleFP(Si.hStdOutput);
+  if CE then
+  begin
+    CreatePipeHandles(HE, SI.hStdError, APipeBufferSize);
+    DuplicateHandleFP(SI.hStdError);
+  end
+  else
+  begin
+    SI.hStdError := SI.hStdOutput;
+    HE := HO;
+  end;
+end;
+
+function MaybeQuote(const S: String): String;
+begin
+  if (Pos(' ', S) <> 0) then
+    Result := '"' + S + '"'
+  else
+    Result := S;
+end;
+
+function MaybeQuoteIfNotQuoted(const S: String): String;
+begin
+  if (Pos(' ', S) <> 0) and (pos('"', S) = 0) then
+    Result := '"' + S + '"'
+  else
+    Result := S;
+end;
+
+{ TProcessUtf8 }
+
+procedure TProcessUtf8.Execute;
+var
+  I: Integer;
+  PName, PDir, PCommandLine: PWideChar;
+  FEnv: Pointer;
+  FCreationFlags: Cardinal;
+  FProcessAttributes: TSecurityAttributes;
+  FThreadAttributes: TSecurityAttributes;
+  FProcessInformation: TProcessInformation;
+  FStartupInfo: STARTUPINFO;
+  HI, HO, HE: THandle;
+  Cmd: String;
+begin
+  InheritHandles := True;
+  PName := nil;
+  PCommandLine := nil;
+  PDir := nil;
+
+  if (ApplicationName = '') and (CommandLine = '') and (Executable = '') then
+    raise EProcess.Create(SNoCommandline);
+  if (ApplicationName <> '') then
+  begin
+    PName := PWideChar(UTF8Decode(ApplicationName));
+    PCommandLine := PWideChar(UTF8Decode(CommandLine));
+  end
+  else if (CommandLine <> '') then
+    PCommandLine := PWideChar(UTF8Decode(CommandLine))
+  else if (Executable <> '') then
+  begin
+    Cmd := MaybeQuoteIfNotQuoted(Executable);
+    for I := 0 to Parameters.Count - 1 do
+      Cmd := Cmd + ' ' + MaybeQuoteIfNotQuoted(Parameters[I]);
+    PCommandLine := PWideChar(UTF8Decode(Cmd));
+  end;
+  if CurrentDirectory <> '' then
+    PDir := PWideChar(UTF8Decode(CurrentDirectory));
+  if Environment.Count <> 0 then
+    FEnv := StringsToPWideChars(Environment)
+  else
+    FEnv := nil;
+  try
+    FCreationFlags := GetCreationFlags(Self);
+    InitProcessAttributes(Self, FProcessAttributes);
+    InitThreadAttributes(Self, FThreadAttributes);
+    InitStartupInfo(Self, FStartUpInfo);
+    if poUsePipes in Options then
+      CreatePipes(HI, HO, HE, FStartupInfo, not (poStdErrToOutPut in Options),
+        PipeBufferSize);
+    try
+      if not CreateProcessW(PName, PCommandLine, @FProcessAttributes,
+        @FThreadAttributes, InheritHandles, FCreationFlags, FEnv,
+        PDir, FStartupInfo, FProcessInformation) then
+        raise EProcess.CreateFmt(SErrCannotExecute, [CommandLine, GetLastError]);
+      PHandle(@ProcessHandle)^ := FProcessInformation.hProcess;
+      PHandle(@ThreadHandle)^ := FProcessInformation.hThread;
+      PInteger(@ProcessID)^ := FProcessINformation.dwProcessID;
+    finally
+      if poUsePipes in Options then
+      begin
+        FileClose(FStartupInfo.hStdInput);
+        FileClose(FStartupInfo.hStdOutput);
+        if not (poStdErrToOutPut in Options) then
+          FileClose(FStartupInfo.hStdError);
+        CreateStreams(HI, HO, HE);
+      end;
+    end;
+    FRunning := True;
+  finally
+    if FEnv <> nil then
+      FreeMem(FEnv);
+  end;
+  if not (csDesigning in ComponentState) and // This would hang the IDE !
+    (poWaitOnExit in Options) and not (poRunSuspended in Options) then
+    WaitOnExit;
+end;
+
+{$ENDIF}
+
+end.
+

components/doublecmd/doublecmd_common.lpk

@@ -1,4 +1,4 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <Package Version="4">
     <PathDelim Value="\"/>
@@ -40,8 +40,8 @@ end"/>
     </CompilerOptions>
     <Description Value="Common units for Double Commander"/>
     <License Value="GNU GPL 2"/>
-    <Version Minor="3"/>
-    <Files Count="8">
+    <Version Minor="3" Release="1"/>
+    <Files Count="9">
       <Item1>
         <Filename Value="dcclassesutf8.pas"/>
         <UnitName Value="DCClassesUtf8"/>
@@ -74,6 +74,10 @@ end"/>
         <Filename Value="dcxmlconfig.pas"/>
         <UnitName Value="DCXmlConfig"/>
       </Item8>
+      <Item9>
+        <Filename Value="dcprocessutf8.pas"/>
+        <UnitName Value="DCProcessUtf8"/>
+      </Item9>
     </Files>
     <RequiredPkgs Count="2">
       <Item1>

components/doublecmd/doublecmd_common.pas

@@ -8,7 +8,7 @@ interface
 
 uses
   DCClassesUtf8, DCOSUtils, DCStrUtils, DCBasicTypes, DCFileAttributes, 
-  DCConvertEncoding, DCDateTimeUtils, DCXmlConfig;
+  DCConvertEncoding, DCDateTimeUtils, DCXmlConfig, DCProcessUtf8;
 
 implementation