uvbase.pas

来自「FMA is a free1 powerful phone editing to」· PAS 代码 · 共 1,002 行 · 第 1/2 页

unit uVBase; // do not localize

{
*******************************************************************************
* Descriptions: vBase object
* $Source: /cvsroot/fma/fma/uVBase.pas,v $
* $Locker:  $
*
* Todo:
*
* Change Log:
* $Log: uVBase.pas,v $
*
*******************************************************************************
}

{$J+}

interface

uses
  Classes, TntClasses, Contnrs;

const
  VEntityType: array [0..4] of WideString = (
    'VUNKNOWN', 'VCARD', 'VCALENDAR', 'VTODO', 'VEVENT'
  );

type
  TVBaseObj = class;

  TVProperty = class(TObject)
  protected
    FOwner: TVBaseObj;

    FPropertyName: WideString;
    FPropertyValue: WideString;
    FPropertyParams: TStrings;

    FIsSet: Boolean;

    function GetText: WideString; virtual;
    procedure SetText(const Value: WideString); virtual;
    function GetEncodedText: WideString; virtual;
    procedure SetEncodedText(const Value: WideString); virtual;

    function GetPropertyName: WideString; virtual;
    procedure SetPropertyName(const Value: WideString); virtual;
    function GetPropertyValue: WideString; virtual;
    procedure SetPropertyValue(const Value: WideString); virtual;
    procedure SetPropertyParams(const Value: TStrings); virtual;

    function GetParamIndex(const Value: WideString): Integer;
  public
    constructor Create(Owner: TVBaseObj);
    destructor Destroy; override;

    procedure Clear; virtual;
    procedure CheckUTFs;
  published
    property IsSet: Boolean read FIsSet write FIsSet;

    property PropertyName: WideString read GetPropertyName write SetPropertyName;
    property PropertyValue: WideString read GetPropertyValue write SetPropertyValue;
    property PropertyParams: TStrings read FPropertyParams write SetPropertyParams;

    // TODO: Use folding
    property Text: WideString read GetText write SetText;
    property EncodedText: WideString read GetEncodedText write SetEncodedText;

    property Owner: TVBaseObj read FOwner;
  end;

  TVType = (
    tenVUnknown, tenVCard, tenVCalendar, tenVTodo, tenVEvent
  );

  { Encapsulates type of the entity }
  TVEntityType = class(TVProperty)
  protected
    FEntityType: TVType;

    procedure SetEntityType(const Value: TVType);

    function GetPropertyValue: WideString; override;
    procedure SetPropertyValue(const Value: WideString); override;
  published
    property EntityType: TVType read FEntityType write SetEntityType default tenVUnknown;
  end;

  TVCalCharSet = (
    tecNone = 0, tecAscii = 1, tecUtf8 = 2, tecUtf8Ascii = 3
  );

  TVBaseObj = class(TObjectList)
  protected
    FOwner: TVBaseObj;

    FItemIndex: Integer;
    FItemCounter: Integer;
    FCalCharSet: TVCalCharSet;

    isDestroying: Boolean;

    FStrList: TStrings;

    function GetRaw: TStrings; virtual;
    procedure SetRaw(const Value: TStrings); virtual;

    procedure SetProperty(AProp: TVProperty); virtual;

    // Returns newly created children entity TVBaseObject of specified type
    function CreateVObject(Value: WideString): TVBaseObj; virtual; abstract;
    function GetCalCharSet: TVCalCharSet;
  public
    VType: TVEntityType;
    VVersion: WideString;

    // FMA specific
    VFmaState: Integer; //0 new entry; 1 modified entry; 2 deleted entry; 3 normal entry

    constructor Create;
    destructor Destroy; override;

    procedure Clear; override;
    function Add(AVObj: TVBaseObj): Integer;

    function GetByItemIndex(const Value: Integer): TVBaseObj;
  published
    property Raw: TStrings read GetRaw write SetRaw;
    property ItemIndex: Integer read FItemIndex;
    property OutputCharSet: TVCalCharSet read GetCalCharSet write FCalCharSet default tecAscii;

    property Owner: TVBaseObj read FOwner;
  end;

  TVObjStorage = class(TObjectList)
  protected
    FItemCounter: Integer;

    isDestroying: Boolean;

    FStrList: TStrings;

    function GetRaw: TStrings; virtual;
    procedure SetRaw(const Value: TStrings); virtual;

    // Returns newly created VObject of specified type
    function CreateVObject(Value: WideString): TVBaseObj; virtual;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear; override;
    function Add(AVObj: TVBaseObj): Integer;

    procedure SaveToFile(const FileName: string); virtual;
    procedure LoadFromFile(const FileName: string); virtual;
  published
    property Raw: TStrings read GetRaw write SetRaw;
  end;

 { Returns position of searched string in array }
  function PosStrInArray(const SearchStr: WideString; Contents: array of WideString; const CaseSensitive: Boolean = False): Integer;

  function Str2QP(instr: String): String;
  function QP2Str(instr: String): String;

  function Str2B64(input: string): string;
  { Warning! Next function returns a new instance of stream! }
  function B642Str(instr: TStream): TStream;

  function UnfoldLines(Value: TStrings; var CurrPos: Integer): String;
  function RemoveSoftLineBreakes(Value1: String; Value: TStrings; var CurrPos: Integer): String;

implementation

uses
  cUnicodeCodecs,
  TntSystem, SysUtils, TntSysUtils, uVCalendar, uVCard;

function UnfoldLines(Value: TStrings; var CurrPos: Integer): String;
begin
  Result := '';
  Inc(CurrPos);
  try
    while (CurrPos < Value.Count) and ((Length(Value[CurrPos] ) > 0) and
      (Value[CurrPos][1] = ' ' )) do begin
      Result := Result + ' ' + Trim(Value[CurrPos]);
      Inc(CurrPos);
    end;
  finally
    // Correct for increment in the main while loop
    Dec(CurrPos);
  end;
end;

function RemoveSoftLineBreakes(Value1: String; Value: TStrings; var CurrPos: Integer): String;
begin
  { schnorbsl: now check for softbreaklines }
  Result := Value1;
  Inc(CurrPos);
  try
    while (CurrPos < Value.Count) and ((Length(Result) > 0) and
      (Result[Length(Result)] = '=' )) do begin
      Result := Copy(Result, 1, Length(Result)-1) + Value[CurrPos];
      Inc(CurrPos);
    end;
  finally
    // Correct for increment in the main while loop
    Dec(CurrPos);
  end;
end;

{ Returns position of searched string in array }
function PosStrInArray(const SearchStr: WideString; Contents: array of WideString; const CaseSensitive: Boolean = False): Integer;
begin
  for Result := Low(Contents) to High(Contents) do
  begin
    if CaseSensitive then
    begin
      if SearchStr = Contents[Result] then Exit;
    end
    else begin
      if WideSameText(SearchStr, Contents[Result]) then Exit;
    end;
  end;
  Result := -1;
end;

const
  _Code64: string[64]=('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');

function Str2QP(instr: String): String;
var
  i,j,k,m,n: Integer;
begin
  {
  Quoted-Printable lines of text must also be limited to less than 76 characters.
  The 76 characters does not include the CRLF (RFC 822) line break sequence.
  For example a multiple line LABEL property value of:

  123 Winding Way
  Any Town, CA 12345
  USA

  Would be represented in a Quoted-Printable encoding as:

  LABEL;ENCODING=QUOTED-PRINTABLE:123 Winding Way=0D=0A=Any Town, CA 12345=0D=0A=USA
  }
  { DO NOT use Trim here since it will remove trailing CRLF chars!
  instr := trim(instr);
  }
  Result := '';
  j := 0; k := Length(instr);
  for i := 1 to k do begin
    if instr[i] = '=' then begin
      Result := Result + '=' + IntToHex(Ord(instr[i]),2);
      inc(j,2);
    end
    else
      if ((instr[i] >= #32) and (instr[i] <= #126)) then
        Result := Result + instr[i]
      else begin
        Result := Result + '=' + IntToHex(Ord(instr[i]),2);
        inc(j,2);
      end;
    inc(j);
    // should we fold the line? 73 (+ max next 3) <= max 76
    if (j > 73) and (i < k) then begin
      // Folding the result into several lines is possible wherever there may be
      // linear white space (NOT simply LWSP-chars), a CRLF immediately followed
      // by at least one LWSP-char may instead be inserted.
      n := Length(Result);
      m := n;
      { find latest LWSP-char }
      while (m <> 0) and (Result[m] <> ' ') do dec(m);
      { if found insert soft line break and CRLF before it }
      if m <> 0 then begin
        Insert('=' + sLinebreak,Result,m);
        j := n - m + 1; // count the LWSP-char too
      end;
    end;
  end;
end;

function QP2Str(instr: String): String;
begin
  { Trim here since it will remove trailing CRLF chars! }
  instr := trim(instr);
  Result := '';

  while length(instr) > 0 do begin
    // Check for 'soft' line break
    if (instr[1] = '=') and (Length(instr) >= 3) then begin
      Result := Result + chr(StrToInt('$' + instr[2] + instr[3]));
      Delete(instr, 1, 3);
    end
    else begin
      // If 'soft' line break, just delete it
      if instr[1] <> '=' then Result := Result + instr[1];
      Delete(instr, 1, 1);
    end;
  end;
end;

function Str2B64(input: string): string;
const charBase64:array[0..63] of char =
    ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P',
 	 	 'Q','R','S','T','U','V','W','X','Y','Z','a','b','c','d','e','f',
  	 'g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v',
		 'w','x','y','z','0','1','2','3','4','5','6','7','8','9','+','/');
var C: array[1..3] of byte;
    E: array[1..4] of byte;
    i,len:integer;
begin
  Result := '';
  len := Length(input);
  i:=0;
  while i < len do
  begin
    case len-i of
    1:
      begin
        c[1]:=ord(input[i+1]);
        i:=i+1;
        E[1] := c[1] shr 2;
        E[2] := ((c[1] and 3) shl 4);
        Result := Result + charBase64[E[1]]+charBase64[E[2]];
        Result := Result + '==';
      end;
    2:
      begin
        c[1]:=ord(input[i+1]);
        i:=i+1;
        c[2]:=ord(input[i+1]);
        i:=i+1;
        E[1] := c[1] shr 2;
        E[2] := ((c[1] and 3) shl 4) or (C[2] shr 4);
        E[3] := ((c[2] and 15) shl 2);
        Result := Result + charBase64[E[1]]+charBase64[E[2]];
        Result := Result + charBase64[E[3]]+'=';
      end;
    else
      begin
        c[1]:=ord(input[i+1]);
        i:=i+1;
        c[2]:=ord(input[i+1]);
        i:=i+1;
        c[3]:=ord(input[i+1]);
        i:=i+1;
        E[1] := c[1] shr 2;
        E[2] := ((c[1] and 3) shl 4) or (C[2] shr 4);
        E[3] := ((c[2] and 15) shl 2) or (C[3] shr 6);
        E[4] := c[3] and 63;
        Result := Result + charBase64[E[1]]+charBase64[E[2]];
        Result := Result + charBase64[E[3]]+charBase64[E[4]];
      end;
    end;
  end;
end;

function B642Str(instr: TStream): TStream;
var
  S2: TMemoryStream;
  A1: array[1..4] of Byte;
  B1: array[1..3] of Byte;
  Byte_Ptr,Real_Bytes: Integer;
  B: Byte;
  C: Char;
begin
  instr.Seek(0,soFromBeginning);
  S2:= TMemoryStream.Create;
  try
    Byte_Ptr:= Low(A1);
    while instr.Position < instr.Size do
    begin
      instr.ReadBuffer(C, SizeOf(C));
      if C > ' ' then
      begin
        case C of
          'A'..'Z': B:=Ord(C)-65;  {<65..90>  --> <0..25>}
          'a'..'z': B:=Ord(C)-71;  {<97..122>  --> <26..51>}
          '0'..'9': B:=Ord(C)+4;   {<48..57>  --> <52..61>}
          '+': B:=62;{43}
          '/': B:=63;{47}
        else
          {'=': }B:=64;{61}
        end;
        A1[Byte_Ptr]:= B;
        Inc(Byte_Ptr);
        if Byte_Ptr=High(A1)+1 then
        begin
          Byte_ptr:=Low(A1);
          Real_Bytes:=3;
          if A1[1]=64 then Real_Bytes:=0;
          if A1[3]=64 then
          begin
            a1[3]:=0;
            a1[4]:=0;
            real_bytes:=1;
          end;
          if a1[4]=64 then
          begin
            a1[4]:=0;
            real_bytes:=2;
          end;
          b1[1]:=a1[1]*4+(a1[2] div 16);
          b1[2]:=(a1[2] mod 16)*16+(a1[3]div 4);
          b1[3]:=(a1[3] mod 4)*64 +a1[4];
          S2.WriteBuffer(b1, real_bytes);
        end;
      end;
    end;
  finally
    result := S2;
    result.Seek(0,soFromBeginning);
  end;
end;

{ TVProperty }

constructor TVProperty.Create(Owner: TVBaseObj);
begin
  inherited Create;

  FOwner := Owner;

  FIsSet := False;

  FPropertyParams := TStringList.Create;
  FPropertyParams.Delimiter := ';';
  (FPropertyParams as TStringList).CaseSensitive := False;
end;

destructor TVProperty.Destroy;
begin
  FPropertyParams.Free;

  inherited;
end;

procedure TVProperty.Clear;
begin
  FIsSet := False;

  FPropertyName := '';
  FPropertyValue := '';
  if FPropertyParams <> nil then FPropertyParams.Clear;
end;

function TVProperty.GetText: WideString;
begin
  Result := '';

  if FIsSet then
  begin
    Result := PropertyName;
    if PropertyParams.Count <> 0 then
      Result := Result + ';' + LongStringToWideString(PropertyParams.DelimitedText);
    Result := Result + ':' + PropertyValue;
  end;
end;

procedure TVProperty.SetText(const Value: WideString);
var
  PropText: WideString;
  StrLen: Integer;
  ParamStart, ParamEnd: Integer;
begin
  PropText := Trim(Value);
  StrLen := Length(PropText);

  if StrLen > 0 then begin
    FIsSet := True;

    ParamStart := Pos(';', PropText);
    ParamEnd := Pos(':', PropText);

    if (ParamStart = 0) or (ParamStart > ParamEnd) then begin
      ParamStart := ParamEnd;
      PropertyParams.Text := '';
    end
    else
      PropertyParams.DelimitedText := UpperCase(Copy(PropText, ParamStart + 1, ParamEnd - ParamStart - 1));

    { Use Trim() here to correct any Unfolded "name :value" }
    PropertyName := Trim(WideUpperCase(Copy(PropText, 1, ParamStart - 1)));
    PropertyValue := Copy(PropText, ParamEnd + 1, StrLen - ParamEnd);
  end
  else
    FIsSet := False;
end;

function TVProperty.GetEncodedText: WideString;
var
  strTemp: WIdeString;
  strUtf8: WideString;
  strQP: WideString;
begin
  Result := '';