Check-in [813ffc57df]

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

Overview
Comment:Added menu item for key, showing either the wizard's name and version, or the name and version of the VCS. Also extended the expiry time for repo information to 15 seconds.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 813ffc57df2013fd257e5315e7e68b2e119fb24a
User & Date: tinus 2015-11-21 01:11:14
Context
2015-11-21
01:11
Tried moving the version number to a central option set. Added version info. check-in: deb518e572 user: tinus tags: trunk
01:11
Added menu item for key, showing either the wizard's name and version, or the name and version of the VCS. Also extended the expiry time for repo information to 15 seconds. check-in: 813ffc57df user: tinus tags: trunk
00:35
Added info button showing the current VCS's icon, which drops down the color key when clicked. check-in: d70d29a14f user: tinus tags: trunk
Changes

Changes to src/VCSInfoMenuWzrd.pas.

68
69
70
71
72
73
74

75
76
77
78
79
80
81
...
362
363
364
365
366
367
368





































369
370
371
372
373
374
375
...
471
472
473
474
475
476
477

478
479
480
481
482
483
484
485
486
487
488


489
490
491
492
493
494
495
...
580
581
582
583
584
585
586
587

588
589
590
591
592
593
594
...
599
600
601
602
603
604
605
606
















































607
608
609
610
611
612
613
....
1060
1061
1062
1063
1064
1065
1066


1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
      procedure actBranchUpdate(Sender: TObject);
      procedure actBranchMenuPopup(Sender: TObject);
      procedure actBranchMenuClick(Sender: TObject);
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(Sender: TObject);
      procedure actInfoExecute(Sender: TObject);
      procedure actInfoUpdate(Sender: TObject);

  end;

procedure Register;

implementation
uses
  System.SysUtils, System.UITypes, System.Classes, System.StrUtils,
................................................................................
                                            nil,
                                            PChar(ACurrentDir),
                                            SUI, ProcInfo);
  except
    Result := False;
  end;
end {CreateProcess};






































{ ================================================================================================ }
{ TVCSInfoWizard }

{ ------------------------------------------------------------------------------------------------ }
constructor TVCSInfoWizard.Create;
var
................................................................................

  Button := Services.AddToolButton(FToolbar.Name, 'btnLegend', actInfo) as TToolButton;
  Button.Style := tbsButton;
  Button.DropdownMenu := TPopupMenu.Create(Button);
  Button.DropdownMenu.AutoHotkeys := maManual;
  Button.DropdownMenu.AutoPopup := True;
  Button.DropdownMenu.Items.SubMenuImages := Services.ImageList;


  AddButtonMenuItem(Button, FImgUnknown,  'Unknown or error');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgSyncNone, 'Nothing to sync');
  AddButtonMenuItem(Button, FImgSyncPull, 'Incoming changesets (pull)');
  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');




  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
  actSync.ImageIndex := FImgUnknown;
................................................................................
      end;
      NewHint := 'No repository';
    end;

    if (actBranch.ImageIndex <> NewImageIndex)
        or (actBranch.Caption <> NewCaption)
        or (actBranch.Hint <> NewHint)
        or (actBranch.Enabled <> NewEnabled) then begin

      actBranch.Enabled := NewEnabled;
      actBranch.ImageIndex := NewImageIndex;
      actBranch.Caption := NewCaption;
      actBranch.Hint := NewHint;

      FToolbar.Invalidate;
      LogMessage('actBranchUpdate: IsRepo=%d, In=%d, Out=%d; Img=%d, Caption="%s", Hint="%s"',
................................................................................
      LogMessage('actBranchUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actInfoExecute(Sender: TObject);
begin
  // TODO?
















































end;

procedure TVCSInfoWizard.actInfoUpdate(Sender: TObject);
var
  actInfo: TAction;
  Repo: TRepoInfo;
  NewImageIndex: integer;
................................................................................
  end else begin
    Result := Default(TRepoInfo);
  end;
end {TVCSInfoWizard.GetProjectRepo};

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean): TRepoInfo;


var
  FilePath, FinalFilePath, RootPath, FinalRootPath: string;
  Lines: TStringList;
  Line: string;
  iRes: Cardinal;
begin
  Result := Default(TRepoInfo);
  if not Assigned(FRepos) then
    FRepos := TDictionary<string,TRepoInfo>.Create;

  FilePath := ExtractFileDir(AFileName);
  FinalFilePath := GetFinalPathName(FilePath);
  if AForceUpdate or (not FRepos.TryGetValue(FinalFilePath, Result)) or (Now - Result.LastUpdated > 5 / SecsPerDay) then begin
    iRes := ExecuteCmd('hg -yq root', RootPath, False, nil, FilePath);
    if iRes >= 255 then begin
      Lines := TStringList.Create;
      try
        Lines.NameValueSeparator := ':';
        iRes := ExecuteCmd('fossil info', Lines.Append, False, nil, FilePath);
        if iRes <> 0 then begin
          Result.Root := FilePath;
          Result.LastUpdated := Now;
          FinalRootPath := FinalFilePath;
        end else begin
          RootPath := Lines.Values['local-root'].Trim.Replace('/', PathDelim, [rfReplaceAll]);
          FinalRootPath := GetFinalPathName(RootPath);
          if AForceUpdate or (not FRepos.TryGetValue(FinalRootPath, Result)) or (Now - Result.LastUpdated > 5 / SecsPerDay) then begin
            Result.Root := RootPath;
            Result.RepoType := 'fossil';

            Lines.Clear;
            iRes := ExecuteCmd('fossil branch list', Lines.Append, False, nil, FilePath);
            if iRes = 0 then begin
              for Line in Lines do







>







 







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







 







>











>
>







 







|
>







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>












|













|







68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
...
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
...
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
...
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
...
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
....
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
      procedure actBranchUpdate(Sender: TObject);
      procedure actBranchMenuPopup(Sender: TObject);
      procedure actBranchMenuClick(Sender: TObject);
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(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,
................................................................................
                                            nil,
                                            PChar(ACurrentDir),
                                            SUI, ProcInfo);
  except
    Result := False;
  end;
end {CreateProcess};

// http://stackoverflow.com/a/1720501/3092116
function GetCurrentVersion(): string;
var
  verblock: PVSFixedFileInfo;
  versionMS, versionLS: cardinal;
  verlen: cardinal;
  rs: TResourceStream;
  m: TMemoryStream;
  p: pointer;
  s: cardinal;
begin
  m := TMemoryStream.Create;
  try
    rs := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
    try
      m.CopyFrom(rs, rs.Size);
    finally
      rs.Free;
    end;
    m.Position := 0;
    if VerQueryValue(m.Memory, '\', pointer(verblock), verlen) then begin
      VersionMS := verblock.dwFileVersionMS;
      VersionLS := verblock.dwFileVersionLS;
      Result := IntToStr(versionMS shr 16) + '.' +
                IntToStr(versionMS and $FFFF) + '.' +
                IntToStr(VersionLS shr 16) + '.' +
                IntToStr(VersionLS and $FFFF);
    end;
    if VerQueryValue(m.Memory, PChar('\\StringFileInfo\\' +
      IntToHex(GetThreadLocale,4) + IntToHex(GetACP,4) + '\\FileDescription'), p, s) or
        VerQueryValue(m.Memory, '\\StringFileInfo\\040904E4\\FileDescription', p, s) then //en-us
          Result := PChar(p) + ' ' + Result;
  finally
    m.Free;
  end;
end;

{ ================================================================================================ }
{ TVCSInfoWizard }

{ ------------------------------------------------------------------------------------------------ }
constructor TVCSInfoWizard.Create;
var
................................................................................

  Button := Services.AddToolButton(FToolbar.Name, 'btnLegend', actInfo) as TToolButton;
  Button.Style := tbsButton;
  Button.DropdownMenu := TPopupMenu.Create(Button);
  Button.DropdownMenu.AutoHotkeys := maManual;
  Button.DropdownMenu.AutoPopup := True;
  Button.DropdownMenu.Items.SubMenuImages := Services.ImageList;
  Button.DropdownMenu.OnPopup := actInfoMenuPopUp;

  AddButtonMenuItem(Button, FImgUnknown,  'Unknown or error');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgSyncNone, 'Nothing to sync');
  AddButtonMenuItem(Button, FImgSyncPull, 'Incoming changesets (pull)');
  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);


  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
  actSync.ImageIndex := FImgUnknown;
................................................................................
      end;
      NewHint := 'No repository';
    end;

    if (actBranch.ImageIndex <> NewImageIndex)
        or (actBranch.Caption <> NewCaption)
        or (actBranch.Hint <> NewHint)
        or (actBranch.Enabled <> NewEnabled) then
    begin
      actBranch.Enabled := NewEnabled;
      actBranch.ImageIndex := NewImageIndex;
      actBranch.Caption := NewCaption;
      actBranch.Hint := NewHint;

      FToolbar.Invalidate;
      LogMessage('actBranchUpdate: IsRepo=%d, In=%d, Out=%d; Img=%d, Caption="%s", Hint="%s"',
................................................................................
      LogMessage('actBranchUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actInfoExecute(Sender: TObject);
begin
  // nothing; just drop down the menu
end;

procedure TVCSInfoWizard.actInfoMenuPopup(Sender: TObject);
var
  Menu: TPopupMenu;
  Item: TMenuItem;
  Button: TToolButton;
  Lines: TStringList;
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;
          Lines := TStringList.Create;
          try
            ExecuteCmd('thg version', Lines.Append);
            if Lines.Count > 0 then
              Item.Caption := Lines[0];
          finally
            Lines.Free;
          end;
        end;
        1: begin // fossil
          Item.ImageIndex := FImgFossil;
          Lines := TStringList.Create;
          try
            ExecuteCmd('fossil version', Lines.Append);
            if Lines.Count > 0 then
              Item.Caption := Lines[0].Replace('This is ', '');
          finally
            Lines.Free;
          end;
        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;
................................................................................
  end else begin
    Result := Default(TRepoInfo);
  end;
end {TVCSInfoWizard.GetProjectRepo};

{ ------------------------------------------------------------------------------------------------ }
function TVCSInfoWizard.GetRepoInfo(const AFileName: string; const AForceUpdate: Boolean): TRepoInfo;
const
  cRefreshSeconds = 15;
var
  FilePath, FinalFilePath, RootPath, FinalRootPath: string;
  Lines: TStringList;
  Line: string;
  iRes: Cardinal;
begin
  Result := Default(TRepoInfo);
  if not Assigned(FRepos) then
    FRepos := TDictionary<string,TRepoInfo>.Create;

  FilePath := ExtractFileDir(AFileName);
  FinalFilePath := GetFinalPathName(FilePath);
  if AForceUpdate or (not FRepos.TryGetValue(FinalFilePath, Result)) or (Now - Result.LastUpdated > cRefreshSeconds / SecsPerDay) then begin
    iRes := ExecuteCmd('hg -yq root', RootPath, False, nil, FilePath);
    if iRes >= 255 then begin
      Lines := TStringList.Create;
      try
        Lines.NameValueSeparator := ':';
        iRes := ExecuteCmd('fossil info', Lines.Append, False, nil, FilePath);
        if iRes <> 0 then begin
          Result.Root := FilePath;
          Result.LastUpdated := Now;
          FinalRootPath := FinalFilePath;
        end else begin
          RootPath := Lines.Values['local-root'].Trim.Replace('/', PathDelim, [rfReplaceAll]);
          FinalRootPath := GetFinalPathName(RootPath);
          if AForceUpdate or (not FRepos.TryGetValue(FinalRootPath, Result)) or (Now - Result.LastUpdated > cRefreshSeconds / SecsPerDay) then begin
            Result.Root := RootPath;
            Result.RepoType := 'fossil';

            Lines.Clear;
            iRes := ExecuteCmd('fossil branch list', Lines.Append, False, nil, FilePath);
            if iRes = 0 then begin
              for Line in Lines do