program ADODBDump; {$APPTYPE CONSOLE} {$mode objfpc}{$H+} uses Classes, // for TFileStream SysUtils, ActiveX, Variants, Interfaces, // used packages: LazActiveX adodb_6_1_tlb, // Microsoft ActiveX Data Objects 2.x-Objektbibliothek adox_6_0_tlb; // ADO Extensions 2.5 for DDL and Security Library Reference type TResultType = (rtSet, rtDump, rtXml); TADOConnection = class(TComponent) private FConnection: _Connection; FCatalog: _Catalog; FTables: TStringList; function GetProvider: UTF8String; procedure SetProvider(const AProvider: UTF8String); function GetProperty(const Idx: OleVariant): OleVariant; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Open(const AConnectionString: string = ''): boolean; procedure Close(); property Provider: UTF8String read GetProvider write SetProvider; property Properties[const Idx: OleVariant]: OleVariant read GetProperty; property Tables: TStringList read FTables write FTables; end; TADOField = class(TComponent) private FField: Field; FBaseTableName: UTF8String; FPrimaryKey: boolean; FIndex: boolean; FForeignKey: UTF8String; Flcid: UTF8String; FDefinedSize: integer; FPrecision: integer; FNumericScale: integer; FSigned: boolean; FIsNullable: boolean; FDefault: UTF8String; FIsAutoIncrement: boolean; function GetName: WideString; function GetNameAsUTF8String: UTF8String; function GetValue: OleVariant; procedure SetValue(Value: OleVariant); function GetProperty(const Idx: WideString): OleVariant; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetValueAsUTF8String(AResultType: TResultType = rtSet): UTF8String; function GetTypeAsUTF8String(AResultType: TResultType = rtSet): UTF8String; property Name: WideString read GetName; property UTF8Name: UTF8String read GetNameAsUTF8String; property Value: OleVariant read GetValue write SetValue; property AsUTF8String: UTF8String read GetValueAsUTF8String; property TypeAsUTF8String: UTF8String read GetTypeAsUTF8String; property Properties[const Idx: WideString]: OleVariant read GetProperty; property PrimaryKey: boolean read FPrimaryKey; property Index: boolean read FIndex; property ForeignKey: UTF8String read FForeignKey; property lcid: UTF8String read Flcid; property DefinedSize: integer read FDEfinedSize; property Precision: integer read FPrecision; property NumericScale: integer read FNumericScale; property Signed: boolean read FSigned; property isNullable: boolean read FIsNullable; property DefaultValue: UTF8String read FDefault; property isAutoIncrement: boolean read FIsAutoIncrement; end; TADOFields = class(TComponent) private FFields: array of TADOField; procedure GetItems(); procedure ClearItems(); procedure UpdateItems(); function GetItemById(const Index: integer): TADOField; function GetItemByName(const ItemName: WideString): TADOField; function GetItem(const Idx: OleVariant): TADOField; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Count: integer; property Field[const Idx: OleVariant]: TADOField read GetItem; default; end; TADORecordset = class(TComponent) private FRecordset: _Recordset; FFields: TADOFields; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Open(const ASelect: string; ACursorType, ALockType, ACommandType: integer): boolean; procedure Close(); function OpenDisconnected(const ASelect: string; ACursorType, ALockType, ACommandType: integer): boolean; procedure CloseDisconnected(); function BOF: boolean; function EOF: boolean; procedure MoveNext; property Fields: TADOFields read FFields write FFields; end; function GetAsUTF8String(const value: OleVariant; AResultType: TResultType = rtSet): UTF8String; var index, lowVal, highVal: integer; oleArray: PSafeArray; oleObj: OleVariant; s: string; begin try case TVarData(Value).vType of varEmpty: result := ''; varNull: if AResultType=rtSet then result := '' else result := 'NULL'; varSmallint, varInteger, varByte, varError: result := IntToStr(Value); varSingle, varDouble, varCurrency: result := FloatToStr(Value); varDate: if AResultType=rtDump then result := '''' + DateTimeToStr(Value) + '''' else result := DateTimeToStr(Value); varOleStr, varStrArg, varString: begin s := Value; if AResultType<>rtSet then begin s := StringReplace(s, '\', '\\', [rfReplaceAll]); s := StringReplace(s, #13#10, '\n', [rfReplaceAll]); s := StringReplace(s, '&', '&', [rfReplaceAll]); s := StringReplace(s, '<', '<', [rfReplaceAll]); s := StringReplace(s, '>', '>', [rfReplaceAll]); if AResultType=rtDump then begin s := StringReplace(s, '''', '\''', [rfReplaceAll]); s := '''' + s + ''''; end; end; result := UTF8Encode(s); end; varBoolean: if Value then result := 'true' else result := 'false'; varDispatch, varVariant, varUnknown, varTypeMask: begin VarAsType(Value, varOleStr); result := UTF8Encode(Widestring(Value)); end; else if VarIsArray(Value) then begin VarArrayLock(Value); index := VarArrayDimCount(Value); lowVal := VarArrayLowBound(Value, index); highVal := VarArrayHighBound(Value, index); oleArray := TVariantArg(Value).pArray; for index := lowVal to highVal do begin SafeArrayGetElement(oleArray, @index, oleObj); result := result + GetAsUTF8String(oleObj, AResultType) + #13#10; end; VarArrayUnlock(Value); Delete(result, length(result) - 1, 2); end else result := ''; // varAny, varByRef end; except result := '#error#' end; end; function IIF(b: boolean; sTrue: UTF8String; sFalse: UTF8String = ''): UTF8String; begin if b then result := sTrue else result := sFalse; end; {$REGION ' - TADOConnection - '} function TADOConnection.GetProvider: UTF8String; begin result := UTF8Encode(FConnection.Provider); end; procedure TADOConnection.SetProvider(const AProvider: UTF8String); begin FConnection.Provider := UTF8Decode(AProvider); end; function TADOConnection.GetProperty(const Idx: OleVariant): OleVariant; begin result := FConnection.Properties[Idx]; end; constructor TADOConnection.Create(AOwner: TComponent); begin inherited Create(AOwner); FConnection := CoConnection.Create; FCatalog := CoCatalog.Create; FTables := TStringList.Create; end; destructor TADOConnection.Destroy; begin if FConnection.State = adStateOpen then Close; FTables.Free; FCatalog := nil; FConnection := nil; inherited; end; function TADOConnection.Open(const AConnectionString: string = ''): boolean; var rs: _Recordset; begin result := false; FConnection.Open(WideString(AConnectionString), '', '', 0); if FConnection.State = adStateOpen then begin FCatalog.Set_ActiveConnection_(FConnection); rs := CoRecordset.Create; rs := FConnection.OpenSchema(adSchemaTables, EmptyParam, EmptyParam); while not (rs.EOF_) do begin if (rs.Fields['TABLE_TYPE'].Value = 'TABLE') then // only tables no 'SYSTEM TABLE' or 'VIEW' FTables.Add(rs.Fields['TABLE_NAME'].Value); rs.MoveNext; end; rs.Close; rs := nil; result := true; end; end; procedure TADOConnection.Close(); begin FCatalog.Set_ActiveConnection_(nil); FConnection.Close; end; {$ENDREGION} {$REGION ' - TADOField - '} function TADOField.GetName: WideString; begin if (self = nil) or not assigned(FField) then result := '' else result := FField.Name; end; function TADOField.GetNameAsUTF8String: UTF8String; begin if (self = nil) or not assigned(FField) then result := '' else result := UTF8Encode(FField.Name); end; function TADOField.GetValue: OleVariant; begin if (self = nil) or not assigned(FField) then result := unassigned else result := FField.Value; end; procedure TADOField.SetValue(Value: OleVariant); begin if not (self = nil) and assigned(FField) then FField.Value := Value; end; function TADOField.GetTypeAsUTF8String(AResultType: TResultType = rtSet): UTF8String; begin result := ''; if AResultType = rtXml then begin case FField.Type_ of adBoolean: result := '"boolean"'; adDate, adDBDate: result := '"date"'; adDBTime: result := '"time"'; adDBTimeStamp: result := '"datetime"'; adTinyInt, adSmallInt, adInteger, adBigInt, adUnsignedTinyInt, adUnsignedSmallInt, adUnsignedInt, adUnsignedBigInt: if FField.Properties['ISAUTOINCREMENT'].Value='True' then result := '"i4" AUTOINCREMENT="true"' else result := '"i4"'; adSingle, adDouble, adDecimal, adNumeric: result := '"r8" PRECISION="' + IntToStr(FPrecision) + '" NUMERICALSCALE="' + IntToStr(FNumericScale) + '"'; adCurrency: result := '"r8" SUBTYPE="Money"'; adBSTR, adChar, adVarChar, adLongVarChar, adWChar, adVarWChar, adLongVarWChar: result := '"string" WIDTH="' + IntToStr(FDefinedSize) + '"'; end; result := 'fieldtype=' + result; end else begin if (((Owner As TADOFields).Owner As TADORecordset).Owner As TADOConnection).Provider = 'SQLOLEDB.1' then case FField.Type_ of adSmallInt: result := 'SmallInt'; adInteger: result := 'Int'; adSingle: result := 'Real'; adDouble: result := 'Float'; adCurrency: result := 'Money'; adDate: result := 'DateTime'; adBoolean: result := 'Bit'; adVariant: result := 'Sql_Variant'; adUnsignedTinyInt: result := 'TinyInt'; adBigInt: result := 'BigInt'; adGUID: result := 'UniqueIdentifier'; adBinary: result := 'Binary'; adChar: result := 'Char'; adWChar: result := 'NChar'; adNumeric: result := 'Numeric'; adDBTimeStamp: result := 'DateTime'; adVarChar: result := 'VarChar'; adLongVarChar: result := 'Text'; adVarWChar: result := 'NVarChar'; adLongVarWChar: result := 'NText'; adVarBinary: result := 'VarBinary'; adLongVarBinary: result := 'Image'; else result := 'Unknown'; end else //if Provider = 'Microsoft.Jet.OLEDB.4.0' then case FField.Type_ of adSmallInt: result := 'Integer'; adInteger: result := 'Integer'; adSingle: result := 'Single'; adDouble: result := 'Double'; adCurrency: result := 'Currency'; adDate: result := 'Date'; adBoolean: result := 'YesNo'; adUnsignedTinyInt: result := 'Byte'; adGUID: result := 'ReplicationID'; adNumeric: result := 'Decimal'; adDBTimeStamp: result := 'DateTime'; adVarChar: result := 'Text'; adLongVarChar: result := 'Memo'; adVarWChar: result := 'Text'; adLongVarWChar: result := 'Memo'; adVarBinary: result := 'ReplicationID'; adLongVarBinary: result := 'OLEObject'; else result := 'Unknown'; end; case FField.Type_ of adBinary, adBSTR, adChar, adWChar, adVarChar, adVarWChar: result := result + '(' + IntToStr(FDefinedSize) + ')'; adSingle, adDouble, adCurrency, adNumeric, adVarNumeric: begin result := result + '(' + IntToStr(FPrecision) + ',' + IntToStr(FNumericScale) + ')'; if not (FSigned) then result := result + ' unsigned'; end; end; if not (FIsNullable) then result := result + ' NOT NULL'; if FDefault<>'' then result := result + ' DEFAULT ' + FDefault; if FIsAutoIncrement then result := result + ' AUTO_INCREMENT'; end; end; function TADOField.GetValueAsUTF8String(AResultType: TResultType = rtSet): UTF8String; begin result := GetAsUTF8String(FField.Value, AResultType); end; function TADOField.GetProperty(const Idx: WideString): OleVariant; var i: Integer; begin if self = nil then result := unassigned; for i:=0 to FField.Properties.Count-1 do if FField.Properties[i].Name = Idx then Result := FField.Properties[i].Value; end; constructor TADOField.Create(AOwner: TComponent); begin inherited Create(AOwner); FPrimaryKey := false; FIndex := false; FForeignKey := ''; Flcid := ''; FDefinedSize := 0; FPrecision := 0; FNumericScale := 0; FSigned := false; FIsNullable := false; FDefault := ''; FIsAutoIncrement := false; end; destructor TADOField.Destroy; begin inherited Destroy; end; {$ENDREGION} {$REGION ' - TADOFields - '} procedure TADOFields.GetItems(); var i: integer; begin setLength(FFields, (Owner as TADORecordset).FRecordset.Fields.Count); for i := 0 to (Owner as TADORecordset).FRecordset.Fields.Count-1 do begin FFields[i] := TADOField.Create(Self); FFields[i].FField := (Owner as TADORecordset).FRecordset.Fields[i]; end; end; procedure TADOFields.ClearItems(); var i: integer; begin for i := length(FFields)-1 downto 0 do FFields[i].Free; setlength(FFields,0); end; procedure TADOFields.UpdateItems(); var i: integer; begin for i := 0 to (Owner as TADORecordset).FRecordset.Fields.Count-1 do FFields[i].FField := (Owner as TADORecordset).FRecordset.Fields[i]; end; function TADOFields.GetItemById(const Index: integer): TADOField; begin if Index varNull) and (TVarData(rs.Fields['COLUMN_HASDEFAULT'].Value).vType <> varNull) and rs.Fields['COLUMN_HASDEFAULT'].Value then FFields[rs.Fields['COLUMN_NAME'].Value].FDefault := GetAsUTF8String(rs.Fields['COLUMN_DEFAULT'].Value, rtDump); rs.MoveNext; end; rs.Close; rs := (Owner As TADOConnection).FConnection.OpenSchema(adSchemaIndexes, VarArrayOf([Unassigned, Unassigned, Unassigned, Unassigned, ASelect]), EmptyParam); while not rs.EOF_ do begin if TVarData(rs.Fields['COLUMN_NAME'].Value).vType <> varNull then begin FFields[rs.Fields['COLUMN_NAME'].Value].FIndex := true; if (TVarData(rs.Fields['PRIMARY_KEY'].Value).vType <> varNull) and rs.Fields['PRIMARY_KEY'].Value then FFields[rs.Fields['COLUMN_NAME'].Value].FPrimaryKey := true; end; rs.MoveNext; end; rs.Close; // find a better way to check if a Schema is supported if ((Owner As TADOConnection).Provider = 'Microsoft.Jet.OLEDB.4.0') then begin rs := (Owner As TADOConnection).FConnection.OpenSchema(adSchemaForeignKeys, VarArrayOf([UnAssigned, UnAssigned, ASelect]), EmptyParam); while not rs.EOF_ do begin s := ''; if TVarData(rs.Fields['FK_TABLE_NAME'].Value).vType <> varNull then s := 'REFERENCES `' + GetAsUTF8String(rs.Fields['FK_TABLE_NAME'].Value) + '`'; if TVarData(rs.Fields['FK_COLUMN_NAME'].Value).vType <> varNull then s := s + ' (`' + GetAsUTF8String(rs.Fields['FK_COLUMN_NAME'].Value) + '`)'; FFields[rs.Fields['PK_COLUMN_NAME'].Value].FForeignKey := s; rs.MoveNext; end; rs.Close; end; rs := nil; end; // field properties for i := 0 to Fields.Count-1 do begin case FFields[i].FField.Type_ of adBinary, adBSTR, adChar, adWChar, adVarChar, adVarWChar: FFields[i].FDefinedSize := FFields[i].FField.DefinedSize; adSingle, adDouble, adCurrency, adNumeric, adVarNumeric: begin FFields[i].FPrecision := FFields[i].FField.Precision; FFields[i].FNumericScale := FFields[i].FField.NumericScale; FFields[i].FSigned := (FFields[i].FField.Attributes and adParamSigned)<>0; end; end; FFields[i].FIsNullable := (FFields[i].FField.Attributes and adFldIsNullable)<>0; if FRecordset.CursorLocation <> adUseClient then begin FFields[i].Flcid := GetAsUTF8String(FFields[i].FField.Properties['COLLATINGSEQUENCE'].Value); FFields[i].FBaseTableName := GetAsUTF8String(FFields[i].FField.Properties['BASETABLENAME'].Value); // FFields[i].FDefault := GetAsUTF8String((Owner As TADOConnection).FCatalog.Tables[FFields[i].FField.Properties['BASETABLENAME'].Value].Columns[FFields[i].FField.Name].Properties['Default'].Value, rtDump); FFields[i].FIsAutoIncrement := FFields[i].FField.Properties['ISAUTOINCREMENT'].Value = 'True'; end; end; result := true; end; procedure TADORecordset.Close(); begin if (FRecordset.State = adStateOpen) then FRecordset.Close; end; function TADORecordset.OpenDisconnected(const ASelect: string; ACursorType, ALockType, ACommandType: integer): boolean; begin FRecordset.CursorLocation := adUseClient; result := Open(ASelect, ACursorType, ALockType, ACommandType); FRecordset.Set_ActiveConnection(nil); end; procedure TADORecordset.CloseDisconnected(); begin FRecordset := nil; FRecordset := CoRecordset.Create; FRecordset.Set_ActiveConnection((Owner as TADOConnection).FConnection); end; function TADORecordset.BOF: boolean; begin result := FRecordset.BOF; end; function TADORecordset.EOF: boolean; begin result := FRecordset.EOF_; end; procedure TADORecordset.MoveNext; begin if not FRecordset.EOF_ then FRecordset.MoveNext; FFields.UpdateItems(); end; {$ENDREGION} procedure WriteUTF8ToStream(f: TFileStream; s: UTF8String); begin f.Write(Pchar(s)^, Length(s)); end; procedure CreateDBDump(const Filename: string); var cn: TADOConnection; rs: TADORecordset; s, sInsert, sCreateTable, sPk, sFk, sIndex: UTF8String; f: TFileStream; i, o: integer; begin cn := TADOConnection.Create(nil); if cn.Open('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + Filename) then begin f := TFileStream.Create(ChangeFileExt(Filename, '.sql'), fmOpenWrite or fmCreate); rs := TADORecordset.Create(cn); for o:=0 to cn.Tables.Count-1 do begin sCreateTable := 'DROP TABLE IF EXISTS `' + cn.Tables[o] + '`;'#13#10 + 'CREATE TABLE IF NOT EXISTS `' + cn.Tables[o] + '` ('; ; sInsert := ''; sPk := ''; sFk := ''; sIndex := ''; rs.Open(cn.Tables[o], adOpenForwardOnly, adLockReadOnly, adCmdTable); for i := 0 to rs.Fields.Count-1 do begin sCreateTable := sCreateTable + #13#10' `' + rs.Fields[i].UTF8Name + '`: ' + rs.Fields[i].getTypeAsUTF8String() + IIF(i'', ' ,') + '`' + rs.Fields[i].UTF8Name + '`'; if rs.Fields[i].Index then sIndex := sIndex + IIF(sIndex<>'', ' ,') + '`' + rs.Fields[i].UTF8Name + '`'; if rs.Fields[i].ForeignKey<>'' then sFk := sFk + IIF(sFk<>'', ', ') + 'FOREIGN KEY (`' + rs.Fields[i].UTF8Name + '`) ' + rs.Fields[i].FForeignKey; end; if sPk <> '' then sCreateTable := sCreateTable + ','#13#10' PRIMARY KEY (' + sPk + ')'; if sFk <> '' then sCreateTable := sCreateTable + ','#13#10 + ' ' + sFk; sCreateTable := sCreateTable + ');' + #13#10#13#10; sInsert := 'INSERT INTO `' + cn.Tables[o] + '` (' + sInsert + ')'; WriteUTF8ToStream(f, sCreateTable); while not rs.EOF do begin s := ''; for i := 0 to rs.Fields.Count-1 do s := s + IIF(s<>'', ', ') + GetAsUTF8String(rs.Fields[i].Value, rtDump); WriteUTF8ToStream(f, sInsert + ' VALUES (' + s + ');'#13#10); rs.MoveNext; end; rs.Close; WriteUTF8ToStream(f, #13#10); end; rs.Free; f.Free; cn.Close; end; cn.Free; end; procedure CreateXMLExport(const Filename: string); var cn: TADOConnection; rs: TADORecordset; sPk, sIndex, sFk: UTF8String; f: TFileStream; i, o: integer; begin cn := TADOConnection.Create(nil); if cn.Open('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + Filename) then begin rs := TADORecordset.Create(cn); for o:=0 to cn.Tables.Count-1 do begin rs.Open(cn.Tables[o], adOpenForwardOnly, adLockReadOnly, adCmdTable); f := TFileStream.Create(cn.Tables[o] + '.xml', fmOpenWrite or fmCreate); WriteUTF8ToStream(f, ''#13#10 + // ''#13#10 + ''#13#10 + ' '#13#10 + ' '#13#10); sPk := ''; sFk := ''; sIndex := ''; for i := 0 to rs.Fields.Count-1 do begin WriteUTF8ToStream(f, ' '#13#10); if rs.Fields[i].PrimaryKey then sPk := sPk + IIF(sPk<>'', ', ') + '`' + rs.Fields[i].UTF8Name + '`'; if rs.Fields[i].FForeignKey<>'' then sFk := sFk + IIF(sFk<>'', ', ') + '`' + rs.Fields[i].UTF8Name + '` ' + rs.Fields[i].FForeignKey; if rs.Fields[i].Index then sIndex := sIndex + IIF(sIndex<>'', ', ') + '`' + rs.Fields[i].UTF8Name + '`'; end; WriteUTF8ToStream(f, ' '#13#10 + ' '#13#10 + ' '#13#10); if not rs.EOF then begin WriteUTF8ToStream(f, ' '#13#10); while not rs.EOF do begin WriteUTF8ToStream(f, ' '#13#10); for i := 0 to rs.Fields.Count-1 do WriteUTF8ToStream(f, ' ' + rs.Fields[i].GetValueAsUTF8String(rtXml) + ''#13#10); WriteUTF8ToStream(f, ' '#13#10); rs.MoveNext; end; WriteUTF8ToStream(f, ' '#13#10); end; WriteUTF8ToStream(f, ''); rs.Close; f.Free; end; rs.Free; cn.Close; end; cn.Free; end; begin CreateDBDump(ParamStr(1)); // CreateXMLExport(ParamStr(1)); end.