RAD Studio VCS Info
Check-in [a512ab16be]
Login
HomeTimelineBranchesTagsTicketsWiki

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

Overview
Comment:Clicking on the VCS info menu item now opens a terminal in the current file's directory, and runs the VCS tool. Sync changesets are now limited to 9; if there are more, indicate this with a + sign.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a512ab16be630ffd1ee9bee145ecb626d5f8ad12
User & Date: tinus 2015-11-25 21:42:41
Context
2015-11-26
13:56
Perform different command depending on the status. If files have changed, show the changes (and the possibility to commit), if not, show the repository. check-in: 22aaec8852 user: tinus tags: trunk
2015-11-25
21:49
Merged in changes from trunk. check-in: a2497f0938 user: tinus tags: feature/async-refresh
21:42
Clicking on the VCS info menu item now opens a terminal in the current file's directory, and runs the VCS tool. Sync changesets are now limited to 9; if there are more, indicate this with a + sign. check-in: a512ab16be user: tinus tags: trunk
19:17
Minor code optimizations. check-in: 9c85a796dd user: tinus tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to src/Delphi10/VCSInfo.dproj. 

62
63
64
65
66
67
68


69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84

85
86
87
88
89
90
91
...
131
132
133
134
135
136
137




138
139
140
141
142
143
144
...
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
...
519
520
521
522
523
524
525
526









527
528
529
530
531
532
533

    <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
        <Cfg_2>true</Cfg_2>
        <CfgParent>Base</CfgParent>
        <Base>true</Base>
    </PropertyGroup>
    <Import Project="..\Version.optset" Condition="'$(Base)'!='' And Exists('..\Version.optset')"/>
    <PropertyGroup Condition="'$(Base)'!=''">


        <DCC_CBuilderOutput>All</DCC_CBuilderOutput>
        <GenPackage>true</GenPackage>
        <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace>
        <GenDll>true</GenDll>
        <SanitizedProjectName>VCSInfo</SanitizedProjectName>
        <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput>
        <DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
        <DCC_E>false</DCC_E>
        <DCC_N>false</DCC_N>
        <DCC_S>false</DCC_S>
        <DCC_F>false</DCC_F>
        <DCC_K>false</DCC_K>
        <CfgDependentOn>..\Version.optset</CfgDependentOn>
        <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
        <VerInfo_Keys>CompanyName=Martijn Coppoolse;FileDescription=VCS Info;FileVersion=0.1.0.0;InternalName=VCSInfo;LegalCopyright=;LegalTrademarks=;OriginalFilename=VCSInfo.bpl;ProductName=VCS Info;ProductVersion=1.0;Comments=http://fossil.2of4.net/vcsInfo</VerInfo_Keys>
        <VerInfo_Locale>1033</VerInfo_Locale>

    </PropertyGroup>
    <PropertyGroup Condition="'$(Base_Android)'!=''">
        <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars>
        <DCC_UsePackage>rtl;$(DCC_UsePackage)</DCC_UsePackage>
        <DCC_CBuilderOutput>None</DCC_CBuilderOutput>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''">
................................................................................
        <DCC_DebugDCUs>true</DCC_DebugDCUs>
        <DCC_Optimize>false</DCC_Optimize>
        <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
        <DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
        <DCC_RemoteDebug>true</DCC_RemoteDebug>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">




        <DCC_RemoteDebug>false</DCC_RemoteDebug>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Cfg_2)'!=''">
        <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
        <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
        <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
        <DCC_DebugInformation>0</DCC_DebugInformation>
................................................................................
                </DeployFile>
                <DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\15.0\Bpl\VCSInfo.bpl" Configuration="Debug" Class="ProjectOutput">
                    <Platform Name="Win32">
                        <RemoteName>VCSInfo.bpl</RemoteName>
                        <Overwrite>true</Overwrite>
                    </Platform>
                </DeployFile>
                <DeployClass Name="DependencyModule">
                    <Platform Name="Win32">
                        <Operation>0</Operation>
                        <Extensions>.dll;.bpl</Extensions>
                    </Platform>
                    <Platform Name="OSX32">
                        <Operation>1</Operation>
                        <Extensions>.dylib</Extensions>
                    </Platform>
                </DeployClass>
                <DeployClass Name="ProjectOSXResource">
                    <Platform Name="OSX32">
                        <RemoteDir>Contents\Resources</RemoteDir>
                        <Operation>1</Operation>
                    </Platform>
                </DeployClass>
                <DeployClass Name="AndroidClassesDexFile">
................................................................................
                </DeployClass>
                <DeployClass Name="Android_LauncherIcon36">
                    <Platform Name="Android">
                        <RemoteDir>res\drawable-ldpi</RemoteDir>
                        <Operation>1</Operation>
                    </Platform>
                </DeployClass>
                <DeployClass Name="ProjectiOSDeviceResourceRules"/>









                <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/>
                <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/>
                <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/>








>
>


<









<
<
<

>







 







>
>
>
>







 







|
<
<
<
<
<
<
<
<
<







 







|
>
>
>
>
>
>
>
>
>








62
63
64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81



82
83
84
85
86
87
88
89
90
...
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
...
199
200
201
202
203
204
205
206









207
208
209
210
211
212
213
...
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

    <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
        <Cfg_2>true</Cfg_2>
        <CfgParent>Base</CfgParent>
        <Base>true</Base>
    </PropertyGroup>
    <Import Project="..\Version.optset" Condition="'$(Base)'!='' And Exists('..\Version.optset')"/>
    <PropertyGroup Condition="'$(Base)'!=''">
        <DCC_UNIT_PLATFORM>false</DCC_UNIT_PLATFORM>
        <DCC_SYMBOL_PLATFORM>false</DCC_SYMBOL_PLATFORM>
        <DCC_CBuilderOutput>All</DCC_CBuilderOutput>
        <GenPackage>true</GenPackage>

        <GenDll>true</GenDll>
        <SanitizedProjectName>VCSInfo</SanitizedProjectName>
        <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput>
        <DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
        <DCC_E>false</DCC_E>
        <DCC_N>false</DCC_N>
        <DCC_S>false</DCC_S>
        <DCC_F>false</DCC_F>
        <DCC_K>false</DCC_K>



        <VerInfo_Locale>1033</VerInfo_Locale>
        <CfgDependentOn>..\Version.optset</CfgDependentOn>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Base_Android)'!=''">
        <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars>
        <DCC_UsePackage>rtl;$(DCC_UsePackage)</DCC_UsePackage>
        <DCC_CBuilderOutput>None</DCC_CBuilderOutput>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''">
................................................................................
        <DCC_DebugDCUs>true</DCC_DebugDCUs>
        <DCC_Optimize>false</DCC_Optimize>
        <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
        <DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
        <DCC_RemoteDebug>true</DCC_RemoteDebug>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
        <VerInfo_MajorVer>0</VerInfo_MajorVer>
        <VerInfo_PreRelease>true</VerInfo_PreRelease>
        <VerInfo_DLL>true</VerInfo_DLL>
        <VerInfo_MinorVer>1</VerInfo_MinorVer>
        <DCC_RemoteDebug>false</DCC_RemoteDebug>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Cfg_2)'!=''">
        <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
        <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
        <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
        <DCC_DebugInformation>0</DCC_DebugInformation>
................................................................................
                </DeployFile>
                <DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\15.0\Bpl\VCSInfo.bpl" Configuration="Debug" Class="ProjectOutput">
                    <Platform Name="Win32">
                        <RemoteName>VCSInfo.bpl</RemoteName>
                        <Overwrite>true</Overwrite>
                    </Platform>
                </DeployFile>
                <DeployClass Name="ProjectiOSDeviceResourceRules"/>









                <DeployClass Name="ProjectOSXResource">
                    <Platform Name="OSX32">
                        <RemoteDir>Contents\Resources</RemoteDir>
                        <Operation>1</Operation>
                    </Platform>
                </DeployClass>
                <DeployClass Name="AndroidClassesDexFile">
................................................................................
                </DeployClass>
                <DeployClass Name="Android_LauncherIcon36">
                    <Platform Name="Android">
                        <RemoteDir>res\drawable-ldpi</RemoteDir>
                        <Operation>1</Operation>
                    </Platform>
                </DeployClass>
                <DeployClass Name="DependencyModule">
                    <Platform Name="Win32">
                        <Operation>0</Operation>
                        <Extensions>.dll;.bpl</Extensions>
                    </Platform>
                    <Platform Name="OSX32">
                        <Operation>1</Operation>
                        <Extensions>.dylib</Extensions>
                    </Platform>
                </DeployClass>
                <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/>
                <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/>
                <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/>
                <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/>

Changes to src/VCSInfoMenuWzrd.pas. 

40
41
42
43
44
45
46

47
48
49
50
51
52
53
54
55
56
..
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
...
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362

363
364

365
366
367
368
369
370
371
...
465
466
467
468
469
470
471
472

473
474
475
476

477
478
479
480
481
482
483
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
...
692
693
694
695
696
697
698
699

700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735

736
737
738
739
740
741
742
...
753
754
755
756
757
758
759















760
761
762
763
764
765
766
...
953
954
955
956
957
958
959



960

961
962
963
964
965
966



967

968
969



970

971
972
973
974
975
976
977
....
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
....
1190
1191
1192
1193
1194
1195
1196
























1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
....
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360

      FImgSyncPull: integer;
      FImgSyncPush: integer;
      FImgSyncBoth: integer;
      FImgClean: integer;
      FImgPending: integer;
      FImgExtra: integer;


      function GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean = False): TRepoInfo;
      function GetProjectRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo; overload;
      function GetProjectRepo(const AForceUpdate: Boolean = False): TRepoInfo; overload; inline;
      function GetActiveFileRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo; overload;
      function GetActiveFileRepo(const AForceUpdate: Boolean = False): TRepoInfo; overload; inline;

      procedure LogMessage(const Text: string); overload;
      procedure LogMessage(const Text: string; const Args: array of const); overload;

      procedure RefreshSyncStatus(const actSync: TAction);
................................................................................
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(Sender: TObject);
      procedure actStatusExecute(Sender: TObject);
      procedure actStatusUpdate(Sender: TObject);
      procedure actInfoExecute(Sender: TObject);
      procedure actInfoUpdate(Sender: TObject);
      procedure actInfoMenuPopup(Sender: TObject);

  end;

procedure Register;

implementation
uses
  System.SysUtils, System.UITypes, System.Classes, System.StrUtils,
  Winapi.Windows, Winapi.ShellAPI,
  Vcl.Forms, Vcl.Dialogs, Vcl.Graphics,
  u_FinalPathName;

const
  scMenuIDString = 'net.2of4.VCSInfoWizard';


{ ------------------------------------------------------------------------------------------------ }
procedure Register;
begin
  RegisterPackageWizard(TVCSInfoWizard.Create);
  (* TODO: create multiple separate menu wizards:
    - pull (incoming) / push (outgoing)
................................................................................
  Dummy := '';
  Result := InternalExecute(CommandLine, Dummy, OutputLineCallback, RawOutput, AbortPtr, CurrentDir);
end;

{$ENDREGION}

{ ------------------------------------------------------------------------------------------------ }
function CreateProcess(const ACommand: string; const ACurrentDir: string = ''): boolean;
var
  SUI: TStartupInfo;
  Command: string;
  ProcInfo: TProcessInformation;
begin
  try
    SUI := Default(TStartupInfo);
    SUI.cb := SizeOf(SUI);

    SUI.dwFlags := STARTF_USESHOWWINDOW;
    SUI.wShowWindow := SW_MINIMIZE;

    Command := ACommand;
    UniqueString(Command);
    Result := Winapi.Windows.CreateProcess(nil, PChar(Command), nil, nil, False,
                                            CREATE_UNICODE_ENVIRONMENT,
                                            nil,
                                            PChar(ACurrentDir),
                                            SUI, ProcInfo);
................................................................................
    finally
      Icon.Free;
    end;
    if ShouldDestroy then
      DestroyIcon(IconHandle);
  end {AddExeIcon};
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  function AddButtonMenuItem(const Button: TToolButton; ImageIndex: integer; Caption: string): TMenuItem;

  begin
    Result := TMenuItem.Create(Button.DropdownMenu);
    Result.Caption := Caption;
    Result.ImageIndex := ImageIndex;

    Button.DropdownMenu.Items.Add(Result);
  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
const
  scToolbarName = 'tlbVCSInfo';
var
  Toolbar: TWinControl;
................................................................................
  AddButtonMenuItem(Button, FImgSyncPush, 'Outgoing changesets (push)');
  AddButtonMenuItem(Button, FImgSyncBoth, 'Incoming and outgoing changesets');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgClean,    'Working dir is clean');
  AddButtonMenuItem(Button, FImgPending,  'Working dir has changes');
  AddButtonMenuItem(Button, FImgExtra,    'Working dir has untracked files');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgIcon,     GetCurrentVersion);


  LogMessage('Creating sync button...');
  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
................................................................................
  Output: string;
begin
  try
    Menu := Sender as TPopupMenu;
    if Menu.Owner is TToolButton then begin
      Item := Menu.Items.Items[Menu.Items.Count - 1];
      Button := TToolButton(Menu.Owner);
      case IndexStr(Button.Hint, ['Mercurial', 'Fossil']) of

        0: begin // hg
          Item.ImageIndex := FImgMercurial;
          ExecuteCmd('thg version', Output);
          if Output <> '' then
            Item.Caption := Output.Split([#13#10, #10, #13], 1, TStringSplitOptions.ExcludeEmpty)[0];
        end;
        1: begin // fossil
          Item.ImageIndex := FImgFossil;
          ExecuteCmd('fossil version', Output);
          if Output <> '' then
            Item.Caption := Output.Replace('This is f', 'F').TrimRight;
        end;
        else begin
          Item.ImageIndex := FImgIcon;
          Item.Caption := GetCurrentVersion;
        end;
      end{case};
    end;
  except
    on E: Exception do begin
      LogMessage('actInfoMenuPopUp raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actInfoUpdate(Sender: TObject);
var
  actInfo: TAction;
  Repo: TRepoInfo;
  NewImageIndex: integer;
  NewCaption: string;
begin
  try
    actInfo := Sender as TAction;
    Repo := GetActiveFileRepo;
    case IndexStr(Repo.RepoType, ['hg', 'fossil']) of

      0: begin
        NewImageIndex := FImgMercurial;
        NewCaption := 'Mercurial';
      end;
      1: begin
        NewImageIndex := FImgFossil;
        NewCaption := 'Fossil';
................................................................................
    end;
  except
    on E: Exception do begin
      LogMessage('actInfoUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;
















procedure TVCSInfoWizard.actBranchExecute(Sender: TObject);
var
  P: TPoint;
begin
  with FButtonBranch.BoundsRect do
    P := FButtonBranch.Parent.ClientToScreen(Point(Left, Bottom));
................................................................................
  if Repo.IsRepo then begin
    if Repo.Incoming = 0 then begin
      NewImageIndex := FImgSyncNone;
      if Repo.Outgoing = 0 then begin
        NewCaption := 'Nothing to sync';
      end else if Repo.Outgoing > 0 then begin
        NewImageIndex := FImgSyncPush;



        NewCaption := Format('%d push(es)', [Repo.Outgoing]);

      end else begin // Repo.Outgoing < 0
        NewImageIndex := FImgUnknown;
        NewCaption := 'No pulls, pushes unknown';
      end;
    end else if Repo.Incoming > 0 then begin
      NewImageIndex := FImgSyncPull;



      NewCaption := Format('%d pull(s)', [Repo.Incoming]);

      if Repo.Outgoing > 0 then begin
        NewImageIndex := FImgSyncBoth;



        NewCaption := Format('%s, %d push(es)', [NewCaption, Repo.Outgoing]);

      end else if Repo.Outgoing < 0 then begin
        NewCaption := Format('%s, pushes unknown', [NewCaption]);
      end;
    end else begin // Repo.Incoming < 0
      NewImageIndex := FImgUnknown;
      NewCaption := 'Pulls unknown';
      if Repo.Outgoing = 0 then begin
................................................................................

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetState: TWizardState;
var
  Repo: TRepoInfo;
begin
  Result := [];
  Repo := GetProjectRepo;
  // wsEnabled if the current module is located inside a working directory
  if Repo.IsRepo then begin
    Include(Result, wsEnabled);
    // wsChecked if the current module has incoming or outgoing changes
    if (Repo.Incoming + Repo.Outgoing > 0) then begin
      Include(Result, wsChecked);
    end;
................................................................................
end;

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetName: string;
begin
  Result := scMenuIDString;
end;

























function TVCSInfoWizard.GetActiveFileRepo(const AForceUpdate: Boolean): TRepoInfo;
var
  FileName: string;
begin
  Result := GetActiveFileRepo(AForceUpdate, FileName);
end;

function TVCSInfoWizard.GetActiveFileRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo;
var
  Modules: IOTAModuleServices;
  Module: IOTAModule;
  Editor: IOTAEditor;
begin
  if Supports(ToolsAPI.BorlandIDEServices, IOTAModuleServices, {out}Modules) then begin
    Module := Modules.CurrentModule;
    if Assigned(Module) then begin
      Editor := Module.CurrentEditor;
      if Assigned(Editor) then
        AFileName := Editor.FileName;
    end;
    if FileExists(AFileName) then begin
      Result := GetRepoInfo(AFileName, AForceUpdate);
    end else begin
      Result := GetProjectRepo(AForceUpdate, {out}AFileName);
    end;
  end else begin
    Result := Default(TRepoInfo);
  end;
end {TVCSInfoWizard.GetActiveFileRepo};

function TVCSInfoWizard.GetProjectRepo(const AForceUpdate: Boolean): TRepoInfo;
var
  FileName: string;
begin
  Result := GetProjectRepo(AForceUpdate, FileName);
end;

function TVCSInfoWizard.GetProjectRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo;
var
  Project: IOTAProject;
begin
  Project := ToolsAPI.GetActiveProject;
  if Assigned(Project) then begin
    AFileName := Project.FileName;
    Result := GetRepoInfo(AFileName, AForceUpdate);
  end else begin
    Result := Default(TRepoInfo);
  end;
end {TVCSInfoWizard.GetProjectRepo};

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean): TRepoInfo;
const
  cRefreshSeconds = 10;
var
  FilePath, FinalFilePath, RootPath, FinalRootPath: string;
  Lines: TStringList;
  Line: string;
................................................................................
          if iRes = 0 then begin
            Result.Pending := Lines.Count;
          end else begin
            Result.Pending := -1;
          end;

          Lines.Clear;
          iRes := ExecuteCmd('hg -yq incoming --newest-first --template "{rev}\t{node|short}\t{node}\t{parents}\t{date|isodatesec}\t{author}\t{branches}\t{desc|firstline}\t{tags}\n"',
                             Lines.Append, False, nil, FilePath);
          if iRes < 255 then begin
            Result.Incoming := Lines.Count;
          end else begin
            Result.Incoming := -1;
          end;

          Lines.Clear;
          iRes := ExecuteCmd('hg -yq outgoing --newest-first --template "{rev}\t{node}\t{parents}\t{date|isodatesec}\t{author}\t{branches}\t{desc|firstline}\t{tags}.\n"',
                             Lines.Append, False, nil, FilePath);
          if iRes < 255 then begin
            Result.Outgoing := Lines.Count;
          end else begin
            Result.Outgoing := -1;
          end;
        finally








>

<
<







 







>













>







 







|








>
|
|
>







 







|
>




>







 







|







 







|
>

<





<





<


|






|











|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
|
>






>
>
>
|
>


>
>
>
|
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









<
<
<
<

<
<
<
<
<
|
<
|
|
<
<
<





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|








|








40
41
42
43
44
45
46
47
48


49
50
51
52
53
54
55
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
...
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
...
697
698
699
700
701
702
703
704
705
706

707
708
709
710
711

712
713
714
715
716

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
...
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
...
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
....
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
....
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260




1261





1262

1263
1264



1265
1266
1267
1268
1269





















1270
1271
1272
1273
1274
1275
1276
....
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381

      FImgSyncPull: integer;
      FImgSyncPush: integer;
      FImgSyncBoth: integer;
      FImgClean: integer;
      FImgPending: integer;
      FImgExtra: integer;

      function GetActiveFileName: string;
      function GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean = False): TRepoInfo;


      function GetActiveFileRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo; overload;
      function GetActiveFileRepo(const AForceUpdate: Boolean = False): TRepoInfo; overload; inline;

      procedure LogMessage(const Text: string); overload;
      procedure LogMessage(const Text: string; const Args: array of const); overload;

      procedure RefreshSyncStatus(const actSync: TAction);
................................................................................
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(Sender: TObject);
      procedure actStatusExecute(Sender: TObject);
      procedure actStatusUpdate(Sender: TObject);
      procedure actInfoExecute(Sender: TObject);
      procedure actInfoUpdate(Sender: TObject);
      procedure actInfoMenuPopup(Sender: TObject);
      procedure actInfoMenuVCSClick(Sender: TObject);
  end;

procedure Register;

implementation
uses
  System.SysUtils, System.UITypes, System.Classes, System.StrUtils,
  Winapi.Windows, Winapi.ShellAPI,
  Vcl.Forms, Vcl.Dialogs, Vcl.Graphics,
  u_FinalPathName;

const
  scMenuIDString = 'net.2of4.VCSInfoWizard';
  cLimit = 9;

{ ------------------------------------------------------------------------------------------------ }
procedure Register;
begin
  RegisterPackageWizard(TVCSInfoWizard.Create);
  (* TODO: create multiple separate menu wizards:
    - pull (incoming) / push (outgoing)
................................................................................
  Dummy := '';
  Result := InternalExecute(CommandLine, Dummy, OutputLineCallback, RawOutput, AbortPtr, CurrentDir);
end;

{$ENDREGION}

{ ------------------------------------------------------------------------------------------------ }
function CreateProcess(const ACommand: string; const ACurrentDir: string = ''; const AShow: boolean = False): boolean;
var
  SUI: TStartupInfo;
  Command: string;
  ProcInfo: TProcessInformation;
begin
  try
    SUI := Default(TStartupInfo);
    SUI.cb := SizeOf(SUI);
    if not AShow then begin
      SUI.dwFlags := STARTF_USESHOWWINDOW;
      SUI.wShowWindow := SW_MINIMIZE;
    end;
    Command := ACommand;
    UniqueString(Command);
    Result := Winapi.Windows.CreateProcess(nil, PChar(Command), nil, nil, False,
                                            CREATE_UNICODE_ENVIRONMENT,
                                            nil,
                                            PChar(ACurrentDir),
                                            SUI, ProcInfo);
................................................................................
    finally
      Icon.Free;
    end;
    if ShouldDestroy then
      DestroyIcon(IconHandle);
  end {AddExeIcon};
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  function AddButtonMenuItem(const Button: TToolButton; ImageIndex: integer; Caption: string;
                             const OnClick: TNotifyEvent = nil): TMenuItem;
  begin
    Result := TMenuItem.Create(Button.DropdownMenu);
    Result.Caption := Caption;
    Result.ImageIndex := ImageIndex;
    Result.OnClick := OnClick;
    Button.DropdownMenu.Items.Add(Result);
  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
const
  scToolbarName = 'tlbVCSInfo';
var
  Toolbar: TWinControl;
................................................................................
  AddButtonMenuItem(Button, FImgSyncPush, 'Outgoing changesets (push)');
  AddButtonMenuItem(Button, FImgSyncBoth, 'Incoming and outgoing changesets');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgClean,    'Working dir is clean');
  AddButtonMenuItem(Button, FImgPending,  'Working dir has changes');
  AddButtonMenuItem(Button, FImgExtra,    'Working dir has untracked files');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgIcon,     GetCurrentVersion, actInfoMenuVCSClick);


  LogMessage('Creating sync button...');
  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
................................................................................
  Output: string;
begin
  try
    Menu := Sender as TPopupMenu;
    if Menu.Owner is TToolButton then begin
      Item := Menu.Items.Items[Menu.Items.Count - 1];
      Button := TToolButton(Menu.Owner);
      Item.ImageIndex := Button.ImageIndex;
      case Button.Action.Tag of
        0: begin // hg

          ExecuteCmd('thg version', Output);
          if Output <> '' then
            Item.Caption := Output.Split([#13#10, #10, #13], 1, TStringSplitOptions.ExcludeEmpty)[0];
        end;
        1: begin // fossil

          ExecuteCmd('fossil version', Output);
          if Output <> '' then
            Item.Caption := Output.Replace('This is f', 'F').TrimRight;
        end;
        else begin

          Item.Caption := GetCurrentVersion;
        end;
      end;
    end;
  except
    on E: Exception do begin
      LogMessage('actInfoMenuPopUp raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end {TVCSInfoWizard.actInfoMenuPopup};

procedure TVCSInfoWizard.actInfoUpdate(Sender: TObject);
var
  actInfo: TAction;
  Repo: TRepoInfo;
  NewImageIndex: integer;
  NewCaption: string;
begin
  try
    actInfo := Sender as TAction;
    Repo := GetActiveFileRepo;
    actInfo.Tag := IndexStr(Repo.RepoType, ['hg', 'fossil']);
    case actInfo.Tag of
      0: begin
        NewImageIndex := FImgMercurial;
        NewCaption := 'Mercurial';
      end;
      1: begin
        NewImageIndex := FImgFossil;
        NewCaption := 'Fossil';
................................................................................
    end;
  except
    on E: Exception do begin
      LogMessage('actInfoUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actInfoMenuVCSClick(Sender: TObject);
var
  Dir: string;
begin
  Dir := ExtractFileDir(GetActiveFileName);
  case (((Sender as TMenuItem).Owner as TComponent).Owner as TToolButton).Action.Tag of
    0: begin // hg
      CreateProcess('cmd.exe /k hg', Dir, True);
    end;
    1: begin // fossil
      CreateProcess('cmd.exe /k fossil', Dir, True);
    end;
  end;
end;

procedure TVCSInfoWizard.actBranchExecute(Sender: TObject);
var
  P: TPoint;
begin
  with FButtonBranch.BoundsRect do
    P := FButtonBranch.Parent.ClientToScreen(Point(Left, Bottom));
................................................................................
  if Repo.IsRepo then begin
    if Repo.Incoming = 0 then begin
      NewImageIndex := FImgSyncNone;
      if Repo.Outgoing = 0 then begin
        NewCaption := 'Nothing to sync';
      end else if Repo.Outgoing > 0 then begin
        NewImageIndex := FImgSyncPush;
        if Repo.Outgoing = cLimit then begin
          NewCaption := Format('%d+ push(es)', [Repo.Outgoing]);
        end else begin
          NewCaption := Format('%d push(es)', [Repo.Outgoing]);
        end;
      end else begin // Repo.Outgoing < 0
        NewImageIndex := FImgUnknown;
        NewCaption := 'No pulls, pushes unknown';
      end;
    end else if Repo.Incoming > 0 then begin
      NewImageIndex := FImgSyncPull;
      if Repo.Incoming = cLimit then begin
        NewCaption := Format('%d+ pull(s)', [Repo.Incoming]);
      end else begin
        NewCaption := Format('%d pull(s)', [Repo.Incoming]);
      end;
      if Repo.Outgoing > 0 then begin
        NewImageIndex := FImgSyncBoth;
        if Repo.Outgoing = cLimit then begin
          NewCaption := Format('%s, %d+ push(es)', [NewCaption, Repo.Outgoing]);
        end else begin
          NewCaption := Format('%s, %d push(es)', [NewCaption, Repo.Outgoing]);
        end;
      end else if Repo.Outgoing < 0 then begin
        NewCaption := Format('%s, pushes unknown', [NewCaption]);
      end;
    end else begin // Repo.Incoming < 0
      NewImageIndex := FImgUnknown;
      NewCaption := 'Pulls unknown';
      if Repo.Outgoing = 0 then begin
................................................................................

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetState: TWizardState;
var
  Repo: TRepoInfo;
begin
  Result := [];
  Repo := GetActiveFileRepo;
  // wsEnabled if the current module is located inside a working directory
  if Repo.IsRepo then begin
    Include(Result, wsEnabled);
    // wsChecked if the current module has incoming or outgoing changes
    if (Repo.Incoming + Repo.Outgoing > 0) then begin
      Include(Result, wsChecked);
    end;
................................................................................
end;

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetName: string;
begin
  Result := scMenuIDString;
end;

function TVCSInfoWizard.GetActiveFileName: string;
var
  Modules: IOTAModuleServices;
  Module: IOTAModule;
  Editor: IOTAEditor;
  Project: IOTAProject;
begin
  Result := '';
  Modules := ToolsAPI.BorlandIDEServices as IOTAModuleServices;
  Module := Modules.CurrentModule;
  if Assigned(Module) then begin
    Editor := Module.CurrentEditor;
    if Assigned(Editor) then
      Result := Editor.FileName
    else
      Result := Module.FileName;
  end;
  if Result = '' then begin
    Project := ToolsAPI.GetActiveProject;
    if Assigned(Project) then
      Result := Project.FileName;
  end;
end {GetActiveFileName};

function TVCSInfoWizard.GetActiveFileRepo(const AForceUpdate: Boolean): TRepoInfo;
var
  FileName: string;
begin
  Result := GetActiveFileRepo(AForceUpdate, FileName);
end;

function TVCSInfoWizard.GetActiveFileRepo(const AForceUpdate: Boolean; out AFileName: string): TRepoInfo;




begin





  AFileName := GetActiveFileName;

  if FileExists(AFileName) then begin
    Result := GetRepoInfo(AFileName, AForceUpdate);



  end else begin
    Result := Default(TRepoInfo);
  end;
end {TVCSInfoWizard.GetActiveFileRepo};






















function TVCSInfoWizard.GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean): TRepoInfo;
const
  cRefreshSeconds = 10;
var
  FilePath, FinalFilePath, RootPath, FinalRootPath: string;
  Lines: TStringList;
  Line: string;
................................................................................
          if iRes = 0 then begin
            Result.Pending := Lines.Count;
          end else begin
            Result.Pending := -1;
          end;

          Lines.Clear;
          iRes := ExecuteCmd('hg -yq incoming --newest-first --template "{rev}\n" --limit ' + IntToStr(cLimit),
                             Lines.Append, False, nil, FilePath);
          if iRes < 255 then begin
            Result.Incoming := Lines.Count;
          end else begin
            Result.Incoming := -1;
          end;

          Lines.Clear;
          iRes := ExecuteCmd('hg -yq outgoing --newest-first --template "{rev}\n" --limit ' + IntToStr(cLimit),
                             Lines.Append, False, nil, FilePath);
          if iRes < 255 then begin
            Result.Outgoing := Lines.Count;
          end else begin
            Result.Outgoing := -1;
          end;
        finally

Powered by Fossil · RSS · Site map