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

* fcl-xml, improved TNSSupport class to work directly with hashed strings, reduces amount of hash lookups.

Browse Source 
git-svn-id: trunk@20538 -
This commit is contained in:
sergei 2012-03-18 19:56:07 +00:00
parent 0cbdc1ae6e
commit 60fe15b01a
3 changed files with 68 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1409,7 +1409,7 @@ begin
FCurrAttrIndex := -1;
if FNamespaces then
begin
FNSHelper := TNSSupport.Create;
FNSHelper := TNSSupport.Create(FNameTable);
FNsAttHash := TDblHashArray.Create;
FStdPrefix_xml := FNSHelper.GetPrefix(@PrefixDefault, 3);
FStdPrefix_xmlns := FNSHelper.GetPrefix(@PrefixDefault, 5);
@ -2946,18 +2946,11 @@ begin
end;
function TXMLTextReader.LookupNamespace(const APrefix: XMLString): XMLString;
var
prefixatom: PHashItem;
b: TBinding;
begin
result := '';
if FNamespaces then
begin
prefixatom := FNSHelper.GetPrefix(PWideChar(APrefix),Length(APrefix));
b := TBinding(prefixatom^.Data);
if Assigned(b) then
result := b.Uri;
end;
if Assigned(FNSHelper) then
result := FNSHelper.LookupNamespace(APrefix)
else
result := '';
end;
function TXMLTextReader.MoveToFirstAttribute: Boolean;
@ -3739,7 +3732,7 @@ begin
if FNamespaces then
begin
FNSHelper.StartElement;
FNSHelper.PushScope;
if FColonPos > 0 then
FCurrNode^.FPrefix := FNSHelper.GetPrefix(FName.Buffer, FColonPos);
end;
@ -3774,15 +3767,15 @@ begin
if Assigned(FCurrNode^.FPrefix) then
begin
b := TBinding(FCurrNode^.FPrefix^.Data);
if not (Assigned(b) and (b.uri <> '')) then
if not (Assigned(b) and Assigned(b.uri) and (b.uri^.Key <> '')) then
DoErrorPos(esFatal, 'Unbound element name prefix "%s"', [FCurrNode^.FPrefix^.Key],FCurrNode^.FLoc);
FCurrNode^.FNsUri := FNameTable.FindOrAdd(b.uri);
FCurrNode^.FNsUri := b.uri;
end
else
begin
b := FNSHelper.DefaultNSBinding;
if Assigned(b) then
FCurrNode^.FNsUri := FNameTable.FindOrAdd(b.uri);
FCurrNode^.FNsUri := b.uri;
end;
end;
@ -3990,9 +3983,9 @@ begin
if (attrData^.FValueStr = '') and not (FXML11 or (Pfx^.Key = '')) then
DoErrorPos(esFatal, 'Illegal undefining of namespace', attrData^.FLoc2);
Result := (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> attrData^.FValueStr);
Result := (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsUri);
if Result then
FNSHelper.BindPrefix(attrData^.FValueStr, Pfx);
FNSHelper.BindPrefix(nsUri, Pfx);
end;
procedure TXMLTextReader.ProcessNamespaceAtts;
@ -4011,17 +4004,17 @@ begin
Pfx := attrData^.FPrefix;
b := TBinding(Pfx^.Data);
if not (Assigned(b) and (b.uri <> '')) then
if not (Assigned(b) and Assigned (b.uri) and (b.uri^.Key <> '')) then
DoErrorPos(esFatal, 'Unbound attribute name prefix "%s"', [Pfx^.Key], attrData^.FLoc);
{ detect duplicates }
J := attrData^.FColonPos+1;
AttrName := attrData^.FQName;
if FNsAttHash.Locate(@b.uri, @AttrName^.Key[J], Length(AttrName^.Key) - J+1) then
if FNsAttHash.Locate(b.uri, @AttrName^.Key[J], Length(AttrName^.Key) - J+1) then
DoErrorPos(esFatal, 'Duplicate prefixed attribute', attrData^.FLoc);
attrData^.FNsUri := FNameTable.FindOrAdd(b.uri);
attrData^.FNsUri := b.uri;
end;
end;
@ -4256,7 +4249,7 @@ end;
procedure TXMLTextReader.PopElement;
begin
if FNamespaces then
FNSHelper.EndElement;
FNSHelper.PopScope;
if (FNesting = 0) and (not FFragmentMode) then
FState := rsEpilog;

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

@ -123,7 +123,7 @@ type
TExpHashEntry = record
rev: LongWord;
hash: LongWord;
uriPtr: PXMLString;
uriPtr: Pointer;
lname: PWideChar;
lnameLen: Integer;
end;
@ -137,7 +137,7 @@ type
FData: PExpHashEntryArray;
public
procedure Init(NumSlots: Integer);
function Locate(uri: PXMLString; localName: PWideChar; localLength: Integer): Boolean;
function Locate(uri: Pointer; localName: PWideChar; localLength: Integer): Boolean;
destructor Destroy; override;
end;
@ -182,7 +182,7 @@ type
TBinding = class
public
uri: XMLString;
uri: PHashItem;
next: TBinding;
prevPrefixBinding: TObject;
Prefix: PHashItem;
@ -196,6 +196,7 @@ type
TNSSupport = class(TObject)
private
FNameTable: THashTable;
FNesting: Integer;
FPrefixSeqNo: Integer;
FFreeBindings: TBinding;
@ -204,17 +205,17 @@ type
FPrefixes: THashTable;
FDefaultPrefix: THashItem;
public
constructor Create;
constructor Create(aNameTable: THashTable);
destructor Destroy; override;
procedure DefineBinding(const Prefix, nsURI: XMLString; out Binding: TBinding);
function CheckAttribute(const Prefix, nsURI: XMLString;
out Binding: TBinding): TAttributeAction;
function IsPrefixBound(P: PWideChar; Len: Integer; out Prefix: PHashItem): Boolean;
function GetPrefix(P: PWideChar; Len: Integer): PHashItem;
function BindPrefix(const nsURI: XMLString; aPrefix: PHashItem): TBinding;
function BindPrefix(nsURI, aPrefix: PHashItem): TBinding;
function DefaultNSBinding: TBinding;
procedure StartElement;
procedure EndElement;
function LookupNamespace(const APrefix: XMLString): XMLString;
procedure PushScope;
function PopScope: Boolean;
end;
{ Buffer builder, used to compose long strings without too much memory allocations }
@ -685,15 +686,14 @@ begin
Dec(FRevision);
end;
function TDblHashArray.Locate(uri: PXMLString; localName: PWideChar; localLength: Integer): Boolean;
function TDblHashArray.Locate(uri: Pointer; localName: PWideChar; localLength: Integer): Boolean;
var
step: Byte;
mask: LongWord;
idx: Integer;
HashValue: LongWord;
begin
HashValue := Hash(0, PWideChar(uri^), Length(uri^));
HashValue := Hash(HashValue, localName, localLength);
HashValue := Hash(PtrUInt(uri), localName, localLength);
mask := (1 shl FSizeLog) - 1;
step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
@ -701,7 +701,7 @@ begin
result := True;
while FData^[idx].rev = FRevision do
begin
if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr^ = uri^) and
if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr = uri) and
(FData^[idx].lnameLen = localLength) and
CompareMem(FData^[idx].lname, localName, localLength * sizeof(WideChar)) then
Exit;
@ -723,11 +723,12 @@ end;
{ TNSSupport }
constructor TNSSupport.Create;
constructor TNSSupport.Create(aNameTable: THashTable);
var
b: TBinding;
begin
inherited Create;
FNameTable := aNameTable;
FPrefixes := THashTable.Create(16, False);
FBindings := TFPList.Create;
SetLength(FBindingStack, 16);
@ -747,7 +748,7 @@ begin
inherited Destroy;
end;
function TNSSupport.BindPrefix(const nsURI: XMLString; aPrefix: PHashItem): TBinding;
function TNSSupport.BindPrefix(nsURI, aPrefix: PHashItem): TBinding;
begin
{ try to reuse an existing binding }
result := FFreeBindings;
@ -778,13 +779,14 @@ end;
procedure TNSSupport.DefineBinding(const Prefix, nsURI: XMLString;
out Binding: TBinding);
var
Pfx: PHashItem;
Pfx, uri: 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 := BindPrefix(nsURI, Pfx)
uri := FNameTable.FindOrAdd(PWideChar(nsURI),Length(nsURI));
if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> uri) then
Binding := BindPrefix(uri, Pfx)
else
Binding := nil;
end;
@ -797,6 +799,7 @@ var
b: TBinding;
buf: array[0..31] of WideChar;
p: PWideChar;
uri: PHashItem;
begin
Binding := nil;
Pfx := nil;
@ -805,8 +808,9 @@ begin
Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix))
else if nsURI = '' then
Exit;
uri := FNameTable.FindOrAdd(PWideChar(nsURI), Length(nsURI));
{ if the prefix is already bound to correct URI, we're done }
if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = nsURI) then
if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = uri) then
Exit;
{ see if there's another prefix bound to the target URI }
@ -816,7 +820,7 @@ begin
b := FBindingStack[i];
while Assigned(b) do
begin
if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then
if (b.uri = uri) and (b.Prefix <> @FDefaultPrefix) then
begin
Binding := b; // found one -> override the attribute's prefix
Result := aaPrefix;
@ -841,17 +845,10 @@ begin
p^ := 'N';
Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1);
until Pfx^.Data = nil;
Binding := BindPrefix(nsURI, Pfx);
Binding := BindPrefix(uri, Pfx);
Result := aaBoth;
end;
function TNSSupport.IsPrefixBound(P: PWideChar; Len: Integer; out
Prefix: PHashItem): Boolean;
begin
Prefix := FPrefixes.FindOrAdd(P, Len);
Result := Assigned(Prefix^.Data) and (TBinding(Prefix^.Data).uri <> '');
end;
function TNSSupport.GetPrefix(P: PWideChar; Len: Integer): PHashItem;
begin
if Assigned(P) and (Len > 0) then
@ -860,17 +857,34 @@ begin
Result := @FDefaultPrefix;
end;
procedure TNSSupport.StartElement;
function TNSSupport.LookupNamespace(const APrefix: XMLString): XMLString;
var
prefixatom: PHashItem;
b: TBinding;
begin
prefixatom := GetPrefix(PWideChar(APrefix),Length(APrefix));
b := TBinding(prefixatom^.Data);
if Assigned(b) and Assigned(b.Uri) then
result := b.Uri^.Key
else
result := '';
end;
procedure TNSSupport.PushScope;
begin
Inc(FNesting);
if FNesting >= Length(FBindingStack) then
SetLength(FBindingStack, FNesting * 2);
end;
procedure TNSSupport.EndElement;
function TNSSupport.PopScope: Boolean;
var
b, temp: TBinding;
begin
{ don't unbind prefixes declared before the first call to PushScope }
Result := FNesting > 0;
if not Result then
Exit;
temp := FBindingStack[FNesting];
while Assigned(temp) do
begin
@ -881,8 +895,7 @@ begin
b.Prefix^.Data := b.prevPrefixBinding;
end;
FBindingStack[FNesting] := nil;
if FNesting > 0 then
Dec(FNesting);
Dec(FNesting);
end;
{ Buffer builder utils }

17
packages/fcl-xml/src/xmlwrite.pp
View File

@ -90,7 +90,7 @@ type
procedure VisitDocumentType(Node: TDOMNode);
procedure VisitPI(Node: TDOMNode);
public
constructor Create(AStream: TStream);
constructor Create(AStream: TStream; ANameTable: THashTable);
destructor Destroy; override;
end;
@ -139,7 +139,7 @@ const
ltStr = '&lt;';
gtStr = '&gt;';
constructor TXMLWriter.Create(AStream: TStream);
constructor TXMLWriter.Create(AStream: TStream; ANameTable: THashTable);
var
I: Integer;
begin
@ -165,7 +165,7 @@ begin
FIndent[2] := ' ';
for I := 3 to 100 do FIndent[I] := ' ';
FIndentCount := 0;
FNSHelper := TNSSupport.Create;
FNSHelper := TNSSupport.Create(ANameTable);
FScratch := TFPList.Create;
FNSDefs := TFPList.Create;
FAttrFixups := TFPList.Create;
@ -426,7 +426,8 @@ begin
wrtStr(B.Prefix^.Key);
end;
wrtChars('="', 2);
ConvWrite(B.uri, AttrSpecialChars, @AttrSpecialCharCallback);
if Assigned(B.uri) then
ConvWrite(B.uri^.Key, AttrSpecialChars, @AttrSpecialCharCallback);
wrtChr('"');
end;
@ -575,7 +576,7 @@ var
begin
if not FInsideTextNode then
wrtIndent;
FNSHelper.StartElement;
FNSHelper.PushScope;
wrtChr('<');
wrtStr(TDOMElement(node).TagName);
@ -611,7 +612,7 @@ begin
wrtStr(TDOMElement(Node).TagName);
wrtChr('>');
end;
FNSHelper.EndElement;
FNSHelper.PopScope;
end;
procedure TXMLWriter.VisitText(node: TDOMNode);
@ -825,7 +826,7 @@ var
begin
s := TTextStream.Create(AFile);
try
with TXMLWriter.Create(s) do
with TXMLWriter.Create(s, doc.Names) do
try
WriteNode(doc);
finally
@ -838,7 +839,7 @@ end;
procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream);
begin
with TXMLWriter.Create(AStream) do
with TXMLWriter.Create(AStream, doc.Names) do
try
WriteNode(doc);
finally