paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 17:19:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Sergei Gorelkin

Browse Source 
xmlutils.pp:
  + Added THashTable - a simple hashed container with WideString keys.

  dom.pp:
  * Use the hash table instead of a sorted list for storing document IDs.
  * Replaced all TLists by TFPList (which is smaller and faster).
  * Fixed TDOMElement.RemoveAttributeNode to throw NOT_FOUND_ERR when
    the requested node is not one of the element's attributes.
  + Added node read-only checks where required by the specs, this fixes
    about 50 DOM tests.

  xmlread.pp:

  * Got rid of TXMLCharSource.FReloadHook, the corresponding procedure may
    be called directly.
  * Used a separate buffer to store the entity value literals, this
    enables correct including of external PEs that have a text declaration
    at the beginning.
  * Some refactoring: ParseAttribute has been split into a separate
    procedure, ProcessTextAndRefs was merged into ParseContent.

git-svn-id: trunk@11942 -
This commit is contained in:
michael 2008-10-22 12:25:12 +00:00
parent 8fe91950e9
commit e632e754cf
3 changed files with 429 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
packages/fcl-xml/src/dom.pp
View File

@ -38,7 +38,7 @@ unit DOM;
interface
uses
SysUtils, Classes, AVL_Tree;
SysUtils, Classes, AVL_Tree, xmlutils;
// -------------------------------------------------------
// DOMException
@ -221,6 +221,8 @@ type
function GetPrefix: DOMString; virtual;
procedure SetPrefix(const Value: DOMString); virtual;
function GetOwnerDocument: TDOMDocument; virtual;
procedure SetReadOnly(Value: Boolean);
procedure Changing;
public
constructor Create(AOwner: TDOMDocument);
destructor Destroy; override;
@ -299,7 +301,7 @@ type
protected
FNode: TDOMNode;
FRevision: Integer;
FList: TList;
FList: TFPList;
function GetCount: LongWord;
function GetItem(index: LongWord): TDOMNode;
procedure BuildList; virtual;
@ -333,7 +335,7 @@ type
protected
FOwner: TDOMNode;
FNodeType: Integer;
FList: TList;
FList: TFPList;
function GetItem(index: LongWord): TDOMNode;
function GetLength: LongWord;
function Find(const name: DOMString; out Index: LongWord): Boolean;
@ -415,7 +417,7 @@ type
TDOMDocument = class(TDOMNode_WithChildren)
protected
FIDList: TList;
FIDList: THashTable;
FRevision: Integer;
FXML11: Boolean;
FImplementation: TDOMImplementation;
@ -427,8 +429,6 @@ type
function GetOwnerDocument: TDOMDocument; override;
procedure SetTextContent(const value: DOMString); override;
function IndexOfNS(const nsURI: DOMString): Integer;
function FindID(const aID: DOMString; out Index: LongWord): Boolean;
procedure ClearIDList;
procedure RemoveID(Elem: TDOMElement);
public
property DocType: TDOMDocumentType read GetDocType;
@ -713,16 +713,6 @@ type
implementation
uses
xmlutils;
type
PIDItem = ^TIDItem;
TIDItem = record
ID: WideString;
Element: TDOMElement;
end;
constructor TRefClass.Create;
begin
inherited Create;
@ -858,12 +848,14 @@ end;
function TDOMNode.InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode;
begin
Changing; // merely to comply with core3/nodeinsertbefore14
raise EDOMHierarchyRequest.Create('Node.InsertBefore');
Result:=nil;
end;
function TDOMNode.ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode;
begin
Changing; // merely to comply with core3/nodereplacechild21
raise EDOMHierarchyRequest.Create('Node.ReplaceChild');
Result:=nil;
end;
@ -1000,6 +992,36 @@ begin
Result := FOwnerDocument;
end;
procedure TDOMNode.SetReadOnly(Value: Boolean);
var
child: TDOMNode;
attrs: TDOMNamedNodeMap;
I: Integer;
begin
if Value then
Include(FFlags, nfReadOnly)
else
Exclude(FFlags, nfReadOnly);
child := FirstChild;
while Assigned(child) do
begin
child.SetReadOnly(Value);
child := child.NextSibling;
end;
attrs := Attributes;
if Assigned(attrs) then
begin
for I := 0 to attrs.Length-1 do
attrs[I].SetReadOnly(Value);
end;
end;
procedure TDOMNode.Changing;
begin
if nfReadOnly in FFlags then
raise EDOMError.Create(NO_MODIFICATION_ALLOWED_ERR, 'Node.CheckReadOnly');
end;
function CompareDOMStrings(const s1, s2: DOMPChar; l1, l2: integer): integer;
var i: integer;
begin
@ -1082,6 +1104,7 @@ begin
Result := NewChild;
NewChildType := NewChild.NodeType;
Changing;
if NewChild.FOwnerDocument <> FOwnerDocument then
begin
if (NewChildType <> DOCUMENT_TYPE_NODE) or
@ -1171,6 +1194,8 @@ end;
function TDOMNode_WithChildren.DetachChild(OldChild: TDOMNode): TDOMNode;
begin
Changing;
if OldChild.ParentNode <> Self then
raise EDOMNotFound.Create('NodeWC.RemoveChild');
@ -1266,6 +1291,7 @@ end;
procedure TDOMNode_WithChildren.SetTextContent(const AValue: DOMString);
begin
Changing;
FreeChildren;
if AValue <> '' then
AppendChild(FOwnerDocument.CreateTextNode(AValue));
@ -1295,7 +1321,7 @@ begin
inherited Create;
FNode := ANode;
FRevision := ANode.GetRevision-1; // force BuildList at first access
FList := TList.Create;
FList := TFPList.Create;
end;
destructor TDOMNodeList.Destroy;
@ -1395,7 +1421,7 @@ begin
inherited Create;
FOwner := AOwner;
FNodeType := ANodeType;
FList := TList.Create;
FList := TFPList.Create;
end;
destructor TDOMNamedNodeMap.Destroy;
@ -1467,7 +1493,9 @@ var
AttrOwner: TDOMNode;
begin
Result := 0;
if arg.FOwnerDocument <> FOwner.FOwnerDocument then
if nfReadOnly in FOwner.FFlags then
Result := NO_MODIFICATION_ALLOWED_ERR
else if arg.FOwnerDocument <> FOwner.FOwnerDocument then
Result := WRONG_DOCUMENT_ERR
else if arg.NodeType <> FNodeType then
Result := HIERARCHY_REQUEST_ERR
@ -1537,6 +1565,8 @@ end;
function TDOMNamedNodeMap.RemoveNamedItem(const name: DOMString): TDOMNode;
begin
if nfReadOnly in FOwner.FFlags then
raise EDOMError.Create(NO_MODIFICATION_ALLOWED_ERR, 'NamedNodeMap.RemoveNamedItem');
Result := InternalRemove(name);
if Result = nil then
raise EDOMNotFound.Create('NamedNodeMap.RemoveNamedItem');
@ -1544,6 +1574,8 @@ end;
function TDOMNamedNodeMap.RemoveNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode;
begin
if nfReadOnly in FOwner.FFlags then
raise EDOMError.Create(NO_MODIFICATION_ALLOWED_ERR, 'NamedNodeMap.RemoveNamedItemNS');
// TODO: Implement TDOMNamedNodeMap.RemoveNamedItemNS
Result := nil;
end;
@ -1565,6 +1597,7 @@ end;
procedure TDOMCharacterData.SetNodeValue(const AValue: DOMString);
begin
Changing;
FNodeValue := AValue;
end;
@ -1577,11 +1610,13 @@ end;
procedure TDOMCharacterData.AppendData(const arg: DOMString);
begin
Changing;
FNodeValue := FNodeValue + arg;
end;
procedure TDOMCharacterData.InsertData(offset: LongWord; const arg: DOMString);
begin
Changing;
if offset > Length then
raise EDOMIndexSize.Create('CharacterData.InsertData');
Insert(arg, FNodeValue, offset+1);
@ -1589,6 +1624,7 @@ end;
procedure TDOMCharacterData.DeleteData(offset, count: LongWord);
begin
Changing;
if offset > Length then
raise EDOMIndexSize.Create('CharacterData.DeleteData');
Delete(FNodeValue, offset+1, count);
@ -1685,86 +1721,61 @@ end;
destructor TDOMDocument.Destroy;
begin
ClearIDList;
FreeAndNil(FIDList); // set to nil before starting destroying chidlren
inherited Destroy;
end;
function TDOMDocument.AddID(Attr: TDOMAttr): Boolean;
var
I: Cardinal;
Item: PIDItem;
ID: DOMString;
Exists: Boolean;
p: PHashItem;
begin
if FIDList = nil then
FIDList := TList.Create;
New(Item);
Item^.ID := Attr.Value;
Item^.Element := Attr.OwnerElement;
if not FindID(Item^.ID, I) then
FIDList := THashTable.Create(256, False);
ID := Attr.Value;
p := FIDList.FindOrAdd(DOMPChar(ID), Length(ID), Exists);
if not Exists then
begin
FIDList.Insert(I, Item);
p^.Data := Attr.OwnerElement;
Result := True;
end
else
begin
Dispose(Item);
Result := False;
end;
end;
// This shouldn't be called if document has no IDs,
// or when it is being destroyed
// TODO: This could be much faster if removing ID happens
// upon modification of corresponding attribute value.
type
TempRec = record
Element: TDOMElement;
Entry: PHashItem;
end;
function CheckID(Entry: PHashItem; arg: Pointer): Boolean;
begin
if Entry^.Data = TempRec(arg^).Element then
begin
TempRec(arg^).Entry := Entry;
Result := False;
end
else
Result := True;
end;
procedure TDOMDocument.RemoveID(Elem: TDOMElement);
var
I: Integer;
hr: TempRec;
begin
for I := 0 to FIDList.Count-1 do
begin
if PIDItem(FIDList.List^[I])^.Element = Elem then
begin
Dispose(PIDItem(FIDList.List^[I]));
FIDList.Delete(I);
Exit;
end;
end;
end;
function TDOMDocument.FindID(const aID: DOMString; out Index: LongWord): Boolean;
var
L, H, I, C: Integer;
P: PIDItem;
begin
Result := False;
L := 0;
H := FIDList.Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
P := PIDItem(FIDList.List^[I]);
C := CompareDOMStrings(PWideChar(aID), PWideChar(P^.ID), Length(aID), Length(P^.ID));
if C > 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result := True;
L := I;
end;
end;
end;
Index := L;
end;
procedure TDOMDocument.ClearIDList;
var
I: Integer;
begin
if Assigned(FIDList) then
begin
for I := 0 to FIDList.Count-1 do
Dispose(PIDItem(FIDList.List^[I]));
FIDList.Clear;
end;
hr.Element := Elem;
hr.Entry := nil;
FIDList.ForEach(@CheckID, @hr);
if Assigned(hr.Entry) then
FIDList.Remove(hr.Entry);
end;
function TDOMDocument.GetNodeType: Integer;
@ -1924,13 +1935,10 @@ begin
end;
function TDOMDocument.GetElementById(const ElementID: DOMString): TDOMElement;
var
I: Cardinal;
begin
if Assigned(FIDList) and FindID(ElementID, I) then
Result := PIDItem(FIDList.List^[I])^.Element
else
Result := nil;
if Assigned(FIDList) then
Result := TDOMElement(FIDList.Get(DOMPChar(ElementID), Length(ElementID)));
end;
function TDOMDocument.ImportNode(ImportedNode: TDOMNode;
@ -1980,6 +1988,7 @@ begin
if Assigned(ent) then
ent.CloneChildren(Result, Self);
end;
Result.SetReadOnly(True);
end;
procedure TXMLDocument.SetXMLVersion(const aValue: DOMString);
@ -2119,6 +2128,7 @@ var
I: Cardinal;
attr: TDOMAttr;
begin
Changing;
if Attributes.Find(name, I) then
Attr := FAttributes[I] as TDOMAttr
else
@ -2132,6 +2142,7 @@ end;
procedure TDOMElement.RemoveAttribute(const name: DOMString);
begin
Changing;
// (note) NamedNodeMap.RemoveNamedItem can raise NOT_FOUND_ERR and we should not.
if Assigned(FAttributes) then
FAttributes.InternalRemove(name).Free;
@ -2140,6 +2151,7 @@ end;
procedure TDOMElement.RemoveAttributeNS(const nsURI,
aLocalName: DOMString);
begin
Changing;
// TODO: Implement TDOMElement.RemoveAttributeNS
raise EDOMNotSupported.Create('TDOMElement.RemoveAttributeNS');
end;
@ -2202,14 +2214,18 @@ end;
function TDOMElement.RemoveAttributeNode(OldAttr: TDOMAttr): TDOMAttr;
begin
Changing;
Result:=nil;
if FAttributes=nil then exit;
// TODO: DOM 2: must raise NOT_FOUND_ERR if OldAttr is not ours.
// -- but what is the purpose of return value then?
// TODO: delegate to TNamedNodeMap? Nope, it does not have such method
// (note) one way around is to remove by name
if FAttributes.FList.Remove(OldAttr) > -1 then
if Assigned(FAttributes) and (FAttributes.FList.Remove(OldAttr) > -1) then
begin
Result := OldAttr;
end
else
raise EDOMNotFound.Create('Element.RemoveAttributeNode');
end;
function TDOMElement.GetElementsByTagName(const name: DOMString): TDOMNodeList;
@ -2418,6 +2434,7 @@ begin
TDOMEntity(Result).FNotationName := FNotationName;
if deep then
CloneChildren(Result, aCloneOwner);
Result.SetReadOnly(True);
end;
// -------------------------------------------------------
@ -2466,6 +2483,7 @@ end;
procedure TDOMProcessingInstruction.SetNodeValue(const AValue: DOMString);
begin
Changing;
FNodeValue := AValue;
end;

201
packages/fcl-xml/src/xmlread.pp
View File

@ -171,7 +171,6 @@ type
FXML11Rules: Boolean;
FSystemID: WideString;
FPublicID: WideString;
FReloadHook: procedure of object;
function GetSystemID: WideString;
function GetPublicID: WideString;
protected
@ -306,6 +305,7 @@ type
FInsideDecl: Boolean;
FDocNotValid: Boolean;
FValue: TWideCharBuf;
FEntityValue: TWideCharBuf;
FName: TWideCharBuf;
FTokenStart: TLocation;
FStandalone: Boolean; // property of Doc ?
@ -379,14 +379,14 @@ type
procedure ParseDoctypeDecl; // [28]
procedure ParseMarkupDecl; // [29]
procedure ParseElement; // [39]
procedure ParseAttribute(Elem: TDOMElement; ElDef: TDOMElementDef);
procedure ParseContent; // [43]
function ResolvePredefined: Boolean;
procedure IncludeEntity(InAttr: Boolean);
procedure StartPE;
function ParseCharRef: Boolean; // [66]
function ParseCharRef(var ToFill: TWideCharBuf): Boolean; // [66]
function ParseExternalID(out SysID, PubID: WideString; // [75]
SysIdOptional: Boolean): Boolean;
procedure ProcessTextAndRefs;
procedure BadPENesting(S: TErrorSeverity = esError);
procedure ParseEntityDecl;
@ -806,8 +806,8 @@ var
c: WideChar;
r: Integer;
begin
if Assigned(FReloadHook) then
FReloadHook;
if DTDSubsetType = dsInternal then
FReader.DTDReloadHook;
r := FBufEnd - FBuf;
if r > 0 then
Move(FBuf^, FBufStart^, r * sizeof(WideChar));
@ -1260,6 +1260,8 @@ end;
destructor TXMLReader.Destroy;
begin
if Assigned(FEntityValue.Buffer) then
FreeMem(FEntityValue.Buffer);
FreeMem(FName.Buffer);
FreeMem(FValue.Buffer);
if Assigned(FSource) then
@ -1425,7 +1427,7 @@ begin
Result := True;
end;
function TXMLReader.ParseCharRef: Boolean; // [66]
function TXMLReader.ParseCharRef(var ToFill: TWideCharBuf): Boolean; // [66]
var
Value: Integer;
begin
@ -1460,15 +1462,15 @@ begin
case Value of
$01..$08, $0B..$0C, $0E..$1F:
if FXML11 then
BufAppend(FValue, WideChar(Value))
BufAppend(ToFill, WideChar(Value))
else
FatalError('Invalid character reference');
$09, $0A, $0D, $20..$D7FF, $E000..$FFFD:
BufAppend(FValue, WideChar(Value));
BufAppend(ToFill, WideChar(Value));
$10000..$10FFFF:
begin
BufAppend(FValue, WideChar($D7C0 + (Value shr 10)));
BufAppend(FValue, WideChar($DC00 xor (Value and $3FF)));
BufAppend(ToFill, WideChar($D7C0 + (Value shr 10)));
BufAppend(ToFill, WideChar($DC00 xor (Value and $3FF)));
end;
else
FatalError('Invalid character reference');
@ -1495,7 +1497,7 @@ begin
end
else
begin
if ParseCharRef or ResolvePredefined then
if ParseCharRef(FValue) or ResolvePredefined then
Continue;
// have to insert entity or reference
if FValue.Length > 0 then
@ -1622,12 +1624,14 @@ begin
SaveCursor := FCursor;
FCursor := AEntity; // build child node tree for the entity
try
AEntity.SetReadOnly(False);
if InAttr then
DoParseAttValue(#0)
else
DoParseFragment;
AEntity.FResolved := True;
finally
AEntity.SetReadOnly(True);
ContextPop;
FCursor := SaveCursor;
FValue.Length := 0;
@ -1672,60 +1676,6 @@ begin
FHavePERefs := True;
end;
procedure TXMLReader.ProcessTextAndRefs;
var
nonWs: Boolean;
begin
FValue.Length := 0;
nonWs := False;
StoreLocation(FTokenStart);
while (FCurChar <> '<') and (FCurChar <> #0) do
begin
if FCurChar <> '&' then
begin
if (FCurChar <> #32) and (FCurChar <> #10) and (FCurChar <> #9) and (FCurChar <> #13) then
nonWs := True;
BufAppend(FValue, FCurChar);
if FCurChar = '>' then
with FValue do
if (Length >= 3) and (Buffer[Length-2] = ']') and (Buffer[Length-3] = ']') then
FatalError('Literal '']]>'' is not allowed in text', 2);
GetChar;
end
else
begin
if FState <> rsRoot then
FatalError('Illegal at document level');
if FCurrContentType = ctEmpty then
ValidationError('References are illegal in EMPTY elements', []);
if ParseCharRef or ResolvePredefined then
nonWs := True // CharRef to whitespace is not considered whitespace
else
begin
if (nonWs or FPreserveWhitespace) and (FValue.Length > 0) then
begin
// 'Reference illegal at root' is checked above, no need to check here
DoText(FValue.Buffer, FValue.Length, not nonWs);
FValue.Length := 0;
end;
IncludeEntity(False);
end;
end;
end; // while
if FState = rsRoot then
begin
if (nonWs or FPreserveWhitespace) and (FValue.Length > 0) then
begin
DoText(FValue.Buffer, FValue.Length, not nonWs);
FValue.Length := 0;
end;
end
else if nonWs then
FatalError('Illegal at document level', -1);
end;
procedure TXMLReader.ExpectAttValue; // [10]
var
Delim: WideChar;
@ -1955,14 +1905,12 @@ begin
begin
BufAllocate(FIntSubset, 256);
FSource.DTDSubsetType := dsInternal;
FSource.FReloadHook := {$IFDEF FPC}@{$ENDIF}DTDReloadHook;
try
FDTDStartPos := FSource.FBuf;
ParseMarkupDecl;
DTDReloadHook; // fetch last chunk
SetString(FDocType.FInternalSubset, FIntSubset.Buffer, FIntSubset.Length);
finally
FSource.FReloadHook := nil;
FreeMem(FIntSubset.Buffer);
FSource.DTDSubsetType := dsNone;
end;
@ -1989,6 +1937,7 @@ begin
end;
FCursor := Doc;
ValidateDTD;
FDocType.SetReadOnly(True);
end;
procedure TXMLReader.ExpectEq; // [25]
@ -2324,7 +2273,9 @@ var
CurrentEntity: TObject;
begin
CurrentEntity := FSource.FEntity;
FValue.Length := 0;
if FEntityValue.Buffer = nil then
BufAllocate(FEntityValue, 256);
FEntityValue.Length := 0;
// "Included in literal": process until delimiter hit IN SAME context
while not ((FSource.FEntity = CurrentEntity) and CheckForChar(Delim)) do
if CheckForChar('%') then
@ -2337,16 +2288,16 @@ begin
end
else if FCurChar = '&' then // CharRefs: include, EntityRefs: bypass
begin
if not ParseCharRef then
if not ParseCharRef(FEntityValue) then
begin
BufAppend(FValue, '&');
BufAppendChunk(FValue, FName.Buffer, FName.Length);
BufAppend(FValue, ';');
BufAppend(FEntityValue, '&');
BufAppendChunk(FEntityValue, FName.Buffer, FName.Length);
BufAppend(FEntityValue, ';');
end;
end
else if FCurChar <> #0 then // Regular character
begin
BufAppend(FValue, FCurChar);
BufAppend(FEntityValue, FCurChar);
GetChar;
end
else if (FSource.FEntity = CurrentEntity) or not ContextPop then // #0
@ -2378,6 +2329,7 @@ begin
end;
Entity := TDOMEntityEx.Create(Doc);
Entity.SetReadOnly(True);
try
Entity.FExternallyDeclared := FSource.DTDSubsetType <> dsInternal;
Entity.FName := ExpectName;
@ -2392,7 +2344,7 @@ begin
StoreLocation(Entity.FStartLocation);
if not ParseEntityDeclValue(Delim) then
DoErrorPos(esFatal, 'Literal has no closing quote', Entity.FStartLocation);
SetString(Entity.FReplacementText, FValue.Buffer, FValue.Length);
SetString(Entity.FReplacementText, FEntityValue.Buffer, FEntityValue.Length);
end
else
if not ParseExternalID(Entity.FSystemID, Entity.FPublicID, False) then
@ -2575,6 +2527,8 @@ begin
end;
procedure TXMLReader.ParseContent;
var
nonWs: Boolean;
begin
repeat
if FCurChar = '<' then
@ -2600,7 +2554,56 @@ begin
RaiseNameNotFound;
end
else
ProcessTextAndRefs;
begin
FValue.Length := 0;
nonWs := False;
StoreLocation(FTokenStart);
while (FCurChar <> '<') and (FCurChar <> #0) do
begin
if FCurChar <> '&' then
begin
if (FCurChar <> #32) and (FCurChar <> #10) and (FCurChar <> #9) and (FCurChar <> #13) then
nonWs := True;
BufAppend(FValue, FCurChar);
if FCurChar = '>' then
with FValue do
if (Length >= 3) and (Buffer[Length-2] = ']') and (Buffer[Length-3] = ']') then
FatalError('Literal '']]>'' is not allowed in text', 2);
GetChar;
end
else
begin
if FState <> rsRoot then
FatalError('Illegal at document level');
if FCurrContentType = ctEmpty then
ValidationError('References are illegal in EMPTY elements', []);
if ParseCharRef(FValue) or ResolvePredefined then
nonWs := True // CharRef to whitespace is not considered whitespace
else
begin
if (nonWs or FPreserveWhitespace) and (FValue.Length > 0) then
begin
// 'Reference illegal at root' is checked above, no need to check here
DoText(FValue.Buffer, FValue.Length, not nonWs);
FValue.Length := 0;
end;
IncludeEntity(False);
end;
end;
end; // while
if FState = rsRoot then
begin
if (nonWs or FPreserveWhitespace) and (FValue.Length > 0) then
begin
DoText(FValue.Buffer, FValue.Length, not nonWs);
FValue.Length := 0;
end;
end
else if nonWs then
FatalError('Illegal at document level', -1);
end;
until FCurChar = #0;
end;
@ -2610,8 +2613,6 @@ var
NewElem: TDOMElement;
ElDef: TDOMElementDef;
IsEmpty: Boolean;
attr: TDOMAttr;
OldAttr: TDOMNode;
begin
if FState > rsRoot then
FatalError('Only one top-level element allowed', FName.Length)
@ -2639,28 +2640,15 @@ begin
ValidationError('Element ''%s'' is not allowed in this context',[NewElem.TagName], FName.Length);
IsEmpty := False;
if SkipS then
while (FSource.FBuf^ <> '>') and (FSource.FBuf^ <> '/') do
begin
while (FCurChar <> '>') and (FCurChar <> '/') do
begin
CheckName;
attr := doc.CreateAttributeBuf(FName.Buffer, FName.Length);
// !!cannot use TDOMElement.SetAttributeNode because it will free old attribute
OldAttr := NewElem.Attributes.SetNamedItem(Attr);
if Assigned(OldAttr) then
begin
OldAttr.Free;
FatalError('Duplicate attribute', FName.Length);
end;
ExpectEq;
FCursor := attr;
ExpectAttValue;
if (FCurChar <> '>') and (FCurChar <> '/') then
SkipS(True);
end; // while
SkipS(True);
if (FSource.FBuf^ = '>') or (FSource.FBuf^ = '/') then
Break;
ParseAttribute(NewElem, ElDef);
end;
if FCurChar = '/' then
if FSource.FBuf^ = '/' then
begin
IsEmpty := True;
GetChar;
@ -2706,6 +2694,25 @@ begin
PopVC;
end;
procedure TXMLReader.ParseAttribute(Elem: TDOMElement; ElDef: TDOMElementDef);
var
attr: TDOMAttr;
OldAttr: TDOMNode;
begin
CheckName;
attr := doc.CreateAttributeBuf(FName.Buffer, FName.Length);
// !!cannot use TDOMElement.SetAttributeNode because it will free old attribute
OldAttr := Elem.Attributes.SetNamedItem(Attr);
if Assigned(OldAttr) then
begin
OldAttr.Free;
FatalError('Duplicate attribute', FName.Length);
end;
ExpectEq;
FCursor := attr;
ExpectAttValue;
end;
procedure TXMLReader.AddForwardRef(aList: TFPList; Buf: PWideChar; Length: Integer);
var
w: PForwardRef;

221
packages/fcl-xml/src/xmlutils.pp
View File

@ -30,6 +30,42 @@ function IsXmlNmTokens(const Value: WideString; Xml11: Boolean = False): Boolean
function IsValidXmlEncoding(const Value: WideString): Boolean;
function Xml11NamePages: PByteArray;
procedure NormalizeSpaces(var Value: WideString);
function Hash(InitValue: LongWord; Key: PWideChar; KeyLen: Integer): LongWord;
{ a simple hash table with WideString keys }
type
PPHashItem = ^PHashItem;
PHashItem = ^THashItem;
THashItem = record
Key: WideString;
HashValue: LongWord;
Next: PHashItem;
Data: TObject;
end;
THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean;
THashTable = class(TObject)
private
FCount: LongWord;
FBucketCount: LongWord;
FBucket: PPHashItem;
FOwnsObjects: Boolean;
function Lookup(Key: PWideChar; KeyLength: Integer; var Found: Boolean; CanCreate: Boolean): PHashItem;
procedure Resize(NewCapacity: LongWord);
public
constructor Create(InitSize: Integer; OwnObjects: Boolean);
destructor Destroy; override;
procedure Clear;
function Find(Key: PWideChar; KeyLen: Integer): PHashItem;
function FindOrAdd(Key: PWideChar; KeyLen: Integer; var Found: Boolean): PHashItem; overload;
function FindOrAdd(Key: PWideChar; KeyLen: Integer): PHashItem; overload;
function Get(Key: PWideChar; KeyLen: Integer): TObject;
function Remove(Entry: PHashItem): Boolean;
procedure ForEach(proc: THashForEach; arg: Pointer);
property Count: LongWord read FCount;
end;
{$i names.inc}
@ -239,6 +275,191 @@ begin
end;
end;
function Hash(InitValue: LongWord; Key: PWideChar; KeyLen: Integer): LongWord;
begin
Result := InitValue;
while KeyLen <> 0 do
begin
Result := Result * $F4243 xor ord(Key^);
Inc(Key);
Dec(KeyLen);
end;
end;
function KeyCompare(const Key1: WideString; Key2: Pointer; Key2Len: Integer): Boolean;
begin
Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0);
end;
{ THashTable }
constructor THashTable.Create(InitSize: Integer; OwnObjects: Boolean);
var
I: Integer;
begin
inherited Create;
FOwnsObjects := OwnObjects;
I := 256;
while I < InitSize do I := I shl 1;
FBucketCount := I;
FBucket := AllocMem(I * sizeof(PHashItem));
end;
destructor THashTable.Destroy;
begin
Clear;
FreeMem(FBucket);
inherited Destroy;
end;
procedure THashTable.Clear;
var
I: Integer;
item, next: PHashItem;
begin
for I := 0 to FBucketCount-1 do
begin
item := FBucket[I];
while Assigned(item) do
begin
next := item^.Next;
if FOwnsObjects then
item^.Data.Free;
Dispose(item);
item := next;
end;
end;
FillChar(FBucket^, FBucketCount * sizeof(PHashItem), 0);
end;
function THashTable.Find(Key: PWideChar; KeyLen: Integer): PHashItem;
var
Dummy: Boolean;
begin
Result := Lookup(Key, KeyLen, Dummy, False);
end;
function THashTable.FindOrAdd(Key: PWideChar; KeyLen: Integer;
var Found: Boolean): PHashItem;
begin
Result := Lookup(Key, KeyLen, Found, True);
end;
function THashTable.FindOrAdd(Key: PWideChar; KeyLen: Integer): PHashItem;
var
Dummy: Boolean;
begin
Result := Lookup(Key, KeyLen, Dummy, True);
end;
function THashTable.Get(Key: PWideChar; KeyLen: Integer): TObject;
var
e: PHashItem;
Dummy: Boolean;
begin
e := Lookup(Key, KeyLen, Dummy, False);
if Assigned(e) then
Result := e^.Data
else
Result := nil;
end;
function THashTable.Lookup(Key: PWideChar; KeyLength: Integer;
var Found: Boolean; CanCreate: Boolean): PHashItem;
var
Entry: PPHashItem;
h: LongWord;
begin
h := Hash(0, Key, KeyLength);
Entry := @FBucket[h mod FBucketCount];
while Assigned(Entry^) and not ((Entry^^.HashValue = h) and KeyCompare(Entry^^.Key, Key, KeyLength) ) do
Entry := @Entry^^.Next;
Found := Assigned(Entry^);
if Found or (not CanCreate) then
begin
Result := Entry^;
Exit;
end;
if FCount > FBucketCount then { arbitrary limit, probably too high }
begin
Resize(FBucketCount * 2);
Result := Lookup(Key, KeyLength, Found, CanCreate);
end
else
begin
New(Result);
SetString(Result^.Key, Key, KeyLength);
Result^.HashValue := h;
Result^.Data := nil;
Result^.Next := nil;
Inc(FCount);
Entry^ := Result;
end;
end;
procedure THashTable.Resize(NewCapacity: LongWord);
var
p, chain: PPHashItem;
i: Integer;
e, n: PHashItem;
begin
p := AllocMem(NewCapacity * sizeof(PHashItem));
for i := 0 to FBucketCount-1 do
begin
e := FBucket[i];
while Assigned(e) do
begin
chain := @p[e^.HashValue mod NewCapacity];
n := e^.Next;
e^.Next := chain^;
chain^ := e;
e := n;
end;
end;
FBucketCount := NewCapacity;
FreeMem(FBucket);
FBucket := p;
end;
function THashTable.Remove(Entry: PHashItem): Boolean;
var
chain: PPHashItem;
begin
chain := @FBucket[Entry^.HashValue mod FBucketCount];
while Assigned(chain^) do
begin
if chain^ = Entry then
begin
chain^ := Entry^.Next;
if FOwnsObjects then
Entry^.Data.Free;
Dispose(Entry);
Dec(FCount);
Result := True;
Exit;
end;
chain := @chain^^.Next;
end;
Result := False;
end;
procedure THashTable.ForEach(proc: THashForEach; arg: Pointer);
var
i: Integer;
e: PHashItem;
begin
for i := 0 to FBucketCount-1 do
begin
e := FBucket[i];
while Assigned(e) do
begin
if not proc(e, arg) then
Exit;
e := e^.Next;
end;
end;
end;
initialization
finalization