From 7db8ffbbdb16391bfde104a914b342ba8ef52f1b Mon Sep 17 00:00:00 2001 From: marco Date: Sun, 27 Sep 2009 16:03:08 +0000 Subject: * deduping #urlstr and #strings git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13767 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/chm/src/chmfilewriter.pas | 24 +++--- packages/chm/src/chmwriter.pas | 157 +++++++++++++++++++++++++++---------- 2 files changed, 131 insertions(+), 50 deletions(-) (limited to 'packages') diff --git a/packages/chm/src/chmfilewriter.pas b/packages/chm/src/chmfilewriter.pas index 1cc98b37d7..a5c4de682f 100644 --- a/packages/chm/src/chmfilewriter.pas +++ b/packages/chm/src/chmfilewriter.pas @@ -26,10 +26,10 @@ interface uses Classes, SysUtils, chmwriter; - + type TChmProject = class; - + TChmProgressCB = procedure (Project: TChmProject; CurrentFile: String) of object; { TChmProject } @@ -42,6 +42,7 @@ type FFiles: TStrings; FIndexFileName: String; FMakeBinaryTOC: Boolean; + FMakeBinaryIndex: Boolean; FMakeSearchable: Boolean; FFileName: String; FOnProgress: TChmProgressCB; @@ -66,12 +67,13 @@ type property AutoFollowLinks: Boolean read FAutoFollowLinks write FAutoFollowLinks; property TableOfContentsFileName: String read FTableOfContentsFileName write FTableOfContentsFileName; property MakeBinaryTOC: Boolean read FMakeBinaryTOC write FMakeBinaryTOC; + property MakeBinaryIndex: Boolean read FMakeBinaryIndex write FMakeBinaryIndex; property Title: String read FTitle write FTitle; property IndexFileName: String read FIndexFileName write FIndexFileName; property MakeSearchable: Boolean read FMakeSearchable write FMakeSearchable; property DefaultPage: String read FDefaultPage write FDefaultPage; property DefaultFont: String read FDefaultFont write FDefaultFont; - + property OnProgress: TChmProgressCB read FOnProgress write FOnProgress; end; @@ -90,7 +92,7 @@ begin // clean up the filename FileName := StringReplace(ExtractFileName(DataName), '\', '/', [rfReplaceAll]); FileName := StringReplace(FileName, '//', '/', [rfReplaceAll]); - + PathInChm := '/'+ExtractFilePath(DataName); if Assigned(FOnProgress) then FOnProgress(Self, DataName); end; @@ -145,7 +147,7 @@ begin Cfg := TXMLConfig.Create(nil); Cfg.Filename := AFileName; FileName := AFileName; - + Files.Clear; FileCount := Cfg.GetValue('Files/Count/Value', 0); for I := 0 to FileCount-1 do begin @@ -153,8 +155,9 @@ begin end; IndexFileName := Cfg.GetValue('Files/IndexFile/Value',''); TableOfContentsFileName := Cfg.GetValue('Files/TOCFile/Value',''); + // For chm file merging, bintoc must be false and binindex true. Change defaults in time? MakeBinaryTOC := Cfg.GetValue('Files/MakeBinaryTOC/Value', True); - + MakeBinaryIndex:= Cfg.GetValue('Files/MakeBinaryIndex/Value', False); AutoFollowLinks := Cfg.GetValue('Settings/AutoFollowLinks/Value', False); MakeSearchable := Cfg.GetValue('Settings/MakeSearchable/Value', False); DefaultPage := Cfg.GetValue('Settings/DefaultPage/Value', ''); @@ -181,7 +184,7 @@ begin Cfg.SetValue('Files/IndexFile/Value', IndexFileName); Cfg.SetValue('Files/TOCFile/Value', TableOfContentsFileName); Cfg.SetValue('Files/MakeBinaryTOC/Value',MakeBinaryTOC); - + Cfg.SetValue('Files/MakeBinaryIndex/Value',MakeBinaryIndex); Cfg.SetValue('Settings/AutoFollowLinks/Value', AutoFollowLinks); Cfg.SetValue('Settings/MakeSearchable/Value', MakeSearchable); Cfg.SetValue('Settings/DefaultPage/Value', DefaultPage); @@ -212,7 +215,7 @@ begin // our callback to get data Writer.OnGetFileData := @GetData; Writer.OnLastFile := @LastFileAdded; - + // give it the list of files Writer.FilesToCompress.AddStrings(Files); @@ -222,10 +225,11 @@ begin Writer.DefaultFont := DefaultFont; Writer.FullTextSearch := MakeSearchable; Writer.HasBinaryTOC := MakeBinaryTOC; - + Writer.HasBinaryIndex := MakeBinaryIndex; + // and write! Writer.Execute; - + if Assigned(TOCStream) then TOCStream.Free; if Assigned(IndexStream) then IndexStream.Free; end; diff --git a/packages/chm/src/chmwriter.pas b/packages/chm/src/chmwriter.pas index 705af4b938..1e5a405098 100644 --- a/packages/chm/src/chmwriter.pas +++ b/packages/chm/src/chmwriter.pas @@ -22,7 +22,7 @@ unit chmwriter; {$MODE OBJFPC}{$H+} interface -uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap; +uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, Avl_Tree; type @@ -33,6 +33,15 @@ type // FileName : /home/user/helpstuff/index.html > index.html // Stream : the file opened with DataName should be written to this stream +Type + TStringIndex = Class // AVLTree needs wrapping in non automated reference type + TheString : String; + StrId : Integer; + end; + TUrlStrIndex = Class + UrlStr : String; + UrlStrId : Integer; + end; { TChmWriter } @@ -40,9 +49,9 @@ type FOnLastFile: TNotifyEvent; private FHasBinaryTOC: Boolean; - + FHasBinaryIndex: Boolean; ForceExit: Boolean; - + FDefaultFont: String; FDefaultPage: String; FFullTextSearch: Boolean; @@ -82,6 +91,10 @@ type HeaderSuffix: TITSFHeaderSuffix; //contains the offset of CONTENTSection0 from zero HeaderSection0: TITSPHeaderPrefix; HeaderSection1: TITSPHeader; // DirectoryListings header + FAvlStrings : TAVLTree; // dedupe strings + FAvlURLStr : TAVLTree; // dedupe urltbl + binindex must resolve URL to topicid + SpareString : TStringIndex; + SpareUrlStr : TUrlStrIndex; // DirectoryListings // CONTENT Section 0 (section 1 is contained in section 0) // EOF @@ -138,7 +151,8 @@ type property FullTextSearch: Boolean read FFullTextSearch write FFullTextSearch; property SearchTitlesOnly: Boolean read FSearchTitlesOnly write FSearchTitlesOnly; property HasBinaryTOC: Boolean read FHasBinaryTOC write FHasBinaryTOC; - property DefaultFont: String read FDefaultFont write FDefaultFont; + property HasBinaryIndex: Boolean read FHasBinaryIndex write FHasBinaryIndex; + property DefaultFont: String read FDefaultFont write FDefaultFont; property DefaultPage: String read FDefaultPage write FDefaultPage; property TempRawStream: TStream read FTempStream write SetTempRawStream; //property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID; @@ -148,12 +162,31 @@ implementation uses dateutils, sysutils, paslzxcomp, chmFiftiMain; const - LZX_WINDOW_SIZE = 16; // 16 = 2 frames = 1 shl 16 LZX_FRAME_SIZE = $8000; {$I chmobjinstconst.inc} + +Function CompareStrings(Node1, Node2: Pointer): integer; +var n1,n2 : TStringIndex; +begin + n1:=TStringIndex(Node1); n2:=TStringIndex(Node2); + Result := CompareText(n1.TheString, n2.TheString); + if Result < 0 then Result := -1 + else if Result > 0 then Result := 1; +end; + + +Function CompareUrlStrs(Node1, Node2: Pointer): integer; +var n1,n2 : TUrlStrIndex; +begin + n1:=TUrlStrIndex(Node1); n2:=TUrlStrIndex(Node2); + Result := CompareText(n1.UrlStr, n2.UrlStr); + if Result < 0 then Result := -1 + else if Result > 0 then Result := 1; +end; + { TChmWriter } procedure TChmWriter.InitITSFHeader; @@ -179,10 +212,10 @@ begin // header section 1 HeaderSection1Table.PosFromZero := HeaderSection0Table.PosFromZero + HeaderSection0Table.Length; HeaderSection1Table.Length := SizeOf(TITSPHeader)+FDirectoryListings.Size; - + //contains the offset of CONTENT Section0 from zero HeaderSuffix.Offset := HeaderSection1Table.PosFromZero + HeaderSection1Table.Length; - + // now fix endian stuff HeaderSection0Table.PosFromZero := NToLE(HeaderSection0Table.PosFromZero); HeaderSection0Table.Length := NToLE(HeaderSection0Table.Length); @@ -209,7 +242,7 @@ begin //IndexOfRootChunk := -1;// if no root chunk //FirstPMGLChunkIndex, //LastPMGLChunkIndex: LongWord; - + Unknown2 := NToLE(Longint(-1)); //DirectoryChunkCount: LongWord; LanguageID := NToLE(DWord($0409)); @@ -219,7 +252,7 @@ begin Unknown4 := NToLE(Longint(-1)); Unknown5 := NToLE(Longint(-1)); end; - + // more endian stuff HeaderSuffix.Offset := NToLE(HeaderSuffix.Offset); end; @@ -289,7 +322,7 @@ const ParentIndex, TmpIndex: TPMGIDirectoryChunk; begin - with IndexHeader do + with IndexHeader do begin PMGIsig := PMGI; UnusedSpace := NToLE(IndexBlock.FreeSpace); @@ -298,11 +331,11 @@ const IndexBlock.WriteChunkToStream(FDirectoryListings, ChunkIndex, ShouldFinish); IndexBlock.Clear; if HeaderSection1.IndexOfRootChunk < 0 then HeaderSection1.IndexOfRootChunk := ChunkIndex; - if ShouldFinish then + if ShouldFinish then begin HeaderSection1.IndexTreeDepth := 2; ParentIndex := IndexBlock.ParentChunk; - if ParentIndex <> nil then + if ParentIndex <> nil then repeat // the parent index is notified by our child index when to write HeaderSection1.IndexOfRootChunk := ChunkIndex; TmpIndex := ParentIndex; @@ -344,7 +377,7 @@ begin FInternalFiles.Sort; HeaderSection1.IndexTreeDepth := 1; HeaderSection1.IndexOfRootChunk := -1; - + ChunkIndex := 0; IndexBlock := TPMGIDirectoryChunk.Create(SizeOf(TPMGIIndexChunk)); @@ -375,9 +408,9 @@ begin if not ListingBlock.CanHold(Size) then WriteListChunk; - + ListingBlock.WriteEntry(Size, @Buffer[0]); - + if ListingBlock.ItemCount = 1 then begin // add the first list item to the index Move(Buffer[0], FirstListEntry.Entry[0], FESize); FirstListEntry.Size := FESize + WriteCompressedInteger(@FirstListEntry.Entry[FESize], ChunkIndex); @@ -395,7 +428,7 @@ begin IndexBlock.Free; ListingBlock.Free; - + //now fix some endian stuff HeaderSection1.IndexOfRootChunk := NToLE(HeaderSection1.IndexOfRootChunk); HeaderSection1.IndexTreeDepth := NtoLE(HeaderSection1.IndexTreeDepth); @@ -463,13 +496,13 @@ begin // two for a QWord FSection0.WriteDWord(0); FSection0.WriteDWord(0); - + FSection0.WriteDWord(0); FSection0.WriteDWord(0); - - + + ////////////////////////<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< // 2 default page to load if FDefaultPage <> '' then begin @@ -493,14 +526,14 @@ begin FSection0.Write(FDefaultFont[1], Length(FDefaultFont)); FSection0.WriteByte(0); end; - + // 6 // unneeded. if output file is : /somepath/OutFile.chm the value here is outfile(lowercase) {FSection0.WriteWord(6); FSection0.WriteWord(Length('test1')+1); Fsection0.Write('test1', 5); FSection0.WriteByte(0);} - + // 0 Table of contents filename if FHasTOC then begin TmpStr := 'default.hhc'; @@ -524,13 +557,13 @@ begin Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset; FInternalFiles.AddEntry(Entry); - {// 7 Binary Index + // 7 Binary Index if FHasBinaryIndex then begin FSection0.WriteWord(NToLE(Word(7))); FSection0.WriteWord(NToLE(Word(4))); FSection0.WriteDWord(DWord(0)); // what is this number to be? - end;} + end; // 11 Binary TOC if FHasBinaryTOC then @@ -551,7 +584,7 @@ begin Entry.Compressed := False; Entry.DecompressedOffset :=0;// FSection0.Position; Entry.DecompressedSize := 0; - + FInternalFiles.AddEntry(Entry); end; @@ -569,14 +602,13 @@ begin cnt:=pinteger(state)^; for i := 0 to AWord.DocumentCount-1 do Inc(cnt, AWord.GetLogicalDocument(i).NumberOfIndexEntries); - // was commented in original procedure, seems to list index entries per doc. + // was commented in original procedure, seems to list index entries per doc. //WriteLn(AWord.TheWord,' documents = ', AWord.DocumentCount, ' h pinteger(state)^:=cnt; -end; +end; procedure TChmWriter.WriteTOPICS; var - AWord: TIndexedWord; FHits: Integer; i: Integer; begin @@ -584,7 +616,7 @@ begin Exit; FTopicsStream.Position := 0; PostAddStreamToArchive('#TOPICS', '/', FTopicsStream); - // I commented the code below since the result seemed unused + // I commented the code below since the result seemed unused // FHits:=0; // FIndexedFiles.ForEach(@IterateWord,FHits); end; @@ -596,7 +628,7 @@ begin FContextStream.Position := 0; // the size of all the entries FContextStream.WriteDWord(NToLE(DWord(FContextStream.Size-SizeOf(dword)))); - + FContextStream.Position := 0; AddStreamToArchive('#IVB', '/', FContextStream); end; @@ -802,7 +834,7 @@ begin Entry.Path := '::DataSpace/Storage/MSCompressed/'; Entry.Name := 'ControlData'; FInternalFiles.AddEntry(Entry, False); - + // ::DataSpace/Storage/MSCompressed/SpanInfo Entry.DecompressedOffset := FSection0.Position; Entry.DecompressedSize := WriteSpanInfoToStream(FSection0, FReadCompressedSize); @@ -833,16 +865,24 @@ begin Entry.Name := 'Content'; FInternalFiles.AddEntry(Entry, False); - + end; function TChmWriter.AddString(AString: String): LongWord; var NextBlock: DWord; Pos: DWord; + n : TAVLTreeNode; + StrRec : TStringIndex; begin // #STRINGS starts with a null char if FStringsStream.Size = 0 then FStringsStream.WriteByte(0); + + SpareString.TheString:=AString; + n:=fAvlStrings.FindKey(SpareString,@CompareStrings); + if assigned(n) then + exit(TStringIndex(n.data).strid); + // each entry is a null terminated string Pos := DWord(FStringsStream.Position); @@ -857,11 +897,16 @@ begin Result := FStringsStream.Position; FStringsStream.WriteBuffer(AString[1], Length(AString)); FStringsStream.WriteByte(0); + + StrRec:=TStringIndex.Create; + StrRec.TheString:=AString; + StrRec.Strid :=Result; + fAvlStrings.Add(StrRec); end; function TChmWriter.AddURL ( AURL: String; TopicsIndex: DWord ) : LongWord; - procedure CheckURLStrBlockCanHold(AString: String); + procedure CheckURLStrBlockCanHold(Const AString: String); var Rem: LongWord; Len: LongWord; @@ -876,26 +921,48 @@ function TChmWriter.AddURL ( AURL: String; TopicsIndex: DWord ) : LongWord; end; end; - function AddURLString(AString: String): DWord; + function AddURLString(Const AString: String): DWord; + var urlstrrec : TUrlStrIndex; begin CheckURLStrBlockCanHold(AString); if FURLSTRStream.Size mod $4000 = 0 then FURLSTRStream.WriteByte(0); Result := FURLSTRStream.Position; + UrlStrRec:=TUrlStrIndex.Create; + UrlStrRec.UrlStr:=AString; + UrlStrRec.UrlStrid:=result; + FAvlUrlStr.Add(UrlStrRec); FURLSTRStream.WriteDWord(NToLE(DWord(0))); // URL Offset for topic after the the "Local" value FURLSTRStream.WriteDWord(NToLE(DWord(0))); // Offset of FrameName?? FURLSTRStream.Write(AString[1], Length(AString)); FURLSTRStream.WriteByte(0); //NT end; + + function LookupUrlString(const AUrl : String):DWord; + var n :TAvlTreeNode; + begin + SpareUrlStr.UrlStr:=AUrl; + n:=FAvlUrlStr.FindKey(SpareUrlStr,@CompareUrlStrs); + if assigned(n) Then + result:=TUrlStrIndex(n.data).UrlStrId + else + result:=AddUrlString(AUrl); + end; + + +var UrlIndex : Integer; + begin if AURL[1] = '/' then Delete(AURL,1,1); + UrlIndex:=LookupUrlString(AUrl); + //if $1000 - (FURLTBLStream.Size mod $1000) = 4 then // we are at 4092 if FURLTBLStream.Size and $FFC = $FFC then // faster :) FURLTBLStream.WriteDWord(0); Result := FURLTBLStream.Position; FURLTBLStream.WriteDWord(0);//($231e9f5c); //unknown FURLTBLStream.WriteDWord(NtoLE(TopicsIndex)); // Index of topic in #TOPICS - FURLTBLStream.WriteDWord(NtoLE(AddURLString(AURL))); + FURLTBLStream.WriteDWord(NtoLE(UrlIndex)); end; function _AtEndOfData(arg: pointer): LongBool; cdecl; @@ -931,7 +998,7 @@ begin FileEntry.DecompressedSize := FCurrentStream.Size; FileEntry.DecompressedOffset := FReadCompressedSize; //269047723;//to test writing really large numbers FileEntry.Compressed := True; - + if FullTextSearch then CheckFileMakeSearchable(FCurrentStream, FileEntry); @@ -1074,6 +1141,11 @@ begin FDestroyStream := FreeStreamOnDestroy; FFileNames := TStringList.Create; FIndexedFiles := TIndexedWordList.Create; + FAvlStrings := TAVLTree.Create(@CompareStrings); // dedupe strings + FAvlURLStr := TAVLTree.Create(@CompareUrlStrs); // dedupe urltbl + binindex must resolve URL to topicid + SpareString := TStringIndex.Create; // We need an object to search in avltree + SpareUrlStr := TUrlStrIndex.Create; // to avoid create/free circles we keep one in spare + // for searching purposes end; destructor TChmWriter.Destroy; @@ -1093,6 +1165,12 @@ begin FDirectoryListings.Free; FFileNames.Free; FIndexedFiles.Free; + SpareString.free; + SpareUrlStr.free; + FAvlUrlStr.FreeAndClear; + FAvlUrlStr.Free; + FAvlStrings.FreeAndClear; + FAvlStrings.Free; inherited Destroy; end; @@ -1104,12 +1182,12 @@ begin // write any internal files to FCurrentStream that we want in the compressed section WriteIVB; - + // written to Section0 (uncompressed) WriteREADMEFile; WriteOBJINST; - + // move back to zero so that we can start reading from zero :) FReadCompressedSize := FCurrentStream.Size; FCurrentStream.Position := 0; // when compressing happens, first the FCurrentStream is read @@ -1128,7 +1206,7 @@ begin //this creates all special files in the archive that start with ::DataSpace WriteDataSpaceFiles(FSection0); - + // creates all directory listings including header CreateDirectoryListings; @@ -1200,7 +1278,7 @@ begin FreeAndNil(NextLevelItems); while NextLevelItems <> nil do - begin + begin CurrentLevelItems := NextLevelItems; NextLevelItems := TFPList.Create; @@ -1314,7 +1392,6 @@ begin TOCIDXStream.Position := 0; AppendBinaryTOCStream(TOCIDXStream); TOCIDXStream.Free; - end; procedure TChmWriter.AppendBinaryTOCStream(AStream: TStream); -- cgit v1.2.1 From 6a1a652d8b93bb416a49af727c423fdd10393fd8 Mon Sep 17 00:00:00 2001 From: mazen Date: Mon, 28 Sep 2009 11:25:25 +0000 Subject: * Source coude don't need to be executable (removes Debian lintian error). git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13771 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/objcrtl/fpmake.pp | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 packages/objcrtl/fpmake.pp (limited to 'packages') diff --git a/packages/objcrtl/fpmake.pp b/packages/objcrtl/fpmake.pp old mode 100755 new mode 100644 -- cgit v1.2.1 From fcf8107ab3775cb42b770d380e17d938b3a4d236 Mon Sep 17 00:00:00 2001 From: joost Date: Wed, 30 Sep 2009 18:10:51 +0000 Subject: * Allow the use of the mysql client version 5.1 with TMysqlClient50Connection git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13781 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-db/src/sqldb/mysql/mysqlconn.inc | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'packages') diff --git a/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc b/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc index 7c6dbd49b2..067f516c37 100644 --- a/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc +++ b/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc @@ -338,17 +338,19 @@ begin end; procedure TConnectionName.DoInternalConnect; +var ClientVerStr: string; begin InitialiseMysql; + ClientVerStr := copy(strpas(mysql_get_client_info()),1,3); {$IFDEF mysql50} - if copy(strpas(mysql_get_client_info()),1,3)<>'5.0' then + if (ClientVerStr<>'5.0') and (ClientVerStr<>'5.1') then Raise EInOutError.CreateFmt(SErrNotversion50,[strpas(mysql_get_client_info())]); {$ELSE} {$IFDEF mysql41} - if copy(strpas(mysql_get_client_info()),1,3)<>'4.1' then + if ClientVerStr<>'4.1' then Raise EInOutError.CreateFmt(SErrNotversion41,[strpas(mysql_get_client_info())]); {$ELSE} - if copy(strpas(mysql_get_client_info()),1,3)<>'4.0' then + if ClientVerStr<>'4.0' then Raise EInOutError.CreateFmt(SErrNotversion40,[strpas(mysql_get_client_info())]); {$ENDIF} {$ENDIF} -- cgit v1.2.1 From 6aeb2fccde0fa226da33563f8e0e45bde7ad4a56 Mon Sep 17 00:00:00 2001 From: sergei Date: Thu, 1 Oct 2009 19:11:47 +0000 Subject: * r13729 was broken due to missing typecast, shame on me. Fixed. git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13787 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-xml/tests/domunit.pp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'packages') diff --git a/packages/fcl-xml/tests/domunit.pp b/packages/fcl-xml/tests/domunit.pp index 48cf0b74dc..896a220275 100644 --- a/packages/fcl-xml/tests/domunit.pp +++ b/packages/fcl-xml/tests/domunit.pp @@ -323,7 +323,7 @@ begin src := TXMLInputSource.Create(data); try FParser.Parse(src, TXMLDocument(Doc)); - GC(Doc); + GC(TObject(Doc)); finally src.Free; end; -- cgit v1.2.1 From f749702524f1ea7cc5be12df83ea3bb5125f4a57 Mon Sep 17 00:00:00 2001 From: sergei Date: Thu, 1 Oct 2009 19:14:36 +0000 Subject: + 3 more tests for verifying the namespace fixup git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13788 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-xml/tests/extras.pp | 112 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 111 insertions(+), 1 deletion(-) (limited to 'packages') diff --git a/packages/fcl-xml/tests/extras.pp b/packages/fcl-xml/tests/extras.pp index 16d8f012af..e58786426f 100644 --- a/packages/fcl-xml/tests/extras.pp +++ b/packages/fcl-xml/tests/extras.pp @@ -18,7 +18,7 @@ unit extras; interface uses - SysUtils, Classes, DOM, xmlread, domunit, testregistry; + SysUtils, Classes, DOM, xmlread, xmlwrite, domunit, testregistry; implementation @@ -29,6 +29,9 @@ type procedure attr_ownership02; procedure attr_ownership03; procedure attr_ownership04; + procedure nsFixup1; + procedure nsFixup2; + procedure nsFixup3; end; { TDOMTestExtra } @@ -113,7 +116,114 @@ begin AssertEquals('ownerElement2', el, attr2.OwnerElement); end; +const + nsURI1 = 'http://www.example.com/ns1'; + nsURI2 = 'http://www.example.com/ns2'; +// verify the namespace fixup with two nested elements +// (same localName, different nsURI, and no prefixes) +procedure TDOMTestExtra.nsFixup1; +var + domImpl: TDOMImplementation; + origDoc: TDOMDocument; + parsedDoc: TDOMDocument; + docElem: TDOMElement; + el: TDOMElement; + stream: TStringStream; + list: TDOMNodeList; +begin + FParser.Options.Namespaces := True; + domImpl := GetImplementation; + origDoc := domImpl.createDocument(nsURI1, 'test', nil); + docElem := origDoc.documentElement; + el := origDoc.CreateElementNS(nsURI2, 'test'); + docElem.AppendChild(el); + + stream := TStringStream.Create(''); + GC(stream); + writeXML(origDoc, stream); + LoadStringData(parsedDoc, stream.DataString); + + docElem := parsedDoc.documentElement; + assertEquals('docElemLocalName', 'test', docElem.localName); + assertEquals('docElemNS', nsURI1, docElem.namespaceURI); + + list := docElem.GetElementsByTagNameNS(nsURI2, '*'); + assertEquals('ns2_elementCount', 1, list.Length); + el := TDOMElement(list[0]); + assertEquals('ns2_nodeName', 'test', el.nodeName); +end; + +// verify the namespace fixup with two nested elements +// (same localName, different nsURI, different prefixes) +procedure TDOMTestExtra.nsFixup2; +var + domImpl: TDOMImplementation; + origDoc: TDOMDocument; + parsedDoc: TDOMDocument; + docElem: TDOMElement; + el: TDOMElement; + stream: TStringStream; + list: TDOMNodeList; +begin + FParser.Options.Namespaces := True; + domImpl := GetImplementation; + origDoc := domImpl.createDocument(nsURI1, 'a:test', nil); + docElem := origDoc.documentElement; + el := origDoc.CreateElementNS(nsURI2, 'b:test'); + docElem.AppendChild(el); + + stream := TStringStream.Create(''); + GC(stream); + writeXML(origDoc, stream); + LoadStringData(parsedDoc, stream.DataString); + + docElem := parsedDoc.documentElement; + assertEquals('docElemLocalName', 'test', docElem.localName); + assertEquals('docElemNS', nsURI1, docElem.namespaceURI); + + list := docElem.GetElementsByTagNameNS(nsURI2, '*'); + assertEquals('ns2_elementCount', 1, list.Length); + el := TDOMElement(list[0]); + assertEquals('ns2_nodeName', 'b:test', el.nodeName); +end; + +// verify the namespace fixup with two nested elements and an attribute +// attribute's prefix must change to that of document element +procedure TDOMTestExtra.nsFixup3; +var + domImpl: TDOMImplementation; + origDoc: TDOMDocument; + parsedDoc: TDOMDocument; + docElem: TDOMElement; + el: TDOMElement; + stream: TStringStream; + list: TDOMNodeList; + attr: TDOMAttr; +begin + FParser.Options.Namespaces := True; + domImpl := GetImplementation; + origDoc := domImpl.createDocument(nsURI1, 'a:test', nil); + docElem := origDoc.documentElement; + el := origDoc.CreateElementNS(nsURI2, 'b:test'); + docElem.AppendChild(el); + el.SetAttributeNS(nsURI1, 'test:attr', 'test value'); + + stream := TStringStream.Create(''); + GC(stream); + writeXML(origDoc, stream); + LoadStringData(parsedDoc, stream.DataString); + + docElem := parsedDoc.documentElement; + assertEquals('docElemLocalName', 'test', docElem.localName); + assertEquals('docElemNS', nsURI1, docElem.namespaceURI); + + list := docElem.GetElementsByTagNameNS(nsURI2, '*'); + assertEquals('ns2_elementCount', 1, list.Length); + el := TDOMElement(list[0]); + attr := el.GetAttributeNodeNS(nsURI1, 'attr'); + assertEquals('attr_nodeName', 'a:attr', attr.nodeName); +end; initialization -- cgit v1.2.1 From 6af3c2bcddce0172c007be1f06b0e07f86e77338 Mon Sep 17 00:00:00 2001 From: sergei Date: Thu, 1 Oct 2009 19:29:13 +0000 Subject: + XML writer now performs the namespace normalization. git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13789 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-xml/src/dom.pp | 1 + packages/fcl-xml/src/xmlutils.pp | 171 ++++++++++++++++++++++++++++++++++++++- packages/fcl-xml/src/xmlwrite.pp | 92 ++++++++++++++++++++- 3 files changed, 260 insertions(+), 4 deletions(-) (limited to 'packages') diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index 4c2e791caf..ff1e9302cb 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/packages/fcl-xml/src/dom.pp @@ -260,6 +260,7 @@ type function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual; function FindNode(const ANodeName: DOMString): TDOMNode; virtual; function CompareName(const name: DOMString): Integer; virtual; + property Flags: TNodeFlags read FFlags; end; TDOMNodeClass = class of TDOMNode; diff --git a/packages/fcl-xml/src/xmlutils.pp b/packages/fcl-xml/src/xmlutils.pp index 4280bc4f92..d8c5c1a6ab 100644 --- a/packages/fcl-xml/src/xmlutils.pp +++ b/packages/fcl-xml/src/xmlutils.pp @@ -20,7 +20,7 @@ unit xmlutils; interface uses - SysUtils; + SysUtils, Classes; function IsXmlName(const Value: WideString; Xml11: Boolean = False): Boolean; overload; function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean; overload; @@ -40,6 +40,7 @@ function WStrLIComp(S1, S2: PWideChar; Len: Integer): Integer; type {$ifndef fpc} PtrInt = LongInt; + TFPList = TList; {$endif} PPHashItem = ^PHashItem; @@ -100,6 +101,36 @@ type destructor Destroy; override; end; + TBinding = class + public + uri: WideString; + next: TBinding; + prevPrefixBinding: TObject; + Prefix: PHashItem; + end; + + TAttributeAction = (aaUnchanged, aaPrefix, aaBoth); + + TNSSupport = class(TObject) + private + FNesting: Integer; + FPrefixSeqNo: Integer; + FFreeBindings: TBinding; + FBindings: TFPList; + FBindingStack: array of TBinding; + FPrefixes: THashTable; + FDefaultPrefix: THashItem; + function GetBinding(const nsURI: WideString; aPrefix: PHashItem): TBinding; + public + constructor Create; + destructor Destroy; override; + procedure DefineBinding(const Prefix, nsURI: WideString; out Binding: TBinding); + function CheckAttribute(const Prefix, nsURI: WideString; + out Binding: TBinding): TAttributeAction; + procedure StartElement; + procedure EndElement; + end; + {$i names.inc} implementation @@ -625,6 +656,144 @@ begin result := False; end; +{ TNSSupport } + +constructor TNSSupport.Create; +begin + inherited Create; + FPrefixes := THashTable.Create(16, False); + FBindings := TFPList.Create; + SetLength(FBindingStack, 16); +end; + +destructor TNSSupport.Destroy; +var + I: Integer; +begin + for I := FBindings.Count-1 downto 0 do + TObject(FBindings.List^[I]).Free; + FBindings.Free; + FPrefixes.Free; + inherited Destroy; +end; + +function TNSSupport.GetBinding(const nsURI: WideString; aPrefix: PHashItem): TBinding; +begin + { try to reuse an existing binding } + result := FFreeBindings; + if Assigned(result) then + FFreeBindings := result.Next + else { no free bindings, create a new one } + begin + result := TBinding.Create; + FBindings.Add(result); + end; + + { link it into chain of bindings at the current element level } + result.Next := FBindingStack[FNesting]; + FBindingStack[FNesting] := result; + + { bind } + result.uri := nsURI; + result.Prefix := aPrefix; + result.PrevPrefixBinding := aPrefix^.Data; + aPrefix^.Data := result; // ** null binding not used here ** +end; + +procedure TNSSupport.DefineBinding(const Prefix, nsURI: WideString; + out Binding: TBinding); +var + Pfx: PHashItem; +begin + Pfx := @FDefaultPrefix; + if (nsURI <> '') and (Prefix <> '') then + Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix)); + if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then + Binding := GetBinding(nsURI, Pfx) + else + Binding := nil; +end; + +function TNSSupport.CheckAttribute(const Prefix, nsURI: WideString; + out Binding: TBinding): TAttributeAction; +var + Pfx: PHashItem; + I: Integer; + b: TBinding; + buf: array[0..31] of WideChar; + p: PWideChar; +begin + Binding := nil; + Pfx := nil; + if Prefix <> '' then + Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix)); + Result := aaUnchanged; + // no prefix, not bound, or bound to wrong URI + if (Pfx = nil) or (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then + begin + // see if there's another prefix bound to the target URI + // TODO: should use something faster than linear search + for i := FNesting downto 0 do + begin + b := FBindingStack[i]; + while Assigned(b) do + begin + if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then + begin + Binding := b; // found one -> override the attribute's prefix + Result := aaPrefix; + Exit; + end; + b := b.Next; + end; + end; + // no prefix, or bound (to wrong URI) -> must use generated prefix instead + if (Pfx = nil) or Assigned(Pfx^.Data) then + repeat + Inc(FPrefixSeqNo); + i := FPrefixSeqNo; // This is just 'NS'+IntToStr(FPrefixSeqNo); + p := @Buf[high(Buf)]; // done without using strings + while i <> 0 do + begin + p^ := WideChar(i mod 10+ord('0')); + dec(p); + i := i div 10; + end; + p^ := 'S'; dec(p); + p^ := 'N'; + Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1); + until Pfx^.Data = nil; + Binding := GetBinding(nsURI, Pfx); + Result := aaBoth; + end; +end; + +procedure TNSSupport.StartElement; +begin + Inc(FNesting); + if FNesting >= Length(FBindingStack) then + SetLength(FBindingStack, FNesting * 2); +end; + +procedure TNSSupport.EndElement; +var + b, temp: TBinding; +begin + temp := FBindingStack[FNesting]; + while Assigned(temp) do + begin + b := temp; + temp := b.next; + b.next := FFreeBindings; + FFreeBindings := b; + b.Prefix^.Data := b.prevPrefixBinding; + end; + FBindingStack[FNesting] := nil; + if FNesting > 0 then + Dec(FNesting); +end; + + initialization finalization diff --git a/packages/fcl-xml/src/xmlwrite.pp b/packages/fcl-xml/src/xmlwrite.pp index 7ca4e9f1ef..9ff777ce23 100644 --- a/packages/fcl-xml/src/xmlwrite.pp +++ b/packages/fcl-xml/src/xmlwrite.pp @@ -37,7 +37,7 @@ procedure WriteXML(Element: TDOMNode; AStream: TStream); overload; implementation -uses SysUtils; +uses SysUtils, xmlutils; type TSpecialCharCallback = procedure(c: WideChar) of object; @@ -51,6 +51,8 @@ type FBufPos: PChar; FCapacity: Integer; FLineBreak: string; + FNSHelper: TNSSupport; + FScratch: TFPList; procedure wrtChars(Src: PWideChar; Length: Integer); procedure IncIndent; procedure DecIndent; {$IFDEF HAS_INLINE} inline; {$ENDIF} @@ -62,6 +64,8 @@ type const SpecialCharCallback: TSpecialCharCallback); procedure AttrSpecialCharCallback(c: WideChar); procedure TextNodeSpecialCharCallback(c: WideChar); + procedure WriteNSDef(B: TBinding); + procedure NamespaceFixup(Element: TDOMElement); protected procedure Write(const Buffer; Count: Longint); virtual; abstract; procedure WriteNode(Node: TDOMNode); @@ -159,10 +163,14 @@ begin // Later on, this may be put under user control // for now, take OS setting FLineBreak := sLineBreak; + FNSHelper := TNSSupport.Create; + FScratch := TFPList.Create; end; destructor TXMLWriter.Destroy; begin + FScratch.Free; + FNSHelper.Free; if FBufPos > FBuffer then write(FBuffer^, FBufPos-FBuffer); @@ -362,6 +370,80 @@ begin end; end; +procedure TXMLWriter.WriteNSDef(B: TBinding); +begin + wrtChars(' xmlns', 6); + if B.Prefix^.Key <> '' then + begin + wrtChr(':'); + wrtStr(B.Prefix^.Key); + end; + wrtChars('="', 2); + ConvWrite(B.uri, AttrSpecialChars, {$IFDEF FPC}@{$ENDIF}AttrSpecialCharCallback); + wrtChr('"'); +end; + +procedure TXMLWriter.NamespaceFixup(Element: TDOMElement); +var + B: TBinding; + i: Integer; + attr: TDOMNode; + s: DOMString; + action: TAttributeAction; +begin + FScratch.Count := 0; + if Element.hasAttributes then + begin + for i := 0 to Element.Attributes.Length-1 do + begin + attr := Element.Attributes[i]; + if nfLevel2 in attr.Flags then + begin + if TDOMNode_NS(attr).NSI.NSIndex = 2 then + begin + if TDOMNode_NS(attr).NSI.PrefixLen = 0 then + s := '' + else + s := attr.localName; + FNSHelper.DefineBinding(s, attr.nodeValue, B); + if Assigned(B) then // drop redundant namespace declarations + VisitAttribute(attr); + end + else + FScratch.Add(attr); + end + else if TDOMAttr(attr).Specified then // Level 1 attribute + VisitAttribute(attr); + end; + end; + + FNSHelper.DefineBinding(Element.Prefix, Element.namespaceURI, B); + if Assigned(B) then + WriteNSDef(B); + + for i := 0 to FScratch.Count-1 do + begin + attr := TDOMNode(FScratch[i]); + action := FNSHelper.CheckAttribute(attr.Prefix, attr.namespaceURI, B); + if action = aaBoth then + WriteNSDef(B); + + if action in [aaPrefix, aaBoth] then + begin + // use prefix from the binding, it might have been changed + wrtChr(' '); + wrtStr(B.Prefix^.Key); + wrtChr(':'); + wrtStr(attr.localName); + wrtChars('="', 2); + // TODO: not correct w.r.t. entities + ConvWrite(attr.nodeValue, AttrSpecialChars, {$IFDEF FPC}@{$ENDIF}AttrSpecialCharCallback); + wrtChr('"'); + end + else // action = aaUnchanged, output unmodified + VisitAttribute(attr); + end; +end; procedure TXMLWriter.VisitElement(node: TDOMNode); var @@ -371,10 +453,13 @@ var begin if not FInsideTextNode then wrtIndent; + FNSHelper.StartElement; wrtChr('<'); wrtStr(TDOMElement(node).TagName); - // FIX: Accessing Attributes was causing them to be created for every element :( - if node.HasAttributes then + + if nfLevel2 in node.Flags then + NamespaceFixup(TDOMElement(node)) + else if node.HasAttributes then for i := 0 to node.Attributes.Length - 1 do begin child := node.Attributes.Item[i]; @@ -402,6 +487,7 @@ begin wrtStr(TDOMElement(Node).TagName); wrtChr('>'); end; + FNSHelper.EndElement; end; procedure TXMLWriter.VisitText(node: TDOMNode); -- cgit v1.2.1 From dcb381287b689aefd8c2f2f64d5ffaf911cc7f21 Mon Sep 17 00:00:00 2001 From: jonas Date: Fri, 2 Oct 2009 12:55:52 +0000 Subject: * fixes for go32v2 compilation by John Lee (approved by Tomas) git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13791 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-process/src/dummy/process.inc | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'packages') diff --git a/packages/fcl-process/src/dummy/process.inc b/packages/fcl-process/src/dummy/process.inc index d3145d0ab0..73311f2ffa 100644 --- a/packages/fcl-process/src/dummy/process.inc +++ b/packages/fcl-process/src/dummy/process.inc @@ -2,10 +2,13 @@ Dummy process.inc } -{$if defined(VER2_2) or defined(VER2_3_1)} +{ + prevent compilation error for the versions mentioned below +} +{$if defined(VER2_4) or defined(VER2_5_1)} {$warning Temporary workaround - unit does nothing} {$else} -{$fatal Proper implementation of TProcess needed} +{$fatal Proper implementation of TProcess for version of this target needed} {$endif} procedure TProcess.CloseProcessHandles; -- cgit v1.2.1 From e61ae1a9b55b32b1c2ffe01f3328ec905994f8ee Mon Sep 17 00:00:00 2001 From: jonas Date: Fri, 2 Oct 2009 13:42:30 +0000 Subject: * made FPathInfo field of TServletRequest protected instead of private, because it's exposed by a property in a derived class git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13793 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-net/src/servlets.pp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'packages') diff --git a/packages/fcl-net/src/servlets.pp b/packages/fcl-net/src/servlets.pp index 85eaba8253..34dca4ba9a 100644 --- a/packages/fcl-net/src/servlets.pp +++ b/packages/fcl-net/src/servlets.pp @@ -35,8 +35,10 @@ type TServletRequest = class private FInputStream: TStream; - FScheme, FPathInfo: String; + FScheme: String; protected + FPathInfo: String; + function GetContentLength: Integer; virtual; abstract; function GetContentType: String; virtual; abstract; function GetProtocol: String; virtual; abstract; -- cgit v1.2.1 From fe171602b45cb033edd9222230eab932fb0e4fc2 Mon Sep 17 00:00:00 2001 From: sergei Date: Sat, 3 Oct 2009 23:35:20 +0000 Subject: Two more DOM Level 3 functions + tests for them: + TDOMNode.lookupPrefix() + TDOMNode.isDefaultNamespaceURI() git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@13800 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/fcl-xml/src/dom.pp | 136 +++++++++++++++++++++++++++++++---------- packages/fcl-xml/tests/api.xml | 9 ++- 2 files changed, 112 insertions(+), 33 deletions(-) (limited to 'packages') diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index ff1e9302cb..f241929cea 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/packages/fcl-xml/src/dom.pp @@ -255,7 +255,9 @@ type property Prefix: DOMString read GetPrefix write SetPrefix; // DOM level 3 property TextContent: DOMString read GetTextContent write SetTextContent; + function LookupPrefix(const nsURI: DOMString): DOMString; function LookupNamespaceURI(const APrefix: DOMString): DOMString; + function IsDefaultNamespace(const nsURI: DOMString): Boolean; // Extensions to DOM interface: function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual; function FindNode(const ANodeName: DOMString): TDOMNode; virtual; @@ -576,6 +578,7 @@ type function GetNodeType: Integer; override; function GetAttributes: TDOMNamedNodeMap; override; procedure AttachDefaultAttrs; + function InternalLookupPrefix(const nsURI: DOMString; Original: TDOMElement): DOMString; procedure RestoreDefaultAttr(AttrDef: TDOMAttr); public destructor Destroy; override; @@ -1141,10 +1144,17 @@ function GetAncestorElement(n: TDOMNode): TDOMElement; var parent: TDOMNode; begin - parent := n.ParentNode; - while Assigned(parent) and (parent.NodeType <> ELEMENT_NODE) do - parent := parent.ParentNode; - Result := TDOMElement(parent); + case n.nodeType of + DOCUMENT_NODE: + result := TDOMDocument(n).documentElement; + ATTRIBUTE_NODE: + result := TDOMAttr(n).OwnerElement; + else + parent := n.ParentNode; + while Assigned(parent) and (parent.NodeType <> ELEMENT_NODE) do + parent := parent.ParentNode; + Result := TDOMElement(parent); + end; end; // TODO: specs prescribe to return default namespace if APrefix=null, @@ -1159,40 +1169,74 @@ begin Result := ''; if Self = nil then Exit; - case NodeType of - ELEMENT_NODE: + if nodeType = ELEMENT_NODE then + begin + if (nfLevel2 in FFlags) and (TDOMElement(Self).Prefix = APrefix) then begin - if (nfLevel2 in FFlags) and (TDOMElement(Self).Prefix = APrefix) then - begin - result := Self.NamespaceURI; - Exit; - end; - if HasAttributes then + result := Self.NamespaceURI; + Exit; + end; + if HasAttributes then + begin + Map := Attributes; + for I := 0 to Map.Length-1 do begin - Map := Attributes; - for I := 0 to Map.Length-1 do + Attr := TDOMAttr(Map[I]); + // should ignore level 1 atts here + if ((Attr.Prefix = 'xmlns') and (Attr.localName = APrefix)) or + ((Attr.localName = 'xmlns') and (APrefix = '')) then begin - Attr := TDOMAttr(Map[I]); - // should ignore level 1 atts here - if ((Attr.Prefix = 'xmlns') and (Attr.localName = APrefix)) or - ((Attr.localName = 'xmlns') and (APrefix = '')) then - begin - result := Attr.NodeValue; - Exit; - end; - end - end; - result := GetAncestorElement(Self).LookupNamespaceURI(APrefix); + result := Attr.NodeValue; + Exit; + end; + end end; - DOCUMENT_NODE: - result := TDOMDocument(Self).documentElement.LookupNamespaceURI(APrefix); - - ATTRIBUTE_NODE: - result := TDOMAttr(Self).OwnerElement.LookupNamespaceURI(APrefix); + end; + result := GetAncestorElement(Self).LookupNamespaceURI(APrefix); +end; +function TDOMNode.LookupPrefix(const nsURI: DOMString): DOMString; +begin + Result := ''; + if (nsURI = '') or (Self = nil) then + Exit; + if nodeType = ELEMENT_NODE then + result := TDOMElement(Self).InternalLookupPrefix(nsURI, TDOMElement(Self)) else - Result := GetAncestorElement(Self).LookupNamespaceURI(APrefix); + result := GetAncestorElement(Self).LookupPrefix(nsURI); +end; + +function TDOMNode.IsDefaultNamespace(const nsURI: DOMString): Boolean; +var + Attr: TDOMAttr; + Map: TDOMNamedNodeMap; + I: Integer; +begin + Result := False; + if Self = nil then + Exit; + if nodeType = ELEMENT_NODE then + begin + if TDOMElement(Self).FNSI.PrefixLen = 0 then + begin + result := (nsURI = namespaceURI); + Exit; + end + else if HasAttributes then + begin + Map := Attributes; + for I := 0 to Map.Length-1 do + begin + Attr := TDOMAttr(Map[I]); + if Attr.LocalName = 'xmlns' then + begin + result := (Attr.Value = nsURI); + Exit; + end; + end; + end; end; + result := GetAncestorElement(Self).IsDefaultNamespace(nsURI); end; //------------------------------------------------------------------------------ @@ -2678,6 +2722,36 @@ begin end; end; +function TDOMElement.InternalLookupPrefix(const nsURI: DOMString; Original: TDOMElement): DOMString; +var + I: Integer; + Attr: TDOMAttr; +begin + result := ''; + if Self = nil then + Exit; + if (nfLevel2 in FFlags) and (namespaceURI = nsURI) and (FNSI.PrefixLen > 0) then + begin + Result := Prefix; + if Original.LookupNamespaceURI(result) = nsURI then + Exit; + end; + if Assigned(FAttributes) then + begin + for I := 0 to FAttributes.Length-1 do + begin + Attr := TDOMAttr(FAttributes[I]); + if (Attr.Prefix = 'xmlns') and (Attr.Value = nsURI) then + begin + result := Attr.LocalName; + if Original.LookupNamespaceURI(result) = nsURI then + Exit; + end; + end; + end; + result := GetAncestorElement(Self).InternalLookupPrefix(nsURI, Original); +end; + procedure TDOMElement.RestoreDefaultAttr(AttrDef: TDOMAttr); var Attr: TDOMAttr; diff --git a/packages/fcl-xml/tests/api.xml b/packages/fcl-xml/tests/api.xml index 770c1e2fae..bf844c8756 100644 --- a/packages/fcl-xml/tests/api.xml +++ b/packages/fcl-xml/tests/api.xml @@ -262,6 +262,7 @@