Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kompon/d356/SDFDATA.ZIP/SdfData.pas

Pascal/Delphi Source File | 2001-07-20 | 21KB | 580 lines

unit SdfData;
{-----------------------------------------------------------------------------}
{ Name        : SdfData                                                       }
{ Application : TBaseTextDataSet TSdfDataSet TFixedFormatDataSet Components   }
{ Version     : 1.03                                                          }
{ Author      : Orlando Arrocha           email: [e-mail]         }
{ Date        : Jan 2001                                                      }
{ Purpose     : This components are enhancements of the Borland's Sample      }
{               TTextDataSet to access delimited (CSV/SDF) and fixed text     }
{               files as if they where database tables.                       }
{ ---------------                                                             }
{  Modifications                                                              }
{ ---------------                                                             }
{ 19/Jul/01  Version 1.03 (Orlando Arrocha)                                   }
{            TBaseTextDataSet class introduced.                               }
{            FileName property changed datatype to TFileName and removed the  }
{                 property editor to segregate design-time code from runtime  }
{                 units.                                                      }
{                 To add file browsing functionality please install           }
{                 TFileNamePropertyEditor -- also freeware.                   }
{            Bug Fixed - TSdfDataSet FieldNames were filled with the first    }
{                 line record even when FirstLineAsSchema was FALSE           }
{            Bug Fixed - TFixedFormatDataSet values were filled with garbage  }
{                 when record line were smaller than defined on schema.       }
{            Demo Project introduced.                                         }
{                                           ********** THANKS WAYNE ********* }
{ 18/Jun/01  Version 1.02 (Wayne Brantley)                                    }
{            SchemaFileName property replaced with a Schema StringList        }
{               property.  Same as SchemaFileName, except you can define the  }
{               schema inside the component.   If you still need an external  }
{               file, just use Schema.LoadFromFile()                          }
{            TFixedFormatDataSet class introduced.  Use this class for a      }
{               Fixed length format file (instead of delimited).  The full    }
{               schema definition (including lengths) is obviously required.  }
{            Bug Fixed - When FirstLineSchema is true and there were no       }
{               records, it would display garbage.                            }
{                                                                             }
{ 30/Mar/01  Version 1.01 (Orlando Arrocha)                                   }
{                 Ligia Maria Pimentel suggested to use the first line of the }
{                 file to define the field names.  ****** THANKS LIGIA ****** }
{            Property editor for file names.                                  }
{                  You'll see the [...] button on the Object inspector        }
{            FileMustExist property.                                          }
{                 I've modified the program to let the component create new   }
{                 files, and considered that it could led to udesirable files }
{                 sometimes. So you must put this property to false if you    }
{                 want to create a new file.                                  }
{            FirstLineSchema property.                                        }
{                 As Ligia suggested, you can define the field names on the   }
{                 first line of your file. I added the field size support and }
{                 the schema file (see below).                                }
{                 Fields have to be defined with this format                  }
{                    <field_name1> [= field_size1] , <field_name2> [= field_size2] ... }
{                  NOTE: Do not leave spaces                                   }
{            SchemaFileName property.  (Changed to Schema by 1.02 Wayne)      }
{                  Lets you define the fields attributes (only supports field }
{                   name and size). Have to be defined in this format         }
{                     One field per line :  <field_name> [= field_size]       }
{                  NOTE: fields that doesn't define the length get the record }
{                        size.                                                }
{            RemoveBlankRecords procedure.                                    }
{                  Removes all the blank records from the file.               }
{            RemoveExtraColumns procedure                                     }
{                  If the schema have less columns than the file, it remove   }
{                  the extra values to make consistent the fields to the      }
{                  scheme.                                                    }
{                  NOTE: If you don't call this procedure, extra columns will }
{                        remain in file, but they won't be shown on dataset   }
{            SaveFileAs(strFileName : String) procedure                       }
{                  Let you save the file to another filename.                 }
{                  NOTE: TTextDataSet component doesn't save changes until    }
{                        you close the table. So you can use this to force    }
{                        writting.                                            }
{ ---------                                                                   }
{  TERMS                                                                      }
{ ---------                                                                   }
{   This component is provided AS-IS without any warranty of any kind, either }
{   express or implied. This component is freeware and can be used in any     }
{   software product. Credits on applications used will be welcomed.          }
{   If you find it useful, improve it or have a wish list ... please drop me  }
{   a mail, I'll be glad to hear your comments.                               }
{ ----------------                                                            }
{  How to Install                                                             }
{ ----------------                                                            }
{   1. Copy this SDFDATA.PAS and the associated SDFDATA.DCR to the folder     }
{      from where you wish to install the component. This will probably be    }
{      $(DELPHI)\Projects\BPL or a sub-folder of the $(DELPHI)\lib folder.    }
{   2. Copy to the same folder (the one choosen before) the files             }
{        $(DELPHI)\Demos\DB\Textdata\Textdata.*  (3 files - .pas, .res, .rc)  }
{        $(DELPHI)\Demos\DB\Textdata\Textpkg.*   (2 files - .dpk, .res)       }
{   3. Make the modifications noted under TEXTDATA.PAS Modifications          }
{      subtitle. Note -- change only your copied files.                       }
{   4. Install TEXTPKG.DPL by choosing the File | Open menu option.           }
{   5. Select Delphi Package (.dpk) filter on the Open File dialog and browse }
{      for TEXTPKG.DPK.                                                       }
{   6. Press the Install button and close the window.                         }
{   7. Install the TSdfDataSet and TFixedFormatDataSet components by choosing }
{      the Component | Install Component menu option.                         }
{   8. Select the "Into exisiting package" page of the Install Components     }
{      dialogue box.                                                          }
{   9. Browse to the folder where you saved this file and select it.          }
{  10. Ensure that the "Package file name" edit box contains                  }
{      $...\TEXTPKG.DPK                                                        }
{  11. Accept that the package will be rebuilt.                               }
{                                                                             }
{ ******************                                                          }
{ * VERY IMPORTANT *                                                          }
{ ******************                                                          }
{       You have to modify the file TEXTDATA.PAS, included in the DB Demos,   }
{       as indicated behind (under TEXTDATA.PAS Modifications) and then       }
{       compile and install TextPKG.DPK in order to install this component.   }
{                                                                             }
{ ==========================                                                  }
{ TEXTDATA.PAS Modifications                                                  }
{ ==========================           MAKE A BACKUP OF TEXTDATA.PAS FIRST    }
{                                                                             }
{ Line : 327 in Function GetRecord                                            }
{   -- Line says --                                                           }
{     StrLCopy(Buffer, PChar(FData[FCurRec]), MaxStrLen);                     }
{                                             ^^^^^^^^^                       }
{   -- must say  --                                                           }
{     StrLCopy(Buffer, PChar(FData[FCurRec]), GetRecordSize);                 }
{                                             ^^^^^^^^^^^^^                   }
{                                                                             }
{ Line : 79 in TTextDataSet class Declaration                                 }
{   -- Line says --                                                           }
{ private                                                                     }
{ ^^^^^^^                                                                     }
{   -- must say  --                                                           }
{ protected                                                                   }
{ ^^^^^^^^^                                                                   }
{                                                                             }
{-----------------------------------------------------------------------------}

interface

uses
  Classes, SysUtils, DB, TextData;

type
  { TBaseTextDataSet }
  TBaseTextDataSet = class(TTextDataSet)
  private
    FRecordSize : Integer;
    FSchema: TStringList;
    FFileMustExist : Boolean;
    FFileName : TFileName;
    function ReadSchema: TStringList;
    procedure WriteSchema(const Value: TStringList);
    procedure SetFileName(Value : TFileName);
    procedure SetFileMustExist(Value : Boolean);
    procedure RemoveWhiteLines(List : TStrings; IsFileRecord : Boolean);
  protected
    { Overriden abstract methods }
    procedure InternalOpen; override;
    procedure InternalInitFieldDefs; override;
    function GetRecordSize: Word; override;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure RemoveBlankRecords;
    procedure SaveFileAs(strFileName : String);
  published
    property FileMustExist: Boolean read FFileMustExist write SetFileMustExist;
    property FileName : TFileName read FFileName write SetFileName;
    property Schema: TStringList read ReadSchema write WriteSchema;
  end;

{ TSdfDataSet }

  TSdfDataSet = class(TBaseTextDataSet)
  private
    FFirstLineAsSchema : Boolean;
    procedure SetFirstLineAsSchema(Value : Boolean);
  protected
    procedure InternalInitFieldDefs; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean)
             : TGetResult; override;
  public
    procedure RemoveExtraColumns;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  published
    property FirstLineAsSchema: Boolean read FFirstLineAsSchema write SetFirstLineAsSchema;
  end;


{ TFixedFormatDataSet }

  TFixedFormatDataSet = class(TBaseTextDataSet)
  protected
    procedure InternalOpen; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
  public
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  end;


procedure Register;

implementation

const
 DELIMITERS_GAP = 4;

{ TBaseTextDataSet }

constructor TBaseTextDataSet.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  FFileMustExist := TRUE;
  FSchema:=TStringList.Create;
end;

destructor TBaseTextDataSet.Destroy;
begin
  FSchema.Free;
  inherited Destroy;
end;

function TBaseTextDataSet.ReadSchema: TStringList;
begin
  result:=FSchema;
end;

procedure TBaseTextDataSet.WriteSchema(const Value: TStringList);
begin
  if not Active then
    FSchema.Assign(Value);
end;

procedure TBaseTextDataSet.SetFileMustExist(Value : Boolean);
begin
  if ((Active) or (FFileMustExist = Value)) then
    exit;

  FFileMustExist := Value;
end;

procedure TBaseTextDataSet.SetFileName(Value : TFileName);
begin
  if ((Active) or (FFileName = Value)) then
    exit;

  inherited FileName := Value;
  FFileName := Value;
end;

procedure TBaseTextDataSet.RemoveWhiteLines(List : TStrings; IsFileRecord : Boolean);
var
  i : integer;
begin
  for i := List.Count -1 downto 0 do
    if (Trim(List.Strings[i]) = '' ) then
      if IsFileRecord then
      begin
        FCurRec := i;
        InternalDelete;
      end
      else
        List.Delete(i);
end;

procedure TBaseTextDataSet.RemoveBlankRecords;
begin
  RemoveWhiteLines(FData, TRUE);
end;

procedure TBaseTextDataSet.SaveFileAs(strFileName : String);
begin
  FData.SaveToFile(strFileName);
  inherited FileName := strFileName;
end;

procedure TBaseTextDataSet.InternalOpen;
var
  Stream : TStream;
begin
  if (not FileMustExist) and (not FileExists(FileName)) then
  begin
    Stream := TFileStream.Create(FileName, fmCreate);
    Stream.Free;
  end;

  inherited;
end;

procedure TBaseTextDataSet.InternalInitFieldDefs;
var
  i, len, Maxlen : Integer;
  UseSchema : Boolean;
  LstFields : TStrings;
  tmpSchema : TStrings;
  tmpLen    : Integer;
  tmpFieldName : string;
begin
  if not Assigned(FData) then
    exit;

  FieldDefs.Clear;

  // Find out the longest string
  Maxlen := 0;

  for i := 0 to FData.Count - 1 do
  begin
    len := Length(FData.Strings[i]);
    if len > Maxlen then
      Maxlen := len;
  end;

  LstFields := TStringList.Create;
  try
    // Load Schema Structure
    tmpSchema := TStringList.Create;
    try
      if (Schema.Count>0) then
      begin
        tmpSchema.Assign(Schema);
        RemoveWhiteLines(tmpSchema, FALSE);
      end
      else if (FData.Count > 0) then
        tmpSchema.CommaText := FData.Strings[0];

      UseSchema := (Schema.Count > 0);

      // Interpret Schema
      i := 1;

      tmpLen   := Maxlen;

      repeat
        // Standardize variables on schema

        if not UseSchema then
          tmpFieldName := Format('Field%d=%d', [i, tmpLen])
        else
        begin
          tmpFieldName := tmpSchema.Names[i-1];
          if (tmpFieldName = '') then
            tmpFieldName := Format('%s=%d', [tmpSchema.Strings[i-1], tmpLen])
          else
            tmpFieldName := tmpSchema.Strings[i-1];
        end;

        LstFields.Add(tmpFieldName);

        Inc(i)

      until i > tmpSchema.Count;
    finally
      tmpSchema.Free;
    end;

    FRecordSize := 0;

    // Add fields
    with LstFields do
      for i := 0 to Count -1 do
      begin
        len := StrToIntDef(Values[Names[i]], Maxlen);
        FieldDefs.Add(Trim(Names[i]), ftString, len, False);
        Inc(FRecordSize, len);
        Inc(FRecordSize, DELIMITERS_GAP);
      end;
  finally
    LstFields.Free;
  end;

  if FRecordSize = 0 then
    FRecordSize := MAXSTRLEN;

  { Initialize an offset value to find the TRecInfo in each buffer }
  FRecInfoOfs := FRecordSize;
  FRecBufSize := FRecInfoOfs + SizeOf(TRecInfo);
end;


function TBaseTextDataSet.GetRecordSize: Word;
begin
  Result := FRecordSize;
end;

{TSdfDataSet}

procedure TSdfDataSet.SetFirstLineAsSchema(Value : Boolean);
begin
  if ((Active) or (FFirstLineAsSchema = Value) ) then
    exit;

  FFirstLineAsSchema := Value;
end;

procedure TSdfDataSet.InternalInitFieldDefs;
begin
  if not Assigned(FData) then
    exit;
  if (FirstLineAsSchema) then
  begin
    if (FData.Count > 0) then
      Schema.CommaText := FData.Strings[0]
    else
      FirstLineAsSchema := FALSE;
  end;

  inherited;
end;

procedure TSdfDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  Temp : TStrings;
  i    : Integer;
begin
  Temp := TStringList.Create;
  Temp.CommaText := ActiveBuffer;

  // Add blank fields as needed
  for i := Temp.Count to Field.FieldNo - 1 do
    Temp.Add('');

  Temp.Strings[Field.FieldNo -1] := Copy(PChar(Buffer), 1, Field.DataSize);

  StrLCopy(ActiveBuffer, PChar(Temp.CommaText), FRecordSize);
  DataEvent(deFieldChange, Longint(Field));

  Temp.Free;
end;

function  TSdfDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  Result := grOk;

  if (FirstLineAsSchema) then     // Avoid showing titles when FirstLineAsSchema
    if FData.Count < 2 then
      Result := grEOF
    else
      case GetMode of
        gmNext:
          if FCurRec >= RecordCount - 1  then
            Result := grEOF
          else
            if FCurRec < 1 then
              FCurRec := 0;
        gmPrior:
          if FCurRec <= 1 then
            Result := grBOF;
      end;

  if (Result = grOk) then
    Result := inherited GetRecord(Buffer, GetMode, DoCheck);

end;

procedure TSdfDataSet.RemoveExtraColumns;
var
  i : Integer;
  Temp : TStrings;
begin
  Temp := TStringList.Create;

  for i := 1 to FData.Count do
  begin
    Temp.CommaText := FData.Strings[i -1];
    if Temp.Count > FieldDefs.Count then   // Remove columns at the end
    begin
      while Temp.Count > FieldDefs.Count do
        Temp.Delete(Temp.Count -1);

      FData.Strings[i -1] := Temp.CommaText;
    end;
  end;

  Temp.Free;

  FData.SaveToFile(FileName);
end;

function TSdfDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
  Temp : TStrings;
begin

  if (FData.Count = 0) or ((FirstLineAsSchema) and (FData.Count < 2)) then   // Avoid showing titles when FirstLineAsSchema
    Result := FALSE
  else
  begin
    Temp := TStringList.Create;
    Temp.CommaText := ActiveBuffer;

    if ((Field.FieldNo > 0) and (Field.FieldNo <= Temp.Count)) then
      StrLCopy(PChar(Buffer), PChar(Temp[Field.FieldNo -1]), Field.DataSize)
    else
      StrCopy(PChar(Buffer), #0);

    Temp.Free;

    Result := PChar(Buffer)^ <> #0;
  end;
end;

{ TFixedFormatDataSet }
procedure TFixedFormatDataSet.InternalOpen;
begin
  if (FSchema.Count=0) then
     raise Exception.Create('Fixed Format requires a schema');
  inherited;
end;

function TFixedFormatDataSet.GetFieldData(Field: TField;
  Buffer: Pointer): Boolean;
var
  thePos: PChar;
  cnt, offset: Cardinal;
begin
  if (FData.Count = 0) then // Avoid showing titles when FirstLineAsSchema
  begin
    Result := FALSE;
    exit;
  end;
  thePos:=ActiveBuffer;
  offset:=0;

  if Field.FieldNo > 1 then
    for cnt:=0 to Field.FieldNo-2 do
       inc(offset, Fields[cnt].Size);

  if offset > StrLen(ActiveBuffer) then
  begin    // Avoid showing garbage
    Result := FALSE;
    exit;
  end;

  Inc(thePos,Offset);
  StrLCopy(Buffer, thePos, Field.Size);
  Result := PChar(Buffer)^ <> #0;
end;

procedure TFixedFormatDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  i, offset : Integer;
  pSrc, pDest : PChar;
  TempStr : String;
begin
  offset := 0;

  // Find the offset
  if Field.FieldNo > 1 then
    for i:=0 to Field.FieldNo-2 do
      Inc(offset, Fields[i].Size);

  TempStr := ActiveBuffer;
  // Fill the String with spaces if necessary
  for i := Length(TempStr) to FRecordSize do
    TempStr := Concat(TempStr, ' ');

  pDest := PChar(TempStr);
  inc(pDest, offset);

  pSrc := PChar(Buffer);
  for i := Length(pSrc) to Field.Size do
    StrCat(pSrc, ' ');

  StrMove(pDest, pSrc, Field.Size);

  StrLCopy(ActiveBuffer, PChar(TempStr), FRecordSize);

  DataEvent(deFieldChange, Longint(Field));

end;

{ This procedure is used to register this component on the component palette }
procedure Register;
begin
  RegisterComponents('Data Access', [TSdfDataSet]);
  RegisterComponents('Data Access', [TFixedFormatDataSet]);
end;

end.