Changeset 59 for trunk/Packages

Timestamp:

Dec 3, 2014, 9:09:42 PM (10 years ago)

Author:

chronos

Message:

• Added: Support for high DPI screens. If not detected automatically correctly then user can specify desired values.
• Updated: Common package to newer version.

Location:

trunk/Packages/Common

Files:

• Common.lpk (modified) (3 diffs)
• Common.pas (modified) (2 diffs)
• Languages/UFindFile.po (added)
• UApplicationInfo.pas (modified) (1 diff)
• UCommon.pas (modified) (3 diffs)
• UDebugLog.pas (modified) (3 diffs)
• UFindFile.pas (modified) (1 diff)
• UJobProgressView.lfm (modified) (3 diffs)
• UJobProgressView.pas (modified) (13 diffs)
• ULastOpenedList.pas (modified) (7 diffs)
• UListViewSort.pas (added)
• UMemory.pas (modified) (2 diffs)
• UPersistentForm.pas (added)
• URegistry.pas (modified) (5 diffs)
• UResetableThread.pas (modified) (2 diffs)
• UScaleDPI.pas (added)
• USyncCounter.pas (added)
• UURI.pas (modified) (1 diff)

trunk/Packages/Common/Common.lpk

@@ -1 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <Package Version="4">
@@ -12 +12 @@
         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
       </SearchPaths>
-      <Other>
-        <CompilerMessages>
-          <UseMsgFile Value="True"/>
-        </CompilerMessages>
-        <CompilerPath Value="$(CompPath)"/>
-      </Other>
     </CompilerOptions>
     <Description Value="Various libraries"/>
     <License Value="GNU/GPL"/>
     <Version Minor="7"/>
-    <Files Count="15">
+    <Files Count="20">
       <Item1>
         <Filename Value="StopWatch.pas"/>
@@ -87 +81 @@
         <UnitName Value="UApplicationInfo"/>
       </Item15>
+      <Item16>
+        <Filename Value="USyncCounter.pas"/>
+        <UnitName Value="USyncCounter"/>
+      </Item16>
+      <Item17>
+        <Filename Value="UListViewSort.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="UListViewSort"/>
+      </Item17>
+      <Item18>
+        <Filename Value="UPersistentForm.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="UPersistentForm"/>
+      </Item18>
+      <Item19>
+        <Filename Value="UFindFile.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="UFindFile"/>
+      </Item19>
+      <Item20>
+        <Filename Value="UScaleDPI.pas"/>
+        <UnitName Value="UScaleDPI"/>
+      </Item20>
     </Files>
     <i18n>

trunk/Packages/Common/Common.pas

@@ -10 +10 @@
   StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading, 
   UMemory, UResetableThread, UPool, ULastOpenedList, URegistry, 
-  UJobProgressView, UXMLUtils, UApplicationInfo, LazarusPackageIntf;
+  UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort, 
+  UPersistentForm, UFindFile, UScaleDPI, LazarusPackageIntf;
 
 implementation
@@ -20 +21 @@
   RegisterUnit('UJobProgressView', @UJobProgressView.Register);
   RegisterUnit('UApplicationInfo', @UApplicationInfo.Register);
+  RegisterUnit('UListViewSort', @UListViewSort.Register);
+  RegisterUnit('UPersistentForm', @UPersistentForm.Register);
+  RegisterUnit('UFindFile', @UFindFile.Register);
 end;
 

trunk/Packages/Common/UApplicationInfo.pas

@@ -55 +55 @@
 procedure Register;
 begin
-  RegisterComponents('Samples', [TApplicationInfo]);
+  RegisterComponents('Common', [TApplicationInfo]);
 end;
 

trunk/Packages/Common/UCommon.pas

@@ -48 +48 @@
 function LoggedOnUserNameEx(Format: TUserNameFormat): string;
 function SplitString(var Text: string; Count: Word): string;
+function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
 function GetBit(Variable: QWord; Index: Byte): Boolean;
+procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
 procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
 procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
@@ -336 +338 @@
 end;
 
+function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
+var
+  I: Integer;
+begin
+  Result := 0;
+  for I := 0 to MaxIndex - 1 do
+    if ((Variable shr I) and 1) = 1 then Inc(Result);
+end;
+
 function GetBit(Variable:QWord;Index:Byte):Boolean;
 begin
@@ -341 +352 @@
 end;
 
+procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean);
+begin
+  Variable := (Variable and ((1 shl Index) xor High(QWord))) or (Int64(State) shl Index);
+end;
+
 procedure SetBit(var Variable:QWord;Index:Byte;State:Boolean); overload;
 begin
-  Variable := (Variable and ((1 shl Index) xor QWord($ffffffffffffffff))) or (QWord(State) shl Index);
+  Variable := (Variable and ((1 shl Index) xor High(QWord))) or (QWord(State) shl Index);
 end;
 
 procedure SetBit(var Variable:Cardinal;Index:Byte;State:Boolean); overload;
 begin
-  Variable := (Variable and ((1 shl Index) xor Cardinal($ffffffff))) or (Cardinal(State) shl Index);
+  Variable := (Variable and ((1 shl Index) xor High(Cardinal))) or (Cardinal(State) shl Index);
 end;
 
 procedure SetBit(var Variable:Word;Index:Byte;State:Boolean); overload;
 begin
-  Variable := (Variable and ((1 shl Index) xor Word($ffff))) or (Word(State) shl Index);
+  Variable := (Variable and ((1 shl Index) xor High(Word))) or (Word(State) shl Index);
 end;
 

trunk/Packages/Common/UDebugLog.pas

@@ -31 +31 @@
     Items: TListObject;
     Lock: TCriticalSection;
-    procedure Add(Group: string; Text: string);
+    procedure Add(Text: string; Group: string = '');
     procedure WriteToFile(Text: string);
     constructor Create(AOwner: TComponent); override;
@@ -52 +52 @@
 procedure Register;
 begin
-  RegisterComponents('Samples', [TDebugLog]);
+  RegisterComponents('Common', [TDebugLog]);
 end;
 
@@ -69 +69 @@
 end;
 
-procedure TDebugLog.Add(Group: string; Text: string);
+procedure TDebugLog.Add(Text: string; Group: string = '');
 var
   NewItem: TDebugLogItem;

trunk/Packages/Common/UFindFile.pas

@@ -64 +64 @@
 procedure Register;
 begin
-  RegisterComponents('Samples', [TFindFile]);
+  RegisterComponents('Common', [TFindFile]);
 end;
 

trunk/Packages/Common/UJobProgressView.lfm

@@ -28 +28 @@
     object LabelOperation: TLabel
       Left = 8
-      Height = 14
+      Height = 13
       Top = 8
-      Width = 67
+      Width = 66
       Caption = 'Operations:'
       Font.Height = -11
@@ -80 +80 @@
     object LabelEstimatedTimePart: TLabel
       Left = 8
-      Height = 14
+      Height = 13
       Top = -2
-      Width = 72
+      Width = 71
       Caption = 'Estimated time:'
       ParentColor = False
@@ -132 +132 @@
     object LabelEstimatedTimeTotal: TLabel
       Left = 8
-      Height = 14
+      Height = 13
       Top = 0
-      Width = 98
+      Width = 97
       Caption = 'Total estimated time:'
       ParentColor = False

trunk/Packages/Common/UJobProgressView.pas

@@ -111 +111 @@
     Finished: Boolean;
     FOnJobFinish: TJobProgressViewMethod;
+    FOnOwnerDraw: TNotifyEvent;
+    FOwnerDraw: Boolean;
     FShowDelay: Integer;
     FTerminate: Boolean;
@@ -116 +118 @@
     TotalStartTime: TDateTime;
     Log: TStringList;
-    Form: TFormJobProgressView;
     procedure SetTerminate(const AValue: Boolean);
     procedure UpdateProgress;
@@ -122 +123 @@
     procedure StartJobs;
     procedure UpdateHeight;
+    procedure JobProgressChange(Sender: TObject);
   public
+    Form: TFormJobProgressView;
     Jobs: TObjectList; // TListObject<TJob>
     CurrentJob: TJob;
@@ -136 +139 @@
     property Terminate: Boolean read FTerminate write SetTerminate;
   published
+    property OwnerDraw: Boolean read FOwnerDraw write FOwnerDraw;
     property ShowDelay: Integer read FShowDelay write FShowDelay;
     property AutoClose: Boolean read FAutoClose write FAutoClose;
     property OnJobFinish: TJobProgressViewMethod read FOnJobFinish
       write FOnJobFinish;
+    property OnOwnerDraw: TNotifyEvent read FOnOwnerDraw
+      write FOnOwnerDraw;
   end;
 
@@ -163 +169 @@
 procedure Register;
 begin
-  RegisterComponents('Samples', [TJobProgressView]);
+  RegisterComponents('Common', [TJobProgressView]);
 end;
 
@@ -196 +202 @@
   NewJob.Progress.Max := 100;
   NewJob.Progress.Reset;
+  NewJob.Progress.OnChange := JobProgressChange;
   Jobs.Add(NewJob);
   //ReloadJobList;
@@ -212 +219 @@
   Terminate := False;
 
-  Form.BringToFront;
+  if not OwnerDraw then Form.BringToFront;
 
   Finished := False;
@@ -244 +251 @@
       CurrentJobIndex := I;
       CurrentJob := TJob(Jobs[I]);
+      JobProgressChange(Self);
       StartTime := Now;
       Form.LabelEstimatedTimePart.Caption := Format(SEstimatedTime, ['']);
@@ -339 +347 @@
 end;
 
+procedure TJobProgressView.JobProgressChange(Sender: TObject);
+begin
+  if Assigned(FOnOwnerDraw) then
+    FOnOwnerDraw(Self);
+end;
+
 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
 var
@@ -357 +371 @@
   if not Visible then begin
     TimerUpdate.Interval := UpdateInterval;
-    Show;
+    if not JobProgressView.OwnerDraw then Show;
   end;
 end;
@@ -509 +523 @@
 destructor TJobProgressView.Destroy;
 begin
-  Log.Free;
-  Jobs.Free;
-  inherited Destroy;
+  FreeAndNil(Log);
+  FreeAndNil(Jobs);
+  inherited;
 end;
 
@@ -519 +533 @@
     FLock.Acquire;
     FMax := AValue;
+    if FMax < 1 then FMax := 1;
     if FValue >= FMax then FValue := FMax;
   finally
@@ -610 +625 @@
 begin
   Progress.Free;
-  inherited Destroy;
+  inherited;
 end;
 

trunk/Packages/Common/ULastOpenedList.pas

@@ -6 +6 @@
 
 uses
-  Classes, SysUtils, Registry, URegistry, Menus;
+  Classes, SysUtils, Registry, URegistry, Menus, XMLConf;
 
 type
@@ -18 +18 @@
     procedure SetMaxCount(AValue: Integer);
     procedure LimitMaxCount;
+    procedure ItemsChange(Sender: TObject);
+    procedure DoChange;
   public
     Items: TStringList;
@@ -25 +27 @@
     procedure LoadFromRegistry(Context: TRegistryContext);
     procedure SaveToRegistry(Context: TRegistryContext);
+    procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string);
+    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
     procedure AddItem(FileName: string);
   published
@@ -38 +42 @@
 procedure Register;
 begin
-  RegisterComponents('Samples', [TLastOpenedList]);
+  RegisterComponents('Common', [TLastOpenedList]);
 end;
 
@@ -58 +62 @@
 end;
 
+procedure TLastOpenedList.ItemsChange(Sender: TObject);
+begin
+  DoChange;
+end;
+
+procedure TLastOpenedList.DoChange;
+begin
+  if Assigned(FOnChange) then
+    FOnChange(Self);
+end;
+
 constructor TLastOpenedList.Create(AOwner: TComponent);
 begin
   inherited;
   Items := TStringList.Create;
+  Items.OnChange := ItemsChange;
   MaxCount := 10;
 end;
@@ -129 +145 @@
 end;
 
+procedure TLastOpenedList.LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string
+  );
+var
+  I: Integer;
+  Value: string;
+  Count: Integer;
+begin
+  with XMLConfig do begin
+    Count := GetValue(Path + '/Count', 0);
+    if Count > MaxCount then Count := MaxCount;
+    Items.Clear;
+    for I := 0 to Count - 1 do begin
+      Value := GetValue(Path + '/File' + IntToStr(I), '');
+      if Trim(Value) <> '' then Items.Add(Value);
+    end;
+    if Assigned(FOnChange) then
+      FOnChange(Self);
+  end;
+end;
+
+procedure TLastOpenedList.SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
+var
+  I: Integer;
+begin
+  with XMLConfig do begin
+    SetValue(Path + '/Count', Items.Count);
+    for I := 0 to Items.Count - 1 do
+      SetValue(Path + '/File' + IntToStr(I), Items[I]);
+    Flush;
+  end;
+end;
+
 procedure TLastOpenedList.AddItem(FileName:string);
 begin
@@ -134 +182 @@
   Items.Insert(0, FileName);
   LimitMaxCount;
-  if Assigned(FOnChange) then
-    FOnChange(Self);
+  DoChange;
 end;
 

trunk/Packages/Common/UMemory.pas

@@ -24 +24 @@
     constructor Create;
     destructor Destroy; override;
-    procedure WriteMemory(Position: Integer; Memory: TMemory);
-    procedure ReadMemory(Position: Integer; Memory: TMemory);
     property Data: PByte read FData;
     property Size: Integer read FSize write SetSize;
@@ -110 +108 @@
 end;
 
-procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
-begin
-  Move(Memory.FData, PByte(@FData + Position)^, Memory.Size);
-end;
-
-procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
-begin
-  Move(PByte(@FData + Position)^, Memory.FData, Memory.Size);
-end;
-
 end.
 

trunk/Packages/Common/URegistry.pas

@@ -17 +17 @@
     rrKeyDynData = HKEY($80000006));
 
+  { TRegistryContext }
+
   TRegistryContext = record
     RootKey: HKEY;
     Key: string;
+    class operator Equal(A, B: TRegistryContext): Boolean;
   end;
 
@@ -26 +29 @@
   TRegistryEx = class(TRegistry)
   private
+    function GetCurrentContext: TRegistryContext;
+    procedure SetCurrentContext(AValue: TRegistryContext);
   public
     function ReadBoolWithDefault(const Name: string;
@@ -35 +40 @@
     function DeleteKeyRecursive(const Key: string): Boolean;
     function OpenKey(const Key: string; CanCreate: Boolean): Boolean;
+    property CurrentContext: TRegistryContext read GetCurrentContext write SetCurrentContext;
   end;
 
@@ -46 +52 @@
   Result.RootKey := RootKey;
   Result.Key := Key;
+end;
+
+{ TRegistryContext }
+
+class operator TRegistryContext.Equal(A, B: TRegistryContext): Boolean;
+begin
+  Result := (A.Key = B.Key) and (A.RootKey = B.RootKey);
 end;
 
@@ -106 +119 @@
 end;
 
+function TRegistryEx.GetCurrentContext: TRegistryContext;
+begin
+  Result.Key := CurrentPath;
+  Result.RootKey := RootKey;
+end;
+
+procedure TRegistryEx.SetCurrentContext(AValue: TRegistryContext);
+begin
+  RootKey := AValue.RootKey;
+  OpenKey(AValue.Key, True);
+end;
+
 function TRegistryEx.ReadBoolWithDefault(const Name: string;
   DefaultValue: Boolean): Boolean;

trunk/Packages/Common/UResetableThread.pas

@@ -104 +104 @@
 
 procedure TResetableThread.WaitForStart;
-var
-  WaitResult: TWaitResult;
+//var
+//  WaitResult: TWaitResult;
 begin
   //try
@@ -127 +127 @@
 
 procedure TResetableThread.WaitForStop;
-var
-  WaitState: TWaitResult;
+//var
+//  WaitState: TWaitResult;
 begin
   try

trunk/Packages/Common/UURI.pas

@@ -326 +326 @@
     Drive := Drive + DriveSeparator;
   end else Drive := '';
-  Directory.AsString := AValue;
+  if (Drive <> '') and (AValue = '') then
+    Directory.AsString := Directory.DirSeparator
+    else Directory.AsString := AValue;
 end;