truncvsfrmunit.pas

CVS IDE plugin for Borland Delphi this is a good program,i like this kind of practise

(* $Id: TRunCvsFrmunit.pas,v 1.8 2003/01/08 20:14:36 turbo Exp $
 *
 * Form for executing a CVS command. Shows an animation while executing, and
 * contains the code for creating the command-line and for executing the command
 * by using the TExtProcess class
 *
 * Copyright 2001 by Thomas Bleier
 * For license details see LICENSE.txt
 *)

unit TRunCvsFrmunit;
interface
//---------------------------------------------------------------------------
uses
{$IFDEF D6UP}
  Types,
{$ENDIF}
  Windows,
  Classes,
  Controls,
  StdCtrls,
  Forms,
  ExtCtrls,
  ComCtrls;
//---------------------------------------------------------------------------
// Use this constants for the CVS commands
resourcestring
  CVSCMD_CHECKOUT = 'checkout';
resourcestring
  CVSCMD_IMPORT = 'import';
resourcestring
  CVSCMD_UPDATE = 'update';
resourcestring
  CVSCMD_COMMIT = 'commit';
resourcestring
  CVSCMD_TAG = 'tag';
resourcestring
  CVSCMD_DIFF = 'diff';
resourcestring
  CVSCMD_LOG = 'log';
resourcestring
  CVSCMD_ADD = 'add';
resourcestring
  CVSCMD_REMOVE = 'remove';
//---------------------------------------------------------------------------
type
  TRunCvsFrm = class(TForm)
    PStatusLbl: TLabel;
    PAnimate: TAnimate;
    PAbortBtn: TButton;
    procedure PAbortBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
  private
    FCommand: string;
    FArguments: TStringList;
    FGlobalOptions: TStringList;
    FCommandOptions: TStringList;
    FWorkingDirectory: string;
    FCvsBinary: string;
    FExitCode: DWORD;
    procedure SetWorkingDirectory(const Value: string);
    procedure DebugInfo(const s: string);
  protected
    FAborted: boolean;
    function CreateCmdLine: string;
    function GetArguments: TStrings; //begin return FArguments; end;
    function GetGlobalOptions: TStrings; // begin return FGlobalOptions; end;
    function GetCommandOptions: TStrings; //) begin return FCommandOptions; end;
    function GetArgumentString(stringlist: TStrings; fQuote: boolean): string;
  public // Anwender-Deklarationen
    constructor create(Owner: TComponent); override;
    destructor destroy; override;
    function Run(outputcontrol: TRichEdit): boolean;
    procedure clear;
    property Command: string read FCommand write FCommand;
    property Arguments: TStrings read getArguments;
    property GlobalOptions: TStrings read getGlobalOptions;
    property CommandOptions: TStrings read getCommandOptions;
    property WorkingDirectory: string read FWorkingDirectory write SetWorkingDirectory;
    property CvsBinary: string read FCvsBinary write FCvsBinary;
    property ExitCode: DWORD read FExitCode;
  end;
//---------------------------------------------------------------------------
//var
//  RunCvsFrm: TRunCvsFrm;
//---------------------------------------------------------------------------
implementation
{$R *.dfm}
uses
  graphics,
  sysutils,
  TExtProcessunit,
  TToolsApiHelperunit,
  Utilityunit,
  TPreferencesFrmunit,
  PELDebugit;
//---------------------------------------------------------------------------

//---------------------------------------------------------------------------

constructor TRunCvsFrm.create(Owner: TComponent);
begin
  inherited create(owner);
  FAborted := false;
  FArguments := TStringList.Create;
  FCommandOptions := TStringList.Create;
  FGlobalOptions := TStringList.Create;
  FWorkingDirectory := ExtractFilePath(ToolsApiHelper.GetMainFile);
  if (FWorkingDirectory = '') then
  begin
    FWorkingDirectory := GetCurrentDir;
  end;
end;
//---------------------------------------------------------------------------

procedure TRunCvsFrm.clear;
begin
  DebugInfo('clear');
  FAborted := false;
  FArguments.clear;
  FCommandOptions.Clear;
  FGlobalOptions.Clear;
  FWorkingDirectory := ExtractFilePath(ToolsApiHelper.GetMainFile);
  if (FWorkingDirectory = '') then
  begin
    FWorkingDirectory := GetCurrentDir;
  end;
end;

destructor TRunCvsFrm.destroy;
begin
  FArguments.Free;
  FCommandOptions.Free;
  FGlobalOptions.Free;
  inherited Destroy;
end;
//---------------------------------------------------------------------------

procedure TRunCvsFrm.FormShow(Sender: TObject);
begin
  PStatusLbl.Caption := 'Executing CVS command...';
  PAbortBtn.Enabled := true;
  PAnimate.Visible := true;
  PAnimate.Active := true;
end;
//---------------------------------------------------------------------------

procedure TRunCvsFrm.PAbortBtnClick(Sender: TObject);
begin
  FAborted := true;
  PStatusLbl.Caption := 'Aborting CVS command...';
  PAbortBtn.Enabled := false;
  PAnimate.Active := false;
  PAnimate.Visible := false;
end;
//---------------------------------------------------------------------------

function TRunCvsFrm.Run(outputcontrol: TRichEdit): boolean;
var
  cmdline: string;
  cvsprocess: TExtProcess;
  outhandle: HWND;
  waitingforabort: boolean;
begin
//  result := false;
  Show;
  try
    PreferencesFrm.ApplyPreferences(self);
    cmdline := CreateCmdLine;
    if assigned(outputcontrol) then
    begin
      outputcontrol.SelAttributes.Style := [fsBold];
      outputcontrol.Lines.Add(FWorkingDirectory + ' > ' + cmdline);
      outputcontrol.Lines.Add('');
      outputcontrol.SelAttributes.Style := [];
    end;
    outhandle := 0;
    if outputcontrol <> nil then
    begin
      outhandle := outputcontrol.Handle;
    end;
    waitingforabort := false;
    DebugInfo(Format('TRunCvsFrm.Run "%s" in %s', [cmdline, FWorkingDirectory]));
    cvsprocess := TExtProcess.create('', cmdline, FWorkingDirectory,
      epmRichText, PreferencesFrm.IsNtCvs, outhandle);
    try
      while not (cvsprocess.Done) do
      begin
        Sleep(10);
        Application.ProcessMessages;
        if FAborted and (not waitingforabort) then
        begin
          cvsprocess.Terminate;
          waitingforabort := true;
        end;
      end;
      result := cvsprocess.Executed;
      FExitCode := cvsprocess.ExitCode;
      if (outputcontrol <> nil) then
      begin
        outputcontrol.SelAttributes.Style := [fsBold];
        outputcontrol.Lines.Add('');
        outputcontrol.Lines.Add('Exit code: ' + IntToStr(ExitCode));
        outputcontrol.SelAttributes.Style := [];
      end;
    finally
      if (outputcontrol <> nil) then
      begin
      if PreferencesFrm.PLogFile.Text <> '' then
      begin
        PreferencesFrm.AddToLog(outputcontrol.Lines.Text);
      end;
      end;
//      if assigned(cvsprocess)
//       then cvsprocess.Free;
    end;
  finally
    Hide;
  end;
end;
//---------------------------------------------------------------------------

function TRunCvsFrm.CreateCmdLine: string;
begin
  if (FCvsBinary = '') then
  begin
//    char buf[MAX_PATH];
//    HMODULE mod ;
//    if ((mod := GetModuleHandle('borcvs.dll'))! := NULL &&
//      GetModuleFileName(mod , buf, sizeof(buf))! := 0 &&
//      FileExists(ExtractFilePath(string(buf)) + 'cvs.exe')) then
//    begin
//      FCvsBinary := ExtractFilePath(string(buf)) + 'cvs.exe';
//    end
//    else
//    begin
    FCvsBinary := 'cvs.exe';
//    end;
  end;
  result := GetOptQuotedString(FCvsBinary) +
    GetArgumentString(FGlobalOptions, false) + ' ' +
    FCommand + GetArgumentString(FCommandOptions, false) +
    GetArgumentString(Arguments, true);
end;
//---------------------------------------------------------------------------

function TRunCvsFrm.GetArgumentString(stringlist: TStrings; fQuote: boolean):
  string;
var
  item: string;
  i: integer;
begin
  result := '';
  for i := 0 to stringlist.Count - 1 do
  begin
    item := stringlist.Strings[i];
    if (Pos(' ', item) > 0) and fQuote then
    begin
      result := result + ' ' + GetQuotedString(item);
    end
    else
    begin
      result := result + ' ' + item;
    end;
  end;
end;
//---------------------------------------------------------------------------

procedure TRunCvsFrm.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  CanClose := false;
end;
//---------------------------------------------------------------------------

function TRunCvsFrm.GetArguments: TStrings;
begin
  result := FArguments;
end;

function TRunCvsFrm.GetCommandOptions: TStrings;
begin
  result := FCommandOptions;
end;

function TRunCvsFrm.GetGlobalOptions: TStrings;
begin
  result := FGlobalOptions;
end;

procedure TRunCvsFrm.SetWorkingDirectory(const Value: string);
begin
  DebugInfo(format('FWorkingDirectory set to :%s ', [Value]));
  FWorkingDirectory := Value;
end;

procedure TRunCvsFrm.DebugInfo(const s: string);
begin
{$IFOPT D+}
  DebugStr('in ' + self.ClassName + ' :' + s);
{$ENDIF D+}
end;

end.