MG: added TPicture clipboard support

git-svn-id: trunk@1507 -

components/codetools/finddeclarationtool.pas

@@ -124,7 +124,7 @@ type
     xtExtended, xtCurrency, xtComp, xtInt64, xtCardinal, xtQWord, xtBoolean,
     xtByteBool, xtLongBool, xtString, xtAnsiString, xtShortString, xtWideString,
     xtPChar, xtPointer, xtConstOrdInteger, xtConstString, xtConstReal,
-    xtConstSet, xtConstBoolean, xtAddress, xtLongInt, xtNil);
+    xtConstSet, xtConstBoolean, xtAddress, xtLongInt, xtWord, xtNil);
   TExpressionTypeDescs = set of TExpressionTypeDesc;
   
 const
@@ -133,12 +133,12 @@ const
     'Extended', 'Currency', 'Comp', 'Int64', 'Cardinal', 'QWord', 'Boolean',
     'ByteBool', 'LongBool', 'String', 'AnsiString', 'ShortString', 'WideString',
     'PChar', 'Pointer', 'ConstOrdInt', 'ConstString', 'ConstReal', 'ConstSet',
-    'ConstBoolean', '@-Operator', 'LongInt', 'Nil'
+    'ConstBoolean', '@-Operator', 'LongInt', 'Word', 'Nil'
   );
 
   xtAllTypes = [xtContext..High(TExpressionTypeDesc)];
   xtAllPredefinedTypes = xtAllTypes-[xtContext];
-  xtAllIntegerTypes = [xtInt64, xtQWord, xtConstOrdInteger, xtLongInt];
+  xtAllIntegerTypes = [xtInt64, xtQWord, xtConstOrdInteger, xtLongInt, xtWord];
   xtAllBooleanTypes = [xtBoolean, xtByteBool, xtLongBool];
   xtAllRealTypes = [xtReal, xtConstReal, xtSingle, xtDouble, xtExtended,
                     xtCurrency, xtComp];
@@ -465,6 +465,10 @@ begin
     Result:=xtCurrency
   else if CompareIdentifiers(Identifier,'LONGINT'#0)=0 then
     Result:=xtLongInt
+  else if CompareIdentifiers(Identifier,'WORD'#0)=0 then
+    Result:=xtWord
+  else if CompareIdentifiers(Identifier,'LONGWORD'#0)=0 then
+    Result:=xtCardinal
   else
     Result:=xtNone;
 end;

components/codetools/keywordfunclists.pas

@@ -918,7 +918,9 @@ begin
     Add('POINTER'    ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('INT64'      ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('CARDINAL'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('LONGWORD'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('INTEGER'    ,{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('WORD'       ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('QWORD'      ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('BOOLEAN'    ,{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('CHAR'       ,{$ifdef FPC}@{$endif}AllwaysTrue);

components/codetools/pascalparsertool.pas

@@ -1088,6 +1088,7 @@ function TPascalParserTool.ReadTilProcedureHeadEnd(
  proc specifiers with parameters:
    message <id or number>;
    external;
+   external <id>;
    external name <id>;
    external <id or number> name <id>;
    external <id or number> index <id>;
@@ -1174,8 +1175,6 @@ begin
           if UpAtomIs('NAME') or UpAtomIs('INDEX') then begin
             ReadNextAtom;
             ReadConstant(true,false,[]);
-          end else begin
-            RaiseException('"name" expected, but '+GetAtom+' found');
           end;
         end;
       end else if AtomIsChar('[') then begin

lcl/clipbrd.pp

@@ -278,6 +278,7 @@ function SecondarySelection: TClipboard;
 function Clipboard(ClipboardType: TClipboardType): TClipboard;
 function SetClipboard(ClipboardType: TClipboardType;
   NewClipboard: TClipboard): TClipboard;
+procedure FreeAllClipboards;
 
 function RegisterClipboardFormat(const Format: string): TClipboardFormat;
 
@@ -375,6 +376,13 @@ begin
   Result:=PredefinedClipboardFormat(pcfDelphiComponent);
 end;
 
+procedure FreeAllClipboards;
+var AClipboardType: TClipboardType;
+begin
+  for AClipboardType:=Low(TClipboardType) to High(TClipboardType) do
+    FreeAndNil(FClipboards[AClipboardType]);
+end;
+
 //-----------------------------------------------------------------------------
 
 procedure InternalInit;
@@ -390,10 +398,8 @@ begin
 end;
 
 procedure InternalFinal;
-var AClipboardType: TClipboardType;
 begin
-  for AClipboardType:=Low(TClipboardType) to High(TClipboardType) do
+  FreeAllClipboards;
-    FClipboards[AClipboardType].Free;
 end;
 
 initialization
@@ -401,11 +407,14 @@ initialization
   
 finalization
   InternalFinal;
-  
+
 end.
 
 {
   $Log$
+  Revision 1.8  2002/03/11 23:22:46  lazarus
+  MG: added TPicture clipboard support
+
   Revision 1.7  2002/03/09 11:55:13  lazarus
   MG: fixed class method completion
 

lcl/graphics.pp

@@ -290,6 +290,8 @@ type
     procedure LoadFromStream(Stream: TStream); virtual; abstract;
     procedure SaveToStream(Stream: TStream); virtual; abstract;
     procedure LoadFromLazarusResource(const ResName: String); virtual; abstract;
+    procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
+    procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
     constructor Create; // virtual;
     property Empty: Boolean read GetEmpty;
     property Height: Integer read GetHeight write SetHeight;
@@ -396,7 +398,7 @@ type
   end;
 
 
-  EInvalidGraphic=class(Exception);
+  EInvalidGraphic = class(Exception);
 
 
   TCanvas = class(TPersistent)
@@ -497,8 +499,8 @@ type
   private
     FRefCount: Integer;
   protected
-    procedure Reference;
+    procedure Reference; // increase reference count
-    procedure Release;
+    procedure Release;   // decrease reference count
     procedure FreeHandle; virtual; abstract;
     property RefCount: Integer read FRefCount;
   end;
@@ -622,7 +624,11 @@ var
  ***************************************************************************)
 implementation
 
-uses Controls;
+
+uses Controls, ClipBrd;
+
+const
+  GraphicsFinalized: boolean = false;
 
 type
   TBitmapCanvas = class(TCanvas)
@@ -741,12 +747,22 @@ end;
 {$I canvas.inc}
 {$I pixmap.inc}
 
+initialization
+
+finalization
+  GraphicsFinalized:=true;
+  FreeAndNil(PicClipboardFormats);
+  FreeAndNil(PicFileFormats);
+
 
 end.
 
 { =============================================================================
 
   $Log$
+  Revision 1.28  2002/03/11 23:22:46  lazarus
+  MG: added TPicture clipboard support
+
   Revision 1.27  2002/03/11 20:36:34  lazarus
   MG: fixed parser for multiple variant identifiers
 

lcl/include/clipbrd.inc

@@ -18,14 +18,14 @@ end;
 
 constructor TClipboard.Create(AClipboardType: TClipboardType);
 begin
-//writeln('[TClipboard.Create] A ',ClipboardTypeName[AClipboardType]);
+//writeln('[TClipboard.Create] A ',ClipboardTypeName[AClipboardType],' Self=',HexStr(Cardinal(Self),8));
   inherited Create;
   FClipboardType:=AClipboardType;
 end;
 
 destructor TClipboard.Destroy;
 begin
-//writeln('[TClipboard.Destroy] A ',ClipboardTypeName[ClipboardType]);
+//writeln('[TClipboard.Destroy] A ',ClipboardTypeName[ClipboardType],' Self=',HexStr(Cardinal(Self),8));
   OnRequest:=nil; // this will notify the owner
   if FAllocated then begin
     ClipboardGetOwnership(ClipboardType,nil,0,nil);
@@ -594,6 +594,9 @@ end;
 
 {
   $Log$
+  Revision 1.7  2002/03/11 23:22:46  lazarus
+  MG: added TPicture clipboard support
+
   Revision 1.6  2002/03/09 11:55:13  lazarus
   MG: fixed class method completion
 

lcl/include/picture.inc

@@ -11,10 +11,13 @@ type
   end;
 
   TPicFileFormatsList = class(TList)
+    // list of TPicFileFormat
   public
     constructor Create;
-    destructor Destroy; override;
+    procedure Clear; override;
+    procedure Delete(Index: Integer);
     procedure Add(const Ext, Desc: String; AClass: TGraphicClass);
+    function GetFormat(Index: integer): PPicFileFormat;
     function FindExt(Ext: string): TGraphicClass;
     function FindClassName(const AClassname: string): TGraphicClass;
     procedure Remove(AClass: TGraphicClass);
@@ -30,30 +33,42 @@ begin
   Add('ico', 'Icon', TIcon);
 end;
 
-destructor TPicFileFormatsList.Destroy;
+procedure TPicFileFormatsList.Clear;
-var
+var i: integer;
-  I: Integer;
+  P: PPicFileFormat;
-  p: PPicFileFormat;
 begin
-  for I := 0 to Count-1 do begin
+  for i:=0 to Count-1 do begin
-    p:=PPicFileFormat(Pointer(Items[I]));
+    P:=GetFormat(i);
-    Dispose(p);
+    Dispose(P);
   end;
-  inherited Destroy;
+  inherited Clear;
+end;
+
+procedure TPicFileFormatsList.Delete(Index: Integer);
+var P: PPicFileFormat;
+begin
+  P:=GetFormat(Index);
+  Dispose(P);
+  inherited Delete(Index);
 end;
 
 procedure TPicFileFormatsList.Add(const Ext, Desc: String;
   AClass: TGraphicClass);
 var
-  NewRec: PPicFileFormat;
+  NewFormat: PPicFileFormat;
 begin
-  New(NewRec);
+  New(NewFormat);
-  with NewRec^ do begin
+  with NewFormat^ do begin
     Extension := AnsiLowerCase(Ext);
     GraphicClass := AClass;
     Description := Desc;
   end;
-  inherited Add(NewRec);
+  inherited Add(NewFormat);
+end;
+
+function TPicFileFormatsList.GetFormat(Index: integer): PPicFileFormat;
+begin
+  Result:=PPicFileFormat(Items[Index]);
 end;
 
 function TPicFileFormatsList.FindExt(Ext: string): TGraphicClass;
@@ -76,9 +91,9 @@ function TPicFileFormatsList.FindClassName(
 var
   I: Integer;
 begin
-  for I := Count-1 downto 0 do
+  // search backwards so that new formats will be found first
-  begin
+  for I := Count-1 downto 0 do begin
-    Result := PPicFileFormat(Items[I])^.GraphicClass;
+    Result := GetFormat(I)^.GraphicClass;
     if AnsiLowerCase(Result.ClassName) = AnsiLowerCase(AClassname) then
       Exit;
   end;
@@ -86,18 +101,15 @@ begin
 end;
 
 procedure TPicFileFormatsList.Remove(AClass: TGraphicClass);
+// remove all file formats which inherits from ACLass
 var
   I: Integer;
   P: PPicFileFormat;
 begin
-  for I := Count-1 downto 0 do
+  for I := Count-1 downto 0 do begin
-  begin
+    P := GetFormat(I);
-    P := PPicFileFormat(Items[I]);
     if P^.GraphicClass.InheritsFrom(AClass) then
-    begin
-      Dispose(P);
       Delete(I);
-    end;
   end;
 end;
 
@@ -111,12 +123,10 @@ begin
   Filters := '';
   C := 0;
   for I := Count-1 downto 0 do begin
-    P := PPicFileFormat(Items[I]);
+    P := GetFormat(I);
     if P^.GraphicClass.InheritsFrom(GraphicClass) and (P^.Extension <> '') then
-      with P^ do
+      with P^ do begin
-      begin
+        if C <> 0 then begin
-        if C <> 0 then
-        begin
           Descriptions := Descriptions + '|';
           Filters := Filters + ';';
         end;
@@ -131,22 +141,115 @@ begin
      ['All files', Filters, Descriptions]);
 end;
 
+//------------------------------------------------------------------------------
+
+type
+  PPicClipboardFormat = ^TPicClipboardFormat;
+  TPicClipboardFormat = record
+    GraphicClass: TGraphicClass;
+    FormatID: TClipboardFormat;
+  end;
+
+  TPicClipboardFormats = class(TList)
+    // list of TPicClipboarFormat
+  public
+    constructor Create;
+    procedure Clear; override;
+    procedure Delete(Index: Integer);
+    function GetFormat(Index: integer): PPicClipboardFormat;
+    procedure Add(AFormatID: TClipboardFormat; AClass: TGraphicClass);
+    function FindFormat(FormatID: TClipboardFormat): TGraphicClass;
+    procedure Remove(AClass: TGraphicClass);
+  end;
+
+constructor TPicClipboardFormats.Create;
+begin
+  inherited Create;
+  Add(PredefinedClipboardFormat(pcfBitmap), TBitmap);
+  Add(PredefinedClipboardFormat(pcfPixmap), TPixmap);
+  Add(PredefinedClipboardFormat(pcfIcon), TIcon);
+end;
+
+procedure TPicClipboardFormats.Clear;
+var i: integer;
+  P: PPicClipboardFormat;
+begin
+  for i:=0 to Count-1 do begin
+    P:=GetFormat(i);
+    Dispose(P);
+  end;
+  inherited Clear;
+end;
+
+procedure TPicClipboardFormats.Delete(Index: Integer);
+var P: PPicClipboardFormat;
+begin
+  P:=GetFormat(Index);
+  Dispose(P);
+  inherited Delete(Index);
+end;
+
+function TPicClipboardFormats.GetFormat(Index: integer): PPicClipboardFormat;
+begin
+  Result:=PPicClipboardFormat(Items[Index]);
+end;
+
+procedure TPicClipboardFormats.Add(AFormatID: TClipboardFormat;
+  AClass: TGraphicClass);
+var NewFormat: PPicClipboardFormat;
+begin
+  New(NewFormat);
+  with NewFormat^ do begin
+    GraphicClass:=AClass;
+    FormatID:=AFormatID;
+  end;
+end;
+
+function TPicClipboardFormats.FindFormat(
+  FormatID: TClipboardFormat): TGraphicClass;
+var
+  I: Integer;
+  P: PPicClipboardFormat;
+begin
+  for I := Count-1 downto 0 do begin
+    P:=GetFormat(i);
+    if P^.FormatID=FormatID then begin
+      Result := P^.GraphicClass;
+      Exit;
+    end;
+  end;
+  Result := nil;
+end;
+
+procedure TPicClipboardFormats.Remove(AClass: TGraphicClass);
+var
+  I: Integer;
+begin
+  for I := Count-1 downto 0 do
+    if GetFormat(i)^.GraphicClass.InheritsFrom(AClass) then
+      Delete(i);
+end;
+
+//------------------------------------------------------------------------------
+
 const
-  PictureFileFormats: TPicFileFormatsList = nil;
+  PicClipboardFormats: TPicClipboardFormats = nil;
+  PicFileFormats: TPicFileFormatsList = nil;
 
 function GetPicFileFormats: TPicFileFormatsList;
 begin
-  if PictureFileFormats = nil then 
+  if (PicFileFormats = nil) and (not GraphicsFinalized) then
-    PictureFileFormats := TPicFileFormatsList.Create;
+    PicFileFormats := TPicFileFormatsList.Create;
-  Result := PictureFileFormats;
+  Result := PicFileFormats;
 end;
 
-{function GetPicClipboardFormats: TPicClipboardFormats;
+function GetPicClipboardFormats: TPicClipboardFormats;
 begin
-  if PicClipboardFormats = nil then
+  if (PicClipboardFormats = nil) and (not GraphicsFinalized) then
     PicClipboardFormats := TPicClipboardFormats.Create;
   Result := PicClipboardFormats;
-end;}
+end;
+
 
 //--TPicture--------------------------------------------------------------------
 
@@ -155,7 +258,7 @@ constructor TPicture.Create;
 begin
   inherited Create;
   GetPicFileFormats;
-  //GetClipboardFormats;
+  GetPicClipboardFormats;
 end;
 
 destructor TPicture.Destroy;
@@ -221,22 +324,25 @@ end;
 procedure TPicture.SetGraphic(Value: TGraphic);
 var
   NewGraphic: TGraphic;
+  ok: boolean;
 begin
   NewGraphic := nil;
-  if Value <> nil then
+  if Value <> nil then begin
-  begin
     NewGraphic := TGraphicClass(Value.ClassType).Create;
     NewGraphic.Assign(Value);
     NewGraphic.OnChange := @Changed;
     NewGraphic.OnProgress := @Progress;
   end;
+  ok:=false;
   try
     FGraphic.Free;
     FGraphic := NewGraphic;
     Changed(Self);
-  except
+    ok:=true;
-    NewGraphic.Free;
+  finally
-    raise;
+    // this try..finally construction will in case of an exception
+    // not alter the error backtrace output
+    if not ok then NewGraphic.Free;
   end;
 end;
 
@@ -279,36 +385,38 @@ begin
 end;
 
 procedure TPicture.LoadFromClipboardFormat(FormatID: TClipboardFormat);
-{var
+var
   NewGraphic: TGraphic;
-  GraphicClass: TGraphicClass;}
+  GraphicClass: TGraphicClass;
 begin
-{  GraphicClass := ClipboardFormats.FindFormat(FormatID);
+  GraphicClass := PicClipboardFormats.FindFormat(FormatID);
   if GraphicClass = nil then
-    InvalidGraphic(@SUnknownClipboardFormat);
+    raise EInvalidGraphic.Create('Unsupported clipboard format: '
+      +ClipboardFormatToMimeType(FormatID));
 
   NewGraphic := GraphicClass.Create;
   try
-    NewGraphic.OnProgress := Progress;
+    NewGraphic.OnProgress := @Progress;
-    NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
+    NewGraphic.LoadFromClipboardFormat(FormatID);
   except
     NewGraphic.Free;
     raise;
   end;
   FGraphic.Free;
   FGraphic := NewGraphic;
-  FGraphic.OnChange := Changed;
+  FGraphic.OnChange := @Changed;
-  Changed(Self);}
+  Changed(Self);
 end;
 
 procedure TPicture.SaveToClipboardFormat(FormatID: TClipboardFormat);
 begin
-
+  if FGraphic <> nil then
+    FGraphic.SaveToClipboardFormat(FormatID);
 end;
 
 function TPicture.SupportsClipboardFormat(FormatID: TClipboardFormat): Boolean;
 begin
-  Result:=false;
+  Result := GetPicClipboardFormats.FindFormat(FormatID) <> nil;
 end;
 
 procedure TPicture.Assign(Source: TPersistent);
@@ -332,13 +440,13 @@ end;
 procedure TPicture.RegisterClipboardFormat(FormatID: TClipboardFormat;
   AGraphicClass: TGraphicClass);
 begin
-
+  GetPicClipboardFormats.Add(FormatID, AGraphicClass);
 end;
 
 class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
 begin
-  if GetPicFileFormats <> nil then GetPicFileFormats.Remove(AClass);
+  if PicFileFormats <> nil then PicFileFormats.Remove(AClass);
-  //if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
+  if PicClipboardFormats <> nil then PicClipboardFormats.Remove(AClass);
 end;
 
 procedure TPicture.Changed(Sender: TObject);
@@ -358,25 +466,25 @@ var
   GraphicClassName: Shortstring;
   NewGraphic: TGraphic;
   GraphicClass: TGraphicClass;
+  ok: boolean;
 begin
   Stream.Read(GraphicClassName[0], 1);
   Stream.Read(GraphicClassName[1], length(GraphicClassName));
   GraphicClass := GetPicFileFormats.FindClassName(GraphicClassName);
   NewGraphic := nil;
-  if GraphicClass <> nil then
+  if GraphicClass <> nil then begin
-  begin
     NewGraphic := GraphicClass.Create;
+    ok:=false;
     try
       NewGraphic.ReadData(Stream);
-    except
+      ok:=true;
-      NewGraphic.Free;
+    finally
-      raise;
+      if not ok then NewGraphic.Free;
     end;
   end;
   FGraphic.Free;
   FGraphic := NewGraphic;
-  if NewGraphic <> nil then
+  if NewGraphic <> nil then begin
-  begin
     NewGraphic.OnChange := @Changed;
     NewGraphic.OnProgress := @Progress;
   end;
@@ -405,15 +513,14 @@ procedure TPicture.DefineProperties(Filer: TFiler);
   var
     Ancestor: TPicture;
   begin
-    if Filer.Ancestor <> nil then
+    if Filer.Ancestor <> nil then begin
-    begin
       Result := True;
-      if Filer.Ancestor is TPicture then
+      if Filer.Ancestor is TPicture then begin
-      begin
         Ancestor := TPicture(Filer.Ancestor);
-        Result := not ((Graphic = Ancestor.Graphic) or
+        Result := not ((Graphic = Ancestor.Graphic)
-          ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
+                       or ((Graphic <> nil) and (Ancestor.Graphic <> nil)
-          Graphic.Equals(Ancestor.Graphic)));
+                           and Graphic.Equals(Ancestor.Graphic))
+                      );
       end;
     end
     else Result := Graphic <> nil;

lcl/include/sharedimage.inc

@@ -1,3 +1,5 @@
+// included by graphics.pp
+
 { TSharedImage }
 
 procedure TSharedImage.Reference;
@@ -7,13 +9,14 @@ end;
 
 procedure TSharedImage.Release;
 begin
-  if Pointer(Self) <> nil then
+  if Pointer(Self) <> nil then begin
-  begin
     Dec(FRefCount);
-    if FRefCount = 0 then
+    if FRefCount = 0 then begin
-    begin
       FreeHandle;
       Free;
     end;
   end;
 end;
+
+// included by graphics.pp
+

lcl/include/winapi.inc

@@ -1064,6 +1064,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.26  2002/03/11 23:22:46  lazarus
+  MG: added TPicture clipboard support
+
   Revision 1.25  2002/03/08 16:16:55  lazarus
   MG: fixed parser of end blocks in initialization section added label sections