unit StringListObjectUnit;

interface

uses
  SysUtils,
  Classes,
end_uses;

type
  TStringListObject = class(TStringList)
  private

  protected

  public
    destructor Destroy; override;
    class function ArrayLength: Integer;
    class procedure ArrayClear;
    function ArrayIndex: Integer;
    function ArrayIndexName: String;
  published

  end;

type TStringList_T = TStringListObject;

type TStringListObjectFlag = (sfObjectAutoCreate, sfArrayAccess);

function StringListObject(Index: Integer = 0;
 Flag: TStringListObjectFlag = sfObjectAutoCreate): TStringList_T; overload;
function StringListObject(Name: String): TStringList_T; overload;
function StrList(Name: string): TStringList;

implementation

type TStringListArray = array of TStringList_T;
var uStringListObject: TStringListArray;

{---------------------------------------
    配列を縮小リサイズする関数
機能:   uStringListObjectの後方からnilの部分について
        リサイズしてnilじゃない所までサイズを小さくする
備考:
履歴:   2010/07/02(金)
        ・  作成
}//(*-----------------------------------
procedure AutoReductionReSize(var StringListArray: TStringListArray);
var
  I: Integer;
  NewLength: Integer;
begin
  NewLength := 0;
  for I := System.Length(StringListArray) - 1 downto 0 do
  begin
    if StringListArray[I] <> nil then
    begin
      NewLength := I + 1;
      break;
    end;
  end;

  SetLength(StringListArray, NewLength);
end;
//------------------------------------*)

var
  uNameTable: TStringList;

function NameTable: TStringList;
begin
  if not Assigned(uNameTable) then
    uNameTable := TStringList.Create;
  Result := uNameTable;
end;

function StringListObject(Index: Integer = 0;
 Flag: TStringListObjectFlag = sfObjectAutoCreate): TStringList_T;
begin
  if Index < 0 then
    raise ERangeError.Create(
      Format('Error:Range Over StringListObject(%d)', [Index]) );

  if Flag = sfArrayAccess then
  begin
    if Length(uStringListObject) <= Index then
      raise ERangeError.Create(
        Format('Error:Range Over StringListObject(%d)', [Index]) );

    Result := uStringListObject[Index];
    Exit;
  end;

  if not (Index <= System.Length(uStringListObject) - 1) then
  begin
    SetLength(uStringListObject, Index + 1);
{----------------------------------------
//SetLengthによってnilは自動で代入されるので、
//下記のように自分で入れる必要はない

    OldLength := Length(uStringListObject);
    SetLength(uStringListObject, Index + 1);
    for I := OldLength to Length(uStringListObject) - 1 do
      uStringListObject[I] := nil
//----------------------------------------}
  end;

  if uStringListObject[Index] = nil then
  begin
    uStringListObject[Index] := TStringList_T.Create;
  end;

  Result := uStringListObject[Index];
end;

function StringListObject(Name: String): TStringList_T;
begin
  if Name = '' then
    raise ERangeError.Create(
      'Error:Range Over StringListObject('')' );

  if NameTable.IndexOfName(Name) = -1 then
    NameTable.Values[Name] := IntToStr(Length(uStringListObject));
{----------------------------------------
    Nameでアクセスする方法は
    最も手っ取り早く重複チェックして代入できるやり方

    Nameの登録がない場合は配列の最後にIndexを指定してそれでアクセス
    Nameの登録がある場合はそのIndexでアクセスしてもらう。
//----------------------------------------}

  Result := StringListObject( StrToInt(NameTable.Values[Name]) );
end;

function StrList(Name: string): TStringList;
begin
  Result := StringListObject(Name);
end;

{ TStringListObject }

(*----------------------------------------
destructor TStringListObject.Destroy;
var
  I: Integer;
  J: Integer;
begin
  for I := 0 to System.Length(uStringListObject) - 1 do
  begin
    if uStringListObject[I] = Self then
    begin
      uStringListObject[I] := nil;

      for J := 0 to NameTable.Count - 1 do
      begin
        if IntToStr(I) = NameTable.Values[ NameTable.Names[J] ] then
        begin
          NameTable.Delete(J);
          break;
        end;
      end;

      AutoReductionReSize(uStringListObject);
      break;
    end;
  end;

  inherited Destroy;
end;
//----------------------------------------*)
destructor TStringListObject.Destroy;
var
  I: Integer;
  J: Integer;
begin
  I := Self.ArrayIndex;
  if I <> -1 then
  begin
    uStringListObject[I] := nil;
    AutoReductionReSize(uStringListObject);

    for J := 0 to NameTable.Count - 1 do
    begin
      if IntToStr(I) = NameTable.ValueFromIndex[J] then
      begin
        NameTable.Delete(J);
        break;
      end;
    end;
  end;
  inherited Destroy;
end;

function TStringListObject.ArrayIndex: Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to System.Length(uStringListObject) - 1 do
  begin
    if uStringListObject[I] = Self then
    begin
      Result := I;
      break;
    end;
  end;
end;

function TStringListObject.ArrayIndexName: String;
var
  I: Integer;
  J: Integer;
begin
  Result := '';
  for I := 0 to System.Length(uStringListObject) - 1 do
  begin
    if uStringListObject[I] = Self then
    begin
      for J := 0 to uNameTable.Count - 1 do
      with uNameTable do
      begin
        if ValueFromIndex[J] = IntToStr(I) then
        begin
          Result := Names[J];
          break;
        end;
      end;

      break;
    end;

  end;

//  Assert(Result = '', 'Error:ArrayIndexName=EmptyStr');
end;


class function TStringListObject.ArrayLength: Integer;
begin
  Result := System.Length(uStringListObject);
end;

class procedure TStringListObject.ArrayClear;
var
  I: Integer;
begin
  for I := System.Length(uStringListObject) - 1 downto 0 do
  begin
    {↓リサイズされてIndexが無くなる場合があるのでcontinueしている}
    if Length(uStringListObject) - 1 < I then continue;
    uStringListObject[I].Free;
  end;

  Assert(NameTable.Count = 0, 'Error:NameTable.Count <> 0');
  Assert(Length(uStringListObject) = 0, 'Error:Length(uStringListObject) <> 0');
end;


initialization
  SetLength(uStringListObject, 0);
  uNameTable := nil;

finalization
  TStringList_T.ArrayClear;

  uNameTable.Free;
end.