{ Database unit. Currently implemented for MySQL only.

  Copyright (C) 2000-2005 Frank Heckenbach <frank@pascal.gnu.de>

  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Library General Public
  License as published by the Free Software Foundation, version 2.

  This library 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
  Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this library; see the file COPYING.LIB. If not,
  write to the Free Software Foundation, Inc., 59 Temple Place -
  Suite 330, Boston, MA 02111-1307, USA. }

{$gnu-pascal,I-}
{$if __GPC_RELEASE__ < 20030426}
{$error This unit requires GPC release 20030426 or newer.}
{$endif}

unit Database;

interface

uses GPC, MySQL;

type
  TDBType = (db_MySQL);  { Someday even more databases may be added ;-}

  TErrorProc = procedure (const Msg: String);

  PDBRes = ^TDBRes;
  TDBRes (Columns, Rows: Integer) = record
    Items: array [1 .. Max (1, Rows), 1 .. Max (1, Columns)] of PString
  end;

{ The following DB... routines operate on a global database handle.
  They are easy to use if you need access to only one database at a
  time. If you need to access several databases simultaneously,
  you can use the DBH... routines below. }

{ Open a database connection. The procedure given in ErrorProc will
  be used by DBOpen and other routines of this unit to output error
  messages. DBType is the type of database to connect to. If
  RequiredVersion is not empty, the database server's version is
  checked, and an error is produced if it is smaller. Host is the
  database server's host. User and Password are use for connecting
  to the server. If Database is not empty, this database is used by
  default. Returns True if successful, False if any error occurred. }
function  DBOpen (ErrorProc: TErrorProc; DBType: TDBType; const RequiredVersion, Host, User, Password, Database: String): Boolean;

{ Quote an arbitrary string for inclusion into an SQL query. The
  result will be surround with single quotes and have all
  problematic characters quoted appropriately. }
function  DBQuoteString (const s: String): TString;

{ Like DBQuoteString, but it is passed a pointer to a string. If the
  pointer is nil, it returns `NULL', the SQL equivalent of nil. }
function  DBQuotePString (p: PString): TString;

{ @@ Obsolete when GPC will support undiscriminated strings. }
{ Like DBQuotePString, but returns the result in a newly allocated
  string pointer. It is necessary to use this function if the quoted
  string may be longer than the capacity of TString. }
function  DBQuotePStringP (p: PString): PString;

{ Like DBQuotePString, but for a CString. }
function  DBQuoteCString (s: CString): TString;

{ Do a database query without a return value. }
function  DBCommand (const QueryStr: String): Boolean; attribute (ignorable);

{ Returns the ID generated by the last command if it was an `INSERT'
  command affecting an `AUTO_INCREMENT' column. Undefined otherwise. }
function  DBInsertID: LongInt;

{ Do a database query with a return value. If the query fails, nil
  is returned (after calling ErrorProc). }
function  DBQuery (const QueryStr: String): PDBRes;

{ Like DBQuery, but if OptionalResult is True, also queries without
  return value are accepted, and nil is returned. }
function  DBQueryOpt (const QueryStr: String; OptionalResult: Boolean): PDBRes;

{ Return an item from a result of DBQuery. }
function  DBQueryItem (QueryRes: PDBRes; Row, Column: Integer): PString;

{ Take an item from a result of DBQuery. Like DBQueryItem, but
  also removes this item from QueryRes. The storage of the item will
  not be freed by DBQueryDone, so the caller can do it any time
  later. Subsequent calls to this function for the same item will
  return nil. }
function  DBQueryTakeItem (QueryRes: PDBRes; Row, Column: Integer): PString;

{ Free the memory allocated by DBQuery. }
procedure DBQueryDone (QueryRes: PDBRes);

{ Close a database connection. This is done automatically at the end
  of a program. }
procedure DBClose;

{ The following DBH... routines work just like the corresponding
  DB... routines, but they take the DB connection handle as an
  additional parameter, so they can be used when several connections
  have to be opened at the same time. DBHInit initializes a handle
  without making a connection. It is not necessary to call it before
  DBHOpen, but you can call it to be sure that you can later call
  DBHClose on the handle without problems, even if the handle was
  never opened. }

type
  TDBHandle = record
    ErrorProc: TErrorProc;
  case DBType: TDBType of
    db_MySQL: (MySQLHandle: PMySQL)
  end;

procedure DBHInit          (var Handle: TDBHandle);
function  DBHOpen          (var Handle: TDBHandle; ErrorProc: TErrorProc; DBType: TDBType; const RequiredVersion, Host, User, Password, Database: String): Boolean;
function  DBHQuoteString   (const Handle: TDBHandle; const s: String) = Res: TString;
function  DBHQuotePString  (const Handle: TDBHandle; p: PString): TString;
function  DBHQuotePStringP (const Handle: TDBHandle; p: PString) = Res: PString;
function  DBHQuoteCString  (const Handle: TDBHandle; s: CString) = Res: TString;
function  DBHCommand       (const Handle: TDBHandle; const QueryStr: String) = Res: Boolean; attribute (ignorable);
function  DBHInsertID      (const Handle: TDBHandle): LongInt;
function  DBHQuery         (const Handle: TDBHandle; const QueryStr: String): PDBRes;
function  DBHQueryOpt      (const Handle: TDBHandle; const QueryStr: String; OptionalResult: Boolean) = Res: PDBRes;
procedure DBHClose         (var Handle: TDBHandle);

implementation

procedure DBHInit (var Handle: TDBHandle);
begin
  Handle.DBType := db_MySQL;
  Handle.MySQLHandle := nil
end;

function DBHOpen (var Handle: TDBHandle; ErrorProc: TErrorProc; DBType: TDBType; const RequiredVersion, Host, User, Password, Database: String): Boolean;
begin
  DBHOpen := False;
  Handle.ErrorProc := ErrorProc;
  Handle.DBType := DBType;
  case DBType of
    db_MySQL: begin
                Handle.MySQLHandle := MySQLInit (nil);
                if Handle.MySQLHandle = nil then
                  begin
                    Handle.ErrorProc ('DBHOpen: MySQLInit failed');
                    Exit
                  end;
                if MySQLRealConnect2 (Handle.MySQLHandle, Host, User, Password, Database) = nil then
                  begin
                    Handle.ErrorProc ('DBHOpen: MySQLRealConnect2 failed, error: ' + MySQLError (Handle.MySQLHandle));
                    DBHClose (Handle);
                    Exit
                  end;
                if (RequiredVersion <> '') and (MySQLGetServerInfo (Handle.MySQLHandle) < RequiredVersion) then
                  begin
                    Handle.ErrorProc ('DBHOpen: need at least MySQL version ' + RequiredVersion);
                    DBHClose (Handle);
                    Exit
                  end
              end;
  end;
  DBHOpen := True
end;

{ DBHQuoteString, DHBQuotePString and DHBQuoteCString should not
  depend on the individual DB connection, but might depend on the
  kind of database used. So we take a Handle parameter as well (just
  like mysql_real_escape_string does). }

function DBHQuoteString (const Handle: TDBHandle; const s: String) = Res: TString;
var
  Buf: array [0 .. 4 * Length (s)] of Char;
  EscapedLength: Cardinal;
begin
  EscapedLength := MySQLRealEscapeString (Handle.MySQLHandle, Buf, s, Length (s));
  SetLength (Res, { @@ } Min (EscapedLength, Res.Capacity));
  if EscapedLength > 0 then Move (Buf, Res[1], Length (Res));
  Res := '''' + Res + ''''
end;

function DBHQuotePString (const Handle: TDBHandle; p: PString): TString;
begin
  if p = nil then
    DBHQuotePString := 'NULL'
  else
    DBHQuotePString := DBHQuoteString (Handle, p^)
end;

function DBHQuotePStringP (const Handle: TDBHandle; p: PString) = Res: PString;
var EscapedLength: Cardinal;
begin
  if p = nil then
    Res := NewString ('NULL')
  else
    begin
      var Buf: array [0 .. 4 * Length (p^)] of Char;
      EscapedLength := MySQLRealEscapeString (Handle.MySQLHandle, Buf, p^, Length (p^));
      New (Res, EscapedLength + 2);
      SetLength (Res^, EscapedLength);
      if EscapedLength > 0 then Move (Buf, Res^[1], Length (Res^));
      Res^ := '''' + Res^ + ''''
    end
end;

function DBHQuoteCString (const Handle: TDBHandle; s: CString) = Res: TString;
var SLength, EscapedLength: Cardinal;
begin
  if s = nil then
    Res := 'NULL'
  else
    begin
      SLength := CStringLength (s);
      var Buf: array [0 .. 4 * SLength] of Char;
      EscapedLength := MySQLRealEscapeString (Handle.MySQLHandle, Buf, s, SLength);
      SetLength (Res, { @@ } Min (EscapedLength, Res.Capacity));
      if EscapedLength > 0 then Move (Buf, Res[1], Length (Res));
      Res := '''' + Res + ''''
    end
end;

function DBHCommand (const Handle: TDBHandle; const QueryStr: String) = Res: Boolean;
begin
  Res := MySQLQuery (Handle.MySQLHandle, QueryStr);
  if not Res then Handle.ErrorProc ('DB: ' + MySQLError (Handle.MySQLHandle) + ' (' + QueryStr + ')')
end;

function DBHInsertID (const Handle: TDBHandle): LongInt;
begin
  DBHInsertID := MySQLInsertId (Handle.MySQLHandle)
end;

function DBHQueryOpt (const Handle: TDBHandle; const QueryStr: String; OptionalResult: Boolean) = Res: PDBRes;
var
  TmpRes: PMySQLRes;
  Length, i, j: Integer;
  p: PString;
  pc: CString;
  Row: MySQLRow;
  Lengths: PFLA;
begin
  Res := nil;
  if not DBHCommand (Handle, QueryStr) then Exit;
  TmpRes := MySQLStoreResult (Handle.MySQLHandle);
  if TmpRes = nil then
    begin
      if not OptionalResult then
        Handle.ErrorProc ('DBHQuery (MySQLStoreResult): ' + MySQLError (Handle.MySQLHandle) + ' (' + QueryStr + ')');
      Exit
    end;
  New (Res, MySQLNumFields (TmpRes), MySQLNumRows (TmpRes));
  for i := 1 to Res^.Rows do
    begin
      Row := MySQLFetchRow (TmpRes);
      Lengths := MySQLFetchLengths (TmpRes);
      for j := 1 to Res^.Columns do
        begin
          pc := Row^[j - 1];
          if pc = nil then
            p := nil
          else
            begin
              Length := Lengths^[j - 1];
              New (p, Max (1, Length));
              SetLength (p^, Length);
              if Length > 0 then Move (pc^, p^[1], Length)
            end;
          Res^.Items[i, j] := p
        end
    end;
  MySQLFreeResult (TmpRes)
end;

function DBHQuery (const Handle: TDBHandle; const QueryStr: String): PDBRes;
begin
  DBHQuery := DBHQueryOpt (Handle, QueryStr, False)
end;

function DBQueryItem (QueryRes: PDBRes; Row, Column: Integer): PString;
begin
  DBQueryItem := QueryRes^.Items[Row, Column]
end;

function DBQueryTakeItem (QueryRes: PDBRes; Row, Column: Integer): PString;
begin
  DBQueryTakeItem := QueryRes^.Items[Row, Column];
  QueryRes^.Items[Row, Column] := nil
end;

procedure DBQueryDone (QueryRes: PDBRes);
var i, j: Integer;
begin
  if QueryRes = nil then Exit;
  for i := 1 to QueryRes^.Rows do
    for j := 1 to QueryRes^.Columns do
      Dispose (QueryRes^.Items[i, j]);
  Dispose (QueryRes)
end;

procedure DBHClose (var Handle: TDBHandle);
begin
  case Handle.DBType of
    db_MySQL: if Handle.MySQLHandle <> nil then
                begin
                  MySQLClose (Handle.MySQLHandle);
                  Handle.MySQLHandle := nil
                end;
  end
end;

var
  DBHandle: TDBHandle;

function DBOpen (ErrorProc: TErrorProc; DBType: TDBType; const RequiredVersion, Host, User, Password, Database: String): Boolean;
begin
  DBClose;
  DBOpen := DBHOpen (DBHandle, ErrorProc, DBType, RequiredVersion, Host, User, Password, Database)
end;

function DBQuoteString (const s: String): TString;
begin
  DBQuoteString := DBHQuoteString (DBHandle, s)
end;

function DBQuotePString (p: PString): TString;
begin
  DBQuotePString := DBHQuotePString (DBHandle, p)
end;

function DBQuotePStringP (p: PString): PString;
begin
  DBQuotePStringP := DBHQuotePStringP (DBHandle, p)
end;

function DBQuoteCString (s: CString): TString;
begin
  DBQuoteCString := DBHQuoteCString (DBHandle, s)
end;

function DBCommand (const QueryStr: String): Boolean;
begin
  DBCommand := DBHCommand (DBHandle, QueryStr)
end;

function DBInsertID: LongInt;
begin
  DBInsertID := DBHInsertID (DBHandle)
end;

function DBQueryOpt (const QueryStr: String; OptionalResult: Boolean): PDBRes;
begin
  DBQueryOpt := DBHQueryOpt (DBHandle, QueryStr, OptionalResult)
end;

function DBQuery (const QueryStr: String): PDBRes;
begin
  DBQuery := DBHQuery (DBHandle, QueryStr)
end;

procedure DBClose;
begin
  DBHClose (DBHandle)
end;

to begin do
  DBHInit (DBHandle);

to end do
  DBClose;

end.