From 4428a1e68ab23a9b1c306a4dcc0bbeeed6014687 Mon Sep 17 00:00:00 2001 From: reiniero Date: Mon, 15 Jul 2013 11:49:36 +0000 Subject: [PATCH] fcl-db: example program that shows creating, using dbf as well as exporting using dbexport git-svn-id: trunk@25106 - --- .gitattributes | 2 + packages/fcl-db/examples/dbftool.lpi | 72 ++++ packages/fcl-db/examples/dbftool.lpr | 574 +++++++++++++++++++++++++++ 3 files changed, 648 insertions(+) create mode 100644 packages/fcl-db/examples/dbftool.lpi create mode 100644 packages/fcl-db/examples/dbftool.lpr diff --git a/.gitattributes b/.gitattributes index dde5bad364..d2adfdc8db 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1975,6 +1975,8 @@ packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain packages/fcl-db/Makefile svneol=native#text/plain packages/fcl-db/Makefile.fpc svneol=native#text/plain packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain +packages/fcl-db/examples/dbftool.lpi svneol=native#text/plain +packages/fcl-db/examples/dbftool.lpr svneol=native#text/plain packages/fcl-db/examples/fbadmindemo.pp svneol=native#text/plain packages/fcl-db/examples/fbeventstest.pp svneol=native#text/plain packages/fcl-db/examples/loadlibdemo.lpi svneol=native#text/plain diff --git a/packages/fcl-db/examples/dbftool.lpi b/packages/fcl-db/examples/dbftool.lpi new file mode 100644 index 0000000000..0d1ba77adb --- /dev/null +++ b/packages/fcl-db/examples/dbftool.lpi @@ -0,0 +1,72 @@ + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <CommandLineParams Value="--createdemo"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="dbftool.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="dbftool"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="dbftool"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fcl-db/examples/dbftool.lpr b/packages/fcl-db/examples/dbftool.lpr new file mode 100644 index 0000000000..df8f087ce7 --- /dev/null +++ b/packages/fcl-db/examples/dbftool.lpr @@ -0,0 +1,574 @@ +program dbftool; + +{ Reads and exports DBF files. Can create a demo DBF file to test with. + +Demonstrates creating DBF tables, filling it with data, +and exporting datasets. +} + +{$mode objfpc}{$H+} + +uses {$IFDEF UNIX} {$IFDEF UseCThreads} + cthreads, {$ENDIF} {$ENDIF} + Classes, + SysUtils, + CustApp, + DB, + dbf, + dbf_fields, + dbf_common, + dateutils, + fpdbexport, + fpcsvexport, + fpdbfexport, + fpfixedexport, + fprtfexport, + fpsimplejsonexport, + fpsimplexmlexport, + fpsqlexport, + fptexexport, + fpxmlxsdexport; + + +type + + { TDBFTool } + + TDBFTool = class(TCustomApplication) + private + procedure ExportDBF(var MyDbf: TDbf); + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + procedure WriteHelp; virtual; + end; + + procedure CreateDemoDBFs(Directory: string; TableLevel: integer); + // Creates 2 demonstration DBFs in Directory with dbase compatibility level + // TableLevel + // and specified codepage (if not CODEPAGE_NOT_SPECIFIED) + var + NewDBF: TDBF; + i: integer; + begin + + NewDBF := TDBF.Create(nil); + try + if Directory = '' then + NewDBF.FilePath := '' { application directory} + else + NewDBF.FilePathFull := ExpandFileName(Directory) {full absolute path}; + if TableLevel <= 0 then + NewDBF.TableLevel := 4 {default to DBase IV} + else + NewDBF.TableLevel := TableLevel; + + NewDBF.TableName := 'CUSTOMER.DBF'; + writeln('Creating ', NewDBF.TableName, ' with table level ', NewDBF.TableLevel); + if TableLevel >= 30 then + begin + NewDBF.FieldDefs.Add('CUST_NO', ftAutoInc); + end + else + NewDBF.FieldDefs.Add('CUST_NO', ftInteger); + NewDBF.FieldDefs.Add('CUSTOMER', ftString, 25); + NewDBF.FieldDefs.Add('CITY', ftString, 25); + NewDBF.FieldDefs.Add('COUNTRY', ftString, 15); + NewDBF.CreateTable; + NewDBF.Open; + + for i := 1 to 5 do //keep size manageable until we have working files + begin + NewDBF.Append; + if (NewDBF.FieldDefs.Find('CUST_NO').DataType <> ftAutoInc) then + NewDBF.FieldByName('CUST_NO').AsInteger := i; + case i of + 1: + begin + NewDBF.FieldByName('CUSTOMER').AsString := 'Michael Design'; + NewDBF.FieldByName('CITY').AsString := 'San Diego'; + NewDBF.FieldByName('COUNTRY').AsString := 'USA'; + end; + 2: + begin + NewDBF.FieldByName('CUSTOMER').AsString := 'Michael Design'; + NewDBF.FieldByName('CITY').AsString := 'San Diego'; + NewDBF.FieldByName('COUNTRY').AsString := 'USA'; + end; + 3: + begin + NewDBF.FieldByName('CUSTOMER').AsString := 'VC Technologies'; + NewDBF.FieldByName('CITY').AsString := 'Dallas'; + NewDBF.FieldByName('COUNTRY').AsString := 'USA'; + end; + 4: + begin + NewDBF.FieldByName('CUSTOMER').AsString := 'Klämpfl, Van Canneyt'; + NewDBF.FieldByName('CITY').AsString := 'Boston'; + NewDBF.FieldByName('COUNTRY').AsString := 'USA'; + end; + 5: + begin + NewDBF.FieldByName('CUSTOMER').AsString := 'Felipe Bank'; + NewDBF.FieldByName('CITY').AsString := 'Manchester'; + NewDBF.FieldByName('COUNTRY').AsString := 'England'; + end; + end; + NewDBF.Post; + end; + NewDBF.Close; + finally + NewDBF.Free; + end; + + NewDBF := TDBF.Create(nil); + try + if Directory = '' then + NewDBF.FilePath := '' { application directory} + else + NewDBF.FilePathFull := ExpandFileName(Directory) {full absolute path}; + if TableLevel <= 0 then + NewDBF.TableLevel := 4 {default to DBase IV} + else + NewDBF.TableLevel := TableLevel; + + NewDBF.TableName := 'EMPLOYEE.DBF'; + writeln('Creating ', NewDBF.TableName, ' with table level ', NewDBF.TableLevel); + if TableLevel >= 30 then + begin + NewDBF.FieldDefs.Add('EMP_NO', ftAutoInc); + end + else + NewDBF.FieldDefs.Add('EMP_NO', ftInteger); + NewDBF.FieldDefs.Add('FIRST_NAME', ftString, 15); + NewDBF.FieldDefs.Add('LAST_NAME', ftString, 20); + NewDBF.FieldDefs.Add('PHONE_EXT', ftString, 4); + NewDBF.FieldDefs.Add('JOB_CODE', ftString, 5); + NewDBF.FieldDefs.Add('JOB_GRADE', ftInteger); + NewDBF.FieldDefs.Add('JOB_COUNTR', ftString, 15); //Note 10 character limit for table/field names in most DBases + NewDBF.FieldDefs.Add('SALARY', ftFloat); + NewDBF.CreateTable; + NewDBF.Open; + + for i := 1 to 5 do //keep size manageable until we have working files + begin + NewDBF.Append; + if (NewDBF.FieldDefs.Find('EMP_NO').DataType <> ftAutoInc) then + NewDBF.FieldByName('EMP_NO').AsInteger := i; + case i of + 1: + begin + NewDBF.FieldByName('FIRST_NAME').AsString := 'William'; + NewDBF.FieldByName('LAST_NAME').AsString := 'Shatner'; + NewDBF.FieldByName('PHONE_EXT').AsString := '1702'; + NewDBF.FieldByName('JOB_CODE').AsString := 'CEO'; + NewDBF.FieldByName('JOB_GRADE').AsInteger := 1; + NewDBF.FieldByName('JOB_COUNTR').AsString := 'USA'; + NewDBF.FieldByName('SALARY').AsFloat := 48000; + end; + 2: + begin + NewDBF.FieldByName('FIRST_NAME').AsString := 'Ivan'; + NewDBF.FieldByName('LAST_NAME').AsString := 'Ishenin'; + NewDBF.FieldByName('PHONE_EXT').AsString := '9802'; + NewDBF.FieldByName('JOB_CODE').AsString := 'Eng'; + NewDBF.FieldByName('JOB_GRADE').AsInteger := 2; + NewDBF.FieldByName('JOB_COUNTR').AsString := 'Russia'; + NewDBF.FieldByName('SALARY').AsFloat := 38000; + end; + 3: + begin + NewDBF.FieldByName('FIRST_NAME').AsString := 'Erin'; + NewDBF.FieldByName('LAST_NAME').AsString := 'Powell'; + NewDBF.FieldByName('PHONE_EXT').AsString := '1703'; + NewDBF.FieldByName('JOB_CODE').AsString := 'Admin'; + NewDBF.FieldByName('JOB_GRADE').AsInteger := 2; + NewDBF.FieldByName('JOB_COUNTR').AsString := 'USA'; + NewDBF.FieldByName('SALARY').AsFloat := 45368; + end; + 4: + begin + NewDBF.FieldByName('FIRST_NAME').AsString := 'Margaret'; + NewDBF.FieldByName('LAST_NAME').AsString := 'Tetchy'; + NewDBF.FieldByName('PHONE_EXT').AsString := '3804'; + NewDBF.FieldByName('JOB_CODE').AsString := 'Eng'; + NewDBF.FieldByName('JOB_GRADE').AsInteger := 3; + NewDBF.FieldByName('JOB_COUNTR').AsString := 'England'; + NewDBF.FieldByName('SALARY').AsFloat := 28045; + end; + 5: + begin + NewDBF.FieldByName('FIRST_NAME').AsString := 'Sergey'; + NewDBF.FieldByName('LAST_NAME').AsString := 'Bron'; + NewDBF.FieldByName('PHONE_EXT').AsString := '3807'; + NewDBF.FieldByName('JOB_CODE').AsString := 'Admin'; + NewDBF.FieldByName('JOB_GRADE').AsInteger := 3; + NewDBF.FieldByName('JOB_COUNTR').AsString := 'England'; + NewDBF.FieldByName('SALARY').AsFloat := 24468; + end; + end; + NewDBF.Post; + end; + NewDBF.Close; + finally + NewDBF.Free; + end; + end; + + procedure GetDBFList(Results: TStringList); + // Gets list of all .dbf files in a directory and its subdirectories. + var + r: TSearchRec; + begin + results.Clear; + if FindFirst('*.dbf', faAnyFile - +{$WARNINGS OFF} + faVolumeID - faSymLink +{$WARNINGS ON} + , r) = 0 then + begin + repeat + if (r.Attr and faDirectory) <> faDirectory then + begin + results.add(expandfilename(r.Name)); + end; + until (FindNext(r) <> 0); + findclose(r); + end; + end; + + function BinFieldToHex(BinarySource: TField): string; + // Convert binary field contents to strings with hexadecimal representation. + // Useful for displaying binary field contents. + var + HexValue: PChar; + begin + Result := ''; + HexValue := StrAlloc(Length(BinarySource.AsBytes)); + try + try + BinToHex(PChar(BinarySource.AsBytes), HexValue, Length(BinarySource.AsBytes)); + Result := 'size: ' + IntToStr(Length(BinarySource.AsBytes)) + '; hex: ' + HexValue; + except + on E: Exception do + begin + Result := 'exception: ' + E.ClassName + '/' + E.Message; + end; + end; + finally + StrDispose(HexValue); + end; + end; + + procedure PrintRecord(DBf: TDBf; RecordNumber: integer); + // Prints contents of a record to screen + var + i: integer; + begin + writeln('Record ' + IntToStr(RecordNumber)); + for i := 0 to DBf.Fields.Count - 1 do + begin + if DBF.fields[i].IsNull then + writeln('Field ', DBf.Fields[i].FieldName, ' is ***NULL***') + else + if DBF.Fields[i].DataType in [ftVarBytes, ftBytes] then + writeln('Field ', DBF.Fields[i].FieldName, ' has value: binary ' + BinFieldToHex(DBF.Fields[i])) + else + writeln('Field ', DBf.Fields[i].FieldName, ' has value: ' + DBf.fields[i].AsString); + end; + end; + + { TDBFTool } + + procedure TDBFTool.ExportDBF(var MyDbf: TDbf); + // Exports recordset to another format depending on user selection + var + ExportFormatText: string; + ExportSettings: TCustomExportFormatSettings; + Exporter: TCustomFileExporter; + begin + ExportFormatText := UpperCase(GetOptionValue('exportformat')); + try + case ExportFormatText of + 'ACCESS', 'MSACCESS': + begin + Exporter := TXMLXSDExporter.Create(nil); + ExportSettings := TXMLXSDFormatSettings.Create(true); + (ExportSettings as TXMLXSDFormatSettings).CreateXSD := true; + (ExportSettings as TXMLXSDFormatSettings).ExportFormat := + AccessCompatible; + (ExportSettings as TXMLXSDFormatSettings).DecimalSeparator := '.'; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.xml'); + end; + 'ADO', 'ADONET', 'ADO.NET': + begin + Exporter := TXMLXSDExporter.Create(nil); + ExportSettings := TXMLXSDFormatSettings.Create(true); + (ExportSettings as TXMLXSDFormatSettings).CreateXSD := true; + (ExportSettings as TXMLXSDFormatSettings).ExportFormat := + ADONETCompatible; + (ExportSettings as TXMLXSDFormatSettings).DecimalSeparator := '.'; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.xml'); + end; + 'CSVEXCEL', 'EXCELCSV', 'CREATIVYST': + begin + Exporter := TCSVExporter.Create(nil); + ExportSettings := TCSVFormatSettings.Create(true); + (ExportSettings as TCSVFormatSettings).RowDelimiter:=LineEnding; + //todo: delimiter? + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.csv'); + end; + 'CSV', 'CSVRFC4180', 'CSVLIBRE', 'CSVLIBREOFFICE': + begin + Exporter := TCSVExporter.Create(nil); + ExportSettings := TCSVFormatSettings.Create(true); + (ExportSettings as TCSVFormatSettings).DecimalSeparator := '.'; + (ExportSettings as TCSVFormatSettings).StringQuoteChar := '"'; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.csv'); + end; + 'DATASET', 'DELPHI': + begin + Exporter := TXMLXSDExporter.Create(nil); + ExportSettings := TXMLXSDFormatSettings.Create(true); + (ExportSettings as TXMLXSDFormatSettings).ExportFormat := + DelphiClientDataset; + (ExportSettings as TXMLXSDFormatSettings).DecimalSeparator := '.'; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.xml'); + end; + 'EXCEL', 'EXCELXML': + begin + Exporter := TXMLXSDExporter.Create(nil); + ExportSettings := TXMLXSDFormatSettings.Create(true); + (ExportSettings as TXMLXSDFormatSettings).ExportFormat := ExcelCompatible; + (ExportSettings as TXMLXSDFormatSettings).DecimalSeparator := '.'; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.xml'); + end; + 'JSON': + begin + Exporter := TSimpleJSONExporter.Create(nil); + ExportSettings := TSimpleJSONFormatSettings.Create(true); + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.json'); + end; + 'SIMPLEXML', 'XML': + begin + Exporter := TSimpleXMLExporter.Create(nil); + ExportSettings := TSimpleXMLFormatSettings.Create(true); + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.xml'); + end; + 'RTF': + begin + Exporter := TRTFExporter.Create(nil); + ExportSettings := TSimpleXMLFormatSettings.Create(true); + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.rtf'); + end; + 'SQL': + begin + Exporter := TSQLExporter.Create(nil); + ExportSettings := TSQLFormatSettings.Create(true); + (ExportSettings as TSQLFormatSettings).QuoteChar := '"'; + (ExportSettings as TSQLFormatSettings).DecimalSeparator := '.'; + (ExportSettings as TSQLFormatSettings).TableName := ChangeFileExt(MyDBF.TableName,''); + (ExportSettings as TSQLFormatSettings).DateFormat := 'yyyy"-"mm"-"dd'; //ISO 8601, yyyy-mm-dd + (ExportSettings as TSQLFormatSettings).TimeFormat := 'hh":"nn":"ss'; //ISO 8601, hh:mm:ss; + (ExportSettings as TSQLFormatSettings).DateTimeFormat := + (ExportSettings as TSQLFormatSettings).DateFormat + '"T"' + (ExportSettings as TSQLFormatSettings).TimeFormat; //ISO 8601 + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.sql'); + end; + 'TEX', 'LATEX': + begin + Exporter := TTeXExporter.Create(nil); + ExportSettings := TTeXExportFormatSettings.Create(true); + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.tex'); + end; + 'TEXT', 'FIXED', 'FIXEDTEXT': + begin + Exporter := TFixedLengthExporter.Create(nil); + ExportSettings := nil; + Exporter.FileName := MyDBF.FilePathFull + ChangeFileExt(MyDBF.TableName, '.txt'); + end + else + begin + writeln('***Error: Unknown export format ' + ExportFormatText + ' specified' + '. Aborting'); + Exporter := nil; + ExportSettings := nil; + Terminate; + Exit; + end; + end; + if assigned(ExportSettings) then + Exporter.FormatSettings := ExportSettings; + Exporter.Dataset := MyDBF; + MyDBF.First; // we've just read the last record - make sure export starts at beginning + Exporter.Execute; + writeln('Completed export to ' + Exporter.FileName); + finally + if assigned(Exporter) then + Exporter.Free; + if assigned(ExportSettings) then + ExportSettings.Free; + end; + end; + + procedure TDBFTool.DoRun; + var + DBFs: TStringList; + Demo: boolean; + ErrorMsg: string; + FileNo: integer; + MyDbf: TDbf; + RecCount: integer; + TableLevel: integer; //todo: use it + begin + // quick check parameters + ErrorMsg := CheckOptions('h', 'codepage: createdemo exportformat: help tablelevel:'); + if ErrorMsg <> '' then + begin + ShowException(Exception.Create(ErrorMsg)); + Terminate; + Exit; + end; + + // parse parameters + if HasOption('h', 'help') then + begin + WriteHelp; + Terminate; + Exit; + end; + + DBFs := TStringList.Create; + try + Demo := false; + if HasOption('createdemo') then + Demo := true; + + TableLevel := 4; //DBF + if HasOption('tablelevel') then + TableLevel := StrToIntDef(GetOptionValue('tablelevel'), 4); + + if Demo then + begin + try + CreateDemoDBFs('', TableLevel); + except + on E: Exception do + begin + writeln('*** Error creating demo databases: ' + E.Message); + Terminate; + Exit; + end; + end; + end; + + // Process all dbfs if no files specified + if DBFs.Count = 0 then + GetDBFList(DBFs); + + if DBFs.Count = 0 then + writeln('Could not find any dbf files'); + + for FileNo := 0 to DBFs.Count - 1 do + begin + if not (fileexists(DBFs[FileNo])) then + begin + // for some reason, fpc trunk suddenly returns the directory as well... + //writeln('Sorry, file ',DBFs[FileNo],' does not exist.'); + break; + end; + MyDbf := TDbf.Create(nil); + try + try + MyDbf.FilePath := ExtractFilePath(DBFs[FileNo]); + MyDbf.TableName := ExtractFileName(DBFs[FileNo]); + MyDbf.ReadOnly := true; + writeln('*** Opening: ' + DBFs[FileNo]); + MyDbf.Open; + writeln('Database tablelevel: ' + IntToStr(MyDbf.TableLevel)); + writeln('Database codepage: ' + IntToStr(MyDBF.CodePage)); + + RecCount := 1; + while not (MyDbf.EOF) do + begin + PrintRecord(MyDBF, RecCount); + MyDBF.Next; + RecCount := RecCount + 1; + writeln(''); + end; + + if HasOption('exportformat') then + begin + try + ExportDBF(MyDbf); + except + on E: Exception do + begin + writeln('*** Problem exporting file ', FileNo, ': ', E.Message); + end; + end; + end; + + MyDbf.Close; + except + on E: Exception do + begin + writeln('*** Error reading file ', FileNo, ': ', E.Message); + end; + end; + finally + MyDbf.Free; + end; + end; + finally + DBFs.Free; + end; + + // stop program loop + Terminate; + end; + + constructor TDBFTool.Create(TheOwner: TComponent); + begin + inherited Create(TheOwner); + StopOnException := true; + end; + + destructor TDBFTool.Destroy; + begin + inherited Destroy; + end; + + procedure TDBFTool.WriteHelp; + begin + writeln('Usage: ', ExeName, ' -h'); + writeln(' --createdemo create demo database'); + writeln(' --tablelevel=<n> optional: desired tablelevel for demo db'); + writeln(' 3 DBase III'); + writeln(' 4 DBase IV'); + writeln(' 7 Visual DBase 7'); + writeln(' 25 FoxPro 2.x'); + writeln(' 30 Visual FoxPro'); + writeln(' --exportformat=<text> export dbfs to format. Format can be:'); + writeln(' access Microsoft Access XML'); + writeln(' adonet ADO.Net dataset'); + writeln(' csvexcel Excel/Creativyst format CSV text file (with locale dependent output)'); + writeln(' csvRFC4180 LibreOffice/RFC4180 format CSV text file'); + writeln(' dataset Delphi dataset XML'); + writeln(' excel Microsoft Excel XML'); + writeln(' fixedtext Fixed length text file'); + writeln(' json JSON file'); + writeln(' rtf Rich Text Format'); + writeln(' simplexml Simple XML'); + writeln(' sql SQL insert statements'); + writeln(' tex LaTeX file'); + end; + +var + Application: TDBFTool; +begin + Application := TDBFTool.Create(nil); + Application.Title := 'DBFTool'; + Application.Run; + Application.Free; +end.