Changeset 21


Ignore:
Timestamp:
Apr 3, 2025, 10:49:00 PM (8 days ago)
Author:
chronos
Message:
  • Modified: Updated Common package.
Location:
trunk
Files:
64 added
11 deleted
8 edited
1 copied
27 moved

Legend:

Unmodified
Added
Removed

  • trunk/Backends/Subversion/USubversion.pas

    r18 r21  
    66
    77uses
    8   Classes, SysUtils, UVCS, UBackend, XMLRead, DOM, UXMLUtils;
     8  Classes, SysUtils, UVCS, UBackend, XMLRead, DOM, XML;
    99
    1010type

  • trunk/Forms/UFormBrowse.pas

    r19 r21  
    77uses
    88  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
    9   ExtCtrls, Menus, ActnList, UFindFile, UVCS, Contnrs, LazFileUtils;
     9  ExtCtrls, Menus, ActnList, FindFile, UVCS, Contnrs, LazFileUtils;
    1010
    1111type

  • trunk/Packages/Common/ApplicationInfo.pas

    r20 r21  
    1 unit UApplicationInfo;
    2 
    3 {$mode delphi}
     1unit ApplicationInfo;
    42
    53interface
    64
    75uses
    8   SysUtils, Registry, Classes, Forms, URegistry;
     6  SysUtils, Classes, Forms, RegistryEx, Controls, Graphics, LCLType;
    97
    108type
    … …  
    1412  TApplicationInfo = class(TComponent)
    1513  private
     14    FDescription: TTranslateString;
     15    FIcon: TBitmap;
    1616    FIdentification: Byte;
    1717    FLicense: string;
    … …  
    3232  public
    3333    constructor Create(AOwner: TComponent); override;
     34    destructor Destroy; override;
    3435    property Version: string read GetVersion;
     36    function GetRegistryContext: TRegistryContext;
    3537  published
    3638    property Identification: Byte read FIdentification write FIdentification;
    … …  
    4547    property EmailContact: string read FEmailContact write FEmailContact;
    4648    property AppName: string read FAppName write FAppName;
     49    property Description: TTranslateString read FDescription write FDescription;
    4750    property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate;
    4851    property RegistryKey: string read FRegistryKey write FRegistryKey;
    4952    property RegistryRoot: TRegistryRoot read FRegistryRoot write FRegistryRoot;
    5053    property License: string read FLicense write FLicense;
     54    property Icon: TBitmap read FIcon write FIcon;
    5155  end;
    5256
    5357procedure Register;
    5458
     59
    5560implementation
    56                        
     61
    5762procedure Register;
    5863begin
    … …  
    7176constructor TApplicationInfo.Create(AOwner: TComponent);
    7277begin
    73   inherited Create(AOwner);
     78  inherited;
    7479  FVersionMajor := 1;
    7580  FIdentification := 1;
    … …  
    7782  FRegistryKey := '\Software\' + FAppName;
    7883  FRegistryRoot := rrKeyCurrentUser;
     84  FIcon := TBitmap.Create;
     85end;
     86
     87destructor TApplicationInfo.Destroy;
     88begin
     89  FreeAndNil(FIcon);
     90  inherited;
     91end;
     92
     93function TApplicationInfo.GetRegistryContext: TRegistryContext;
     94begin
     95  Result := TRegistryContext.Create(RegistryRoot, RegistryKey);
    7996end;
    8097

  • trunk/Packages/Common/Common.Delay.pas

    r20 r21  
    1 unit UDelay;
    2 
    3 {$mode delphi}
     1unit Common.Delay;
    42
    53interface
    … …  
    7371
    7472end.
    75 

  • trunk/Packages/Common/Common.lpk

    r19 r21  
    11<?xml version="1.0" encoding="UTF-8"?>
    22<CONFIG>
    3   <Package Version="4">
     3  <Package Version="5">
    44    <PathDelim Value="\"/>
    55    <Name Value="Common"/>
    … …  
    1111      <PathDelim Value="\"/>
    1212      <SearchPaths>
    13         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
     13        <OtherUnitFiles Value="Forms"/>
     14        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    1415      </SearchPaths>
     16      <Parsing>
     17        <SyntaxOptions>
     18          <SyntaxMode Value="Delphi"/>
     19          <CStyleOperator Value="False"/>
     20          <AllowLabel Value="False"/>
     21          <CPPInline Value="False"/>
     22        </SyntaxOptions>
     23      </Parsing>
     24      <CodeGeneration>
     25        <Optimizations>
     26          <OptimizationLevel Value="0"/>
     27        </Optimizations>
     28      </CodeGeneration>
     29      <Linking>
     30        <Debugging>
     31          <GenerateDebugInfo Value="False"/>
     32        </Debugging>
     33      </Linking>
     34      <Other>
     35        <CompilerMessages>
     36          <IgnoredMessages idx6058="True" idx5071="True" idx5024="True" idx3124="True" idx3123="True"/>
     37        </CompilerMessages>
     38      </Other>
    1539    </CompilerOptions>
    16     <Description Value="Various libraries"/>
    17     <License Value="GNU/GPL"/>
    18     <Version Minor="7"/>
    19     <Files Count="20">
     40    <Description Value="Common package with various useful units.
     41
     42Source: https://svn.zdechov.net/PascalClassLibrary/Common/"/>
     43    <License Value="Copy left."/>
     44    <Version Minor="12"/>
     45    <Files Count="40">
    2046      <Item1>
    2147        <Filename Value="StopWatch.pas"/>
    … …  
    2349      </Item1>
    2450      <Item2>
    25         <Filename Value="UCommon.pas"/>
    26         <UnitName Value="UCommon"/>
     51        <Filename Value="Common.pas"/>
     52        <UnitName Value="Common"/>
    2753      </Item2>
    2854      <Item3>
    29         <Filename Value="UDebugLog.pas"/>
    30         <HasRegisterProc Value="True"/>
    31         <UnitName Value="UDebugLog"/>
     55        <Filename Value="DebugLog.pas"/>
     56        <HasRegisterProc Value="True"/>
     57        <UnitName Value="DebugLog"/>
    3258      </Item3>
    3359      <Item4>
    34         <Filename Value="UDelay.pas"/>
    35         <UnitName Value="UDelay"/>
     60        <Filename Value="Common.Delay.pas"/>
     61        <UnitName Value="Common.Delay"/>
    3662      </Item4>
    3763      <Item5>
    38         <Filename Value="UPrefixMultiplier.pas"/>
    39         <UnitName Value="UPrefixMultiplier"/>
     64        <Filename Value="PrefixMultiplier.pas"/>
     65        <HasRegisterProc Value="True"/>
     66        <UnitName Value="PrefixMultiplier"/>
    4067      </Item5>
    4168      <Item6>
    42         <Filename Value="UURI.pas"/>
    43         <UnitName Value="UURI"/>
     69        <Filename Value="URI.pas"/>
     70        <UnitName Value="URI"/>
    4471      </Item6>
    4572      <Item7>
    46         <Filename Value="UThreading.pas"/>
    47         <UnitName Value="UThreading"/>
     73        <Filename Value="Threading.pas"/>
     74        <UnitName Value="Threading"/>
    4875      </Item7>
    4976      <Item8>
    50         <Filename Value="UMemory.pas"/>
    51         <UnitName Value="UMemory"/>
     77        <Filename Value="Memory.pas"/>
     78        <UnitName Value="Memory"/>
    5279      </Item8>
    5380      <Item9>
    54         <Filename Value="UResetableThread.pas"/>
    55         <UnitName Value="UResetableThread"/>
     81        <Filename Value="ResetableThread.pas"/>
     82        <UnitName Value="ResetableThread"/>
    5683      </Item9>
    5784      <Item10>
    58         <Filename Value="UPool.pas"/>
    59         <UnitName Value="UPool"/>
     85        <Filename Value="Pool.pas"/>
     86        <UnitName Value="Pool"/>
    6087      </Item10>
    6188      <Item11>
    62         <Filename Value="ULastOpenedList.pas"/>
    63         <HasRegisterProc Value="True"/>
    64         <UnitName Value="ULastOpenedList"/>
     89        <Filename Value="LastOpenedList.pas"/>
     90        <HasRegisterProc Value="True"/>
     91        <UnitName Value="LastOpenedList"/>
    6592      </Item11>
    6693      <Item12>
    67         <Filename Value="URegistry.pas"/>
    68         <UnitName Value="URegistry"/>
     94        <Filename Value="RegistryEx.pas"/>
     95        <UnitName Value="RegistryEx"/>
    6996      </Item12>
    7097      <Item13>
    71         <Filename Value="UJobProgressView.pas"/>
    72         <HasRegisterProc Value="True"/>
    73         <UnitName Value="UJobProgressView"/>
     98        <Filename Value="JobProgressView.pas"/>
     99        <HasRegisterProc Value="True"/>
     100        <UnitName Value="JobProgressView"/>
    74101      </Item13>
    75102      <Item14>
    76         <Filename Value="UXMLUtils.pas"/>
    77         <UnitName Value="UXMLUtils"/>
     103        <Filename Value="XML.pas"/>
     104        <UnitName Value="XML"/>
    78105      </Item14>
    79106      <Item15>
    80         <Filename Value="UApplicationInfo.pas"/>
    81         <HasRegisterProc Value="True"/>
    82         <UnitName Value="UApplicationInfo"/>
     107        <Filename Value="ApplicationInfo.pas"/>
     108        <HasRegisterProc Value="True"/>
     109        <UnitName Value="ApplicationInfo"/>
    83110      </Item15>
    84111      <Item16>
    85         <Filename Value="USyncCounter.pas"/>
    86         <UnitName Value="USyncCounter"/>
     112        <Filename Value="SyncCounter.pas"/>
     113        <UnitName Value="SyncCounter"/>
    87114      </Item16>
    88115      <Item17>
    89         <Filename Value="UListViewSort.pas"/>
    90         <HasRegisterProc Value="True"/>
    91         <UnitName Value="UListViewSort"/>
     116        <Filename Value="ListViewSort.pas"/>
     117        <HasRegisterProc Value="True"/>
     118        <UnitName Value="ListViewSort"/>
    92119      </Item17>
    93120      <Item18>
    94         <Filename Value="UPersistentForm.pas"/>
    95         <HasRegisterProc Value="True"/>
    96         <UnitName Value="UPersistentForm"/>
     121        <Filename Value="PersistentForm.pas"/>
     122        <HasRegisterProc Value="True"/>
     123        <UnitName Value="PersistentForm"/>
    97124      </Item18>
    98125      <Item19>
    99         <Filename Value="UFindFile.pas"/>
    100         <HasRegisterProc Value="True"/>
    101         <UnitName Value="UFindFile"/>
     126        <Filename Value="FindFile.pas"/>
     127        <HasRegisterProc Value="True"/>
     128        <UnitName Value="FindFile"/>
    102129      </Item19>
    103130      <Item20>
    104         <Filename Value="UScaleDPI.pas"/>
    105         <HasRegisterProc Value="True"/>
    106         <UnitName Value="UScaleDPI"/>
     131        <Filename Value="ScaleDPI.pas"/>
     132        <HasRegisterProc Value="True"/>
     133        <UnitName Value="ScaleDPI"/>
    107134      </Item20>
     135      <Item21>
     136        <Filename Value="Theme.pas"/>
     137        <HasRegisterProc Value="True"/>
     138        <UnitName Value="Theme"/>
     139      </Item21>
     140      <Item22>
     141        <Filename Value="StringTable.pas"/>
     142        <UnitName Value="StringTable"/>
     143      </Item22>
     144      <Item23>
     145        <Filename Value="MetaCanvas.pas"/>
     146        <UnitName Value="MetaCanvas"/>
     147      </Item23>
     148      <Item24>
     149        <Filename Value="Geometric.pas"/>
     150        <UnitName Value="Geometric"/>
     151      </Item24>
     152      <Item25>
     153        <Filename Value="Translator.pas"/>
     154        <HasRegisterProc Value="True"/>
     155        <UnitName Value="Translator"/>
     156      </Item25>
     157      <Item26>
     158        <Filename Value="Languages.pas"/>
     159        <UnitName Value="Languages"/>
     160      </Item26>
     161      <Item27>
     162        <Filename Value="PixelPointer.pas"/>
     163        <UnitName Value="PixelPointer"/>
     164      </Item27>
     165      <Item28>
     166        <Filename Value="DataFile.pas"/>
     167        <UnitName Value="DataFile"/>
     168      </Item28>
     169      <Item29>
     170        <Filename Value="TestCase.pas"/>
     171        <UnitName Value="TestCase"/>
     172      </Item29>
     173      <Item30>
     174        <Filename Value="Generics.pas"/>
     175        <UnitName Value="Generics"/>
     176      </Item30>
     177      <Item31>
     178        <Filename Value="CommonPackage.pas"/>
     179        <Type Value="Main Unit"/>
     180        <UnitName Value="CommonPackage"/>
     181      </Item31>
     182      <Item32>
     183        <Filename Value="Table.pas"/>
     184        <UnitName Value="Table"/>
     185      </Item32>
     186      <Item33>
     187        <Filename Value="FormEx.pas"/>
     188        <HasRegisterProc Value="True"/>
     189        <UnitName Value="FormEx"/>
     190      </Item33>
     191      <Item34>
     192        <Filename Value="Forms\FormTests.pas"/>
     193        <UnitName Value="FormTests"/>
     194      </Item34>
     195      <Item35>
     196        <Filename Value="Forms\FormTest.pas"/>
     197        <UnitName Value="FormTest"/>
     198      </Item35>
     199      <Item36>
     200        <Filename Value="Forms\FormAbout.pas"/>
     201        <UnitName Value="FormAbout"/>
     202      </Item36>
     203      <Item37>
     204        <Filename Value="Forms\FormKeyShortcuts.pas"/>
     205        <UnitName Value="FormKeyShortcuts"/>
     206      </Item37>
     207      <Item38>
     208        <Filename Value="ItemList.pas"/>
     209        <UnitName Value="ItemList"/>
     210      </Item38>
     211      <Item39>
     212        <Filename Value="Forms\FormItem.pas"/>
     213        <UnitName Value="FormItem"/>
     214      </Item39>
     215      <Item40>
     216        <Filename Value="Forms\FormList.pas"/>
     217        <UnitName Value="FormList"/>
     218      </Item40>
    108219    </Files>
     220    <CompatibilityMode Value="True"/>
    109221    <i18n>
    110222      <EnableI18N Value="True"/>
    … …  
    112224      <EnableI18NForLFM Value="True"/>
    113225    </i18n>
    114     <RequiredPkgs Count="3">
     226    <RequiredPkgs Count="2">
    115227      <Item1>
    116228        <PackageName Value="LCL"/>
    117229      </Item1>
    118230      <Item2>
    119         <PackageName Value="TemplateGenerics"/>
    120       </Item2>
    121       <Item3>
    122231        <PackageName Value="FCL"/>
    123232        <MinVersion Major="1" Valid="True"/>
    124       </Item3>
     233      </Item2>
    125234    </RequiredPkgs>
    126235    <UsageOptions>

  • trunk/Packages/Common/Common.pas

    r20 r21  
    1 unit UCommon;
    2 
    3 {$mode delphi}
     1unit Common;
    42
    53interface
    64
    75uses
    8   {$ifdef Windows}Windows,{$endif}
    9   {$ifdef Linux}baseunix,{$endif}
    10   Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
    11   FileUtil; //, ShFolder, ShellAPI;
     6  {$IFDEF WINDOWS}Windows,{$ENDIF}
     7  {$IFDEF UNIX}baseunix,{$ENDIF}
     8  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics,
     9  FileUtil, Generics.Collections; //, ShFolder, ShellAPI;
    1210
    1311type
    1412  TArrayOfByte = array of Byte;
    15   TArrayOfString = array of string;
    1613  TExceptionEvent = procedure(Sender: TObject; E: Exception) of object;
    1714
    … …  
    2825    unfDNSDomainName = 11);
    2926
     27  TFilterMethod = function (FileName: string): Boolean of object;
     28  TFileNameMethod = procedure (FileName: string) of object;
     29
    3030var
    3131  ExceptionHandler: TExceptionEvent;
    3232  DLLHandle1: HModule;
    3333
    34 {$IFDEF Windows}
    35   GetUserNameEx: procedure (NameFormat: DWORD;
    36     lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
    37 {$ENDIF}
    38 
    39 function IntToBin(Data: Int64; Count: Byte): string;
     34  {$IFDEF WINDOWS}
     35    GetUserNameEx: procedure (NameFormat: DWORD;
     36      lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
     37  {$ENDIF}
     38
     39const
     40  clLightBlue = TColor($FF8080);
     41  clLightGreen = TColor($80FF80);
     42  clLightRed = TColor($8080FF);
     43
     44function AddLeadingZeroes(const aNumber, Length : integer) : string;
    4045function BinToInt(BinStr: string): Int64;
    41 function TryHexToInt(Data: string; var Value: Integer): Boolean;
    42 function TryBinToInt(Data: string; var Value: Integer): Boolean;
    4346function BinToHexString(Source: AnsiString): string;
    4447//function DelTree(DirName : string): Boolean;
    … …  
    4649function BCDToInt(Value: Byte): Byte;
    4750function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
     51procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     52function CombinePaths(Path1, Path2: string): string;
     53function ComputerName: string;
     54procedure DeleteFiles(APath, AFileSpec: string);
     55function EndsWith(Text, What: string): Boolean;
     56function Explode(Separator: Char; Data: string): TStringArray;
     57procedure ExecuteProgram(Executable: string; Parameters: array of string;
     58  Environment: array of string; CurrentDirectory: string = '');
     59procedure ExecuteProgramOutput(Executable: string; Parameters: array of string;
     60  Environment: array of string; out Output, Error: string;
     61  out ExitCode: Integer; CurrentDirectory: string = '');
     62procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
     63procedure FreeThenNil(var Obj);
     64function GetDirCount(Dir: string): Integer;
    4865function GetUserName: string;
    49 function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    50 function SplitString(var Text: string; Count: Word): string;
    5166function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
    5267function GetBit(Variable: QWord; Index: Byte): Boolean;
     68function GetStringPart(var Text: string; Separator: string): string;
     69function GetEnvironmentVariables: TStringArray;
     70function GenerateNewName(OldName: string): string;
     71function GetFileFilterItemExt(Filter: string; Index: Integer): string;
     72function IntToBin(Data: Int64; Count: Byte): string;
     73function Implode(Separator: string; List: TList<string>): string; overload;
     74function Implode(Separator: string; List: array of string): string; overload;
     75function Implode(Separator: string; List: TStringList; Around: string = ''): string; overload;
     76function LastPos(const SubStr: String; const S: String): Integer;
     77function LoadFileToStr(const FileName: TFileName): AnsiString;
     78function LoggedOnUserNameEx(Format: TUserNameFormat): string;
     79function MergeArray(A, B: array of string): TStringArray;
     80function OccurenceOfChar(What: Char; Where: string): Integer;
     81procedure OpenWebPage(URL: string);
     82procedure OpenEmail(Email: string);
     83procedure OpenFileInShell(FileName: string);
     84function PosFromIndex(SubStr: string; Text: string;
     85  StartIndex: Integer): Integer;
     86function PosFromIndexReverse(SubStr: string; Text: string;
     87  StartIndex: Integer): Integer;
     88function RemoveQuotes(Text: string): string;
     89procedure SaveStringToFile(S, FileName: string);
    5390procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
    5491procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
    5592procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
    5693procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload;
    57 function AddLeadingZeroes(const aNumber, Length : integer) : string;
    58 function LastPos(const SubStr: String; const S: String): Integer;
    59 function GenerateNewName(OldName: string): string;
    60 function GetFileFilterItemExt(Filter: string; Index: Integer): string;
    61 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
    62 procedure DeleteFiles(APath, AFileSpec: string);
    63 procedure OpenWebPage(URL: string);
    64 procedure OpenFileInShell(FileName: string);
    65 procedure ExecuteProgram(CommandLine: string);
    66 procedure FreeThenNil(var Obj);
    67 function RemoveQuotes(Text: string): string;
    68 function ComputerName: string;
    69 function OccurenceOfChar(What: Char; Where: string): Integer;
    70 function GetDirCount(Dir: string): Integer;
    71 function MergeArray(A, B: array of string): TArrayOfString;
    72 function LoadFileToStr(const FileName: TFileName): AnsiString;
     94procedure SearchFiles(AList: TStrings; Dir: string;
     95  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     96procedure SortStrings(Strings: TStrings);
     97function SplitString(var Text: string; Count: Word): string;
     98function StripTags(const S: string): string;
     99function StartsWith(Text, What: string): Boolean;
     100function TryHexToInt(Data: string; out Value: Integer): Boolean;
     101function TryBinToInt(Data: string; out Value: Integer): Boolean;
    73102
    74103
    75104implementation
    76105
    77 function BinToInt(BinStr : string) : Int64;
    78 var
    79   i : byte;
    80   RetVar : Int64;
     106resourcestring
     107  SExecutionError = 'Excution error: %s (exit code: %d)';
     108
     109function StartsWith(Text, What: string): Boolean;
     110begin
     111  Result := Copy(Text, 1, Length(Text)) = What;
     112end;
     113
     114function EndsWith(Text, What: string): Boolean;
     115begin
     116  Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What;
     117end;
     118
     119function BinToInt(BinStr: string): Int64;
     120var
     121  I: Byte;
     122  RetVar: Int64;
    81123begin
    82124  BinStr := UpperCase(BinStr);
    83   if BinStr[length(BinStr)] = 'B' then Delete(BinStr,length(BinStr),1);
     125  if BinStr[length(BinStr)] = 'B' then Delete(BinStr, Length(BinStr), 1);
    84126  RetVar := 0;
    85   for i := 1 to length(BinStr) do begin
    86     if not (BinStr[i] in ['0','1']) then begin
     127  for I := 1 to Length(BinStr) do begin
     128    if not (BinStr[I] in ['0','1']) then begin
    87129      RetVar := 0;
    88130      Break;
    89131    end;
    90     RetVar := (RetVar shl 1) + (byte(BinStr[i]) and 1) ;
     132    RetVar := (RetVar shl 1) + (Byte(BinStr[I]) and 1);
    91133  end;
    92134
    … …  
    98140  I: Integer;
    99141begin
     142  Result := '';
    100143  for I := 1 to Length(Source) do begin
    101144    Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
    102145  end;
    103146end;
    104 
    105147
    106148procedure DeleteFiles(APath, AFileSpec: string);
    … …  
    112154  Path := IncludeTrailingPathDelimiter(APath);
    113155
    114   Find := FindFirst(UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);
     156  Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec);
    115157  while Find = 0 do begin
    116     DeleteFile(Path + UTF8Encode(SearchRec.Name));
     158    DeleteFile(Path + SearchRec.Name);
    117159
    118160    Find := SysUtils.FindNext(SearchRec);
    … …  
    120162  FindClose(SearchRec);
    121163end;
    122 
    123164
    124165function GetFileFilterItemExt(Filter: string; Index: Integer): string;
    … …  
    143184  if FileExt <> '.*' then
    144185    FileDialog.FileName := ChangeFileExt(FileDialog.FileName, FileExt)
     186end;
     187
     188function GetEnvironmentVariables: TStringArray;
     189var
     190  I: Integer;
     191begin
     192  Result := Default(TStringArray);
     193  SetLength(Result, GetEnvironmentVariableCount);
     194  for I := 0 to GetEnvironmentVariableCount - 1 do
     195    Result[I] := GetEnvironmentString(I);
    145196end;
    146197
    … …  
    185236end;*)
    186237
     238function Implode(Separator: string; List: array of string): string;
     239var
     240  I: Integer;
     241begin
     242  Result := '';
     243  for I := 0 to Length(List) - 1 do begin
     244    Result := Result + List[I];
     245    if I < Length(List) - 1 then Result := Result + Separator;
     246  end;
     247end;
     248
     249function Implode(Separator: string; List: TStringList; Around: string = ''): string;
     250var
     251  I: Integer;
     252begin
     253  Result := '';
     254  for I := 0 to List.Count - 1 do begin
     255    Result := Result + Around + List[I] + Around;
     256    if I < List.Count - 1 then Result := Result + Separator;
     257  end;
     258end;
     259
    187260function LastPos(const SubStr: String; const S: String): Integer;
    188261begin
    … …  
    230303end;
    231304
    232 function TryHexToInt(Data: string; var Value: Integer): Boolean;
     305function TryHexToInt(Data: string; out Value: Integer): Boolean;
    233306var
    234307  I: Integer;
    … …  
    246319end;
    247320
    248 function TryBinToInt(Data: string; var Value: Integer): Boolean;
     321function TryBinToInt(Data: string; out Value: Integer): Boolean;
    249322var
    250323  I: Integer;
    … …  
    274347end;
    275348
    276 function Explode(Separator: char; Data: string): TArrayOfString;
    277 begin
    278   SetLength(Result, 0);
    279   while Pos(Separator, Data) > 0 do begin
     349function Explode(Separator: Char; Data: string): TStringArray;
     350var
     351  Index: Integer;
     352begin
     353  Result := Default(TStringArray);
     354  repeat
     355    Index := Pos(Separator, Data);
     356    if Index > 0 then begin
     357      SetLength(Result, Length(Result) + 1);
     358      Result[High(Result)] := Copy(Data, 1, Index - 1);
     359      Delete(Data, 1, Index);
     360    end else Break;
     361  until False;
     362  if Data <> '' then begin
    280363    SetLength(Result, Length(Result) + 1);
    281     Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
    282     Delete(Data, 1, Pos(Separator, Data));
    283   end;
    284   SetLength(Result, Length(Result) + 1);
    285   Result[High(Result)] := Data;
    286 end;
    287 
    288 {$IFDEF Windows}
     364    Result[High(Result)] := Data;
     365  end;
     366end;
     367
     368function Implode(Separator: string; List: TList<string>): string;
     369var
     370  I: Integer;
     371begin
     372  Result := '';
     373  for I := 0 to List.Count - 1 do begin
     374    Result := Result + List[I];
     375    if I < List.Count - 1 then Result := Result + Separator;
     376  end;
     377end;
     378
     379{$IFDEF WINDOWS}
    289380function GetUserName: string;
    290381const
    … …  
    294385begin
    295386  L := MAX_USERNAME_LENGTH + 2;
     387  Result := Default(string);
    296388  SetLength(Result, L);
    297389  if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
    … …  
    307399  end;
    308400end;
    309 {$endif}
     401{$ENDIF}
    310402
    311403function ComputerName: string;
    312 {$ifdef mswindows}
     404{$IFDEF WINDOWS}
    313405const
    314406 INFO_BUFFER_SIZE = 32767;
    … …  
    325417  end;
    326418end;
    327 {$endif}
    328 {$ifdef unix}
     419{$ENDIF}
     420{$IFDEF UNIX}
    329421var
    330422  Name: UtsName;
    331423begin
     424  Name := Default(UtsName);
    332425  fpuname(Name);
    333426  Result := Name.Nodename;
    334427end;
    335 {$endif}
    336 
    337 {$ifdef windows}
     428{$ENDIF}
     429
     430{$IFDEF WINDOWS}
    338431function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    339432const
    … …  
    413506procedure LoadLibraries;
    414507begin
    415   {$IFDEF Windows}
     508  {$IFDEF WINDOWS}
    416509  DLLHandle1 := LoadLibrary('secur32.dll');
    417510  if DLLHandle1 <> 0 then
    … …  
    424517procedure FreeLibraries;
    425518begin
    426   {$IFDEF Windows}
     519  {$IFDEF WINDOWS}
    427520  if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
    428521  {$ENDIF}
    429522end;
    430523
    431 procedure ExecuteProgram(CommandLine: string);
     524procedure ExecuteProgram(Executable: string; Parameters: array of string;
     525  Environment: array of string; CurrentDirectory: string = '');
    432526var
    433527  Process: TProcess;
    434 begin
     528  I: Integer;
     529begin
     530  Process := TProcess.Create(nil);
    435531  try
    436     Process := TProcess.Create(nil);
    437     Process.CommandLine := CommandLine;
     532    Process.Executable := Executable;
     533    for I := 0 to Length(Parameters) - 1 do
     534      Process.Parameters.Add(Parameters[I]);
     535    for I := 0 to Length(Environment) - 1 do
     536      Process.Environment.Add(Environment[I]);
     537    Process.CurrentDirectory := CurrentDirectory;
     538    Process.ShowWindow := swoHIDE;
    438539    Process.Options := [poNoConsole];
    439540    Process.Execute;
    … …  
    443544end;
    444545
     546procedure ExecuteProgramOutput(Executable: string; Parameters: array of string;
     547  Environment: array of string; out Output, Error: string; out ExitCode: Integer;
     548  CurrentDirectory: string);
     549var
     550  Process: TProcess;
     551  I: Integer;
     552  ReadCount: Integer;
     553  Buffer: string;
     554const
     555  BufferSize = 1000;
     556begin
     557  Process := TProcess.Create(nil);
     558  try
     559    Process.Executable := Executable;
     560    for I := 0 to Length(Parameters) - 1 do
     561      Process.Parameters.Add(Parameters[I]);
     562    for I := 0 to Length(Environment) - 1 do
     563      Process.Environment.Add(Environment[I]);
     564    Process.CurrentDirectory := CurrentDirectory;
     565    Process.ShowWindow := swoHIDE;
     566    Process.Options := [poNoConsole, poUsePipes];
     567    Process.Execute;
     568
     569    Output := '';
     570    Error := '';
     571    Buffer := '';
     572    SetLength(Buffer, BufferSize);
     573    while Process.Running do begin
     574      if Process.Output.NumBytesAvailable > 0 then begin
     575        ReadCount := Process.Output.Read(Buffer[1], Length(Buffer));
     576        Output := Output + Copy(Buffer, 1, ReadCount);
     577      end;
     578
     579      if Process.Stderr.NumBytesAvailable > 0 then begin
     580        ReadCount := Process.Stderr.Read(Buffer[1], Length(Buffer));
     581        Error := Error + Copy(Buffer, 1, ReadCount)
     582      end;
     583
     584      Sleep(10);
     585    end;
     586
     587    if Process.Output.NumBytesAvailable > 0 then begin
     588      ReadCount := Process.Output.Read(Buffer[1], Length(Buffer));
     589      Output := Output + Copy(Buffer, 1, ReadCount);
     590    end;
     591
     592    if Process.Stderr.NumBytesAvailable > 0 then begin
     593      ReadCount := Process.Stderr.Read(Buffer[1], Length(Buffer));
     594      Error := Error + Copy(Buffer, 1, ReadCount);
     595    end;
     596
     597    ExitCode := Process.ExitCode;
     598
     599    if (ExitCode <> 0) or (Error <> '') then
     600      raise Exception.Create(Format(SExecutionError, [Output + Error, ExitCode]));
     601  finally
     602    Process.Free;
     603  end;
     604end;
     605
    445606procedure FreeThenNil(var Obj);
    446607begin
    … …  
    454615end;
    455616
     617procedure OpenEmail(Email: string);
     618begin
     619  OpenURL('mailto:' + Email);
     620end;
     621
    456622procedure OpenFileInShell(FileName: string);
    457623begin
    458   ExecuteProgram('cmd.exe /c start "' + FileName + '"');
     624  ExecuteProgram('cmd.exe', ['/c', 'start', FileName], []);
    459625end;
    460626
    … …  
    482648end;
    483649
    484 function MergeArray(A, B: array of string): TArrayOfString;
    485 var
    486   I: Integer;
    487 begin
     650function MergeArray(A, B: array of string): TStringArray;
     651var
     652  I: Integer;
     653begin
     654  Result := Default(TStringArray);
    488655  SetLength(Result, Length(A) + Length(B));
    489656  for I := 0 to Length(A) - 1 do
    … …  
    511678end;
    512679
     680function DefaultSearchFilter(const FileName: string): Boolean;
     681begin
     682  Result := True;
     683end;
     684
     685procedure SaveStringToFile(S, FileName: string);
     686var
     687  F: TextFile;
     688begin
     689  AssignFile(F, FileName);
     690  try
     691    ReWrite(F);
     692    Write(F, S);
     693  finally
     694    CloseFile(F);
     695  end;
     696end;
     697
     698procedure SearchFiles(AList: TStrings; Dir: string;
     699  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     700var
     701  SR: TSearchRec;
     702begin
     703  Dir := IncludeTrailingPathDelimiter(Dir);
     704  if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
     705    try
     706      repeat
     707        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
     708          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     709        if Assigned(FileNameMethod) then
     710          FileNameMethod(Dir + SR.Name);
     711        AList.Add(Dir + SR.Name);
     712        if (SR.Attr and faDirectory) <> 0 then
     713          SearchFiles(AList, Dir + SR.Name, FilterMethod);
     714      until FindNext(SR) <> 0;
     715    finally
     716      FindClose(SR);
     717    end;
     718end;
     719
     720function GetStringPart(var Text: string; Separator: string): string;
     721var
     722  P: Integer;
     723begin
     724  P := Pos(Separator, Text);
     725  if P > 0 then begin
     726    Result := Copy(Text, 1, P - 1);
     727    Delete(Text, 1, P - 1 + Length(Separator));
     728  end else begin
     729    Result := Text;
     730    Text := '';
     731  end;
     732  Result := Trim(Result);
     733  Text := Trim(Text);
     734end;
     735
     736function StripTags(const S: string): string;
     737var
     738  Len: Integer;
     739
     740  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
     741  var
     742    J: Integer;
     743  begin
     744    for J := ReadFrom to Len do
     745      if (S[j] = C) then
     746      begin
     747        Result := J;
     748        Exit;
     749      end;
     750    Result := Len + 1;
     751  end;
     752
     753var
     754  I, APos: Integer;
     755begin
     756  Len := Length(S);
     757  I := 0;
     758  Result := '';
     759  while (I <= Len) do begin
     760    Inc(I);
     761    APos := ReadUntil(I, '<');
     762    Result := Result + Copy(S, I, APos - i);
     763    I := ReadUntil(APos + 1, '>');
     764  end;
     765end;
     766
     767function PosFromIndex(SubStr: string; Text: string;
     768  StartIndex: Integer): Integer;
     769var
     770  I, MaxLen: SizeInt;
     771  Ptr: PAnsiChar;
     772begin
     773  Result := 0;
     774  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
     775  if Length(SubStr) > 0 then begin
     776    MaxLen := Length(Text) - Length(SubStr) + 1;
     777    I := StartIndex;
     778    Ptr := @Text[StartIndex];
     779    while (I <= MaxLen) do begin
     780      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     781        Result := I;
     782        Exit;
     783      end;
     784      Inc(I);
     785      Inc(Ptr);
     786    end;
     787  end;
     788end;
     789
     790function PosFromIndexReverse(SubStr: string; Text: string;
     791  StartIndex: Integer): Integer;
     792var
     793  I: SizeInt;
     794  Ptr: PAnsiChar;
     795begin
     796  Result := 0;
     797  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
     798  if Length(SubStr) > 0 then begin
     799    I := StartIndex;
     800    Ptr := @Text[StartIndex];
     801    while (I > 0) do begin
     802      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     803        Result := I;
     804        Exit;
     805      end;
     806      Dec(I);
     807      Dec(Ptr);
     808    end;
     809  end;
     810end;
     811
     812procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     813var
     814  I: Integer;
     815begin
     816  SetLength(Dest, Length(Source));
     817  for I := 0 to Length(Dest) - 1 do
     818    Dest[I] := Source[I];
     819end;
     820
     821function CombinePaths(Path1, Path2: string): string;
     822begin
     823  Result := Path1;
     824  if Result <> '' then Result := Result + DirectorySeparator + Path2
     825    else Result := Path2;
     826end;
     827
     828procedure SortStrings(Strings: TStrings);
     829var
     830  Tmp: TStringList;
     831begin
     832  Strings.BeginUpdate;
     833  try
     834    if Strings is TStringList then begin
     835      TStringList(Strings).Sort;
     836    end else begin
     837      Tmp := TStringList.Create;
     838      try
     839        Tmp.Assign(Strings);
     840        Tmp.Sort;
     841        Strings.Assign(Tmp);
     842      finally
     843        Tmp.Free;
     844      end;
     845    end;
     846  finally
     847    Strings.EndUpdate;
     848  end;
     849end;
    513850
    514851

  • trunk/Packages/Common/CommonPackage.pas

    r20 r21  
    33 }
    44
    5 unit Common;
     5unit CommonPackage;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
    910uses
    10   StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
    11   UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
    12   UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
    13   UPersistentForm, UFindFile, UScaleDPI, LazarusPackageIntf;
     11  StopWatch, Common, DebugLog, Common.Delay, PrefixMultiplier, URI, Threading,
     12  Memory, ResetableThread, Pool, LastOpenedList, RegistryEx, JobProgressView,
     13  XML, ApplicationInfo, SyncCounter, ListViewSort, PersistentForm, FindFile,
     14  ScaleDPI, Theme, StringTable, MetaCanvas, Geometric, Translator, Languages,
     15  PixelPointer, DataFile, TestCase, Generics, Table, FormEx, FormTests,
     16  FormTest, FormAbout, FormKeyShortcuts, ItemList, FormItem, FormList,
     17  LazarusPackageIntf;
    1418
    1519implementation
    … …  
    1721procedure Register;
    1822begin
    19   RegisterUnit('UDebugLog', @UDebugLog.Register);
    20   RegisterUnit('ULastOpenedList', @ULastOpenedList.Register);
    21   RegisterUnit('UJobProgressView', @UJobProgressView.Register);
    22   RegisterUnit('UApplicationInfo', @UApplicationInfo.Register);
    23   RegisterUnit('UListViewSort', @UListViewSort.Register);
    24   RegisterUnit('UPersistentForm', @UPersistentForm.Register);
    25   RegisterUnit('UFindFile', @UFindFile.Register);
    26   RegisterUnit('UScaleDPI', @UScaleDPI.Register);
     23  RegisterUnit('DebugLog', @DebugLog.Register);
     24  RegisterUnit('PrefixMultiplier', @PrefixMultiplier.Register);
     25  RegisterUnit('LastOpenedList', @LastOpenedList.Register);
     26  RegisterUnit('JobProgressView', @JobProgressView.Register);
     27  RegisterUnit('ApplicationInfo', @ApplicationInfo.Register);
     28  RegisterUnit('ListViewSort', @ListViewSort.Register);
     29  RegisterUnit('PersistentForm', @PersistentForm.Register);
     30  RegisterUnit('FindFile', @FindFile.Register);
     31  RegisterUnit('ScaleDPI', @ScaleDPI.Register);
     32  RegisterUnit('Theme', @Theme.Register);
     33  RegisterUnit('Translator', @Translator.Register);
     34  RegisterUnit('FormEx', @FormEx.Register);
    2735end;
    2836

  • trunk/Packages/Common/DebugLog.pas

    r20 r21  
    1 unit UDebugLog;
    2 
    3 {$mode delphi}
     1unit DebugLog;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;
     6  Classes, SysUtils, FileUtil, Generics.Collections, SyncObjs;
    97
    108type
    … …  
    1513    Group: string;
    1614    Text: string;
     15  end;
     16
     17  TDebugLogItems = class(TObjectList<TDebugLogItem>)
    1718  end;
    1819
    … …  
    2930    procedure SetMaxCount(const AValue: Integer);
    3031  public
    31     Items: TListObject;
     32    Items: TDebugLogItems;
    3233    Lock: TCriticalSection;
    3334    procedure Add(Text: string; Group: string = '');
    … …  
    4445
    4546procedure Register;
     47
    4648
    4749implementation
    … …  
    104106    if ExtractFileDir(FileName) <> '' then
    105107      ForceDirectories(ExtractFileDir(FileName));
    106     if FileExists(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite)
    107       else LogFile := TFileStream.Create(UTF8Decode(FileName), fmCreate);
     108    if FileExists(FileName) then LogFile := TFileStream.Create(FileName, fmOpenWrite)
     109      else LogFile := TFileStream.Create(FileName, fmCreate);
    108110    LogFile.Seek(0, soFromEnd);
    109111    Text := FormatDateTime('hh:nn:ss.zzz', Now) + ': ' + Text + LineEnding;
    … …  
    117119begin
    118120  inherited;
    119   Items := TListObject.Create;
     121  Items := TDebugLogItems.Create;
    120122  Lock := TCriticalSection.Create;
    121123  MaxCount := 100;
    … …  
    126128destructor TDebugLog.Destroy;
    127129begin
    128   Items.Free;
    129   Lock.Free;
     130  FreeAndNil(Items);
     131  FreeAndNil(Lock);
    130132  inherited;
    131133end;
    132134
    133135end.
    134 

  • trunk/Packages/Common/FindFile.pas

    r20 r21  
    1919}
    2020
    21 unit UFindFile;
     21unit FindFile;
    2222
    2323interface
    2424
    2525uses
    26   SysUtils, Classes, Graphics, Controls, Forms, Dialogs, FileCtrl;
     26  SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
    2727
    2828type
    … …  
    3535  private
    3636    s : TStringList;
    37 
    3837    fSubFolder : boolean;
    3938    fAttr: TFileAttrib;
    4039    fPath : string;
    4140    fFileMask : string;
    42 
    4341    procedure SetPath(Value: string);
    4442    procedure FileSearch(const inPath : string);
    … …  
    4644    constructor Create(AOwner: TComponent); override;
    4745    destructor Destroy; override;
    48 
    4946    function SearchForFiles: TStringList;
    5047  published
    … …  
    5956  FilterAll = '*.*';
    6057{$ENDIF}
    61 {$IFDEF LINUX}
     58{$IFDEF UNIX}
    6259  FilterAll = '*';
    6360{$ENDIF}
    6461
    6562procedure Register;
     63
    6664
    6765implementation
    … …  
    7775constructor TFindFile.Create(AOwner: TComponent);
    7876begin
    79   inherited Create(AOwner);
     77  inherited;
    8078  Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir));
    8179  FileMask := FilterAll;
    … …  
    8785begin
    8886  s.Free;
    89   inherited Destroy;
     87  inherited;
    9088end;
    9189
    … …  
    117115  Attr := 0;
    118116  if ffaReadOnly in FileAttr then Attr := Attr + faReadOnly;
    119   if ffaHidden in FileAttr then Attr := Attr + faHidden;
    120   if ffaSysFile in FileAttr then Attr := Attr + faSysFile;
    121   if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
     117  if ffaHidden in FileAttr then Attr := Attr + 2; //faHidden; use constant to avoid platform warning
     118  if ffaSysFile in FileAttr then Attr := Attr + 4; //faSysFile; use constant to avoid platform warning
     119  // Deprecated: if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
    122120  if ffaDirectory in FileAttr then Attr := Attr + faDirectory;
    123121  if ffaArchive in FileAttr then Attr := Attr + faArchive;
    124122  if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile;
    125123
    126   if SysUtils.FindFirst(UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then
     124  if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then
    127125  try
    128126    repeat
    129       s.Add(inPath + UTF8Encode(Rec.Name));
     127      s.Add(inPath + Rec.Name);
    130128    until SysUtils.FindNext(Rec) <> 0;
    131129  finally
    … …  
    135133  If not InSubFolders then Exit;
    136134
    137   if SysUtils.FindFirst(UTF8Decode(inPath + FilterAll), faDirectory, Rec) = 0 then
     135  if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then
    138136  try
    139137    repeat
    140138      if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.')
    141139      and (Rec.Name <> '..') then
    142         FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));
     140        FileSearch(IncludeTrailingBackslash(inPath + Rec.Name));
    143141    until SysUtils.FindNext(Rec) <> 0;
    144142  finally
    145143    SysUtils.FindClose(Rec);
    146144  end;
    147 end; 
     145end;
    148146
    149147end.
    150 

  • trunk/Packages/Common/JobProgressView.lfm

    r20 r21  
    11object FormJobProgressView: TFormJobProgressView
    22  Left = 467
    3   Height = 246
     3  Height = 414
    44  Top = 252
    5   Width = 328
     5  Width = 647
    66  BorderIcons = [biSystemMenu]
    7   ClientHeight = 246
    8   ClientWidth = 328
    9   Font.Height = -11
    10   Font.Name = 'MS Sans Serif'
     7  ClientHeight = 414
     8  ClientWidth = 647
     9  DesignTimePPI = 144
    1110  OnClose = FormClose
    1211  OnCloseQuery = FormCloseQuery
    1312  OnCreate = FormCreate
    14   OnDestroy = FormDestroy
     13  OnHide = FormHide
     14  OnShow = FormShow
    1515  Position = poScreenCenter
    16   LCLVersion = '1.6.0.4'
     16  LCLVersion = '2.2.0.4'
    1717  object PanelOperationsTitle: TPanel
    1818    Left = 0
    19     Height = 24
     19    Height = 38
    2020    Top = 0
    21     Width = 328
     21    Width = 647
    2222    Align = alTop
    2323    BevelOuter = bvNone
    24     ClientHeight = 24
    25     ClientWidth = 328
     24    ClientHeight = 38
     25    ClientWidth = 647
    2626    FullRepaint = False
    2727    TabOrder = 0
    2828    object LabelOperation: TLabel
    29       Left = 8
    30       Height = 13
    31       Top = 8
    32       Width = 66
     29      Left = 10
     30      Height = 26
     31      Top = 10
     32      Width = 99
    3333      Caption = 'Operations:'
    34       Font.Height = -11
    35       Font.Name = 'MS Sans Serif'
    36       Font.Style = [fsBold]
    37       ParentColor = False
    3834      ParentFont = False
    3935    end
    … …  
    4137  object PanelLog: TPanel
    4238    Left = 0
    43     Height = 122
    44     Top = 124
    45     Width = 328
     39    Height = 161
     40    Top = 253
     41    Width = 647
    4642    Align = alClient
    4743    BevelOuter = bvSpace
    48     ClientHeight = 122
    49     ClientWidth = 328
     44    ClientHeight = 161
     45    ClientWidth = 647
    5046    TabOrder = 1
    5147    object MemoLog: TMemo
    52       Left = 8
    53       Height = 106
    54       Top = 8
    55       Width = 312
     48      Left = 10
     49      Height = 141
     50      Top = 10
     51      Width = 627
    5652      Anchors = [akTop, akLeft, akRight, akBottom]
    5753      ReadOnly = True
    … …  
    6258  object PanelProgress: TPanel
    6359    Left = 0
    64     Height = 38
    65     Top = 50
    66     Width = 328
     60    Height = 65
     61    Top = 126
     62    Width = 647
    6763    Align = alTop
    6864    BevelOuter = bvNone
    69     ClientHeight = 38
    70     ClientWidth = 328
     65    ClientHeight = 65
     66    ClientWidth = 647
    7167    TabOrder = 2
    7268    object ProgressBarPart: TProgressBar
    73       Left = 8
    74       Height = 17
    75       Top = 16
    76       Width = 312
     69      Left = 12
     70      Height = 29
     71      Top = 29
     72      Width = 628
    7773      Anchors = [akTop, akLeft, akRight]
    7874      TabOrder = 0
    7975    end
    8076    object LabelEstimatedTimePart: TLabel
    81       Left = 8
    82       Height = 13
     77      Left = 10
     78      Height = 26
    8379      Top = -2
    84       Width = 71
     80      Width = 132
    8581      Caption = 'Estimated time:'
    86       ParentColor = False
    8782    end
    8883  end
    8984  object PanelOperations: TPanel
    9085    Left = 0
    91     Height = 26
    92     Top = 24
    93     Width = 328
     86    Height = 50
     87    Top = 76
     88    Width = 647
    9489    Align = alTop
    9590    BevelOuter = bvNone
    96     ClientHeight = 26
    97     ClientWidth = 328
     91    ClientHeight = 50
     92    ClientWidth = 647
    9893    FullRepaint = False
    9994    TabOrder = 3
    10095    object ListViewJobs: TListView
    101       Left = 8
    102       Height = 16
    103       Top = 5
    104       Width = 312
     96      Left = 10
     97      Height = 38
     98      Top = 6
     99      Width = 627
    105100      Anchors = [akTop, akLeft, akRight, akBottom]
    106101      AutoWidthLastColumn = True
    … …  
    109104      Columns = <     
    110105        item
    111           Width = 312
     106          Width = 614
    112107        end>
    113108      OwnerData = True
    … …  
    122117  object PanelProgressTotal: TPanel
    123118    Left = 0
    124     Height = 36
    125     Top = 88
    126     Width = 328
     119    Height = 62
     120    Top = 191
     121    Width = 647
    127122    Align = alTop
    128123    BevelOuter = bvNone
    129     ClientHeight = 36
    130     ClientWidth = 328
     124    ClientHeight = 62
     125    ClientWidth = 647
    131126    TabOrder = 4
    132127    object LabelEstimatedTimeTotal: TLabel
    133       Left = 8
    134       Height = 13
     128      Left = 10
     129      Height = 26
    135130      Top = 0
    136       Width = 97
     131      Width = 178
    137132      Caption = 'Total estimated time:'
    138       ParentColor = False
    139133    end
    140134    object ProgressBarTotal: TProgressBar
    141       Left = 8
    142       Height = 16
    143       Top = 16
    144       Width = 312
     135      Left = 10
     136      Height = 29
     137      Top = 29
     138      Width = 627
    145139      Anchors = [akTop, akLeft, akRight]
    146140      TabOrder = 0
    147141    end
    148142  end
     143  object PanelText: TPanel
     144    Left = 0
     145    Height = 38
     146    Top = 38
     147    Width = 647
     148    Align = alTop
     149    BevelOuter = bvNone
     150    ClientHeight = 38
     151    ClientWidth = 647
     152    TabOrder = 5
     153    object LabelText: TLabel
     154      Left = 10
     155      Height = 29
     156      Top = 10
     157      Width = 630
     158      Anchors = [akTop, akLeft, akRight]
     159      AutoSize = False
     160    end
     161  end
    149162  object ImageList1: TImageList
    150     BkColor = clForeground
    151     left = 200
    152     top = 8
     163    Left = 240
     164    Top = 10
    153165    Bitmap = {
    154       4C69020000001000000010000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
    155       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    156       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    157       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    158       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    159       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    160       FF00000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    161       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    162       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    163       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    164       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    165       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    166       00FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    167       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    168       00FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00
    169       FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00
    170       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FFFF00
    171       FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00
    172       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    173       00FFFF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00
    174       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    175       00FF000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00
    176       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    177       00FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00
    178       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    179       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    180       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    181       FF00000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    182       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    183       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    184       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    185       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    186       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    187       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    188       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    189       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    190       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    191       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    192       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    193       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    194       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    195       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    196       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    197       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    198       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    199       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    200       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    201       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    202       FFFF000084FF000000FFFF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    203       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    204       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    205       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    206       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    207       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    208       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    209       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    210       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    211       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    212       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    213       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    214       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    215       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    216       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    217       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    218       FF00FF00FF00FF00FF00FF00FF00
     166      4C7A0200000010000000100000006A0000000000000078DAE593490E00100C45
     167      7B78F72E5684A63A1142C382BE4F0708F89C955117F4B016BE67B5FC6E96DB97
     168      B0D4B9F4CD949F36DED1DF922B0F1BD11FAB5AFC68DE5C44D40220A9FA779EC8
     169      6A349FD5A435E43CADA1E3678D73F773F1DBF3EFADFFEEFEBBF97F6696BE9D36
    219170    }
    220171  end
    … …  
    223174    Interval = 100
    224175    OnTimer = TimerUpdateTimer
    225     left = 264
    226     top = 8
     176    Left = 384
     177    Top = 10
    227178  end
    228179end

  • trunk/Packages/Common/JobProgressView.pas

    r20 r21  
    1 unit UJobProgressView;
    2 
    3 {$MODE Delphi}
     1unit JobProgressView;
    42
    53interface
    … …  
    75uses
    86  SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs,
    9   Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading,
     7  Dialogs, ComCtrls, StdCtrls, ExtCtrls, Generics.Collections, Threading, Math,
    108  DateUtils;
    119
    … …  
    1311  EstimatedTimeShowTreshold = 4;
    1412  EstimatedTimeShowTresholdTotal = 1;
    15   MemoLogHeight = 200;
    1613  UpdateInterval = 100; // ms
    1714
    … …  
    2421    FLock: TCriticalSection;
    2522    FOnChange: TNotifyEvent;
     23    FText: string;
    2624    FValue: Integer;
    2725    FMax: Integer;
    2826    procedure SetMax(const AValue: Integer);
     27    procedure SetText(AValue: string);
    2928    procedure SetValue(const AValue: Integer);
    3029  public
    … …  
    3534    property Value: Integer read FValue write SetValue;
    3635    property Max: Integer read FMax write SetMax;
     36    property Text: string read FText write SetText;
    3737    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    3838  end;
    … …  
    6969  end;
    7070
     71  TJobs = class(TObjectList<TJob>)
     72  end;
     73
    7174  TJobThread = class(TListedThread)
    7275    procedure Execute; override;
    … …  
    8083  TFormJobProgressView = class(TForm)
    8184    ImageList1: TImageList;
     85    LabelText: TLabel;
    8286    Label2: TLabel;
    8387    LabelOperation: TLabel;
    … …  
    8690    ListViewJobs: TListView;
    8791    MemoLog: TMemo;
     92    PanelText: TPanel;
    8893    PanelProgressTotal: TPanel;
    8994    PanelOperationsTitle: TPanel;
    … …  
    9499    ProgressBarTotal: TProgressBar;
    95100    TimerUpdate: TTimer;
     101    procedure FormHide(Sender: TObject);
     102    procedure FormShow(Sender: TObject);
     103    procedure ReloadJobList;
    96104    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    97     procedure FormDestroy(Sender: TObject);
    98105    procedure ListViewJobsData(Sender: TObject; Item: TListItem);
    99106    procedure TimerUpdateTimer(Sender: TObject);
    100107    procedure FormCreate(Sender: TObject);
    101108    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     109    procedure UpdateHeight;
    102110  public
    103111    JobProgressView: TJobProgressView;
    … …  
    118126    TotalStartTime: TDateTime;
    119127    Log: TStringList;
     128    FForm: TFormJobProgressView;
    120129    procedure SetTerminate(const AValue: Boolean);
    121130    procedure UpdateProgress;
    122     procedure ReloadJobList;
    123     procedure StartJobs;
    124     procedure UpdateHeight;
    125131    procedure JobProgressChange(Sender: TObject);
    126132  public
    127     Form: TFormJobProgressView;
    128     Jobs: TObjectList; // TListObject<TJob>
     133    Jobs: TJobs;
    129134    CurrentJob: TJob;
    130135    CurrentJobIndex: Integer;
    … …  
    132137    destructor Destroy; override;
    133138    procedure Clear;
    134     procedure AddJob(Title: string; Method: TJobProgressViewMethod;
    135       NoThreaded: Boolean = False; WaitFor: Boolean = False);
    136     procedure Start(AAutoClose: Boolean = True);
     139    function AddJob(Title: string; Method: TJobProgressViewMethod;
     140      NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     141    procedure Start;
    137142    procedure Stop;
    138143    procedure TermSleep(Delay: Integer);
     144    property Form: TFormJobProgressView read FForm;
    139145    property Terminate: Boolean read FTerminate write SetTerminate;
    140146  published
    … …  
    148154  end;
    149155
    150   //var
    151   //  FormJobProgressView: TFormJobProgressView;
    152 
    153156procedure Register;
    154157
    155158resourcestring
    156159  SExecuted = 'Executed';
     160
    157161
    158162implementation
    … …  
    166170  STotalEstimatedTime = 'Total estimated time: %s';
    167171  SFinished = 'Finished';
    168   SOperations = 'Operations';
    169172
    170173procedure Register;
    … …  
    173176end;
    174177
     178{ TJobThread }
     179
    175180procedure TJobThread.Execute;
    176181begin
    177182  try
    178183    try
    179       //raise Exception.Create('Exception in job');
    180184      ProgressView.CurrentJob.Method(Job);
    181185    except
    … …  
    190194end;
    191195
    192 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
    193   NoThreaded: Boolean = False; WaitFor: Boolean = False);
     196{ TFormJobProgressView }
     197
     198procedure TFormJobProgressView.UpdateHeight;
    194199var
    195   NewJob: TJob;
    196 begin
    197   NewJob := TJob.Create;
    198   NewJob.ProgressView := Self;
    199   NewJob.Title := Title;
    200   NewJob.Method := Method;
    201   NewJob.NoThreaded := NoThreaded;
    202   NewJob.WaitFor := WaitFor;
    203   NewJob.Progress.Max := 100;
    204   NewJob.Progress.Reset;
    205   NewJob.Progress.OnChange := JobProgressChange;
    206   Jobs.Add(NewJob);
     200  H: Integer;
     201  PanelOperationsVisible: Boolean;
     202  PanelOperationsHeight: Integer;
     203  PanelProgressVisible: Boolean;
     204  PanelProgressTotalVisible: Boolean;
     205  PanelLogVisible: Boolean;
     206  MemoLogHeight: Integer = 200;
     207  I: Integer;
     208  ItemRect: TRect;
     209  MaxH: Integer;
     210begin
     211    H := PanelOperationsTitle.Height;
     212    PanelOperationsVisible := JobProgressView.Jobs.Count > 0;
     213    if PanelOperationsVisible <> PanelOperations.Visible then
     214      PanelOperations.Visible := PanelOperationsVisible;
     215    if ListViewJobs.Items.Count > 0 then begin
     216      Maxh := 0;
     217      for I := 0 to ListViewJobs.Items.Count - 1 do
     218      begin
     219        ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds);
     220        Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top));
     221      end;
     222      PanelOperationsHeight := Scale96ToScreen(12) + Maxh;
     223    end else PanelOperationsHeight := Scale96ToScreen(8);
     224    if PanelOperationsHeight <> PanelOperations.Height then
     225      PanelOperations.Height := PanelOperationsHeight;
     226    if PanelOperationsVisible then
     227      H := H + PanelOperations.Height;
     228
     229    PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished;
     230    if PanelProgressVisible <> PanelProgress.Visible then
     231      PanelProgress.Visible := PanelProgressVisible;
     232    if PanelProgressVisible then
     233      H := H + PanelProgress.Height;
     234    PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished;
     235    if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
     236      PanelProgressTotal.Visible := PanelProgressTotalVisible;
     237    if PanelProgressTotalVisible then
     238      H := H + PanelProgressTotal.Height;
     239    Constraints.MinHeight := H;
     240    PanelLogVisible := MemoLog.Lines.Count > 0;
     241    if PanelLogVisible <> PanelLog.Visible then
     242      PanelLog.Visible := PanelLogVisible;
     243    if PanelLogVisible then
     244      H := H + Scale96ToScreen(MemoLogHeight);
     245    if PanelText.Visible then
     246      H := H + PanelText.Height;
     247    if Height <> H then begin
     248      Height := H;
     249      Top := (Screen.Height - H) div 2;
     250    end;
     251end;
     252
     253procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
     254var
     255  ProgressBarPartVisible: Boolean;
     256  ProgressBarTotalVisible: Boolean;
     257begin
     258  JobProgressView.UpdateProgress;
     259  if Visible and (not ProgressBarPart.Visible) and
     260  Assigned(JobProgressView.CurrentJob) and
     261  (JobProgressView.CurrentJob.Progress.Value > 0) then begin
     262    ProgressBarPartVisible := True;
     263    if ProgressBarPartVisible <> ProgressBarPart.Visible then
     264      ProgressBarPart.Visible := ProgressBarPartVisible;
     265    ProgressBarTotalVisible := True;
     266    if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
     267      ProgressBarTotal.Visible := ProgressBarTotalVisible;
     268  end;
     269  if not Visible then begin
     270    TimerUpdate.Interval := UpdateInterval;
     271    if not JobProgressView.OwnerDraw then Show;
     272  end;
     273  if Assigned(JobProgressView.CurrentJob) then begin
     274    LabelText.Caption := JobProgressView.CurrentJob.Progress.Text;
     275    if LabelText.Caption <> '' then begin
     276      PanelText.Visible := True;
     277      UpdateHeight;
     278    end;
     279  end;
     280end;
     281
     282procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
     283begin
     284  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
     285  with JobProgressView.Jobs[Item.Index] do begin
     286    Item.Caption := Title;
     287    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
     288      else if Finished then Item.ImageIndex := 0
     289      else Item.ImageIndex := 2;
     290    Item.Data := JobProgressView.Jobs[Item.Index];
     291  end;
     292end;
     293
     294procedure TFormJobProgressView.FormClose(Sender: TObject;
     295  var CloseAction: TCloseAction);
     296begin
     297end;
     298
     299procedure TFormJobProgressView.FormCreate(Sender: TObject);
     300begin
     301  Caption := SPleaseWait;
     302  try
     303    //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
     304    //  DirectorySeparator + 'horse.avi';
     305    //Animate1.Active := True;
     306  except
     307
     308  end;
     309end;
     310
     311procedure TFormJobProgressView.ReloadJobList;
     312begin
     313  // Workaround for not showing first line
     314  //Form.ListViewJobs.Items.Count := Jobs.Count + 1;
     315  //Form.ListViewJobs.Refresh;
     316
     317  if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then
     318    ListViewJobs.Items.Count := JobProgressView.Jobs.Count;
     319  ListViewJobs.Refresh;
     320  Application.ProcessMessages;
     321  UpdateHeight;
     322end;
     323
     324procedure TFormJobProgressView.FormShow(Sender: TObject);
     325begin
     326  ReloadJobList;
     327end;
     328
     329procedure TFormJobProgressView.FormHide(Sender: TObject);
     330begin
     331  JobProgressView.Jobs.Clear;
     332  ReloadJobList;
     333end;
     334
     335procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     336begin
     337  CanClose := JobProgressView.Finished;
     338  JobProgressView.Terminate := True;
     339  Caption := SPleaseWait + STerminate;
     340end;
     341
     342
     343{ TJobProgressView }
     344
     345function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
     346  NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     347begin
     348  Result := TJob.Create;
     349  Result.ProgressView := Self;
     350  Result.Title := Title;
     351  Result.Method := Method;
     352  Result.NoThreaded := NoThreaded;
     353  Result.WaitFor := WaitFor;
     354  Result.Progress.Max := 100;
     355  Result.Progress.Reset;
     356  Result.Progress.OnChange := JobProgressChange;
     357  Jobs.Add(Result);
    207358  //ReloadJobList;
    208359end;
    209360
    210 procedure TJobProgressView.Start(AAutoClose: Boolean = True);
    211 begin
    212   AutoClose := AAutoClose;
    213   StartJobs;
    214 end;
    215 
    216 procedure TJobProgressView.StartJobs;
     361procedure TJobProgressView.Start;
    217362var
    218363  I: Integer;
    … …  
    229374    Form.MemoLog.Clear;
    230375
     376    Form.PanelText.Visible := False;
    231377    Form.LabelEstimatedTimePart.Visible := False;
    232378    Form.LabelEstimatedTimeTotal.Visible := False;
    … …  
    249395    I := 0;
    250396    while I < Jobs.Count do
    251     with TJob(Jobs[I]) do begin
     397    with Jobs[I] do begin
    252398      CurrentJobIndex := I;
    253       CurrentJob := TJob(Jobs[I]);
     399      CurrentJob := Jobs[I];
    254400      JobProgressChange(Self);
    255401      StartTime := Now;
    … …  
    258404      Form.ProgressBarPart.Visible := False;
    259405      //Show;
    260       ReloadJobList;
     406      Form.ReloadJobList;
    261407      Application.ProcessMessages;
    262408      if NoThreaded then begin
    … …  
    264410        Method(CurrentJob);
    265411      end else begin
     412        Thread := TJobThread.Create(True);
    266413        try
    267           Thread := TJobThread.Create(True);
    268414          with Thread do begin
    269415            FreeOnTerminate := False;
    … …  
    296442    //if Visible then Hide;
    297443    Form.MemoLog.Lines.Assign(Log);
    298     if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin
     444    if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin
    299445      Form.Hide;
    300446    end;
    301     Clear;
     447    if not Form.Visible then Clear;
    302448    Form.Caption := SFinished;
    303449    //LabelEstimatedTimePart.Visible := False;
    304450    Finished := True;
    305451    CurrentJobIndex := -1;
    306     ReloadJobList;
    307   end;
    308 end;
    309 
    310 procedure TJobProgressView.UpdateHeight;
    311 var
    312   H: Integer;
    313   PanelOperationsVisible: Boolean;
    314   PanelOperationsHeight: Integer;
    315   PanelProgressVisible: Boolean;
    316   PanelProgressTotalVisible: Boolean;
    317   PanelLogVisible: Boolean;
    318 begin
    319   with Form do begin
    320   H := PanelOperationsTitle.Height;
    321   PanelOperationsVisible := Jobs.Count > 0;
    322   if PanelOperationsVisible <> PanelOperations.Visible then
    323     PanelOperations.Visible := PanelOperationsVisible;
    324   PanelOperationsHeight := 8 + 18 * Jobs.Count;
    325   if PanelOperationsHeight <> PanelOperations.Height then
    326     PanelOperations.Height := PanelOperationsHeight;
    327   if PanelOperationsVisible then
    328     H := H + PanelOperations.Height;
    329 
    330   PanelProgressVisible := (Jobs.Count > 0) and not Finished;
    331   if PanelProgressVisible <> PanelProgress.Visible then
    332     PanelProgress.Visible := PanelProgressVisible;
    333   if PanelProgressVisible then
    334     H := H + PanelProgress.Height;
    335   PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished;
    336   if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
    337     PanelProgressTotal.Visible := PanelProgressTotalVisible;
    338   if PanelProgressTotalVisible then
    339     H := H + PanelProgressTotal.Height;
    340   Constraints.MinHeight := H;
    341   PanelLogVisible := MemoLog.Lines.Count > 0;
    342   if PanelLogVisible <> PanelLog.Visible then
    343     PanelLog.Visible := PanelLogVisible;
    344   if PanelLogVisible then
    345     H := H + MemoLogHeight;
    346   if Height <> H then Height := H;
     452    Form.ReloadJobList;
    347453  end;
    348454end;
    … …  
    352458  if Assigned(FOnOwnerDraw) then
    353459    FOnOwnerDraw(Self);
    354 end;
    355 
    356 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
    357 var
    358   ProgressBarPartVisible: Boolean;
    359   ProgressBarTotalVisible: Boolean;
    360 begin
    361   JobProgressView.UpdateProgress;
    362   if Visible and (not ProgressBarPart.Visible) and
    363   Assigned(JobProgressView.CurrentJob) and
    364   (JobProgressView.CurrentJob.Progress.Value > 0) then begin
    365     ProgressBarPartVisible := True;
    366     if ProgressBarPartVisible <> ProgressBarPart.Visible then
    367       ProgressBarPart.Visible := ProgressBarPartVisible;
    368     ProgressBarTotalVisible := True;
    369     if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
    370       ProgressBarTotal.Visible := ProgressBarTotalVisible;
    371   end;
    372   if not Visible then begin
    373     TimerUpdate.Interval := UpdateInterval;
    374     if not JobProgressView.OwnerDraw then Show;
    375   end;
    376 end;
    377 
    378 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    379 begin
    380 end;
    381 
    382 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    383 begin
    384   if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    385   with TJob(JobProgressView.Jobs[Item.Index]) do begin
    386     Item.Caption := Title;
    387     if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    388       else if Finished then Item.ImageIndex := 0
    389       else Item.ImageIndex := 2;
    390     Item.Data := JobProgressView.Jobs[Item.Index];
    391   end;
    392 end;
    393 
    394 procedure TFormJobProgressView.FormClose(Sender: TObject;
    395   var CloseAction: TCloseAction);
    396 begin
    397   ListViewJobs.Clear;
    398 end;
    399 
    400 procedure TFormJobProgressView.FormCreate(Sender: TObject);
    401 begin
    402   Caption := SPleaseWait;
    403   try
    404     //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
    405     //  DirectorySeparator + 'horse.avi';
    406     //Animate1.Active := True;
    407   except
    408 
    409   end;
    410460end;
    411461
    … …  
    428478end;
    429479
    430 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    431 begin
    432   CanClose := JobProgressView.Finished;
    433   JobProgressView.Terminate := True;
    434   Caption := SPleaseWait + STerminate;
    435 end;
    436 
    437480procedure TJobProgressView.SetTerminate(const AValue: Boolean);
    438481var
    … …  
    441484  if AValue = FTerminate then Exit;
    442485  for I := 0 to Jobs.Count - 1 do
    443     TJob(Jobs[I]).Terminate := AValue;
     486    Jobs[I].Terminate := AValue;
    444487  FTerminate := AValue;
    445488end;
    … …  
    490533end;
    491534
    492 procedure TJobProgressView.ReloadJobList;
    493 begin
    494   UpdateHeight;
    495   // Workaround for not showing first line
    496   Form.ListViewJobs.Items.Count := Jobs.Count + 1;
    497   Form.ListViewJobs.Refresh;
    498 
    499   if Form.ListViewJobs.Items.Count <> Jobs.Count then
    500     Form.ListViewJobs.Items.Count := Jobs.Count;
    501   Form.ListViewJobs.Refresh;
    502   //Application.ProcessMessages;
    503 end;
    504 
    505535constructor TJobProgressView.Create(TheOwner: TComponent);
    506536begin
    507537  inherited;
    508538  if not (csDesigning in ComponentState) then begin
    509     Form := TFormJobProgressView.Create(Self);
    510     Form.JobProgressView := Self;
    511   end;
    512   Jobs := TObjectList.Create;
     539    FForm := TFormJobProgressView.Create(Self);
     540    FForm.JobProgressView := Self;
     541  end;
     542  Jobs := TJobs.Create;
    513543  Log := TStringList.Create;
    514544  //PanelOperationsTitle.Height := 80;
    515   ShowDelay := 0; //1000; // ms
     545  AutoClose := True;
     546  ShowDelay := 0;
    516547end;
    517548
    … …  
    519550begin
    520551  Jobs.Clear;
     552  Log.Clear;
    521553  //ReloadJobList;
    522554end;
    … …  
    528560  inherited;
    529561end;
     562
     563{ TProgress }
    530564
    531565procedure TProgress.SetMax(const AValue: Integer);
    … …  
    536570    if FMax < 1 then FMax := 1;
    537571    if FValue >= FMax then FValue := FMax;
     572  finally
     573    FLock.Release;
     574  end;
     575end;
     576
     577procedure TProgress.SetText(AValue: string);
     578begin
     579  try
     580    FLock.Acquire;
     581    if FText = AValue then Exit;
     582    FText := AValue;
    538583  finally
    539584    FLock.Release;
    … …  
    563608end;
    564609
    565 { TProgress }
    566 
    567610procedure TProgress.Increment;
    568611begin
    569   try
    570     FLock.Acquire;
     612  FLock.Acquire;
     613  try
    571614    Value := Value + 1;
    572615  finally
    … …  
    577620procedure TProgress.Reset;
    578621begin
    579   try
    580     FLock.Acquire;
     622  FLock.Acquire;
     623  try
    581624    FValue := 0;
    582625  finally
    … …  
    594637begin
    595638  FLock.Free;
    596   inherited Destroy;
     639  inherited;
    597640end;
    598641
    … …  
    625668destructor TJob.Destroy;
    626669begin
    627   Progress.Free;
     670  FreeAndNil(Progress);
    628671  inherited;
    629672end;

  • trunk/Packages/Common/Languages/DebugLog.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Jiří Hajda <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: udebuglog.sfilenamenotdefined
     14#: debuglog.sfilenamenotdefined
     15msgctxt "debuglog.sfilenamenotdefined"
    1316msgid "Filename not defined"
    1417msgstr "Neurčen soubor"

  • trunk/Packages/Common/Languages/FindFile.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: \n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
    11 "Language: cs\n"
    12 "X-Generator: Poedit 1.8.9\n"
     12"X-Generator: Poedit 3.0.1\n"
    1313
    14 #: ufindfile.sdirnotfound
     14#: findfile.sdirnotfound
     15msgctxt "findfile.sdirnotfound"
    1516msgid "Directory not found"
    1617msgstr "Adresář nenalezen"

  • trunk/Packages/Common/Languages/JobProgressView.cs.po

    r20 r21  
    1010"Content-Type: text/plain; charset=UTF-8\n"
    1111"Content-Transfer-Encoding: 8bit\n"
    12 "X-Generator: Poedit 1.8.8\n"
     12"X-Generator: Poedit 3.0.1\n"
    1313
    14 #: ujobprogressview.sestimatedtime
     14#: jobprogressview.sestimatedtime
    1515#, object-pascal-format
     16msgctxt "jobprogressview.sestimatedtime"
    1617msgid "Estimated time: %s"
    1718msgstr "OdhadovanÜ čas: %s"
    1819
    19 #: ujobprogressview.sexecuted
     20#: jobprogressview.sexecuted
     21msgctxt "jobprogressview.sexecuted"
    2022msgid "Executed"
    2123msgstr "Vykonané"
    2224
    23 #: ujobprogressview.sfinished
     25#: jobprogressview.sfinished
     26msgctxt "jobprogressview.sfinished"
    2427msgid "Finished"
    2528msgstr "Dokončené"
    2629
    27 #: ujobprogressview.soperations
    28 msgid "Operations"
    29 msgstr "Operace"
    30 
    31 #: ujobprogressview.spleasewait
     30#: jobprogressview.spleasewait
     31msgctxt "jobprogressview.spleasewait"
    3232msgid "Please wait..."
    3333msgstr "Prosím čekejte..."
    3434
    35 #: ujobprogressview.sterminate
     35#: jobprogressview.sterminate
     36msgctxt "jobprogressview.sterminate"
    3637msgid "Termination"
    3738msgstr "Přerušení"
    3839
    39 #: ujobprogressview.stotalestimatedtime
     40#: jobprogressview.stotalestimatedtime
    4041#, object-pascal-format
     42msgctxt "jobprogressview.stotalestimatedtime"
    4143msgid "Total estimated time: %s"
    4244msgstr "CelkovÜ odhadovanÜ čas: %s"

  • trunk/Packages/Common/Languages/Pool.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: upool.sobjectpoolempty
     14#: pool.sobjectpoolempty
     15msgctxt "pool.sobjectpoolempty"
    1316msgid "Object pool is empty"
    1417msgstr "Zásobník objektů je prázdnÜ"
    1518
    16 #: upool.sreleaseerror
     19#: pool.sreleaseerror
     20msgctxt "pool.sreleaseerror"
    1721msgid "Unknown object for release from pool"
    1822msgstr "NeznÃœmÃœ objekt pro uvolnění ze zásobníku"

  • trunk/Packages/Common/Languages/ResetableThread.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: uresetablethread.swaiterror
     14#: resetablethread.swaiterror
     15msgctxt "resetablethread.swaiterror"
    1316msgid "WaitFor error"
    1417msgstr "Chyba WaitFor"

  • trunk/Packages/Common/Languages/ScaleDPI.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: \n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
    11 "Language: cs\n"
    12 "X-Generator: Poedit 1.8.9\n"
     12"X-Generator: Poedit 3.0.1\n"
    1313
    14 #: uscaledpi.swrongdpi
     14#: scaledpi.swrongdpi
    1515#, object-pascal-format
     16msgctxt "scaledpi.swrongdpi"
    1617msgid "Wrong DPI [%d,%d]"
    1718msgstr "Chybné DPI [%d,%d]"

  • trunk/Packages/Common/Languages/Threading.cs.po

    r20 r21  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: uthreading.scurrentthreadnotfound
     14#: threading.scurrentthreadnotfound
    1315#, object-pascal-format
     16msgctxt "threading.scurrentthreadnotfound"
    1417msgid "Current thread ID %d not found in virtual thread list."
    1518msgstr "Aktuální vlákno ID %d nenalezeno v seznamu virtuálních vláken."

  • trunk/Packages/Common/LastOpenedList.pas

    r20 r21  
    1 unit ULastOpenedList;
    2 
    3 {$mode delphi}
     1unit LastOpenedList;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, Registry, URegistry, Menus, XMLConf;
     6  Classes, SysUtils, Registry, RegistryEx, Menus, XMLConf, DOM;
    97
    108type
    … …  
    3028    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    3129    procedure AddItem(FileName: string);
     30    function GetFirstFileName: string;
    3231  published
    3332    property MaxCount: Integer read FMaxCount write SetMaxCount;
    … …  
    8382destructor TLastOpenedList.Destroy;
    8483begin
    85   Items.Free;
     84  FreeAndNil(Items);
    8685  inherited;
    8786end;
    … …  
    9392begin
    9493  if Assigned(MenuItem) then begin
    95     MenuItem.Clear;
     94    while MenuItem.Count > Items.Count do
     95      MenuItem.Delete(MenuItem.Count - 1);
     96    while MenuItem.Count < Items.Count do begin
     97      NewMenuItem := TMenuItem.Create(MenuItem);
     98      MenuItem.Add(NewMenuItem);
     99    end;
    96100    for I := 0 to Items.Count - 1 do begin
    97       NewMenuItem := TMenuItem.Create(MenuItem);
    98       NewMenuItem.Caption := Items[I];
    99       NewMenuItem.OnClick := ClickAction;
    100       MenuItem.Add(NewMenuItem);
     101      MenuItem.Items[I].Caption := Items[I];
     102      MenuItem.Items[I].OnClick := ClickAction;
    101103    end;
    102104  end;
    … …  
    139141    OpenKey(Context.Key, True);
    140142    for I := 0 to Items.Count - 1 do
    141       WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));
     143      WriteString('File' + IntToStr(I), Items[I]);
    142144  finally
    143145    Free;
    … …  
    153155begin
    154156  with XMLConfig do begin
    155     Count := GetValue(Path + '/Count', 0);
     157    Count := GetValue(DOMString(Path + '/Count'), 0);
    156158    if Count > MaxCount then Count := MaxCount;
    157159    Items.Clear;
    158160    for I := 0 to Count - 1 do begin
    159       Value := GetValue(Path + '/File' + IntToStr(I), '');
     161      Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), ''));
    160162      if Trim(Value) <> '' then Items.Add(Value);
    161163    end;
    … …  
    170172begin
    171173  with XMLConfig do begin
    172     SetValue(Path + '/Count', Items.Count);
     174    SetValue(DOMString(Path + '/Count'), Items.Count);
    173175    for I := 0 to Items.Count - 1 do
    174       SetValue(Path + '/File' + IntToStr(I), Items[I]);
     176      SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I]));
    175177    Flush;
    176178  end;
    … …  
    185187end;
    186188
     189function TLastOpenedList.GetFirstFileName: string;
     190begin
     191  if Items.Count > 0 then Result := Items[0]
     192    else Result := '';
     193end;
     194
    187195end.
    188 

  • trunk/Packages/Common/ListViewSort.pas

    r20 r21  
    1 unit UListViewSort;
    2 
    3 // Date: 2010-11-03
    4 
    5 {$mode delphi}
     1unit ListViewSort;
     2
     3// Date: 2019-05-17
    64
    75interface
    86
    97uses
    10   {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
    11   Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls,
    12   LclIntf, LMessages, LclType, LResources;
     8  {$IFDEF Windows}Windows, CommCtrl, LMessages, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
     9  Controls, DateUtils, Dialogs, Forms, Grids, StdCtrls, ExtCtrls,
     10  LclIntf, LclType, LResources, Generics.Collections, Generics.Defaults;
    1311
    1412type
    … …  
    1917  TCompareEvent = function (Item1, Item2: TObject): Integer of object;
    2018  TListFilterEvent = procedure (ListViewSort: TListViewSort) of object;
     19
     20  TObjects = TObjectList<TObject>;
    2121
    2222  { TListViewSort }
    … …  
    5252    {$ENDIF}
    5353  public
    54     List: TListObject;
    55     Source: TListObject;
     54    Source: TObjects;
     55    List: TObjects;
    5656    constructor Create(AOwner: TComponent); override;
    5757    destructor Destroy; override;
    … …  
    8181    FOnChange: TNotifyEvent;
    8282    FStringGrid1: TStringGrid;
    83     procedure DoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    84     procedure DoOnResize(Sender: TObject);
     83    procedure DoOnChange;
     84    procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
     85    procedure GridDoOnResize(Sender: TObject);
    8586  public
    8687    constructor Create(AOwner: TComponent); override;
    … …  
    9091    function TextEnteredColumn(Index: Integer): Boolean;
    9192    function GetColValue(Index: Integer): string;
     93    procedure Reset;
    9294    property StringGrid: TStringGrid read FStringGrid1 write FStringGrid1;
    9395  published
    … …  
    98100  end;
    99101
     102  { TListViewEx }
     103
     104  TListViewEx = class(TWinControl)
     105  private
     106    FFilter: TListViewFilter;
     107    FListView: TListView;
     108    FListViewSort: TListViewSort;
     109    procedure ResizeHanlder;
     110  public
     111    constructor Create(TheOwner: TComponent); override;
     112    destructor Destroy; override;
     113  published
     114    property ListView: TListView read FListView write FListView;
     115    property ListViewSort: TListViewSort read FListViewSort write FListViewSort;
     116    property Filter: TListViewFilter read FFilter write FFilter;
     117    property Visible;
     118  end;
     119
    100120procedure Register;
    101121
    … …  
    105125procedure Register;
    106126begin
    107   RegisterComponents('Common', [TListViewSort, TListViewFilter]);
     127  RegisterComponents('Common', [TListViewSort, TListViewFilter, TListViewEx]);
     128end;
     129
     130{ TListViewEx }
     131
     132procedure TListViewEx.ResizeHanlder;
     133begin
     134end;
     135
     136constructor TListViewEx.Create(TheOwner: TComponent);
     137begin
     138  inherited;
     139  Filter := TListViewFilter.Create(Self);
     140  Filter.Parent := Self;
     141  Filter.Align := alBottom;
     142  ListView := TListView.Create(Self);
     143  ListView.Parent := Self;
     144  ListView.Align := alClient;
     145  ListViewSort := TListViewSort.Create(Self);
     146  ListViewSort.ListView := ListView;
     147end;
     148
     149destructor TListViewEx.Destroy;
     150begin
     151  inherited;
    108152end;
    109153
    110154{ TListViewFilter }
    111155
    112 procedure TListViewFilter.DoOnKeyUp(Sender: TObject; var Key: Word;
     156procedure TListViewFilter.DoOnChange;
     157begin
     158  if Assigned(FOnChange) then FOnChange(Self);
     159end;
     160
     161procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word;
    113162  Shift: TShiftState);
    114163begin
    115   if Assigned(FOnChange) then
    116     FOnChange(Self);
    117 end;
    118 
    119 procedure TListViewFilter.DoOnResize(Sender: TObject);
     164  DoOnChange;
     165end;
     166
     167procedure TListViewFilter.GridDoOnResize(Sender: TObject);
    120168begin
    121169  FStringGrid1.DefaultRowHeight := FStringGrid1.Height;
    … …  
    124172constructor TListViewFilter.Create(AOwner: TComponent);
    125173begin
    126   inherited Create(AOwner);
     174  inherited;
    127175  FStringGrid1 := TStringGrid.Create(Self);
    128176  FStringGrid1.Align := alClient;
    … …  
    135183  FStringGrid1.Options := [goFixedHorzLine, goFixedVertLine, goVertLine,
    136184    goHorzLine, goRangeSelect, goEditing, goAlwaysShowEditor, goSmoothScroll];
    137   FStringGrid1.OnKeyUp := DoOnKeyUp;
    138   FStringGrid1.OnResize := DoOnResize;
     185  FStringGrid1.OnKeyUp := GridDoOnKeyUp;
     186  FStringGrid1.OnResize := GridDoOnResize;
    139187end;
    140188
    … …  
    142190var
    143191  I: Integer;
     192  R: TRect;
    144193begin
    145194  with FStringGrid1 do begin
    146     //Columns.Clear;
    147195    while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1);
    148196    while Columns.Count < ListView.Columns.Count do Columns.Add;
    149197    for I := 0 to ListView.Columns.Count - 1 do begin
    150198      Columns[I].Width := ListView.Columns[I].Width;
     199      if Selection.Left = I then begin
     200        R := CellRect(I, 0);
     201        Editor.Left := R.Left + 2;
     202        Editor.Width := R.Width - 4;
     203      end;
    151204    end;
    152205  end;
    … …  
    182235end;
    183236
     237procedure TListViewFilter.Reset;
     238var
     239  I: Integer;
     240begin
     241  with StringGrid do
     242  for I := 0 to ColCount - 1 do
     243    Cells[I, 0] := '';
     244  DoOnChange;
     245end;
     246
    184247{ TListViewSort }
    185248
    … …  
    197260  if AMsg.Msg = WM_NOTIFY then
    198261  begin
    199     Code := PHDNotify(vMsgNotify.NMHdr)^.Hdr.Code;
     262    Code := NMHDR(PHDNotify(vMsgNotify.NMHdr)^.Hdr).Code;
    200263    case Code of
    201264      HDN_ENDTRACKA, HDN_ENDTRACKW:
    … …  
    272335end;
    273336
     337var
     338  ListViewSortCompare: TCompareEvent;
     339
     340function ListViewCompare(constref Item1, Item2: TObject): Integer;
     341begin
     342  Result := ListViewSortCompare(Item1, Item2);
     343end;
     344
    274345procedure TListViewSort.Sort(Compare: TCompareEvent);
    275346begin
     347  // TODO: Because TFLGObjectList compare handler is not class method,
     348  // it is necessary to use simple function compare handler with local variable
     349  ListViewSortCompare := Compare;
    276350  if (List.Count > 0) then
    277     List.Sort(Compare);
     351    List.Sort(TComparer<TObject>.Construct(ListViewCompare));
    278352end;
    279353
    … …  
    281355begin
    282356  if Assigned(FOnFilter) then FOnFilter(Self)
    283   else if Assigned(Source) then
    284     List.Assign(Source) else
     357  else if Assigned(Source) then begin
    285358    List.Clear;
     359    List.AddRange(Source);
     360  end;
    286361  if ListView.Items.Count <> List.Count then
    287362    ListView.Items.Count := List.Count;
    … …  
    338413begin
    339414  inherited;
    340   List := TListObject.Create;
     415  List := TObjects.Create;
    341416  List.OwnsObjects := False;
    342417end;
    … …  
    344419destructor TListViewSort.Destroy;
    345420begin
    346   List.Free;
     421  FreeAndNil(List);
    347422  inherited;
    348423end;
    … …  
    353428  TP1: TPoint;
    354429  XBias, YBias: Integer;
    355   OldColor: TColor;
     430  PenColor: TColor;
     431  BrushColor: TColor;
    356432  BiasTop, BiasLeft: Integer;
    357433  Rect1: TRect;
    … …  
    365441  Item.Left := 0;
    366442  GetCheckBias(XBias, YBias, BiasTop, BiasLeft, ListView);
    367   OldColor := ListView.Canvas.Pen.Color;
     443  PenColor := ListView.Canvas.Pen.Color;
     444  BrushColor := ListView.Canvas.Brush.Color;
    368445  //TP1 := Item.GetPosition;
    369446  lRect := Item.DisplayRect(drBounds); // Windows 7 workaround
    … …  
    377454  ItemLeft := Item.Left;
    378455  ItemLeft := 23; // Windows 7 workaround
    379  
     456
    380457  Rect1.Left := ItemLeft - CheckWidth - BiasLeft + 1 + XBias;
    381458  //ShowMessage(IntToStr(Tp1.Y) + ', ' + IntToStr(BiasTop) + ', ' + IntToStr(XBias));
    … …  
    408485  end;
    409486  //ListView.Canvas.Brush.Color := ListView.Color;
    410   ListView.Canvas.Brush.Color := clWindow;
    411   ListView.Canvas.Pen.Color := OldColor;
     487  ListView.Canvas.Brush.Color := BrushColor;
     488  ListView.Canvas.Pen.Color := PenColor;
    412489end;
    413490
    … …  
    476553    FHeaderHandle := ListView_GetHeader(FListView.Handle);
    477554    for I := 0 to FListView.Columns.Count - 1 do begin
     555      {$push}{$warn 5057 off}
    478556      FillChar(Item, SizeOf(THDItem), 0);
     557      {$pop}
    479558      Item.Mask := HDI_FORMAT;
    480559      Header_GetItem(FHeaderHandle, I, Item);

  • trunk/Packages/Common/Memory.pas

    r20 r21  
    1 unit UMemory;
    2 
    3 {$mode Delphi}{$H+}
     1unit Memory;
    42
    53interface
    … …  
    2422    constructor Create;
    2523    destructor Destroy; override;
     24    procedure WriteMemory(Position: Integer; Memory: TMemory);
     25    procedure ReadMemory(Position: Integer; Memory: TMemory);
    2626    property Data: PByte read FData;
    2727    property Size: Integer read FSize write SetSize;
    … …  
    4242  end;
    4343
     44
    4445implementation
    4546
    … …  
    4849procedure TPositionMemory.SetSize(AValue: Integer);
    4950begin
    50   inherited SetSize(AValue);
     51  inherited;
    5152  if FPosition > FSize then FPosition := FSize;
    5253end;
    … …  
    105106begin
    106107  Size := 0;
    107   inherited Destroy;
     108  inherited;
     109end;
     110
     111procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
     112begin
     113  Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size);
     114end;
     115
     116procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
     117begin
     118  Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size);
    108119end;
    109120
    110121end.
    111 

  • trunk/Packages/Common/PersistentForm.pas

    r20 r21  
    1 unit UPersistentForm;
    2 
    3 {$mode delphi}
    4 
    5 // Date: 2015-04-18
     1unit PersistentForm;
    62
    73interface
    84
    95uses
    10   Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls;
     6  Classes, SysUtils, Forms, RegistryEx, LCLIntf, Registry, Controls, ComCtrls,
     7  ExtCtrls, LCLType;
    118
    129type
    … …  
    1916    FMinVisiblePart: Integer;
    2017    FRegistryContext: TRegistryContext;
     18    FResizeEventOccured: Boolean;
    2119    procedure LoadControl(Control: TControl);
    2220    procedure SaveControl(Control: TControl);
     21    procedure WindowStateChange(Sender: TObject);
    2322  public
    24     FormNormalSize: TRect;
    2523    FormRestoredSize: TRect;
    2624    FormWindowState: TWindowState;
     25    FormFullScreen: Boolean;
    2726    Form: TForm;
    2827    procedure LoadFromRegistry(RegistryContext: TRegistryContext);
    … …  
    3029    function CheckEntireVisible(Rect: TRect): TRect;
    3130    function CheckPartVisible(Rect: TRect; Part: Integer): TRect;
    32     procedure Load(Form: TForm; DefaultMaximized: Boolean = False);
     31    procedure Load(Form: TForm; DefaultMaximized: Boolean = False;
     32      DefaultFullScreen: Boolean = False);
    3333    procedure Save(Form: TForm);
    3434    constructor Create(AOwner: TComponent); override;
     35    procedure SetFullScreen(State: Boolean);
    3536    property RegistryContext: TRegistryContext read FRegistryContext
    3637      write FRegistryContext;
    … …  
    4243procedure Register;
    4344
     45
    4446implementation
    45 
    4647
    4748procedure Register;
    … …  
    5657  I: Integer;
    5758  WinControl: TWinControl;
    58   Count: Integer;
    5959begin
    6060  if Control is TListView then begin
    … …  
    7272  end;
    7373
     74  if (Control is TPanel) then begin
     75    with Form, TRegistryEx.Create do
     76    try
     77      RootKey := RegistryContext.RootKey;
     78      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     79      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     80        if ValueExists('Width') then
     81          TPanel(Control).Width := ReadInteger('Width');
     82      end;
     83      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     84        if ValueExists('Height') then
     85          TPanel(Control).Height := ReadInteger('Height');
     86      end;
     87    finally
     88      Free;
     89    end;
     90  end;
     91
    7492  if Control is TWinControl then begin
    7593    WinControl := TWinControl(Control);
    … …  
    96114      for I := 0 to TListView(Control).Columns.Count - 1 do begin
    97115        WriteInteger('ColWidth' + IntToStr(I), TListView(Control).Columns[I].Width);
     116      end;
     117    finally
     118      Free;
     119    end;
     120  end;
     121
     122  if (Control is TPanel) then begin
     123    with Form, TRegistryEx.Create do
     124    try
     125      RootKey := RegistryContext.RootKey;
     126      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     127      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     128        WriteInteger('Width', TPanel(Control).Width);
     129      end;
     130      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     131        WriteInteger('Height', TPanel(Control).Height);
    98132      end;
    99133    finally
    … …  
    120154    RootKey := RegistryContext.RootKey;
    121155    OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True);
    122     // Normal size
    123     FormNormalSize.Left := ReadIntegerWithDefault('NormalLeft', FormNormalSize.Left);
    124     FormNormalSize.Top := ReadIntegerWithDefault('NormalTop', FormNormalSize.Top);
    125     FormNormalSize.Right := ReadIntegerWithDefault('NormalWidth', FormNormalSize.Right - FormNormalSize.Left)
    126       + FormNormalSize.Left;
    127     FormNormalSize.Bottom := ReadIntegerWithDefault('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top)
    128       + FormNormalSize.Top;
     156
    129157    // Restored size
    130158    FormRestoredSize.Left := ReadIntegerWithDefault('RestoredLeft', FormRestoredSize.Left);
    … …  
    134162    FormRestoredSize.Bottom := ReadIntegerWithDefault('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top)
    135163      + FormRestoredSize.Top;
     164
    136165    // Other state
    137     FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(wsNormal)));
     166    FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(FormWindowState)));
     167    FormFullScreen := ReadBoolWithDefault('FullScreen', FormFullScreen);
    138168  finally
    139169    Free;
    … …  
    147177    RootKey := RegistryContext.RootKey;
    148178    OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True);
    149     // Normal state
    150     WriteInteger('NormalWidth', FormNormalSize.Right - FormNormalSize.Left);
    151     WriteInteger('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top);
    152     WriteInteger('NormalTop', FormNormalSize.Top);
    153     WriteInteger('NormalLeft', FormNormalSize.Left);
    154     // Restored state
     179
     180    // Restored size
    155181    WriteInteger('RestoredWidth', FormRestoredSize.Right - FormRestoredSize.Left);
    156182    WriteInteger('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top);
    157183    WriteInteger('RestoredTop', FormRestoredSize.Top);
    158184    WriteInteger('RestoredLeft', FormRestoredSize.Left);
     185
    159186    // Other state
    160187    WriteInteger('WindowState', Integer(FormWindowState));
     188    WriteBool('FullScreen', FormFullScreen);
    161189  finally
    162190    Free;
    … …  
    216244end;
    217245
    218 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False);
    219 var
    220   LoadDefaults: Boolean;
     246procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False;
     247  DefaultFullScreen: Boolean = False);
    221248begin
    222249  Self.Form := Form;
     250
    223251  // Set default
    224   FormNormalSize := Bounds((Screen.Width - Form.Width) div 2,
    225     (Screen.Height - Form.Height) div 2, Form.Width, Form.Height);
    226252  FormRestoredSize := Bounds((Screen.Width - Form.Width) div 2,
    227253    (Screen.Height - Form.Height) div 2, Form.Width, Form.Height);
     254  FormWindowState := Form.WindowState;
     255  FormFullScreen := DefaultFullScreen;
    228256
    229257  LoadFromRegistry(RegistryContext);
    230258
    231   if not EqualRect(FormNormalSize, FormRestoredSize) or
    232     (LoadDefaults and DefaultMaximized) then begin
     259  if (FormWindowState = wsMaximized) or DefaultMaximized then begin
    233260    // Restore to maximized state
    234261    Form.WindowState := wsNormal;
    … …  
    239266    // Restore to normal state
    240267    Form.WindowState := wsNormal;
    241     if FEntireVisible then FormNormalSize := CheckEntireVisible(FormNormalSize)
     268    if FEntireVisible then FormRestoredSize := CheckEntireVisible(FormRestoredSize)
    242269      else if FMinVisiblePart > 0 then
    243     FormNormalSize := CheckPartVisible(FormNormalSize, FMinVisiblePart);
    244     if not EqualRect(FormNormalSize, Form.BoundsRect) then
    245       Form.BoundsRect := FormNormalSize;
    246   end;
     270        FormRestoredSize := CheckPartVisible(FormRestoredSize, FMinVisiblePart);
     271    if not EqualRect(FormRestoredSize, Form.BoundsRect) then
     272      Form.BoundsRect := FormRestoredSize;
     273  end;
     274  if FormFullScreen then SetFullScreen(True);
    247275  LoadControl(Form);
    248276end;
    … …  
    251279begin
    252280  Self.Form := Form;
    253   FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height);
    254   FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
    255     Form.RestoredHeight);
    256   FormWindowState := Form.WindowState;
     281  if not FormFullScreen then begin
     282    FormWindowState := Form.WindowState;
     283    if FormWindowState = wsMaximized then begin
     284      FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     285        Form.RestoredHeight);
     286    end else
     287    if FormWindowState = wsNormal then begin
     288      FormRestoredSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height);
     289    end;
     290  end;
    257291  SaveToRegistry(RegistryContext);
    258292  SaveControl(Form);
    … …  
    268302end;
    269303
     304procedure TPersistentForm.SetFullScreen(State: Boolean);
     305{$IFDEF UNIX}
     306var
     307  OldHandler: TNotifyEvent;
     308var
     309  I: Integer;
     310{$ENDIF}
     311begin
     312  if State then begin
     313    FormFullScreen := True;
     314    if Form.WindowState = wsMaximized then begin
     315      FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     316        Form.RestoredHeight);
     317    end else
     318    if Form.WindowState = wsNormal then begin
     319      FormRestoredSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height);
     320    end;
     321    FormWindowState := Form.WindowState;
     322    {$IFDEF WINDOWS}
     323    Form.BorderStyle := bsNone;
     324    {$ENDIF}
     325    Form.WindowState := wsFullscreen;
     326    {$IFDEF UNIX}
     327    // Workaround on Linux, WindowState is rewriten by WMSize event to wsNormal.
     328    // We need for that even to occure
     329    OldHandler := Form.OnWindowStateChange;
     330    Form.OnWindowStateChange := WindowStateChange;
     331    FResizeEventOccured := False;
     332    for I := 0 to 10 do begin
     333      if FResizeEventOccured then Break;
     334      Application.ProcessMessages;
     335      Sleep(1);
     336    end;
     337    Form.OnWindowStateChange := OldHandler;
     338    FormFullScreen := True;
     339    {$ENDIF}
     340  end else begin
     341    FormFullScreen := False;
     342    Form.WindowState := wsNormal;
     343    {$IFDEF WINDOWS}
     344    Form.BorderStyle := bsSizeable;
     345    {$ENDIF}
     346    if FormWindowState = wsNormal then begin
     347      Form.WindowState := wsNormal;
     348      Form.BoundsRect := FormRestoredSize;
     349    end else
     350    if FormWindowState = wsMaximized then begin
     351      Form.BoundsRect := FormRestoredSize;
     352      Form.WindowState := wsMaximized;
     353    end;
     354  end;
     355end;
     356
     357procedure TPersistentForm.WindowStateChange(Sender: TObject);
     358begin
     359  Form.WindowState := wsFullscreen;
     360  FResizeEventOccured := True;
     361end;
     362
    270363end.
    271 

  • trunk/Packages/Common/Pool.pas

    r20 r21  
    1 unit UPool;
    2 
    3 {$mode Delphi}{$H+}
     1unit Pool;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, syncobjs, SpecializedList, UThreading;
     6  Classes, SysUtils, syncobjs, Generics.Collections, Threading;
    97
    108type
    … …  
    2220    function NewItemObject: TObject; virtual;
    2321  public
    24     Items: TListObject;
    25     FreeItems: TListObject;
     22    Items: TObjectList<TObject>;
     23    FreeItems: TObjectList<TObject>;
    2624    function Acquire: TObject; virtual;
    2725    procedure Release(Item: TObject); virtual;
    … …  
    5957  try
    6058    Lock.Acquire;
    61     inherited SetTotalCount(AValue);
     59    inherited;
    6260  finally
    6361    Lock.Release;
    … …  
    6967  try
    7068    Lock.Acquire;
    71     Result := inherited GetUsedCount;
     69    Result := inherited;
    7270  finally
    7371    Lock.Release;
    … …  
    9088      end;
    9189    end;
    92     Result := inherited Acquire;
     90    Result := inherited;
    9391  finally
    9492    Lock.Release;
    … …  
    10098  try
    10199    Lock.Acquire;
    102     inherited Release(Item);
     100    inherited;
    103101  finally
    104102    Lock.Release;
    … …  
    108106constructor TThreadedPool.Create;
    109107begin
    110   inherited Create;
     108  inherited;
    111109  Lock := TCriticalSection.Create;
    112110end;
    … …  
    115113begin
    116114  TotalCount := 0;
    117   Lock.Free;
    118   inherited Destroy;
     115  FreeAndNil(Lock);
     116  inherited;
    119117end;
    120118
    … …  
    185183begin
    186184  inherited;
    187   Items := TListObject.Create;
    188   FreeItems := TListObject.Create;
     185  Items := TObjectList<TObject>.Create;
     186  FreeItems := TObjectList<TObject>.Create;
    189187  FreeItems.OwnsObjects := False;
    190188  FReleaseEvent := TEvent.Create(nil, False, False, '');
    … …  
    201199
    202200end.
    203 

  • trunk/Packages/Common/PrefixMultiplier.pas

    r20 r21  
    1 unit UPrefixMultiplier;
     1unit PrefixMultiplier;
    22
    33// Date: 2010-06-01
    4 
    5 {$mode delphi}
    64
    75interface
    … …  
    2119  { TPrefixMultiplier }
    2220
    23   TPrefixMultiplier = class
     21  TPrefixMultiplier = class(TComponent)
    2422  private
    25     function TruncateDigits(Value:Double;Digits:Integer=3):Double;
     23    function TruncateDigits(Value: Double; Digits: Integer = 3): Double;
    2624  public
    2725    function Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef;
    … …  
    3331  (
    3432    (ShortText: 'y'; FullText: 'yocto'; Value: 1e-24),
    35           (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21),
     33    (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21),
    3634    (ShortText: 'a'; FullText: 'atto'; Value: 1e-18),
    3735    (ShortText: 'f'; FullText: 'femto'; Value: 1e-15),
    … …  
    5452  (
    5553    (ShortText: 'ys'; FullText: 'yocto'; Value: 1e-24),
    56           (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21),
     54    (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21),
    5755    (ShortText: 'as'; FullText: 'atto'; Value: 1e-18),
    5856    (ShortText: 'fs'; FullText: 'femto'; Value: 1e-15),
    … …  
    7270  );
    7371
     72procedure Register;
     73
     74
    7475implementation
     76
     77procedure Register;
     78begin
     79  RegisterComponents('Common', [TPrefixMultiplier]);
     80end;
    7581
    7682{ TPrefixMultiplier }
    … …  
    9298end;
    9399
    94 function TPrefixMultiplier.Add(Value:Double;PrefixMultipliers:TPrefixMultiplierDef
    95   ;UnitText:string;Digits:Integer):string;
     100function TPrefixMultiplier.Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef
     101  ; UnitText:string; Digits: Integer): string;
    96102var
    97103  I: Integer;
    … …  
    118124
    119125end.
    120 

  • trunk/Packages/Common/RegistryEx.pas

    r20 r21  
    1 unit URegistry;
    2 
    3 {$MODE Delphi}
     1unit RegistryEx;
    42
    53interface
    … …  
    97
    108type
    11   TRegistryRoot = (rrKeyClassesRoot = HKEY($80000000),
    12     rrKeyCurrentUser = HKEY($80000001),
    13     rrKeyLocalMachine = HKEY($80000002),
    14     rrKeyUsers = HKEY($80000003),
    15     rrKeyPerformanceData = HKEY($80000004),
    16     rrKeyCurrentConfig = HKEY($80000005),
    17     rrKeyDynData = HKEY($80000006));
     9  TRegistryRoot = (rrKeyClassesRoot, rrKeyCurrentUser, rrKeyLocalMachine,
     10    rrKeyUsers, rrKeyPerformanceData, rrKeyCurrentConfig, rrKeyDynData);
    1811
    1912  { TRegistryContext }
    … …  
    2215    RootKey: HKEY;
    2316    Key: string;
     17    class function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; static; overload;
     18    class function Create(RootKey: HKEY; Key: string): TRegistryContext; static; overload;
    2419    class operator Equal(A, B: TRegistryContext): Boolean;
    2520  end;
    … …  
    3227    procedure SetCurrentContext(AValue: TRegistryContext);
    3328  public
     29    function ReadChar(const Name: string): Char;
     30    procedure WriteChar(const Name: string; Value: Char);
    3431    function ReadBoolWithDefault(const Name: string;
    3532      DefaultValue: Boolean): Boolean;
    3633    function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer;
    3734    function ReadStringWithDefault(const Name: string; DefaultValue: string): string;
     35    function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char;
    3836    function ReadFloatWithDefault(const Name: string;
    3937      DefaultValue: Double): Double;
     38    function ReadDateTimeWithDefault(const Name: string; DefaultValue: TDateTime): TDateTime;
    4039    function DeleteKeyRecursive(const Key: string): Boolean;
    4140    function OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    … …  
    4342  end;
    4443
    45 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
     44const
     45  RegistryRootHKEY: array[TRegistryRoot] of HKEY = (HKEY_CLASSES_ROOT,
     46    HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA,
     47    HKEY_CURRENT_CONFIG, HKEY_DYN_DATA);
    4648
    4749
    4850implementation
    49 
    50 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
    51 begin
    52   Result.RootKey := RootKey;
    53   Result.Key := Key;
    54 end;
    5551
    5652{ TRegistryContext }
    … …  
    5955begin
    6056  Result := (A.Key = B.Key) and (A.RootKey = B.RootKey);
     57end;
     58
     59class function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext;
     60begin
     61  Result.RootKey := RegistryRootHKEY[RootKey];
     62  Result.Key := Key;
     63end;
     64
     65class function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext;
     66begin
     67  Result.RootKey := RootKey;
     68  Result.Key := Key;
    6169end;
    6270
    … …  
    8391end;
    8492
     93function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char
     94  ): Char;
     95begin
     96  if ValueExists(Name) then Result := ReadChar(Name)
     97    else begin
     98      WriteChar(Name, DefaultValue);
     99      Result := DefaultValue;
     100    end;
     101end;
     102
    85103function TRegistryEx.ReadFloatWithDefault(const Name: string;
    86104  DefaultValue: Double): Double;
    … …  
    89107    else begin
    90108      WriteFloat(Name, DefaultValue);
     109      Result := DefaultValue;
     110    end;
     111end;
     112
     113function TRegistryEx.ReadDateTimeWithDefault(const Name: string;
     114  DefaultValue: TDateTime): TDateTime;
     115begin
     116  if ValueExists(Name) then Result := ReadDateTime(Name)
     117    else begin
     118      WriteDateTime(Name, DefaultValue);
    91119      Result := DefaultValue;
    92120    end;
    … …  
    113141function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    114142begin
    115   {$IFDEF Linux}
    116   CloseKey;
     143  {$IFDEF UNIX}
     144  //CloseKey;
    117145  {$ENDIF}
    118   Result := inherited OpenKey(Key, CanCreate);
     146  Result := inherited;
    119147end;
    120148
    121149function TRegistryEx.GetCurrentContext: TRegistryContext;
    122150begin
    123   Result.Key := CurrentPath;
     151  Result.Key := String(CurrentPath);
    124152  Result.RootKey := RootKey;
    125153end;
    … …  
    129157  RootKey := AValue.RootKey;
    130158  OpenKey(AValue.Key, True);
     159end;
     160
     161function TRegistryEx.ReadChar(const Name: string): Char;
     162var
     163  S: string;
     164begin
     165  S := ReadString(Name);
     166  if Length(S) > 0 then Result := S[1]
     167    else Result := #0;
     168end;
     169
     170procedure TRegistryEx.WriteChar(const Name: string; Value: Char);
     171begin
     172  WriteString(Name, Value);
    131173end;
    132174

  • trunk/Packages/Common/ResetableThread.pas

    r20 r21  
    1 unit UResetableThread;
    2 
    3 {$mode Delphi}{$H+}
     1unit ResetableThread;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, syncobjs, UThreading, UPool;
     6  Classes, SysUtils, syncobjs, Threading, Pool;
    97
    108type
    … …  
    156154  FThread.Name := 'ResetableThread';
    157155  FThread.Parent := Self;
    158   FThread.Resume;
     156  FThread.Start;
    159157end;
    160158
    … …  
    167165  FreeAndNil(FStopEvent);
    168166  FreeAndNil(FLock);
    169   inherited Destroy;
     167  inherited;
    170168end;
    171169
    … …  
    286284constructor TThreadPool.Create;
    287285begin
    288   inherited Create;
     286  inherited;
    289287end;
    290288
    … …  
    293291  TotalCount := 0;
    294292  WaitForEmpty;
    295   inherited Destroy;
     293  inherited;
    296294end;
    297295
    298296end.
    299 

  • trunk/Packages/Common/ScaleDPI.pas

    r20 r21  
    1 unit UScaleDPI;
     1unit ScaleDPI;
    22
    33{ See: http://wiki.lazarus.freepascal.org/High_DPI }
    44
    5 {$mode delphi}{$H+}
    6 
    75interface
    86
    97uses
    10   Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls,
    11   Contnrs;
     8  Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils,
     9  Generics.Collections;
    1210
    1311type
     12  TControlDimensions = class;
    1413
    1514  { TControlDimension }
    … …  
    1817    BoundsRect: TRect;
    1918    FontHeight: Integer;
    20     Controls: TObjectList; // TList<TControlDimension>
     19    Controls: TControlDimensions;
    2120    // Class specifics
    2221    ButtonSize: TPoint; // TToolBar
    … …  
    2625    constructor Create;
    2726    destructor Destroy; override;
     27  end;
     28
     29  TControlDimensions = class(TObjectList<TControlDimension>)
    2830  end;
    2931
    … …  
    7375constructor TControlDimension.Create;
    7476begin
    75   Controls := TObjectList.Create;
     77  Controls := TControlDimensions.Create;
    7678end;
    7779
    … …  
    7981begin
    8082  FreeAndNil(Controls);
    81   inherited Destroy;
     83  inherited;
    8284end;
    8385
    … …  
    212214  TempBmp: TBitmap;
    213215  Temp: array of TBitmap;
    214   NewWidth, NewHeight: integer;
    215   I: Integer;
    216 begin
    217   NewWidth := ScaleX(ImgList.Width, FromDPI.X);
    218   NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
    219 
    220   SetLength(Temp, ImgList.Count);
    221   for I := 0 to ImgList.Count - 1 do
    222   begin
    223     TempBmp := TBitmap.Create;
    224     TempBmp.PixelFormat := pf32bit;
    225     ImgList.GetBitmap(I, TempBmp);
    226     Temp[I] := TBitmap.Create;
    227     Temp[I].SetSize(NewWidth, NewHeight);
    228     Temp[I].PixelFormat := pf32bit;
    229     Temp[I].TransparentColor := TempBmp.TransparentColor;
    230     //Temp[I].TransparentMode := TempBmp.TransparentMode;
    231     Temp[I].Transparent := True;
    232     Temp[I].Canvas.Brush.Style := bsSolid;
    233     Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
    234     Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
    235 
    236     if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
    237     Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
    238     TempBmp.Free;
    239   end;
    240 
    241   ImgList.Clear;
    242   ImgList.Width := NewWidth;
    243   ImgList.Height := NewHeight;
    244 
    245   for I := 0 to High(Temp) do
    246   begin
    247     ImgList.Add(Temp[I], nil);
    248     Temp[i].Free;
     216  NewWidth: Integer;
     217  NewHeight: Integer;
     218  I: Integer;
     219begin
     220  ImgList.BeginUpdate;
     221  try
     222    NewWidth := ScaleX(ImgList.Width, FromDPI.X);
     223    NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
     224
     225    Temp := nil;
     226    SetLength(Temp, ImgList.Count);
     227    for I := 0 to ImgList.Count - 1 do
     228    begin
     229      TempBmp := TBitmap.Create;
     230      try
     231        TempBmp.PixelFormat := pf32bit;
     232        ImgList.GetBitmap(I, TempBmp);
     233        Temp[I] := TBitmap.Create;
     234        Temp[I].SetSize(NewWidth, NewHeight);
     235        {$IFDEF UNIX}
     236        Temp[I].PixelFormat := pf24bit;
     237        {$ELSE}
     238        Temp[I].PixelFormat := pf32bit;
     239        {$ENDIF}
     240        Temp[I].TransparentColor := TempBmp.TransparentColor;
     241        //Temp[I].TransparentMode := TempBmp.TransparentMode;
     242        Temp[I].Transparent := True;
     243        Temp[I].Canvas.Brush.Style := bsSolid;
     244        Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
     245        Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
     246
     247        if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
     248        Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
     249      finally
     250        TempBmp.Free;
     251      end;
     252    end;
     253
     254    ImgList.Clear;
     255    ImgList.Width := NewWidth;
     256    ImgList.Height := NewHeight;
     257
     258    for I := 0 to High(Temp) do
     259    begin
     260      ImgList.Add(Temp[I], nil);
     261      Temp[i].Free;
     262    end;
     263  finally
     264    ImgList.EndUpdate;
    249265  end;
    250266end;
    … …  
    284300  WinControl: TWinControl;
    285301  ToolBarControl: TToolBar;
    286   OldAnchors: TAnchors;
    287   OldAutoSize: Boolean;
    288 begin
     302  //OldAnchors: TAnchors;
     303  //OldAutoSize: Boolean;
     304begin
     305  //if not (Control is TCustomPage) then
     306  // Resize childs first
     307  if Control is TWinControl then begin
     308    WinControl := TWinControl(Control);
     309    if WinControl.ControlCount > 0 then begin
     310      for I := 0 to WinControl.ControlCount - 1 do begin
     311        if WinControl.Controls[I] is TControl then begin
     312          ScaleControl(WinControl.Controls[I], FromDPI);
     313        end;
     314      end;
     315    end;
     316  end;
     317
    289318  //if Control is TMemo then Exit;
    290319  //if Control is TForm then
    … …  
    312341  with TCoolBar(Control) do begin
    313342    BeginUpdate;
    314     for I := 0 to Bands.Count - 1 do
    315       with Bands[I] do begin
    316         MinWidth := ScaleX(MinWidth, FromDPI.X);
    317         MinHeight := ScaleY(MinHeight, FromDPI.Y);
    318         Width := ScaleX(Width, FromDPI.X);
    319         //Control.Invalidate;
     343    try
     344      for I := 0 to Bands.Count - 1 do
     345        with Bands[I] do begin
     346          MinWidth := ScaleX(MinWidth, FromDPI.X);
     347          MinHeight := ScaleY(MinHeight, FromDPI.Y);
     348          // Workaround to bad band width auto sizing
     349          //Width := ScaleX(Width, FromDPI.X);
     350          Width := ScaleX(Control.Width + 28, FromDPI.X);
     351          //Control.Invalidate;
     352        end;
     353      // Workaround for bad autosizing of coolbar
     354      if AutoSize then begin
     355        AutoSize := False;
     356        Height := ScaleY(Height, FromDPI.Y);
     357        AutoSize := True;
    320358      end;
    321     EndUpdate;
     359    finally
     360      EndUpdate;
     361    end;
    322362  end;
    323363
    … …  
    330370  end;
    331371
    332   //if not (Control is TCustomPage) then
    333   if Control is TWinControl then begin
    334     WinControl := TWinControl(Control);
    335     if WinControl.ControlCount > 0 then begin
    336       for I := 0 to WinControl.ControlCount - 1 do begin
    337         if WinControl.Controls[I] is TControl then begin
    338           ScaleControl(WinControl.Controls[I], FromDPI);
    339         end;
    340       end;
    341     end;
    342   end;
    343372  //if Control is TForm then
    344373  //  Control.EnableAutoSizing;

  • trunk/Packages/Common/StopWatch.pas

    r6 r21  
    55
    66uses
    7   {$IFDEF Windows}Windows,{$ENDIF}
     7  {$IFDEF WINDOWS}Windows,{$ENDIF}
    88  SysUtils, DateUtils;
    99
    … …  
    1313  TStopWatch = class
    1414  private
    15     fFrequency : TLargeInteger;
    16     fIsRunning: Boolean;
    17     fIsHighResolution: Boolean;
    18     fStartCount, fStopCount : TLargeInteger;
    19     procedure SetTickStamp(var lInt : TLargeInteger) ;
     15    FFrequency: TLargeInteger;
     16    FIsRunning: Boolean;
     17    FIsHighResolution: Boolean;
     18    FStartCount, fStopCount: TLargeInteger;
     19    procedure SetTickStamp(var Value: TLargeInteger);
    2020    function GetElapsedTicks: TLargeInteger;
    2121    function GetElapsedMiliseconds: TLargeInteger;
    2222    function GetElapsed: string;
    2323  public
    24     constructor Create(const startOnCreate : Boolean = False) ;
     24    constructor Create(const StartOnCreate: Boolean = False) ;
    2525    procedure Start;
    2626    procedure Stop;
    27     property IsHighResolution : Boolean read fIsHighResolution;
    28     property ElapsedTicks : TLargeInteger read GetElapsedTicks;
    29     property ElapsedMiliseconds : TLargeInteger read GetElapsedMiliseconds;
    30     property Elapsed : string read GetElapsed;
    31     property IsRunning : Boolean read fIsRunning;
     27    property IsHighResolution: Boolean read FIsHighResolution;
     28    property ElapsedTicks: TLargeInteger read GetElapsedTicks;
     29    property ElapsedMiliseconds: TLargeInteger read GetElapsedMiliseconds;
     30    property Elapsed: string read GetElapsed;
     31    property IsRunning: Boolean read FIsRunning;
    3232  end;
     33
    3334
    3435implementation
    3536
    36 constructor TStopWatch.Create(const startOnCreate : boolean = false) ;
     37constructor TStopWatch.Create(const StartOnCreate: Boolean = False);
    3738begin
    38   inherited Create;
     39  FIsRunning := False;
    3940
    40   fIsRunning := False;
    41 
    42   {$IFDEF Windows}
     41  {$IFDEF WINDOWS}
    4342  fIsHighResolution := QueryPerformanceFrequency(fFrequency) ;
    4443  {$ELSE}
    45   fIsHighResolution := False;
     44  FIsHighResolution := False;
    4645  {$ENDIF}
    47   if NOT fIsHighResolution then fFrequency := MSecsPerSec;
     46  if NOT FIsHighResolution then FFrequency := MSecsPerSec;
    4847
    4948  if StartOnCreate then Start;
    … …  
    5251function TStopWatch.GetElapsedTicks: TLargeInteger;
    5352begin
    54   Result := fStopCount - fStartCount;
     53  Result := FStopCount - FStartCount;
    5554end;
    5655
    57 procedure TStopWatch.SetTickStamp(var lInt : TLargeInteger) ;
     56procedure TStopWatch.SetTickStamp(var Value: TLargeInteger);
    5857begin
    59   if fIsHighResolution then
     58  if FIsHighResolution then
    6059    {$IFDEF Windows}
    61     QueryPerformanceCounter(lInt)
     60    QueryPerformanceCounter(Value)
    6261    {$ELSE}
    6362    {$ENDIF}
    6463  else
    65     lInt := MilliSecondOf(Now) ;
     64    Value := MilliSecondOf(Now);
    6665end;
    6766
    6867function TStopWatch.GetElapsed: string;
    6968var
    70   dt: TDateTime;
     69  Elapsed: TDateTime;
    7170begin
    72   dt := ElapsedMiliseconds / MSecsPerSec / SecsPerDay;
    73   result := Format('%d days, %s', [Trunc(dt), FormatDateTime('hh:nn:ss.z', Frac(dt))]) ;
     71  Elapsed := ElapsedMiliseconds / MSecsPerSec / SecsPerDay;
     72  Result := Format('%d days, %s', [Trunc(Elapsed), FormatDateTime('hh:nn:ss.z', Frac(Elapsed))]) ;
    7473end;
    7574
    7675function TStopWatch.GetElapsedMiliseconds: TLargeInteger;
    7776begin
    78   Result := (MSecsPerSec * (fStopCount - fStartCount)) div fFrequency;
     77  Result := (MSecsPerSec * (fStopCount - FStartCount)) div FFrequency;
    7978end;
    8079
    8180procedure TStopWatch.Start;
    8281begin
    83   SetTickStamp(fStartCount);
    84   fIsRunning := True;
     82  SetTickStamp(FStartCount);
     83  FIsRunning := True;
    8584end;
    8685
    8786procedure TStopWatch.Stop;
    8887begin
    89   SetTickStamp(fStopCount);
    90   fIsRunning := False;
     88  SetTickStamp(FStopCount);
     89  FIsRunning := False;
    9190end;
    9291

  • trunk/Packages/Common/SyncCounter.pas

    r20 r21  
    1 unit USyncCounter;
    2 
    3 {$mode delphi}
     1unit SyncCounter;
    42
    53interface
    … …  
    2523    procedure Assign(Source: TSyncCounter);
    2624  end;
     25
    2726
    2827implementation
    … …  
    6968begin
    7069  Lock.Free;
    71   inherited Destroy;
     70  inherited;
    7271end;
    7372
    … …  
    7978
    8079end.
    81 

  • trunk/Packages/Common/Threading.pas

    r20 r21  
    1 unit UThreading;
    2 
    3 {$mode delphi}
     1unit Threading;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, Forms, Contnrs, SyncObjs;
     6  Classes, SysUtils, Forms, Generics.Collections, SyncObjs;
    97
    108type
    119  TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
    1210  TMethodCall = procedure of object;
    13 
    1411
    1512  { TVirtualThread }
    … …  
    2219    function GetSuspended: Boolean; virtual; abstract;
    2320    function GetTerminated: Boolean; virtual; abstract;
    24     function GetThreadId: Integer; virtual; abstract;
     21    function GetThreadId: TThreadID; virtual; abstract;
    2522    procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract;
    2623    procedure SetPriority(const AValue: TThreadPriority); virtual; abstract;
    … …  
    3027    Name: string;
    3128    procedure Execute; virtual; abstract;
    32     procedure Resume; virtual; abstract;
    33     procedure Suspend; virtual; abstract;
    3429    procedure Start; virtual; abstract;
    3530    procedure Terminate; virtual; abstract;
    … …  
    4439    property Terminated: Boolean read GetTerminated write SetTerminated;
    4540    property Finished: Boolean read GetFinished;
    46     property ThreadId: Integer read GetThreadId;
     41    property ThreadId: TThreadID read GetThreadId;
    4742  end;
    4843
    … …  
    7065    function GetSuspended: Boolean; override;
    7166    function GetTerminated: Boolean; override;
    72     function GetThreadId: Integer; override;
     67    function GetThreadId: TThreadID; override;
    7368    procedure SetFreeOnTerminate(const AValue: Boolean); override;
    7469    procedure SetPriority(const AValue: TThreadPriority); override;
    … …  
    8176    procedure Sleep(Delay: Integer); override;
    8277    procedure Execute; override;
    83     procedure Resume; override;
    84     procedure Suspend; override;
    8578    procedure Start; override;
    8679    procedure Terminate; override;
    … …  
    10699  { TThreadList }
    107100
    108   TThreadList = class(TObjectList)
    109     function FindById(Id: Integer): TVirtualThread;
     101  TThreadList = class(TObjectList<TVirtualThread>)
     102    function FindById(Id: TThreadID): TVirtualThread;
    110103    constructor Create; virtual;
    111104  end;
    … …  
    134127    Thread.FreeOnTerminate := False;
    135128    Thread.Method := Method;
    136     Thread.Resume;
     129    Thread.Start;
    137130    while (Thread.State = ttsRunning) or (Thread.State = ttsReady) do begin
    138131      if MainThreadID = ThreadID then Application.ProcessMessages;
    … …  
    155148    Thread.Method := Method;
    156149    Thread.OnFinished := CallBack;
    157     Thread.Resume;
     150    Thread.Start;
    158151    //if Thread.State = ttsExceptionOccured then
    159152    //  raise Exception.Create(Thread.ExceptionMessage);
    … …  
    168161  if MainThreadID = ThreadID then Method
    169162  else begin
    170     Thread := ThreadList.FindById(ThreadID);
     163    try
     164      ThreadListLock.Acquire;
     165      Thread := ThreadList.FindById(ThreadID);
     166    finally
     167      ThreadListLock.Release;
     168    end;
    171169    if Assigned(Thread) then begin
    172170      Thread.Synchronize(Method);
    … …  
    177175{ TThreadList }
    178176
    179 function TThreadList.FindById(Id: Integer): TVirtualThread;
     177function TThreadList.FindById(Id: TThreadID): TVirtualThread;
    180178var
    181179  I: Integer;
    182180begin
    183181  I := 0;
    184   while (I < ThreadList.Count) and (TVirtualThread(ThreadList[I]).ThreadID <> Id) do
     182  while (I < ThreadList.Count) and (ThreadList[I].ThreadID <> Id) do
    185183    Inc(I);
    186   if I < ThreadList.Count then Result := TVirtualThread(ThreadList[I])
     184  if I < ThreadList.Count then Result := ThreadList[I]
    187185    else Result := nil;
    188186end;
    … …  
    190188constructor TThreadList.Create;
    191189begin
    192   inherited Create;
     190  inherited;
    193191end;
    194192
    … …  
    237235end;
    238236
    239 function TListedThread.GetThreadId: Integer;
     237function TListedThread.GetThreadId: TThreadID;
    240238begin
    241239  Result := FThread.ThreadID;
    … …  
    293291    ThreadListLock.Release;
    294292  end;
    295   FThread.Free;
    296   inherited Destroy;
     293  FreeAndNil(FThread);
     294  inherited;
    297295end;
    298296
    … …  
    313311procedure TListedThread.Execute;
    314312begin
    315 end;
    316 
    317 procedure TListedThread.Resume;
    318 begin
    319   FThread.Resume;
    320 end;
    321 
    322 procedure TListedThread.Suspend;
    323 begin
    324   FThread.Suspend;
    325313end;
    326314
    … …  
    374362finalization
    375363
    376 ThreadList.Free;
    377 ThreadListLock.Free;
     364FreeAndNil(ThreadList);
     365FreeAndNil(ThreadListLock);
    378366
    379367end.
    380 

  • trunk/Packages/Common/URI.pas

    r20 r21  
    1 unit UURI;
     1unit URI;
    22
    33// Date: 2011-04-04
    4 
    5 {$mode delphi}
    64
    75interface
    … …  
    8583  end;
    8684
     85
    8786implementation
    8887
    8988function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    9089var
    91   I, J: Integer;
     90  I: Integer;
    9291  Matched: Boolean;
    9392begin
    … …  
    113112function RightCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    114113var
    115   I, J: Integer;
     114  I: Integer;
    116115  Matched: Boolean;
    117116begin
    … …  
    183182begin
    184183  Items.Free;
    185   inherited Destroy;
     184  inherited;
    186185end;
    187186
    … …  
    202201
    203202procedure TURI.SetAsString(Value: string);
    204 var
    205   HostAddr: string;
    206   HostPort: string;
    207203begin
    208204  LeftCutString(Value, Scheme, ':');
    … …  
    235231begin
    236232  Path.Free;
    237   inherited Destroy;
     233  inherited;
    238234end;
    239235
    … …  
    246242    Fragment := TURI(Source).Fragment;
    247243    Query := TURI(Source).Query;
    248   end else inherited Assign(Source);
     244  end else inherited;
    249245end;
    250246
    … …  
    294290destructor TURL.Destroy;
    295291begin
    296   inherited Destroy;
     292  inherited;
    297293end;
    298294
    … …  
    347343begin
    348344  Directory.Free;
    349   inherited Destroy;
    350 end;
    351 
     345  inherited;
     346end;
    352347
    353348end.
    354 

  • trunk/Packages/Common/XML.pas

    r20 r21  
    1 unit UXMLUtils;
    2 
    3 {$mode delphi}
     1unit XML;
    42
    53interface
    … …  
    75uses
    86  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils, XMLRead, XMLWrite, DOM;
     7  Classes, SysUtils, DateUtils, DOM, xmlread;
    108
    119function XMLTimeToDateTime(XMLDateTime: string): TDateTime;
    12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     10function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    1311procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
    1412procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
    … …  
    1614procedure WriteString(Node: TDOMNode; Name: string; Value: string);
    1715procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime);
     16procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double);
    1817function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer;
    1918function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64;
    … …  
    2120function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
    2221function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
     22function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double;
     23procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
    2324
    2425
    2526implementation
     27
     28function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double;
     29var
     30  NewNode: TDOMNode;
     31begin
     32  Result := DefaultValue;
     33  NewNode := Node.FindNode(DOMString(Name));
     34  if Assigned(NewNode) then
     35    Result := StrToFloat(string(NewNode.TextContent));
     36end;
     37
     38procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
     39var
     40  Parser: TDOMParser;
     41  Src: TXMLInputSource;
     42  InFile: TFileStream;
     43begin
     44  try
     45    InFile := TFileStream.Create(FileName, fmOpenRead);
     46    Src := TXMLInputSource.Create(InFile);
     47    Parser := TDOMParser.Create;
     48    Parser.Options.PreserveWhitespace := True;
     49    Parser.Parse(Src, Doc);
     50  finally
     51    Src.Free;
     52    Parser.Free;
     53    InFile.Free;
     54  end;
     55end;
    2656
    2757function GetTimeZoneBias: Integer;
    … …  
    3060  TimeZoneInfo: TTimeZoneInformation;
    3161begin
     62  {$push}{$warn 5057 off}
    3263  case GetTimeZoneInformation(TimeZoneInfo) of
    33   TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
    34   TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
     64    TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
     65    TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
    3566  else
    3667    Result := 0;
    3768  end;
     69  {$pop}
    3870end;
    3971{$ELSE}
    … …  
    4577function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    4678var
    47   I, J: Integer;
     79  I: Integer;
    4880  Matched: Boolean;
    4981begin
    … …  
    99131      if Pos('Z', XMLDateTime) > 0 then
    100132        LeftCutString(XMLDateTime, Part, 'Z');
    101       SecondFraction := StrToFloat('0' + DecimalSeparator + Part);
     133      SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part);
    102134      Millisecond := Trunc(SecondFraction * 1000);
    103135    end else begin
    … …  
    118150end;
    119151
    120 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     152function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    121153const
    122154  Neg: array[Boolean] of string =  ('+', '-');
    … …  
    139171  NewNode: TDOMNode;
    140172begin
    141   NewNode := Node.OwnerDocument.CreateElement(Name);
    142   NewNode.TextContent := IntToStr(Value);
     173  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     174  NewNode.TextContent := DOMString(IntToStr(Value));
    143175  Node.AppendChild(NewNode);
    144176end;
    … …  
    148180  NewNode: TDOMNode;
    149181begin
    150   NewNode := Node.OwnerDocument.CreateElement(Name);
    151   NewNode.TextContent := IntToStr(Value);
     182  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     183  NewNode.TextContent := DOMString(IntToStr(Value));
    152184  Node.AppendChild(NewNode);
    153185end;
    … …  
    157189  NewNode: TDOMNode;
    158190begin
    159   NewNode := Node.OwnerDocument.CreateElement(Name);
    160   NewNode.TextContent := BoolToStr(Value);
     191  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     192  NewNode.TextContent := DOMString(BoolToStr(Value));
    161193  Node.AppendChild(NewNode);
    162194end;
    … …  
    166198  NewNode: TDOMNode;
    167199begin
    168   NewNode := Node.OwnerDocument.CreateElement(Name);
    169   NewNode.TextContent := Value;
     200  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     201  NewNode.TextContent := DOMString(Value);
    170202  Node.AppendChild(NewNode);
    171203end;
    … …  
    175207  NewNode: TDOMNode;
    176208begin
    177   NewNode := Node.OwnerDocument.CreateElement(Name);
    178   NewNode.TextContent := DateTimeToXMLTime(Value);
     209  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     210  NewNode.TextContent := DOMString(DateTimeToXMLTime(Value));
     211  Node.AppendChild(NewNode);
     212end;
     213
     214procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double);
     215var
     216  NewNode: TDOMNode;
     217begin
     218  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     219  NewNode.TextContent := DOMString(FloatToStr(Value));
    179220  Node.AppendChild(NewNode);
    180221end;
    … …  
    185226begin
    186227  Result := DefaultValue;
    187   NewNode := Node.FindNode(Name);
    188   if Assigned(NewNode) then
    189     Result := StrToInt(NewNode.TextContent);
     228  NewNode := Node.FindNode(DOMString(Name));
     229  if Assigned(NewNode) then
     230    Result := StrToInt(string(NewNode.TextContent));
    190231end;
    191232
    … …  
    195236begin
    196237  Result := DefaultValue;
    197   NewNode := Node.FindNode(Name);
    198   if Assigned(NewNode) then
    199     Result := StrToInt64(NewNode.TextContent);
     238  NewNode := Node.FindNode(DOMString(Name));
     239  if Assigned(NewNode) then
     240    Result := StrToInt64(string(NewNode.TextContent));
    200241end;
    201242
    … …  
    205246begin
    206247  Result := DefaultValue;
    207   NewNode := Node.FindNode(Name);
    208   if Assigned(NewNode) then
    209     Result := StrToBool(NewNode.TextContent);
     248  NewNode := Node.FindNode(DOMString(Name));
     249  if Assigned(NewNode) then
     250    Result := StrToBool(string(NewNode.TextContent));
    210251end;
    211252
    … …  
    215256begin
    216257  Result := DefaultValue;
    217   NewNode := Node.FindNode(Name);
    218   if Assigned(NewNode) then
    219     Result := NewNode.TextContent;
     258  NewNode := Node.FindNode(DOMString(Name));
     259  if Assigned(NewNode) then
     260    Result := string(NewNode.TextContent);
    220261end;
    221262
    … …  
    226267begin
    227268  Result := DefaultValue;
    228   NewNode := Node.FindNode(Name);
    229   if Assigned(NewNode) then
    230     Result := XMLTimeToDateTime(NewNode.TextContent);
     269  NewNode := Node.FindNode(DOMString(Name));
     270  if Assigned(NewNode) then
     271    Result := XMLTimeToDateTime(string(NewNode.TextContent));
    231272end;
    232273
    233274end.
    234 

  • trunk/UCore.pas

    r20 r21  
    77uses
    88  Classes, SysUtils, XMLConf, LazFileUtils, ActnList, Controls, UVCS, UProject,
    9   ULastOpenedList, Forms, Dialogs, Menus, Contnrs, UBackend;
     9  LastOpenedList, Forms, Dialogs, Menus, Contnrs, UBackend;
    1010
    1111type

  • trunk/Units/UProject.pas

    r19 r21  
    66
    77uses
    8   Classes, SysUtils, UVCS, UBackend, Contnrs, DOM, XMLRead, XMLWrite, UXMLUtils,
     8  Classes, SysUtils, UVCS, UBackend, Contnrs, DOM, XMLRead, XMLWrite, XML,
    99  LazFileUtils;
    1010

  • trunk/VCSCommander.lpi

    r20 r21  
    4646            <Debugging>
    4747              <GenerateDebugInfo Value="False"/>
     48              <DebugInfoType Value="dsDwarf3"/>
    4849            </Debugging>
    4950            <LinkSmart Value="True"/>
    … …  
    7172      </Modes>
    7273    </RunParams>
    73     <RequiredPackages Count="4">
     74    <RequiredPackages Count="3">
    7475      <Item1>
    75         <PackageName Value="TemplateGenerics"/>
    76         <DefaultFilename Value="Packages/TemplateGenerics/TemplateGenerics.lpk" Prefer="True"/>
     76        <PackageName Value="FCL"/>
    7777      </Item1>
    7878      <Item2>
    79         <PackageName Value="FCL"/>
     79        <PackageName Value="Common"/>
     80        <DefaultFilename Value="Packages/Common/Common.lpk" Prefer="True"/>
    8081      </Item2>
    8182      <Item3>
    82         <PackageName Value="Common"/>
    83         <DefaultFilename Value="Packages/Common/Common.lpk" Prefer="True"/>
     83        <PackageName Value="LCL"/>
    8484      </Item3>
    85       <Item4>
    86         <PackageName Value="LCL"/>
    87       </Item4>
    8885    </RequiredPackages>
    8986    <Units Count="19">

  • trunk/VCSCommander.lpr

    r20 r21  
    88  {$ENDIF}
    99  Interfaces, // this includes the LCL widgetset
    10   Forms, UFormMain, UCore, Common, TemplateGenerics, UFormBrowse, UVCS,
     10  Forms, UFormMain, UCore, Common, UFormBrowse, UVCS,
    1111  UFormFavorites, UFormSettings, UFormConsole, USubversion, UProject, SysUtils,
    1212  UFormCommit, UFormCheckout, UBazaar, UBackend, UFormLog, UFormTest,
Note: See TracChangeset for help on using the changeset viewer.