tsmask.pas

企业进销存管理系统

uses
    TSMbcs, TSGLib, Dialogs;

var
    FNodeCount: Integer = 0;

const
    VersionNumber = '2.0';
    
    {Picture mask characters}
    tsPicDigit = '#';
    tsPicLetter = '?';
    tsPicUpperLetter = '&';
    tsPicAny = '@';
    tsPicUpperAny = '!';

    tsPicOptStartChar = '[';
    tsPicOptEndChar = ']';
    tsPicNonOptStartChar = '{';
    tsPicNonOptEndChar = '}';
    tsPicAltChar = ',';
    tsPicNotChar = '^';
    tsPicRangeChar = '-';
    tsPicEscapeChar = ';';
    tsPicCountChar = '*';
    tsPicLower = '<';
    tsPicUpper = '>';

    tsPicAllChars = tsPicOptStartChar + tsPicCountChar + tsPicAny + tsPicOptEndChar;
    tsPicMaskChars = [tsPicDigit, tsPicLetter, tsPicUpperLetter, tsPicAny,
                      tsPicUpperAny];
    tsPicNonMaskChars = [tsPicAltChar, tsPicOptStartChar, tsPicOptEndChar,
                         tsPicNonOptStartChar, tsPicNonOptEndChar, tsPicNotChar,
                         tsPicEscapeChar, tsPicCountChar, tsPicLower, tsPicUpper];
    tsPicCharSet = tsPicMaskChars + tsPicNonMaskChars + [tsPicRangeChar];
    tsPicNonLiteral = tsPicMaskChars + tsPicNonMaskChars;

function SetMaskInput(Text: string; TextPos, InsertPos, InsertLen: Integer): TtsMaskInput;
begin
    Result.Text := Text;
    Result.TextPos := 1;
    Result.InsertPos := InsertPos;
    Result.InsertLen := InsertLen;
    Result.Literals := '';
    Result.MatchedLiterals := '';
    Result.MinMatchedLiterals := '';
    Result.InsertChars := '';
end;

procedure CopyMaskInput(const FromInput: TtsMaskInput; var ToInput: TtsMaskInput);
var
    Literals: string;
    MinLiterals: string;
    InsertChars: string;
begin
    Literals := ToInput.MatchedLiterals;
    MinLiterals := ToInput.MinMatchedLiterals;
    InsertChars := ToInput.InsertChars;
    ToInput := FromInput;
    ToInput.MatchedLiterals := Literals;
    ToInput.MinMatchedLiterals := MinLiterals;
    ToInput.InsertChars := InsertChars;
end;

{TtsPictureNode}

constructor TtsPictureNode.Create(NodeType: TtsPictureNodeType);
begin
    inherited Create;
    FNodeType := NodeType;
    FCount := 0;
    FOptional := False;
    FComplement := False;
    FStartPos := 0;
    FEndPos := 0;
    FCharCount := 0;
    FSubItems := nil;
    FNextItem := nil;
    FNextAlternative := nil;
    Inc(FNodeCount);
end;

destructor TtsPictureNode.Destroy;
begin
    FSubItems.Free;
    FNextItem.Free;
    FNextAlternative.Free;
    inherited;
end;

{TtsPictureList}

constructor TtsPictureList.Create(PictureType: TtsPictureType);
begin
    inherited Create;
    FPictureType := PictureType;
    FStartNode := nil;
end;

destructor TtsPictureList.Destroy;
begin
    FStartNode.Free;
    inherited;
end;

{TtsParseStack}

constructor TtsParseStack.Create;
begin
    inherited;
    FBuffer := nil;
    FBufSize := 0;
    FCount := 0;
end;

destructor TtsParseStack.Destroy;
begin
    ReallocMem(FBuffer, 0);
    inherited;
end;

function TtsParseStack.Push(Parent: Integer; Node: TtsPictureNode; TextPos, Count: Integer): Integer;
begin
    if FCount >= FBufSize then
    begin
        FBufSize := FCount + 10;
        ReallocMem(FBuffer, FBufSize * SizeOf(TtsParseStackElement));
    end;

    Inc(FCount);
    FBuffer[FCount].Parent := Parent;
    FBuffer[FCount].Node := Node;
    FBuffer[FCount].Count := Count;
    FBuffer[FCount].TextPos := TextPos;
    Result := FCount;
end;

procedure TtsParseStack.Pop;
begin
    if Count > 0 then Dec(FCount);
end;

procedure TtsParseStack.Reset;
begin
    FCount := 0;
end;

{TtsTextCase}

constructor TtsTextCase.Create(Mask: TtsMask);
begin
    inherited Create;
    FMask := Mask;
    FCaseType := cstNone;
    FOptional := False;
end;

procedure TtsTextCase.Assign(Source: TPersistent);
begin
    if Source is TtsTextCase then
    begin
        FCaseType := TtsTextCase(Source).CaseType;
        FOptional := TtsTextCase(Source).Optional;
    end
    else
        inherited;
end;

procedure TtsTextCase.SetCaseType(Value: TtsCaseType);
begin
    if FCaseType <> Value then
    begin
        FCaseType := Value;
        FMask.Changed;
    end;
end;

procedure TtsTextCase.SetOptional(Value: Boolean);
begin
    if FOptional <> Value then
    begin
        FOptional := Value;
        FMask.Changed;
    end;
end;

{TtsTextMask}

constructor TtsTextMask.Create(Mask: TtsMask);
begin
    inherited Create;
    FMask := Mask;
    FPicture := '';
    FPictureLength := Length(Picture);
    FPictureList := nil;
    FCreateTree := False;
    FValidPicture := True;
    FPictureParsed := True;
end;

destructor TtsTextMask.Destroy;
begin
    FPictureList.Free;
    inherited;
end;

procedure TtsTextMask.ErrChar(Chars: string; TextPos: Integer);
var
    Msg: string;
begin
    Msg := Format(StsPctExpChar, [FMask.Name, Chars, TextPos]);
    FMask.InvalidOp(Msg);
end;

function TtsTextMask.CreatePictureTree(PictureType: TtsPictureType): TtsPictureList;
begin
    Result := nil;
    if FCreateTree then Result := TtsPictureList.Create(PictureType);
end;

function TtsTextMask.CreatePictureNode(NodeType: TtsPictureNodeType): TtsPictureNode;
begin
    Result := nil;
    if FCreateTree then Result := TtsPictureNode.Create(NodeType);
end;

function TtsTextMask.CharCount(const Text: string; TextPos: Integer): Integer;
begin
    Result := 1;
    if tsIsFarEast then
    begin
        if StrByteType(PChar(Text) + TextPos - 1, 0) <> mbSingleByte then
            Result := 2;
    end;
end;

function TtsTextMask.PictureCharCount(TextPos: Integer): Integer;
begin
    if Picture[TextPos] = tsPicEscapeChar then
    begin
        if TextPos + 1 > FPictureLength then FMask.InvalidOp(Format(StsPctErrEnd, [FMask.Name]));
        if tsIsfarEast then Result := CharCount(Picture, TextPos + 1) + 1
                       else Result := 2;
    end
    else if Picture[TextPos] = tsPicLower then
    begin
        Result := 1;
        if (TextPos < FPictureLength) and
           (Picture[TextPos+1] in [tsPicUpper, tsPicLower]) then Inc(Result);
    end
    else if Picture[TextPos] = tsPicUpper then
    begin
        Result := 1;
        if (TextPos < FPictureLength) and
           (Picture[TextPos+1] = tsPicUpper) then Inc(Result);
    end
    else
    begin
        if tsIsFarEast then Result := CharCount(Picture, TextPos)
                       else Result := 1;
    end
end;

function TtsTextMask.IsLiteral(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;

    Result := (Picture[TextPos] = tsPicEscapeChar) or
              not (Picture[TextPos] in tsPicNonLiteral);
end;

function TtsTextMask.IsMaskChar(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := Picture[TextPos] in tsPicMaskChars;
end;

function TtsTextMask.IsCaseChar(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := (Picture[TextPos] = tsPicUpper) or
              (Picture[TextPos] = tsPicLower);
end;

function TtsTextMask.IsRangeChar(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := Picture[TextPos] = tsPicRangeChar;
end;

function TtsTextMask.IsCountChar(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := Picture[TextPos] = tsPicCountChar;
end;

function TtsTextMask.IsGroupStart(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := (Picture[TextPos] = tsPicOptStartChar) or
              (Picture[TextPos] = tsPicNonOptStartChar);
end;

function TtsTextMask.IsGroupEnd(TextPos: Integer): Boolean;
begin
    Result := False;
    if TextPos > FPictureLength then Exit;
    Result := (Picture[TextPos] = tsPicOptEndChar) or
              (Picture[TextPos] = tsPicNonOptEndChar);
end;

procedure TtsTextMask.CheckGroupEnd(var TextPos: Integer; EndChar: Char);
begin
    if EndChar <> #0 then
    begin
        if (TextPos > FPictureLength) or (Picture[TextPos] <> EndChar) then
            ErrChar(EndChar, TextPos);
        Inc(TextPos);
    end;
end;

function TtsTextMask.IsRange(TextPos: Integer; var Chars: Integer): Boolean;
var
    Pos: Integer;
    RangeOk: Boolean;
begin
    Chars := 0;
    Pos := TextPos;
    Result := False;
    if Pos > FPictureLength then Exit;

    if Picture[Pos] = tsPicNotChar then Inc(Pos);
    RangeOk := IsLiteral(Pos);

    if RangeOk then
    begin
        Pos := Pos + PictureCharCount(Pos);
        RangeOk := IsRangeChar(Pos);
    end;

    if RangeOk then
    begin
        Inc(Pos);
        RangeOk := IsLiteral(Pos);
    end;

    if RangeOk then
    begin
        Pos := Pos + PictureCharCount(Pos);
        RangeOk := IsGroupEnd(Pos);
    end;

    Result := RangeOk;
    if Result then Chars := Pos - TextPos;
end;

function TtsTextMask.GetItemCount(var TextPos: Integer): Integer;
var
    Pos: Integer;
    CountStr: string;
begin
    Result := 1;
    if Picture[TextPos] <> tsPicCountChar then Exit;

    CountStr := '';
    Pos := TextPos + 1;
    while Pos <= FPictureLength do
    begin
        if not (Picture[Pos] in ['0'..'9']) then Break;
        Inc(Pos);
    end;

    if Pos > TextPos + 1 then CountStr := Copy(Picture, TextPos + 1, Pos - TextPos - 1);
    TextPos := Pos;

    if CountStr = '' then Result := -1
                     else Result := StrToInt(CountStr);
end;

function TtsTextMask.GetGroupType(var TextPos: Integer; var EndChar: Char): Boolean;
begin
    Result := False;
    EndChar := #0;
    if TextPos > FPictureLength then Exit;

    if Picture[TextPos] = tsPicOptStartChar then
    begin
        Result := True;
        TextPos := TextPos + 1;
        EndChar := tsPicOptEndChar;
    end
    else if Picture[TextPos] = tsPicNonOptStartChar then
    begin
        TextPos := TextPos + 1;
        EndChar := tsPicNonOptEndChar;