xmlutils.pp 20 KB

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