← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazutils/laz2_xmlutils.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/lazutils/laz2_xmlutils.pas
 
1
{
 
2
    This file is part of the Free Component Library
 
3
 
 
4
    XML utility routines.
 
5
    Copyright (c) 2006 by Sergei Gorelkin, sergei_gorelkin@mail.ru
 
6
 
 
7
    See the file COPYING.FPC, included in this distribution,
 
8
    for details about the copyright.
 
9
 
 
10
    This program is distributed in the hope that it will be useful,
 
11
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
13
 
 
14
 **********************************************************************}
 
15
unit laz2_xmlutils;
 
16
 
 
17
{$ifdef fpc}{$mode objfpc}{$endif}
 
18
{$H+}
 
19
{$ifopt Q+}{$define overflow_check}{$endif}
 
20
{$R-}
 
21
 
 
22
interface
 
23
 
 
24
uses
 
25
  SysUtils, Classes;
 
26
 
 
27
type
 
28
  TXMLUtilString = AnsiString;
 
29
  TXMLUtilChar = Char;
 
30
  PXMLUtilChar = PChar;
 
31
  PXMLUtilString = ^TXMLUtilString;
 
32
 
 
33
function IsXmlName(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean; overload;
 
34
function IsXmlName(Value: PXMLUtilChar; Len: Integer; Xml11: Boolean = False): Boolean; overload;
 
35
function IsXmlNames(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
 
36
function IsXmlNmToken(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
 
37
function IsXmlNmTokens(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
 
38
function IsValidXmlEncoding(const Value: TXMLUtilString): Boolean;
 
39
function Xml11NamePages: PByteArray;
 
40
procedure NormalizeSpaces(var Value: TXMLUtilString);
 
41
function IsXmlWhiteSpace(c: PXMLUtilChar): Boolean;
 
42
function Hash(InitValue: LongWord; Key: PXMLUtilChar; KeyLen: Integer): LongWord;
 
43
{ beware, works in ASCII range only }
 
44
function WStrLIComp(S1, S2: PXMLUtilChar; Len: Integer): Integer;
 
45
 
 
46
{ a simple hash table with TXMLUtilString keys }
 
47
 
 
48
type
 
49
{$ifndef fpc}
 
50
  PtrInt = LongInt;
 
51
  TFPList = TList;
 
52
{$endif}  
 
53
 
 
54
  PPHashItem = ^PHashItem;
 
55
  PHashItem = ^THashItem;
 
56
  THashItem = record
 
57
    Key: TXMLUtilString;
 
58
    HashValue: LongWord;
 
59
    Next: PHashItem;
 
60
    Data: TObject;
 
61
  end;
 
62
  THashItemArray = array[0..MaxInt div sizeof(Pointer)-1] of PHashItem;
 
63
  PHashItemArray = ^THashItemArray;
 
64
 
 
65
  THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean;
 
66
 
 
67
  THashTable = class(TObject)
 
68
  private
 
69
    FCount: LongWord;
 
70
    FBucketCount: LongWord;
 
71
    FBucket: PHashItemArray;
 
72
    FOwnsObjects: Boolean;
 
73
    function Lookup(Key: PXMLUtilChar; KeyLength: Integer; out Found: Boolean; CanCreate: Boolean): PHashItem;
 
74
    procedure Resize(NewCapacity: LongWord);
 
75
  public
 
76
    constructor Create(InitSize: Integer; OwnObjects: Boolean);
 
77
    destructor Destroy; override;
 
78
    procedure Clear;
 
79
    function Find(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
 
80
    function FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer; out Found: Boolean): PHashItem; overload;
 
81
    function FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer): PHashItem; overload;
 
82
    function Get(Key: PXMLUtilChar; KeyLen: Integer): TObject;
 
83
    function Remove(Entry: PHashItem): Boolean;
 
84
    function RemoveData(aData: TObject): Boolean;
 
85
    procedure ForEach(proc: THashForEach; arg: Pointer);
 
86
    property Count: LongWord read FCount;
 
87
  end;
 
88
 
 
89
{ another hash, for detecting duplicate namespaced attributes without memory allocations }
 
90
 
 
91
  TExpHashEntry = record
 
92
    rev: LongWord;
 
93
    hash: LongWord;
 
94
    uriPtr: PXMLUtilString;
 
95
    lname: PXMLUtilChar;
 
96
    lnameLen: Integer;
 
97
  end;
 
98
  TExpHashEntryArray = array[0..MaxInt div sizeof(TExpHashEntry)-1] of TExpHashEntry;
 
99
  PExpHashEntryArray = ^TExpHashEntryArray;
 
100
 
 
101
  TDblHashArray = class(TObject)
 
102
  private
 
103
    FSizeLog: Integer;
 
104
    FRevision: LongWord;
 
105
    FData: PExpHashEntryArray;
 
106
  public  
 
107
    procedure Init(NumSlots: Integer);
 
108
    function Locate(uri: PXMLUtilString; localName: PXMLUtilChar; localLength: Integer): Boolean;
 
109
    destructor Destroy; override;
 
110
  end;
 
111
 
 
112
  TBinding = class
 
113
  public
 
114
    uri: TXMLUtilString;
 
115
    next: TBinding;
 
116
    prevPrefixBinding: TObject;
 
117
    Prefix: PHashItem;
 
118
  end;
 
119
 
 
120
  TAttributeAction = (
 
121
    aaUnchanged,
 
122
    aaPrefix,         // only override the prefix
 
123
    aaBoth            // override prefix and emit namespace definition
 
124
  );
 
125
 
 
126
  TNSSupport = class(TObject)
 
127
  private
 
128
    FNesting: Integer;
 
129
    FPrefixSeqNo: Integer;
 
130
    FFreeBindings: TBinding;
 
131
    FBindings: TFPList;
 
132
    FBindingStack: array of TBinding;
 
133
    FPrefixes: THashTable;
 
134
    FDefaultPrefix: THashItem;
 
135
  public
 
136
    constructor Create;
 
137
    destructor Destroy; override;
 
138
    procedure DefineBinding(const Prefix, nsURI: TXMLUtilString; out Binding: TBinding);
 
139
    function CheckAttribute(const Prefix, nsURI: TXMLUtilString;
 
140
      out Binding: TBinding): TAttributeAction;
 
141
    function IsPrefixBound(P: PXMLUtilChar; Len: Integer; out Prefix: PHashItem): Boolean;
 
142
    function GetPrefix(P: PXMLUtilChar; Len: Integer): PHashItem;
 
143
    function BindPrefix(const nsURI: TXMLUtilString; aPrefix: PHashItem): TBinding;
 
144
    function DefaultNSBinding: TBinding;
 
145
    procedure StartElement;
 
146
    procedure EndElement;
 
147
  end;
 
148
 
 
149
{$i laz2_names.inc}
 
150
 
 
151
implementation
 
152
 
 
153
var
 
154
  Xml11Pg: PByteArray = nil;
 
155
 
 
156
function Xml11NamePages: PByteArray;
 
157
var
 
158
  I: Integer;
 
159
  p: PByteArray;
 
160
begin
 
161
  if Xml11Pg = nil then
 
162
  begin
 
163
    GetMem(p, 512);
 
164
    for I := 0 to 255 do
 
165
      p^[I] := ord(Byte(I) in Xml11HighPages);
 
166
    p^[0] := 2;
 
167
    p^[3] := $2c;
 
168
    p^[$20] := $2a;
 
169
    p^[$21] := $2b;
 
170
    p^[$2f] := $29;
 
171
    p^[$30] := $2d;
 
172
    p^[$fd] := $28;
 
173
    p^[$ff] := $30;
 
174
 
 
175
    Move(p^, p^[256], 256);
 
176
    p^[$100] := $19;
 
177
    p^[$103] := $2E;
 
178
    p^[$120] := $2F;
 
179
    Xml11Pg := p;
 
180
  end;
 
181
  Result := Xml11Pg;
 
182
end;
 
183
 
 
184
function IsXml11Char(Value: PXMLUtilChar; var Index: Integer): Boolean; overload;
 
185
begin
 
186
  if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
 
187
  begin
 
188
    Inc(Index);
 
189
    Result := (Value[Index] >= #$DC00) and (Value[Index] <= #$DFFF);
 
190
  end
 
191
  else
 
192
    Result := False;
 
193
end;
 
194
 
 
195
function IsXml11Char(const Value: TXMLUtilString; var Index: Integer): Boolean; overload;
 
196
begin
 
197
  if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
 
198
  begin
 
199
    Inc(Index);
 
200
    Result := (Value[Index] >= #$DC00) and (Value[Index] <= #$DFFF);
 
201
  end
 
202
  else
 
203
    Result := False;
 
204
end;
 
205
 
 
206
function IsXmlName(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
 
207
begin
 
208
  Result := IsXmlName(PXMLUtilChar(Value), Length(Value), Xml11);
 
209
end;
 
210
 
 
211
function IsXmlName(Value: PXMLUtilChar; Len: Integer; Xml11: Boolean = False): Boolean;
 
212
var
 
213
  Pages: PByteArray;
 
214
  I: Integer;
 
215
begin
 
216
  Result := False;
 
217
  if Xml11 then
 
218
    Pages := Xml11NamePages
 
219
  else
 
220
    Pages := @NamePages;
 
221
 
 
222
  I := 0;
 
223
  if (Len = 0) or not ((Byte(Value[I]) in NamingBitmap[Pages^[hi(Word(Value[I]))]]) or
 
224
    (Value[I] = ':') or
 
225
    (Xml11 and IsXml11Char(Value, I))) then
 
226
      Exit;
 
227
  Inc(I);
 
228
  while I < Len do
 
229
  begin
 
230
    if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
 
231
      (Value[I] = ':') or
 
232
      (Xml11 and IsXml11Char(Value, I))) then
 
233
        Exit;
 
234
    Inc(I);
 
235
  end;
 
236
  Result := True;
 
237
end;
 
238
 
 
239
function IsXmlNames(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
 
240
var
 
241
  Pages: PByteArray;
 
242
  I: Integer;
 
243
  Offset: Integer;
 
244
begin
 
245
  if Xml11 then
 
246
    Pages := Xml11NamePages
 
247
  else
 
248
    Pages := @NamePages;
 
249
  Result := False;
 
250
  if Value = '' then
 
251
    Exit;
 
252
  I := 1;
 
253
  Offset := 0;
 
254
  while I <= Length(Value) do
 
255
  begin
 
256
    if not ((Byte(Value[I]) in NamingBitmap[Pages^[Offset+hi(Word(Value[I]))]]) or
 
257
      (Value[I] = ':') or
 
258
      (Xml11 and IsXml11Char(Value, I))) then
 
259
    begin
 
260
      if (I = Length(Value)) or (Value[I] <> #32) then
 
261
        Exit;
 
262
      Offset := 0;
 
263
      Inc(I);
 
264
      Continue;
 
265
    end;
 
266
    Offset := $100;
 
267
    Inc(I);
 
268
  end;
 
269
  Result := True;
 
270
end;
 
271
 
 
272
function IsXmlNmToken(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
 
273
var
 
274
  I: Integer;
 
275
  Pages: PByteArray;
 
276
begin
 
277
  if Xml11 then
 
278
    Pages := Xml11NamePages
 
279
  else
 
280
    Pages := @NamePages;
 
281
  Result := False;
 
282
  if Value = '' then
 
283
    Exit;
 
284
  I := 1;
 
285
  while I <= Length(Value) do
 
286
  begin
 
287
    if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
 
288
      (Value[I] = ':') or
 
289
      (Xml11 and IsXml11Char(Value, I))) then
 
290
        Exit;
 
291
    Inc(I);
 
292
  end;
 
293
  Result := True;
 
294
end;
 
295
 
 
296
function IsXmlNmTokens(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
 
297
var
 
298
  I: Integer;
 
299
  Pages: PByteArray;
 
300
begin
 
301
  if Xml11 then
 
302
    Pages := Xml11NamePages
 
303
  else
 
304
    Pages := @NamePages;
 
305
  I := 1;
 
306
  Result := False;
 
307
  if Value = '' then
 
308
    Exit;
 
309
  while I <= Length(Value) do
 
310
  begin
 
311
    if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
 
312
      (Value[I] = ':') or
 
313
      (Xml11 and IsXml11Char(Value, I))) then
 
314
    begin
 
315
      if (I = Length(Value)) or (Value[I] <> #32) then
 
316
        Exit;
 
317
    end;
 
318
    Inc(I);
 
319
  end;
 
320
  Result := True;
 
321
end;
 
322
 
 
323
function IsValidXmlEncoding(const Value: TXMLUtilString): Boolean;
 
324
var
 
325
  I: Integer;
 
326
begin
 
327
  Result := False;
 
328
  if (Value = '') or (Value[1] > #255) or not (char(ord(Value[1])) in ['A'..'Z', 'a'..'z']) then
 
329
    Exit;
 
330
  for I := 2 to Length(Value) do
 
331
    if (Value[I] > #255) or not (char(ord(Value[I])) in ['A'..'Z', 'a'..'z', '0'..'9', '.', '_', '-']) then
 
332
      Exit;
 
333
  Result := True;
 
334
end;
 
335
 
 
336
procedure NormalizeSpaces(var Value: TXMLUtilString);
 
337
var
 
338
  I, J: Integer;
 
339
begin
 
340
  I := Length(Value);
 
341
  // speed: trim only whed needed
 
342
  if (I > 0) and ((Value[1] = #32) or (Value[I] = #32)) then
 
343
    Value := Trim(Value);
 
344
  I := 1;
 
345
  while I < Length(Value) do
 
346
  begin
 
347
    if Value[I] = #32 then
 
348
    begin
 
349
      J := I+1;
 
350
      while (J <= Length(Value)) and (Value[J] = #32) do Inc(J);
 
351
      if J-I > 1 then Delete(Value, I+1, J-I-1);
 
352
    end;
 
353
    Inc(I);
 
354
  end;
 
355
end;
 
356
 
 
357
function IsXmlWhiteSpace(c: PXMLUtilChar): Boolean;
 
358
begin
 
359
  Result := c^ in [#32,#9,#10,#13];
 
360
end;
 
361
 
 
362
function WStrLIComp(S1, S2: PXMLUtilChar; Len: Integer): Integer;
 
363
var
 
364
  counter: Integer;
 
365
  c1, c2: Word;
 
366
begin
 
367
  counter := 0;
 
368
  result := 0;
 
369
  if Len = 0 then
 
370
    exit;
 
371
  repeat
 
372
    c1 := ord(S1[counter]);
 
373
    c2 := ord(S2[counter]);
 
374
    if (c1 = 0) or (c2 = 0) then break;
 
375
    if c1 <> c2 then
 
376
    begin
 
377
      if c1 in [97..122] then
 
378
        Dec(c1, 32);
 
379
      if c2 in [97..122] then
 
380
        Dec(c2, 32);
 
381
      if c1 <> c2 then
 
382
        Break;
 
383
    end;
 
384
    Inc(counter);
 
385
  until counter >= Len;
 
386
  result := c1 - c2;
 
387
end;
 
388
 
 
389
function Hash(InitValue: LongWord; Key: PXMLUtilChar; KeyLen: Integer): LongWord;
 
390
begin
 
391
  Result := InitValue;
 
392
  while KeyLen <> 0 do
 
393
  begin
 
394
{$ifdef overflow_check}{$q-}{$endif}
 
395
    Result := Result * $F4243 xor ord(Key^);
 
396
{$ifdef overflow_check}{$q+}{$endif}
 
397
    Inc(Key);
 
398
    Dec(KeyLen);
 
399
  end;
 
400
end;
 
401
 
 
402
function KeyCompare(const Key1: TXMLUtilString; Key2: Pointer; Key2Len: Integer): Boolean;
 
403
begin
 
404
{$IF defined(FPC) and (SizeOf(TXMLUtilChar)=2)}
 
405
  Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0);
 
406
{$ELSE}
 
407
  Result := (Length(Key1)=Key2Len) and CompareMem(Pointer(Key1), Key2, Key2Len*SizeOf(TXMLUtilChar));
 
408
{$ENDIF}
 
409
end;
 
410
 
 
411
{ THashTable }
 
412
 
 
413
constructor THashTable.Create(InitSize: Integer; OwnObjects: Boolean);
 
414
var
 
415
  I: Integer;
 
416
begin
 
417
  inherited Create;
 
418
  FOwnsObjects := OwnObjects;
 
419
  I := 256;
 
420
  while I < InitSize do I := I shl 1;
 
421
  FBucketCount := I;
 
422
  FBucket := AllocMem(I * sizeof(PHashItem));
 
423
end;
 
424
 
 
425
destructor THashTable.Destroy;
 
426
begin
 
427
  Clear;
 
428
  FreeMem(FBucket);
 
429
  inherited Destroy;
 
430
end;
 
431
 
 
432
procedure THashTable.Clear;
 
433
var
 
434
  I: Integer;
 
435
  item, next: PHashItem;
 
436
begin
 
437
  for I := 0 to FBucketCount-1 do
 
438
  begin
 
439
    item := FBucket^[I];
 
440
    while Assigned(item) do
 
441
    begin
 
442
      next := item^.Next;
 
443
      if FOwnsObjects then
 
444
        item^.Data.Free;
 
445
      Dispose(item);
 
446
      item := next;
 
447
    end;
 
448
    FBucket^[I] := nil;
 
449
  end;
 
450
end;
 
451
 
 
452
function THashTable.Find(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
 
453
var
 
454
  Dummy: Boolean;
 
455
begin
 
456
  Result := Lookup(Key, KeyLen, Dummy, False);
 
457
end;
 
458
 
 
459
function THashTable.FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer;
 
460
  out Found: Boolean): PHashItem;
 
461
begin
 
462
  Result := Lookup(Key, KeyLen, Found, True);
 
463
end;
 
464
 
 
465
function THashTable.FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
 
466
var
 
467
  Dummy: Boolean;
 
468
begin
 
469
  Result := Lookup(Key, KeyLen, Dummy, True);
 
470
end;
 
471
 
 
472
function THashTable.Get(Key: PXMLUtilChar; KeyLen: Integer): TObject;
 
473
var
 
474
  e: PHashItem;
 
475
  Dummy: Boolean;
 
476
begin
 
477
  e := Lookup(Key, KeyLen, Dummy, False);
 
478
  if Assigned(e) then
 
479
    Result := e^.Data
 
480
  else
 
481
    Result := nil;  
 
482
end;
 
483
 
 
484
function THashTable.Lookup(Key: PXMLUtilChar; KeyLength: Integer;
 
485
  out Found: Boolean; CanCreate: Boolean): PHashItem;
 
486
var
 
487
  Entry: PPHashItem;
 
488
  h: LongWord;
 
489
begin
 
490
  h := Hash(0, Key, KeyLength);
 
491
  Entry := @FBucket^[h mod FBucketCount];
 
492
  while Assigned(Entry^) and not ((Entry^^.HashValue = h) and KeyCompare(Entry^^.Key, Key, KeyLength) ) do
 
493
    Entry := @Entry^^.Next;
 
494
  Found := Assigned(Entry^);
 
495
  if Found or (not CanCreate) then
 
496
  begin
 
497
    Result := Entry^;
 
498
    Exit;
 
499
  end;
 
500
  if FCount > ((FBucketCount*7) div 8) then
 
501
  begin
 
502
    Resize(FBucketCount * 2);
 
503
    Result := Lookup(Key, KeyLength, Found, CanCreate);
 
504
  end
 
505
  else
 
506
  begin
 
507
    New(Result);
 
508
    // SetString for TXMLUtilStrings trims on zero chars [fixed, #14740]
 
509
    SetLength(Result^.Key, KeyLength);
 
510
    Move(Key^, Pointer(Result^.Key)^, KeyLength*sizeof(TXMLUtilChar));
 
511
    Result^.HashValue := h;
 
512
    Result^.Data := nil;
 
513
    Result^.Next := nil;
 
514
    Inc(FCount);
 
515
    Entry^ := Result;
 
516
  end;
 
517
end;
 
518
 
 
519
procedure THashTable.Resize(NewCapacity: LongWord);
 
520
var
 
521
  p: PHashItemArray;
 
522
  chain: PPHashItem;
 
523
  i: Integer;
 
524
  e, n: PHashItem;
 
525
begin
 
526
  p := AllocMem(NewCapacity * sizeof(PHashItem));
 
527
  for i := 0 to FBucketCount-1 do
 
528
  begin
 
529
    e := FBucket^[i];
 
530
    while Assigned(e) do
 
531
    begin
 
532
      chain := @p^[e^.HashValue mod NewCapacity];
 
533
      n := e^.Next;
 
534
      e^.Next := chain^;
 
535
      chain^ := e;
 
536
      e := n;
 
537
    end;
 
538
  end;
 
539
  FBucketCount := NewCapacity;
 
540
  FreeMem(FBucket);
 
541
  FBucket := p;
 
542
end;
 
543
 
 
544
function THashTable.Remove(Entry: PHashItem): Boolean;
 
545
var
 
546
  chain: PPHashItem;
 
547
begin
 
548
  chain := @FBucket^[Entry^.HashValue mod FBucketCount];
 
549
  while Assigned(chain^) do
 
550
  begin
 
551
    if chain^ = Entry then
 
552
    begin
 
553
      chain^ := Entry^.Next;
 
554
      if FOwnsObjects then
 
555
        Entry^.Data.Free;
 
556
      Dispose(Entry);
 
557
      Dec(FCount);
 
558
      Result := True;
 
559
      Exit;
 
560
    end;
 
561
    chain := @chain^^.Next;
 
562
  end;
 
563
  Result := False;
 
564
end;
 
565
 
 
566
// this does not free the aData object
 
567
function THashTable.RemoveData(aData: TObject): Boolean;
 
568
var
 
569
  i: Integer;
 
570
  chain: PPHashItem;
 
571
  e: PHashItem;
 
572
begin
 
573
  for i := 0 to FBucketCount-1 do
 
574
  begin
 
575
    chain := @FBucket^[i];
 
576
    while Assigned(chain^) do
 
577
    begin
 
578
      if chain^^.Data = aData then
 
579
      begin
 
580
        e := chain^;
 
581
        chain^ := e^.Next;
 
582
        Dispose(e);
 
583
        Dec(FCount);
 
584
        Result := True;
 
585
        Exit;
 
586
      end;
 
587
      chain := @chain^^.Next;
 
588
    end;
 
589
  end;
 
590
  Result := False;
 
591
end;
 
592
 
 
593
procedure THashTable.ForEach(proc: THashForEach; arg: Pointer);
 
594
var
 
595
  i: Integer;
 
596
  e: PHashItem;
 
597
begin
 
598
  for i := 0 to FBucketCount-1 do
 
599
  begin
 
600
    e := FBucket^[i];
 
601
    while Assigned(e) do
 
602
    begin
 
603
      if not proc(e, arg) then
 
604
        Exit;
 
605
      e := e^.Next;
 
606
    end;
 
607
  end;
 
608
end;
 
609
 
 
610
{ TDblHashArray }
 
611
 
 
612
destructor TDblHashArray.Destroy;
 
613
begin
 
614
  FreeMem(FData);
 
615
  inherited Destroy;
 
616
end;
 
617
 
 
618
procedure TDblHashArray.Init(NumSlots: Integer);
 
619
var
 
620
  i: Integer;
 
621
begin
 
622
  if ((NumSlots * 2) shr FSizeLog) <> 0 then   // need at least twice more entries, and no less than 8
 
623
  begin
 
624
    FSizeLog := 3;
 
625
    while (NumSlots shr FSizeLog) <> 0 do
 
626
      Inc(FSizeLog);
 
627
    ReallocMem(FData, (1 shl FSizeLog) * sizeof(TExpHashEntry));
 
628
    FRevision := 0;
 
629
  end;
 
630
  if FRevision = 0 then
 
631
  begin
 
632
    FRevision := $FFFFFFFF;
 
633
    for i := (1 shl FSizeLog)-1 downto 0 do
 
634
      FData^[i].rev := FRevision;
 
635
  end;
 
636
  Dec(FRevision);
 
637
end;
 
638
 
 
639
function TDblHashArray.Locate(uri: PXMLUtilString; localName: PXMLUtilChar; localLength: Integer): Boolean;
 
640
var
 
641
  step: Byte;
 
642
  mask: LongWord;
 
643
  idx: Integer;
 
644
  HashValue: LongWord;
 
645
begin
 
646
  HashValue := Hash(0, PXMLUtilChar(uri^), Length(uri^));
 
647
  HashValue := Hash(HashValue, localName, localLength);
 
648
 
 
649
  mask := (1 shl FSizeLog) - 1;
 
650
  step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
 
651
  idx := HashValue and mask;
 
652
  result := True;
 
653
  while FData^[idx].rev = FRevision do
 
654
  begin
 
655
    if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr^ = uri^) and
 
656
      (FData^[idx].lnameLen = localLength) and
 
657
       CompareMem(FData^[idx].lname, localName, localLength * sizeof(TXMLUtilChar)) then
 
658
      Exit;
 
659
    if idx < step then
 
660
      Inc(idx, (1 shl FSizeLog) - step)
 
661
    else
 
662
      Dec(idx, step);
 
663
  end;
 
664
  with FData^[idx] do
 
665
  begin
 
666
    rev := FRevision;
 
667
    hash := HashValue;
 
668
    uriPtr := uri;
 
669
    lname := localName;
 
670
    lnameLen := localLength;
 
671
  end;
 
672
  result := False;
 
673
end;
 
674
 
 
675
{ TNSSupport }
 
676
 
 
677
constructor TNSSupport.Create;
 
678
var
 
679
  b: TBinding;
 
680
begin
 
681
  inherited Create;
 
682
  FPrefixes := THashTable.Create(16, False);
 
683
  FBindings := TFPList.Create;
 
684
  SetLength(FBindingStack, 16);
 
685
 
 
686
  { provide implicit binding for the 'xml' prefix }
 
687
  // TODO: move stduri_xml, etc. to this unit, so they are reused.
 
688
  DefineBinding('xml', 'http://www.w3.org/XML/1998/namespace', b);
 
689
end;
 
690
 
 
691
destructor TNSSupport.Destroy;
 
692
var
 
693
  I: Integer;
 
694
begin
 
695
  for I := FBindings.Count-1 downto 0 do
 
696
    TObject(FBindings.List^[I]).Free;
 
697
  FBindings.Free;
 
698
  FPrefixes.Free;
 
699
  inherited Destroy;
 
700
end;
 
701
 
 
702
function TNSSupport.BindPrefix(const nsURI: TXMLUtilString; aPrefix: PHashItem): TBinding;
 
703
begin
 
704
  { try to reuse an existing binding }
 
705
  result := FFreeBindings;
 
706
  if Assigned(result) then
 
707
    FFreeBindings := result.Next
 
708
  else { no free bindings, create a new one }
 
709
  begin
 
710
    result := TBinding.Create;
 
711
    FBindings.Add(result);
 
712
  end;
 
713
 
 
714
  { link it into chain of bindings at the current element level }
 
715
  result.Next := FBindingStack[FNesting];
 
716
  FBindingStack[FNesting] := result;
 
717
 
 
718
  { bind }
 
719
  result.uri := nsURI;
 
720
  result.Prefix := aPrefix;
 
721
  result.PrevPrefixBinding := aPrefix^.Data;
 
722
  aPrefix^.Data := result;
 
723
end;
 
724
 
 
725
function TNSSupport.DefaultNSBinding: TBinding;
 
726
begin
 
727
  result := TBinding(FDefaultPrefix.Data);
 
728
end;
 
729
 
 
730
procedure TNSSupport.DefineBinding(const Prefix, nsURI: TXMLUtilString;
 
731
  out Binding: TBinding);
 
732
var
 
733
  Pfx: PHashItem;
 
734
begin
 
735
  Pfx := @FDefaultPrefix;
 
736
  if (nsURI <> '') and (Prefix <> '') then
 
737
    Pfx := FPrefixes.FindOrAdd(PXMLUtilChar(Prefix), Length(Prefix));
 
738
  if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then
 
739
    Binding := BindPrefix(nsURI, Pfx)
 
740
  else
 
741
    Binding := nil;
 
742
end;
 
743
 
 
744
function TNSSupport.CheckAttribute(const Prefix, nsURI: TXMLUtilString;
 
745
  out Binding: TBinding): TAttributeAction;
 
746
var
 
747
  Pfx: PHashItem;
 
748
  I: Integer;
 
749
  b: TBinding;
 
750
  buf: array[0..31] of TXMLUtilChar;
 
751
  p: PXMLUtilChar;
 
752
begin
 
753
  Binding := nil;
 
754
  Pfx := nil;
 
755
  Result := aaUnchanged;
 
756
  if Prefix <> '' then
 
757
    Pfx := FPrefixes.FindOrAdd(PXMLUtilChar(Prefix), Length(Prefix))
 
758
  else if nsURI = '' then
 
759
    Exit;
 
760
  { if the prefix is already bound to correct URI, we're done }
 
761
  if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = nsURI) then
 
762
    Exit;
 
763
 
 
764
  { see if there's another prefix bound to the target URI }
 
765
  // TODO: should use something faster than linear search
 
766
  for i := FNesting downto 0 do
 
767
  begin
 
768
    b := FBindingStack[i];
 
769
    while Assigned(b) do
 
770
    begin
 
771
      if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then
 
772
      begin
 
773
        Binding := b;   // found one -> override the attribute's prefix
 
774
        Result := aaPrefix;
 
775
        Exit;
 
776
      end;
 
777
      b := b.Next;
 
778
    end;
 
779
  end;
 
780
  { no prefix, or bound (to wrong URI) -> use generated prefix instead }
 
781
  if (Pfx = nil) or Assigned(Pfx^.Data) then
 
782
  repeat
 
783
    Inc(FPrefixSeqNo);
 
784
    i := FPrefixSeqNo;    // This is just 'NS'+IntToStr(FPrefixSeqNo);
 
785
    p := @Buf[high(Buf)]; // done without using strings
 
786
    while i <> 0 do
 
787
    begin
 
788
      p^ := TXMLUtilChar(i mod 10+ord('0'));
 
789
      dec(p);
 
790
      i := i div 10;
 
791
    end;
 
792
    p^ := 'S'; dec(p);
 
793
    p^ := 'N';
 
794
    Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1);
 
795
  until Pfx^.Data = nil;
 
796
  Binding := BindPrefix(nsURI, Pfx);
 
797
  Result := aaBoth;
 
798
end;
 
799
 
 
800
function TNSSupport.IsPrefixBound(P: PXMLUtilChar; Len: Integer; out
 
801
  Prefix: PHashItem): Boolean;
 
802
begin
 
803
  Prefix := FPrefixes.FindOrAdd(P, Len);
 
804
  Result := Assigned(Prefix^.Data) and (TBinding(Prefix^.Data).uri <> '');
 
805
end;
 
806
 
 
807
function TNSSupport.GetPrefix(P: PXMLUtilChar; Len: Integer): PHashItem;
 
808
begin
 
809
  if Assigned(P) and (Len > 0) then
 
810
    Result := FPrefixes.FindOrAdd(P, Len)
 
811
  else
 
812
    Result := @FDefaultPrefix;
 
813
end;
 
814
 
 
815
procedure TNSSupport.StartElement;
 
816
begin
 
817
  Inc(FNesting);
 
818
  if FNesting >= Length(FBindingStack) then
 
819
    SetLength(FBindingStack, FNesting * 2);
 
820
end;
 
821
 
 
822
procedure TNSSupport.EndElement;
 
823
var
 
824
  b, temp: TBinding;
 
825
begin
 
826
  temp := FBindingStack[FNesting];
 
827
  while Assigned(temp) do
 
828
  begin
 
829
    b := temp;
 
830
    temp := b.next;
 
831
    b.next := FFreeBindings;
 
832
    FFreeBindings := b;
 
833
    b.Prefix^.Data := b.prevPrefixBinding;
 
834
  end;
 
835
  FBindingStack[FNesting] := nil;
 
836
  if FNesting > 0 then
 
837
    Dec(FNesting);
 
838
end;
 
839
 
 
840
 
 
841
initialization
 
842
 
 
843
finalization
 
844
  if Assigned(Xml11Pg) then
 
845
    FreeMem(Xml11Pg);
 
846
 
 
847
end.