From dd481d39529c1ebead428a60a2920744f8010486 Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 24 Jun 2020 17:20:11 +0000 Subject: [PATCH] # revisions: 44293,44294,44435,44877,45188,45539 git-svn-id: branches/fixes_3_2@45686 - --- .gitattributes | 2 + packages/chm/src/chmwriter.pas | 17 +- packages/fcl-base/src/fileinfo.pp | 33 ++-- packages/fcl-image/src/fpimage.pp | 32 ++-- packages/fcl-pdf/examples/metautf16.pp | 45 +++++ packages/fcl-pdf/src/fppdf.pp | 220 ++++++++++++++++++++-- packages/fcl-xml/examples/htmlwithsax.lpr | 117 ++++++++++++ utils/fpcm/revision.inc | 2 +- 8 files changed, 416 insertions(+), 52 deletions(-) create mode 100644 packages/fcl-pdf/examples/metautf16.pp create mode 100644 packages/fcl-xml/examples/htmlwithsax.lpr diff --git a/.gitattributes b/.gitattributes index 4eda0256cf..d7dcb0b812 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3653,6 +3653,7 @@ packages/fcl-passrc/tests/testpassrc.lpr svneol=native#text/plain packages/fcl-pdf/Makefile svneol=native#text/plain packages/fcl-pdf/Makefile.fpc svneol=native#text/plain packages/fcl-pdf/examples/diamond.png -text svneol=unset#image/png +packages/fcl-pdf/examples/metautf16.pp svneol=native#text/plain packages/fcl-pdf/examples/poppy.jpg -text packages/fcl-pdf/examples/testfppdf.lpi svneol=native#text/plain packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain @@ -4529,6 +4530,7 @@ packages/fcl-xml/Makefile.fpc svneol=native#text/plain packages/fcl-xml/Makefile.fpc.fpcmake svneol=native#text/plain packages/fcl-xml/buildfclxml.lpi svneol=native#text/plain packages/fcl-xml/buildfclxml.pp svneol=native#text/plain +packages/fcl-xml/examples/htmlwithsax.lpr svneol=native#text/plain packages/fcl-xml/examples/reducexml.lpi svneol=native#text/plain packages/fcl-xml/examples/reducexml.pp svneol=native#text/plain packages/fcl-xml/examples/test.html svneol=native#text/html diff --git a/packages/chm/src/chmwriter.pas b/packages/chm/src/chmwriter.pas index 9ea29f9dc0..a173fd4181 100644 --- a/packages/chm/src/chmwriter.pas +++ b/packages/chm/src/chmwriter.pas @@ -1174,7 +1174,7 @@ const idxhdrmagic ='T#SM'; procedure TChmWriter.CreateIDXHDRStream; var i : Integer; begin - if fmergefiles.count=0 then // I assume text/site properties could also trigger idxhdr + if (fmergefiles.count=0) and not HasBinaryIndex then // I assume text/site properties could also trigger idxhdr exit; FIDXHdrStream.setsize(4096); @@ -2295,7 +2295,7 @@ begin mapstream.size:=2; mapstream.position:=2; propertystream :=TMemoryStream.Create; - propertystream.write(NToLE(0),sizeof(4)); + propertystream.write(NToLE(0),sizeof(longint)); // we iterate over all entries and write listingblocks directly to the stream. // and the first (and maybe last) level is written to blockn. // we can't do higher levels yet because we don't know how many listblocks we get @@ -2442,6 +2442,19 @@ begin hdr.unknown4 :=NToLE(0); // unknown 0 hdr.unknown5 :=NToLE(0); // unknown 0 + if totalentries<>0 then + begin + // If there are no links of this type in the CHM then this will be a zero DWORD. Othewise it contains the following DWORDs: 0, 0, 0, 0xC, 1, 1, 0, 0. AFAICS this file is pretty much useless. + // we already have written the first 0 dword + propertystream.write(NToLE(0),sizeof(longint)); + propertystream.write(NToLE(0),sizeof(longint)); + propertystream.write(NToLE($C),sizeof(longint)); + propertystream.write(NToLE(1),sizeof(longint)); + propertystream.write(NToLE(1),sizeof(longint)); + propertystream.write(NToLE(0),sizeof(longint)); + propertystream.write(NToLE(0),sizeof(longint)); + end; + IndexStream.Position:=0; IndexStream.write(hdr,sizeof(hdr)); {$ifdef binindex} diff --git a/packages/fcl-base/src/fileinfo.pp b/packages/fcl-base/src/fileinfo.pp index 23bd706250..3d2cab7a77 100644 --- a/packages/fcl-base/src/fileinfo.pp +++ b/packages/fcl-base/src/fileinfo.pp @@ -101,17 +101,17 @@ type ); // Extract program version information in 1 call. -Function GetProgramVersion (Var Version : TVersionQuad) : Boolean; -Function GetProgramVersion (Var Version : TProgramVersion) : Boolean; +Function GetProgramVersion (Out Version : TVersionQuad) : Boolean; +Function GetProgramVersion (Out Version : TProgramVersion) : Boolean; // Compare 2 versions Function CompareVersionQuads(Quad1,Quad2 : TVersionQuad) : TVersionCompare; Function CompareProgramVersion(Version1,Version2 : TProgramVersion) : TVersionCompare; // Convert version quad to string Function VersionQuadToStr(Const Quad : TVersionQuad) : String; -Function ProgramversionToStr(Const Version : TProgramVersion) : String; +Function ProgramVersionToStr(Const Version : TProgramVersion) : String; // Try to convert string to version quad. -Function TryStrToVersionQuad(S : String; Var Quad : TVersionQuad) : Boolean; -Function TryStrToProgramVersion(S : String; Var Version : TProgramVersion) : Boolean; +Function TryStrToVersionQuad(S : String; Out Quad : TVersionQuad) : Boolean; +Function TryStrToProgramVersion(S : String; Out Version : TProgramVersion) : Boolean; // Convert string to version quad, raise exception if invalid string. Function StrToVersionQuad(Const S : String) : TVersionQuad; Function StrToProgramVersion(Const S : String ): TProgramVersion; @@ -183,7 +183,7 @@ end; procedure TVersionInfo.Load(Const AFileName : String); Var - I : Integer; + I : LongWord; begin FreeResources; @@ -265,8 +265,7 @@ procedure TFileVersionInfo.ReadFileInfo; Var VI : TVersionInfo; ST : TVersionStringTable; - TI,I,J : Integer; - S: String; + TI,I : Integer; begin FEnabled:=True; @@ -304,9 +303,9 @@ begin end; end; ST:=VI.StringFileInfo.Items[Ti]; - for J:=0 to ST.Count-1 do - if (FFilter.Count=0) or (FFilter.IndexOf(ST.Keys[j])<>-1) then - FVersionStrings.Add(ST.Keys[j]+'='+ST.Values[j]); + for i:=0 to ST.Count-1 do + if (FFilter.Count=0) or (FFilter.IndexOf(ST.Keys[i])<>-1) then + FVersionStrings.Add(ST.Keys[i]+'='+ST.Values[i]); finally FreeAndNil(VI); end; @@ -347,7 +346,7 @@ end; { Convenience function } -Function GetProgramVersion (Var Version : TVersionQuad) : Boolean; +Function GetProgramVersion (Out Version : TVersionQuad) : Boolean; Var VI : TVersionInfo; @@ -370,7 +369,7 @@ begin end; end; -Function GetProgramVersion (Var Version : TProgramVersion) : Boolean; +Function GetProgramVersion (Out Version : TProgramVersion) : Boolean; Var VQ : TVersionQuad; begin @@ -435,7 +434,7 @@ begin Result:=Format('%d.%d.%d.%d',[Version.Major,Version.Minor,Version.Revision,Version.Build]); end; -Function TryStrToProgramVersion(S : String; Var Version : TProgramVersion) : Boolean; +Function TryStrToProgramVersion(S : String; Out Version : TProgramVersion) : Boolean; Var Q : TVersionQuad; @@ -445,7 +444,7 @@ begin Version:=Q; end; -Function TryStrToVersionQuad(S : String; Var Quad : TVersionQuad) : Boolean; +Function TryStrToVersionQuad(S : String; Out Quad : TVersionQuad) : Boolean; Var I,P,Dots,Q : Integer; @@ -488,12 +487,12 @@ end; Function NewerVersion(V1,V2 : TProgramVersion) : Boolean; Var - Q1,Q2 : TversionQuad; + Q1,Q2 : TVersionQuad; begin Q1:=V1; Q2:=V2; - Result:=Newerversion(Q1,Q2); + Result:=NewerVersion(Q1,Q2); end; Function NewerVersion(Q1,Q2 : TVersionQuad) : Boolean; diff --git a/packages/fcl-image/src/fpimage.pp b/packages/fcl-image/src/fpimage.pp index 23bb730b4a..9f03953dce 100644 --- a/packages/fcl-image/src/fpimage.pp +++ b/packages/fcl-image/src/fpimage.pp @@ -664,22 +664,22 @@ type const HtmlColorNameToFPColorMap: array[THtmlColorName] of TFPColor = ( - (red: $ff; green: $ff; blue: $ff; alpha: alphaOpaque), //hcnWhite - (red: $c0; green: $c0; blue: $c0; alpha: alphaOpaque), //hcnSilver - (red: $80; green: $80; blue: $80; alpha: alphaOpaque), //hcnGray - (red: $00; green: $00; blue: $00; alpha: alphaOpaque), //hcnBlack - (red: $ff; green: $00; blue: $00; alpha: alphaOpaque), //hcnRed - (red: $80; green: $00; blue: $00; alpha: alphaOpaque), //hcnMaroon - (red: $ff; green: $ff; blue: $00; alpha: alphaOpaque), //hcnYellow - (red: $80; green: $80; blue: $00; alpha: alphaOpaque), //hcnOlive - (red: $00; green: $ff; blue: $00; alpha: alphaOpaque), //hcnLime - (red: $00; green: $80; blue: $00; alpha: alphaOpaque), //hcnGreen - (red: $00; green: $ff; blue: $ff; alpha: alphaOpaque), //hcnAqua - (red: $00; green: $80; blue: $80; alpha: alphaOpaque), //hcnTeal - (red: $00; green: $00; blue: $ff; alpha: alphaOpaque), //hcnBlue - (red: $00; green: $00; blue: $80; alpha: alphaOpaque), //hcnNavy - (red: $ff; green: $00; blue: $ff; alpha: alphaOpaque), //hcnFuchsia - (red: $80; green: $00; blue: $80; alpha: alphaOpaque) //hcnPurple + (red: $ff or $ff shl 8; green: $ff or $ff shl 8; blue: $ff or $ff shl 8; alpha: alphaOpaque), //hcnWhite + (red: $c0 or $c0 shl 8; green: $c0 or $c0 shl 8; blue: $c0 or $c0 shl 8; alpha: alphaOpaque), //hcnSilver + (red: $80 or $80 shl 8; green: $80 or $80 shl 8; blue: $80 or $80 shl 8; alpha: alphaOpaque), //hcnGray + (red: $00; green: $00; blue: $00; alpha: alphaOpaque), //hcnBlack + (red: $ff or $ff shl 8; green: $00; blue: $00; alpha: alphaOpaque), //hcnRed + (red: $80 or $80 shl 8; green: $00; blue: $00; alpha: alphaOpaque), //hcnMaroon + (red: $ff or $ff shl 8; green: $ff or $ff shl 8; blue: $00; alpha: alphaOpaque), //hcnYellow + (red: $80 or $80 shl 8; green: $80 or $80 shl 8; blue: $00; alpha: alphaOpaque), //hcnOlive + (red: $00; green: $ff or $ff shl 8; blue: $00; alpha: alphaOpaque), //hcnLime + (red: $00; green: $80 or $80 shl 8; blue: $00; alpha: alphaOpaque), //hcnGreen + (red: $00; green: $ff or $ff shl 8; blue: $ff or $ff shl 8; alpha: alphaOpaque), //hcnAqua + (red: $00; green: $80 or $80 shl 8; blue: $80 or $80 shl 8; alpha: alphaOpaque), //hcnTeal + (red: $00; green: $00; blue: $ff or $ff shl 8; alpha: alphaOpaque), //hcnBlue + (red: $00; green: $00; blue: $80 or $80 shl 8; alpha: alphaOpaque), //hcnNavy + (red: $ff or $ff shl 8; green: $00; blue: $ff or $ff shl 8; alpha: alphaOpaque), //hcnFuchsia + (red: $80 or $80 shl 8; green: $00; blue: $80 or $80 shl 8; alpha: alphaOpaque) //hcnPurple ); function TryStrToHtmlColorName(const S: String; out AName: THtmlColorName): Boolean; diff --git a/packages/fcl-pdf/examples/metautf16.pp b/packages/fcl-pdf/examples/metautf16.pp new file mode 100644 index 0000000000..5ef3875ad3 --- /dev/null +++ b/packages/fcl-pdf/examples/metautf16.pp @@ -0,0 +1,45 @@ +program metautf16; + +{$codepage utf-8} + +uses sysutils,fpPDF; + +var + D:TpdfDocument; + S:TPdfSection; + P:TPdfPage; + +begin + D:=TpdfDocument.Create(nil); + try + D.Infos.Title := 'Урывак з паэмы "Новая Зямля"'; + D.Infos.Author := 'Якуб Колас'; + D.Infos.Producer := 'fcl-pdf'; + D.Infos.ApplicationName := 'нейкі тэст'; + D.Infos.CreationDate := Now; + D.Infos.KeyWords:='fcl-pdf report'; + + D.Options := [poPageOriginAtTop,poSubsetFont,poCompressFonts,poCompressImages,poUseImageTransparency,poUTF16Info]; + + D.StartDocument; + D.AddFont('fonts/FreeSans.ttf','FreeSans'); + + + S:=D.Sections.AddSection; + + P:=D.Pages.AddPage; + P.PaperType := ptA4; + P.UnitOfMeasure := uomPixels; + P.Orientation:=ppoPortrait; + S.AddPage(P); + + P.SetFont(0,10); + P.WriteText(100,100,'Мой родны кут,'); + P.WriteText(100,150,'Як ты мне мілы'); + P.WriteText(100,200,'Забыць цябе'); + P.WriteText(100,250,'Не маю сілы'); + finally + D.SaveToFile('test.pdf'); + D.Free; + end; +end. \ No newline at end of file diff --git a/packages/fcl-pdf/src/fppdf.pp b/packages/fcl-pdf/src/fppdf.pp index 646bf1b59d..d481948c36 100644 --- a/packages/fcl-pdf/src/fppdf.pp +++ b/packages/fcl-pdf/src/fppdf.pp @@ -70,7 +70,7 @@ type TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels); TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, - poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency); + poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency,poUTF16info); TPDFOptions = set of TPDFOption; EPDF = Class(Exception); @@ -282,6 +282,16 @@ type property Value: AnsiString read FValue; end; + TPDFUTF16String = class(TPDFAbstractString) + private + FValue: UnicodeString; + protected + procedure Write(const AStream: TStream); override; + public + constructor Create(Const ADocument : TPDFDocument; const AValue: UnicodeString; const AFontIndex : Integer); overload; + property Value: UnicodeString read FValue; + end; + { TPDFRawHexString } TPDFRawHexString = class(TPDFDocumentObject) @@ -424,6 +434,17 @@ type property Text: TPDFUTF8String read FString; end; + TPDFUTF16Text = class(TPDFBaseText) + private + FString: TPDFUTF16String; + protected + procedure Write(const AStream: TStream); override; + public + constructor Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: UnicodeString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); overload; + destructor Destroy; override; + property Text: TPDFUTF16String read FString; + end; + TPDFLineSegment = class(TPDFDocumentObject) private @@ -601,6 +622,7 @@ type procedure AddInteger(const AKey : String; AInteger : Integer); procedure AddReference(const AKey : String; AReference : Integer); procedure AddString(const AKey, AString : String); + procedure AddString(const AKey:string;const AString : UnicodeString); function IndexOfKey(const AValue: string): integer; procedure Write(const AStream: TStream); override; procedure WriteDictionary(const AObject: integer; const AStream: TStream); @@ -1069,7 +1091,7 @@ type procedure CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary); virtual; function CreateContentsEntry(const APageNum: integer): integer;virtual; function CreateCatalogEntry: integer;virtual; - procedure CreateInfoEntry;virtual; + procedure CreateInfoEntry(UseUTF16 : Boolean);virtual; procedure CreateMetadataEntry;virtual; procedure CreateTrailerID;virtual; procedure CreatePreferencesEntry;virtual; @@ -1095,6 +1117,7 @@ type function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual; procedure CreatePageStream(APage : TPDFPage; PageNum: integer); Function CreateString(Const AValue : String) : TPDFString; + Function CreateUTF16String(Const AValue : UnicodeString; const AFontIndex: integer) : TPDFUTF16String; Function CreateUTF8String(Const AValue : UTF8String; const AFontIndex: integer) : TPDFUTF8String; Function CreateGlobalXRef: TPDFXRef; Function AddGlobalXRef(AXRef : TPDFXRef) : Integer; @@ -1117,6 +1140,7 @@ type Function CreateEmbeddedFont(const APage: TPDFPage; AFontIndex, AFontSize : Integer) : TPDFEmbeddedFont; Function CreateText(X,Y : TPDFFloat; AText : AnsiString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean) : TPDFText; overload; Function CreateText(X,Y : TPDFFloat; AText : UTF8String; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean) : TPDFUTF8Text; overload; + Function CreateText(X,Y : TPDFFloat; AText : UnicodeString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean) : TPDFUTF16Text; overload; Function CreateRectangle(const X,Y,W,H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean) : TPDFRectangle; function CreateRoundedRectangle(const X, Y, W, H, ARadius, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean): TPDFRoundedRectangle; Function CreateColor(AColor : TARGBColor; AStroke : Boolean) : TPDFColor; @@ -3431,6 +3455,54 @@ begin FValue := InsertEscape(FValue); end; + +{ TPDFUTF16String } + +constructor TPDFUTF16String.Create(Const ADocument : TPDFDocument; const AValue: Unicodestring; const AFontIndex : Integer); +begin + inherited Create(ADocument); + FValue := AValue; + FFontIndex:=aFontIndex; +end; + +function oct_str(b:byte):string; +begin + Result:=''; + repeat + Result:=IntToStr(b and $7)+Result; + b:=b shr 3; + until b=0; +end; + +procedure TPDFUTF16String.Write(const AStream: TStream); +var + i:integer; + us:utf8string; + s:ansistring; + wv:word; +begin + us := Utf8Encode(FValue); + if (length(us)<>length(fValue)) then // quote + begin + s:='\376\377'; // UTF-16BE BOM + for i:=1 to length(fValue) do + begin + wv:=word(fValue[i]); + s:=s+'\'+oct_str(hi(wv)); + s:=s+'\'+oct_str(lo(wv)); + end; + end else + begin + if (Pos('(', FValue) > 0) or (Pos(')', FValue) > 0) or (Pos('\', FValue) > 0) then + s := InsertEscape(FValue) + else + s:=fValue; + end; + WriteString('('+s+')', AStream); +end; + + + { TPDFUTF8String } function TPDFUTF8String.RemapedText: AnsiString; @@ -3858,6 +3930,101 @@ begin inherited Destroy; end; +{ TPDFUTF16Text } + +procedure TPDFUTF16Text.Write(const AStream: TStream); +var + t1, t2, t3: string; + rad: single; + lFC: TFPFontCacheItem; + lWidth: single; + lTextWidthInMM: single; + lHeight: single; + lTextHeightInMM: single; + lColor: string; + lLineWidth: string; + lDescender: single; + v : UTF8String; + +begin + inherited Write(AStream); + WriteString('BT'+CRLF, AStream); + if Degrees <> 0.0 then + begin + rad := DegToRad(-Degrees); + t1 := FloatStr(Cos(rad)); + t2 := FloatStr(-Sin(rad)); + t3 := FloatStr(Sin(rad)); + WriteString(Format('%s %s %s %s %s %s Tm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream); + end + else + begin + WriteString(FloatStr(X)+' '+FloatStr(Y)+' TD'+CRLF, AStream); + end; + FString.Write(AStream); + WriteString(' Tj'+CRLF, AStream); + WriteString('ET'+CRLF, AStream); + + if (not Underline) and (not StrikeThrough) then + Exit; + + // implement Underline and Strikethrough here + lFC := gTTFontCache.Find(Document.Fonts[Font.FontIndex].Name); + if not Assigned(lFC) then + Exit; // we can't do anything further + + // result is in Font Units + v:=UTF8Encode(FString.Value); + lWidth := lFC.TextWidth(v, Font.PointSize); + lHeight := lFC.TextHeight(v, Font.PointSize, lDescender); + { convert the Font Units to Millimeters. This is also because fontcache DPI (default 96) could differ from PDF DPI (72). } + lTextWidthInMM := (lWidth * cInchToMM) / gTTFontCache.DPI; + lTextHeightInMM := (lHeight * cInchToMM) / gTTFontCache.DPI; + + if Degrees <> 0.0 then + // angled text + WriteString(Format('q %s %s %s %s %s %s cm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream) + else + // horizontal text + WriteString(Format('q 1 0 0 1 %s %s cm', [FloatStr(X), FloatStr(Y)]) + CRLF, AStream); + + { set up a pen width and stroke color } + lColor := TPDFColor.Command(True, Color); + lLineWidth := FloatStr(mmToPDF(lTextHeightInMM / 12)) + ' w '; + WriteString(lLineWidth + lColor + CRLF, AStream); + + { line segment is relative to matrix translation coordinate, set above } + if Underline then + WriteString(Format('0 -1.5 m %s -1.5 l S', [FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream); + if StrikeThrough then + WriteString(Format('0 %s m %s %0:s l S', [FloatStr(mmToPDF(lTextHeightInMM) / 2), FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream); + + { restore graphics state to before the translation matrix adjustment } + WriteString('Q' + CRLF, AStream); + +end; + +constructor TPDFUTF16Text.Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: UnicodeString; + const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); +begin + inherited Create(ADocument); + X := AX; + Y := AY; + Font := AFont; + Degrees := ADegrees; + Underline := AUnderline; + if Assigned(AFont) and Assigned(AFont.Page) then + Color := AFont.Page.FLastFontColor; + StrikeThrough := AStrikeThrough; + FString := ADocument.CreateUTF16String(AText, AFont.FontIndex); +end; + +destructor TPDFUTF16Text.Destroy; +begin + FreeAndNil(FString); + inherited Destroy; +end; + { TPDFLineSegment } procedure TPDFLineSegment.Write(const AStream: TStream); @@ -4202,6 +4369,11 @@ begin AddElement(AKey,Document.CreateString(AString)); end; +procedure TPDFDictionary.AddString(const AKey:string;const AString: UnicodeString); +begin + AddElement(AKey,Document.CreateUTF16String(AString,-1)); +end; + function TPDFDictionary.IndexOfKey(const AValue: string): integer; var i: integer; @@ -4578,7 +4750,7 @@ begin FInfos.Assign(AValue); end; -procedure TPDFDocument.SetOptions(AValue: TPDFOptions); +procedure TPDFDocument.SetOptions(aValue: TPDFOptions); begin if FOptions=AValue then Exit; if (poNoEmbeddedFonts in aValue) then @@ -4772,26 +4944,31 @@ begin Result:=GlobalXRefCount-1; end; -procedure TPDFDocument.CreateInfoEntry; +procedure TPDFDocument.CreateInfoEntry(UseUTF16 : Boolean); var IDict: TPDFDictionary; + Procedure DoEntry(aName, aValue : String; NoUnicode: boolean = false); + + begin + if aValue='' then exit; + if UseUTF16 and not NoUnicode then + IDict.AddString(aName,utf8decode(aValue)) + else + IDict.AddString(aName,aValue); + end; + begin IDict:=CreateGlobalXRef.Dict; Trailer.AddReference('Info', GLobalXRefCount-1); (Trailer.ValueByName('Size') as TPDFInteger).Value:=GLobalXRefCount; - if Infos.Title <> '' then - IDict.AddString('Title',Infos.Title); - if Infos.Author <> '' then - IDict.AddString('Author',Infos.Author); - if Infos.ApplicationName <> '' then - IDict.AddString('Creator',Infos.ApplicationName); - IDict.AddString('Producer',Infos.Producer); - if Infos.CreationDate <> 0 then - IDict.AddString('CreationDate',DateToPdfDate(Infos.CreationDate)); - if Infos.Keywords <> '' then - IDict.AddString('Keywords', Infos.Keywords); + DoEntry('Title',Infos.Title); + DoEntry('Author',Infos.Author); + DoEntry('Creator',Infos.ApplicationName); + DoEntry('Producer',Infos.Producer); + DoEntry('CreationDate',DateToPdfDate(Infos.CreationDate),True); + DoEntry('Keywords',Infos.Keywords); end; procedure TPDFDocument.CreateMetadataEntry; @@ -5530,7 +5707,7 @@ begin CreateRefTable; CreateTrailer; FCatalogue:=CreateCatalogEntry; - CreateInfoEntry; + CreateInfoEntry(poUTF16Info in Options); if poMetadataEntry in Options then CreateMetadataEntry; if not (poNoTrailerID in Options) then @@ -5840,6 +6017,12 @@ begin Result := TPDFUTF8Text.Create(Self, X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); end; +function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: UnicodeString; const AFont: TPDFEmbeddedFont; + const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean): TPDFUTF16Text; +begin + Result := TPDFUTF16Text.Create(Self, X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); +end; + function TPDFDocument.CreateRectangle(const X,Y,W,H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean): TPDFRectangle; begin Result:=TPDFRectangle.Create(Self,X,Y,W,H,ALineWidth,AFill, AStroke); @@ -5876,6 +6059,11 @@ begin Result:=TPDFString.Create(Self,AValue); end; +function TPDFDocument.CreateUTF16String(const AValue: UnicodeString; const AFontIndex: integer): TPDFUTF16String; +begin + Result:=TPDFUTF16String.Create(Self,AValue,aFontIndex); +end; + function TPDFDocument.CreateUTF8String(const AValue: UTF8String; const AFontIndex: integer): TPDFUTF8String; begin Result := TPDFUTF8String.Create(self, AValue, AFontIndex); diff --git a/packages/fcl-xml/examples/htmlwithsax.lpr b/packages/fcl-xml/examples/htmlwithsax.lpr new file mode 100644 index 0000000000..df1ae365fe --- /dev/null +++ b/packages/fcl-xml/examples/htmlwithsax.lpr @@ -0,0 +1,117 @@ +program htmlwithsax; + +uses sysutils, classes, sax,sax_html, custapp; + +Type + + { TMyApp } + + TMyApp = Class(TCustomApplication) + Private + Indent : string; + procedure DoEndDocument(Sender: TObject); + procedure DoEndElement(Sender: TObject; const NamespaceURI, LocalName, QName: SAXString); + procedure DoFile(const aFileName: String); + procedure DoStartDocument(Sender: TObject); + procedure DoStartElement(Sender: TObject; const NamespaceURI, LocalName, QName: SAXString; Atts: TSAXAttributes); + Protected + Procedure DoRun; override; + end; + + +{ TMyApp } + +procedure TMyApp.DoFile(const aFileName : String); + +var + F : TFileStream; + MyReader : THTMLReader; + +begin + MyReader:=Nil; + F:=TFileStream.Create(aFileName,fmOpenRead or fmShareDenyWrite); + try + MyReader:=THTMLReader.Create; + MyReader.OnStartDocument:=@DoStartDocument; + MyReader.OnStartElement:=@DoStartElement; + MyReader.OnEndElement:=@DoEndElement; + MyReader.OnEndDocument:=@DoEndDocument; + MyReader.ParseStream(F); + finally + FreeAndNil(MyReader); + F.Free; + end; +end; + +procedure TMyApp.DoRun; + +var + I : Integer; + +begin + StopOnException:=True; + Terminate; + if ParamCount<1 then + begin + Writeln('Usage : ',ExtractFileName(ExeName),' [htmlfile2 [htmlfile3]]'); + Exit; + end; + for I:=1 to ParamCount do + DoFile(Params[i]); +end; + +procedure TMyApp.DoStartDocument(Sender: TObject); +begin + Writeln('Document start'); + Indent:=''; +end; + +procedure TMyApp.DoEndElement(Sender: TObject; const NamespaceURI, LocalName, QName: SAXString); +begin + Indent:=Copy(Indent,1,Length(Indent)-2); +end; + +procedure TMyApp.DoEndDocument(Sender: TObject); +begin + Writeln('Document end'); + Indent:=''; +end; + +procedure TMyApp.DoStartElement(Sender: TObject; const NamespaceURI, LocalName, QName: SAXString; Atts: TSAXAttributes); + +Var + I : Integer; + S : unicodestring; + +begin + S:=''; + if Assigned(Atts) then + for I:=0 to Atts.Length-1 do + begin + if S<>'' then S:=S+', '; + S:=S+Atts.LocalNames[i]; + end; + Write(Indent,'Tag: <',LocalName,'>'); + if NameSpaceURI<>'' then + Write(' xmlns: ',NameSpaceURI); + if QName<>'' then + Write(', full tag: ',QName); + If S<>'' then + Write(', attrs: ',S); + Writeln; + Indent:=Indent+' '; +end; + + + +begin + With TMyApp.Create(Nil) do + try + Initialize; + Run; + finally + Free; + end; + +end. + diff --git a/utils/fpcm/revision.inc b/utils/fpcm/revision.inc index 4a8d91738e..678b9798e2 100644 --- a/utils/fpcm/revision.inc +++ b/utils/fpcm/revision.inc @@ -1 +1 @@ -'2020-03-20 rev 44315' +'2020-06-20 rev 45662'