sybdatabase.pas

sybase大全

unit sybdatabase;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,DsgnIntf,sybase32,sybase_components;

type
  SybObjectname = string[30];
  String255     = string[255];

type
  Tsybobjectproperty = class(Tstringproperty)
  public
    procedure GetValues(TheProc: TGetStrProc); override;
    function getattributes:Tpropertyattributes; override;
  end;

type
  TSybDatabase = class(TComponent)
  private
    { Private declarations }
    FUserName    :SybObjectname;
    FDBName      :SybObjectname;
    FPassword    :SybObjectname;
    FServerName  :SybObjectname;
    FLoginPrompt :boolean;
    FServerPrompt:boolean;
    FServerShow  :boolean;
    FShowmessage :boolean;
    FConnected   :boolean;
    FBuffersize  :integer;
    FServerList  :TStrings;
    FDbLibVersion:string;
    FDbVersion   :string;
    fcharset     :SybObjectname;
    fservercharset :SybObjectname;
    flanguage    :SybObjectname;
    fappname     :SybObjectname;
    fhostname    :SybObjectname;
    fdebugfile   :string255;
    Ftimeout     :Integer;
    FLoginTimeOut:Integer;
    procedure SetTimeOut(Value :Integer);
    procedure SetLoginTimeOut(Value :Integer);
    procedure SetUserName(Value :SybObjectname);
    procedure SetPassword(Value :SybObjectname);
    procedure SetDBName(Value :SybObjectname);
    procedure SetServerName(Value :SybObjectname);
    procedure SetLoginPrompt(Value :boolean);
    procedure SetServerPrompt(Value :boolean);
    procedure SetServerShow(Value :boolean);
    procedure SetConnected(Value :boolean);
    procedure SetShowmessage(Value :boolean);
    procedure SetBuffersize(Value :integer);
    procedure SetServerList(Value:TStrings);
    procedure SetCharset(Value:SybObjectname);
    procedure SetLanguage(Value:SybObjectname);
    procedure SetAppName(Value:SybObjectname);
    procedure SetHostName(Value:SybObjectname);
    procedure SetDebugFile(Value:String255);
  protected
    { Protected declarations }
  public
    { Public declarations }
    dbconnected :boolean;
    dbprocc:integer;
    Server,user,pwd,dBase  :array[0..30] of char;
    Login,Retcode,retcode2,nocols,col:integer;
    MsgPointer,ErrPointer,tPointer,Adr:Pointer;
    dbproc:integer;
    servlist    :tstrings;
    constructor create(AOwner:TComponent); override;
    destructor destroy; override;
    procedure setname(const NewName:Tcomponentname); override;
    procedure loaded; override;
    procedure CanQuery;
  published
    { Published declarations }
    procedure connect;
    procedure disconnect;
    procedure get_servers;
    property TimeOut :Integer read FTimeOut write SetTimeOut;
    property LoginTimeOut :Integer read FLoginTimeOut write SetLoginTimeOut;
    property DbLibVersion:string read fdblibversion;
    property ServerCharSet:SybObjectname read fservercharset;
    property CharSet:SybObjectname read fcharset write SetCharset;
    property Language:SybObjectname read flanguage write SetLanguage;
    property AppName:SybObjectname read fappname write SetAppName;
    property HostName:SybObjectname read fhostname write SetHostName;
    property DebugFile:string255 read fdebugfile write SetDebugFile;
    property DBVersion:string read fdbversion;
    property Password :SybObjectname read FPassword write SetPassword;
    property UserName :SybObjectname read FUserName write SetUserName;
    property DBName :SybObjectname read FDBName write SetDBName;
    property ServerName :SybObjectname read FServerName write SetServerName;
    property LoginPrompt :boolean read Floginprompt write Setloginprompt default True;
    property ServerPrompt :boolean read FServerPrompt write SetServerPrompt default True;
    property ServerShow :boolean read FServerShow write SetServerShow default True;
    property Connected :boolean read FConnected write SetConnected stored false;
    property ShowMessage :boolean read Fshowmessage write Setshowmessage default false;
    property BufferSize :integer read FBuffersize write SetBuffersize;
    property ServerList:TStrings read FServerList write FServerList; //SetServerList;
  end;

procedure Register;

var from_create :boolean;

implementation
uses objectlistdlg,
     sybaselogin,
     sybquery;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(SybObjectname),TSybDatabase,'DBName',TsybobjectProperty);
  RegisterPropertyEditor(TypeInfo(SybObjectname),TSybDatabase,'ServerName',TsybobjectProperty);
  RegisterComponents('Sybase DBLIB', [TSybDatabase]);
end;

constructor TSybDatabase.create(AOwner:TComponent);
var p:pointer;
begin
  inherited create(AOwner);
  ErrPointer := MakeProcInstance(GetProcAddress(0,'Errors'),hInstance);
  MsgPointer := MakeProcInstance(GetProcAddress(0,'Messages'),hInstance);
  dbmsghandle(addr(syb_messages));
  dberrhandle(addr(errors));
  Floginprompt:=True;
  Fserverprompt:=True;
  Fservershow:=True;
  FConnected:=False;
  dbConnected:=False;
  FDBName:='master';
  FBuffersize:=0;
  fdblibversion:='';
  fdbversion:='';
  fcharset:='';
  fservercharset:='';
  from_create:=true;
  if FirstDatabase = 0 then
  begin
    DatabasesList:= TList.Create;
    FirstDatabase:=1;
  end;

  fserverlist:=tstringlist.create;
  servlist:=tstringlist.create;
  get_servers;
  setserverlist(servlist);
end;

destructor TSybDatabase.destroy;
var i :integer;
begin
  databaseslist.remove(self);
  FServerList.Free;
  ServList.Free;
  
  inherited destroy;
end;

procedure TSybDatabase.loaded;
begin
  inherited loaded;
  setserverlist(servlist);
end;

procedure TSybDatabase.setname(const NewName:Tcomponentname);
var oldname   :Tcomponentname;
    i         :integer;
    adatabase :tsybdatabase;
begin
  oldname:=name;
  inherited setname(NewName);

  if databaseslist.indexof(self) = -1 then
    databaseslist.add(self)
  else
  begin
    databaseslist.items[databaseslist.indexof(self)]:=self;
  end;
end;

procedure TSybDatabase.SetCharset(Value:SybObjectname);
begin
  fCharset:=value;
end;

procedure TSybDatabase.SetLanguage(Value:SybObjectname);
begin
  fLanguage:=value;
end;

procedure TSybDatabase.SetAppName(Value:SybObjectname);
begin
  fappname:=value;
end;

procedure TSybDatabase.SetHostName(Value:SybObjectname);
begin
  fhostname:=value;
end;

procedure TSybDatabase.SetDebugFile(Value:String255);
begin
  fdebugfile:=value;
end;

procedure TSybDatabase.SetServerList(Value :TStrings);
begin
  FServerList.assign(Value);
end;

procedure TSybDatabase.SetUserName(Value :SybObjectname);
begin
  FUserName:=Value;
end;

procedure TSybDatabase.SetDBName(Value :SybObjectname);
begin
  FDBName:=Value;
  strpcopy(dbase,fdbname);
  Retcode := dbuse(dbProc,@dBase);
end;

procedure TSybDatabase.SetServerName(Value :SybObjectname);
begin
  FServerName:=Value;
end;

procedure TSybDatabase.SetBuffersize(Value :integer);
var p :pchar;
    s :string[20];
begin
  FBuffersize:=Value;
  s:=inttostr(value);
  new(p);
  strpcopy(p,s);
  if (Value > 0)
    and (connected) then
  begin
    retcode:=dbsetopt(dbproc,DBBUFFER,p,-1);
  end;
  dispose(p);
end;  

procedure TSybDatabase.SetPassword(Value :SybObjectname);
begin
  FPassword:=Value;
end;

procedure TSybDatabase.SetLoginPrompt(Value :boolean);
begin
  FLoginPrompt:=Value;
end;

procedure TSybDatabase.SetServerPrompt(Value :boolean);
begin
  FServerPrompt:=Value;
end;

procedure TSybDatabase.SetServerShow(Value :boolean);
begin
  FServerShow:=Value;
end;

procedure TSybDatabase.Setshowmessage(Value :boolean);
begin
  Fshowmessage:=Value;
end;

procedure TSybDatabase.SetConnected(Value :boolean);
begin
  if not Fconnected then
    connect
  else
    disconnect;
end;

procedure TSybDatabase.connect;
var
  usernm      :pchar;
  PasswordDlg :TPasswordDlg;
  q           :tsybquery;

  the_set    :array[0..30] of char;
  the_file   :array[0..255] of char;

begin
  if Fconnected then
    exit;
  if length(FDBName) = 0 then
    FDBName:='master';
  passworddlg:=TPasswordDlg.create(nil);
  if loginprompt then
  begin
    if length(FServerName) > 0 then
      passworddlg.caption:='Login to ' + FServerName;
    if not FServerPrompt then
      passworddlg.server.enabled:=false;

    if not FServerShow then
    begin
      passworddlg.server.visible:=false;
      passworddlg.label3.visible:=false;
      passworddlg.username.top:=9;
      passworddlg.username.left:=84;
      passworddlg.password.top:=43;
      passworddlg.password.left:=84;
      passworddlg.label2.top:=17;
      passworddlg.label1.top:=49;
      passworddlg.label1.left:=20;
      passworddlg.label2.left:=36;
      passworddlg.bevel1.height:=73;
      passworddlg.height:=140;
      passworddlg.okbtn.top:=82;
      passworddlg.cancelbtn.top:=82;
    end;

    passworddlg.username.text:=FUserName;
    passworddlg.password.text:=FPassword;
    passworddlg.Server.text:=FServerName;
    passworddlg.server.items:=fserverlist;
    passworddlg.showmodal;
    if passworddlg.modalresult = mrcancel then
    begin
      FConnected:=false;
      dbConnected:=false;
      exit;
    end;
    FUserName:=passworddlg.username.text;
    FPassword:=passworddlg.password.text;
    FServerName:=passworddlg.server.text;
  end;
  passworddlg.free;

  FConnected:=false;
  dbConnected:=false;

  if (passworddlg.modalresult = mrok)
    or (not loginprompt) then
  begin
    strpcopy(User,UserName);
    strpcopy(Pwd,Password);
    StrpCopy(Server,ServerName);
    StrpCopy(dBase,DBName);
    dbinit;
    login := dblogin;

//     1 - Host Name
//      2 - User Name
//      3 - Password
//      4 - Don't know yet
//      5 - Application Name
//      6 - Don't know yet
//      7 - Default Language
//      10 - Default Charcter Set

    if length(hostname)>0 then
    begin
      strpcopy(the_set,hostname);
      Retcode := dbsetlname(login,@the_set,1);
    end;
    Retcode := dbsetlname(login,@User,2);
    Retcode := dbsetlname(login,@Pwd,3);
    if length(appname)>0 then
    begin
      strpcopy(the_set,appname);
      Retcode := dbsetlname(login,@the_set,5);
    end;
    if length(language)>0 then
    begin
      strpcopy(the_set,language);
      Retcode := dbsetlname(login,@the_set,7);
    end;
    if length(charset)>0 then
    begin
      strpcopy(the_set,charset);
      Retcode := dbsetlname(login,@the_set,10);
    end;
    if length(debugfile)>0 then
    begin
      strpcopy(the_file,debugfile);
      dbrecftos(@the_file);
    end;
    Retcode:=dbSetlBool(Login, 1, 6);
    dbProc := dbopen(login,server);
    If dbProc <> 0 then
    Begin
      retcode:=dbuse(dbProc,@dBase);
      FConnected:=true;
      dbConnected:=true;
      dbprocc:=dbproc;
      setbuffersize(buffersize);
      fdblibversion:=dbversion;
      fcharset:=dbgetcharset(dbproc);
      fservercharset:=dbservcharset(dbproc);
      fLanguage:=dbgetnatlang(dbproc);

      q:=tsybquery.create(nil);
      q.AutoDbProc:=false;
      q.dbproc:=dbprocc;
      q.dbname:=name;
      q.sql:='select @@version';
      q.sqlexec;
      while q.nextrow = -1 do
      begin
        fdbversion:=q.column(1);
      end;
      q.free;

      if databaseslist.indexof(self) = -1 then
        databaseslist.add(self)
      else
        databaseslist.items[databaseslist.indexof(self)]:=self;
    end
    else
    begin
      FConnected:=false;
      dbConnected:=false;
    end;
  end
  else
  begin
    FConnected:=false;
    dbConnected:=false;
  end;
  if not FConnected then
  begin
    MessageBox(GetActiveWindow,'Could not login to Server','DB-Library error',mb_ok+mb_iconexclamation);
    FConnected:=false;
    dbConnected:=false;
  end;
  dbloginfree(login);

end;

procedure TSybDatabase.disconnect;
begin
  if Fconnected then
  begin
    FConnected:=false;
    dbConnected:=false;
    dbclose(dbProc);
{    dbexit;}
  end;
end;

procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc);
var
  SqlCommand:array[0..2048] of char;
  Login,Retcode,retcode2:integer;
  dbname :SybObjectname;
  proc,i :integer;
  tslist :tsybdatabase;
begin
  tslist:=tsybdatabase(getcomponent(0));
  proc:=tslist.dbproc;

  if getname='ServerName' then
  begin
    for i:=0 to tslist.fserverlist.count-1 do
      theproc(tslist.fserverlist[i]);
  end;

  if getname='DBName' then
  begin
    if tslist.dbconnected then
    begin
      strpcopy(Sqlcommand,'select name from master..sysdatabases');
      Retcode := dbcmd(Proc,@Sqlcommand);
      Retcode := Dbsqlexec(Proc);
      Retcode := dbresults(Proc);
      retcode2:=0;
      while (retcode <> No_more_results) and (retcode <> Fail) do
      begin
        if retcode = Succeed then
        begin
          retcode2 := dbnextrow(Proc);
          while retcode2 <> No_More_Rows do
          Begin
            theproc(strpas(dbvalue(proc,1)));
            retcode2 := dbnextrow(Proc);
          end;
        end;
        Retcode := dbresults(proc);
      end;
    end;  
  end;

  strpcopy(tslist.dbase,getstrvalue);
  retcode:=dbuse(Proc,@tslist.dbase);
end;

function Tsybobjectproperty.getattributes:Tpropertyattributes;
begin
  Result := [paValueList,paAutoUpdate,paMultiSelect];
end;

procedure TSybDatabase.get_servers;
var sybase_dir  :array[0..255] of char;
    fin         :textfile;
    l           :string[30];
    l2          :string[1];
begin
    GetEnvironmentVariable('SYBASE',sybase_dir,sizeof(sybase_dir));
    l:=string(sybase_dir) + '\INI\SQL.INI';
    try
    assignfile(fin,l);
    {$i-} reset(fin) {$i+};
    if (ioresult=0) then
    begin

      while not eof(fin) do
      begin
        readln(fin,l);
        l2:=l;
        if l2='[' then
        begin
          ServList.add(copy(l,2,length(l)-2));
        end;
      end;
    end;
    finally
    {$i-} closefile(fin) {$i+};
    end;
end;

procedure TSybDatabase.CanQuery;
begin
  Dbcanquery(dbProcc);
end;

procedure TSybDatabase.SetLoginTimeOut(Value: Integer);
var retcode   :Integer;
begin
  retcode:=dbsetlogintime(Value);
  FLoginTimeOut:=Value;
end;

procedure TSybDatabase.SetTimeOut(Value: Integer);
var retcode   :Integer;
begin
  retcode:=dbsettime(Value);
  FTimeOut:=Value;
end;

end.