Changeset 21 for trunk/Packages


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

Legend:

Unmodified
Added
Removed

  • 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 
Note: See TracChangeset for help on using the changeset viewer.