home *** CD-ROM | disk | FTP | other *** search
- unit SdfData;
- {-----------------------------------------------------------------------------}
- { Name : SdfData }
- { Application : TBaseTextDataSet TSdfDataSet TFixedFormatDataSet Components }
- { Version : 1.03 }
- { Author : Orlando Arrocha email: oarrocha@hotmail.com }
- { 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.
-