sttxtdat.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StTxtDat.pas 4.03                           *}
{*********************************************************}
{* SysTools: Formatted Text Data Handling                *}
{*********************************************************}

{$include StDefine.inc}

unit StTxtDat;

interface
uses
  SysUtils, Classes, TypInfo, StConst, StBase, StStrms, StStrL;

const
  StDefaultDelim = ',';
  StDefaultQuote = '"';
  StDefaultComment = ';';
  StDefaultFixedSep = ' ';                                               {!!.01}
  StDefaultLineTerm = #13#10;
  St_WhiteSpace = #8#9#10#13' ';  {page feed, tab, LF, CR, space}        {!!.01}

type
  TStSchemaLayoutType = (ltUnknown, ltFixed, ltVarying);
  TStSchemaFieldType = (sftUnknown, sftChar, sftFloat, sftNumber, sftBool, sftLongInt, sftDate, sftTime, sftTimeStamp);
  TStOnQuoteFieldEvent = procedure (Sender : TObject; var Field : AnsiString) of object;

  { Text Data Layout descriptors (Schemas)}
  TStDataField = class
  protected {private}
    FFieldDecimals: Integer;
    FFieldLen: Integer;
    FFieldName: AnsiString;
    FFieldOffset: Integer;
    FFieldType: TStSchemaFieldType;
    function GetAsString: AnsiString;
    procedure SetFieldDecimals(const Value: Integer);
    procedure SetFieldLen(const Value: Integer);
    procedure SetFieldName(const Value: AnsiString);
    procedure SetFieldOffset(const Value: Integer);
    procedure SetFieldType(const Value: TStSchemaFieldType);
  public
    { properties }
    property AsString : AnsiString read GetAsString;
    property FieldDecimals: Integer read FFieldDecimals write SetFieldDecimals;
    property FieldLen: Integer read FFieldLen write SetFieldLen;
    property FieldName : AnsiString read FFieldName write SetFieldName;
    property FieldOffset: Integer read FFieldOffset write SetFieldOffset;
    property FieldType: TStSchemaFieldType read FFieldType write SetFieldType;
  end;


  TStDataFieldList = class
  private
    FList : TStringList;
  protected {private}
    function GetCount: Integer;
    function GetField(Index: Integer): TStDataField;
    function GetFieldByName(const FieldName: AnsiString): TStDataField;
    procedure SetField(Index: Integer; const Value: TStDataField);
    procedure SetFieldByName(const FieldName: AnsiString;
      const Value: TStDataField);
  public
    constructor Create;
    destructor Destroy; override;

    { Access and Update Methods }
    procedure AddField(const FieldName: AnsiString; FieldType: TStSchemaFieldType;
      FieldLen, FieldDecimals, FieldOffset: Integer);
    procedure AddFieldStr(const FieldDef : AnsiString);
    procedure Clear;
    procedure RemoveField(const FieldName: AnsiString);

    { properties }
    property Count : Integer read GetCount;
    property Fields[Index : Integer] : TStDataField
      read GetField write SetField; default;
    property FieldByName[const FieldName: AnsiString] : TStDataField
      read GetFieldByName write SetFieldByName;
  end;

  TStTextDataSchema = class
  private
    FCommentDelimiter: AnsiChar;
    FFieldDelimiter: AnsiChar;
    FLayoutType: TStSchemaLayoutType;
    FLineTermChar : AnsiChar;
    FLineTerminator : TStLineTerminator;
    FQuoteDelimiter: AnsiChar;
    FFixedSeparator : AnsiChar;                                      {!!.01}
    FSchema: TStrings;
    FSchemaName: AnsiString;
    dsFieldList : TStDataFieldList;
  protected {private}
    function GetCaptions: TStrings;
    function GetField(Index: Integer): TStDataField;
    function GetFieldByName(const FieldName: AnsiString): TStDataField;
    function GetFieldCount: Integer;
    function GetSchema: TStrings;
    procedure SetCommentDelimiter(const Value: AnsiChar);
    procedure SetField(Index: Integer; const Value: TStDataField);
    procedure SetFieldByName(const FieldName: AnsiString; const Value: TStDataField);
    procedure SetFieldDelimiter(const Value: AnsiChar);
    procedure SetLayoutType(const Value: TStSchemaLayoutType);
    procedure SetQuoteDelimiter(const Value: AnsiChar);
    procedure SetFixedSeparator(const Value: AnsiChar);              {!!.01}
    procedure SetSchema(const Value: TStrings);
    procedure SetSchemaName(const Value: AnsiString);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(ASchema : TStTextDataSchema);

    { Access and Update Methods }
    procedure AddField(const FieldName : AnsiString; FieldType : TStSchemaFieldType;
      FieldLen, FieldDecimals : Integer);
    function IndexOf(const FieldName : AnsiString) : Integer;
    procedure RemoveField(const FieldName: AnsiString);
    procedure Update(AList : TStrings);                               {!!.01}
    procedure ClearFields;                                            {!!.01}
    procedure BuildSchema(AList: TStrings);                           {!!.01}

    { Persistence and streaming methods }
    procedure LoadFromFile(const AFileName : TFileName);
    procedure LoadFromStream(AStream : TStream);
    procedure SaveToFile(const AFileName : TFileName);
    procedure SaveToStream(AStream : TStream);

    { properties }
    property Captions : TStrings
      read GetCaptions;
    property CommentDelimiter : AnsiChar
      read FCommentDelimiter write SetCommentDelimiter default StDefaultComment;
    property FieldByName[const FieldName: AnsiString] : TStDataField
      read GetFieldByName write SetFieldByName;
    property FieldCount : Integer
      read GetFieldCount;
    property FieldDelimiter : AnsiChar
      read FFieldDelimiter write SetFieldDelimiter default StDefaultDelim;
    property Fields[Index : Integer] : TStDataField
      read GetField write SetField; default;
    property LayoutType : TStSchemaLayoutType
      read FLayoutType write SetLayoutType;
    property LineTermChar : AnsiChar
      read FLineTermChar write FLineTermChar default #0;
    property LineTerminator : TStLineTerminator
      read FLineTerminator write FLineTerminator default ltCRLF;
    property QuoteDelimiter : AnsiChar
      read FQuoteDelimiter write SetQuoteDelimiter default StDefaultQuote;
    property FixedSeparator : AnsiChar                                        {!!.01}
      read FFixedSeparator write SetFixedSeparator default StDefaultFixedSep; {!!.01}
    property Schema : TStrings
      read GetSchema write SetSchema;
    property SchemaName : AnsiString
      read FSchemaName write SetSchemaName;
  end;

  { Text Data Records and Data Sets }
  TStTextDataRecord = class
  private
    FFieldList: TStrings;
    FQuoteAlways: Boolean;
    FQuoteIfSpaces: Boolean;
    FSchema: TStTextDataSchema;
    FValue : AnsiString;
    FOnQuoteField : TStOnQuoteFieldEvent;
  protected {private}
    function GetField(Index: Integer): AnsiString;
    function GetFieldCount: Integer;
    function GetFieldByName(const FieldName: AnsiString): AnsiString;
    function GetFieldList: TStrings;
    function GetValues: TStrings;
    procedure SetField(Index: Integer; const NewValue: AnsiString);
    procedure SetFieldByName(const FieldName: AnsiString; const NewValue: AnsiString);
    procedure SetQuoteAlways(const Value: Boolean);
    procedure SetQuoteIfSpaces(const Value: Boolean);
    procedure SetSchema(const Value: TStTextDataSchema);
  public
    constructor Create;
    destructor Destroy; override;

    { Access and Update Methods }
    procedure BuildRecord(Values: TStrings; var NewRecord: AnsiString); virtual;
    function GetRecord : AnsiString;                                   {!!.02}
    procedure DoQuote(var Value: AnsiString); virtual;
    procedure FillRecordFromArray(Values: array of const);
    procedure FillRecordFromList(Items: TStrings);
    procedure FillRecordFromValues(Values: TStrings);
    procedure MakeEmpty; virtual;

    { properties }
    property AsString : AnsiString                                     {!!.02}
//      read FValue {write SetValue};                                  {!!.02}
      read GetRecord;
    property FieldByName[const FieldName : AnsiString] : AnsiString
      read GetFieldByName write SetFieldByName;
    property FieldCount : Integer
      read GetFieldCount;
    property FieldList : TStrings
      read GetFieldList;
    property Fields[Index : Integer] : AnsiString
      read GetField write SetField;
    property QuoteAlways : Boolean
      read FQuoteAlways write SetQuoteAlways default False;
    property QuoteIfSpaces : Boolean
      read FQuoteIfSpaces write SetQuoteIfSpaces default False;
    property Schema : TStTextDataSchema
      read FSchema write SetSchema;
    property Values : TStrings
      read GetValues;

    { events }
    property OnQuoteField : TStOnQuoteFieldEvent
      read FOnQuoteField write FOnQuoteField;
  end;

  TStTextDataRecordSet = class
  private
    FActive: Boolean;
    FCurrentIndex : Integer;
    FIsDirty: Boolean;
    FRecords: TList;
    FSchema: TStTextDataSchema;
    FAtEndOfFile : Boolean;                                  {!!.01}
    FIgnoreStartingLines : Integer;                                    {!!.02}
  protected {private}
    function GetCount: Integer;
    function GetCurrentRecord: TStTextDataRecord;
    function GetRecord(Index: Integer): TStTextDataRecord;
    function GetSchema: TStTextDataSchema;
    procedure SetActive(const Value: Boolean);
    procedure SetCurrentRecord(const Value: TStTextDataRecord);
    procedure SetRecord(Index: Integer; const Value: TStTextDataRecord);
    procedure SetSchema(const Value: TStTextDataSchema);

  public
    constructor Create;
    destructor Destroy; override;

    { Access and Update Methods }
    procedure Append;
    procedure AppendArray(Values : array of const);
    procedure AppendList(Items : TStrings);
    procedure AppendValues(Values : TStrings);
    procedure Clear;
    procedure Delete;
    procedure Insert(Index : Integer);
    procedure InsertArray(Index: Integer; Values : array of const);
    procedure InsertList(Index : Integer; Items : TStrings);
    procedure InsertValues(Index : Integer; Values : TStrings);

    { navigation methods }
    function BOF : Boolean;
    function EOF : Boolean;
    procedure First;
    procedure Last;
    function Next : Boolean;
    function Prior : Boolean;

    { Persistence and streaming methods }
    procedure LoadFromFile(const AFile : TFileName);
    procedure LoadFromStream(AStream : TStream);
    procedure SaveToFile(const AFile : TFileName);
    procedure SaveToStream(AStream : TStream);

    { properties }
    property Active : Boolean
      read FActive write SetActive;
    property Count : Integer
      read GetCount;
    property CurrentRecord : TStTextDataRecord
      read GetCurrentRecord write SetCurrentRecord;
    property IsDirty : Boolean
      read FIsDirty;
    property Records[Index : Integer] : TStTextDataRecord
      read GetRecord write SetRecord;
    property Schema : TStTextDataSchema
      read GetSchema write SetSchema;
    property IgnoreStartingLines : Integer                             {!!.02}
      read FIgnoreStartingLines write FIgnoreStartingLines default 0;  {!!.02}
  end;

procedure StParseLine(const Data : AnsiString; Schema : TStTextDataSchema; Result : TStrings);
function StFieldTypeToStr(FieldType : TStSchemaFieldType) : AnsiString;
function StStrToFieldType(const S : AnsiString) : TStSchemaFieldType;
function StDeEscape(const EscStr : AnsiString): AnsiChar;
function StDoEscape(Delim : AnsiChar): AnsiString;
function StTrimTrailingChars(const S : AnsiString; Trailer : AnsiChar) : AnsiString; {!!.01}

implementation

procedure StParseLine(const Data : AnsiString; Schema : TStTextDataSchema;
  Result : TStrings);
{ split a line of delimited data according to provided schema into
  <name>=<value> pairs into Result }
var
  DataLine : TStTextDataRecord;
  ownSchema : Boolean;
begin
  { need a valid TStrings to work with }
  if not Assigned(Result) then Exit;


  ownSchema := False;
  { if no Schema to use passed in, create a default schema }
  if not Assigned(Schema) then begin
    Schema := TStTextDataSchema.Create;
    ownSchema := True; { we made it we, s have to free it }
  end;

  DataLine := TStTextDataRecord.Create;
  try
    DataLine.Schema := Schema;
    DataLine.FValue := Data;
    Result.Assign(DataLine.FieldList);
  finally
    DataLine.Free;
    { free the Schema if needed }
    if ownSchema then
      Schema.Free;
  end;
end;

{ TStDataField }

function StFieldTypeToStr(FieldType : TStSchemaFieldType) : AnsiString;
{ convert TStSchemaFieldType enum into matching string for BDE schema }
begin
  Result := '';
  case FieldType of
    sftChar	 : Result := 'CHAR';
    sftFloat	 : Result := 'FLOAT';
    sftNumber	 : Result := 'NUMBER';
    sftBool	 : Result := 'BOOL';
    sftLongInt	 : Result := 'LONGINT';
    sftDate	 : Result := 'DATE';
    sftTime	 : Result := 'TIME';
    sftTimeStamp : Result := 'TIMESTAMP';

    else
      Result := '';
  end;
end;

function StStrToFieldType(const S : AnsiString) : TStSchemaFieldType;
{ convert string to TStSchemaFieldType constant }
var
  Value : Integer;
begin
  Value := GetEnumValue(TypeInfo(TStSchemaFieldType), S);
  if Value > -1 then
    Result := TStSchemaFieldType(Value)
  else
    Result := sftUnknown;
end;

{!!.01 - Added}
function StTrimTrailingChars(const S : AnsiString; Trailer : AnsiChar) : AnsiString;
{
Return a string with specified trailing character removed,
useful for cleanup of fixed data records
}
var
  Len : LongInt;
begin
  Result := S;
  Len := Length(S);
  while (Len > 0) and (Result[Len] = Trailer) do
    Dec(Len);
  SetLength(Result, Len);
end;
{!!.01 - End Added}

function TStDataField.GetAsString: AnsiString;
{ build string representation of field to match BDE style }
{
Format :
  <name>,<type>,<width>,<decimals>,<offset>
}
begin
  Result := FFieldName + ',' + StFieldTypeToStr(FFieldType) + ',' +
    { zero pad width, decimals, and offset to at least two places
      to match BDE Schema formatting }
      Format('%.2d,%.2d,%.2d', [FFieldLen, FFieldDecimals, FFieldOffset]);
end;

procedure TStDataField.SetFieldDecimals(const Value: Integer);
begin
  FFieldDecimals := Value;
end;

procedure TStDataField.SetFieldLen(const Value: Integer);
begin
  FFieldLen := Value;
end;

procedure TStDataField.SetFieldName(const Value: AnsiString);
begin
  FFieldName := Value;
end;

procedure TStDataField.SetFieldOffset(const Value: Integer);
begin
  FFieldOffset := Value;
end;

procedure TStDataField.SetFieldType(const Value: TStSchemaFieldType);
begin
  FFieldType := Value;
end;


{ TStDataFieldList }

function CharPosIdx(C: AnsiChar; const S : AnsiString; Idx: Integer): Integer;
{ Find leftmost occurrence of character C in string S past location Idx }
{
If C not found returns 0
}
var
  Len : Integer;
begin
  Len := Length(S);
  if (Idx > Len) or (Idx < 1) then begin
    Result := 0;
    Exit;
  end;

  Result := Idx;
  while (Result <= Len) and (S[Result] <> C) do
    Inc(Result);
  if Result > Len then
    Result := 0;
end;

procedure SplitFieldStr(const Source: AnsiString; var Name: AnsiString;
  var FieldType: TStSchemaFieldType; var ValLen, Decimals, Offset: Integer);
{ split field description string according to BDE Schema layout }