【Delphi】StringList组件进行接口化处理

TStringList是Delphi编程中经常使用到的组件，对它进行接口化处理的主要目的，是实现TStringList的内存自动释放。例如下命的过程，执行完毕后，为aList变量所分配的内存就会自动释放，不需要用aList.free来释放内存，可以有效避免因忘记释放内存而导致内存泄漏。接口中并没有包括全部的TStringList函数或过程，可以根据实际需要进行增减。这个接口化处理方法也适用于其它组件。

uses uStringList;

procedure TForm1.Button1Click(Sender: TObject);
var
  aList: IStringList;
begin
  aList := TStringListIntf.Create;
  aList.Add('Test')
end;

unit uStringlist;

interface

uses System.Classes;

type
  IStringList = interface['{7BC2765C-9289-48EA-AB97-1A73E2AF637F}']
    function Get(Index: Integer): string;
    procedure Put(Index: Integer; const S: string);
    function GetCount: Integer;
    function GetTextStr: string;
    procedure SetTextStr(const Value: string);
    function GetDelimiter: Char;
    procedure SetDelimiter(aChar: Char);
    function GetDelimitedText: String;
    procedure SetDelimitedText(aText: String);
    function GetValue(const Name: string): String;
    procedure SetValue(const Name, Value: string);
    function GetSorted: Boolean;
    procedure SetSorted(Value: Boolean);
    function GetCaseSensitive: Boolean;
    procedure SetCaseSensitive(const Value: Boolean);
    function GetDuplicates: TDuplicates;
    procedure SetDuplicates(const Value: TDuplicates);

    function GetEnumerator: TStringsEnumerator;
    function Add(const S: string): Integer;
    procedure LoadFromFile(const FileName: string);
    function First: String;
    function Last: String;
    procedure Clear;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure Delete(Index: Integer);
    function AddPair(const Name, Value: string): IStringList;
    procedure Append(const S: string);
    procedure AddStrings(Strings: IStringList);
 // procedure SetStrings(Source : IStringList);
    function IndexOf(const S: string): Integer;
    function IndexOfName(const Name: string): Integer;
    procedure Insert(Index: Integer; const S: string);
    procedure Sort;
    function Find(const S: string; var Index: Integer): Boolean;
    property Strings[Index: Integer]: string read Get write Put; default;
    property Count: Integer read GetCount;
    property Text: string read GetTextStr write SetTextStr;
    property Delimiter: Char read GetDelimiter write SetDelimiter;
    property DelimitedText: string read GetDelimitedText write SetDelimitedText;
    property Values[const Name: string]: string read GetValue write SetValue;
    property Sorted: Boolean read GetSorted write SetSorted;
    property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;
    property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
  end;

  TStringListIntf = class
    class function Create: IStringList;
  end;

implementation

type
  TInterfacedStringList = class(TStringList, IStringList)
  private
    const objDestroyingFlag = Integer($80000000);
    function GetRefCount: Integer; inline;
  protected
    [Volatile] FRefCount: Integer;
    class procedure __MarkDestroying(const Obj); static; inline;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    property RefCount: Integer read GetRefCount;
  protected
    function First: String;
    function Last: String;
    procedure AddStrings(Strings: IStringList); overload;
  //procedure SetStrings(Source : IStringList); overload;
    function AddPair(const Name, Value: string): IStringList; overload;

    function GetDelimiter: Char;
    procedure SetDelimiter(aChar: Char);
    property Delimiter: Char read GetDelimiter write SetDelimiter;

    function GetDelimitedText: String;
    procedure SetDelimitedText(aText: String);
    property DelimitedText: string read GetDelimitedText write SetDelimitedText;

    function GetValue(const Name: string): String;
    procedure SetValue(const Name, Value: string);
    property Values[const Name: string]: string read GetValue write SetValue;

    function GetSorted: Boolean;
    procedure SetSorted(Value: Boolean);
    property Sorted: Boolean read GetSorted write SetSorted;

    function GetCaseSensitive: Boolean;
    procedure SetCaseSensitive(const Value: Boolean);
    property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;

    function GetDuplicates: TDuplicates;
    procedure SetDuplicates(const Value: TDuplicates);
    property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
  end;

class function TStringListIntf.Create: IStringList;
begin
  Result := TInterfacedStringList.Create;
end;

function TInterfacedStringList.First: String;
begin
  Result := Strings[0];
end;

function TInterfacedStringList.Last: String;
begin
  Result := Strings[Count-1];
end;

function TInterfacedStringList.AddPair(const Name, Value: string): IStringList;
begin
  Add(Name + NameValueSeparator + Value);
  Result := Self;
end;

function TInterfacedStringList.GetDelimiter: Char;
begin
  Result := inherited Delimiter;
end;

procedure TInterfacedStringList.SetDelimiter(aChar: Char);
begin
  inherited Delimiter := aChar;
end;

function TInterfacedStringList.GetDelimitedText: String;
begin
  Result := inherited DelimitedText;
end;

procedure TInterfacedStringList.SetDelimitedText(aText: String);
begin
  inherited DelimitedText := aText;
end;

function TInterfacedStringList.GetValue(const Name: string): String;
begin
  Result := inherited Values[Name];
end;

procedure TInterfacedStringList.SetValue(const Name, Value: string);
begin
  inherited Values[Name] := Value;
end;

function TInterfacedStringList.GetSorted: Boolean;
begin
  Result := inherited Sorted;
end;

procedure TInterfacedStringList.SetSorted(Value: Boolean);
begin
  inherited Sorted := Value;
end;

function TInterfacedStringList.GetCaseSensitive: Boolean;
begin
  Result := inherited CaseSensitive;
end;

procedure TInterfacedStringList.SetCaseSensitive(const Value: Boolean);
begin
  inherited CaseSensitive := Value;
end;

function TInterfacedStringList.GetDuplicates: TDuplicates;
begin
  Result := inherited Duplicates;
end;

procedure TInterfacedStringList.SetDuplicates(const Value: TDuplicates);
begin
  inherited Duplicates := Value;
end;

procedure TInterfacedStringList.AddStrings(Strings: IStringList);
begin
  inherited AddStrings(TStrings(Strings));
end;

{procedure TInterfacedStringList.SetStrings(Source: IStringList);
begin
  inherited SetStrings(TStrings(Source));
end;}

function TInterfacedStringList.GetRefCount: Integer;
begin
  Result := FRefCount and not objDestroyingFlag;
end;

class procedure TInterfacedStringList.__MarkDestroying(const Obj);
var
  LRef: Integer;
begin
  repeat
    LRef := TInterfacedStringList(Obj).FRefCount;
  until AtomicCmpExchange(TInterfacedStringList(Obj).FRefCount, LRef or objDestroyingFlag, LRef) = LRef;
end;

procedure TInterfacedStringList.AfterConstruction;
begin
// Release the constructor's implicit refcount
  AtomicDecrement(FRefCount);
end;

procedure TInterfacedStringList.BeforeDestruction;
begin
  if RefCount <> 0 then
    System.Error(reInvalidPtr);
end;

// Set an implicit refcount so that refcounting during construction won't destroy the object.
class function TInterfacedStringList.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TInterfacedStringList(Result).FRefCount := 1;
end;

function TInterfacedStringList.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TInterfacedStringList._AddRef: Integer;
begin
  Result := AtomicIncrement(FRefCount);
end;

function TInterfacedStringList._Release: Integer;
begin
  Result := AtomicDecrement(FRefCount);
  if Result = 0 then
  begin
    // Mark the refcount field so that any refcounting during destruction doesn't infinitely recurse.
    __MarkDestroying(Self);
    Destroy;
  end;
end;

end.