Check-in [20d7dd8edd]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added console running code to TVCSClient.
Timelines: family | ancestors | descendants | both | feature/rewrite-multi-async
Files: files | file ages | folders
SHA1: 20d7dd8eddae669743f3ddf47bfedf035d9058fc
User & Date: tinus 2016-02-22 18:34:25
Context
2016-02-22
18:50
Run commands in the repo root by default. Implemented Fossil.GetBranches. check-in: c92164b9f9 user: tinus tags: feature/rewrite-multi-async
18:34
Added console running code to TVCSClient. check-in: 20d7dd8edd user: tinus tags: feature/rewrite-multi-async
2016-02-21
15:22
Added scaffolding for VCS client interface. check-in: 083aa4a165 user: tinus tags: feature/rewrite-multi-async
Changes

Changes to src/vcsinfo.VCSClient.pas.

     3      3   interface
     4      4   uses
     5      5     System.SysUtils, System.Generics.Collections;
     6      6   
     7      7   type
     8      8     EVCSException = class(Exception);
     9      9   
           10  +type
           11  +  // e.g. TStrings.Append
           12  +  TTextHandler = procedure(const Text: string) of object;
           13  +
    10     14   type
    11     15     TVCSClient = class;
    12     16     TVCSClientClass = class of TVCSClient;
    13     17   
    14     18     TVCSClient = class
    15     19     public
    16     20       class function CreateForPath(const APath: string): TVCSClient;
    17     21       class function IsRepo(const APath: string; out ARootPath: string): boolean; virtual; abstract;
    18     22       class procedure RegisterVCSClass(const VCSClass: TVCSClientClass);
    19     23     strict private
    20     24       class var FRegisteredVCSes: TList<TVCSClientClass>;
           25  +  strict private
           26  +    function InternalExecute(CommandLine: string; var Output: string;
           27  +      OutputLineCallback: TTextHandler; RawOutput: Boolean; AbortPtr: PBoolean;
           28  +      const CurrentDir: string): Cardinal;
           29  +    function MuteCRTerminatedLines(const RawOutput: string): string;
    21     30     strict protected
    22     31       FRoot: string;
    23     32   
           33  +    function ExecuteCmd(const CommandLine: string;
           34  +                        OutputLineCallback: TTextHandler;
           35  +                        RawOutput: Boolean = False;
           36  +                        AbortPtr: PBoolean = nil;
           37  +                        const CurrentDir: string = ''): Cardinal; overload;
           38  +    function ExecuteCmd(const CommandLine: string;
           39  +                        var Output: string;
           40  +                        RawOutput: Boolean = False;
           41  +                        AbortPtr: PBoolean = nil;
           42  +                        const CurrentDir: string = ''): Cardinal; overload;
           43  +
    24     44       function  GetExecutable: string; virtual; abstract;
    25     45       function  GetUIExecutable: string; virtual; abstract;
    26     46       function  GetTitle: string; virtual;
    27     47       function  GetCurrentBranch: string; virtual;
    28     48     public
    29     49       constructor Create(const APath: string);
    30     50       destructor  Destroy; override;
................................................................................
    52     72   
    53     73       property CurrentBranch: string  read GetCurrentBranch;
    54     74     end;
    55     75   
    56     76   
    57     77   implementation
    58     78   
           79  +uses
           80  +  Winapi.Windows;
           81  +
    59     82   { TVCSClient }
    60     83   
    61     84   constructor TVCSClient.Create(const APath: string);
    62     85   begin
    63     86   
    64     87   end;
    65     88   
................................................................................
    82    105       Result := '';
    83    106   end;
    84    107   
    85    108   function TVCSClient.GetTitle: string;
    86    109   begin
    87    110     Result := ExtractFileName(ExcludeTrailingPathDelimiter(FRoot));
    88    111   end;
          112  +
          113  +{$REGION 'Functions to execute command-line and capture output'}
          114  +//--- JclBase and JclSysUtils --------------------------------------------------
          115  +const
          116  +  // line delimiters for a version of Delphi/C++Builder
          117  +  NativeLineFeed       = Char(#10);
          118  +  NativeCarriageReturn = Char(#13);
          119  +
          120  +function CharIsReturn(const C: Char): Boolean;
          121  +begin
          122  +  Result := (C = NativeLineFeed) or (C = NativeCarriageReturn);
          123  +end;
          124  +
          125  +// memory initialization
          126  +procedure ResetMemory(out P; Size: Longint);
          127  +begin
          128  +  if Size > 0 then
          129  +  begin
          130  +    Byte(P) := 0;
          131  +    FillChar(P, Size, 0);
          132  +  end;
          133  +end;
          134  +
          135  +const
          136  +  ABORT_EXIT_CODE = {$IFDEF MSWINDOWS} ERROR_CANCELLED {$ELSE} 1223 {$ENDIF};
          137  +
          138  +
          139  +function TVCSClient.MuteCRTerminatedLines(const RawOutput: string): string;
          140  +const
          141  +  Delta = 1024;
          142  +var
          143  +  BufPos, OutPos, LfPos, EndPos: Integer;
          144  +  C: Char;
          145  +begin
          146  +  SetLength(Result, Length(RawOutput));
          147  +  OutPos := 1;
          148  +  LfPos := OutPos;
          149  +  EndPos := OutPos;
          150  +  for BufPos := 1 to Length(RawOutput) do
          151  +  begin
          152  +    if OutPos >= Length(Result)-2 then
          153  +      SetLength(Result, Length(Result) + Delta);
          154  +    C := RawOutput[BufPos];
          155  +    case C of
          156  +      NativeCarriageReturn:
          157  +        OutPos := LfPos;
          158  +      NativeLineFeed:
          159  +        begin
          160  +          OutPos := EndPos;
          161  +          Result[OutPos] := NativeCarriageReturn;
          162  +          Inc(OutPos);
          163  +          Result[OutPos] := C;
          164  +          Inc(OutPos);
          165  +          EndPos := OutPos;
          166  +          LfPos := OutPos;
          167  +        end;
          168  +    else
          169  +      Result[OutPos] := C;
          170  +      Inc(OutPos);
          171  +      EndPos := OutPos;
          172  +    end;
          173  +  end;
          174  +  SetLength(Result, OutPos - 1);
          175  +end;
          176  +
          177  +function TVCSClient.InternalExecute(CommandLine: string; var Output: string; OutputLineCallback: TTextHandler;
          178  +  RawOutput: Boolean; AbortPtr: PBoolean; const CurrentDir: string): Cardinal;
          179  +
          180  +const
          181  +  BufferSize = 255;
          182  +type
          183  +  TBuffer = array [0..BufferSize] of AnsiChar;
          184  +
          185  +  procedure ProcessLine(const Line: string; LineEnd: Integer);
          186  +  begin
          187  +    if RawOutput or (Line[LineEnd] <> NativeCarriageReturn) then
          188  +    begin
          189  +      while (LineEnd > 0) and CharIsReturn(Line[LineEnd]) do
          190  +        Dec(LineEnd);
          191  +      OutputLineCallback(Copy(Line, 1, LineEnd));
          192  +    end;
          193  +  end;
          194  +
          195  +  procedure ProcessBuffer(var Buffer: TBuffer; var Line: string; PipeBytesRead: Cardinal);
          196  +  var
          197  +    CR, LF: Integer;
          198  +  begin
          199  +    Buffer[PipeBytesRead] := #0;
          200  +    Line := Line + string(Buffer);
          201  +    if Assigned(OutputLineCallback) then
          202  +    repeat
          203  +      CR := Pos(NativeCarriageReturn, Line);
          204  +      if CR = Length(Line) then
          205  +        CR := 0;        // line feed at CR + 1 might be missing
          206  +      LF := Pos(NativeLineFeed, Line);
          207  +      if (CR > 0) and ((LF > CR + 1) or (LF = 0)) then
          208  +        LF := CR;       // accept CR as line end
          209  +      if LF > 0 then
          210  +      begin
          211  +        ProcessLine(Line, LF);
          212  +        Delete(Line, 1, LF);
          213  +      end;
          214  +    until LF = 0;
          215  +  end;
          216  +
          217  +var
          218  +  Buffer: TBuffer;
          219  +  Line: string;
          220  +  PipeBytesRead: Cardinal;
          221  +{$IFDEF MSWINDOWS}
          222  +var
          223  +  StartupInfo: TStartupInfo;
          224  +  ProcessInfo: TProcessInformation;
          225  +  SecurityAttr: TSecurityAttributes;
          226  +  PipeRead, PipeWrite: THandle;
          227  +  PCurrentDir: PChar;
          228  +begin
          229  +  Result := $FFFFFFFF;
          230  +  SecurityAttr.nLength := SizeOf(SecurityAttr);
          231  +  SecurityAttr.lpSecurityDescriptor := nil;
          232  +  SecurityAttr.bInheritHandle := True;
          233  +  PipeWrite := 0;
          234  +  PipeRead := 0;
          235  +  Line := '';
          236  +  ResetMemory(Buffer, SizeOf(Buffer));
          237  +  if not CreatePipe(PipeRead, PipeWrite, @SecurityAttr, 0) then
          238  +  begin
          239  +    Result := GetLastError;
          240  +    Exit;
          241  +  end;
          242  +  ResetMemory(StartupInfo, SizeOf(TStartupInfo));
          243  +  StartupInfo.cb := SizeOf(TStartupInfo);
          244  +  StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
          245  +  StartupInfo.wShowWindow := SW_HIDE;
          246  +  StartupInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
          247  +  StartupInfo.hStdOutput := PipeWrite;
          248  +  StartupInfo.hStdError := PipeWrite;
          249  +  UniqueString(CommandLine); // CommandLine must be in a writable memory block
          250  +  ProcessInfo.dwProcessId := 0;
          251  +  try
          252  +    if CurrentDir <> '' then
          253  +      PCurrentDir := PChar(CurrentDir)
          254  +    else
          255  +      PCurrentDir := nil;
          256  +    if CreateProcess(nil, PChar(CommandLine), nil, nil, True, NORMAL_PRIORITY_CLASS,
          257  +      nil, PCurrentDir, StartupInfo, ProcessInfo) then
          258  +    begin
          259  +      CloseHandle(PipeWrite);
          260  +      PipeWrite := 0;
          261  +      if AbortPtr <> nil then
          262  +        {$IFDEF FPC}
          263  +        AbortPtr^ := 0;
          264  +        {$ELSE ~FPC}
          265  +        AbortPtr^ := False;
          266  +        {$ENDIF ~FPC}
          267  +      PipeBytesRead := 0;
          268  +      while ((AbortPtr = nil) or not LongBool(AbortPtr^)) and
          269  +        ReadFile(PipeRead, Buffer, BufferSize, PipeBytesRead, nil) and (PipeBytesRead > 0) do
          270  +        ProcessBuffer(Buffer, Line, PipeBytesRead);
          271  +      if (AbortPtr <> nil) and LongBool(AbortPtr^) then
          272  +        TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
          273  +      if (WaitForSingleObject(ProcessInfo.hProcess, INFINITE) = WAIT_OBJECT_0) and
          274  +        not GetExitCodeProcess(ProcessInfo.hProcess, Result) then
          275  +          Result := $FFFFFFFF;
          276  +      CloseHandle(ProcessInfo.hThread);
          277  +      ProcessInfo.hThread := 0;
          278  +      CloseHandle(ProcessInfo.hProcess);
          279  +      ProcessInfo.hProcess := 0;
          280  +    end
          281  +    else
          282  +    begin
          283  +      CloseHandle(PipeWrite);
          284  +      PipeWrite := 0;
          285  +    end;
          286  +    CloseHandle(PipeRead);
          287  +    PipeRead := 0;
          288  +  finally
          289  +    if PipeRead <> 0 then
          290  +      CloseHandle(PipeRead);
          291  +    if PipeWrite <> 0 then
          292  +      CloseHandle(PipeWrite);
          293  +    if ProcessInfo.hThread <> 0 then
          294  +      CloseHandle(ProcessInfo.hThread);
          295  +    if ProcessInfo.hProcess <> 0 then
          296  +    begin
          297  +      TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
          298  +      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
          299  +      GetExitCodeProcess(ProcessInfo.hProcess, Result);
          300  +      CloseHandle(ProcessInfo.hProcess);
          301  +    end;
          302  +  end;
          303  +{$ENDIF MSWINDOWS}
          304  +{$IFDEF UNIX}
          305  +var
          306  +  Pipe: PIOFile;
          307  +  Cmd: string;
          308  +begin
          309  +  Cmd := Format('%s 2>&1', [CommandLine]);
          310  +  Pipe := nil;
          311  +  try
          312  +    Pipe := Libc.popen(PChar(Cmd), 'r');
          313  +    { TODO : handle Abort }
          314  +    repeat
          315  +      PipeBytesRead := fread_unlocked(@Buffer, 1, BufferSize, Pipe);
          316  +      if PipeBytesRead > 0 then
          317  +        ProcessBuffer(Buffer, Line, PipeBytesRead);
          318  +    until PipeBytesRead = 0;
          319  +    Result := pclose(Pipe);
          320  +    Pipe := nil;
          321  +    wait(nil);
          322  +  finally
          323  +    if Pipe <> nil then
          324  +      pclose(Pipe);
          325  +    wait(nil);
          326  +  end;
          327  +{$ENDIF UNIX}
          328  +  if Line <> '' then
          329  +    if Assigned(OutputLineCallback) then
          330  +      // output wasn't terminated by a line feed...
          331  +      // (shouldn't happen, but you never know)
          332  +      ProcessLine(Line, Length(Line))
          333  +    else
          334  +      if RawOutput then
          335  +        Output := Output + Line
          336  +      else
          337  +        Output := Output + MuteCRTerminatedLines(Line);
          338  +end;
          339  +
          340  +function TVCSClient.ExecuteCmd(const CommandLine: string;
          341  +                                var Output: string;
          342  +                                RawOutput: Boolean = False;
          343  +                                AbortPtr: PBoolean = nil;
          344  +                                const CurrentDir: string = ''): Cardinal;
          345  +begin
          346  +  Result := InternalExecute(CommandLine, Output, nil, RawOutput, AbortPtr, CurrentDir);
          347  +end;
          348  +
          349  +function TVCSClient.ExecuteCmd(const CommandLine: string;
          350  +                                OutputLineCallback: TTextHandler;
          351  +                                RawOutput: Boolean = False;
          352  +                                AbortPtr: PBoolean = nil;
          353  +                                const CurrentDir: string = ''): Cardinal;
          354  +var
          355  +  Dummy: string;
          356  +begin
          357  +  Dummy := '';
          358  +  Result := InternalExecute(CommandLine, Dummy, OutputLineCallback, RawOutput, AbortPtr, CurrentDir);
          359  +end;
          360  +
          361  +{$ENDREGION}
          362  +
    89    363   
    90    364   class function TVCSClient.CreateForPath(const APath: string): TVCSClient;
    91    365   var
    92    366     VCSClass: TVCSClientClass;
    93    367     RootPath: string;
    94    368   begin
    95    369     for VCSClass in FRegisteredVCSes do begin