Added changes from Lazarus 3.0

Demos/Minimal/Main.lfm

@@ -28,23 +28,28 @@ object MainForm: TMainForm
     Colors.HotColor = clBlack
     DefaultText = 'Node'
     Header.AutoSizeIndex = -1
-    Header.Columns = <>
     Header.DefaultHeight = 17
     Header.Font.Height = -11
     Header.Font.Name = 'MS Sans Serif'
     Header.MainColumn = -1
-    Header.Options = [hoColumnResize, hoDrag]
+    Header.Options = [hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible]
+    HintAnimation = hatNone
     IncrementalSearch = isAll
     RootNodeCount = 100
     TabOrder = 0
     TreeOptions.AnimationOptions = [toAnimatedToggle]
-    TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking]
     TreeOptions.MiscOptions = [toEditable, toInitOnSave, toToggleOnDblClick, toWheelPanning]
     TreeOptions.PaintOptions = [toShowButtons, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages]
-    TreeOptions.SelectionOptions = [toMultiSelect, toCenterScrollIntoView]
+    TreeOptions.SelectionOptions = [toMultiSelect]
     OnFreeNode = VSTFreeNode
     OnGetText = VSTGetText
     OnInitNode = VSTInitNode
+    Columns = <
+      item
+        Position = 0
+        Width = 300
+        WideText = 'Name'
+      end>
   end
   object ClearButton: TButton
     Left = 97

Demos/dragdrop/fmain.lfm

@@ -17,9 +17,7 @@ object MainForm: TMainForm
     DragMode = dmAutomatic
     DragType = dtVCL
     Header.AutoSizeIndex = 0
-    Header.Columns = <>
     Header.DefaultHeight = 17
-    Header.MainColumn = -1
     RootNodeCount = 30
     TabOrder = 0
     TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
@@ -29,6 +27,19 @@ object MainForm: TMainForm
     OnGetText = VirtualStringTree1GetText
     OnGetNodeDataSize = VirtualStringTree1GetNodeDataSize
     OnInitNode = VirtualStringTree1InitNode
+    Columns = <    
+      item
+        Position = 0
+        Spacing = 4
+        Text = 'te1'
+        Width = 63
+      end    
+      item
+        Position = 1
+        Spacing = 4
+        Text = 'te2'
+        Width = 63
+      end>
   end
   object ListBox1: TListBox
     Left = 248

Source/VTConfig.inc

@@ -58,7 +58,8 @@
 {$ifdef Windows}
   {$define EnableThreadSupport}
 {$endif}
-{$if defined(CPU64) or defined(LCLCarbon)}
+
+{$if not (defined(CPU386) or Defined(CPUX64))}
   {$define PACKARRAYPASCAL}
 {$endif}
 

Source/VirtualTrees.DataObject.pas

@@ -7,7 +7,7 @@ interface
 {$I VTConfig.inc}
 
 uses
-  Classes, Controls, Graphics, LCLType, SysUtils, Types,
+  Classes, Controls, Graphics, LCLType, SysUtils, Types, WSReferences,
   {$ifdef Windows}
   ActiveX,
   JwaWinBase,
@@ -39,7 +39,7 @@   TVTDataObject = class(TInterfacedObject, IDataObject)
     function EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean;
     function FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : Integer;
     function FindInternalStgMedium(Format : TClipFormat) : PStgMedium;
-    function HGlobalClone(HGlobal : THandle) : THandle;
+    function HGlobalClone(HGlobal : TLCLHandle) : TLCLHandle;
     function RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean;
     function StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult;
 
@@ -195,7 +195,7 @@ function TVTDataObject.FindInternalStgMedium(Format : TClipFormat) : PStgMedium;
 
 //----------------------------------------------------------------------------------------------------------------------
 
-function TVTDataObject.HGlobalClone(HGlobal : THandle) : THandle;
+function TVTDataObject.HGlobalClone(HGlobal : TLCLHandle) : TLCLHandle;
 // Returns a global memory block that is a copy of the passed memory block.
 {$IFDEF EnableWinDataObject}
 var

Source/VirtualTrees.EditLink.pas

@@ -10,7 +10,7 @@ interface
 {$I VTConfig.inc}
 
 uses
-  Classes, Controls, StdCtrls, LMessages, VirtualTrees.Types, VirtualTrees.BaseTree, VirtualTrees,
+  Classes, Controls, StdCtrls, LMessages, VirtualTrees.Types, VirtualTrees.BaseTree, VirtualTrees, WSReferences,
   LCLType, LCLIntf, Types;
 
 type
@@ -503,7 +503,7 @@ procedure TVTEdit.CreateParams(var Params : TCreateParams);
 function TVTEdit.GetTextSize : TSize;
 var
   DC : HDC;
-  LastFont : THandle;
+  LastFont : TLCLHandle;
 begin
   DC := GetDC(Handle);
   LastFont := SelectObject(DC, Font.Handle);

Source/VirtualTrees.Header.pas

@@ -7,6 +7,10 @@ interface
 {$I VTConfig.inc}
 
 uses
+  {$ifdef LCLCocoa}
+  MacOSAll, // hack: low-level access to Cocoa drawins is going to be used
+            //       in order to support Cocoa HighDPI implementation
+  {$endif}
   LMessages, LCLIntf, LCLType, Controls, Classes, StdCtrls, Themes, Graphics,
   {$ifdef Windows}
   Windows,
@@ -27,7 +31,13 @@ interface
   , ImgList
   , Menus
   , LCLVersion
-  , Types;
+  , Types
+  {$ifdef LCLCocoa}
+  ,CocoaGDIObjects // hack: while using buffered drawing, multiply the context
+                   //       by the retina scale to achieve the needed scale for Retina
+                   //       Ideally - not to use Buffered. but Unbuffered drawing
+                   //       seems to need a fix
+  {$endif};
 
 const
   DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable,
@@ -413,9 +423,7 @@   TVTHeader = class(TPersistent)
     procedure RescaleHeader;
     procedure UpdateMainColumn;
     procedure UpdateSpringColumns;
-    {$IFDEF DelphiSupport}
     procedure WriteColumns(Writer : TWriter);
-    {$ENDIF}
     procedure InternalSetMainColumn(const Index : TColumnIndex);
     procedure InternalSetAutoSizeIndex(const Index : TColumnIndex);
     procedure InternalSetSortColumn(const Index : TColumnIndex);
@@ -1547,7 +1555,7 @@ function TVTHeader.HandleMessage(var Message: TLMessage): Boolean;
   P                                          : TPoint;
   I                                          : TColumnIndex;
   HitIndex                                   : TColumnIndex;
-  NewCursor                                  : TVTCursor;
+  NewCursor                                  : TCursor;
   Button                                     : TMouseButton;
   IsInHeader, IsHSplitterHit, IsVSplitterHit : Boolean;
 
@@ -1915,13 +1923,14 @@ function TVTHeader.HandleMessage(var Message: TLMessage): Boolean;
         else
           IsVSplitterHit := InHeaderSplitterArea(P) and Self.CanSplitterResize(P);
 
+        //lcl: in lazarus we must use TCursor
         if IsVSplitterHit or IsHSplitterHit then
         begin
-          NewCursor := Screen.Cursors[Tree.Cursor];
+          NewCursor := Tree.Cursor;
           if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Tree.ComponentState)) then
-            NewCursor := Screen.Cursors[crVSplit]
+            NewCursor := crVSplit
           else if IsHSplitterHit then
-            NewCursor := Screen.Cursors[crHSplit];
+            NewCursor := crHSplit;
 
           if not (csDesigning in Tree.ComponentState) then
             Tree.DoGetHeaderCursor(NewCursor);
@@ -2271,7 +2280,6 @@ procedure TVTHeader.UpdateSpringColumns;
 
 //----------------------------------------------------------------------------------------------------------------------
 
-{$IFDEF DelphiSupport}
 type
   //--- HACK WARNING!
   //This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to
@@ -2310,7 +2318,6 @@ procedure TVTHeader.WriteColumns(Writer : TWriter);
     TWriterHack(Writer).FPropPath := LastPropPath;
   end;
 end;
-{$ENDIF}
 
 //----------------------------------------------------------------------------------------------------------------------
 
@@ -2582,7 +2589,7 @@ procedure TVTHeader.LoadFromStream(const Stream : TStream);
 
 var
   Dummy, Version : Integer;
-  S              : AnsiString;
+  S              : AnsiString = '';
   OldOptions     : TVTHeaderOptions;
 
 begin
@@ -2687,7 +2694,8 @@ function TVTHeader.ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnI
   ColCount,
   Sign: Integer;
   ToGo, MaxDelta, Difference, Rest: TDimension;
-  Constraints, Widths                              : array of TDimension;
+  Constraints                                      : array of TDimension = nil;
+  Widths                                           : array of TDimension = nil;
   BonusPixel                                       : Boolean;
 
   //--------------- local functions -------------------------------------------
@@ -4157,7 +4165,7 @@ function TVirtualTreeColumn.GetText : string;
 procedure TVirtualTreeColumn.LoadFromStream(const Stream : TStream; Version : Integer);
 var
   Dummy : Integer;
-  S     : string;
+  S     : string = '';
 
 begin
   with Stream do
@@ -5529,6 +5537,7 @@ function TVirtualTreeColumns.GetVisibleColumns : TColumnsArray;
   I, Counter : Integer;
 
 begin
+  Result := nil;
   SetLength(Result, Count);
   Counter := 0;
 
@@ -5610,6 +5619,9 @@ procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : TDimens
 var
   VisibleFixedWidth : TDimension;
   RTLOffset         : TDimension;
+  {$ifdef LCLCocoa}
+  sc : Double;
+  {$endif}
 
   procedure PaintFixedArea;
 
@@ -5623,6 +5635,15 @@ procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : TDimens
 begin
   // Adjust size of the header bitmap
   FHeaderBitmap.SetSize(Max(TreeViewControl.HeaderRect.Right, R.Right - R.Left), TreeViewControl.HeaderRect.Bottom);
+  {$ifdef LCLCocoa}
+  if Assigned(Header) and Assigned(Header.TreeView) then
+    sc := Header.Treeview.GetCanvasScaleFactor
+  else
+    sc := 1.0;
+  FHeaderBitmap.Width := Round(FHeaderBitmap.Width * sc);
+  FHeaderBitmap.Height := Round(FHeaderBitmap.Height * sc);
+  CGContextScaleCTM(TCocoaBitmapContext(FHeaderBitmap.Canvas.Handle).CGContext, sc, sc);
+  {$endif}
 
   VisibleFixedWidth := GetVisibleFixedWidth;
 
@@ -5645,7 +5666,15 @@ procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : TDimens
     PaintFixedArea;
 
   // Blit the result to target.
+  {$ifdef LCLCocoa}
+  StretchBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
+    FHeaderBitmap.Canvas.Handle,
+    R.Left, R.Top,
+    FHeaderBitmap.Width, FHeaderBitmap.Height,
+    SRCCOPY);
+  {$else}
   BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, FHeaderBitmap.Canvas.Handle, R.Left, R.Top, SRCCOPY);
+  {$endif}
 end;
 
 //----------------------------------------------------------------------------------------------------------------------
@@ -5971,15 +6000,15 @@ procedure TVirtualTreeColumns.PaintHeader(TargetCanvas : TCanvas; R : TRect; con
 
         // caption
         if WrapCaption then
-          ColCaptionText := FCaptionText
+          ColCaptionText := UnicodeString(FCaptionText)
         else
-          ColCaptionText := Text;
+          ColCaptionText := UnicodeString(Text);
         if IsHoverIndex and TreeViewControl.VclStyleEnabled then
           DrawHot := True
         else
           DrawHot := (IsHoverIndex and (hoHotTrack in Header.Options) and not (tsUseThemes in TreeViewControl.TreeStates));
         if not (hpeText in ActualElements) and (Length(Text) > 0) then
-          DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption);
+          DrawButtonText(TargetCanvas.Handle, String(ColCaptionText), TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption);
 
         // sort glyph
         if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then

Source/VirtualTrees.Utils.pas

@@ -43,7 +43,7 @@ interface
     bmConstantAlphaAndColor  // blend the destination color with the given constant color und the constant alpha value
   );
 
-procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
+procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
 function GetRGBColor(Value: TColor): DWORD;
 {$ifdef EnablePrint}
 procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
@@ -460,7 +460,7 @@ function WrapString(DC: HDC; const S: string; const Bounds: TRect; RTL: Boolean;
   I, W: Integer;
   Buffer,
   Line: string;
-  Words: array of string;
+  Words: array of string = nil;
   R: TRect;
 
 begin

Source/include/intf/carbon/vtgraphicsi.inc

@@ -1,5 +1,5 @@
 //todo: properly implement
-procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
+procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
 begin
   case Mode of
     bmConstantAlpha,
@@ -20,4 +20,4 @@ end;
 function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
 begin
   Result := nil;
-end;
+end;

Source/include/intf/cocoa/vtgraphicsi.inc

@@ -1,5 +1,5 @@
 //todo: properly implement
-procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
+procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
 begin
   case Mode of
     bmConstantAlpha,
@@ -20,4 +20,4 @@ end;
 function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
 begin
   Result := nil;
-end;
+end;