PRogram singletonTest;

uses
  Forms,
  mainfrm in 'mainfrm.pas' {Form1},
  singletonfrm in 'singletonfrm.pas' {Form2};

{$R *.res}

begin
  application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


unit singletonfrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm2 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    selfptr:Tform2;
    class function GetInstancePtr:integer;
    class Function GetInstance:TForm2;
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}
procedure TForm2.Button1Click(Sender: TObject);
begin
  hide;
end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  action:=cafree;
end;

procedure TForm2.Button2Click(Sender: TObject);
begin
  close;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
  selfptr:=nil;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  selfptr:=self;
end;

class function TForm2.GetInstancePtr: integer;
const
  isave:integer=0;
var
  pr:pointer;
  p:^integer;
  Form:TForm2;
begin
  p:=@isave;
  Form:=nil;
  if (isave<>0) then
  begin
    result:=isave;
    Form:=pointer(isave);
  end;
  if not assigned(Form) then
  begin
    Form:=Tform2.Create(nil);
    p^:=integer(Form);
    result:=isave;
  end
  else if not assigned(Form.selfptr) then
  begin
    Form:=Tform2.Create(nil);
    p^:=integer(Form);
    result:=isave;
  end;
end;

class function TForm2.GetInstance: TForm2;
begin
  result:=pointer(GetInstancePtr);
end;

end.

unit mainfrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Button2: TButton;
    Button3: TButton;
    Edit2: TEdit;
    Button4: TButton;
    Button5: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TSingleton = class(TObject)
  private
    Fusername: string;
    procedure SetUsername(const Value: string);
  published
    destructor Destroy;override;
  public
    property Username:string read Fusername write SetUsername;
    class function GetInstancePtr(value:integer):integer;
    class Function GetInstance:Tsingleton;
  End;

var
  Form1: TForm1;

implementation

uses singletonfrm;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  Form2:TForm2;
begin
  Form2:=Tform2.GetInstance;
  Edit1.Text:=inttostr(integer(Form2));
  Form2.Show;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  frm2:Tform2;
begin
  frm2:=Tform2.GetInstance;
  frm2.Free;
end;

{ TSingleton }

destructor TSingleton.Destroy;
begin
  GetInstancePtr(1);
  inherited;
end;

class function TSingleton.GetInstance: Tsingleton;
begin
  result:=pointer(GetInstancePtr(0));
end;

class function TSingleton.GetInstancePtr(value:integer): integer;
const
  isave:integer=0;
var
  p:^integer;
  obj:Tsingleton;
begin
  p:=@isave;
  obj:=nil;
  case value of
  0:
    begin
      if (isave<>0) then
      begin
        result:=isave;
        obj:=pointer(isave);
      end;
      if not assigned(obj) then
      begin
        obj:=Tsingleton.Create;
        p^:=integer(obj);
        result:=isave;
      end
    end;
  1:
    begin
      p^:=0;
    end;
  end;
end;

procedure TSingleton.SetUsername(const Value: string);
begin
  Fusername := Value;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  singleton:Tsingleton;
begin
  singleton:=Tsingleton.GetInstance;
  singleton.Username:=Edit1.Text;
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  singleton:Tsingleton;
begin
  singleton:=Tsingleton.GetInstance;
  Edit2.Text:=singleton.Username;
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  singleton:Tsingleton;
begin
  singleton:=Tsingleton.GetInstance;
  singleton.Free;
end;

end.