unit QExport4DBF;

{$I QExport4VerCtrl.inc}

interface

uses QExport4, Classes, SysUtils, QExport4IniFiles;

const
  dBaseIII = $03;
  dBaseIIIMemo = $83;
  dBaseIVMemo = $8B;
  dBaseIVSQL = $63;
  FoxPro = $05;
  FoxProMemo = $F5;

  dftString  = 'C';  // char (symbol(s))
  dftBoolean = 'L';  // boolean
  dftNumber  = 'N';  // number
  dftDate    = 'D';  // date
  dftMemo    = 'M';  // memo
  dftFloat   = 'F';  // float -- not in DBaseIII

  MAX_FIELD_NAME_LEN = 10;

type

  TFieldName = array[1..MAX_FIELD_NAME_LEN] of AnsiChar;

  TDBFHeader = packed record { *** First record ***  L=32 }
   {+0} DBType,
   {+1} Year,
   {+2} Month,
   {+3} Day: Byte;
   {+4} RecCount: LongInt;
   {+8} HeaderSize: Word;
   {+10} RecordSize: Longint;
   {+14} FDelayTrans: Byte;
   {+15} Reserve2: array[1..13] of Byte;
   {+28} FlagMDX: Byte;
   {+29} Reserve3: array[1..3] of Byte;
  end;

  PDBFFieldDescriptor = ^TDBFFieldDescriptor;
  TDBFFieldDescriptor = packed record { *** Field Descriptor *** L= 32 }
    {+0}  FieldName: TFieldName;
(*dee    {+10} FieldEnd: Char;
    {+11} FieldType: Char;
*)
    {+10} FieldEnd: AnsiChar;
    {+11} FieldType: AnsiChar;
    {+12} FieldDisp: LongInt;
    {+16} FieldLen,
    {+17} FieldDec: Byte;
    {+18} A1: array[1..13] of Byte;
    {+31} FlagTagMDX: Byte;
  end;

  //TMemoType = (mtNone, mtDBT, mtFPT);
  TQExport4DBF = class;

  TQDBFWriter = class(TQExportWriter)
  private
    DBFHeader: TDBFHeader;
    DList: TList;
    {$IFDEF QE_UNICODE}
    FExportCharsetType: TQExportCharsetType;
    {$ENDIF}
    MemoStream: TFileStream;
    MemoRecord: PByteArray;
    NextMemoRecord: integer;

    function GetDBFExport: TQExport4DBF;
  protected
    property DBFExport: TQExport4DBF read GetDBFExport;
  public
    constructor Create(AOwner: TQExport4; AStream: TStream); override;
    destructor Destroy; override;
    procedure AddFieldDef(Descriptor: PDBFFieldDescriptor);
    procedure CreateDBF;
    procedure DestroyDBF;
{$IFDEF VCL12}
    procedure WriteData(Num: integer; const AData: string);
{$ELSE}
    procedure WriteData(Num: integer; const Data: String);
{$ENDIF}
    function WriteMemo(Index: integer): integer;
    {$IFDEF QE_UNICODE}
    property ExportCharsetType: TQExportCharsetType read FExportCharsetType write
        FExportCharsetType;
    {$ENDIF}
  end;

  TQExport4DBF = class(TQExport4Text)
  private
    FColumnsPrecision: TStrings;
    FOldDecimalSeparator: char;
    FDefaultFloatSize: integer;
    FDefaultFloatDecimal: integer;
    FExportTimeAsStr: Boolean;
    function GetMemoFileName: string;
    function GetNullValue: string;
    procedure SetNullValue(const Value: string);
    procedure SetColumnsPrecision(Value: TStrings);
    procedure GetColumnSizeDecimal(const ColumnName: string; var Size,
      Decimal: integer);
  protected
    function GetWriterClass: TQExportWriterClass; override;
    function GetWriter: TQDBFWriter;

    procedure BeginExport; override;
    procedure EndExport; override;
    procedure BeforeExport; override;
    procedure AfterExport; override;

    procedure WriteDataRow; override;
    procedure SaveProperties(IniFile: TQIniFile); override;
    procedure LoadProperties(IniFile: TQIniFile); override;

    property MemoFileName: string read GetMemoFileName;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Captions;
    property ColumnsLength;
    property ColumnsPrecision: TStrings read FColumnsPrecision
      write SetColumnsPrecision;
    property DefaultFloatSize: integer read FDefaultFloatSize
      write FDefaultFloatSize default 15;
    property DefaultFloatDecimal: integer read FDefaultFloatDecimal
      write FDefaultFloatDecimal default 4;
    property ExportTimeAsStr: Boolean read FExportTimeAsStr write FExportTimeAsStr;
    property NullValue: string read GetNullValue write SetNullValue;
  end;

  TShortFieldNameGenerator = class
  private
    FFieldNames: TStringList;
    function GetNumberString(const AValue: Integer): string;
    function IncNumberString(const AValue: string): string;
  public
    constructor Create;
    destructor Destroy; override;
    function GetShortFieldName(AFieldName: string): string;
  end;

implementation

uses QExport4Common, DB, QExport4Types{$IFDEF VCL9}, Windows{$ENDIF}, Math;

{ TQDBFWriter }

procedure TQDBFWriter.AddFieldDef(Descriptor: PDBFFieldDescriptor);
begin
  DList.Add(Descriptor);
end;

constructor TQDBFWriter.Create(AOwner: TQExport4; AStream: TStream);
begin
  inherited;
  DList := TList.Create;
end;

procedure TQDBFWriter.CreateDBF;
var
  B: Byte;
  I: Integer;
  Y, M, D : Word;
begin
  FillChar(DBFHeader, 32, #0);
  DecodeDate(Date, Y, M, D);
  with DBFHeader do
  begin
    if (Owner as TQExport4DBF).Columns.ContainsBLOB and
       (Stream is TFileStream) then
    begin
      DBType := dBaseIIIMemo;
      MemoStream := TFileStream.Create((Owner as TQExport4DBF).MemoFileName, fmCreate);
      GetMem(MemoRecord, 512);
      FillChar(MemoRecord^, 512, #0);
      MemoStream.WriteBuffer(MemoRecord^, 512);
      NextMemoRecord := 1;
    end
    else DBType := dBaseIII;

    Year := Y - 2000;
    Month := M;
    Day := D;
    HeaderSize := (DList.Count + 1) * 32 + 1;
    RecordSize := 1;
    for I := 0 to DList.Count - 1 do
      RecordSize := RecordSize + PDBFFieldDescriptor(DList[I])^.FieldLen;
  end;
  Stream.WriteBuffer(DBFHeader, SizeOf(DBFHeader));
  for I := 0 to DList.Count - 1 do
    Stream.WriteBuffer(PDBFFieldDescriptor(DList[I])^, 32);
  B := $0D; // End of DBF Header
  Stream.WriteBuffer(B, SizeOf(B));
end;

destructor TQDBFWriter.Destroy;
var
  i: Integer;
begin
  for i := 0 to DList.Count - 1 do
    if Assigned(DList.Items[i]) then
      Dispose(PDBFFieldDescriptor(DList.Items[i]));
  DList.Free;
  inherited;
end;

procedure TQDBFWriter.DestroyDBF;
begin
  if Assigned(MemoStream) then begin
    MemoStream.Seek(0, soFromBeginning);
    MemoStream.Write(NextMemoRecord, SizeOf(Integer));
    MemoStream.Free;
  end;
end;

function TQDBFWriter.GetDBFExport: TQExport4DBF;
begin
  Result := Owner as TQExport4DBF;
end;

{$IFDEF VCL12}
procedure TQDBFWriter.WriteData(Num: integer; const AData: string);
{$else}
procedure TQDBFWriter.WriteData(Num: integer; const Data: string);
{$endif}

  {$IFDEF QE_UNICODE}
  procedure WriteUsingCharset(WS: WideString);
  var
    s: AnsiString;
  begin
    if not Assigned(Owner) then
      Exit;
    if WS = EmptyStr then
      Exit;

    case ExportCharsetType of
      ectLocalANSI, ectLocalOEM, ectLocalMAC:
        begin
          s := WideStringToString(WS, Integer(ExportCharsetType));
          if length(s) > length(ws) then
            SetLength(s, Length(ws));
          Stream.WriteBuffer(s[1], Length(s));
        end;
      ectUTF8:
        begin
          s := UTF8Encode(WS);
          if length(s) > length(ws) then
            SetLength(s, Length(ws));
          Stream.WriteBuffer(s[1], Length(s));
        end;
    end;
  end;
  {$ENDIF}

const
  NewRecordMarker: Byte = $20;
  STrue  = 'TRUE';
  SFalse = 'FALSE';
  SDBFTrue  = 'T';
  SDBFFalse = 'F';
var
  CurPos, RCount: integer;
{$IFDEF VCL12}
  Data: AnsiString;
{$ENDIF}
  _Data: AnsiString;
  DD: TDateTime;
begin
{$IFDEF VCL12}
  Data := AnsiString(AData);
{$ENDIF}
  SetLength(_Data, PDBFFieldDescriptor(DList[Num])^.FieldLen);
  FillChar(_Data[1], Length(_Data), ' ');
  if string(Data) <> EmptyStr then begin
    case PDBFFieldDescriptor(DList[Num])^.FieldType of
      dftString:
          if Length(Data) > 254 // !!!
            then Move(Data[1], _Data[1], 254) // !!!
            else Move(Data[1], _Data[1], Length(Data));
      dftNumber:
         begin
           Move(Data[1], _Data[Max(Length(_Data) - Length(Data) + 1, 1)], Length(Data));
         end;
      dftDate: begin
          DD := StrToDateTime(string(Data));
          _Data := AnsiString(FormatDateTime('yyyymmdd', DD));
         if string(_Data) = EmptyStr then begin
           SetLength(_Data, 8);
           FillChar(_Data[1], 8, ' ');
         end;
      end;
      dftBoolean: begin
        if Pos(STrue, UpperCase(string(Data))) > 0 then
          _Data[1] := SDBFTrue
        else
        if Pos(SFalse, UpperCase(string(Data))) > 0 then
          _Data[1] := SDBFFalse
        else
          _Data[1] := ' ';
      end;
    end;
  end;
  if Num = 0 then begin
      Stream.WriteBuffer(NewRecordMarker, 1); // it's new record
      // update record count
      CurPos := Stream.Position; // save current position
      Stream.Position := 4;
      Stream.ReadBuffer(RCount, 4);
      Inc(RCount);
      Stream.Position := 4;
      Stream.WriteBuffer(RCount, 4);
      Stream.Position := CurPos; // restore current position
  end;
  {$IFDEF QE_UNICODE}
  WriteUsingCharset(string(_Data)); //alex c - 桉鐿朦珞弳