diff --git a/.gitattributes b/.gitattributes index 613f31e7c3..47191ab7ad 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8351,6 +8351,11 @@ packages/winunits-base/tests/OOHelper.pp svneol=native#text/plain packages/winunits-base/tests/OOTest.pp svneol=native#text/plain packages/winunits-base/tests/hhex.pp svneol=native#text/pascal packages/winunits-base/tests/hhex2.pp svneol=native#text/pascal +packages/winunits-base/tests/inproccomtest/com_clnt.dpr svneol=native#text/plain +packages/winunits-base/tests/inproccomtest/com_impl.pas svneol=native#text/plain +packages/winunits-base/tests/inproccomtest/com_serv.dpr svneol=native#text/plain +packages/winunits-base/tests/inproccomtest/com_serv.tlb -text +packages/winunits-base/tests/inproccomtest/com_serv_TLB.pas svneol=native#text/plain packages/winunits-base/tests/testcom1.pp svneol=native#text/plain packages/winunits-base/tests/testcom2.pp svneol=native#text/plain packages/winunits-base/tests/testver.pp svneol=native#text/plain diff --git a/packages/fcl-image/src/fpreadpng.pp b/packages/fcl-image/src/fpreadpng.pp index d996ee5864..1a9049a782 100644 --- a/packages/fcl-image/src/fpreadpng.pp +++ b/packages/fcl-image/src/fpreadpng.pp @@ -26,6 +26,8 @@ Type TSetPixelProc = procedure (x,y:integer; CD : TColordata) of object; TConvertColorProc = function (CD:TColorData) : TFPColor of object; + { TFPReaderPNG } + TFPReaderPNG = class (TFPCustomImageReader) private @@ -46,6 +48,11 @@ Type FPalette : TFPPalette; FSetPixel : TSetPixelProc; FConvertColor : TConvertColorProc; + function GetGrayScale: Boolean; + function GetHeaderByte(AIndex: Integer): Byte; + function GetIndexed: Boolean; + function GetUseAlpha: Boolean; + function GetWordSized: Boolean; procedure ReadChunk; procedure HandleData; procedure HandleUnknown; @@ -99,6 +106,17 @@ Type public constructor create; override; destructor destroy; override; + // These 2 match writer properties. Calculated from header values + Property GrayScale : Boolean Read GetGrayScale; + Property WordSized : Boolean Read GetWordSized; + Property Indexed : Boolean Read GetIndexed; + Property UseAlpha : Boolean Read GetUseAlpha; + // Raw reader values + Property BitDepth : Byte Index 0 Read GetHeaderByte; + Property ColorType : Byte Index 1 Read GetHeaderByte; + Property Compression : Byte Index 2 Read GetHeaderByte; + Property Filter : Byte Index 3 Read GetHeaderByte; + Property Interlace : Byte Index 4 Read GetHeaderByte; end; implementation @@ -176,6 +194,40 @@ begin end; end; +function TFPReaderPNG.GetHeaderByte(AIndex: Integer): Byte; +begin + With FHeader do + Case aIndex of + 0 : Result:=BitDepth; + 1 : Result:=ColorType; + 2 : Result:=Compression; + 3 : Result:=Filter; + 4 : Result:=Interlace; + else + Result:=0; + end; +end; + +function TFPReaderPNG.GetIndexed: Boolean; +begin + Result:=ColorType=3; +end; + +function TFPReaderPNG.GetUseAlpha: Boolean; +begin + Result:=ColorType in [4,6]; // Can also be in 3, but that would require scanning the palette +end; + +function TFPReaderPNG.GetWordSized: Boolean; +begin + Result:=BitDepth=16; +end; + +function TFPReaderPNG.GetGrayScale: Boolean; +begin + Result:=ColorType in [0,4]; +end; + procedure TFPReaderPNG.HandleData; var OldSize : longword; begin diff --git a/packages/fcl-image/src/fptiffcmn.pas b/packages/fcl-image/src/fptiffcmn.pas index ff6f43c647..1a1c295ef0 100644 --- a/packages/fcl-image/src/fptiffcmn.pas +++ b/packages/fcl-image/src/fptiffcmn.pas @@ -88,7 +88,9 @@ const TiffCompressionIT8BL = 32898; { IT8BL } TiffCompressionPixarFilm = 32908; { PIXARFILM } TiffCompressionPixarLog = 32909; { PIXARLOG } - TiffCompressionDeflateZLib = 32946; { DeflatePKZip } + TiffCompressionDeflateZLib = 32946; { DeflatePKZip - obsolete, + same as TiffCompressionDeflateAdobe, + Macos Finder does not like this, use Adobe instead } TiffCompressionDCS = 32947; { DCS } TiffCompressionJBIG = 34661; { JBIG } TiffCompressionSGILog = 34676; { SGILOG } diff --git a/packages/fcl-image/src/fpwritetiff.pas b/packages/fcl-image/src/fpwritetiff.pas index fa6d40c34c..89f6f03261 100644 --- a/packages/fcl-image/src/fpwritetiff.pas +++ b/packages/fcl-image/src/fpwritetiff.pas @@ -464,12 +464,12 @@ begin Compression:=IFD.Compression; case Compression of TiffCompressionNone, - TiffCompressionDeflateZLib: ; + TiffCompressionDeflateAdobe: ; else {$ifdef FPC_DEBUG_IMAGE} writeln('TFPWriterTiff.AddImage unsupported compression '+TiffCompressionName(Compression)+', using deflate instead.'); {$endif} - Compression:=TiffCompressionDeflateZLib; + Compression:=TiffCompressionDeflateAdobe; end; if IFD.Orientation in [1..4] then begin @@ -698,7 +698,7 @@ t=',ChunkCount); // compress case Compression of - TiffCompressionDeflateZLib: EncodeDeflate(Chunk,ChunkBytes); + TiffCompressionDeflateZLib, TiffCompressionDeflateAdobe: EncodeDeflate(Chunk,ChunkBytes); end; ChunkOffsets.Chunks[ChunkIndex].Data:=Chunk; diff --git a/packages/winunits-base/tests/inproccomtest/com_clnt.dpr b/packages/winunits-base/tests/inproccomtest/com_clnt.dpr new file mode 100644 index 0000000000..2e121ed03b --- /dev/null +++ b/packages/winunits-base/tests/inproccomtest/com_clnt.dpr @@ -0,0 +1,28 @@ +program com_clnt; +// Comtest demo from Anton K. mantis #35013 + +{$ifdef fpc}{$mode delphi}{$endif} +uses variants,sysutils,classes,activex,comobj; + +var co,resp:variant; +begin + co := CreateOleObject('com_serv.TestApp'); + + if (VarIsEmpty(co)) then halt(1); + + try + co.test('Hello1'); + resp:=widestring('yyyyy'); + co.test_ret(resp); + writeln(resp); + if (resp<>'zzzz') then halt(2); + except + on E:Exception do + begin + writeln(E.Message); + halt(3); + end; + end; + writeln('Success!'); + +end. \ No newline at end of file diff --git a/packages/winunits-base/tests/inproccomtest/com_impl.pas b/packages/winunits-base/tests/inproccomtest/com_impl.pas new file mode 100644 index 0000000000..3ff3adc3bc --- /dev/null +++ b/packages/winunits-base/tests/inproccomtest/com_impl.pas @@ -0,0 +1,49 @@ +unit com_impl; +// Comtest from Anton K. mantis #35013 +{$WARN SYMBOL_PLATFORM OFF} + +interface +{$ifdef fpc}{$mode delphi}{$endif} + +uses + ComObj, com_serv_TLB; + +type + TTestApp = class(TAutoObject, ITestApp) + private + stor:widestring; + protected + procedure test(const text: WideString); safecall; + procedure test_ret(var res: OleVariant); safecall; + public + procedure Initialize;override; + end; + +implementation + +uses comserv,sysutils; + +procedure TTestApp.Initialize; +begin + inherited; + +end; + +procedure TTestApp.test(const text: WideString); +begin + stor:=formatdatetime('yyyy-mm-dd hh:nn:ss',now)+': '+text; + writeln(stor); +end; + +procedure TTestApp.test_ret(var res: OleVariant); +begin + writeln('Got: '+widestring(res)); + res:=widestring('zzzz'); + // res:=formatdatetime('yyyy-mm-dd hh:nn:ss',now)+': '+widestring(res); + writeln(res); +end; + +initialization + TAutoObjectFactory.Create(ComServer, TTestApp, Class_TestApp, + ciMultiInstance, tmApartment); +end. diff --git a/packages/winunits-base/tests/inproccomtest/com_serv.dpr b/packages/winunits-base/tests/inproccomtest/com_serv.dpr new file mode 100644 index 0000000000..f9b6c9f60a --- /dev/null +++ b/packages/winunits-base/tests/inproccomtest/com_serv.dpr @@ -0,0 +1,42 @@ +program com_serv; +// Comtest from Anton K. mantis #35013 +uses + windows, + messages, + sysutils, + com_serv_TLB in 'com_serv_TLB.pas', + com_impl in 'com_impl.pas' {TestApp: CoClass}; + +{$R *.TLB} + +var msg:TMsg; + res:integer; + fTerminate:boolean; +begin + AllocConsole; + + fTerminate:=false; + + repeat + if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then + begin + if Msg.Message <> WM_QUIT then + begin + TranslateMessage(Msg); + + writeln(format('msg.message=%.08x msg.wparam=%.08x msg.lparam=%.08x',[msg.message,msg.wparam,msg.lparam])); + res:=DispatchMessage(Msg); + writeln(format('result=%.08x',[res])); + end + else + FTerminate := True; + end; + until fterminate; + + + (*Application.Run; + repeat + Application.ProcessMessages; + until Application.Terminated;*) + +end. diff --git a/packages/winunits-base/tests/inproccomtest/com_serv.tlb b/packages/winunits-base/tests/inproccomtest/com_serv.tlb new file mode 100644 index 0000000000..fd7a146300 Binary files /dev/null and b/packages/winunits-base/tests/inproccomtest/com_serv.tlb differ diff --git a/packages/winunits-base/tests/inproccomtest/com_serv_TLB.pas b/packages/winunits-base/tests/inproccomtest/com_serv_TLB.pas new file mode 100644 index 0000000000..bd15f96268 --- /dev/null +++ b/packages/winunits-base/tests/inproccomtest/com_serv_TLB.pas @@ -0,0 +1,116 @@ +unit com_serv_TLB; +// part of Comtest demo from Anton K. mantis #35013 + +// ************************************************************************ // +// WARNING +// ------- +// The types declared in this file were generated from data read from a +// Type Library. If this type library is explicitly or indirectly (via +// another type library referring to this type library) re-imported, or the +// 'Refresh' command of the Type Library Editor activated while editing the +// Type Library, the contents of this file will be regenerated and all +// manual modifications will be lost. +// ************************************************************************ // + +// PASTLWTR : 1.2 +// File generated on 16.08.2019 18:46:07 from Type Library described below. + +// ************************************************************************ // +// Type Lib: com_serv.tlb (1) +// LIBID: {4657B1E3-77D1-4504-A96C-3E79EF05721C} +// LCID: 0 +// Helpfile: +// HelpString: Project1 Library +// DepndLst: +// (1) v2.0 stdole, (C:\WINDOWS\system32\stdole2.tlb) +// ************************************************************************ // +{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. +{$WARN SYMBOL_PLATFORM OFF} +{$WRITEABLECONST ON} +{$VARPROPSETTER ON} +interface +{$ifdef fpc}{$mode delphi}{$endif} + +uses Windows, ActiveX, Classes, Variants; + + +// *********************************************************************// +// GUIDS declared in the TypeLibrary. Following prefixes are used: +// Type Libraries : LIBID_xxxx +// CoClasses : CLASS_xxxx +// DISPInterfaces : DIID_xxxx +// Non-DISP interfaces: IID_xxxx +// *********************************************************************// +const + // TypeLibrary Major and minor versions + com_servMajorVersion = 1; + com_servMinorVersion = 0; + + LIBID_com_serv: TGUID = '{4657B1E3-77D1-4504-A96C-3E79EF05721C}'; + + IID_ITestApp: TGUID = '{1DD0AE6B-30C7-474E-8972-01981454B649}'; + CLASS_TestApp: TGUID = '{FD2054C2-4C67-47AE-A518-3FA6A7D691AA}'; +type + +// *********************************************************************// +// Forward declaration of types defined in TypeLibrary +// *********************************************************************// + ITestApp = interface; + ITestAppDisp = dispinterface; + +// *********************************************************************// +// Declaration of CoClasses defined in Type Library +// (NOTE: Here we map each CoClass to its Default Interface) +// *********************************************************************// + TestApp = ITestApp; + + +// *********************************************************************// +// Interface: ITestApp +// Flags: (4416) Dual OleAutomation Dispatchable +// GUID: {1DD0AE6B-30C7-474E-8972-01981454B649} +// *********************************************************************// + ITestApp = interface(IDispatch) + ['{1DD0AE6B-30C7-474E-8972-01981454B649}'] + procedure test(const text: WideString); safecall; + procedure test_ret(var res: OleVariant); safecall; + end; + +// *********************************************************************// +// DispIntf: ITestAppDisp +// Flags: (4416) Dual OleAutomation Dispatchable +// GUID: {1DD0AE6B-30C7-474E-8972-01981454B649} +// *********************************************************************// + ITestAppDisp = dispinterface + ['{1DD0AE6B-30C7-474E-8972-01981454B649}'] + procedure test(const text: WideString); dispid 201; + procedure test_ret(var res: OleVariant); dispid 202; + end; + +// *********************************************************************// +// The Class CoTestApp provides a Create and CreateRemote method to +// create instances of the default interface ITestApp exposed by +// the CoClass TestApp. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoTestApp = class + class function Create: ITestApp; + class function CreateRemote(const MachineName: string): ITestApp; + end; + +implementation + +uses ComObj; + +class function CoTestApp.Create: ITestApp; +begin + Result := CreateComObject(CLASS_TestApp) as ITestApp; +end; + +class function CoTestApp.CreateRemote(const MachineName: string): ITestApp; +begin + Result := CreateRemoteComObject(MachineName, CLASS_TestApp) as ITestApp; +end; + +end. diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index 4e83e126b2..ca32bbbad1 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/rtl/objpas/classes/classesh.inc @@ -91,6 +91,8 @@ type TAlignment = (taLeftJustify, taRightJustify, taCenter); TLeftRight = taLeftJustify..taRightJustify; + TVerticalAlignment = (taAlignTop, taAlignBottom, taVerticalCenter); + TTopBottom = taAlignTop..taAlignBottom; TBiDiMode = (bdLeftToRight,bdRightToLeft,bdRightToLeftNoAlign,bdRightToLeftReadingOnly);