strhlder.pas

企业端数据申报系统：单位管理模块 单位查询. 业务申报模块 在线数据下载 在线数据上传 在线业务申核 申报业务查询 磁盘数据导出 磁盘数据导入 在线业务模块 在线业务

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1996 AO ROSNO                   }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}

unit StrHlder;

interface

{$I RX.INC}

uses SysUtils, Classes, Variants, RTLConsts;

type

{$IFDEF RX_D3}

{ TMacro }

  TMacros = class;
  TMacroTextEvent = procedure(Sender: TObject; Data: Variant; 
    var Text: string) of object;
  
  TMacro = class(TCollectionItem)
  private
    FName: string;
    FData: Variant;
    FOnGetText: TMacroTextEvent;
    function IsMacroStored: Boolean;
    function GetText: string;
    function GetMacros: TMacros;
  protected
    function GetDisplayName: string; override;
    procedure SetDisplayName(const Value: string); override;
    procedure GetMacroText(var AText: string);
    function GetAsVariant: Variant;
    procedure SetAsVariant(Value: Variant);
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
    function IsEqual(Value: TMacro): Boolean;
    property Macros: TMacros read GetMacros;
    property Text: string read GetText;
  published
    property Name: string read FName write SetDisplayName;
    property Value: Variant read GetAsVariant write SetAsVariant stored IsMacroStored;
    property OnGetText: TMacroTextEvent read FOnGetText write FOnGetText;
  end;

{ TMacros }

  TMacros = class({$IFDEF RX_D4}TOwnedCollection{$ELSE}TCollection{$ENDIF})
  private
    function GetMacroValue(const MacroName: string): Variant;
    procedure SetMacroValue(const MacroName: string;
      const Value: Variant);
    function GetItem(Index: Integer): TMacro;
    procedure SetItem(Index: Integer; Value: TMacro);
  public
{$IFDEF RX_D4}
    constructor Create(AOwner: TPersistent);
{$ELSE}
    constructor Create;
{$ENDIF}
    procedure AssignValues(Value: TMacros);
    procedure AddMacro(Value: TMacro);
    procedure RemoveMacro(Value: TMacro);
    function CreateMacro(const MacroName: string): TMacro;
    procedure GetMacroList(List: TList; const MacroNames: string);
    function IndexOf(const AName: string): Integer;
    function IsEqual(Value: TMacros): Boolean;
    function ParseString(const Value: string; DoCreate: Boolean; 
      SpecialChar: Char): string;
    function MacroByName(const Value: string): TMacro;
    function FindMacro(const Value: string): TMacro;
    property Items[Index: Integer]: TMacro read GetItem write SetItem; default;
    property MacroValues[const MacroName: string]: Variant read GetMacroValue write SetMacroValue;
  end;

{$ENDIF RX_D3}

{ TStrHolder }

  TStrHolder = class(TComponent)
  private
    FStrings: TStrings;
    FXorKey: string;
    FReserved: Integer;
{$IFDEF RX_D3}
    FMacros: TMacros;
    FMacroChar: Char;
    FOnExpandMacros: TNotifyEvent;
{$ENDIF}
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    function GetDuplicates: TDuplicates;
    procedure SetDuplicates(Value: TDuplicates);
    function GetSorted: Boolean;
    procedure SetSorted(Value: Boolean);
    procedure SetStrings(Value: TStrings);
    procedure StringsChanged(Sender: TObject);
    procedure StringsChanging(Sender: TObject);
    procedure ReadStrings(Reader: TReader);
    procedure WriteStrings(Writer: TWriter);
    procedure ReadVersion(Reader: TReader);
    procedure WriteVersion(Writer: TWriter);
{$IFDEF WIN32}
    function GetCommaText: string;
    procedure SetCommaText(const Value: string);
{$ENDIF}
{$IFDEF RX_D3}
    function GetCapacity: Integer;
    procedure SetCapacity(NewCapacity: Integer);
{$ENDIF}
{$IFDEF RX_D3}
    procedure SetMacros(Value: TMacros);
    procedure RecreateMacros;
    procedure SetMacroChar(Value: Char);
{$ENDIF}
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Changed; dynamic;
    procedure Changing; dynamic;
{$IFDEF RX_D3}
    procedure BeforeExpandMacros; dynamic;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
{$IFDEF RX_D3}
    function MacroCount: Integer;
    function MacroByName(const MacroName: string): TMacro;
    function ExpandMacros: string;
{$ENDIF}
{$IFDEF WIN32}
    property CommaText: string read GetCommaText write SetCommaText;
{$ENDIF}
  published
{$IFDEF RX_D3}
    property Capacity: Integer read GetCapacity write SetCapacity default 0;
    property MacroChar: Char read FMacroChar write SetMacroChar default '%';
    property Macros: TMacros read FMacros write SetMacros;
    property OnExpandMacros: TNotifyEvent read FOnExpandMacros write FOnExpandMacros;
{$ENDIF}
    property Duplicates: TDuplicates read GetDuplicates write SetDuplicates
      default dupIgnore;
    property KeyString: string read FXorKey write FXorKey stored False;
    property Sorted: Boolean read GetSorted write SetSorted default False;
    property Strings: TStrings read FStrings write SetStrings stored False;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;

implementation

uses
{$IFDEF RX_D3}
  Consts,
{$ENDIF}
  rxStrUtils;

const
  XorVersion = 1;

{$IFDEF RX_D3}

function ExtractName(const Items: string; var Pos: Integer): string;
var
  I: Integer;
begin
  I := Pos;
  while (I <= Length(Items)) and (Items[I] <> ';') do Inc(I);
  Result := Trim(Copy(Items, Pos, I - Pos));
  if (I <= Length(Items)) and (Items[I] = ';') then Inc(I);
  Pos := I;
end;

function NameDelimiter(C: Char; Delims: TCharSet): Boolean;
begin
  Result := (C in [' ', ',', ';', ')', #13, #10]) or (C in Delims);
end;

function IsLiteral(C: Char): Boolean;
begin
  Result := C in ['''', '"'];
end;

procedure CreateMacros(List: TMacros; const Value: PChar; SpecialChar: Char; Delims: TCharSet);
var
  CurPos, StartPos: PChar;
  CurChar: Char;
  Literal: Boolean;
  EmbeddedLiteral: Boolean;
  Name: string;

  function StripLiterals(Buffer: PChar): string;
  var
    Len: Word;
    TempBuf: PChar;

    procedure StripChar(Value: Char);
    begin
      if TempBuf^ = Value then
        StrMove(TempBuf, TempBuf + 1, Len - 1);
      if TempBuf[StrLen(TempBuf) - 1] = Value then
        TempBuf[StrLen(TempBuf) - 1] := #0;
    end;

  begin
    Len := StrLen(Buffer) + 1;
    TempBuf := AllocMem(Len);
    Result := '';
    try
      StrCopy(TempBuf, Buffer);
      StripChar('''');
      StripChar('"');
      Result := StrPas(TempBuf);
    finally
      FreeMem(TempBuf, Len);
    end;
  end;

begin
  if SpecialChar = #0 then Exit;
  CurPos := Value;
  Literal := False;
  EmbeddedLiteral := False;
  repeat
    CurChar := CurPos^;
    if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ <> SpecialChar) then
    begin
      StartPos := CurPos;
      while (CurChar <> #0) and (Literal or not NameDelimiter(CurChar, Delims)) do begin
        Inc(CurPos);
        CurChar := CurPos^;
        if IsLiteral(CurChar) then begin
          Literal := Literal xor True;
          if CurPos = StartPos + 1 then EmbeddedLiteral := True;
        end;
      end;
      CurPos^ := #0;
      if EmbeddedLiteral then begin
        Name := StripLiterals(StartPos + 1);
        EmbeddedLiteral := False;
      end
      else Name := StrPas(StartPos + 1);
      if Assigned(List) then begin
        if List.FindMacro(Name) = nil then
          List.CreateMacro(Name);
      end;
      CurPos^ := CurChar;
      StartPos^ := '?';
      Inc(StartPos);
      StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
      CurPos := StartPos;
    end
    else if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ = SpecialChar) then
      StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
    else if IsLiteral(CurChar) then Literal := Literal xor True;
    Inc(CurPos);
  until CurChar = #0;
end;

{ TMacro }

constructor TMacro.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FData := Unassigned;
end;

procedure TMacro.Assign(Source: TPersistent);
begin
  if (Source is TMacro) and (Source <> nil) then begin
    if VarIsEmpty(TMacro(Source).FData) then Clear
    else Value := TMacro(Source).FData;
    Name := TMacro(Source).Name;
  end;
end;

function TMacro.GetDisplayName: string;
begin
  if FName = '' then 
    Result := inherited GetDisplayName 
  else 
    Result := FName;
end;

procedure TMacro.SetDisplayName(const Value: string);
begin
  if (Value <> '') and (AnsiCompareText(Value, FName) <> 0) and
    (Collection is TMacros) and (TMacros(Collection).IndexOf(Value) >= 0) then
    raise Exception.Create(SDuplicateString);    
  FName := Value;
  inherited;
end;

procedure TMacro.GetMacroText(var AText: string);
begin
  if Assigned(FOnGetText) then FOnGetText(Self, FData, AText);
end;

function TMacro.GetText: string;
begin
  Result := FData;
  GetMacroText(Result);
end;

function TMacro.GetMacros: TMacros;
begin
  if Collection is TMacros then 
    Result := TMacros(Collection)
  else 
    Result := nil;
end;

procedure TMacro.Clear;
begin
  FData := Unassigned;
end;

function TMacro.IsMacroStored: Boolean;
begin
  Result := not VarIsEmpty(FData);
end;

function TMacro.GetAsVariant: Variant;
begin
  Result := FData;
end;

procedure TMacro.SetAsVariant(Value: Variant);
begin
  FData := Value;
end;

function TMacro.IsEqual(Value: TMacro): Boolean;
begin
  Result := (VarType(FData) = VarType(Value.FData)) and
    (VarIsEmpty(FData) or (FData = Value.FData)) and
    (Name = Value.Name);
end;

{ TMacros }

{$IFDEF RX_D4}
constructor TMacros.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner, TMacro);
end;
{$ELSE}
constructor TMacros.Create;
begin
  inherited Create(TMacro);
end;
{$ENDIF}

function TMacros.IndexOf(const AName: string): Integer;
begin
  for Result := 0 to Count - 1 do
    if AnsiCompareText(TMacro(Items[Result]).Name, AName) = 0 then Exit;
  Result := -1;
end;

function TMacros.GetItem(Index: Integer): TMacro;
begin
  Result := TMacro(inherited Items[Index]);
end;

procedure TMacros.SetItem(Index: Integer; Value: TMacro);
begin
  inherited SetItem(Index, TCollectionItem(Value));
end;

procedure TMacros.AddMacro(Value: TMacro);
begin
  Value.Collection := Self;
end;