unit uVStringList;

interface
  uses Variants, Classes ;

type
  TVStringList = class(TStringList)
  published
    function Add(const S: string): Integer; override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function Find(const S: string; var Index: Integer): Boolean; override;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure InsertObject(Index: Integer; const S: string;
      AObject: TObject); override;
    procedure Sort; override;
    procedure CustomSort(Compare: TStringListSortCompare); override;
    property Duplicates;
    property Sorted;
    property CaseSensitive;
  end;

function VarStringListCreate: Variant;
function VarStringList: TVarType;

implementation
  uses TypInfo, SysUtils ;

type
  TStringListVariantType = class(TPublishableVariantType, IVarStreamable)
  protected
    function LeftPromotion(const V: TVarData; const Operator: TVarOp;
      out RequiredVarType: TVarType): Boolean; override;
    function RightPromotion(const V: TVarData; const Operator: TVarOp;
      out RequiredVarType: TVarType): Boolean; override;
    function GetInstance(const V: TVarData): TObject; override;
  public
    procedure Clear(var V: TVarData); override;
    function IsClear(const V: TVarData): Boolean; override;
    procedure Copy(var Dest: TVarData; const Source: TVarData;
      const Indirect: Boolean); override;
    procedure Cast(var Dest: TVarData; const Source: TVarData); override;
    procedure CastTo(var Dest: TVarData; const Source: TVarData;
      const AVarType: TVarType); override;

    procedure BinaryOp(var Left: TVarData; const Right: TVarData;
      const Operator: TVarOp); override;
    function CompareOp(const Left: TVarData; const Right: TVarData;
      const Operator: Integer): Boolean; override;

    procedure StreamIn(var Dest: TVarData; const Stream: TStream);
    procedure StreamOut(const Source: TVarData; const Stream: TStream);
  end;

var
  StringListVariantType: TStringListVariantType = nil;

type
  TStringListVarData = packed record
    VType: TVarType;
    Reserved1, Reserved2, Reserved3: Word;
    VStringList: TVStringList;
    Reserved4: LongInt;
  end;

procedure VarStringListCreateInto(var ADest: Variant; const AStringList: TVStringList);
begin
  VarClear(ADest);
  TStringListVarData(ADest).VType := VarStringList;
  TStringListVarData(ADest).VStringList := AStringList;
end;

function VarStringListCreate: Variant;
begin
  VarStringListCreateInto(Result, TVStringList.Create);
end;

function VarStringList;
begin
  Result := StringListVariantType.VarType;
end ;

{ TStringListVariantType }

procedure TStringListVariantType.BinaryOp(var Left: TVarData;
  const Right: TVarData; const Operator: TVarOp);
var
  AStringListL : TVStringList ;
  i, index : integer ;
begin
  { On accepte
      V1 op qqchose qui se transforme en chaîne
      V1 op V2
  }

  if Right.VType = VarType then begin
    if (Left.VType = VarType) then begin
    end else begin
      RaiseInvalidOp; // x + V2 interdit
    end;

  end else if Left.VType = VarType then begin
    AStringListL := TStringListVarData(Left).VStringList ;
    case Operator of
      opAdd: begin
        if Right.VType <> VarType then begin
          AStringListL.Add(Variant(Right)); { StringList + TypeX }
        end else begin
          with TStringListVarData(Right).VStringList do begin { StringList + StringList }
            for i := 0 to Pred (count) do begin
              AStringListL.Add(Strings[i])
            end ;
          end;
        end ;
      end ;
      opSubtract: begin { StringList - TypeX }
        index := AStringListL.IndexOf(Variant(Right));
        if index <> -1 then begin
          AStringListL.Delete (index) ;
        end ;
      end ;
    else
      RaiseInvalidOp; // les autres opérateurs sont interdits
    end
  end else begin
    RaiseInvalidOp;
  end ;
end;

procedure TStringListVariantType.Cast(var Dest: TVarData;
  const Source: TVarData);
begin
  inherited;

end;

procedure TStringListVariantType.CastTo(var Dest: TVarData;
  const Source: TVarData; const AVarType: TVarType);
begin
  if Source.VType = VarType then begin
    case AVarType of
      varOleStr:
        VarDataFromOleStr(Dest, TStringListVarData(Source).VStringList.CommaText);
      varString:
        VarDataFromStr(Dest, TStringListVarData(Source).VStringList.CommaText);
    else
      RaiseCastError;
    end ;
  end else begin
    inherited;
  end ;
end;

procedure TStringListVariantType.Clear(var V: TVarData);
begin
  V.VType := varEmpty;
  FreeAndNil(TStringListVarData(V).VStringList);
end;

function TStringListVariantType.CompareOp(const Left, Right: TVarData;
  const Operator: Integer): Boolean;
var
  AStringListL, AStringListR : TVStringList ;
begin
  Result := False;
  if (Left.VType = VarType) and (Right.VType = VarType) then begin
    AStringListL := TStringListVarData(Left).VStringList ;
    AStringListR := TStringListVarData(Right).VStringList ;
    case Operator of
      opCmpEQ:
        Result := AStringListL.Count = AStringListR.Count;
      opCmpNE:
        Result := not (AStringListL.Count = AStringListR.Count) ;
      opCmpLT:
        Result := AStringListL.Count < AStringListR.Count;
      opCmpLE:
        Result := AStringListL.Count <= AStringListR.Count;
      opCmpGT:
        Result := AStringListL.Count > AStringListR.Count;
      opCmpGE:
        Result := AStringListL.Count >= AStringListR.Count;
    else
      RaiseInvalidOp;
    end
  end else begin
    RaiseInvalidOp;
  end;
end;

procedure TStringListVariantType.Copy(var Dest: TVarData;
  const Source: TVarData; const Indirect: Boolean);
begin
  if Indirect and VarDataIsByRef(Source) then
    VarDataCopyNoInd(Dest, Source)
  else
    with TStringListVarData(Dest) do
    begin
      VType := VarType;
      VStringList := TVStringList.Create;
      VStringList.Assign (TStringListVarData(Source).VStringList);
    end;
end;

function TStringListVariantType.GetInstance(const V: TVarData): TObject;
begin
  Result := TStringListVarData(V).VStringList;
end;

function TStringListVariantType.IsClear(const V: TVarData): Boolean;
begin
  Result := (TStringListVarData(V).VStringList = nil) or
            (TStringListVarData(V).VStringList.Count = 0);
end;

function TStringListVariantType.LeftPromotion(const V: TVarData;
  const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin

end;

function TStringListVariantType.RightPromotion(const V: TVarData;
  const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin
  { StringList Op TypeX }
  { On accepte pour les additions et les soustractions que TypeX
    soit une chaîne ou un numérique,
    sinon, il faut qu'il soit du type StringList }
  if ((Operator = opAdd) or (Operator = opSubtract)) then begin
    if VarDataIsStr(V) then begin
      RequiredVarType := varString
    end else if VarDataIsNumeric(V) then begin
      RequiredVarType := V.VType ;
    end else begin
      RequiredVarType := VarType ;
    end ;
  end else begin
    RequiredVarType := VarType;
  end ;

  Result := True;
end;

procedure TStringListVariantType.StreamIn(var Dest: TVarData;
  const Stream: TStream);
begin

end;

procedure TStringListVariantType.StreamOut(const Source: TVarData;
  const Stream: TStream);
begin

end;

{ TVStringList }

function TVStringList.Add(const S: string): Integer;
begin
  Result := inherited Add (S) ;
end;

function TVStringList.AddObject(const S: string;
  AObject: TObject): Integer;
begin
  Result := inherited AddObject (S, AObject) ;
end;

procedure TVStringList.Clear;
begin
  inherited;
end;

procedure TVStringList.CustomSort(Compare: TStringListSortCompare);
begin
  inherited;
end;

procedure TVStringList.Delete(Index: Integer);
begin
  inherited;
end;

procedure TVStringList.Exchange(Index1, Index2: Integer);
begin
  inherited;
end;

function TVStringList.Find(const S: string; var Index: Integer): Boolean;
begin
  Result := inherited Find (S, Index) ;
end;

function TVStringList.IndexOf(const S: string): Integer;
begin
  Result := inherited IndexOf (S) ;
end;

procedure TVStringList.Insert(Index: Integer; const S: string);
begin
  inherited;
end;

procedure TVStringList.InsertObject(Index: Integer; const S: string;
  AObject: TObject);
begin
  inherited;
end;

procedure TVStringList.Sort;
begin
  inherited;
end;

initialization
  StringListVariantType := TStringListVariantType.Create;
finalization
  FreeAndNil(StringListVariantType);
end.