home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / sql_rdb.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-10-01  |  26.0 KB  |  862 lines  |  [TEXT/ttxt]
  1. /*****************************************************************************/
  2. /**                                                                         **/
  3. /**  Copyright (C) 1992-1994 BY                                             **/
  4. /**  MITECH CORPORATION, ACTON, MASSACHUSETTS.                              **/
  5. /**  ALL RIGHTS RESERVED.                                                   **/
  6. /**                                                                         **/
  7. /** Permission to use, copy, modify, distribute and sell this software      **/
  8. /** and its documentation for any purpose and without fee is hereby         **/
  9. /** granted, provided that the above copyright notice appear in all copies  **/
  10. /** and that both that copyright notice and this permission notice appear   **/
  11. /** in supporting documentation, and that the name of Mitech Corporation    **/
  12. /** not be used in advertising or publicity pertaining to distribution      **/
  13. /** of the software without specific, written prior permission.             **/
  14. /**                                                                         **/
  15. /** MITECH DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING **/
  16. /** ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL**/
  17. /** MITECH BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR  **/
  18. /** ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,     **/
  19. /** WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,  **/
  20. /** ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS     **/
  21. /** SOFTWARE.                                                               **/
  22. /**                                                                         **/
  23. /*****************************************************************************/
  24.  
  25. /* Interface from SIOD to DIGITAL RDB SQL SERVICES.
  26.    20-JAN-94 George Carrette. GJC@MITECH.COM
  27.    This is a good demonstration of the fact that a direct
  28.    argument-for-argument translation of a C-language API into a lisp
  29.    language API is inferior to the more studied approach used here,
  30.    where we can eliminate the need for redundant arguments by encapsulation
  31.    of state.
  32.  
  33. Building: With SIOD 3.0, under VMS use $MMS/MACRO=("EXTRA=sql_rdb")
  34.           which compiles siod.c with #define INIT_EXTRA init_sql_rdb
  35.           and add sql_rdb.obj to the link statement.
  36.           Or use $@MAKEFILE EXTRA SQL_RDB
  37.  */
  38.  
  39. #include <stdio.h>
  40. #include <stdlib.h>
  41. #include <string.h>
  42. #include <sqlsrv.h>
  43. #include <math.h>
  44.  
  45. #include "siod.h"
  46.  
  47. LISP sym_ascii_string = NIL;
  48. LISP sym_generalized_number = NIL;
  49. LISP sym_generalized_date = NIL;
  50. LISP sym_varchar = NIL;
  51. LISP sym_varbyte = NIL;
  52. LISP sym_list_varbyte = NIL;
  53. LISP sym_table = NIL;
  54. LISP sym_list = NIL;
  55. LISP sym_update = NIL;
  56. LISP sym_read_only = NIL;
  57. LISP sym_insert_only = NIL;
  58. LISP sym_begin = NIL;
  59. LISP sym_end = NIL;
  60. LISP sym_abort = NIL;
  61.  
  62. LISP associations = NIL;
  63.  
  64. long cursor_gensym_counter = 0;
  65.  
  66. #define tc_extra tc_user_5
  67. #define extra_tc_association 1
  68. #define extra_tc_statement 2
  69.  
  70. struct association
  71. {LISP args;
  72.  LISP statements;
  73.  ASSOCIATE_ID id;
  74.  char *error_buffer;
  75.  char *read_buffer;
  76.  char *write_buffer;
  77.  long error_buffer_size;
  78.  long read_buffer_size;
  79.  long write_buffer_size;};
  80.  
  81. struct statement
  82. {LISP association;
  83.  LISP param_alist;
  84.  LISP select_alist;
  85.  LISP cursor;
  86.  long id;
  87.  SQLDA_ID params;
  88.  SQLDA_ID selects;};
  89.  
  90. LISP cadr(LISP x)
  91. {return(car(cdr(x)));}
  92.  
  93. LISP list3(LISP a,LISP b,LISP c)
  94. {return(cons(a,cons(b,cons(c,NIL))));}
  95.  
  96. void ps_i(char *fmt,long n)
  97. {char buff[512];
  98.  sprintf(buff,fmt,n);
  99.  put_st(buff);}
  100.  
  101. static LISP extcons(long length,long typec)
  102. {long flag;
  103.  LISP s;
  104.  flag = no_interrupt(1);
  105.  s = cons(NIL,NIL);
  106.  s->type = tc_extra;
  107.  s->storage_as.string.data = must_malloc(length);
  108.  s->storage_as.string.dim = typec;
  109.  memset(s->storage_as.string.data,0,length);
  110.  no_interrupt(flag);
  111.  return(s);}
  112.  
  113. LISP sqlrtl_associate(LISP l)
  114. {LISP obj,tmp;
  115.  long iflag,local_flag,status;
  116.  struct ASSOCIATE_STR  associate_str;
  117.  struct association *a;
  118.  char *nodename,*username,*password;
  119.  long majerr,suberr1,suberr2;
  120.  char errmsg[512],*estatus;
  121.  memset(&associate_str,0,sizeof(associate_str));
  122.  if NNULLP(cadr(assq(cintern("log"),l)))
  123.    {associate_str.CLIENT_LOG = SQLSRV_LOG_ASSOCIATION + SQLSRV_LOG_ROUTINE;
  124.     associate_str.SERVER_LOG = SQLSRV_LOG_ASSOCIATION;}
  125.  iflag = no_interrupt(1);
  126.  tmp = cadr(assq(cintern("node"),l));
  127.  if NULLP(tmp)
  128.    {local_flag = 1;
  129.     nodename = "0";}
  130.  else
  131.    {local_flag = 0;
  132.     nodename = get_c_string(tmp);}
  133.  username = NNULLP(tmp = cadr(assq(cintern("username"),l)))
  134.    ? get_c_string(tmp) : NULL;
  135.  password = NNULLP(tmp = cadr(assq(cintern("password"),l)))
  136.    ? get_c_string(tmp) : 0;
  137.  obj = extcons(sizeof(struct association),extra_tc_association);
  138.  a = (struct association *) obj->storage_as.string.data;
  139.  a->args = l;
  140.  a->statements = NIL;
  141.  a->id = 0;
  142.  a->error_buffer_size = 512;
  143.  a->read_buffer_size = 1024;
  144.  a->write_buffer_size = 1024;
  145.  a->error_buffer = (char *) malloc(a->error_buffer_size);
  146.  a->read_buffer = (char *) malloc(a->read_buffer_size);
  147.  a->write_buffer = (char *) malloc(a->write_buffer_size);
  148.  associate_str.ERRBUFLEN = a->error_buffer_size;
  149.  associate_str.ERRBUF = (unsigned char *)a->error_buffer;
  150.  associate_str.LOCAL_FLAG = local_flag;
  151.  associate_str.MEMORY_ROUTINE = NULL;
  152.  associate_str.FREE_MEMORY_ROUTINE = NULL;
  153.  status = sqlsrv_associate(nodename,
  154.                username,
  155.                password,
  156.                (unsigned char *)a->read_buffer,
  157.                (unsigned char *)a->write_buffer,
  158.                a->read_buffer_size,
  159.                a->write_buffer_size,
  160.                0,
  161.                &associate_str,
  162.                &a->id);
  163.  if (status == SQL_SUCCESS)
  164.    {associations = cons(obj,associations);
  165.     no_interrupt(iflag);
  166.     return(obj);}
  167.  if (a->id)
  168.    /* The id may be set even though the status is not success.
  169.       This area of the API is not well documented. */
  170.    {sqlsrv_sqlca_error(a->id,&majerr,&suberr1,&suberr2);
  171.     sqlsrv_release(a->id,0);}
  172.  else
  173.    {suberr1 = 0;
  174.     suberr2 = 0;
  175.     free(a->error_buffer);
  176.     free(a->read_buffer);
  177.     free(a->write_buffer);}
  178.  sprintf(errmsg,"sqlsrv_associate error %d, %d, %d",
  179.      status,suberr1,suberr2);
  180.  return(err(errmsg,NIL));}
  181.  
  182. struct association *get_association(LISP assoc,long oflag)
  183. {struct association *a;
  184.  if ((TYPE(assoc) != tc_extra) ||
  185.      (assoc->storage_as.string.dim != extra_tc_association))
  186.    return(err("not an association",assoc));
  187.  a = (struct association *)assoc->storage_as.string.data;
  188.  if (a->id || !oflag)
  189.    return(a);
  190.  else
  191.    {err("sqlsrv association has been released",assoc);
  192.     return(NULL);}}
  193.  
  194. LISP sqlrtl_associations(void)
  195. {return(associations);}
  196.  
  197. LISP sqlrtl_release(LISP assoc)
  198. {struct association *a;
  199.  long iflag,status;
  200.  char errmsg[512];
  201.  a = get_association(assoc,1);
  202.  iflag = no_interrupt(1);
  203.  status = sqlsrv_release(a->id,0);
  204.  free(a->error_buffer);
  205.  free(a->read_buffer);
  206.  free(a->write_buffer);
  207.  memset(a,0,sizeof(struct association));
  208.  associations = delq(assoc,associations);
  209.  if (status != SQL_SUCCESS)
  210.    {sprintf(errmsg,"sqlsrv_release error %d",status);
  211.     err(errmsg,NIL);}
  212.  no_interrupt(iflag);
  213.  return(nullp(NIL));}
  214.  
  215. LISP sqlrtl_error(ASSOCIATE_ID id)
  216. {long majerr,suberr1,suberr2;
  217.  char *estatus,errmsg[512];
  218.  sqlsrv_sqlca_error(id,&majerr,&suberr1,&suberr2);
  219.  sprintf(errmsg,"SQL error %d %d %d",majerr,suberr1,suberr2);
  220.  return(err(errmsg,NIL));}
  221.  
  222. LISP sqlrtl_status_error(long status)
  223. {char errmsg[512];
  224.  sprintf(errmsg,"SQL error %d",status);
  225.  return(err(errmsg,NIL));}
  226.  
  227. LISP sqlrtl_sqlca_num_batch_rows(LISP assoc)
  228. {long status,iflag;
  229.  struct association *a;
  230.  a = get_association(assoc,1);
  231.  iflag = no_interrupt(1);
  232.  status = sqlsrv_sqlca_num_batch_rows(a->id);
  233.  if (status >= 0)
  234.    {no_interrupt(iflag);
  235.     return(flocons(status));}
  236.  else
  237.    return(sqlrtl_error(a->id));}
  238.  
  239. LISP sqlrtl_sqlca_count(LISP assoc)
  240. {long status,iflag;
  241.  struct association *a;
  242.  a = get_association(assoc,1);
  243.  iflag = no_interrupt(1);
  244.  status = sqlsrv_sqlca_count(a->id);
  245.  if (status >= 0)
  246.    {no_interrupt(iflag);
  247.     return(flocons(status));}
  248.  else
  249.    return(sqlrtl_error(a->id));}
  250.  
  251.  
  252. LISP sqlrtl_execute_immediate(LISP assoc,LISP stmt)
  253. {long status,iflag;
  254.  char *st;
  255.  struct association *a;
  256.  a = get_association(assoc,1);
  257.  st = get_c_string(stmt);
  258.  iflag = no_interrupt(1);
  259.  status = sqlsrv_execute_immediate(a->id,0,st);
  260.  if (status == SQL_SUCCESS)
  261.    {no_interrupt(iflag);
  262.     return(nullp(NIL));}
  263.  else
  264.    return(sqlrtl_error(a->id));}
  265.  
  266. LISP sqlrtl_describe_association(LISP assoc)
  267. {struct association *a;
  268.  a = get_association(assoc,0);
  269.  put_st("An SQLSRV association\n");
  270.  put_st("Opened with: ");
  271.  lprin1f(a->args,stdout);
  272.  put_st("\n");
  273.  ps_i("Statements: %d\n",get_c_long(llength(a->statements)));
  274.  if (a->id)
  275.    {ps_i("Associate id: %x\n",a->id);
  276.     put_st("error buffer: ");
  277.     put_st(a->error_buffer);
  278.     put_st("\n");}
  279.  else
  280.    put_st("which has been released\n");
  281.  return(NIL);}
  282.  
  283. LISP sqlrtl_sqlda_alist(SQLDA_ID x)
  284. {long i,n;
  285.  char name[1000];
  286.  LISP vtype,l;
  287.  short namelen,type,scale;
  288.  unsigned short len;
  289.  n = sqlsrv_sqlda_sqld(x);
  290.  l = NIL;
  291.  for(i = 0; i < n; ++i)
  292.    {sqlsrv_sqlda_column_name(x,i,&name[0],&namelen);
  293.     sqlsrv_sqlda_column_type(x,i,&type,&len,&scale,0);
  294.     switch(type)
  295.       {case SQLSRV_ASCII_STRING: vtype = sym_ascii_string; break;
  296.        case SQLSRV_GENERALIZED_NUMBER: vtype = sym_generalized_number; break;
  297.        case SQLSRV_GENERALIZED_DATE: vtype = sym_generalized_date; break;
  298.        case SQLSRV_VARCHAR: vtype = sym_varchar; break;
  299.        case SQLSRV_VARBYTE: vtype = sym_varbyte; break;
  300.        case SQLSRV_LIST_VARBYTE: vtype = sym_list_varbyte; break;
  301.        default: vtype = NIL; break;}
  302.     name[namelen] = 0;
  303.     l = cons(list3(rintern(name),flocons(i),vtype),l);}
  304.  return(nreverse(l));}
  305.  
  306. #define SQL_WSR_CHARSET "\t\n"
  307.  
  308. LISP sqlrtl_prepare(LISP assoc,LISP sql)
  309. {long iflag,status,tmpn;
  310.  char *s,cname[32],*tmps = NULL,*ptr;
  311.  struct statement *c;
  312.  struct association *a;
  313.  LISP st;
  314.  a = get_association(assoc,1);
  315.  s = get_c_string(sql);
  316.  iflag = no_interrupt(1);
  317.  st = extcons(sizeof(struct statement),extra_tc_statement);
  318.  c = (struct statement *) st->storage_as.string.data;
  319.  c->association = assoc;
  320.  tmpn = strlen(s);
  321.  if (tmpn != strcspn(s,SQL_WSR_CHARSET))
  322.    {tmps = (char *) malloc(tmpn+1);
  323.     strcpy(tmps,s);
  324.     for(ptr=tmps;*ptr;++ptr) if (strchr(SQL_WSR_CHARSET,*ptr)) *ptr = ' ';
  325.     s = tmps;}
  326.  status = sqlsrv_prepare(a->id,0,s,&c->id,&c->params,&c->selects);
  327.  if (tmps) free(tmps);
  328.  if (status != SQL_SUCCESS)
  329.    sqlrtl_error(a->id);
  330.  if (c->params)
  331.    {status = sqlsrv_allocate_sqlda_data(a->id,c->params);
  332.     if (status != SQL_SUCCESS)
  333.       {sqlsrv_release_statement(a->id,1,&c->id);
  334.        sqlrtl_error(a->id);}}
  335.  if (c->selects)
  336.    {status = sqlsrv_allocate_sqlda_data(a->id,c->selects);
  337.     if (status != SQL_SUCCESS)
  338.       {sqlsrv_release_statement(a->id,1,&c->id);
  339.        sqlrtl_error(a->id);}}
  340.  c->param_alist = NIL;
  341.  c->select_alist = NIL;
  342.  c->cursor = NIL;
  343.  a->statements = cons(st,a->statements);
  344.  c->param_alist = sqlrtl_sqlda_alist(c->params);
  345.  c->select_alist = sqlrtl_sqlda_alist(c->selects);
  346.  if (c->selects)
  347.    {sprintf(cname,"CUR_%06D",++cursor_gensym_counter);
  348.     c->cursor = strcons(strlen(cname),cname);}
  349.  no_interrupt(iflag);
  350.  return(st);}
  351.  
  352. struct statement *get_statement(LISP st)
  353. {if ((TYPE(st) != tc_extra) ||
  354.      (st->storage_as.string.dim != extra_tc_statement))
  355.    {err("not a statement",st);
  356.     return(NULL);}
  357.  else
  358.    return((struct statement *)st->storage_as.string.data);}
  359.  
  360. LISP sqlrtl_statement_params(LISP x)
  361. {return((get_statement(x))->params);}
  362.  
  363. LISP sqlrtl_statement_selects(LISP x)
  364. {return((get_statement(x))->select_alist);}
  365.  
  366. LISP sqlrtl_statement_association(LISP x)
  367. {return((get_statement(x))->association);}
  368.  
  369. void describe_sqlda(SQLDA_ID x)
  370. {long i,n;
  371.  char name[100],*vtype;
  372.  short namelen,type,scale;
  373.  unsigned short len;
  374.  n = sqlsrv_sqlda_sqld(x);
  375.  ps_i("sqlda: %d elements\n",n);
  376.  for(i = 0; i < n; ++i)
  377.    {sqlsrv_sqlda_column_name(x,i,&name[0],&namelen);
  378.     sqlsrv_sqlda_column_type(x,i,&type,&len,&scale,0);
  379.     switch(type)
  380.       {case SQLSRV_ASCII_STRING: vtype = "ASCII_STRING"; break;
  381.        case SQLSRV_GENERALIZED_NUMBER: vtype = "GENERALIZED_NUMBER"; break;
  382.        case SQLSRV_GENERALIZED_DATE: vtype = "GENERALIZED_DATE"; break;
  383.        case SQLSRV_VARCHAR: vtype = "VARCHAR"; break;
  384.        case SQLSRV_VARBYTE: vtype = "VARBYTE"; break;
  385.        case SQLSRV_LIST_VARBYTE: vtype = "LIST_VARBYTE"; break;
  386.        default: vtype = "????"; break;}
  387.     name[namelen] = 0;
  388.     put_st(name);
  389.     put_st(": ");
  390.     put_st(vtype);
  391.     ps_i(" %d \n",len);}}
  392.  
  393. LISP sqlrtl_describe_statement(LISP x)
  394. {struct statement *c;
  395.  c = get_statement(x);
  396.  put_st("A prepared SQL statement\n");
  397.  ps_i("ID: %d\n",c->id);
  398.  if (c->params)
  399.    {put_st("param ");
  400.     describe_sqlda(c->params);}
  401.  if (c->selects)
  402.    {put_st("select ");
  403.     describe_sqlda(c->selects);
  404.     put_st("Cursor: ");
  405.     lprin1f(c->cursor,stdout);
  406.     put_st("\n");}
  407.  return(NIL);}
  408.  
  409. LISP sqlrtl_release_statement(LISP x)
  410. {struct statement *c;
  411.  struct association *a;
  412.  LISP assoc;
  413.  long status,iflag;
  414.  c = get_statement(x);
  415.  assoc = c->association;
  416.  a = get_association(assoc,1);
  417.  iflag = no_interrupt(1);
  418.  status = sqlsrv_release_statement(a->id,1,&c->id);
  419.  a->statements = delq(x,a->statements);
  420.  if (status != SQL_SUCCESS)
  421.    sqlrtl_error(a->id);
  422.  no_interrupt(iflag);
  423.  return(NIL);}
  424.  
  425. LISP sqlrtl_declare_cursor(LISP stmt,LISP type,LISP mode)
  426. {long status,iflag,itype,imode;
  427.  struct statement *c;
  428.  struct association *a;
  429.  LISP cursor;
  430.  c = (struct statement *)get_statement(stmt);
  431.  a = get_association(c->association,1);
  432.  cursor = c->cursor;
  433.  if NULLP(cursor)
  434.    return(err("statement has no cursor",stmt));
  435.  if (NULLP(type) && NULLP(mode))
  436.    return(NIL);
  437.  else
  438.    {if EQ(type,sym_table)
  439.       itype = SQLSRV_TABLE_CURSOR;
  440.     else if EQ(type,sym_list)
  441.       itype = SQLSRV_LIST_CURSOR;
  442.     else
  443.       err("invalid cursor type",type);
  444.     if EQ(mode,sym_update)
  445.       imode = SQLSRV_MODE_UPDATE;
  446.     else if EQ(mode,sym_read_only)
  447.       imode = SQLSRV_MODE_READ_ONLY;
  448.     else if EQ(mode,sym_insert_only)
  449.       imode = SQLSRV_MODE_INSERT_ONLY;
  450.     else
  451.       err("invalid cursor mode",mode);}
  452.  iflag = no_interrupt(1);
  453.  status = sqlsrv_declare_cursor(a->id,get_c_string(cursor),c->id,itype,imode);
  454.  if (status == SQL_SUCCESS)
  455.    {no_interrupt(iflag);
  456.     return(nullp(NIL));}
  457.  return(sqlrtl_error(a->id));}
  458.  
  459. LISP sqlrtl_execute(LISP stmt,LISP batchp)
  460. {struct statement *c;
  461.  struct association *a;
  462.  long status,iflag,eflag;
  463.  c = get_statement(stmt);
  464.  a = get_association(c->association,1);
  465.  if NULLP(batchp)
  466.    eflag = 0;
  467.  else if EQ(batchp,sym_begin)
  468.    eflag = 1;
  469.  else if EQ(batchp,sym_end)
  470.    eflag = 2;
  471.  else if EQ(batchp,sym_abort)
  472.    eflag = 3;
  473.  else
  474.    err("invalid batch execute mode",batchp);
  475.  iflag = no_interrupt(1);
  476.  status = sqlsrv_execute(a->id,0,c->id,eflag,c->params);
  477.  if (status == SQL_SUCCESS)
  478.    {no_interrupt(iflag);
  479.     return(nullp(NIL));}
  480.  sqlrtl_error(a->id);}
  481.  
  482. LISP sqlrtl_open_cursor(LISP stmt)
  483. {struct statement *c;
  484.  struct association *a;
  485.  long status,iflag;
  486.  LISP cursor;
  487.  c = get_statement(stmt);
  488.  a = get_association(c->association,1);
  489.  cursor = c->cursor;
  490.  if NULLP(cursor)
  491.    err("statement has no cursor",stmt);
  492.  iflag = no_interrupt(1);
  493.  status = sqlsrv_open_cursor(a->id,get_c_string(cursor),c->id,c->params);
  494.  if (status == SQL_SUCCESS)
  495.    {no_interrupt(iflag);
  496.     return(nullp(NIL));}
  497.  sqlrtl_error(a->id);}
  498.  
  499. LISP sqlrtl_fetch(LISP stmt)
  500. {struct statement *c;
  501.  struct association *a;
  502.  long status,iflag;
  503.  LISP cursor;
  504.  c = get_statement(stmt);
  505.  a = get_association(c->association,1);
  506.  cursor = c->cursor;
  507.  if NULLP(cursor)
  508.    err("statement has no cursor",stmt);
  509.  iflag = no_interrupt(1);
  510.  status = sqlsrv_fetch(a->id,get_c_string(cursor),0,0,c->selects);
  511.  switch(status)
  512.    {case SQL_SUCCESS:
  513.     case 1:
  514.       /* with fetch_many in use this sometimes returned 1 */
  515.       no_interrupt(iflag);
  516.       return(nullp(NIL));
  517.     case SQL_EOS:
  518.       no_interrupt(iflag);
  519.       return(NIL);
  520.     default:
  521.       sqlrtl_error(a->id);}}
  522.  
  523. LISP sqlrtl_fetch_many(LISP stmt,LISP count)
  524. {struct statement *c;
  525.  struct association *a;
  526.  long status,iflag,k;
  527.  LISP cursor;
  528.  c = get_statement(stmt);
  529.  a = get_association(c->association,1);
  530.  cursor = c->cursor;
  531.  if NULLP(cursor)
  532.    err("statement has no cursor",stmt);
  533.  if NULLP(count)
  534.    k = 0;
  535.  else
  536.    k = get_c_long(count);
  537.  iflag = no_interrupt(1);
  538.  status = sqlsrv_fetch_many(a->id,get_c_string(cursor),0,k);
  539.  switch(status)
  540.    {case SQL_SUCCESS:
  541.       no_interrupt(iflag);
  542.       return(nullp(NIL));
  543.     case SQL_EOS:
  544.       no_interrupt(iflag);
  545.       return(NIL);
  546.     default:
  547.       sqlrtl_error(a->id);}}
  548.  
  549. LISP sqlrtl_close_cursor(LISP stmt)
  550. {struct statement *c;
  551.  struct association *a;
  552.  long status,iflag;
  553.  LISP cursor;
  554.  c = get_statement(stmt);
  555.  a = get_association(c->association,1);
  556.  cursor = c->cursor;
  557.  if NULLP(cursor)
  558.    err("statement has no cursor",stmt);
  559.  iflag = no_interrupt(1);
  560.  status = sqlsrv_close_cursor(a->id,get_c_string(cursor));
  561.  if (status == SQL_SUCCESS)
  562.    {no_interrupt(iflag);
  563.     return(nullp(NIL));}
  564.  sqlrtl_error(a->id);}
  565.  
  566. long decnumpick(char *str,long len,long start,long count)
  567. {long n,c,j;
  568.  if (start >= len)
  569.    return(0);
  570.  n = 0;
  571.  for(j=0;(j<count) && str[j+start]; ++j)
  572.    n = n * 10 + str[j+start] - '0';
  573.  return(n);}
  574.  
  575. LISP sqlrtl_get_datum(SQLDA_ID x,long k)
  576. {short typ,scl,nullp,varlen;
  577.  unsigned short len;
  578.  char *data;
  579.  long status,iflag;
  580.  LISP result;
  581.  double d;
  582.  iflag = no_interrupt(1);
  583.  if (k < sqlsrv_sqlda_sqld(x))
  584.    /* need to check because sqlsrv's currently does not correctly */
  585.    status = sqlsrv_sqlda_map_data(x,k,&typ,&len,&scl,
  586.                   (unsigned char **)&data,&nullp,0);
  587.  else
  588.    status = SQLSRV_INVCOLNUM;
  589.  if (status == SQL_SUCCESS)
  590.    {if (nullp)
  591.       result = NIL;
  592.     else
  593.       switch(typ)
  594.     {case SQLSRV_ASCII_STRING:
  595.        result = strcons(len,data);
  596.        break;
  597.      case SQLSRV_GENERALIZED_DATE:
  598.        result = cons(flocons((double) decnumpick(data,len,12,2) +
  599.                  ((double) decnumpick(data,len,14,2)) / 100),
  600.              NIL);
  601.        result = cons(flocons(decnumpick(data,len,10,2)),result);
  602.        result = cons(flocons(decnumpick(data,len,8,2)),result);
  603.        result = cons(flocons(decnumpick(data,len,6,2)),result);
  604.        result = cons(flocons(decnumpick(data,len,4,2)),result);
  605.        result = cons(flocons(decnumpick(data,len,0,4)),result);
  606.        break;
  607.      case SQLSRV_GENERALIZED_NUMBER:
  608.        data[len] = 0;
  609.        d = atof(data);
  610.        if (scl != 0)
  611.          d = d * pow(10.0,- (double) scl);
  612.        result = flocons(d);
  613.        break;
  614.      case SQLSRV_VARCHAR:
  615.        varlen = *((unsigned short *) data);
  616.        /* this varlen check is just paranoia */
  617.        if (varlen > len) varlen = len;
  618.        result = strcons(varlen,&data[2]);
  619.        break;
  620.      case SQLSRV_VARBYTE:
  621.      case SQLSRV_LIST_VARBYTE:
  622.      default:
  623.        sqlsrv_sqlda_unmap_data(x,k);
  624.        err("SQLSRV data type not handled",NIL);}
  625.     sqlsrv_sqlda_unmap_data(x,k);
  626.     no_interrupt(iflag);
  627.     return(result);}
  628.  sqlrtl_status_error(status);}
  629.  
  630. LISP sqlrtl_get_param(LISP x,LISP n)
  631. {struct statement *c;
  632.  c = get_statement(x);
  633.  return(sqlrtl_get_datum(c->params,
  634.              get_c_long(NNULLP(numberp(n)) ? n :
  635.                     cadr(assq(n,c->param_alist)))));}
  636.  
  637. LISP sqlrtl_get_column(LISP x,LISP n)
  638. {struct statement *c;
  639.  c = get_statement(x);
  640.  return(sqlrtl_get_datum(c->selects,
  641.              get_c_long(NNULLP(numberp(n)) ? n :
  642.                     cadr(assq(n,c->select_alist)))));}
  643.  
  644. void sqlrtl_put_datum(SQLDA_ID x,long k,LISP value)
  645. {short typ,scl,nullp;
  646.  char *data,*string,num[100];
  647.  long status,iflag,slen;
  648.  double d;
  649.  unsigned short len;
  650.  iflag = no_interrupt(1);
  651.  if (k < sqlsrv_sqlda_sqld(x))
  652.    /* need to check because sqlsrv's currently does not correctly */
  653.    status = sqlsrv_sqlda_map_data(x,k,&typ,&len,&scl,
  654.                   (unsigned char **)&data,&nullp,0);
  655.  else
  656.    status = SQLSRV_INVCOLNUM;
  657.  if (status != SQL_SUCCESS)
  658.    sqlrtl_status_error(status);
  659.  switch(TYPE(value))
  660.    {case tc_flonum:
  661.       d = FLONM(value);
  662.       if (scl != 0)
  663.     d = d * pow(10.0,(double) scl);
  664.       string = num;
  665.       sprintf(string,"%g",d);
  666.       break;
  667.     case tc_symbol:
  668.     case tc_string:
  669.       string = get_c_string(value);
  670.       break;
  671.     default:
  672.       sqlsrv_sqlda_unmap_data(x,k);
  673.       err("lisp data type not handled",value);}
  674.  slen = strlen(string);
  675.  switch(typ)
  676.    {case SQLSRV_ASCII_STRING:
  677.     case SQLSRV_GENERALIZED_NUMBER:
  678.       /* note: date is being handled as a string here, instead
  679.      of the list of numbers that I returned in sqlrtl_get_datum. */
  680.     case SQLSRV_GENERALIZED_DATE:
  681.       /* note: not signalling error on truncation */
  682.       if (slen > len)
  683.     memcpy(data,string,len);
  684.       else
  685.     {memcpy(data,string,slen);
  686.      if (len > slen)
  687.        memset(&data[slen],' ',len-slen);}
  688.       break;
  689.     case SQLSRV_VARCHAR:
  690.       if (slen > len)
  691.     /* note: not signalling error on truncation */
  692.     {memcpy(&data[2],string,len);
  693.      *((unsigned short *) data) = len;}
  694.       else
  695.     {memcpy(&data[2],string,slen);
  696.      *((unsigned short *) data) = slen;}
  697.       break;
  698.     case SQLSRV_VARBYTE:
  699.     case SQLSRV_LIST_VARBYTE:
  700.     default:
  701.      sqlsrv_sqlda_unmap_data(x,k);
  702.      err("SQLSRV data type not handled",NIL);}
  703.  sqlsrv_sqlda_unmap_data(x,k);
  704.  no_interrupt(iflag);}
  705.  
  706. LISP sqlrtl_set_param(LISP x,LISP n,LISP value)
  707. {struct statement *c;
  708.  c = get_statement(x);
  709.  sqlrtl_put_datum(c->params,
  710.           get_c_long(NNULLP(numberp(n)) ? n :
  711.                  cadr(assq(n,c->param_alist))),
  712.           value);
  713.  return(NIL);}
  714.  
  715. LISP sqlrtl_release_generic(LISP x)
  716. {if ((TYPE(x) != tc_extra) ||
  717.      ((x->storage_as.string.dim != extra_tc_statement) &&
  718.       (x->storage_as.string.dim != extra_tc_association)))
  719.    err("not a statement or association",x);
  720.  if (x->storage_as.string.dim == extra_tc_statement)
  721.    return(sqlrtl_release_statement(x));
  722.  else
  723.    return(sqlrtl_release(x));}
  724.  
  725. LISP sqlrtl_error_buffer(LISP assoc,LISP resetp)
  726. {struct association *a;
  727.  long iflag,len;
  728.  char *end;
  729.  LISP s;
  730.  a = get_association(assoc,1);
  731.  if NNULLP(resetp)
  732.    {memset(a->error_buffer,0,a->error_buffer_size);
  733.     return(NIL);}
  734.  iflag = no_interrupt(1);
  735.  if (end = memchr(a->error_buffer,0,a->error_buffer_size))
  736.    len = end - a->error_buffer;
  737.  else
  738.    len = a->error_buffer_size;
  739.  s = strcons(len,a->error_buffer);
  740.  no_interrupt(iflag);
  741.  return(s);}
  742.  
  743.  
  744. LISP sqlrtl_association_statements(LISP assoc)
  745. {struct association *a;
  746.  a = get_association(assoc,0);
  747.  return(a->statements);}
  748.  
  749. void extra_gc_scan(LISP ptr)
  750. {struct association *a;
  751.  struct statement *s;
  752.  switch(ptr->storage_as.string.dim)
  753.    {case extra_tc_association:
  754.       a = (struct association *) ptr->storage_as.string.data;
  755.       a->args = gc_relocate(a->args);
  756.       a->statements = gc_relocate(a->statements);
  757.       break;
  758.     case extra_tc_statement:
  759.       s = (struct statement *) ptr->storage_as.string.data;
  760.       s->association = gc_relocate(s->association);
  761.       s->param_alist = gc_relocate(s->param_alist);
  762.       s->select_alist = gc_relocate(s->select_alist);
  763.       s->cursor = gc_relocate(s->cursor);
  764.       break;
  765.     default:
  766.       errswitch();}}
  767.  
  768. LISP extra_gc_mark(LISP ptr)
  769. {struct association *a;
  770.  struct statement *s;
  771.  switch(ptr->storage_as.string.dim)
  772.    {case extra_tc_association:
  773.       a = (struct association *) ptr->storage_as.string.data;
  774.       gc_mark(a->args);
  775.       gc_mark(a->statements);
  776.       break;
  777.     case extra_tc_statement:
  778.       s = (struct statement *) ptr->storage_as.string.data;
  779.       gc_mark(s->association);
  780.       gc_mark(s->param_alist);
  781.       gc_mark(s->select_alist);
  782.       gc_mark(s->cursor);
  783.       break;
  784.     default:
  785.       errswitch();}
  786.  return(NIL);}
  787.  
  788. void extra_gc_free(LISP ptr)
  789.      /* release storage allocated. As an extra feature we could
  790.     release associations and statements that were not
  791.     otherwise released. */
  792. {free(ptr->storage_as.string.data);}
  793.  
  794. void extra_prin1(LISP ptr,FILE *f)
  795. {struct association *a;
  796.  struct statement *s;
  797.  char buff[512];
  798.  switch(ptr->storage_as.string.dim)
  799.    {case extra_tc_association:
  800.       a = (struct association *) ptr->storage_as.string.data;
  801.       sprintf(buff,"#{SQL ASSOCIATION %p}",a);
  802.       fput_st(f,buff);
  803.       break;
  804.     case extra_tc_statement:
  805.       s = (struct statement *) ptr->storage_as.string.data;
  806.       sprintf(buff,"#{SQL STATEMENT %p}",s);
  807.       fput_st(f,buff);
  808.       break;
  809.     default:
  810.       errswitch();}}
  811.  
  812. void init_sql_rdb(void)
  813. {long j;
  814.  set_gc_hooks(tc_extra,
  815.           NULL,
  816.           extra_gc_mark,
  817.           extra_gc_scan,
  818.           extra_gc_free,
  819.           &j);
  820.  set_print_hooks(tc_extra,extra_prin1);
  821.  gc_protect(&associations);
  822.  gc_protect_sym(&sym_ascii_string,"ascii_string");
  823.  gc_protect_sym(&sym_generalized_number,"generalized_number");
  824.  gc_protect_sym(&sym_generalized_date,"generalized_date");
  825.  gc_protect_sym(&sym_varchar,"varchar");
  826.  gc_protect_sym(&sym_varbyte,"varbyte");
  827.  gc_protect_sym(&sym_list_varbyte,"list_varbyte");
  828.  gc_protect_sym(&sym_table,"table");
  829.  gc_protect_sym(&sym_list,"list");
  830.  gc_protect_sym(&sym_update,"update");
  831.  gc_protect_sym(&sym_read_only,"read-only");
  832.  gc_protect_sym(&sym_insert_only,"insert-only");
  833.  gc_protect_sym(&sym_begin,"begin");
  834.  gc_protect_sym(&sym_end,"end");
  835.  gc_protect_sym(&sym_abort,"abort");
  836.  init_subr_1("rdb-describe-association",sqlrtl_describe_association);
  837.  init_subr_1("rdb-describe-statement",sqlrtl_describe_statement);
  838.  init_lsubr("rdb-sql-associate",sqlrtl_associate);
  839.  init_subr_1("rdb-sql-release",sqlrtl_release_generic);
  840.  init_subr_1("rdb-sql-release-statement",sqlrtl_release_statement);
  841.  init_subr_1("rdb-sql-release-association",sqlrtl_release);
  842.  init_subr_0("rdb-sql-associations",sqlrtl_associations);
  843.  init_subr_1("rdb-sql-association-statements",sqlrtl_association_statements);
  844.  init_subr_2("rdb-sql-execute-immediate",sqlrtl_execute_immediate);
  845.  init_subr_2("rdb-sql-prepare",sqlrtl_prepare);
  846.  init_subr_1("rdb-sql-statement-params",sqlrtl_statement_params);
  847.  init_subr_1("rdb-sql-statement-selects",sqlrtl_statement_selects);
  848.  init_subr_1("rdb-sql-statement-association",sqlrtl_statement_association);
  849.  init_subr_3("rdb-sql-declare-cursor",sqlrtl_declare_cursor);
  850.  init_subr_1("rdb-sql-open-cursor",sqlrtl_open_cursor);
  851.  init_subr_1("rdb-sql-close-cursor",sqlrtl_close_cursor);
  852.  init_subr_1("rdb-sql-fetch",sqlrtl_fetch);
  853.  init_subr_2("rdb-sql-fetch-many",sqlrtl_fetch_many);
  854.  init_subr_2("rdb-sql-execute",sqlrtl_execute);
  855.  init_subr_2("rdb-sql-get-param",sqlrtl_get_param);
  856.  init_subr_2("rdb-sql-get-column",sqlrtl_get_column);
  857.  init_subr_3("rdb-sql-set-param",sqlrtl_set_param);
  858.  init_subr_1("rdb-sql-num-batch-rows",sqlrtl_sqlca_num_batch_rows);
  859.  init_subr_1("rdb-sql-count",sqlrtl_sqlca_count);
  860.  init_subr_2("rdb-sql-error-buffer",sqlrtl_error_buffer);
  861.  printf("Enhancements (C) Copyright 1994 Mitech Corporation.\n");}
  862.