ADDED src/Cache.pas Index: src/Cache.pas ================================================================== --- /dev/null +++ src/Cache.pas @@ -0,0 +1,99 @@ +unit Cache; + +//////////////////////////////////////////////////////////////////////////////////////////////////// +interface +uses + System.Generics.Collections; + +type + TCache = class + private + FRoots: TDictionary; + FInfos: TDictionary; + public + constructor Create; + destructor Destroy; override; + + function GetAssociatedRoot(const Dir: string): string; + procedure SetAssociatedRoot(const Dir, RootDir: string); + function GetInfo(const RootDir: string; out Repo: T): Boolean; + procedure SetInfo(const RootDir: string; const Info: T); + end; + + +//////////////////////////////////////////////////////////////////////////////////////////////////// +implementation +uses + u_FinalPathName; + +const + cLockTimeout = 1000; + +{ TCache } + +constructor TCache.Create; +begin + FRoots := TDictionary.Create; + FInfos := TDictionary.Create; +end; + +destructor TCache.Destroy; +begin + FRoots.Free; + FInfos.Free; + inherited; +end; + +function TCache.GetInfo(const RootDir: string; out Repo: T): Boolean; +begin + Result := TMonitor.Enter(FInfos, cLockTimeout); + if Result then + try + Result := FInfos.TryGetValue(RootDir, Repo) or FInfos.TryGetValue(GetFinalPathName(RootDir), Repo); + finally + TMonitor.Exit(FInfos); + end; +end; + +function TCache.GetAssociatedRoot(const Dir: string): string; +begin + if TMonitor.Enter(FRoots, cLockTimeout) then begin + try + if not (FRoots.TryGetValue(Dir, Result) or FRoots.TryGetValue(GetFinalPathName(Dir), Result)) then + Result := ''; + finally + TMonitor.Exit(FRoots); + end; + end else begin + Result := ''; + end; +end; + +procedure TCache.SetInfo(const RootDir: string; const Info: T); +begin + TMonitor.Enter(FInfos); + try + FInfos.AddOrSetValue(GetFinalPathName(RootDir), Info); + finally + TMonitor.Exit(FInfos); + end; +end; + +procedure TCache.SetAssociatedRoot(const Dir, RootDir: string); +var + FinalDir: string; +begin + TMonitor.Enter(FRoots); + try + FinalDir := GetFinalPathName(Dir); + if RootDir = '' then begin + FRoots.Remove(FinalDir); + end else begin + FRoots.AddOrSetValue(GetFinalPathName(Dir), RootDir); + end; + finally + TMonitor.Exit(FRoots); + end; +end; + +end. Index: src/Delphi10/VCSInfo.dproj ================================================================== --- src/Delphi10/VCSInfo.dproj +++ src/Delphi10/VCSInfo.dproj @@ -68,10 +68,11 @@ false false All true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) true VCSInfo .\$(Platform)\$(Config) .\$(Platform)\$(Config) false Index: src/DelphiXE5/VCSInfo.dpk ================================================================== --- src/DelphiXE5/VCSInfo.dpk +++ src/DelphiXE5/VCSInfo.dpk @@ -31,8 +31,10 @@ rtl, designide; contains VCSInfoMenuWzrd in '..\VCSInfoMenuWzrd.pas', - u_FinalPathName; + u_FinalPathName, + u_VersionInfo in '..\u_VersionInfo.pas', + Cache in '..\Cache.pas'; end. Index: src/DelphiXE5/VCSInfo.dproj ================================================================== --- src/DelphiXE5/VCSInfo.dproj +++ src/DelphiXE5/VCSInfo.dproj @@ -64,22 +64,19 @@ ..;$(DCC_UnitSearchPath) false false All true - System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) true VCSInfo .\$(Platform)\$(Config) .\$(Platform)\$(Config) false false false false false - true - 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 1033 ..\Version.optset rtl;$(DCC_UsePackage) @@ -110,10 +107,15 @@ true true true + 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 + 0 + true + true + 1 false false RELEASE;$(DCC_Define) @@ -125,10 +127,12 @@ MainSource + + Cfg_2 Base Index: src/VCSInfoMenuWzrd.pas ================================================================== --- src/VCSInfoMenuWzrd.pas +++ src/VCSInfoMenuWzrd.pas @@ -21,10 +21,11 @@ // TODO: implement IOTAEditorNotifier and/or IOTAIDENotifier so we know which file is active TVCSInfoWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard) private FRepos: TDictionary; + FCurrentVersion: string; FToolbar: TToolBar; FPluginAbout: Integer; FButtonSync: TToolButton; @@ -86,27 +87,35 @@ implementation uses System.SysUtils, System.UITypes, System.Classes, System.StrUtils, Winapi.Windows, Winapi.ShellAPI, Vcl.Forms, Vcl.Dialogs, Vcl.Graphics, - u_FinalPathName; + u_FinalPathName, u_VersionInfo; const scMenuIDString = 'net.2of4.VCSInfoWizard'; cLimit = 9; +type + TRefreshTrigger = (trgCode, trgUser, trgFileSaved, trgFileSwitched, trgTimer); + TRefreshTask = record + Trigger: TRefreshTrigger; + FileName: string; + end; + TRefreshTaskQueue = class(TThreadedQueue); + { ------------------------------------------------------------------------------------------------ } procedure Register; begin RegisterPackageWizard(TVCSInfoWizard.Create); (* TODO: create multiple separate menu wizards: - pull (incoming) / push (outgoing) *) end; - {$REGION 'Functions to execute command-line and capture output'} + //--- JclBase and JclSysUtils -------------------------------------------------- const // line delimiters for a version of Delphi/C++Builder NativeLineFeed = Char(#10); NativeCarriageReturn = Char(#13); @@ -375,46 +384,10 @@ except Result := False; end; end {CreateProcess}; -function GetCurrentVersion(): string; -// http://stackoverflow.com/a/1720501/3092116 -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 } { ------------------------------------------------------------------------------------------------ } @@ -496,10 +469,27 @@ begin LogMessage(StringOfChar('-', 80)); Services := ToolsAPI.BorlandIDEServices as INTAServices; + LogMessage('Inserting about box...'); + with TFileVersionInfo.Create(HInstance) do begin + try + FCurrentVersion := Trim(FileDescription + ' ' + FileVersionText); + + AboutBox := ToolsAPI.BorlandIDEServices as IOTAAboutBoxServices; + FPluginAbout := AboutBox.AddPluginInfo(FCurrentVersion, + FCurrentVersion + sLineBreak + + sLineBreak + + '© ' + CompanyName + ' - ' + Comments, + 0); + finally + Free; + end; + end; + + LogMessage('Creating toolbar'); Toolbar := nil; Services.ReadToolbar(Application.MainForm, Application.MainForm.FindChildControl('Controlbar1') as TWinControl, scToolbarName, Toolbar); if not (Toolbar is TToolBar) then begin FToolbar := Services.NewToolbar(scToolbarName, 'Repository'); FToolbar.AutoSize := True; @@ -553,11 +543,11 @@ 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); + AddButtonMenuItem(Button, FImgIcon, FCurrentVersion, actInfoMenuVCSClick); LogMessage('Creating sync button...'); actSync := TAction.Create(FToolbar); actSync.Caption := 'Nothing to sync'; @@ -610,16 +600,10 @@ FToolbar.Visible := True; end; // Services.ToolbarModified(FToolbar); FToolbar.Invalidate; - LogMessage('Inserting about box...'); - AboutBox := ToolsAPI.BorlandIDEServices as IOTAAboutBoxServices; - FPluginAbout := AboutBox.AddPluginInfo(GetCurrentVersion, GetCurrentVersion + sLineBreak + - sLineBreak + - '© Martijn Coppoolse - http://fossil.2of4.net/vcsInfo', - 0); end {TVCSInfoWizard.Create}; { ------------------------------------------------------------------------------------------------ } destructor TVCSInfoWizard.Destroy; var Services: INTAServices; @@ -712,11 +696,11 @@ ExecuteCmd('fossil version', Output); if Output <> '' then Item.Caption := Output.Replace('This is f', 'F').TrimRight; end; else begin - Item.Caption := GetCurrentVersion; + Item.Caption := FCurrentVersion; end; end; end; except on E: Exception do begin @@ -889,11 +873,15 @@ NewImageIndex := FImgClean; NewHint := 'Working directory is clean'; end else begin NewImageIndex := FImgPending; - NewHint := Format('%d file(s) pending', [Repo.Pending]); + if Repo.Pending = 1 then begin + NewHint := Format('%d file pending', [Repo.Pending]); + end else begin + NewHint := Format('%d files pending', [Repo.Pending]); + end; end; end; end else begin NewImageIndex := -1; // FImgNeutral; NewHint := 'No repository'; ADDED src/u_VersionInfo.pas Index: src/u_VersionInfo.pas ================================================================== --- /dev/null +++ src/u_VersionInfo.pas @@ -0,0 +1,387 @@ +unit u_VersionInfo; + +interface + +uses + Windows, SysUtils, System.Classes; + +type + TVersion = packed record + class operator Implicit(Text: string): TVersion; + class operator Implicit(Version: TVersion): string; + class operator Equal(A, B: TVersion): boolean; inline; + class operator NotEqual(A, B: TVersion): boolean; inline; + class operator GreaterThan(A, B: TVersion): boolean; inline; + class operator GreaterThanOrEqual(A, B: TVersion): boolean; inline; + class operator LessThan(A, B: TVersion): boolean; inline; + class operator LessThanOrEqual(A, B: TVersion): boolean; inline; + function CompareTo(const Other: TVersion): integer; + case Integer of + 0: ( + Major: Word; + Minor: Word; + Revision: Word; + Build: Word; + ); + 1: ( + Values: packed array[0..3] of Word; + ); + end; + +type + TFileVersionInfo = class + {$SCOPEDENUMS ON} + type + TFlag = (Debug, PreRelease, Patched, PrivateBuild, SpecialBuild); + TFlags = set of TFlag; + strict private const + cFlags: array[TFlag] of Cardinal = (VS_FF_DEBUG, + VS_FF_PRERELEASE, + VS_FF_PATCHED, + VS_FF_PRIVATEBUILD, + VS_FF_SPECIALBUILD); + type + TFileType = (Unknown = VFT_UNKNOWN, + Application = VFT_APP, + DLL = VFT_DLL, + Driver = VFT_DRV, + Font = VFT_FONT, + VirtualDevice = VFT_VXD, + StaticLib = VFT_STATIC_LIB); + TFileSubtype = (Unknown = VFT2_UNKNOWN, + PrinterPrinter = VFT2_DRV_PRINTER, + KeyboardDriver = VFT2_DRV_KEYBOARD, + LanguageDriver = VFT2_DRV_LANGUAGE, + DisplayDriver = VFT2_DRV_DISPLAY, + MouseDriver = VFT2_DRV_MOUSE, + NetworkDriver = VFT2_DRV_NETWORK, + SystemDriver = VFT2_DRV_SYSTEM, + InstallableDriver = VFT2_DRV_INSTALLABLE, + SoundDriver = VFT2_DRV_SOUND, + CommunicationsDriver = VFT2_DRV_COMM, + RasterFont = VFT2_FONT_RASTER, + VectorFont = VFT2_FONT_VECTOR, + TrueTypeFont = VFT2_FONT_TRUETYPE); + {$SCOPEDENUMS OFF} + strict private type + TLangAndCP = record + wLanguage : word; + wCodePage : word; + end; + PLangAndCP = ^TLangAndCP; + private + { Private declarations } + FBufferStream : TMemoryStream; + FBufferPtr : Pointer; + FFilename : string; + FHasVersionInfo : boolean; + FLang : PLangAndCP; + + FCompanyName : string; + FFileDescription : string; + FFileVersionText : string; + FInternalname : string; + FLegalCopyright : string; + FLegalTradeMarks : string; + FOriginalFilename : string; + FProductName : string; + FProductVersionText : string; + FComments : string; + FSpecialBuild : string; + FPrivateBuild : string; + FFileVersion : TVersion; + FProductVersion : TVersion; + FFlags : cardinal; + FFileType : TFileType; + FFileSubtype : TFileSubtype; + + procedure Clear; + procedure ReadVersionInfoFromFile(const AFileName: string); + procedure ReadVersionInfoFromModule(const AInstance: THandle); + procedure ReadVersionInfo(const ABuffer: Pointer); + + procedure SetFileName(const AFileName: string); + function QueryValue(const AName: string): string; + function GetFlags: TFlags; + protected + { Protected declarations } + public + { Public declarations } + constructor Create(const AFileName: string); overload; + constructor Create(const AInstance: THandle); overload; + destructor Destroy; override; + + property FileName : string read FFileName write SetFileName; + property HasVersionInfo : boolean read FHasVersionInfo; + property Flags : TFlags read GetFlags; + property FileType : TFileType read FFileType; + property FileSubtype : TFileSubtype read FFileSubtype; + + { Published declarations } + property CompanyName : string read FCompanyName; + property FileDescription : string read FFileDescription; + property FileVersion : TVersion read FFileVersion; + property FileVersionText : string read FFileVersionText; + property InternalName : string read FInternalname; + property LegalCopyright : string read FLegalCopyright; + property LegalTradeMarks : string read FLegalTradeMarks; + property OriginalFilename : string read FOriginalFilename; + property ProductName : string read FProductName; + property ProductVersion : TVersion read FProductVersion; + property ProductVersionText : string read FProductVersionText; + property Comments : string read FComments; + + property Value[const Name: string]: string read QueryValue; + end; + +implementation + +constructor TFileVersionInfo.Create(const AFileName: string); +begin + inherited Create; + SetFileName(AFileName); +end; + +constructor TFileVersionInfo.Create(const AInstance: THandle); +begin + inherited Create; + ReadVersionInfoFromModule(AInstance); +end; + +destructor TFileVersionInfo.Destroy; +begin + Clear; + inherited Destroy; +end; + +procedure TFileVersionInfo.Clear; +begin + FFilename := ''; + FCompanyname := ''; + FFileDescription := ''; + FFileVersionText := ''; + FInternalname := ''; + FLegalCopyright := ''; + FLegalTradeMarks := ''; + FOriginalFilename := ''; + FProductName := ''; + FProductVersionText := ''; + FComments := ''; + FSpecialBuild := ''; + FPrivateBuild := ''; + FFileVersion := Default(TVersion); + FProductVersion := Default(TVersion); + FFlags := 0; + if FBufferStream <> nil then begin + FBufferStream.Free; + FBufferStream := nil; + end else if FBufferPtr <> nil then begin + FreeMem(FBufferPtr); + end; + FBufferPtr := nil; +end; + +procedure TFileVersionInfo.ReadVersionInfoFromFile(const AFileName: string); +var + Dummy : cardinal; + BufferSize: integer; +begin + Clear; + FFilename := AFileName; + + BufferSize := GetFileVersionInfoSize(PChar(AFileName), Dummy); + FHasVersionInfo := (Buffersize > 0); + if FHasVersionInfo then begin + FBufferPtr := AllocMem(BufferSize); + FHasVersionInfo := GetFileVersionInfo(PChar(AFileName), 0, BufferSize, FBufferPtr); + if FHasVersionInfo then begin + ReadVersionInfo(FBufferPtr); + end else begin + FreeMem(FBufferPtr, BufferSize); + FBufferPtr := nil; + end; + end; +end; + +procedure TFileVersionInfo.ReadVersionInfoFromModule(const AInstance: THandle); +var + RS: TResourceStream; + BufferSize, ResultSize: Cardinal; +begin + Clear; + // Inspired by http://stackoverflow.com/a/1720501/3092116 + FBufferStream := TMemoryStream.Create; + try + RS := TResourceStream.CreateFromID(AInstance, 1, RT_VERSION); + try + FBufferStream.CopyFrom(RS, RS.Size); + finally + RS.Free; + end; + FBufferStream.Position := 0; + FBufferPtr := FBufferStream.Memory; + ReadVersionInfo(FBufferPtr); + except + FBufferStream.Free; + FBufferStream := nil; + end; + + // also try to determine the filename of the given instance + BufferSize := MAX_PATH; + repeat + FFilename := StringOfChar(#0, BufferSize); + ResultSize := GetModuleFileName(AInstance, PChar(FFilename), BufferSize); + SetLength(FFilename, ResultSize); + BufferSize := BufferSize * 2; + until (ResultSize < BufferSize) or (GetLastError <> ERROR_INSUFFICIENT_BUFFER); +end; + +procedure TFileVersionInfo.ReadVersionInfo(const ABuffer: Pointer); + { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - } + function ReadVersion(const MS, LS: Cardinal): TVersion; inline; + begin + Result.Major := MS shr 16; + Result.Minor := MS and 65535; + Result.Revision := LS shr 16; + Result.Build := LS and 65535; + end; + { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - } +var + Dummy : cardinal; + SubBlock : string; + InfoPtr : Pointer; + InfoBlock : TVSFixedFileInfo; +begin + SubBlock := '\\VarFileInfo\\Translation'; + VerQueryValue(ABuffer, PChar(SubBlock), Pointer(FLang), Dummy); + + FCompanyName := QueryValue('CompanyName'); + FFileDescription := QueryValue('FileDescription'); + FFileVersionText := QueryValue('FileVersion'); + FInternalName := QueryValue('InternalName'); + FLegalCopyright := QueryValue('LegalCopyright'); + FLegalTradeMarks := QueryValue('LegalTradeMarks'); + FOriginalFilename := QueryValue('OriginalFilename'); + FProductName := QueryValue('ProductName'); + FProductVersionText := QueryValue('ProductVersion'); + FComments := QueryValue('Comments'); + FSpecialBuild := QueryValue('SpecialBuild'); + FPrivateBuild := QueryValue('PrivateBuild'); + + VerQueryValue(ABuffer, '\', InfoPtr, Dummy); + Move(InfoPtr^, InfoBlock, SizeOf(InfoBlock)); + FFileVersion := ReadVersion(InfoBlock.dwFileVersionMS, InfoBlock.dwFileVersionLS); + FProductVersion := ReadVersion(InfoBlock.dwProductVersionMS, InfoBlock.dwProductVersionLS); + FFlags := InfoBlock.dwFileFlags and InfoBlock.dwFileFlagsMask; + FFileType := TFileType(InfoBlock.dwFileType); + FFileSubtype := TFileSubtype(InfoBlock.dwFileSubtype); +end; + +function TFileVersionInfo.QueryValue(const AName: string): string; +var + SubBlock : string; + Dummy : cardinal; + Value : PChar; +begin + SubBlock := Format('\\StringFileInfo\\%.4x%.4x\\%s', [GetThreadLocale, GetACP, AName]); + if VerQueryValue(FBufferPtr, PChar(SubBlock), Pointer(Value), Dummy) then begin + Result := string(Value); + end else begin + SubBlock := Format('\\StringFileInfo\\%.4x%.4x\\%s', [FLang.wLanguage, FLang.wCodePage, AName]); + VerQueryValue(FBufferPtr, PChar(SubBlock), Pointer(Value), Dummy); + Result := string(Value); + end; +end; + +procedure TFileVersionInfo.SetFileName(const AFileName: string); +begin + ReadVersionInfoFromFile(AFileName); +end {TFileVersionInfo.SetFileName}; + +function TFileVersionInfo.GetFlags: TFlags; +var + Flag: TFlag; +begin + Result := []; + for Flag := Low(cFlags) to High(cFlags) do begin + if (FFlags and cFlags[Flag]) <> 0 then begin + Include(Result, Flag); + end; + end; +end; + + +{ TVersion } + +class operator TVersion.Implicit(Text: string): TVersion; +var + vi, ci: Integer; + Value: Cardinal; + Index: Integer; +begin + Result := Default(TVersion); + vi := Low(Result.Values); + ci := 1; + while (ci <= Length(Text)) and (vi <= High(Result.Values)) do begin + Val(Copy(Text, ci), Value, Index); + if Index = 0 then begin // the entire remainder of the string is a valid integer + Result.Values[vi] := Value; + Break; + end else if Index > 1 then begin // we have an integer, followed by something non-integer + Result.Values[vi] := Value; + Inc(vi); + end; + ci := ci + Index; + end; +end; + +class operator TVersion.Implicit(Version: TVersion): string; +begin + Result := Format('%d.%d.%d.%d', [Version.Major, Version.Minor, Version.Revision, Version.Build]); +end; + +function TVersion.CompareTo(const Other: TVersion): integer; +var + i: Integer; +begin + for i := Low(Values) to High(Values) do begin + if Values[i] < Other.Values[i] then + Exit(-1) + else if Values[i] > Other.Values[i] then + Exit(1); + end; + Result := 0; +end; + +class operator TVersion.Equal(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) = 0; +end; + +class operator TVersion.GreaterThan(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) > 0; +end; + +class operator TVersion.GreaterThanOrEqual(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) >= 0; +end; + +class operator TVersion.LessThan(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) < 0; +end; + +class operator TVersion.LessThanOrEqual(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) <= 0; +end; + +class operator TVersion.NotEqual(A, B: TVersion): boolean; +begin + Result := A.CompareTo(B) <> 0; +end; + +end. +