设计模式之singleton[1]

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