View Issue Details

IDProjectCategoryView StatusLast Update
0035608FPCCompilerpublic2019-05-21 12:30
ReporterBenito van der ZanderAssigned To 
PrioritynormalSeverityminorReproducibilityunable to reproduce
Status newResolutionopen 
Platformamd64OSlinuxOS Versionopensuse
Product Version3.3.1Product Buildr40721 
Target VersionFixed in Version 
Summary0035608: linking error when generic crc differ
DescriptionI use some source files in multiple projects in the same directory and now FPC has created two different object files for this file:

/usr/local/bin/fpc -MObjFPC -Scgi -Cg -O1 -g -gl -l -vewnhibq -Fu../../../../../benito/hg/components/pascal/import/synapse -Fu../../../../../benito/hg/components/pascal/import/regexpr/Source -Fu../../../../../benito/hg/components/pascal/internet -Fu. -Fu../../../components/pascal/import/bigint -Fu../../../../opt/lazarus/lcl/units/x86_64-linux -Fu../../../../opt/lazarus/components/lazutils/lib/x86_64-linux -Fu../../../components/pascal/lib/x86_64-linux -Fu../../../../opt/lazarus/packager/units/x86_64-linux -oxidelcgi

made a file xquery.namespace.o containing this method:

0000000000000000 g F .text.n_xquery.namespaces$_$tfastinterfacelist$1$crc0a34dd37_$__$$_delete$longint 00000000000000d9 XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC0A34DD37_$__$$_DELETE$LONGINT

while

/usr/local/bin/fpc -MObjFPC -Scaghi -CX -Cg -Cr -O2 -g -gl -gv -XX -l -vewnhibq -Filib/x86_64-linux -Fu../../../components/pascal/import/synapse -Fu../../../components/pascal/internet -Fu../../../components/pascal/data -Fu../../../components/pascal/system -Fu../../../components/pascal/import/regexpr/source -Fu../../../components/pascal/import/utf8tools -Fu../../../components/pascal/lib/x86_64-linux -Fu../../../../opt/lazarus/packager/units/x86_64-linux -Fu. -FUlib/x86_64-linux -FE. -oxidel

made a file lib/x86_64-linux/xquery.namespace.o containing method:

0000000000000000 g F .text.n_xquery.namespaces$_$tfastinterfacelist$1$crc7b637175_$__$$_delete$longint 00000000000000cc XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC7B637175_$__$$_DELETE$LONGINT


Since I made both fpc calls in the same directory, the second call finds the xquery.namespace.o of the first call, and uses the CRC0A34DD37 method. But in the link.res it refers to its input lib/x86_64-linux/xquery.namespace.o, so it does not link:

/home/theo/hg/programs/internet/xidel//../../../components/pascal/data/simplehtmltreeparser.pas:1797: undefined reference to `XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC0A34DD37_$__$$_DELETE$LONGINT'
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files
  • xquery.namespaces.o (143,040 bytes)
  • xquery.namespaces.ppu (56,354 bytes)
  • xquery.namespaces-2.o (142,616 bytes)
  • xquery.namespaces-2.ppu (56,385 bytes)
  • xquery.namespaces.pas (9,178 bytes)
    unit xquery.namespaces;
    {
    Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                              benito@benibela.de
                              www.benibela.de
    
    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.
    
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
    
    }
    
    {$mode objfpc}{$H+}
    
    interface
    
    uses
      Classes, SysUtils, xquery.internals.common;
    
    type
    
    TNamespace = class;
    
    //** Namespace interface, storing url and prefix. (Interface, so it is ref-counted)
    INamespace = interface
    ['{5F6DF5F2-548C-4F13-9BEA-CE59EBAE4CAB}']
      function getPrefix: string; //**< Returns the prefix
      function getURL: string; //**< Returns the url
      function serialize: string; //**< Returns an xmlns attribute declaring this namespace with url and prefix
      function getSelf: TNamespace;
      function equal(const ns: string): boolean;
    end;
    
    
    { TNamespace }
    
    //** Class implementing the INamespace interface
    TNamespace = class(TInterfacedObject, INamespace)
    public
      url: string;
      prefix: string;
      //** Creates a new namespace with url and prefix. (watch the argument order. It follows the XPath fn:QName function)
      constructor create(const aurl: string; aprefix: string);
    
      class function make(const aurl: string; const aprefix: string): TNamespace; static;
      class function uniqueUrl(const aurl: string): string; static;
      class procedure freeCache; static;
    
      function getPrefix: string;
      function getURL: string;
      function serialize: string;
      function getSelf: TNamespace;
      function equal(const ns: string): boolean;
      destructor Destroy; override;
    end;
    
    { TNamespaceList }
    
    //** List of namespaces
    TNamespaceList = class(specialize TFastInterfaceList<INamespace>)
    private
      function getNamespace(const prefix: string): INamespace;
      function getNamespace(i: integer): INamespace;
    public
      function hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
      function hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
      function hasNamespacePrefix(const prefix: string): boolean;
      function hasNamespace(const n: INamespace): boolean;
    
      function lastIndexOfNamespacePrefix(const prefix: string): integer;
    
      procedure add(const ns: TNamespace);
      procedure add(const ns: INamespace);
      procedure addIfNewPrefix(const ns: TNamespace);
      procedure addIfNewPrefix(const ns: INamespace);
      procedure addIfNewPrefixUrl(const ns: TNamespace);
      procedure addIfNewPrefixUrl(const ns: INamespace);
    
      procedure deleteFrom(i: integer);
    
      function clone: TNamespaceList;
    
      property namespaces[prefix: string]: INamespace read getNamespace;
      property items[i: integer]: INamespace read getNamespace;
    end;
    
    const XMLNamespaceUrl_XML = 'http://www.w3.org/XML/1998/namespace';
          XMLNamespaceUrl_XMLNS = 'http://www.w3.org/2000/xmlns/';
    
    var
       XMLNamespace_XMLNS, XMLNamespace_XML: INamespace;
    
    function equalNamespaces(const ans, bns: INamespace): boolean; inline;
    function equalNamespaces(const ans, bns: string): boolean; inline;
    function namespaceGetURL(const n: INamespace): string; inline;
    
    
    implementation
    
    uses bbutils;
    
    
    
    function equalNamespaces(const ans, bns: INamespace): boolean;
    begin
      result := (ans = bns) or ((ans <> nil) and (bns <> nil) and strEqual(ans.getURL, bns.getURL));
    end;
    
    function equalNamespaces(const ans, bns: string): boolean;
    begin
      result := strEqual(ans, bns);
    end;
    
    function namespaceGetURL(const n: INamespace): string;
    begin
      if n = nil then result := ''
      else result := n.getURL;
    end;
    
    
    
    function TNamespaceList.getNamespace(const prefix: string): INamespace;
    begin
      hasNamespacePrefix(prefix, result);
    end;
    
    function TNamespaceList.getNamespace(i: integer): INamespace;
    begin
      result := INamespace(pointer(inherited get(i)));
    end;
    
    function TNamespaceList.hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
    var
      i: Integer;
    begin
      for i := c - 1 downto 0 do
        if (Items[i]).getPrefix = prefix then exit(true);
      exit(false);
    end;
    
    function TNamespaceList.hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
    var
      i: Integer;
    begin
      for i := Count - 1 downto 0 do
        if (Items[i]).getPrefix = prefix then begin
          ns := items[i];
          exit(true);
        end;
      ns := nil;
      exit(false);
    end;
    
    function TNamespaceList.hasNamespacePrefix(const prefix: string): boolean;
    var temp: INamespace;
    begin
      result := hasNamespacePrefix(prefix, temp);
    end;
    
    function TNamespaceList.hasNamespace(const n: INamespace): boolean;
    var
      temp: INamespace;
    begin
      if not hasNamespacePrefix(n.getPrefix, temp) then exit(false);
      if temp.getURL <> n.getURL then exit(false);
      result := true;
    end;
    
    function TNamespaceList.lastIndexOfNamespacePrefix(const prefix: string): integer;
    var
      i: Integer;
    begin
      for i := Count - 1 downto 0 do
        if (Items[i]).getPrefix = prefix then
          exit(i);
      exit(-1);
    end;
    
    procedure TNamespaceList.add(const ns: TNamespace);
    begin
      inherited add(INamespace(ns)); //hide ancestor method to prevent crash when tnamespace is treated as inamespace instead being cast
    end;
    
    procedure TNamespaceList.add(const ns: INamespace);
    begin
      inherited add(ns);
    end;
    
    procedure TNamespaceList.addIfNewPrefix(const ns: TNamespace);
    begin
      addIfNewPrefix(INamespace(ns));
    end;
    
    procedure TNamespaceList.addIfNewPrefix(const ns: INamespace);
    var
      temp: INamespace;
    begin
      if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
      if not hasNamespacePrefix(ns.getPrefix, temp) then
        add(ns);
    end;
    
    procedure TNamespaceList.addIfNewPrefixUrl(const ns: TNamespace);
    begin
      addIfNewPrefixUrl(INamespace(ns));
    end;
    
    procedure TNamespaceList.addIfNewPrefixUrl(const ns: INamespace);
    var
      temp: INamespace;
    begin
      if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
      if not hasNamespacePrefix(ns.getPrefix, temp) then
        add(ns)
      else if temp.getURL <> ns.getURL then
        add(ns);
    end;
    
    procedure TNamespaceList.deleteFrom(i: integer);
    begin
      if i < 0 then i := 0;
      while count > i do
        delete(count - 1);
    end;
    
    
    function TNamespaceList.clone: TNamespaceList;
    var
      i: Integer;
    begin
      result := TNamespaceList.Create;
      for i := 0 to count - 1 do
        result.Add(items[i]);
    end;
    
    type
    TXQHashmapStrOwningNamespace = specialize TXQHashmapStrOwning<INamespace, TNamespaceList>;
    TNamespaceCache = class
      uniqueUrl: string;
      prefixes: TXQHashmapStrOwningNamespace;
      constructor Create;
      destructor Destroy; override;
    end;
    
    constructor TNamespaceCache.Create;
    begin
      prefixes := TXQHashmapStrOwningNamespace.Create;
    end;
    
    destructor TNamespaceCache.Destroy;
    begin
      prefixes.free;
      inherited Destroy;
    end;
    
    threadvar globalNamespaceCache: TXQHashmapStrOwningObject;
    
    function TNamespace.getSelf: TNamespace;
    begin
      result := self;
    end;
    
    function TNamespace.equal(const ns: string): boolean;
    begin
      result := strEqual(url, ns);
    end;
    
    constructor TNamespace.create(const aurl: string; aprefix: string);
    begin
      url := aurl;
      prefix := aprefix;
    end;
    
    function namespaceCache(const aurl: string): TNamespaceCache;
    begin
      if globalNamespaceCache = nil then globalNamespaceCache := TXQHashmapStrOwningObject.Create();
      result := TNamespaceCache(globalNamespaceCache[aurl]);
      if result = nil then begin
        result := TNamespaceCache.Create;
        result.uniqueUrl := aurl;
        globalNamespaceCache.Add(aurl, result);
        //writeln(strFromPtr(pointer(aurl)), ' ',aurl);
      end;
    end;
    
    {$ImplicitExceptions off}
    class function TNamespace.make(const aurl: string; const aprefix: string): TNamespace;
    var cache : TNamespaceCache;
      old: INamespace;
    begin
      cache := namespaceCache(aurl);
      old := cache.prefixes[aprefix];
      if old = nil then begin
        result := TNamespace.create(cache.uniqueUrl, aprefix);
        cache.prefixes.Add(aprefix, result);
      end else result := old.getSelf;
    end;
    {$ImplicitExceptions on}
    
    class function TNamespace.uniqueUrl(const aurl: string): string;
    begin
      result := namespaceCache(aurl).uniqueUrl;
    end;
    
    class procedure TNamespace.freeCache;
    begin
      FreeAndNil(globalNamespaceCache);
    end;
    
    function TNamespace.getPrefix: string;
    begin
      if self = nil then exit('');
      result := prefix;
    end;
    
    function TNamespace.getURL: string;
    begin
      if self = nil then exit('');
      result := url;
    end;
    
    function TNamespace.serialize: string;
    begin
      if prefix = '' then result := 'xmlns="'+xmlStrEscape(url, true)+'"'
      else result := 'xmlns:'+prefix+'="'+xmlStrEscape(url, true)+'"'
    end;
    
    destructor TNamespace.Destroy;
    begin
      inherited Destroy;
    end;
    
    initialization
      XMLNamespace_XML := TNamespace.Make(XMLNamespaceUrl_XML, 'xml');
      XMLNamespace_XMLNS := TNamespace.Make(XMLNamespaceUrl_XMLNS, 'xmlns');
    
    end.
    
    
    xquery.namespaces.pas (9,178 bytes)
  • xquery.internals.common.pas (14,185 bytes)
    unit xquery.internals.common;
    
    {
    Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                              benito@benibela.de
                              www.benibela.de
    
    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.
    
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
    
    }
    
    {$I ../internettoolsconfig.inc}
    
    interface
    
    uses
      classes, contnrs, SysUtils, {$ifdef USE_FLRE}FLRE{$else}ghashmap{$endif}, bbutils;
    
    type
    
      TXQHashKeyString = {$ifdef USE_FLRE}TFLRERawByteString{$else}RawByteString{$endif};
    {$ifndef USE_FLRE}TXQHash = record
      class function hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt; static;
    end;{$endif}
    generic TXQHashmapStr<TValue> = class({$ifdef USE_FLRE}TFLRECacheHashMap{$else}specialize THashmap<TXQHashKeyString, TValue, TXQHash>{$endif})
    protected
      function GetValue(const Key: TXQHashKeyString): TValue; inline;
      procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
    public
      procedure Add(const Key:TXQHashKeyString; const AValue:TValue); inline;
      property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
    end;
    generic TXQHashmapStrOwning<TValue, TOwningList> = class(specialize TXQHashmapStr<TValue>)
    protected
      owner: TOwningList;
      procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
    public
      constructor create;
      destructor destroy; override;
      procedure Add(const Key:TXQHashKeyString; const Value:TValue); inline;
      property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
    end;
    generic TXQHashmapStrOwningGenericObject<TValue> = class(specialize TXQHashmapStrOwning<TValue, TObjectList>);
    TXQHashmapStrOwningObject = specialize TXQHashmapStrOwningGenericObject<TObject>;
    
    //**a list to store interfaces, similar to TInterfaceList, but faster, because
    //**  (1) it assumes all added interfaces are non nil
    //**  (2) it is not thread safe
    //**  (3) it is generic, so you need no casting
    generic TFastInterfaceList<IT> = class
      type PIT = ^IT;
    protected
      fcount, fcapacity: integer; // count
      fbuffer: PIT; // Backend storage
      procedure raiseInvalidIndexError(i: integer);  //**< Raise an exception
      procedure checkIndex(i: integer); inline; //**< Range check
      procedure reserve(cap: integer); //**< Allocates new memory if necessary
      procedure compress; //**< Deallocates memory by shorting list if necessary
      procedure setCount(c: integer); //**< Forces a count (elements are initialized with )
      procedure setBufferSize(c: integer);
      procedure insert(i: integer; child: IT);
      procedure put(i: integer; const AValue: IT); inline; //**< Replace the IT at position i
    public
      constructor create(capacity: integer = 0);
      destructor Destroy; override;
      procedure delete(i: integer); //**< Deletes a value (since it is an interface, the value is freed iff there are no other references to it remaining)
      procedure remove(const value: IT);
      procedure add(const value: IT);
      procedure addAll(other: TFastInterfaceList);
      function get(i: integer): IT; inline; //**< Gets an interface from the list.
      function last: IT; //**< Last interface in the list.
      function first: IT; //**< First interface in the list.
      procedure clear;
      property items[i: integer]: IT read get write put; default;
      property Count: integer read fcount write setCount;
    end;
    
    type TXHTMLStrBuilder = object(TStrBuilder)
      procedure appendHTMLText(inbuffer: pchar; len: SizeInt);
      procedure appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
      procedure appendHTMLText(const s: string);
      procedure appendHTMLAttrib(const s: string);
    end;
    
    function xmlStrEscape(s: string; attrib: boolean = false):string;
    function xmlStrWhitespaceCollapse(const s: string):string;
    function htmlStrEscape(s: string; attrib: boolean = false):string;
    function strSplitOnAsciiWS(s: string): TStringArray;
    function urlHexDecode(s: string): string;
    
    
    function nodeNameHash(const s: RawByteString): cardinal;
    function nodeNameHashCheckASCII(const s: RawByteString): cardinal;
    
    
    
    type  TRaiseXQEvaluationExceptionCallback = procedure (const code, message: string);
    
    var raiseXQEvaluationExceptionCallback: TRaiseXQEvaluationExceptionCallback = nil;
    
    procedure raiseXQEvaluationException(const code, message: string); overload; noreturn;
    
    type xqfloat = double;
    function xqround(const f: xqfloat): Int64;
    
    implementation
    
    function xqround(const f: xqfloat): Int64;
    var tempf: xqfloat;
    begin
      tempf := f + 0.5;
      result := trunc(tempf);
      if frac(tempf) < 0 then result -= 1;
    end;
    
    
    function TXQHashmapStr.GetValue(const Key: TXQHashKeyString): TValue;
    begin
      {$ifdef USE_FLRE}
      result := TValue(pointer(inherited GetValue(key)));
      {$else}
      if not inherited GetValue(key, result) then result := default(TValue);
      {$endif}
    end;
    
    procedure TXQHashmapStr.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
    begin
      {$ifdef USE_FLRE}
      inherited SetValue(key, TFLRECacheHashMapData(pointer(AValue)) );
      {$else}
      insert(key, AValue);
      {$endif}
    end;
    
    procedure TXQHashmapStr.Add(const Key: TXQHashKeyString; const AValue: TValue);
    begin
      {$ifdef USE_FLRE}
      inherited Add(key, TFLRECacheHashMapData(pointer(AValue)));
      {$else}
      insert(key, AValue);
      {$endif}
    end;
    
    procedure TXQHashmapStrOwning.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
    var
      old: TValue;
    begin
      old := GetValue(key);
      if old = AValue then exit;
      if old <> nil then owner.remove(old);
      add(key, Avalue);
    end;
    
    constructor TXQHashmapStrOwning.create;
    begin
      inherited;
      owner := TOwningList.create;
    end;
    
    destructor TXQHashmapStrOwning.destroy;
    begin
      owner.free;
      inherited destroy;
    end;
    
    procedure TXQHashmapStrOwning.Add(const Key: TXQHashKeyString; const Value: TValue);
    begin
      owner.add(value);
      inherited add(key, value);
    end;
    
    
    function xmlStrEscape(s: string; attrib: boolean = false):string;
    var
      i: Integer;
      builder: TStrBuilder;
    
    begin
      builder.init(@result, length(s));
      i := 1;
      while i <= length(s) do begin
        case s[i] of
          '<': builder.append('&lt;');
          '>': builder.append('&gt;');
          '&': builder.append('&amp;');
          '''': builder.append('&apos;');
          '"': builder.append('&quot;');
          #13: builder.append('&#xD;');
          #10: if attrib then builder.append('&#xA;') else builder.append(#10);
          #9: if attrib then builder.append('&#x9;') else builder.append(#9);
          #0..#8,#11,#12,#14..#$1F,#$7F: builder.appendhexentity(ord(s[i]));
          #$C2: if (i = length(s)) or not (s[i+1] in [#$80..#$9F]) then builder.append(#$C2) else begin
            i+=1;
            builder.appendhexentity(ord(s[i]));
          end;
          #$E2: if (i + 2 > length(s)) or (s[i+1] <> #$80) or (s[i+2] <> #$A8) then builder.append(#$E2) else begin
            builder.append('&#x2028;');
            i+=2;
          end;
          else builder.append(s[i]);
        end;
        i+=1;
      end;
      builder.final;
    end;
    
    function xmlStrWhitespaceCollapse(const s: string): string;
    begin
      result := strTrimAndNormalize(s, [#9,#$A,#$D,' ']);
    end;
    
    procedure TXHTMLStrBuilder.appendHTMLText(inbuffer: pchar; len: SizeInt);
    var
      inbufferend: pchar;
    begin
      inbufferend := inbuffer + len;
      reserveadd(len);
      while inbuffer < inbufferend do begin
        case inbuffer^ of
          '&': append('&amp;');
          '<': append('&lt;');
          '>': append('&gt;');
          else append(inbuffer^);
        end;
        inc(inbuffer);
      end;
    end;
    
    
    procedure TXHTMLStrBuilder.appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
    var
      inbufferend: pchar;
    begin
      inbufferend := inbuffer + len;
      reserveadd(len);
      while inbuffer < inbufferend do begin
        case inbuffer^ of
          '&': append('&amp;');
          '"': append('&quot;');
          '''': append('&apos;');
          else append(inbuffer^);
        end;
        inc(inbuffer);
      end;
    end;
    
    procedure TXHTMLStrBuilder.appendHTMLText(const s: string);
    begin
      appendHTMLText(pchar(pointer(s)), length(s));
    end;
    procedure TXHTMLStrBuilder.appendHTMLAttrib(const s: string);
    begin
      appendHTMLAttrib(pchar(pointer(s)), length(s));
    end;
    
    function htmlStrEscape(s: string; attrib: boolean): string;
    var
      i: Integer;
      builder: TXHTMLStrBuilder;
    
    begin
      builder.init(@result, length(s));
      if attrib then builder.appendHTMLAttrib(s)
      else builder.appendHTMLText(s);
      builder.final;
    end;
    
    function strSplitOnAsciiWS(s: string): TStringArray;
    begin
      result := strSplit(strTrimAndNormalize(s, [#9,#$A,#$C,#$D,' ']), ' ');
    end;
    
    function urlHexDecode(s: string): string;
    var
      p: Integer;
      i: Integer;
    begin
      SetLength(result, length(s));
      p := 1;
      i := 1;
      while i <= length(s) do begin
        case s[i] of
          '+': result[p] := ' ';
          '%': if (i + 2 <= length(s)) and (s[i+1] in ['a'..'f','A'..'F','0'..'9']) and (s[i+2] in ['a'..'f','A'..'F','0'..'9']) then begin
            result[p] := chr(StrToInt('$'+s[i+1]+s[i+2])); //todo: optimize
            i+=2;
          end else raiseXQEvaluationException('pxp:uri', 'Invalid input string at: '+copy(s,i,10))
          else result[p] := s[i];
        end;
        i+=1;
        p+=1;
      end;
      setlength(result, p-1);
    end;
    
    
    
    
    
    
    
    
    {$PUSH}{$RangeChecks off}{$OverflowChecks off}
    function nodeNameHash(const s: RawByteString): cardinal;
    var
      p, last: PByte;
    begin
      if s = '' then exit(1);
      p := pbyte(pointer(s));
      last := p + length(s);
      result := 0;
      while p < last do begin
        if p^ < 128  then begin //give the same hash independent of latin1/utf8 encoding and collation
          result := result + p^;
          if (p^ >= ord('a')) and (p^ <= ord('z')) then result := result - ord('a') + ord('A');
          result := result + (result shl 10);
          result := result xor (result shr 6);
        end;
        inc(p);
      end;
    
      result := result + (result shl 3);
      result := result xor (result shr 11);
      result := result + (result shl 15);
      //remember to update HTMLNodeNameHashs when changing anything here;
    end;
    function nodeNameHashCheckASCII(const s: RawByteString): cardinal;
    var
      i: Integer;
    begin
      for i := 1 to length(s) do if s[i] >= #128 then exit(0);
      result := nodeNameHash(s);
    end;
    {$ifndef USE_FLRE}
    class function TXQHash.hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt;
    begin
      result := nodeNameHash(a) and (n-1);
    end;
    {$endif}
    
    {$POP}
    
    
    procedure raiseXQEvaluationException(const code, message: string); noreturn;
    begin
      if Assigned(raiseXQEvaluationExceptionCallback) then raiseXQEvaluationExceptionCallback(code, message)
      else raise exception.Create(code + ': ' + message);
    end;
    
    
    
    
    
    
    procedure TFastInterfaceList.raiseInvalidIndexError(i: integer);
    begin
      raiseXQEvaluationException('pxp:INTERNAL', 'Invalid index: '+IntToStr(i));
    end;
    
    procedure TFastInterfaceList.checkIndex(i: integer);
    begin
      if (i < 0) or (i >= fcount) then raiseInvalidIndexError(i);
    end;
    
    
    procedure TFastInterfaceList.put(i: integer; const AValue: IT); inline;
    begin
      checkIndex(i);
      fbuffer[i] := AValue;
    end;
    
    procedure TFastInterfaceList.delete(i: integer);
    begin
      checkIndex(i);
      fbuffer[i] := nil;
      if i <> fcount - 1 then begin
        move(fbuffer[i+1], fbuffer[i], (fcount - i - 1) * sizeof(IT));
        FillChar(fbuffer[fcount-1], sizeof(fbuffer[fcount-1]), 0);
      end;
      fcount -= 1;
      compress;
    end;
    
    procedure TFastInterfaceList.remove(const value: IT);
    var
      i: Integer;
    begin
      for i := fcount - 1 downto 0 do
        if fbuffer[i] = value then
          delete(i);
    end;
    
    procedure TFastInterfaceList.add(const value: IT);
    begin
      if fcount = fcapacity then
        reserve(fcount + 1);
      PPointer(fbuffer)[fcount] := value;
      value._AddRef;
      fcount += 1;
    end;
    
    procedure TFastInterfaceList.addAll(other: TFastInterfaceList);
    var
      i: Integer;
    begin
      reserve(fcount + other.Count);
      for i := 0 to other.Count - 1 do
        add(other.fbuffer[i]);
    end;
    
    function TFastInterfaceList.get(i: integer): IT;
    begin
      checkIndex(i);
      result := fbuffer[i];
    end;
    
    function TFastInterfaceList.last: IT;
    begin
      checkIndex(0);
      result := fbuffer[fcount-1];
    end;
    
    function TFastInterfaceList.first: IT;
    begin
      checkIndex(0);
      result := fbuffer[0];
    end;
    
    
    
    
    {$ImplicitExceptions off}
    
    procedure TFastInterfaceList.setBufferSize(c: integer);
    begin
      ReAllocMem(fbuffer, c * sizeof(IT));
      fcapacity := c;
    end;
    
    procedure TFastInterfaceList.reserve(cap: integer);
    var
      oldcap: Integer;
    begin
      if cap <= fcapacity then exit;
    
      oldcap := fcapacity;
      if cap < 4 then setBufferSize(4)
      else if (cap < 1024) and (cap <= fcapacity * 2) then setBufferSize(fcapacity * 2)
      else if (cap < 1024) then setBufferSize(cap)
      else if cap <= fcapacity + 1024 then setBufferSize(fcapacity + 1024)
      else setBufferSize(cap);
    
      FillChar(fbuffer[oldcap], sizeof(IT) * (fcapacity - oldcap), 0);
    end;
    
    procedure TFastInterfaceList.compress;
    begin
      if fcount <= fcapacity div 2 then setBufferSize(fcapacity div 2)
      else if fcount <= fcapacity - 1024 then setBufferSize(fcapacity - 1024);
    end;
    
    procedure TFastInterfaceList.setCount(c: integer);
    var
      i: Integer;
    begin
      reserve(c);
      if c < fcount then begin
        for i := c to fcount - 1 do
          fbuffer[i]._Release;
        FillChar(fbuffer[c], (fcount - c) * sizeof(IT), 0);
      end;
      fcount:=c;
    end;
    
    
    
    
    {$ImplicitExceptions on}
    
    procedure TFastInterfaceList.clear;
    var
      i: Integer;
    begin
      for i := 0 to fcount - 1 do
        fbuffer[i]._Release;
      fcount:=0;
      setBufferSize(0);
    end;
    
    destructor TFastInterfaceList.Destroy;
    begin
      clear;
      inherited Destroy;
    end;
    
    procedure TFastInterfaceList.insert(i: integer; child: IT);
    begin
      reserve(fcount + 1);
      if i <> fcount then begin
        checkIndex(i);
        move(fbuffer[i], fbuffer[i+1], (fcount - i) * sizeof(fbuffer[i]));
        fillchar(fbuffer[i],sizeof(fbuffer[i]),0);
      end;
      fbuffer[i] := child;
      fcount+=1;
    end;
    
    constructor TFastInterfaceList.create(capacity: integer);
    begin
      reserve(capacity);
      fcount := 0;
    end;
    
    
    
    end.
    
    

Activities

Benito van der Zander

2019-05-21 12:27

reporter  

xquery.namespaces.o (143,040 bytes)
xquery.namespaces.ppu (56,354 bytes)
xquery.namespaces-2.o (142,616 bytes)
xquery.namespaces-2.ppu (56,385 bytes)
xquery.namespaces.pas (9,178 bytes)
unit xquery.namespaces;
{
Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                          benito@benibela.de
                          www.benibela.de

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

}

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, xquery.internals.common;

type

TNamespace = class;

//** Namespace interface, storing url and prefix. (Interface, so it is ref-counted)
INamespace = interface
['{5F6DF5F2-548C-4F13-9BEA-CE59EBAE4CAB}']
  function getPrefix: string; //**< Returns the prefix
  function getURL: string; //**< Returns the url
  function serialize: string; //**< Returns an xmlns attribute declaring this namespace with url and prefix
  function getSelf: TNamespace;
  function equal(const ns: string): boolean;
end;


{ TNamespace }

//** Class implementing the INamespace interface
TNamespace = class(TInterfacedObject, INamespace)
public
  url: string;
  prefix: string;
  //** Creates a new namespace with url and prefix. (watch the argument order. It follows the XPath fn:QName function)
  constructor create(const aurl: string; aprefix: string);

  class function make(const aurl: string; const aprefix: string): TNamespace; static;
  class function uniqueUrl(const aurl: string): string; static;
  class procedure freeCache; static;

  function getPrefix: string;
  function getURL: string;
  function serialize: string;
  function getSelf: TNamespace;
  function equal(const ns: string): boolean;
  destructor Destroy; override;
end;

{ TNamespaceList }

//** List of namespaces
TNamespaceList = class(specialize TFastInterfaceList<INamespace>)
private
  function getNamespace(const prefix: string): INamespace;
  function getNamespace(i: integer): INamespace;
public
  function hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
  function hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
  function hasNamespacePrefix(const prefix: string): boolean;
  function hasNamespace(const n: INamespace): boolean;

  function lastIndexOfNamespacePrefix(const prefix: string): integer;

  procedure add(const ns: TNamespace);
  procedure add(const ns: INamespace);
  procedure addIfNewPrefix(const ns: TNamespace);
  procedure addIfNewPrefix(const ns: INamespace);
  procedure addIfNewPrefixUrl(const ns: TNamespace);
  procedure addIfNewPrefixUrl(const ns: INamespace);

  procedure deleteFrom(i: integer);

  function clone: TNamespaceList;

  property namespaces[prefix: string]: INamespace read getNamespace;
  property items[i: integer]: INamespace read getNamespace;
end;

const XMLNamespaceUrl_XML = 'http://www.w3.org/XML/1998/namespace';
      XMLNamespaceUrl_XMLNS = 'http://www.w3.org/2000/xmlns/';

var
   XMLNamespace_XMLNS, XMLNamespace_XML: INamespace;

function equalNamespaces(const ans, bns: INamespace): boolean; inline;
function equalNamespaces(const ans, bns: string): boolean; inline;
function namespaceGetURL(const n: INamespace): string; inline;


implementation

uses bbutils;



function equalNamespaces(const ans, bns: INamespace): boolean;
begin
  result := (ans = bns) or ((ans <> nil) and (bns <> nil) and strEqual(ans.getURL, bns.getURL));
end;

function equalNamespaces(const ans, bns: string): boolean;
begin
  result := strEqual(ans, bns);
end;

function namespaceGetURL(const n: INamespace): string;
begin
  if n = nil then result := ''
  else result := n.getURL;
end;



function TNamespaceList.getNamespace(const prefix: string): INamespace;
begin
  hasNamespacePrefix(prefix, result);
end;

function TNamespaceList.getNamespace(i: integer): INamespace;
begin
  result := INamespace(pointer(inherited get(i)));
end;

function TNamespaceList.hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
var
  i: Integer;
begin
  for i := c - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then exit(true);
  exit(false);
end;

function TNamespaceList.hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then begin
      ns := items[i];
      exit(true);
    end;
  ns := nil;
  exit(false);
end;

function TNamespaceList.hasNamespacePrefix(const prefix: string): boolean;
var temp: INamespace;
begin
  result := hasNamespacePrefix(prefix, temp);
end;

function TNamespaceList.hasNamespace(const n: INamespace): boolean;
var
  temp: INamespace;
begin
  if not hasNamespacePrefix(n.getPrefix, temp) then exit(false);
  if temp.getURL <> n.getURL then exit(false);
  result := true;
end;

function TNamespaceList.lastIndexOfNamespacePrefix(const prefix: string): integer;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then
      exit(i);
  exit(-1);
end;

procedure TNamespaceList.add(const ns: TNamespace);
begin
  inherited add(INamespace(ns)); //hide ancestor method to prevent crash when tnamespace is treated as inamespace instead being cast
end;

procedure TNamespaceList.add(const ns: INamespace);
begin
  inherited add(ns);
end;

procedure TNamespaceList.addIfNewPrefix(const ns: TNamespace);
begin
  addIfNewPrefix(INamespace(ns));
end;

procedure TNamespaceList.addIfNewPrefix(const ns: INamespace);
var
  temp: INamespace;
begin
  if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
  if not hasNamespacePrefix(ns.getPrefix, temp) then
    add(ns);
end;

procedure TNamespaceList.addIfNewPrefixUrl(const ns: TNamespace);
begin
  addIfNewPrefixUrl(INamespace(ns));
end;

procedure TNamespaceList.addIfNewPrefixUrl(const ns: INamespace);
var
  temp: INamespace;
begin
  if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
  if not hasNamespacePrefix(ns.getPrefix, temp) then
    add(ns)
  else if temp.getURL <> ns.getURL then
    add(ns);
end;

procedure TNamespaceList.deleteFrom(i: integer);
begin
  if i < 0 then i := 0;
  while count > i do
    delete(count - 1);
end;


function TNamespaceList.clone: TNamespaceList;
var
  i: Integer;
begin
  result := TNamespaceList.Create;
  for i := 0 to count - 1 do
    result.Add(items[i]);
end;

type
TXQHashmapStrOwningNamespace = specialize TXQHashmapStrOwning<INamespace, TNamespaceList>;
TNamespaceCache = class
  uniqueUrl: string;
  prefixes: TXQHashmapStrOwningNamespace;
  constructor Create;
  destructor Destroy; override;
end;

constructor TNamespaceCache.Create;
begin
  prefixes := TXQHashmapStrOwningNamespace.Create;
end;

destructor TNamespaceCache.Destroy;
begin
  prefixes.free;
  inherited Destroy;
end;

threadvar globalNamespaceCache: TXQHashmapStrOwningObject;

function TNamespace.getSelf: TNamespace;
begin
  result := self;
end;

function TNamespace.equal(const ns: string): boolean;
begin
  result := strEqual(url, ns);
end;

constructor TNamespace.create(const aurl: string; aprefix: string);
begin
  url := aurl;
  prefix := aprefix;
end;

function namespaceCache(const aurl: string): TNamespaceCache;
begin
  if globalNamespaceCache = nil then globalNamespaceCache := TXQHashmapStrOwningObject.Create();
  result := TNamespaceCache(globalNamespaceCache[aurl]);
  if result = nil then begin
    result := TNamespaceCache.Create;
    result.uniqueUrl := aurl;
    globalNamespaceCache.Add(aurl, result);
    //writeln(strFromPtr(pointer(aurl)), ' ',aurl);
  end;
end;

{$ImplicitExceptions off}
class function TNamespace.make(const aurl: string; const aprefix: string): TNamespace;
var cache : TNamespaceCache;
  old: INamespace;
begin
  cache := namespaceCache(aurl);
  old := cache.prefixes[aprefix];
  if old = nil then begin
    result := TNamespace.create(cache.uniqueUrl, aprefix);
    cache.prefixes.Add(aprefix, result);
  end else result := old.getSelf;
end;
{$ImplicitExceptions on}

class function TNamespace.uniqueUrl(const aurl: string): string;
begin
  result := namespaceCache(aurl).uniqueUrl;
end;

class procedure TNamespace.freeCache;
begin
  FreeAndNil(globalNamespaceCache);
end;

function TNamespace.getPrefix: string;
begin
  if self = nil then exit('');
  result := prefix;
end;

function TNamespace.getURL: string;
begin
  if self = nil then exit('');
  result := url;
end;

function TNamespace.serialize: string;
begin
  if prefix = '' then result := 'xmlns="'+xmlStrEscape(url, true)+'"'
  else result := 'xmlns:'+prefix+'="'+xmlStrEscape(url, true)+'"'
end;

destructor TNamespace.Destroy;
begin
  inherited Destroy;
end;

initialization
  XMLNamespace_XML := TNamespace.Make(XMLNamespaceUrl_XML, 'xml');
  XMLNamespace_XMLNS := TNamespace.Make(XMLNamespaceUrl_XMLNS, 'xmlns');

end.

xquery.namespaces.pas (9,178 bytes)
xquery.internals.common.pas (14,185 bytes)
unit xquery.internals.common;

{
Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                          benito@benibela.de
                          www.benibela.de

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

}

{$I ../internettoolsconfig.inc}

interface

uses
  classes, contnrs, SysUtils, {$ifdef USE_FLRE}FLRE{$else}ghashmap{$endif}, bbutils;

type

  TXQHashKeyString = {$ifdef USE_FLRE}TFLRERawByteString{$else}RawByteString{$endif};
{$ifndef USE_FLRE}TXQHash = record
  class function hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt; static;
end;{$endif}
generic TXQHashmapStr<TValue> = class({$ifdef USE_FLRE}TFLRECacheHashMap{$else}specialize THashmap<TXQHashKeyString, TValue, TXQHash>{$endif})
protected
  function GetValue(const Key: TXQHashKeyString): TValue; inline;
  procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
public
  procedure Add(const Key:TXQHashKeyString; const AValue:TValue); inline;
  property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
end;
generic TXQHashmapStrOwning<TValue, TOwningList> = class(specialize TXQHashmapStr<TValue>)
protected
  owner: TOwningList;
  procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
public
  constructor create;
  destructor destroy; override;
  procedure Add(const Key:TXQHashKeyString; const Value:TValue); inline;
  property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
end;
generic TXQHashmapStrOwningGenericObject<TValue> = class(specialize TXQHashmapStrOwning<TValue, TObjectList>);
TXQHashmapStrOwningObject = specialize TXQHashmapStrOwningGenericObject<TObject>;

//**a list to store interfaces, similar to TInterfaceList, but faster, because
//**  (1) it assumes all added interfaces are non nil
//**  (2) it is not thread safe
//**  (3) it is generic, so you need no casting
generic TFastInterfaceList<IT> = class
  type PIT = ^IT;
protected
  fcount, fcapacity: integer; // count
  fbuffer: PIT; // Backend storage
  procedure raiseInvalidIndexError(i: integer);  //**< Raise an exception
  procedure checkIndex(i: integer); inline; //**< Range check
  procedure reserve(cap: integer); //**< Allocates new memory if necessary
  procedure compress; //**< Deallocates memory by shorting list if necessary
  procedure setCount(c: integer); //**< Forces a count (elements are initialized with )
  procedure setBufferSize(c: integer);
  procedure insert(i: integer; child: IT);
  procedure put(i: integer; const AValue: IT); inline; //**< Replace the IT at position i
public
  constructor create(capacity: integer = 0);
  destructor Destroy; override;
  procedure delete(i: integer); //**< Deletes a value (since it is an interface, the value is freed iff there are no other references to it remaining)
  procedure remove(const value: IT);
  procedure add(const value: IT);
  procedure addAll(other: TFastInterfaceList);
  function get(i: integer): IT; inline; //**< Gets an interface from the list.
  function last: IT; //**< Last interface in the list.
  function first: IT; //**< First interface in the list.
  procedure clear;
  property items[i: integer]: IT read get write put; default;
  property Count: integer read fcount write setCount;
end;

type TXHTMLStrBuilder = object(TStrBuilder)
  procedure appendHTMLText(inbuffer: pchar; len: SizeInt);
  procedure appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
  procedure appendHTMLText(const s: string);
  procedure appendHTMLAttrib(const s: string);
end;

function xmlStrEscape(s: string; attrib: boolean = false):string;
function xmlStrWhitespaceCollapse(const s: string):string;
function htmlStrEscape(s: string; attrib: boolean = false):string;
function strSplitOnAsciiWS(s: string): TStringArray;
function urlHexDecode(s: string): string;


function nodeNameHash(const s: RawByteString): cardinal;
function nodeNameHashCheckASCII(const s: RawByteString): cardinal;



type  TRaiseXQEvaluationExceptionCallback = procedure (const code, message: string);

var raiseXQEvaluationExceptionCallback: TRaiseXQEvaluationExceptionCallback = nil;

procedure raiseXQEvaluationException(const code, message: string); overload; noreturn;

type xqfloat = double;
function xqround(const f: xqfloat): Int64;

implementation

function xqround(const f: xqfloat): Int64;
var tempf: xqfloat;
begin
  tempf := f + 0.5;
  result := trunc(tempf);
  if frac(tempf) < 0 then result -= 1;
end;


function TXQHashmapStr.GetValue(const Key: TXQHashKeyString): TValue;
begin
  {$ifdef USE_FLRE}
  result := TValue(pointer(inherited GetValue(key)));
  {$else}
  if not inherited GetValue(key, result) then result := default(TValue);
  {$endif}
end;

procedure TXQHashmapStr.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
begin
  {$ifdef USE_FLRE}
  inherited SetValue(key, TFLRECacheHashMapData(pointer(AValue)) );
  {$else}
  insert(key, AValue);
  {$endif}
end;

procedure TXQHashmapStr.Add(const Key: TXQHashKeyString; const AValue: TValue);
begin
  {$ifdef USE_FLRE}
  inherited Add(key, TFLRECacheHashMapData(pointer(AValue)));
  {$else}
  insert(key, AValue);
  {$endif}
end;

procedure TXQHashmapStrOwning.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
var
  old: TValue;
begin
  old := GetValue(key);
  if old = AValue then exit;
  if old <> nil then owner.remove(old);
  add(key, Avalue);
end;

constructor TXQHashmapStrOwning.create;
begin
  inherited;
  owner := TOwningList.create;
end;

destructor TXQHashmapStrOwning.destroy;
begin
  owner.free;
  inherited destroy;
end;

procedure TXQHashmapStrOwning.Add(const Key: TXQHashKeyString; const Value: TValue);
begin
  owner.add(value);
  inherited add(key, value);
end;


function xmlStrEscape(s: string; attrib: boolean = false):string;
var
  i: Integer;
  builder: TStrBuilder;

begin
  builder.init(@result, length(s));
  i := 1;
  while i <= length(s) do begin
    case s[i] of
      '<': builder.append('&lt;');
      '>': builder.append('&gt;');
      '&': builder.append('&amp;');
      '''': builder.append('&apos;');
      '"': builder.append('&quot;');
      #13: builder.append('&#xD;');
      #10: if attrib then builder.append('&#xA;') else builder.append(#10);
      #9: if attrib then builder.append('&#x9;') else builder.append(#9);
      #0..#8,#11,#12,#14..#$1F,#$7F: builder.appendhexentity(ord(s[i]));
      #$C2: if (i = length(s)) or not (s[i+1] in [#$80..#$9F]) then builder.append(#$C2) else begin
        i+=1;
        builder.appendhexentity(ord(s[i]));
      end;
      #$E2: if (i + 2 > length(s)) or (s[i+1] <> #$80) or (s[i+2] <> #$A8) then builder.append(#$E2) else begin
        builder.append('&#x2028;');
        i+=2;
      end;
      else builder.append(s[i]);
    end;
    i+=1;
  end;
  builder.final;
end;

function xmlStrWhitespaceCollapse(const s: string): string;
begin
  result := strTrimAndNormalize(s, [#9,#$A,#$D,' ']);
end;

procedure TXHTMLStrBuilder.appendHTMLText(inbuffer: pchar; len: SizeInt);
var
  inbufferend: pchar;
begin
  inbufferend := inbuffer + len;
  reserveadd(len);
  while inbuffer < inbufferend do begin
    case inbuffer^ of
      '&': append('&amp;');
      '<': append('&lt;');
      '>': append('&gt;');
      else append(inbuffer^);
    end;
    inc(inbuffer);
  end;
end;


procedure TXHTMLStrBuilder.appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
var
  inbufferend: pchar;
begin
  inbufferend := inbuffer + len;
  reserveadd(len);
  while inbuffer < inbufferend do begin
    case inbuffer^ of
      '&': append('&amp;');
      '"': append('&quot;');
      '''': append('&apos;');
      else append(inbuffer^);
    end;
    inc(inbuffer);
  end;
end;

procedure TXHTMLStrBuilder.appendHTMLText(const s: string);
begin
  appendHTMLText(pchar(pointer(s)), length(s));
end;
procedure TXHTMLStrBuilder.appendHTMLAttrib(const s: string);
begin
  appendHTMLAttrib(pchar(pointer(s)), length(s));
end;

function htmlStrEscape(s: string; attrib: boolean): string;
var
  i: Integer;
  builder: TXHTMLStrBuilder;

begin
  builder.init(@result, length(s));
  if attrib then builder.appendHTMLAttrib(s)
  else builder.appendHTMLText(s);
  builder.final;
end;

function strSplitOnAsciiWS(s: string): TStringArray;
begin
  result := strSplit(strTrimAndNormalize(s, [#9,#$A,#$C,#$D,' ']), ' ');
end;

function urlHexDecode(s: string): string;
var
  p: Integer;
  i: Integer;
begin
  SetLength(result, length(s));
  p := 1;
  i := 1;
  while i <= length(s) do begin
    case s[i] of
      '+': result[p] := ' ';
      '%': if (i + 2 <= length(s)) and (s[i+1] in ['a'..'f','A'..'F','0'..'9']) and (s[i+2] in ['a'..'f','A'..'F','0'..'9']) then begin
        result[p] := chr(StrToInt('$'+s[i+1]+s[i+2])); //todo: optimize
        i+=2;
      end else raiseXQEvaluationException('pxp:uri', 'Invalid input string at: '+copy(s,i,10))
      else result[p] := s[i];
    end;
    i+=1;
    p+=1;
  end;
  setlength(result, p-1);
end;








{$PUSH}{$RangeChecks off}{$OverflowChecks off}
function nodeNameHash(const s: RawByteString): cardinal;
var
  p, last: PByte;
begin
  if s = '' then exit(1);
  p := pbyte(pointer(s));
  last := p + length(s);
  result := 0;
  while p < last do begin
    if p^ < 128  then begin //give the same hash independent of latin1/utf8 encoding and collation
      result := result + p^;
      if (p^ >= ord('a')) and (p^ <= ord('z')) then result := result - ord('a') + ord('A');
      result := result + (result shl 10);
      result := result xor (result shr 6);
    end;
    inc(p);
  end;

  result := result + (result shl 3);
  result := result xor (result shr 11);
  result := result + (result shl 15);
  //remember to update HTMLNodeNameHashs when changing anything here;
end;
function nodeNameHashCheckASCII(const s: RawByteString): cardinal;
var
  i: Integer;
begin
  for i := 1 to length(s) do if s[i] >= #128 then exit(0);
  result := nodeNameHash(s);
end;
{$ifndef USE_FLRE}
class function TXQHash.hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt;
begin
  result := nodeNameHash(a) and (n-1);
end;
{$endif}

{$POP}


procedure raiseXQEvaluationException(const code, message: string); noreturn;
begin
  if Assigned(raiseXQEvaluationExceptionCallback) then raiseXQEvaluationExceptionCallback(code, message)
  else raise exception.Create(code + ': ' + message);
end;






procedure TFastInterfaceList.raiseInvalidIndexError(i: integer);
begin
  raiseXQEvaluationException('pxp:INTERNAL', 'Invalid index: '+IntToStr(i));
end;

procedure TFastInterfaceList.checkIndex(i: integer);
begin
  if (i < 0) or (i >= fcount) then raiseInvalidIndexError(i);
end;


procedure TFastInterfaceList.put(i: integer; const AValue: IT); inline;
begin
  checkIndex(i);
  fbuffer[i] := AValue;
end;

procedure TFastInterfaceList.delete(i: integer);
begin
  checkIndex(i);
  fbuffer[i] := nil;
  if i <> fcount - 1 then begin
    move(fbuffer[i+1], fbuffer[i], (fcount - i - 1) * sizeof(IT));
    FillChar(fbuffer[fcount-1], sizeof(fbuffer[fcount-1]), 0);
  end;
  fcount -= 1;
  compress;
end;

procedure TFastInterfaceList.remove(const value: IT);
var
  i: Integer;
begin
  for i := fcount - 1 downto 0 do
    if fbuffer[i] = value then
      delete(i);
end;

procedure TFastInterfaceList.add(const value: IT);
begin
  if fcount = fcapacity then
    reserve(fcount + 1);
  PPointer(fbuffer)[fcount] := value;
  value._AddRef;
  fcount += 1;
end;

procedure TFastInterfaceList.addAll(other: TFastInterfaceList);
var
  i: Integer;
begin
  reserve(fcount + other.Count);
  for i := 0 to other.Count - 1 do
    add(other.fbuffer[i]);
end;

function TFastInterfaceList.get(i: integer): IT;
begin
  checkIndex(i);
  result := fbuffer[i];
end;

function TFastInterfaceList.last: IT;
begin
  checkIndex(0);
  result := fbuffer[fcount-1];
end;

function TFastInterfaceList.first: IT;
begin
  checkIndex(0);
  result := fbuffer[0];
end;




{$ImplicitExceptions off}

procedure TFastInterfaceList.setBufferSize(c: integer);
begin
  ReAllocMem(fbuffer, c * sizeof(IT));
  fcapacity := c;
end;

procedure TFastInterfaceList.reserve(cap: integer);
var
  oldcap: Integer;
begin
  if cap <= fcapacity then exit;

  oldcap := fcapacity;
  if cap < 4 then setBufferSize(4)
  else if (cap < 1024) and (cap <= fcapacity * 2) then setBufferSize(fcapacity * 2)
  else if (cap < 1024) then setBufferSize(cap)
  else if cap <= fcapacity + 1024 then setBufferSize(fcapacity + 1024)
  else setBufferSize(cap);

  FillChar(fbuffer[oldcap], sizeof(IT) * (fcapacity - oldcap), 0);
end;

procedure TFastInterfaceList.compress;
begin
  if fcount <= fcapacity div 2 then setBufferSize(fcapacity div 2)
  else if fcount <= fcapacity - 1024 then setBufferSize(fcapacity - 1024);
end;

procedure TFastInterfaceList.setCount(c: integer);
var
  i: Integer;
begin
  reserve(c);
  if c < fcount then begin
    for i := c to fcount - 1 do
      fbuffer[i]._Release;
    FillChar(fbuffer[c], (fcount - c) * sizeof(IT), 0);
  end;
  fcount:=c;
end;




{$ImplicitExceptions on}

procedure TFastInterfaceList.clear;
var
  i: Integer;
begin
  for i := 0 to fcount - 1 do
    fbuffer[i]._Release;
  fcount:=0;
  setBufferSize(0);
end;

destructor TFastInterfaceList.Destroy;
begin
  clear;
  inherited Destroy;
end;

procedure TFastInterfaceList.insert(i: integer; child: IT);
begin
  reserve(fcount + 1);
  if i <> fcount then begin
    checkIndex(i);
    move(fbuffer[i], fbuffer[i+1], (fcount - i) * sizeof(fbuffer[i]));
    fillchar(fbuffer[i],sizeof(fbuffer[i]),0);
  end;
  fbuffer[i] := child;
  fcount+=1;
end;

constructor TFastInterfaceList.create(capacity: integer);
begin
  reserve(capacity);
  fcount := 0;
end;



end.

Benito van der Zander

2019-05-21 12:30

reporter   ~0116304

This is my 300th bug tracker report!

Issue History

Date Modified Username Field Change
2019-05-21 12:27 Benito van der Zander New Issue
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.o
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.ppu
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces-2.o
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces-2.ppu
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.pas
2019-05-21 12:27 Benito van der Zander File Added: xquery.internals.common.pas
2019-05-21 12:30 Benito van der Zander Note Added: 0116304