umysqlclient.~pas

用delphi连接mysql的组件

{--------------------------------------------------------------------------------
Licencing issues:
13-December-2003      〤ristian Nicola
Note:
 Mysql is copyright by MySQL AB. Refer to their site ( http://www.mysql.com )
for licencing issues.
 Zlib is copyright by Jean-loup Gailly and Mark Adler. Refer to their site for
licencing issues. ( http://www.info-zip.org/pub/infozip/zlib/ )

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

NOTES:
  1. The origin of this software must not be misrepresented; you must not
     claim that you wrote the original software. If you use this software
     in a product, an acknowledgment in the product documentation would be
     appreciated.
  2. Altered source versions must be plainly marked as such, and must not be
     misrepresented as being the original software.
  3. If you are using it for a commercial software it must be open source and
     it must include full source code of this library in an unaltered fashion
     or you would need to ask for permission to use it. This library will be
     considered donationware which means if you want to contribute with any money
     or hardware you are more than welcome.
  4. This notice may not be removed or altered from any source distribution.

  Cristian Nicola
  [e-mail]

If you use the mysqldirect library in a product, i would appreciate *not*
receiving lengthy legal documents to sign. The sources are provided
for free but without warranty of any kind.  The library has been
entirely written by Cristian Nicola after libmysql of MYSQL AB.
--------------------------------------------------------------------------------}
unit uMysqlClient;
////////////////////////////////////////////////////////////////////////////////
// This is the main unit and it defines:
// - mysql client for communication stuff
// - mysql result for dealing with the results of queryes

interface

{$I mysqlinc.inc}

uses
  sysutils, uMysqlCT, uMysqlErrors, uMysqlNet {$IFDEF HAVE_SSL}, uMysqlSSL{$ENDIF},
  uMysqlNewPassword, SyncObjs;

type
  PCardinal = ^Cardinal;

  TMysql_Row = ^pchar;
  // double linked list to store a result set
  // in libmysql it was single linked
  PMysql_Rows = ^TMysql_Rows;
  TMysql_Rows = record
    prior: PMysql_Rows;
    next: PMysql_Rows;
    data: TMysql_Row;
  end;

  //internal structure to use when reading a result
  TMYSQL_DATA = record
    rows:int64;
    fields:longint;
    data: PMysql_Rows;
  end;
  PMYSQL_DATA = ^TMYSQL_DATA;

//------------------------------------------------------------------------------
  PMysql_FieldDef = ^TMysql_FieldDef;
  TMysql_FieldDef = packed record
    name: PChar;                  // Name of column
    org_name: PChar;              // Original column name, if an alias
    table: PChar;                 // Table of column if column was a field
    org_table: PChar;		          // Org table name if table was an  alias
    db: PChar;      			        // Database for table
    catalog: PChar;      			    // Catalog for table
    def: PChar;                   // Default value (set by mysql_list_fields)
    length: Longword;             // Width of column
    max_length: Longword;         // Max width of selected set
    name_length: Longword;
    org_name_length: Longword;
    table_length: Longword;
    org_table_length: Longword;
    db_length: Longword;
    catalog_length: Longword;
    def_length: Longword;
    flags: Longword;              // Div flags
    decimals: Longword;           // Number of decimals in field
    charsetnr: Longword;          // Character set
    field_type: byte; // Type of field. Se mysql_com.h for types
  end;
  TResultType=(rtUsed,rtStored);

//==============================================================================
  TMysqlClient=class;
  TMysqlResult = class(TObject)
  private
    ffieldscount   : longint;
    frowscount     : int64;
    ffields        : PMysql_FieldDef;
    fhandle        : TMysqlClient;
    fType          : TResultType;
    flengths       : PCardinal;
    frow           : TMysql_Row;
    fdata          : PMysql_Data;
    fdata_cursor   : PMysql_Rows;
    fRecNo         : longint;
    fcurrent_row   : TMysql_Row;
    fEOF           : boolean;
    fBOF           : boolean;
    flengthsread   : boolean;
    fLastRow       : longint;
    procedure SetRecNo(const Value: longint);
    procedure SetHasLengths(const Value: boolean);
    function GetHadErrors: boolean;
    function GetLastRowRead: boolean;
  public
    property Eof:boolean read fEof;
    property Bof:boolean read fBof;
    property RecNo: longint read fRecNo write SetRecNo;
    property HasLengths:boolean read flengthsread write SetHasLengths;
    property FieldsCount:longint read ffieldscount;
    property RowsCount:int64 read frowscount;
    property ResultType : TResultType read fType;
    property FieldsDefs : PMysql_FieldDef read ffields;
    property Lengths : PCardinal read flengths;
    property CurrentRow : TMysql_Row read fcurrent_row;
    property HadErrors : boolean read GetHadErrors;
    property LastRowRead : boolean read GetLastRowRead;
    constructor create(aMysql:TMysqlClient; aType:TResultType);
    destructor destroy;override;
    function FieldLenght(aIndex:longint):cardinal;
    function FieldValue(aIndex:longint):pchar;
    function FieldDef(aIndex:longint):PMysql_FieldDef;
    function FieldValueByName (aName:string; CaseSensitive:boolean=false):pchar;
    function FieldDefByName (aName:string; CaseSensitive:boolean=false):PMysql_FieldDef;
    function FieldIndexByName(aName:string; CaseSensitive:boolean=false):longint;
    procedure Next;
    procedure Prior;
    procedure First;
    procedure Last;
    procedure FetchLengths;
  end;

//==============================================================================
  TMysqlClient = class (TObject)
  private
    fnet                 : TMysqlNet; //internal net
    fhost                : string; //internal host
    fuser                : string; //internal user
    fpasswd              : string; //internal password
    funix_socket         : string; //internal unix socket
    fdb                  : string; //internal db
    fport                : cardinal; //internal port
    fscramble_buff       : string[20]; //internal scramble buffer (used for password encryption)
    fthread_id           : cardinal; //internal thread id for current connection
    faffected_rows       : int64; //internal affected rows
    finsert_id           : int64; //last insert id
    fstatus              : TMysql_Status;//status of the client
    freconnect           : boolean;//internal reconnect flag if true one should reconnect
    fnamed_pipe          : Boolean;//do we use named pipes?
    ftrysock             : boolean;//if we use named pipes should we attempt sockets if pipe is down?
    fconnect_timeout     : cardinal;//time out on connect
    fcompress            : Boolean; //if we use compressed protocol
    fclient_flag         : cardinal;
    fserver_version      : string;
    fserver_capabilities : cardinal;
    fserver_status       : longint;
    fserver_language     : cardinal;
    fextra_info          : int64;
    finfo                : string;
    ffield_count         : longint;
    ffields              : PMysql_FieldDef;
    fusedresult          : TMysqlResult;
    fuse_ssl             : Boolean;
    FUse410Password      : boolean;
    FNullLength          : Integer;
    FThreaded            : boolean;
    FCriticalSection     : TCriticalSection;
    {$IFDEF HAVE_SSL}
    fssl_key         : string;
    fssl_cert        : string;
    fssl_cipher      : string;
    fssl_ca          : string;
    fssl_capath      : string;
    {$ENDIF}
    FWarningCount: integer;
    function send_file_to_server(const filename:string):longint;
    function read_rows(mysql_fields:PMysql_FieldDef;fields:longint; var hadErrors:boolean):PMYSQL_DATA;
    function read_one_row(fields:longint;row:TMysql_Row;lengths:PCardinal):longint;
    function simple_command(command:TEnumServerCommand; arg:pchar;lengt:longint; skipp_check:boolean; retry:boolean):longint;
    function read_query_result:longint;
    procedure free_old_query;
    function unpack_fields(data:PMYSQL_DATA;fields:longint;long_flag_protocol:boolean; anew: boolean):PMysql_FieldDef;
    function store_result:TMysqlResult;
    function use_result:TMysqlResult;
    procedure SetHost(const Value: string);
    procedure SetDb(const Value: string);
    procedure SetPasswd(const Value: string);
    procedure SetPort(const Value: cardinal);
    procedure SetUnixSocket(const Value: string);
    procedure SetUser(const Value: string);
    procedure SetClientFlag(const Value: cardinal);
    procedure SetNamedPipe(const Value: Boolean);
    procedure SetTrySock(const Value: Boolean);
    procedure setfcompress(const Value: Boolean);
    procedure SetUseSSL(const Value: Boolean);
    {$IFDEF HAVE_SSL}
    procedure Setsslcert(const Value: string);
    procedure Setsslcipher(const Value: string);
    procedure Setsslkey(const Value: string);
    procedure Setsslca(const Value: string);
    procedure Setsslcapath(const Value: string);
    {$ENDIF}
    function GetLastErrorNo: cardinal;
    function GetLastError: string;
    function GetClientInfo: string;
    function GetProtocol_version: cardinal;
    function GetConnected: boolean;
    procedure SetNoTimeOut(const Value: Boolean);
    function GetNoTimeOut: Boolean;
    function mysql_authenticate:boolean;
    procedure SetMultiResults(const Value: boolean);
    function GetMultiResults: boolean;
  public
    property Host: string read FHost write SetHost;
    property User: string read FUser write SetUser;
    property Password:string read FPasswd write SetPasswd;
    property UnixSocket: string read funix_socket write SetUnixSocket;
    property Db: string read fdb write SetDb;
    property Port: cardinal read FPort write SetPort;
    property ClientFlag: cardinal read fclient_flag write SetClientFlag;
    property ShouldReconnect: boolean read freconnect write freconnect;
    property UseNamedPipe: Boolean read fnamed_pipe write SetNamedPipe;
    property TrySockets: Boolean read ftrysock write SetTrySock;
    property ConnectTimeout: cardinal read fconnect_timeout write fconnect_timeout;
    property Compress: Boolean read fcompress write setfcompress;
    property Status: TMysql_Status read fstatus;
    property ThreadId: cardinal read fthread_id;
    property AffectedRows: int64 read faffected_rows;
    property LastInsertId: int64 read finsert_id;
    property WarningCount: integer read FWarningCount;
    property ServerVersion: string read fserver_version;
    property ClientVersion: string read GetClientInfo;
    property ProtocolVersion: cardinal read GetProtocol_Version;
    property ServerCapabilities: cardinal read fserver_capabilities;
    property ServerStatus: longint read fserver_status;
    property ServerLanguage: cardinal read fserver_language;
    property ExtraInfo: int64 read fextra_info;
    property Info: string read finfo;
    property Connected: boolean read GetConnected;
    property LastError: string read GetLastError;
    property LastErrorNo: cardinal read GetLastErrorNo;
    property NoTimeOut : Boolean read GetNoTimeOut write SetNoTimeOut;
    property UseSSL : Boolean read fuse_ssl write SetUseSSL;
    property NullLength: integer read FNullLength write FNullLength;
    property Use410Password:boolean read FUse410Password write FUse410Password;
    {$IFDEF HAVE_SSL}
    property SSLKey : string read fssl_key write Setsslkey;
    property SSLCert : string read fssl_cert write Setsslcert;
    property SSLCipher : string read fssl_cipher write Setsslcipher;
    property SSLCa : string read fssl_ca write Setsslca;
    property SSLCaPath : string read fssl_capath write Setsslcapath;
    {$ENDIF}
    constructor create;
    destructor destroy; override;
    function connect(ahost:string; auser:string = ''; apasswd:string = ''; adb:string = ''; aport:cardinal = 3306; aunix_socket:string = ''; atrysocket:boolean = false; aclient_flag:longint = CLIENT_CAPABILITIES):boolean; overload;
    function connect:boolean; overload;
    function reconnect:boolean;
    procedure close;
    function select_db( const newdb:string):boolean;
    function create_db(const db:string):boolean;
    function drop_db(const adb:string):boolean;
    function change_user(NewUser:string; NewPasswd:string; NewDb: string=''):boolean;
    function refresh(options:longint):boolean;
    function dump_debug_info:boolean;
    function kill(pid:longint):boolean;
    function ping:boolean;
    function shutdown:boolean;
    function query( const aquery:string; StoreResult:boolean;var ExecutedOk:boolean):TMysqlResult;
    function stat:string;
    function list_processes:TMysqlResult;
    {$IFDEF HAVE_SSL}
    function SSL_ReadError:boolean;
    {$ENDIF}
    property MultiResults: boolean read GetMultiResults write SetMultiResults;
    function moreResults: boolean;
    function nextResult(StoreResult:boolean;var ExecutedOk:boolean): TMysqlResult; 
  end;

implementation

type
  //internal array of pchar
  TPPCA=array of pchar;
  //internal array of cardinal
  TPCA=array of cardinal;
  //internal array of field def
  TPFDA=array of TMysql_FieldDef;

////////////////////////////////////////////////////////////////////////////////
// free for a PMysql_Data structure
procedure free_rows(var cur: PMYSQL_DATA);
var
  row, tmp:PMysql_Rows;
  i:longint;
begin
  if (cur<>nil) then //is it empty?
    begin
      row:=cur.data;
      while row<>nil do
        begin
          for i:=0 to cur.fields-1 do //let's free the fields
            strdispose(TPPCA(row.data)[i]);
          dispose(row.data);
          tmp:=row;
          row:=row.next;
          dispose(tmp); //we can free the row
        end;
      dispose(cur); //finally we can free the PMysql_Data
      cur:=nil;
    end;
end;

////////////////////////////////////////////////////////////////////////////////
// length decoder 
// refer mysql docs to see why 251,252,253
function net_field_length(var packet: Integer): longint;
begin
  if ( pchar(packet)[0] < chr(251)) then //1 byte value
    begin
      result:= byte(pchar(packet)[0]);
      inc(packet);
      exit;
    end;
  if ( pchar(packet)[0] = chr(251)) then //null length
    begin
      inc(packet);
      result:=NULL_LENGTH;
      exit;
    end;
  if ( pchar(packet)[0] = chr(252)) then //2 bytes value
    begin
      result:=byte(pchar(packet)[1])+ (byte(pchar(packet)[2]) shl 8);
      packet:=packet+3;
      exit;
    end;
  if ( pchar(packet)[0] = chr(253)) then //3 bytes value
    begin
      result:= byte(pchar(packet)[1])+ (byte(pchar(packet)[2]) shl 8)+(byte(pchar(packet)[3]) shl 16);
      packet:=packet+4;
      exit