(* Collection of code snippets by Arne Vajhøj *)
(* (from articles on eksperten.dk / vajhoej.dk written sometime between 2004 and now) *)
[inherit('common')]
program dbremote(input, output);

%include "sqlr$pascal:sqlrdef.pas"

%include 't1.inc'

type
   sqlrcon = integer64;
   sqlrcurs = integer64;

procedure con_exit(con : sqlrcon);

var
   msg : pstr;

begin
   sqlr$con_errormessage(con, msg.body, msg.length);
   writeln('SQLR connection error: ' + msg);
   halt;
end;

procedure curs_exit(curs : sqlrcurs);

var
   msg : pstr;

begin
   sqlr$cur_errormessage(curs, msg.body, msg.length);
   writeln('SQLR cursor error: ' + msg);
   halt;
end;

procedure other_exit(msg : pstr);

begin
   writeln(msg);
   halt;
end;

function t1_get_one(con : sqlrcon;
                    f2 : pstr;
                    function ph(num, nam, typ : pstr) : pstr;
                    function bn(num, nam : pstr) : pstr) : integer;

var
   curs : sqlrcurs;
   temp : integer64;
   stat, res, f1 : integer;
   s : pstr;

begin
   sqlr$cur_alloc(con, curs);
   sqlr$cur_preparequery(curs, 'SELECT f1 FROM t1 WHERE f2 = ' + ph('1', 'f2', 'text'));
   sqlr$cur_inputbindstring(curs, bn('1', 'f2'), substr(f2.body, 1, f2.length));
   stat := sqlr$cur_executequery(curs, res);
   if (stat mod 2) = 0 then curs_exit(curs);
   stat := sqlr$cur_getfieldbyindex(curs, 0, 0, s.body, s.length);
   if (stat mod 2) = 0 then begin
      other_exit('Row not found');
   end;
   sqlr$cur_getfieldasintbyind(curs, 0, 0, temp);
   f1 := temp;
   sqlr$con_endsession(con);
   sqlr$cur_free(curs);
   t1_get_one := f1;
end;

function t1_get_all(con : sqlrcon;
                    var buf : array[$L1..$U1:integer] of t1;
                    bufsiz : integer) : integer;

label
   done;

var
   curs : sqlrcurs;
   stat, count : integer;
   row : unsigned64;
   temp : integer64;
   s : pstr;

begin
   sqlr$cur_alloc(con, curs);
   stat := sqlr$cur_sendquery(curs, 'select f1,f2 from t1');
   if (stat mod 2) = 0 then curs_exit(curs);
   sqlr$cur_setresultsetbuffersize(curs, 100);
   row := 0;
   count := 0;
   while true do begin
      if count >= bufsiz then goto done;
      stat := sqlr$cur_getfieldbyindex(curs, row, 0, s.body, s.length);
      if (stat mod 2) = 0 then goto done;
      count := count + 1;
      sqlr$cur_getfieldasintbyind(curs, row, 0, temp);
      buf[count].f1 := temp;
      sqlr$cur_getfieldbyindex(curs, row, 1, buf[count].f2.body, buf[count].f2.length);
      row := row + 1;
   end;
done:
   sqlr$con_endsession(con);
   sqlr$cur_free(curs);
   t1_get_all := count;
end;

procedure t1_put(con : sqlrcon;
                 f1 : integer;
                 f2 : pstr; function ph(num, nam, typ : pstr) : pstr;
                 function bn(num, nam : pstr) : pstr);

var
   curs : sqlrcurs;
   stat, res : integer;
   temp : integer64;
   n : unsigned64;

begin
   sqlr$cur_alloc(con, curs);
   sqlr$cur_preparequery(curs, 'INSERT INTO t1 VALUES(' + ph('1', 'f1', 'int') + ', ' + ph('2', 'f2', 'text') + ')');
   temp := f1;
   sqlr$cur_inputbindlong(curs, bn('1', 'f1'), temp);
   sqlr$cur_inputbindstring(curs, bn('2', 'f2'), substr(f2.body, 1, f2.length));
   stat := sqlr$cur_executequery(curs, res);
   if (stat mod 2) = 0 then curs_exit(curs);
   sqlr$cur_affectedrows(curs, n);
   if n <> 1 then begin
      other_exit('INSERT did not insert 1 row');
   end;
   sqlr$con_endsession(con);
   sqlr$cur_free(curs);
end;

procedure t1_remove(con : sqlrcon;
                    f1 : integer;
                    function ph(num, nam, typ : pstr) : pstr;
                    function bn(num, nam : pstr) : pstr);

var
   curs : sqlrcurs;
   stat, res : integer;
   temp : integer64;
   n : unsigned64;

begin
   sqlr$cur_alloc(con, curs);
   sqlr$cur_preparequery(curs, 'DELETE FROM t1 WHERE f1 = ' + ph('1', 'f1', 'int'));
   temp := f1;
   sqlr$cur_inputbindlong(curs, bn('1', 'f1'), temp);
   stat := sqlr$cur_executequery(curs, res);
   if (stat mod 2) = 0 then curs_exit(curs);
   sqlr$cur_affectedrows(curs, n);
   if n <> 1 then begin
      other_exit('DELETE did not delete 1 row');
   end;
   sqlr$con_endsession(con);
   sqlr$cur_free(curs);
end;

procedure t1_dump(con : sqlrcon);

const
   MAX_REC = 100;

var
   buf : array [1..MAX_REC] of t1;
   i, n : integer;

begin
   n := t1_get_all(con, buf, MAX_REC);
   for i := 1 to n do begin
      writeln('  ', buf[i].f1:1, ' ', buf[i].f2);
   end;
end;

procedure test(lbl : pstr;
               host : pstr;
               port : unsigned16;
               un : pstr;
               pw : pstr;
               function ph(num, nam, typ : pstr) : pstr;
               function bn(num, nam : pstr) : pstr);

var
   con : sqlrcon;
   socket : packed array[1..1] of char value '?';
   f1 : integer;

begin
   writeln('Connect host=', host, ' port=', port:1, ' (', lbl, ')'); 
   sqlr$con_alloc(fix(host), port, socket, fix(un), fix(pw), 0, 1, con);
   f1 := t1_get_one(con, 'BB', ph, bn);
   writeln('one:');
   writeln('  ', f1:1);
   writeln('all:');
   t1_dump(con);   
   t1_put(con, 999, 'XXX', ph, bn);
   writeln('all after insert:');
   t1_dump(con);
   t1_remove(con, 999, ph, bn);
   writeln('all after delete:');
   t1_dump(con);
   sqlr$con_free(con);
end;

function std_ph(num, nam, typ : pstr) : pstr;

begin
   std_ph := '?';
end;

function std_bn(num, nam : pstr) : pstr;

begin
   std_bn := num;
end;

function pgsql_ph(num, nam, typ : pstr) : pstr;

begin
   pgsql_ph := '$' + num + '::' + typ;
end;

function pgsql_bn(num, nam : pstr) : pstr;

begin
   pgsql_bn := num;
end;

function ora_ph(num, nam, typ : pstr) : pstr;

begin
   ora_ph := ':' + nam;
end;

function ora_bn(num, nam : pstr) : pstr;

begin
   ora_bn := nam;
end;

begin
   test('ODBC - MS SQLServer', 'arnepc5', 9001, 'arne', 'topsecret', std_ph, std_bn);
   test('ODBC - IBM DB2', 'arnepc5', 9002, 'arne', 'topsecret', std_ph, std_bn);
   test('local - Oracle DB', 'arnepc5', 9003, 'arne', 'topsecret', ora_ph, ora_bn);
   test('local - IBM DB2', 'arnepc5', 9004, 'arne', 'topsecret', std_ph, std_bn);
   test('local - MySQL', 'arnepc5', 9005, 'arne', 'topsecret', std_ph, std_bn);
   test('local - PostgreSQL', 'arnepc5', 9006, 'arne', 'topsecret', pgsql_ph, pgsql_bn);
end.