tsmask.pas

企业进销存管理系统

{*******************************************************}
{                                                       }
{       Top Support Visual Components                   }
{       Classes for masked edit                         }
{                                                       }
{       Copyright (c) 1998 - 1999, Top Support          }
{                                                       }
{*******************************************************}

unit TSMask;

{$INCLUDE TSCmpVer}

interface

uses
    Windows, Classes, SysUtils {$IFDEF TSVER_V6}, Variants {$ENDIF};

type
    TtsShowThousands   = (sthParent, sthOn, sthOff);
    TtsShowTrailZeros  = (stzParent, stzOn, stzOff);
    TtsSymbolPosition  = (spoParent, spoWindows, spoBefore, spoAfter);
    TtsCaseType        = (cstNone, cstUpper, cstLower, cstSentence, cstTitle);
    TtsPictureType     = (pctText, pctDate, pctTime);
    TtsPictureNodeType = (pntNone, pntGroup, pntLiteralChars, pntMaskChars,
                          pntCase, pntRange);
    TtsMaskOption      = (moNone, moUpper, moOptUpper, moLower, moOptLower,
                          moFullCompare, moConvertInput, moInsertLiteral, moCheckUnique);
    TtsMaskOptions     = set of TtsMaskOption;
    TtsMaskCheck       = (mcOnEdit, mcOnExit);
    TtsMaskChecks      = set of TtsMaskCheck;

    EtsMaskError = class(Exception);
    TtsParsePictureEvent = procedure(Sender: TObject; Picture: string; PictureType: TtsPictureType;
                                     var Cancel: Boolean) of object;
    TtsMaskErrorEvent    = procedure(Sender: TObject; Msg: string; var RaiseError: Boolean) of object;

type
    TtsMask = class;
    TtsMaskDefs = class;
    TtsMaskCollection = class;
    TtsPictureNode = class;
    TtsMaskLink = class;
    TtsCharSet = set of Char;

    TtsPictureNode = class(TObject)
    protected
        FNodeType: TtsPictureNodeType;
        FCount: Integer;
        FOptional: Boolean;
        FComplement: Boolean;
        FStartPos: Integer;
        FEndPos: Integer;
        FCharCount: Integer;
        FSubItems: TtsPictureNode;
        FNextItem: TtsPictureNode;
        FNextAlternative: TtsPictureNode;

    public
        constructor Create(NodeType: TtsPictureNodeType); virtual;
        destructor  Destroy; override;

        property Complement: Boolean read FComplement write FComplement;
        property Count: Integer read FCount write FCount;
        property SubItems: TtsPictureNode read FSubItems write FSubItems;
        property NextItem: TtsPictureNode read FNextItem write FNextItem;
        property NextAlternative: TtsPictureNode read FNextAlternative write FNextAlternative;
        property NodeType: TtsPictureNodeType read FNodeType write FNodeType;
        property Optional: Boolean read FOptional write FOptional;
        property StartPos: Integer read FStartPos write FStartPos;
        property EndPos: Integer read FEndPos write FEndPos;
        property CharCount: Integer read FCharCount write FCharCount;
    end;

    TtsPictureList = class(TObject)
    protected
        FPictureType: TtsPictureType;
        FStartNode: TtsPictureNode;

    public
        constructor Create(PictureType: TtsPictureType); virtual;
        destructor  Destroy; override;

        property PictureType: TtsPictureType read FPictureType write FPictureType;
        property StartNode: TtsPictureNode read FStartNode write FStartNode;
    end;

    TtsParseStackElement = record
        Parent: Integer;
        Node: TtsPictureNode;
        Count: Integer;
        TextPos: Integer;
    end;

    PtsParseStackArray = ^TtsParseStackArray;
    TtsParseStackArray = array[1..(MaxListSize div ((SizeOf(TtsParseStackElement) div SizeOf(Longint)) + 1))] of TtsParseStackElement;

    TtsParseStack = class(TObject)
    protected
        FBuffer: PtsParseStackArray;
        FBufSize: Integer;
        FCount: Integer;

        function  Push(Parent: Integer; Node: TtsPictureNode; TextPos, Count: Integer): Integer;
        procedure Pop;
        procedure Reset;

        property  Count: Integer read FCount;
        property  Items: PtsParseStackArray read FBuffer;

    public
        constructor Create;
        destructor  Destroy; override;
    end;

    TtsTextCase = class(TPersistent)
    protected
        FMask: TtsMask;
        FCaseType: TtsCaseType;
        FOptional: Boolean;

        procedure SetCaseType(Value: TtsCaseType);
        procedure SetOptional(Value: Boolean);
    public
        constructor Create(Mask: TtsMask); virtual;
        procedure   Assign(Source: TPersistent); override;
    published
        property CaseType: TtsCaseType read FCaseType write SetCaseType default cstNone;
        property Optional: Boolean read FOptional write SetOptional default False;
    end;

    TtsMaskInput = record
        Text: string;
        TextPos: Integer;
        InsertPos: Integer;
        InsertLen: Integer;
        Literals: string;
        MatchedLiterals: string;
        MinMatchedLiterals: string;
        InsertChars: string;
    end;

    TtsTextMask = class(TPersistent)
    protected
        FMask: TtsMask;
        FPictureList: TtsPictureList;
        FPictureLength: Integer;
        FValidPicture: Boolean;
        FPictureParsed: Boolean;
        FCreateTree: Boolean;

        {property fields}
        FPicture: string;

        {Error detection procedures}
        procedure ErrChar(Chars: string; TextPos: Integer);

        {Create procedures}
        function  CreatePictureTree(PictureType: TtsPictureType): TtsPictureList;
        function  CreatePictureNode(NodeType: TtsPictureNodeType): TtsPictureNode;

        {Parse procedures}
        function  CharCount(const Text: string; TextPos: Integer): Integer;
        function  PictureCharCount(TextPos: Integer): Integer;
        function  IsLiteral(TextPos: Integer): Boolean;
        function  IsMaskChar(TextPos: Integer): Boolean;
        function  IsCaseChar(TextPos: Integer): Boolean;
        function  IsRangeChar(TextPos: Integer): Boolean;
        function  IsCountChar(TextPos: Integer): Boolean;
        function  IsGroupStart(TextPos: Integer): Boolean;
        function  IsGroupEnd(TextPos: Integer): Boolean;
        procedure CheckGroupEnd(var TextPos: Integer; EndChar: Char);
        function  IsRange(TextPos: Integer; var Chars: Integer): Boolean;
        function  GetItemCount(var TextPos: Integer): Integer;
        function  GetGroupType(var TextPos: Integer; var EndChar: Char): Boolean;
        function  GetItem(var TextPos: Integer; Chars: Integer; NodeType: TtsPictureNodeType): TtsPictureNode;
        function  GetNextItem(var TextPos: Integer): TtsPictureNode;
        function  GetRange(var TextPos: Integer; var Node: TtsPictureNode): Boolean;
        function  GetNextAlternative(var TextPos: Integer; EndChar: Char): TtsPictureNode;
        function  GetGroup(var TextPos: Integer): TtsPictureNode;
        procedure ParsePicture(SyntaxOnly: Boolean);
        function  CheckInput(Stack: TtsParseStack; MaskInput: TtsMaskInput;
                             Options: TtsMaskOptions; var InsertChars: string): Boolean;

        {Value check procedures}
        function  CheckCase(Text: string; TextPos: Integer; Chars: Integer; Option: TtsMaskOption): Boolean;
        function  IsWordStart(MaskInput: TtsMaskInput): Boolean;
        function  IsSentenceStart(MaskInput: TtsMaskInput): Boolean;
        function  GetCaseType(const MaskInput: TtsMaskInput; Options: TtsMaskOptions;
                              DefaultCase: TtsMaskOption): TtsMaskOption;
        function  IsInputChar(const MaskInput: TtsMaskInput): Boolean;
        function  CanConvertCase(const MaskInput: TtsMaskInput; Options: TtsMaskOptions; CaseType: TtsMaskOption): Boolean;
        procedure ConvertCase(var MaskInput: TtsMaskInput; Chars: Integer; ConvertType: TtsMaskOption);
        function  CanInsertLiteral(MaskInput: TtsMaskInput; Options: TtsMaskOptions): Boolean;
        function  CheckLiteralChar(var MaskInput: TtsMaskInput; var MaskPos: Integer;
                                   var Matched: Boolean; Node: TtsPictureNode; Options: TtsMaskOptions): Boolean;
        function  CheckLiterals(Node: TtsPictureNode; var MaskInput: TtsMaskInput;
                                Options: TtsMaskOptions; var Matched: Boolean): Boolean;
        function  CheckMaskChar(var MaskInput: TtsMaskInput; var MaskPos: Integer; Options: TtsMaskOptions): Boolean;
        function  CheckMaskChars(Node: TtsPictureNode; var MaskInput: TtsMaskInput; Options: TtsMaskOptions): Boolean;
        function  CheckRange(Node: TtsPictureNode; var MaskInput: TtsMaskInput; Options: TtsMaskOptions): Boolean;
        function  CheckItem(Node: TtsPictureNode; var MaskInput: TtsMaskInput; Options: TtsMaskOptions): Boolean;
        procedure CheckCaseOptions(Node: TtsPictureNode; var Options: TtsMaskOptions);

        function  CheckNextItems(Stack: TtsParseStack; StackPos: Integer; Options: TtsMaskOptions;
                                 var MaskInput: TtsMaskInput; var NrOfMatches: Integer): Boolean;
        function  CheckSubItems(Stack: TtsParseStack; Parent: Integer; Node: TtsPictureNode;
                                Count: Integer; Options: TtsMaskOptions;
                                var MaskInput: TtsMaskInput; var NrOfMatches: Integer): Boolean;

        {Property procedures}
        procedure SetPicture(Value: string);
        function  GetTextCase: TtsTextCase;
        function  GetPictureList: TtsPictureList;
        function  ValidText(const Text: string; FullCompare: Boolean): Boolean;
        function  ValidInput(const Text: string; var InsertChars: string; InsertPos: Integer;
                             FullCompare, AutoFill: Boolean): Boolean;

        property PictureList: TtsPictureList read GetPictureList write FPictureList;
        property Picture: string read FPicture write SetPicture;
        property TextCase: TtsTextCase read GetTextCase;

    public
        constructor Create(Mask: TtsMask); virtual;
        destructor  Destroy; override;
    end;

    TtsMaskItem = class(TCollectionItem)
    protected
        function  GetAutoFill: TtsMaskChecks; virtual; abstract;
        procedure SetAutoFill(Value: TtsMaskChecks); virtual; abstract;
        function  GetEvaluate: TtsMaskChecks; virtual; abstract;
        procedure SetEvaluate(Value: TtsMaskChecks); virtual; abstract;
        function  GetName: string; virtual; abstract;
        procedure SetName(Value: string); virtual; abstract;
        function  GetPicture: string; virtual; abstract;
        procedure SetPicture(Value: string); virtual; abstract;
        function  GetTextCase: TtsTextCase; virtual; abstract;
        procedure SetTextCase(Value: TtsTextCase); virtual; abstract;

        function  GetOnChange: TNotifyEvent; virtual; abstract;
        procedure SetOnChange(Value: TNotifyEvent); virtual; abstract;
        function  GetOnParseError: TtsMaskErrorEvent; virtual; abstract;
        procedure SetOnParseError(Value: TtsMaskErrorEvent); virtual; abstract;

    public
        function  ValidText(const Text: string; FullCompare: Boolean): Boolean; virtual; abstract;
        function  ValidInput(const Text: string; var InsertChars: string; InsertPos: Integer;
                             FullCompare, AutoFill: Boolean): Boolean; virtual; abstract;

        property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
        property OnParseError: TtsMaskErrorEvent read GetOnParseError write SetOnParseError;

    published
        property AutoFill: TtsMaskChecks read GetAutoFill write SetAutoFill default [Low(TtsMaskCheck)..High(TtsMaskCheck)];
        property Evaluate: TtsMaskChecks read GetEvaluate write SetEvaluate default [Low(TtsMaskCheck)..High(TtsMaskCheck)];
        property Name: string read GetName write SetName;
        property Picture: string read GetPicture write SetPicture;
        property TextCase: TtsTextCase read GetTextCase write SetTextCase;
    end;

    TtsMask = class(TtsMaskItem)
    protected
        FName: string;
        FUpdateCount: Integer;

        {Property fields}
        FTextMask: TtsTextMask;
        FAutoFill: TtsMaskChecks;
        FEvaluate: TtsMaskChecks;
        FPicture: string;
        FTextCase: TtsTextCase;

        {Event fields}
        FOnChange: TNotifyEvent;
        FOnParseError: TtsMaskErrorEvent;

        {Error detection procedures}
        procedure InvalidOp(Msg: string);
        function  CheckRaise: Boolean;
        procedure DoParseError(Msg: string; var RaiseError: Boolean);

        function  ParentComponent: TComponent; virtual;
        procedure CheckName(Value: string);
        procedure BeginUpdate;
        procedure EndUpdate;
        procedure Changed; virtual;
        function  GetDisplayName: string; {$IFDEF TSVER_V3} override; {$ENDIF}
        procedure DoChange; virtual;

        {Property procedures}
        procedure SetAutoFill(Value: TtsMaskChecks); override;
        procedure SetEvaluate(Value: TtsMaskChecks); override;
        procedure SetName(Value: string); override;
        procedure SetPicture(Value: string); override;
        procedure SetTextCase(Value: TtsTextCase); override;
        function  GetAutoFill: TtsMaskChecks; override;
        function  GetEvaluate: TtsMaskChecks; override;
        function  GetName: string; override;
        function  GetPicture: string; override;
        function  GetTextCase: TtsTextCase; override;
        function  GetOnChange: TNotifyEvent; override;
        procedure SetOnChange(Value: TNotifyEvent); override;
        function  GetOnParseError: TtsMaskErrorEvent; override;
        procedure SetOnParseError(Value: TtsMaskErrorEvent); override;

        property TextMask: TtsTextMask read FTextMask;

    public
        constructor Create(Collection: TCollection); override;
        destructor  Destroy; override;

        procedure Assign(Source: TPersistent); override;
        function  ValidText(const Text: string; FullCompare: Boolean): Boolean; override;
        function  ValidInput(const Text: string; var InsertChars: string; InsertPos: Integer;
                             FullCompare, AutoFill: Boolean): Boolean; override;
    end;

    TtsMaskDefsComponent = class(TComponent)
    protected
        procedure RemoveLink(MaskLink: TtsMaskLink); virtual; abstract;
        procedure AddLink(MaskLink: TtsMaskLink); virtual; abstract;
        function  GetMask(Index: Variant): TtsMaskItem; virtual; abstract;
        procedure SetMask(Index: Variant; Value: TtsMaskItem); virtual; abstract;
    public
        property Mask[Index: Variant]: TtsMaskItem read GetMask write SetMask;
    end;

    TtsMaskDefs = class(TtsMaskDefsComponent)
    protected
        FMasks: TtsMaskCollection;
        FLinks: TList;

        procedure RemoveLink(MaskLink: TtsMaskLink); override;
        procedure AddLink(MaskLink: TtsMaskLink); override;
        function  GetMask(Index: Variant): TtsMaskItem; override;
        procedure SetMask(Index: Variant; Value: TtsMaskItem); override;
        procedure RemoveLinks;
        procedure SetMasks(Value: TtsMaskCollection);
        procedure CheckErrorEvent(Mask: TtsMask);
        procedure Changed(Mask: TtsMask); virtual;
        procedure DoParseError(Sender: TObject; Msg: string; var RaiseError: Boolean);

    public
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;

    published
        property Masks: TtsMaskCollection read FMasks write SetMasks;
    end;

    TtsMaskClass = class of TtsMask;

    TtsMaskCollection = class(TCollection)
    protected
        FMaskDefs: TtsMaskDefs;

        function  NameIndex(Name: string): Integer;
        function  GetMask(Index: Variant): TtsMask;
        procedure SetMask(Index: Variant; Value: TtsMask);
        procedure Update(Item: TCollectionItem); override;
        function  FindUniqueName(Item: TCollectionItem): string;
        function  GetOwner: TPersistent; {$IFDEF TSVER_V3} override; {$ENDIF}
        procedure SetItemName(Item: TCollectionItem); {$IFDEF TSVER_V3} override; {$ENDIF}

    public
        constructor Create(MaskDefs: TtsMaskDefs; MaskClass: TtsMaskClass);

        function  Add: TtsMask;

        property MaskDefs: TtsMaskDefs read FMaskDefs;
        property Items[Index: Variant]: TtsMask read GetMask write SetMask; default;
    end;

    TtsMaskLink = class(TPersistent)
    protected
        FMaskDefs: TtsMaskDefsComponent;

        procedure SetMaskDefs(Value: TtsMaskDefsComponent);
        procedure MaskChanged(Mask: TtsMaskItem); virtual;
        procedure MaskDefsDeleted; virtual;
        function  GetMask(Name: string): TtsMaskItem;

    public
        constructor Create;
        destructor Destroy; override;

        property MaskDefs: TtsMaskDefsComponent read FMaskDefs write SetMaskDefs;
        property Mask[Name: string]: TtsMaskItem read GetMask;
    end;

const
    StsPctExpChar = 'Error in mask %s, expected ''%s'' at position %d';
    StsPctErrEnd = 'Error in mask %s, unexpected end of picture';
    StsPctInvalidChar = 'Error in mask %s, invalid character ''%s'' at position %d';
    StsMaskNotUnique = 'Mask ''%s'' already exists. Mask names must be unique';

implementation

{$R *.dcr}