jvqcsvdata.pas

East make Tray Icon in delphi

    procedure SetRowTag(TagValue: Integer);

    // protected TDataSet base METHODS:
    procedure SetTableName(const Value: string); virtual;
    function FieldDefsStored: Boolean; virtual;
    function GetCanModify: Boolean; override; //already virtual!

    // internal calls:
    procedure AppendPlaceHolderCommasToAllRows(Strings: TStrings); // Add placeholders to end of a csv file.
    procedure ProcessCsvHeaderRow;
    procedure ProcessCsvDataRow(const DataRow: string; Index: Integer);
    procedure SetCsvFieldDef(const Value: string);

    { Mandatory VCL TDataSet Overrides - Pure Virtual Methods of Base Class }
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure InternalInitRecord(Buffer: PChar); override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;

    function GetRecordSize: Word; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure ClearCalcFields(Buffer: PChar); override;

    // Bookmark methods:
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalSetToRecord(Buffer: PChar); override; // on Insertion???
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;

    // Navigational methods:
    procedure InternalFirst; override;
    procedure InternalLast; override;
    // Editing methods:
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalDelete; override;
    procedure InternalPost; override;
    { procedure InternalInsert; override; }{not needed.}

    // Misc methods:
    procedure InternalClose; override;
    // procedure DestroyFields; override;

    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalOpen; override;

    function GetFileName: string; // used by InternalOpen, and Flush.

    function IsCursorOpen: Boolean; override;
    { Optional overrides }
    function GetRecordCount: Integer; override;
    function GetRecNo: Integer; override;
    procedure SetRecNo(Value: Integer); override;

    { dataset designer calls these }
    procedure DefChanged(Sender: TObject); override;

    // handling functions for enquoting,dequoting string fields in csv files.
    // handles using the default Excel method which is to double the quotes inside
    // quotes.

    // (rom) inacceptable names
    function _Enquote(const StrVal: string): string; virtual;
    // puts whole string in quotes, escapes embedded separators and quote characters!
    function _Dequote(const StrVal: string): string; virtual; // removes quotes

    property Separator: Char read FSeparator write SetSeparator default ',';
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function BookmarkValid(Bookmark: TBookmark): Boolean; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;

    // Autoincrement feature: Get next available auto-incremented value for numbered/indexed autoincrementing fields.
    function GetAutoincrement(const FieldName: string): Integer;

    // NEW: COPY FROM ANOTHER TDATASET (TTable, TADOTable, TQuery, or whatever)
    function CopyFromDataset(DataSet: TDataSet): Integer;

    // SELECT * FROM TABLE WHERE <fieldname> LIKE <pattern>:
    procedure SetFilter(const FieldName: string; Pattern: string); // Make Rows Visible Only if they match filterString

    // SELECT * FROM TABLE WHERE <fieldname> IS <NULL|NOT NULL>:
    procedure SetFilterOnNull(const FieldName: string; NullFlag: Boolean);


    procedure ClearFilter; // Clear all previous SetFilters, shows All Rows. Refresh screen.
    // (rom) inacceptable name
    procedure _ClearFilter; // Clear Previous Filtering. DOES NOT REFRESH SCREEN.


    procedure CustomFilter(FilterCallback: TJvCustomCsvDataSetFilterFunction); {NEW:APRIL 2004-WP}

    // ----------- THIS IS A DUMMY FUNCTION, DON'T USE IT!:
    function Locate(const KeyFields: string; const KeyValues: Variant;
      Options: TLocateOptions): Boolean; override;

    //------------

    /// procedure FilteredDeletion(Inverted: Boolean); /// XXX TODO?
    /// procedure DeleteRowsMatchingFilter; /// XXX TODO?
    /// procedure DeleteRowsNotMatchingFilter; /// XXX TODO?

    // this is necessary to make bookmarks work as well:
    function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;

    // Additional procedures
    procedure EmptyTable;

      // Tells controls to redraw.
    procedure Refresh;

    // Clone current row/record from one CsvDataSet to another (primitive synchronization/copying ability).
    procedure CloneRow(DataSet: TJvCustomCsvDataSet);

    // TODO: Implement row/record copy from ANY dataset.
    
    // A fast row lookup function specific to this CSV table object.
    function FindByCsvKey(const Key: string): Boolean;

    // Sort the table:
    procedure Sort(const SortFields: string; Ascending: Boolean);

    // All rows have a UserData and UserTag property, these
    // next two functions quickly set all the userdata and usertag
    // values for all rows, which is a good way to set defaults
    // without having to iterate through the dataset.
    procedure SetAllUserData(Data: Pointer);
    procedure SetAllUserTags(TagValue: Integer);

    // The UserData/UserTag properties apply to the row that the
    // cursor is sitting on. Without visibly moving the cursor,
    // its handy to get/set the usertag and Data values.
    function GetUserTag(RecNo: Integer): Integer;
    procedure SetUserTag(RecNo, NewValue: Integer);

    function GetUserData(RecNo: Integer): Pointer;
    procedure SetUserData(RecNo: Integer; NewValue: Pointer);

    function GetCsvHeader: string; // NEW FEB 2004 WP

    {  Additional Public methods }
    procedure OpenWith(Strings: TStrings); virtual;

    procedure AppendWith(Strings: TStrings); virtual;

    { Special declarations }
    // as long as the field names and positions have not changed.
    procedure AssignFromStrings(const Strings: TStrings); virtual; // update String Data directly.
    procedure AssignToStrings(Strings: TStrings); virtual;

    procedure DeleteRows(FromRow, ToRow: Integer); // NEW: Quickly zap a bunch of rows:
    procedure ExportRows(const FileName: string; FromRow, ToRow: Integer); // NEW: Quickly save a bunch of rows:

    procedure ExportCsvFile(const FileName: string); virtual;
      // save out to a file. does NOT keep backups! If file exists, it will be
        // overwritten, and NO backups are made!

    procedure Flush; virtual; // Save CSV file to disk if file has changed and SavesChanges is True.
    // Note: FLUSH will make backup copies if FAutoBackupCount>0!!!

    function GetAsString(const Row, Column: Integer): string; virtual;

    { Row Access as String }
    function GetRowAsString(const Index: Integer): string; virtual;

    function CurrentRowAsString: string; virtual; // Return any row by index, special: -1 means last row NEW.

    // Return any row by index, special: -1 means last row
    function GetColumnsAsString: string; virtual;
    { Row Append one String }
    procedure AppendRowString(const RowAsString: string);
    // Along with GetRowAsString, easy way to copy a dataset to another dataset!

    function IsKeyUnique: Boolean; // Checks current row's key uniqueness. Note that FCsvKeyDef MUST be set!
    procedure SaveToFile(const FileName: string);
    procedure LoadFromFile(const FileName: string);

     {These are made protected so that you can write another derivce component
      unfortunately if it is in another unit, you can't do much about it.}
  protected
    property InternalData: TJvCsvRows read FData write FData;
    property AppendedFieldCount: Integer read FAppendedFieldCount;
      // Number of fields not in the file on disk, appended to file as NULLs during import.
      // Per-Record user-Data fields:
      //    Each record can have a pointer (for associating each row with an object)
    property UserData: Pointer read GetRowUserData write SetRowUserData;
      //    Each record can have a tag (Integer) (for help in marking rows as Selected/Unselected or some other
      //    end user task)
    property UserTag: Integer read GetRowTag write SetRowTag;

    property FileName: string read FTableName write SetTableName;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property Changed: Boolean read FFileDirty write FFileDirty;
    // property DataFileSize: Integer read GetDataFileSize;

    // if HasHeaderRow is True, calidate that it conforms to CvsFieldDef
    property ValidateHeaderRow: Boolean read FValidateHeaderRow write FValidateHeaderRow default True;
    property ExtendedHeaderInfo: Boolean read FExtendedHeaderInfo write FExtendedHeaderInfo;

    property CaseInsensitive: Boolean read FCsvCaseInsensitiveComparison write FCsvCaseInsensitiveComparison;

    // Properties for Automatically Loading/Saving CSV file when Active property is set True/False:
    property LoadsFromFile: Boolean read FLoadsFromFile write FLoadsFromFile default True;
    property AutoBackupCount: Integer read FAutoBackupCount write FAutoBackupCount;
    // >0 means Keep Last N Copies the Old Csv File, updated before each save?

    // Do field definitions "persist"?
    // Ie: do they get stored in DFM Form file along with the component
    property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;

    { value in seconds : to do GMT to EST (ie GMT-5) use value of (-3600*5)
      This is only useful if you use the Hex encoded date-time fields.
    }
    property TimeZoneCorrection: Integer read FTimeZoneCorrection write FTimeZoneCorrection default 0;
    { If False (default) we use the more normal CSV rendering of quotes, which is to double them in
      the csv file, but if this property is True, we use backslash-quote to render quotes in the file,
      which has the side-effect of also requiring all backslashes to themself be escaped by a backslash.
      So filenames would have to be in the form "c:\\directory\\names\\like\\c\\programmers\\do\\it".
      Not recommended behaviour, except when absolutely necessary! }
    property EnquoteBackslash: Boolean read FEnquoteBackslash write FEnquoteBackslash default False;

    {new}
    property CreatePaths: Boolean read FCreatePaths write FCreatePaths default True; // When saving, create subdirectories/paths if it doesn't exist?

    { Additional Events }
    property OnSpecialData: TJvCsvOnSpecialData read FOnSpecialData write FOnSpecialData;
    property OnGetFieldData: TJvCsvOnGetFieldData read FOnGetFieldData write FOnGetFieldData;
    property OnSetFieldData: TJvCsvOnSetFieldData read FOnSetFieldData write FOnSetFieldData;
   public
    { these MUST be available at runtime even when the object is of the Custom base class type
      This enables interoperability at design time between non-visual helper components
      and user-derived CsvDataSet descendants }
     // CSV Table definition properties:
    property CsvFieldDef: string read FCsvFieldDef write SetCsvFieldDef; // Our own "Csv Field Definition String"
    property CsvKeyDef: string read FCsvKeyDef write FCsvKeyDef; // Primary key definition.
    property CsvUniqueKeys: Boolean read FCsvUniqueKeys write FCsvUniqueKeys; // Rows must be unique on the primary key.
      
    property OpenFileName: string read FOpenFileName; // Set in InternalOpen, used elsewhere.
    property FieldDefs stored FieldDefsStored;
    property TableName: string read FTableName; // Another name, albeit read only, for the FileName property!
    property HasHeaderRow: Boolean read FHasHeaderRow write FHasHeaderRow default True;
    property HeaderRow: string read FHeaderRow; // first row of CSV file.
    property SavesChanges: Boolean read FSavesChanges write FSavesChanges default True;
  end;

  // TJvCsvDataSet is just a TJvCustomCsvDataSet with all properties and events exposed:
  TJvCsvDataSet = class(TJvCustomCsvDataSet)
  public
    property TableName;
    property UserData;
    property UserTag;
  published
    property FieldDefs;
    property Active;
    property BufferCount;
    property FileName;
    property ReadOnly;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property OnDeleteError;
    property OnEditError;
    property OnCalcFields;
    property AutoCalcFields; // TDataSet property!
    //property MasterFields;
    //property MasterSource;
    property Changed;
    property CsvFieldDef;
    property CsvKeyDef;
    property CsvUniqueKeys;
    property HasHeaderRow;
    property ValidateHeaderRow;
    property ExtendedHeaderInfo;
    property CaseInsensitive;
    property Separator;
    property LoadsFromFile;
    property SavesChanges;
    property AutoBackupCount;
    property StoreDefs;
    property OnSpecialData;
    property OnGetFieldData;
    property OnSetFieldData;
    property TimeZoneCorrection;
    property EnquoteBackslash;
    property HeaderRow;
  end;

{ CSV String Processing Functions }
procedure CsvRowToString(RowItem: PCsvRow; var RowString: string);

{ modified! }
procedure StringToCsvRow(const RowString: string; Separator: Char;
  RowItem: PCsvRow; PermitEscapeSequences, EnquoteBackslash: Boolean);

function CsvRowItemCopy(Source, Dest: PCsvRow; FieldIndex, FieldSize: Integer): Boolean;
procedure SetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer; const NewValue: string);
function GetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer): string;
procedure CsvRowSetDirtyBit(Row: PCsvRow; ColumnIndex: Integer);
procedure CsvRowClearDirtyBit(Row: PCsvRow; ColumnIndex: Integer);
function CsvRowGetDirtyBit(Row: PCsvRow; ColumnIndex: Integer): Boolean;
procedure CsvRowSetColumnMarker(Row: PCsvRow; ColumnIndex: Integer; ColumnMarker: Integer);
function CsvRowGetColumnMarker(Row: PCsvRow; ColumnIndex: Integer): Integer;

{ Date/Time String decoding functions }
function TimeTHexToDateTime(const HexStr: string; TimeZoneCorrection: Integer): TDateTime;
function TimeTAsciiToDateTime(const AsciiDateStr: string): TDateTime;

{ Date/Time string encoding functions }
function DateTimeToTimeToIsoAscii(ADateTime: TDateTime): string;
function DateTimeToTimeTHex(ADateTime: TDateTime; TimeZoneCorrection: Integer): string;

{ Routine to keep backup copies of old Data files around }
function JvCsvBackupPreviousFiles(const FileName: string; MaxFiles: Integer): Boolean;

//JvCsvWildcardMatch:
// Recursive wildcard (%=AnyString, ?=SingleChar) matching function with
// Boolean sub expressions (|=or, &=and).
function JvCsvWildcardMatch(Data, Pattern: string): Boolean;

implementation

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF HAS_UNIT_VARIANTS}
  SysUtils, QControls, QForms,  
  JvQJCLUtils, JvQCsvParse, JvQConsts, JvQResources;

const
  // These characters cannot be used for separator for various reasons:
  // Either they are used as field type specifiers, break lines or are used to
  // delimit field content
  cInvalidSeparators = [#0, Backspace, Lf, #12, Cr, #39, '"', '\',
    '$', '%', '&', '@', '#', '^', '!', '-'];

var
  // (rom) disabled unused
  // CallCount: Integer = 0;
  AsciiTime_MinValue: array [1..6] of Integer = (1900, 1, 1, 0, 0, 0);
  AsciiTime_MaxValue: array [1..6] of Integer = (3999, 12, 31, 23, 59, 59);
  AsciiTime_ExpectLengths: array [1..6] of Integer = (4, 2, 2, 2, 2, 2);

procedure JvCsvDatabaseError(const TableName, Msg: string);
begin
  // (rom) no OutputDebugString in production code
  {$IFDEF DEBUGINFO_ON}
  OutputDebugString(PChar('JvCsvDatabaseError in ' + TableName + ': ' + Msg));
  {$ENDIF DEBUGINFO_ON}