* merged fixes

fcl/db/dataset.inc

@@ -34,6 +34,9 @@ end;
 
 destructor TDataSet.Destroy;
 
+var
+  i: Integer;
+
 begin
   Active:=False;
   FFieldDefs.Free;
@@ -44,6 +47,12 @@ begin
       TDatasource(Items[Count - 1]).DataSet:=Nil;
     Free;
     end;
+  if Assigned(FBuffers) then
+  begin
+    for i := 0 to FBufferCount do
+      FreeRecordBuffer(FBuffers[i]);
+    FreeMem(FBuffers);
+  end;
   Inherited Destroy;
 end;
 
@@ -75,7 +84,7 @@ begin
      // ATM Set by CreateField ...
   For I:=0 to FFieldList.Count-1 do
     FFieldList[i].FFieldNo:=I;
-  }  
+  }
 end;
 
 Function TDataset.BookmarkAvailable: Boolean;
@@ -150,7 +159,9 @@ begin
     With Fielddefs.Items[I] do
       If DataType<>ftUnknown then
         begin
+        {$ifdef DSDebug}
         Writeln('About to create field',FieldDefs.Items[i].Name);
+        {$endif}
         CreateField(self);
         end;
 end;
@@ -788,6 +799,7 @@ Procedure TDataset.SetName(const Value: TComponentName);
 
 begin
   //!! To be implemented
+  inherited SetName(Value);
 end;
 
 Procedure TDataset.SetOnFilterRecord(const Value: TFilterRecordEvent);
@@ -1593,7 +1605,10 @@ end;
 
 {
   $Log$
-  Revision 1.4  2001-01-18 22:10:07  michael
+  Revision 1.5  2001-04-10 23:28:23  peter
+    * merged fixes
+
+  Revision 1.4  2001/01/18 22:10:07  michael
   + Fixes to make dbase working merged from fixbranch
 
   Revision 1.3  2000/12/24 12:45:19  peter

fcl/db/fields.inc

@@ -38,7 +38,7 @@ begin
   Inherited Create(AOwner);
 {$ifdef dsdebug }
   Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
-{$endif}  
+{$endif}
   FName:=Aname;
   FDatatype:=ADatatype;
   FSize:=ASize;
@@ -51,7 +51,7 @@ begin
     end
   else If FDataType in [ftWord,ftsmallint,ftinteger] Then
     If Not (FSize in [1,2,4]) then FSize:=4;
-  
+
   FFieldNo:=AFieldNo;
   AOwner.FItems.Add(Self);
 end;
@@ -69,7 +69,9 @@ Function TFieldDef.CreateField(AOwner: TComponent): TField;
 Var TheField : TFieldClass;
 
 begin
-  Writeln ('Creating field'+FNAME);
+{$ifdef dsdebug}
+  Writeln ('Creating field '+FNAME);
+{$endif dsdebug}
   TheField:=GetFieldClass;
   if TheField=Nil then
     DatabaseErrorFmt(SUnknownFieldType,[FName]);
@@ -82,10 +84,10 @@ begin
     Result.SetFieldType(DataType);
 {$ifdef dsdebug}
     Writeln ('TFieldDef.CReateField : Trying to set dataset');
-{$endif dsdebug}    
+{$endif dsdebug}
 {$ifdef dsdebug}
     Writeln ('TFieldDef.CReateField : Result Fieldno : ',Result.FieldNo,' Self : ',FieldNo);
-{$endif dsdebug}    
+{$endif dsdebug}
     Result.Dataset:=TFieldDefs(Owner).FDataset;
     If Result is TFloatField then
       TFloatField(Result).Precision:=FPrecision;
@@ -93,7 +95,7 @@ begin
     Result.Free;
     Raise;
   end;
-  
+
 end;
 
 Function TFieldDef.GetFieldClass : TFieldClass;
@@ -123,7 +125,7 @@ procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word
   ARequired: Boolean);
 
 begin
-  If Length(AName)=0 Then 
+  If Length(AName)=0 Then
     DatabaseError(SNeedFieldName);
   // the fielddef will register itself here as a owned component.
   // fieldno is 1 based !
@@ -168,6 +170,7 @@ Var I : longint;
 begin
   For I:=FItems.Count-1 downto 0 do
     TFieldDef(Fitems[i]).Free;
+  FItems.Clear;
 end;
 
 function TFieldDefs.Find(const AName: string): TFieldDef;
@@ -465,7 +468,7 @@ Procedure TField.SetDataset (Value : TDataset);
 begin
 {$ifdef dsdebug}
   Writeln ('Setting dataset');
-{$endif}  
+{$endif}
   If Value=FDataset then exit;
   If Assigned(FDataset) Then FDataset.CheckInactive;
   If Assigned(Value) then
@@ -476,9 +479,9 @@ begin
     end;
   If Assigned(FDataset) then
     FDataset.FFieldList.Remove(Self);
-  If Assigned(Value) then 
+  If Assigned(Value) then
     Value.FFieldList.Add(Self);
-  FDataset:=Value;    
+  FDataset:=Value;
 end;
 
 procedure TField.SetDataType(AValue: TFieldType);
@@ -1773,7 +1776,10 @@ end;
 
 {
   $Log$
-  Revision 1.5  2001-01-18 22:10:07  michael
+  Revision 1.6  2001-04-10 23:28:23  peter
+    * merged fixes
+
+  Revision 1.5  2001/01/18 22:10:07  michael
   + Fixes to make dbase working merged from fixbranch
 
   Revision 1.4  2000/12/24 12:45:19  peter

fcl/db/interbase/interbase.pp

@@ -18,6 +18,7 @@ unit Interbase;
 
 {$mode objfpc}
 {$H+}
+{$M+}   // ### remove this!!!
 
 interface
 
@@ -33,6 +34,8 @@ type
   TIBQuery = class;
   TIBStoredProc = class;
 
+  EInterBaseError = class(Exception);
+
 { TIBDatabase }
 
   TIBDatabase = class (TDatabase)
@@ -42,6 +45,7 @@ type
     FStatus              : array [0..19] of ISC_STATUS;
     FTransaction         : TIBTransaction;
     FUserName            : string;
+    FCharSet             : string;
     FDialect             : integer;
 
     procedure SetDBDialect;
@@ -63,8 +67,8 @@ type
   public
     procedure StartTransaction; override;
     procedure EndTransaction; override;
-    constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
+    property Handle: Pointer read GetHandle;
   published
     { On connect, TIBDatabase object retrieve SQL dialect of database file,
       and sets this property to responding value }
@@ -79,6 +83,8 @@ type
     { Before firing Open method you must set @link(Password),@link(DatabaseName),
       @link(UserName) properties in order of successfull connect to database }
     property UserName : string read FUserName write FUserName;
+    { The character set used in SQL statements }
+    property CharSet : string read FCharSet write FCharSet;
 
     { Identifies, if connection to Interbase server is established, or not.
       Instead of calling Open, Close methods you can connect or disconnect
@@ -150,6 +156,7 @@ type
     procedure StartTransaction;
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
+    property Handle: Pointer read GetHandle;
   published
     { Default action while closing transaction by setting
      @link(Active) property. For details see @link(TCommitRollbackAction)}
@@ -305,7 +312,7 @@ begin
     p := @Status;
     while isc_interprete(Buf, @p) > 0 do
       Msg := Msg + #10' -' + StrPas(Buf);
-    raise Exception.Create(ProcName + ': ' + Msg);
+    raise EInterBaseError.Create(ProcName + ': ' + Msg);
   end;
 end;
 
@@ -342,8 +349,9 @@ begin
   if FTransaction = nil then
   begin
     FTransaction := Value;
-    FTransaction.Database := Self;
-    Exit;
+    if Assigned(FTransaction) then
+      FTransaction.Database := Self;
+    exit;
   end;
 
   if (Value <> FTransaction) and (Value <> nil) then
@@ -352,7 +360,8 @@ begin
       FTransaction := Value;
       FTransaction.Database := Self;
     end
-    else Exception.Create('Cannot assign transaction while old transaction active!');
+    else
+      raise EInterBaseError.Create('Cannot assign transaction while old transaction active!');
 end;
 
 function TIBDatabase.GetHandle: pointer;
@@ -373,8 +382,11 @@ begin
     if (FPassword <> '') then
       DPB := DPB + chr(isc_dpb_password) + chr(Length(FPassword)) + FPassword;
   end;
+  if Length(CharSet) > 0 then
+    DPB := DPB + Chr(isc_dpb_lc_ctype) + Chr(Length(CharSet)) + CharSet;
+
   if (DatabaseName = '') then
-    raise Exception.Create('TIBDatabase.Open: Database connect string not filled in!');
+    raise EInterBaseError.Create('TIBDatabase.Open: Database connect string not filled in!');
   FIBDatabaseHandle := nil;
   if isc_attach_database(@FStatus, Length(DatabaseName), @DatabaseName[1], @FIBDatabaseHandle,
          Length(DPB), @DPB[1]) <> 0 then
@@ -407,16 +419,6 @@ begin
   FTransaction.Active := False;
 end;
 
-constructor TIBDatabase.Create(AOwner : TComponent);
-begin
-  inherited Create(AOwner);
-  FIBDatabaseHandle    := nil;
-  FPassword            := '';
-  FTransaction         := nil;
-  FUserName            := '';
-  FillChar(FStatus, SizeOf(FStatus), #0);
-end;
-
 destructor TIBDatabase.Destroy;
 begin
   if FTransaction <> nil then
@@ -431,17 +433,9 @@ end;
 
 procedure TIBTransaction.SetActive(Value : boolean);
 begin
-  if FActive = Value then Exit;
-  if (FActive) and (not Value) then
-    case FAction of
-      caCommit            : Commit;
-      caCommitRetaining   : CommitRetaining;
-      caRollback          : Rollback;
-      caRollbackRetaining : RollbackRetaining;
-    else
-      Exception.Create('TIBTransaction.SetActive: Transaction is already active.');
-    end;
-  if (not FActive) and (Value) then
+  if FActive and (not Value) then
+    Rollback
+  else if (not FActive) and Value then
     StartTransaction;
 end;
 
@@ -522,7 +516,7 @@ begin
   if Active then Active := False;
 
   if FDatabase = nil then
-    Exception.Create('TIBTransaction.StartTransaction: Database not assigned!');
+    raise EInterBaseError.Create('TIBTransaction.StartTransaction: Database not assigned!');
 
   if not Database.Connected then
     Database.Open;
@@ -540,35 +534,16 @@ end;
 constructor TIBTransaction.Create(AOwner : TComponent);
 begin
   inherited Create(AOwner);
-
-  FAction := caNone;
-  FActive := False;
-  FAccessMode := amReadWrite;
   FIsolationLevel := ilReadCommitted;
-  FLockResolution := lrWait;
-  FTableReservation := trNone;
-  FTransactionHandle := nil;
-  FDatabase := nil;
-
-  FillChar(FStatus, SizeOf(FStatus), #0);
 end;
 
 destructor TIBTransaction.Destroy;
 begin
+  // This will also do a Rollback, if the transaction is currently active
+  Active := False;
+
   if Database <> nil then
     Database.Transaction := nil;
-
-{  // i really can't allow commit of transaction
-  // on destroy...
-}
-{
-  try
-    if Active then
-      Active := False;
-  except
-  end;
-}
-
   inherited Destroy;
 end;
 
@@ -595,8 +570,11 @@ end;
 procedure TIBQuery.AllocSQLDA(Count : integer);
 begin
   if FSQLDAAllocated > 0 then
-    FreeMem(FSQLDA, XSQLDA_Length * FSQLDAAllocated);
-  GetMem(FSQLDA, XSQLDA_Length * Count);
+    FreeMem(FSQLDA);
+  GetMem(FSQLDA, XSQLDA_Length(Count));
+  { Zero out the memory block to avoid problems with exceptions within the
+    constructor of this class. }
+  FillChar(FSQLDA^, XSQLDA_Length(Count), 0);
   FSQLDAAllocated := Count;
   FSQLDA^.Version := sqlda_version1;
   FSQLDA^.SQLN := Count;
@@ -617,7 +595,7 @@ end;
 procedure TIBQuery.FreeStatement;
 begin
   if isc_dsql_free_statement(@FStatus, @FStatement, DSQL_Drop) <> 0 then
-    CheckError('TIBQuery.DeallocStatement', FStatus);
+    CheckError('TIBQuery.FreeStatement', FStatus);
   FStatement := nil;
 end;
 
@@ -632,7 +610,7 @@ begin
   for x := 0 to FSQL.Count - 1 do
     Buf := Buf + FSQL[x] + ' ';
 
-  if isc_dsql_prepare(@FStatus, @tr, @FStatement, 0, @Buf[1], 1, nil) <> 0 then
+  if isc_dsql_prepare(@FStatus, @tr, @FStatement, 0, @Buf[1], Database.Dialect, nil) <> 0 then
     CheckError('TIBQuery.PrepareStatement', FStatus);
 end;
 
@@ -677,14 +655,12 @@ end;
 
 procedure TIBQuery.AllocFldBuffers;
 var
-  Buf: pointer;
   x  : shortint;
 begin
   {$R-}
   for x := 0 to FSQLDA^.SQLD - 1 do
   begin
-    Buf := AllocMem(FSQLDA^.SQLVar[x].SQLLen);
-    FSQLDA^.SQLVar[x].SQLData := Buf;
+    FSQLDA^.SQLVar[x].SQLData := AllocMem(FSQLDA^.SQLVar[x].SQLLen);
     FSQLDA^.SQLVar[x].SQLInd  := @FFieldFlag[x];
   end;
   {$R+}
@@ -1160,24 +1136,20 @@ end;
 procedure TIBQuery.ExecSQL;
 begin
   AllocStatement;
-  PrepareStatement;
-  GetStatementType;
-  Execute;
-  FreeStatement;
+  try
+    PrepareStatement;
+    GetStatementType;
+    Execute;
+  finally
+    FreeStatement;
+  end;
 end;
 
 constructor TIBQuery.Create(AOwner : TComponent);
 begin
   inherited Create(AOwner);
-  FillChar(FFieldFlag, SizeOf(FFieldFlag), #0);
   FSQL := TStringList.Create;
-  FStatement := nil;
   FCurrentRecord := -1;
-  FDatabase := nil;
-  FTransaction := nil;
-  FSQLDAAllocated := 0;
-  FLoadingFieldDefs := False;
-  FPrepared := False;
   AllocSQLDA(10);
 end;
 
@@ -1186,7 +1158,7 @@ begin
   if Active then Close;
   FSQL.Free;
   inherited Destroy;
-  FreeMem(FSQLDA, XSQLDA_Length * FSQLDAAllocated);
+  FreeMem(FSQLDA);
 end;
 
 { TIBStoredProc }

fcl/inc/classes.inc

@@ -934,7 +934,7 @@ var
           else
           begin
             Output.WriteByte(Ord(vaIdent));
-            WriteString(parser.TokenString);
+            WriteString(parser.TokenComponentIdent);
           end;
           Parser.NextToken;
         end;
@@ -1182,7 +1182,10 @@ end;
 
 {
   $Log$
-  Revision 1.6  2001-03-08 19:39:25  michael
+  Revision 1.7  2001-04-10 23:24:51  peter
+    * merged fixes
+
+  Revision 1.6  2001/03/08 19:39:25  michael
   + Merged fixes
 
   Revision 1.5  2000/10/15 09:27:48  peter

fcl/inc/stringl.inc

@@ -833,8 +833,17 @@ begin
     end
   else if NewCapacity<FCapacity then
     begin
-    NewList:=Flist+NewCapacity*SizeOf(TStringItem);
-    FreeMem (NewList, (FCapacity-NewCapacity)*SizeOf(TStringItem));
+    if NewCapacity = 0 then
+    begin
+      FreeMem(FList);
+      FList := nil;
+    end else
+    begin
+      GetMem(NewList, NewCapacity * SizeOf(TStringItem));
+      System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
+      FreeMem(FList);
+      FList := NewList;
+    end;
     FCapacity:=NewCapacity;
     end;
 end;
@@ -1010,7 +1019,10 @@ end;
 
 {
   $Log$
-  Revision 1.7  2001-02-23 22:24:08  michael
+  Revision 1.8  2001-04-10 23:24:51  peter
+    * merged fixes
+
+  Revision 1.7  2001/02/23 22:24:08  michael
   + Fixed sorting of stringslist
 
   Revision 1.6  2000/12/03 22:35:09  sg

fcl/xml/xmlcfg.pp

@@ -3,7 +3,7 @@
     This file is part of the Free Component Library
 
     Implementation of TXMLConfig class
-    Copyright (c) 1999-2000 by Sebastian Guenther, [email protected]
+    Copyright (c) 1999 - 2001 by Sebastian Guenther, [email protected]
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -25,7 +25,7 @@
 unit XMLCfg;
 
 interface
-uses DOM, XMLRead, XMLWrite;
+uses Classes, DOM, XMLRead, XMLWrite;
 
 type
 
@@ -34,12 +34,16 @@ type
    is the name of the value. The path components will be mapped to XML
    elements, the name will be an element attribute.}
 
-  TXMLConfig = class
+  TXMLConfig = class(TComponent)
+  private
+    FFilename: String;
+    procedure SetFilename(const AFilename: String);
   protected
     doc: TXMLDocument;
-    FileName: String;
+    FModified: Boolean;
+    procedure Loaded; override;
   public
-    constructor Create(const AFileName: String);
+    constructor Create(const AFilename: String);
     destructor Destroy; override;
     procedure Flush;    // Writes the XML file
     function  GetValue(const APath, ADefault: String): String;
@@ -48,6 +52,9 @@ type
     procedure SetValue(const APath, AValue: String);
     procedure SetValue(const APath: String; AValue: Integer);
     procedure SetValue(const APath: String; AValue: Boolean);
+    property Modified: Boolean read FModified;
+  published
+    property Filename: String read FFilename write SetFilename;
   end;
 
 
@@ -58,41 +65,19 @@ implementation
 uses SysUtils;
 
 
-constructor TXMLConfig.Create(const AFileName: String);
-var
-  f: File;
-  cfg: TDOMElement;
+constructor TXMLConfig.Create(const AFilename: String);
 begin
-  FileName := AFileName;
-  Assign(f, AFileName);
-  {$I-}
-  Reset(f, 1);
-  {$I+}
-  if IOResult = 0 then begin
-    try
-      ReadXMLFile(doc, f);
-    except
-      on e: EXMLReadError do
-        WriteLn(StdErr, 'Warning: XML config parsing error: ', e.Message);
-    end;
-    Close(f);
-  end;
-
-  if not Assigned(doc) then
-    doc := TXMLDocument.Create;
-
-  cfg :=TDOMElement(doc.FindNode('CONFIG'));
-  if not Assigned(cfg) then begin
-    cfg := doc.CreateElement('CONFIG');
-    doc.AppendChild(cfg);
-  end;
+  inherited Create(nil);
+  SetFilename(AFilename);
 end;
 
 destructor TXMLConfig.Destroy;
 begin
-  Flush;
   if Assigned(doc) then
+  begin
+    Flush;
     doc.Free;
+  end;
   inherited Destroy;
 end;
 
@@ -100,35 +85,44 @@ procedure TXMLConfig.Flush;
 var
   f: Text;
 begin
-  Assign(f, FileName);
-  Rewrite(f);
-  WriteXMLFile(doc, f);
-  Close(f);
+  if Modified then
+  begin
+    AssignFile(f, Filename);
+    Rewrite(f);
+    try
+      WriteXMLFile(doc, f);
+    finally
+      CloseFile(f);
+    end;
+    FModified := False;
+  end;
 end;
 
 function TXMLConfig.GetValue(const APath, ADefault: String): String;
 var
-  node, subnode, attr: TDOMNode;
+  Node, Child, Attr: TDOMNode;
   i: Integer;
-  name, path: String;
+  NodePath: String;
 begin
-  node := doc.DocumentElement;
-  path := APath;
-  while True do begin
-    i := Pos('/', path);
-    if i = 0 then break;
-    name := Copy(path, 1, i - 1);
-    path := Copy(path, i + 1, Length(path));
-    subnode := node.FindNode(name);
-    if not Assigned(subnode) then begin
+  Node := doc.DocumentElement;
+  NodePath := APath;
+  while True do
+  begin
+    i := Pos('/', NodePath);
+    if i = 0 then
+      break;
+    Child := Node.FindNode(Copy(NodePath, 1, i - 1));
+    NodePath := Copy(NodePath, i + 1, Length(NodePath));
+    if not Assigned(Child) then
+    begin
       Result := ADefault;
       exit;
     end;
-    node := subnode;
+    Node := Child;
   end;
-  attr := node.Attributes.GetNamedItem(path);
-  if Assigned(attr) then
-    Result := attr.NodeValue
+  Attr := Node.Attributes.GetNamedItem(NodePath);
+  if Assigned(Attr) then
+    Result := Attr.NodeValue
   else
     Result := ADefault;
 end;
@@ -159,34 +153,34 @@ end;
 
 procedure TXMLConfig.SetValue(const APath, AValue: String);
 var
-  node, subnode, attr: TDOMNode;
+  Node, Child, Attr: TDOMNode;
   i: Integer;
-  name, path: String;
+  NodeName, NodePath: String;
 begin
-  node := doc.DocumentElement;
-  path := APath;
+  Node := Doc.DocumentElement;
+  NodePath := APath;
   while True do
   begin
-    i := Pos('/', path);
+    i := Pos('/', NodePath);
     if i = 0 then
       break;
-    name := Copy(path, 1, i - 1);
-    path := Copy(path, i + 1, Length(path));
-    subnode := node.FindNode(name);
-    if not Assigned(subnode) then
+    NodeName := Copy(NodePath, 1, i - 1);
+    NodePath := Copy(NodePath, i + 1, Length(NodePath));
+    Child := Node.FindNode(NodeName);
+    if not Assigned(Child) then
     begin
-      subnode := doc.CreateElement(name);
-      node.AppendChild(subnode);
+      Child := Doc.CreateElement(NodeName);
+      Node.AppendChild(Child);
     end;
-    node := subnode;
+    Node := Child;
   end;
-  TDOMElement(node).SetAttribute(path, AValue);
-{  attr := node.Attributes.GetNamedItem(path);
-  if not Assigned(attr) then begin
-    attr := doc.CreateAttribute(path);
-    node.Attributes.SetNamedItem(attr);
+
+  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodePath))) or
+    (TDOMElement(Node)[NodePath] <> AValue) then
+  begin
+    TDOMElement(Node)[NodePath] := AValue;
+    FModified := True;
   end;
-  attr.NodeValue := AValue;}
 end;
 
 procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
@@ -202,16 +196,61 @@ begin
     SetValue(APath, 'False');
 end;
 
+procedure TXMLConfig.Loaded;
+begin
+  inherited Loaded;
+  if Length(Filename) > 0 then
+    SetFilename(Filename);              // Load the XML config file
+end;
 
-end.
+procedure TXMLConfig.SetFilename(const AFilename: String);
+var
+  f: File;
+  cfg: TDOMElement;
+begin
+  FFilename := AFilename;
+
+  if csLoading in ComponentState then
+    exit;
+
+  if Assigned(doc) then
+  begin
+    Flush;
+    doc.Free;
+  end;
+
+  AssignFile(f, AFileName);
+  {$I-}
+  Reset(f, 1);
+  {$I+}
+  if IOResult = 0 then
+    try
+      ReadXMLFile(doc, f);
+    finally
+      CloseFile(f);
+    end;
+
+  if not Assigned(doc) then
+    doc := TXMLDocument.Create;
+
+  cfg :=TDOMElement(doc.FindNode('CONFIG'));
+  if not Assigned(cfg) then begin
+    cfg := doc.CreateElement('CONFIG');
+    doc.AppendChild(cfg);
+  end;
+end;
 
 
+end.
 {
   $Log$
-  Revision 1.3  2000-07-29 14:52:24  sg
+  Revision 1.4  2001-04-10 23:22:05  peter
+    * merged fixes
+
+  Revision 1.3  2000/07/29 14:52:24  sg
   * Modified the copyright notice to remove ambiguities
 
   Revision 1.2  2000/07/13 11:33:07  michael
   + removed logs
- 
+
 }