設計模式之singleton

　　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.