* Base units of the package now can be compiled also with Delphi, patch from Dariusz Mazur (with some modifications).

git-svn-id: trunk@13627 -

packages/fcl-xml/src/dom.pp

@@ -18,8 +18,8 @@
   This unit provides classes which implement the interfaces defined in the
   DOM (Document Object Model) specification.
   The current state is:
-  DOM Level 1  -  Almost completely implemented
-  DOM Level 2  -  Partially implemented
+  DOM Levels 1 and 2 -  Completely implemented
+  DOM Level 3  -  Partially implemented
 
   Specification used for this implementation:
 
@@ -99,9 +99,13 @@ type
   TDOMProcessingInstruction = class;
 
   TDOMAttrDef = class;
-  PNodePool = ^TNodePool;
   TNodePool = class;
+  PNodePoolArray = ^TNodePoolArray;
+  TNodePoolArray = array[0..0] of TNodePool;
 
+{$ifndef fpc}
+  TFPList = TList;
+{$endif}
 
 // -------------------------------------------------------
 //   DOMString
@@ -430,7 +434,7 @@ type
     FEmptyNode: TDOMElement;
     FNodeLists: THashTable;
     FMaxPoolSize: Integer;
-    FPools: PNodePool;
+    FPools: PNodePoolArray;
     FDocumentURI: DOMString;
     function GetDocumentElement: TDOMElement;
     function GetDocType: TDOMDocumentType;
@@ -2081,7 +2085,7 @@ begin
   FEmptyNode.Free;
   inherited Destroy;
   for i := 0 to (FMaxPoolSize div sizeof(TNodePool))-1 do
-    FPools[i].Free;
+    FPools^[i].Free;
   FreeMem(FPools);
   FNames.Free;           // free the nametable after inherited has destroyed the children
                          // (because children reference the nametable)
@@ -2099,11 +2103,11 @@ begin
     Exit;
   end;
 
-  pp := FPools[size div sizeof(TNodePool)];
+  pp := FPools^[size div sizeof(TNodePool)];
   if pp = nil then
   begin
     pp := TNodePool.Create(size);
-    FPools[size div sizeof(TNodePool)] := pp;
+    FPools^[size div sizeof(TNodePool)] := pp;
   end;
   Result := pp.AllocNode(AClass);
 end;
@@ -3163,16 +3167,16 @@ end;
 destructor TNodePool.Destroy;
 var
   ext, next: PExtent;
-  ptr, ptr_end: Pointer;
+  ptr, ptr_end: PAnsiChar;
   sz: Integer;
 begin
   ext := FCurrExtent;
-  ptr := Pointer(FCurrBlock) + FElementSize;
+  ptr := PAnsiChar(FCurrBlock) + FElementSize;
   sz := FCurrExtentSize;
   while Assigned(ext) do
   begin
     // call destructors for everyone still there
-    ptr_end := Pointer(ext) + sizeof(TExtent) + (sz - 1) * FElementSize;
+    ptr_end := PAnsiChar(ext) + sizeof(TExtent) + (sz - 1) * FElementSize;
     while ptr <= ptr_end do
     begin
       if TDOMNode(ptr).FPool = Self then
@@ -3184,7 +3188,7 @@ begin
     FreeMem(ext);
     ext := next;
     sz := sz div 2;
-    ptr := Pointer(ext) + sizeof(TExtent);
+    ptr := PAnsiChar(ext) + sizeof(TExtent);
   end;
   inherited Destroy;
 end;
@@ -3194,13 +3198,13 @@ var
   ext: PExtent;
 begin
   Assert((FCurrExtent = nil) or
-    (Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent)));
+    (PAnsiChar(FCurrBlock) = PAnsiChar(FCurrExtent) + sizeof(TExtent)));
   Assert(AElemCount > 0);
 
   GetMem(ext, sizeof(TExtent) + AElemCount * FElementSize);
   ext^.Next := FCurrExtent;
   // point to the beginning of the last block of extent
-  FCurrBlock := TDOMNode(Pointer(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize);
+  FCurrBlock := TDOMNode(PAnsiChar(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize);
   FCurrExtent := ext;
   FCurrExtentSize := AElemCount;
 end;
@@ -3214,7 +3218,7 @@ begin
   end
   else
   begin
-    if Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent) then
+    if PAnsiChar(FCurrBlock) = PAnsiChar(FCurrExtent) + sizeof(TExtent) then
       AddExtent(FCurrExtentSize * 2);
     Result := FCurrBlock;
     Dec(PAnsiChar(FCurrBlock), FElementSize);

packages/fcl-xml/src/xmlcfg.pp

@@ -18,7 +18,7 @@
   configuration data
 }
 
-{$MODE objfpc}
+{$ifdef fpc}{$MODE objfpc}{$endif}
 {$H+}
 
 unit XMLCfg;
@@ -51,7 +51,7 @@ type
     FStartEmpty: Boolean;
     FUseEscaping: Boolean;
     FRootName: DOMString;
-    procedure SetFilename(const AFilename: String; ForceReload: Boolean);
+    procedure SetFilenameForce(const AFilename: String; ForceReload: Boolean);
     procedure SetFilename(const AFilename: String);
     procedure SetStartEmpty(AValue: Boolean);
     procedure SetRootName(const AValue: DOMString);
@@ -66,15 +66,15 @@ type
     destructor Destroy; override;
     procedure Clear;
     procedure Flush;    // Writes the XML file
-    function  GetValue(const APath, ADefault: String): String;
-    function  GetValue(const APath: String; ADefault: Integer): Integer;
-    function  GetValue(const APath: String; ADefault: Boolean): Boolean;
-    procedure SetValue(const APath, AValue: String);
-    procedure SetDeleteValue(const APath, AValue, DefValue: String);
-    procedure SetValue(const APath: String; AValue: Integer);
-    procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer);
-    procedure SetValue(const APath: String; AValue: Boolean);
-    procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
+    function  GetValue(const APath, ADefault: String): String; overload;
+    function  GetValue(const APath: String; ADefault: Integer): Integer; overload;
+    function  GetValue(const APath: String; ADefault: Boolean): Boolean; overload;
+    procedure SetValue(const APath, AValue: String); overload;
+    procedure SetDeleteValue(const APath, AValue, DefValue: String); overload;
+    procedure SetValue(const APath: String; AValue: Integer); overload;
+    procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer); overload;
+    procedure SetValue(const APath: String; AValue: Boolean); overload;
+    procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean); overload;
     procedure DeletePath(const APath: string);
     procedure DeleteValue(const APath: string);
     property Modified: Boolean read FModified;
@@ -300,7 +300,7 @@ procedure TXMLConfig.Loaded;
 begin
   inherited Loaded;
   if Length(Filename) > 0 then
-    SetFilename(Filename, true);              // Load the XML config file
+    SetFilenameForce(Filename, true);              // Load the XML config file
 end;
 
 function TXMLConfig.FindNode(const APath: String;
@@ -370,7 +370,7 @@ begin
     Result := s;
 end;
 
-procedure TXMLConfig.SetFilename(const AFilename: String; ForceReload: Boolean);
+procedure TXMLConfig.SetFilenameForce(const AFilename: String; ForceReload: Boolean);
 begin
   {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
   if (not ForceReload) and (FFilename = AFilename) then
@@ -400,7 +400,7 @@ end;
 
 procedure TXMLConfig.SetFilename(const AFilename: String);
 begin
-  SetFilename(AFilename, False);
+  SetFilenameForce(AFilename, False);
 end;
 
 procedure TXMLConfig.SetRootName(const AValue: DOMString);
@@ -424,7 +424,7 @@ begin
   begin
     FStartEmpty := AValue;
     if (not AValue) and not Modified then
-      SetFilename(Filename, True);
+      SetFilenameForce(Filename, True);
   end;
 end;
 

packages/fcl-xml/src/xmlutils.pp

@@ -14,7 +14,7 @@
  **********************************************************************}
 unit xmlutils;
 
-{$mode objfpc}
+{$ifdef fpc}{$mode objfpc}{$endif}
 {$H+}
 
 interface
@@ -38,6 +38,10 @@ function WStrLIComp(S1, S2: PWideChar; Len: Integer): Integer;
 { a simple hash table with WideString keys }
 
 type
+{$ifndef fpc}
+  PtrInt = LongInt;
+{$endif}  
+
   PPHashItem = ^PHashItem;
   PHashItem = ^THashItem;
   THashItem = record
@@ -46,6 +50,8 @@ type
     Next: PHashItem;
     Data: TObject;
   end;
+  THashItemArray = array[0..0] of PHashItem;
+  PHashItemArray = ^THashItemArray;
 
   THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean;
 
@@ -53,7 +59,7 @@ type
   private
     FCount: LongWord;
     FBucketCount: LongWord;
-    FBucket: PPHashItem;
+    FBucket: PHashItemArray;
     FOwnsObjects: Boolean;
     function Lookup(Key: PWideChar; KeyLength: Integer; out Found: Boolean; CanCreate: Boolean): PHashItem;
     procedure Resize(NewCapacity: LongWord);
@@ -73,7 +79,6 @@ type
 
 { another hash, for detecting duplicate namespaced attributes without memory allocations }
 
-  PExpHashEntry = ^TExpHashEntry;
   TExpHashEntry = record
     rev: LongWord;
     hash: LongWord;
@@ -81,12 +86,14 @@ type
     lname: PWideChar;
     lnameLen: Integer;
   end;
+  TExpHashEntryArray = array[0..0] of TExpHashEntry;
+  PExpHashEntryArray = ^TExpHashEntryArray;
 
   TDblHashArray = class(TObject)
   private
     FSizeLog: Integer;
     FRevision: LongWord;
-    FData: PExpHashEntry;
+    FData: PExpHashEntryArray;
   public  
     procedure Init(NumSlots: Integer);
     function Locate(uri: PWideString; localName: PWideChar; localLength: Integer): Boolean;
@@ -128,7 +135,7 @@ begin
   Result := Xml11Pg;
 end;
 
-function IsXml11Char(Value: PWideChar; var Index: Integer): Boolean;
+function IsXml11Char(Value: PWideChar; var Index: Integer): Boolean; overload;
 begin
   if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
   begin
@@ -139,7 +146,7 @@ begin
     Result := False;
 end;
 
-function IsXml11Char(const Value: WideString; var Index: Integer): Boolean;
+function IsXml11Char(const Value: WideString; var Index: Integer): Boolean; overload;
 begin
   if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
   begin
@@ -346,7 +353,11 @@ end;
 
 function KeyCompare(const Key1: WideString; Key2: Pointer; Key2Len: Integer): Boolean;
 begin
+{$IFDEF FPC}
   Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0);
+{$ELSE}
+  Result := (Length(Key1)=Key2Len) and CompareMem(Pointer(Key1), Key2, Key2Len*2);
+{$ENDIF}
 end;
 
 { THashTable }
@@ -377,7 +388,7 @@ var
 begin
   for I := 0 to FBucketCount-1 do
   begin
-    item := FBucket[I];
+    item := FBucket^[I];
     while Assigned(item) do
     begin
       next := item^.Next;
@@ -386,8 +397,8 @@ begin
       Dispose(item);
       item := next;
     end;
+    FBucket^[I] := nil;
   end;
-  FillChar(FBucket^, FBucketCount * sizeof(PHashItem), 0);
 end;
 
 function THashTable.Find(Key: PWideChar; KeyLen: Integer): PHashItem;
@@ -460,14 +471,15 @@ end;
 
 procedure THashTable.Resize(NewCapacity: LongWord);
 var
-  p, chain: PPHashItem;
+  p: PHashItemArray;
+  chain: PPHashItem;
   i: Integer;
   e, n: PHashItem;
 begin
   p := AllocMem(NewCapacity * sizeof(PHashItem));
   for i := 0 to FBucketCount-1 do
   begin
-    e := FBucket[i];
+    e := FBucket^[i];
     while Assigned(e) do
     begin
       chain := @p[e^.HashValue mod NewCapacity];
@@ -538,7 +550,7 @@ var
 begin
   for i := 0 to FBucketCount-1 do
   begin
-    e := FBucket[i];
+    e := FBucket^[i];
     while Assigned(e) do
     begin
       if not proc(e, arg) then
@@ -572,7 +584,7 @@ begin
   begin
     FRevision := $FFFFFFFF;
     for i := (1 shl FSizeLog)-1 downto 0 do
-      FData[i].rev := FRevision;
+      FData^[i].rev := FRevision;
   end;
   Dec(FRevision);
 end;
@@ -591,18 +603,18 @@ begin
   step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
   idx := HashValue and mask;
   result := True;
-  while FData[idx].rev = FRevision do
+  while FData^[idx].rev = FRevision do
   begin
-    if (HashValue = FData[idx].hash) and (FData[idx].uriPtr^ = uri^) and
-      (FData[idx].lnameLen = localLength) and
-       CompareMem(FData[idx].lname, localName, localLength * sizeof(WideChar)) then
+    if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr^ = uri^) and
+      (FData^[idx].lnameLen = localLength) and
+       CompareMem(FData^[idx].lname, localName, localLength * sizeof(WideChar)) then
       Exit;
     if idx < step then
       Inc(idx, (1 shl FSizeLog) - step)
     else
       Dec(idx, step);
   end;
-  with FData[idx] do
+  with FData^[idx] do
   begin
     rev := FRevision;
     hash := HashValue;

packages/fcl-xml/src/xmlwrite.pp

@@ -17,7 +17,7 @@
 
 unit XMLWrite;
 
-{$MODE objfpc}
+{$ifdef fpc}{$MODE objfpc}{$endif}
 {$H+}
 
 interface