From da158e6e835b70b60933a37aaf700fd6ac2653e8 Mon Sep 17 00:00:00 2001 From: lazarus Date: Mon, 11 Mar 2002 23:22:46 +0000 Subject: [PATCH] MG: added TPicture clipboard support git-svn-id: trunk@1507 - --- components/codetools/finddeclarationtool.pas | 10 +- components/codetools/keywordfunclists.pas | 2 + components/codetools/pascalparsertool.pas | 3 +- lcl/clipbrd.pp | 17 +- lcl/graphics.pp | 24 +- lcl/include/clipbrd.inc | 7 +- lcl/include/picture.inc | 241 +++++++++++++------ lcl/include/sharedimage.inc | 11 +- lcl/include/winapi.inc | 3 + 9 files changed, 232 insertions(+), 86 deletions(-) diff --git a/components/codetools/finddeclarationtool.pas b/components/codetools/finddeclarationtool.pas index 9450552b37..73f1d5237c 100644 --- a/components/codetools/finddeclarationtool.pas +++ b/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; diff --git a/components/codetools/keywordfunclists.pas b/components/codetools/keywordfunclists.pas index 4ef3f02e3b..070e6d5023 100644 --- a/components/codetools/keywordfunclists.pas +++ b/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); diff --git a/components/codetools/pascalparsertool.pas b/components/codetools/pascalparsertool.pas index 623fba4315..58302ce4e0 100644 --- a/components/codetools/pascalparsertool.pas +++ b/components/codetools/pascalparsertool.pas @@ -1088,6 +1088,7 @@ function TPascalParserTool.ReadTilProcedureHeadEnd( proc specifiers with parameters: message ; external; + external ; external name ; external name ; external index ; @@ -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 diff --git a/lcl/clipbrd.pp b/lcl/clipbrd.pp index 58b920535f..9c4a6c37c0 100644 --- a/lcl/clipbrd.pp +++ b/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 - FClipboards[AClipboardType].Free; + FreeAllClipboards; 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 diff --git a/lcl/graphics.pp b/lcl/graphics.pp index c62542c482..bca6350bfb 100644 --- a/lcl/graphics.pp +++ b/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 Release; + procedure Reference; // increase reference count + 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 diff --git a/lcl/include/clipbrd.inc b/lcl/include/clipbrd.inc index fc468cd685..0c07e3ebdd 100644 --- a/lcl/include/clipbrd.inc +++ b/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 diff --git a/lcl/include/picture.inc b/lcl/include/picture.inc index 8b817680f6..9f6689d651 100644 --- a/lcl/include/picture.inc +++ b/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; -var - I: Integer; - p: PPicFileFormat; +procedure TPicFileFormatsList.Clear; +var i: integer; + P: PPicFileFormat; begin - for I := 0 to Count-1 do begin - p:=PPicFileFormat(Pointer(Items[I])); - Dispose(p); + for i:=0 to Count-1 do begin + P:=GetFormat(i); + 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); - with NewRec^ do begin + New(NewFormat); + 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 - begin - Result := PPicFileFormat(Items[I])^.GraphicClass; + // search backwards so that new formats will be found first + for I := Count-1 downto 0 do begin + 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 - begin - P := PPicFileFormat(Items[I]); + for I := Count-1 downto 0 do begin + P := GetFormat(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 - begin - if C <> 0 then - begin + with P^ do 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 - PictureFileFormats := TPicFileFormatsList.Create; - Result := PictureFileFormats; + if (PicFileFormats = nil) and (not GraphicsFinalized) then + PicFileFormats := TPicFileFormatsList.Create; + 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 - begin + if Value <> nil then 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 - NewGraphic.Free; - raise; + ok:=true; + finally + // 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.LoadFromClipboardFormat(AFormat, AData, APalette); + NewGraphic.OnProgress := @Progress; + NewGraphic.LoadFromClipboardFormat(FormatID); except NewGraphic.Free; raise; end; FGraphic.Free; FGraphic := NewGraphic; - FGraphic.OnChange := Changed; - Changed(Self);} + FGraphic.OnChange := @Changed; + 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 ClipboardFormats <> nil then ClipboardFormats.Remove(AClass); + if PicFileFormats <> nil then PicFileFormats.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 - begin + if GraphicClass <> nil then begin NewGraphic := GraphicClass.Create; + ok:=false; try NewGraphic.ReadData(Stream); - except - NewGraphic.Free; - raise; + ok:=true; + finally + if not ok then NewGraphic.Free; end; end; FGraphic.Free; FGraphic := NewGraphic; - if NewGraphic <> nil then - begin + if NewGraphic <> nil then 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 - begin + if Filer.Ancestor <> nil then begin Result := True; - if Filer.Ancestor is TPicture then - begin + if Filer.Ancestor is TPicture then begin Ancestor := TPicture(Filer.Ancestor); - Result := not ((Graphic = Ancestor.Graphic) or - ((Graphic <> nil) and (Ancestor.Graphic <> nil) and - Graphic.Equals(Ancestor.Graphic))); + Result := not ((Graphic = Ancestor.Graphic) + or ((Graphic <> nil) and (Ancestor.Graphic <> nil) + and Graphic.Equals(Ancestor.Graphic)) + ); end; end else Result := Graphic <> nil; diff --git a/lcl/include/sharedimage.inc b/lcl/include/sharedimage.inc index c7072c7b0c..f61bce5322 100644 --- a/lcl/include/sharedimage.inc +++ b/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 - begin + if Pointer(Self) <> nil then begin Dec(FRefCount); - if FRefCount = 0 then - begin + if FRefCount = 0 then begin FreeHandle; Free; end; end; end; + +// included by graphics.pp + diff --git a/lcl/include/winapi.inc b/lcl/include/winapi.inc index 6c5698b772..ffd2dc6a8f 100644 --- a/lcl/include/winapi.inc +++ b/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