home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume28 / sybperl / part01 / sybperl.c < prev   
Encoding:
C/C++ Source or Header  |  1992-02-10  |  23.2 KB  |  992 lines
  1. static char SccsId[] = "@(#)sybperl.c    1.9    12/20/91";
  2. /************************************************************************/
  3. /*    Copyright 1991 by Michael Peppler and ITF Management SA     */
  4. /*                                    */
  5. /*    Full ownership of this software, and all rights pertaining to     */
  6. /*    the for-profit distribution of this software, are retained by     */
  7. /*    Michael Peppler and ITF Management SA.  You are permitted to     */
  8. /*    use this software without fee.  This software is provided "as     */
  9. /*    is" without express or implied warranty.  You may redistribute     */
  10. /*    this software, provided that this copyright notice is retained,    */
  11. /*    and that the software is not distributed for profit.  If you     */
  12. /*    wish to use this software in a profit-making venture, you must     */
  13. /*    first license this code and its underlying technology from     */
  14. /*    ITF Management SA.                         */
  15. /*                                    */
  16. /*    Bottom line: you can have this software, you can use it, you     */
  17. /*    can give it away.  You just can't sell any or all parts of it     */
  18. /*    without prior permission from ITF Management SA.        */
  19. /************************************************************************/
  20.  
  21. /* sybperl.c
  22.  *
  23.  * Call Sybase DB-Library functions from Perl.
  24.  * Written by Michael Peppler (mpeppler@itf.ch)
  25.  * ITF Management SA, 13 rue de la Fontaine
  26.  * CH-1204 Geneva, Switzerland
  27.  * Tel: (+4122) 312 1311 Fax: (+4122) 312 1322
  28.  */
  29.  
  30.  
  31. /* 
  32.  * The Perl/Sybase savestr() conflict.
  33.  * Both Perl and Sybase DB-Library have a function called savestr(). 
  34.  * This creates a problem when calling dbcmd() and dbuse(). There are 
  35.  * several ways to work around this, one of which is to #define 
  36.  * BROKEN_DBCMD, which enables some code that I've written to simulate 
  37.  * dbcmd() locally. See Makefile and BUGS for details.
  38.  */
  39. #include "EXTERN.h"
  40. #include "perl.h"
  41. #undef MAX
  42. #undef MIN
  43.  
  44. #if !defined(VERSION3)
  45. #define str_2static(s)        str_2mortal(s)
  46. #endif
  47.  
  48. #include <sybfront.h>
  49. #include <sybdb.h>
  50. #include <syberror.h>
  51.  
  52. #include "patchlevel.h"
  53.  
  54. extern int wantarray;
  55.  
  56. /* 
  57.  * The variables that the Sybase routines set, and that you may want 
  58.  * to test in your Perl script. These variables are READ-ONLY.
  59.  */
  60. static enum uservars
  61. {
  62.     UV_SUCCEED,            /* Returns SUCCEED */
  63.     UV_FAIL,            /* Returns FAIL */
  64.     UV_NO_MORE_ROWS,        /* Returns NO_MORE_ROWS */
  65.     UV_NO_MORE_RESULTS,        /* Returns NO_MORE_RESULTS */
  66.     UV_ComputeId,        /* Returns the compute id of the row (in dbnextrow()) */
  67.     UV_SybperlVer,        /* Returns Sybperl Version/Patchlevel */
  68.     UV_DBstatus,        /* The value status value of the last dbnextrow() call */
  69. };
  70.  
  71. /* 
  72.  * User subroutines that we have implemented. I've found that I can do 
  73.  * all the stuff I want to with this subset of DB-Library. Let me know 
  74.  * if you implement further routines.
  75.  * The names are self-explanatory.
  76.  */
  77. static enum usersubs
  78. {
  79.     US_dblogin,            /* This also performs the first dbopen()  */
  80.     US_dbopen,
  81.     US_dbclose,
  82.     US_dbcmd,
  83.     US_dbsqlexec,
  84.     US_dbresults,
  85.     US_dbnextrow,
  86.     US_dbcancel,
  87.     US_dbcanquery,
  88.     US_dbexit,
  89.     US_dbuse,
  90. #ifdef HAS_CALLBACK
  91.     US_dberrhandle,
  92.     US_dbmsghandle,
  93. #endif
  94.     US_dbstrcpy,
  95. };
  96.  
  97. #ifndef MAX_DBPROCS
  98. #define MAX_DBPROCS 25        /* Change this if you really want your perl script to talk to */
  99.                 /* more than 25 dataserver connections at a time ...*/
  100. #endif
  101.  
  102. static LOGINREC *login;
  103. static DBPROCESS *dbproc[MAX_DBPROCS];
  104. static int exitCalled = 0;    /* Set to 1 if dbexit() has been called. */
  105. static int ComputeId;
  106. static int DBstatus;        /* Set by dbnextrow() */
  107.  
  108. /* Stack pointer for the error routines.  This is set to the stack pointer
  109.    when entering into the sybase subroutines.  Error and message
  110.    handling needs this.  */
  111.  
  112. static int perl_sp;
  113.  
  114. /* Current error handler name. */
  115.  
  116. static char *err_handler_sub;
  117.  
  118. /* Current message handler subroutine name */
  119.  
  120. static char *msg_handler_sub;
  121.  
  122. /* Macro to access the stack.  This is necessary since error handlers may
  123.    call perl routines and thus the stack may change.  I hope most compilers
  124.    will optimize this reasonably. */
  125.  
  126. #define STACK(SP) (stack->ary_array + (SP))
  127.  
  128.  
  129. static int usersub();
  130. static int userset();
  131. static int userval();
  132. static int err_handler(), msg_handler();
  133.  
  134. int userinit()
  135. {
  136.     init_sybase();
  137. }
  138.  
  139. int
  140. init_sybase()
  141. {
  142.     struct ufuncs uf;
  143.     char *filename = "sybase.c";
  144.  
  145.     if (dbinit() == FAIL)    /* initialize dblibrary */
  146.     exit(ERREXIT);
  147. /*
  148.  * Install the user-supplied error-handling and message-handling routines.
  149.  * They are defined at the bottom of this source file.
  150.  */
  151.     dberrhandle(err_handler);
  152.     dbmsghandle(msg_handler);
  153.  
  154.     if(MAX_DBPROCS > 25)
  155.     dbsetmaxprocs(MAX_DBPROCS);
  156.     
  157.     uf.uf_set = userset;
  158.     uf.uf_val = userval;
  159.  
  160. #define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
  161.  
  162.     MAGICVAR("SUCCEED",    UV_SUCCEED);
  163.     MAGICVAR("FAIL",UV_FAIL);
  164.     MAGICVAR("NO_MORE_ROWS",    UV_NO_MORE_ROWS);
  165.     MAGICVAR("NO_MORE_RESULTS",    UV_NO_MORE_RESULTS);
  166.     MAGICVAR("ComputeId",    UV_ComputeId);
  167.     MAGICVAR("SybperlVer",    UV_SybperlVer);
  168.  
  169.     make_usub("dblogin",    US_dblogin,    usersub, filename);
  170.     make_usub("dbopen",        US_dbopen,    usersub, filename);
  171.     make_usub("dbclose",    US_dbclose,    usersub, filename);
  172.     make_usub("dbcmd",        US_dbcmd,    usersub, filename);
  173.     make_usub("dbsqlexec",    US_dbsqlexec,    usersub, filename);
  174.     make_usub("dbresults",    US_dbresults,    usersub, filename);
  175.     make_usub("dbnextrow",    US_dbnextrow,    usersub, filename);
  176.     make_usub("dbcancel",    US_dbcancel,    usersub, filename);
  177.     make_usub("dbcanquery",    US_dbcanquery,    usersub, filename);
  178.     make_usub("dbexit",    US_dbexit,    usersub, filename);
  179.     make_usub("dbuse",    US_dbuse,    usersub, filename);
  180. #ifdef HAS_CALLBACK
  181.     make_usub("dberrhandle", US_dberrhandle, usersub, filename);
  182.     make_usub("dbmsghandle", US_dbmsghandle, usersub, filename);
  183. #endif
  184.     make_usub("dbstrcpy", US_dbstrcpy, usersub, filename);
  185.  
  186. }
  187.  
  188. static int
  189. usersub(ix, sp, items)
  190. int ix;
  191. register int sp;
  192. register int items;
  193. {
  194.     STR **st = stack->ary_array + sp;
  195.     ARRAY *ary = stack;    
  196.     register int i;
  197.     register STR *Str;        /* used in str_get and str_gnum macros */
  198.     int inx = -1;        /* Index into dbproc[] array. Passed as first parameter to nearly all &dbxxx() calls */
  199.  
  200.  
  201.     if(exitCalled)
  202.     fatal("&dbexit() has been called. Access to Sybase impossible.");
  203.  
  204.     perl_sp = sp + items;
  205.  
  206.     /* 
  207.      * We're calling some dblib function, but dblogin has not been 
  208.      * called. Two actions are possible: either fail the call, or call 
  209.      * dblogin/dbopen with the default info. The second option is used 
  210.      * to keep backwards compatibility with an older version of 
  211.      * sybperl. A call to fatal(msg) is probably better.
  212.      */
  213.     if(!login && (ix != US_dblogin) && (ix != US_dbmsghandle) && (ix != US_dberrhandle))
  214.     {                /* You can call &dbmsghandle/errhandle before calling &dblogin */
  215. #ifdef OLD_SYBPERL
  216.     login = dblogin();
  217.     dbproc[0] = dbopen(login, NULL);
  218. #else
  219.     fatal("&dblogin has not been called yet!");
  220. #endif
  221.     }
  222.     
  223.     switch (ix)
  224.     {
  225.       case US_dblogin:
  226.     if (items > 2)
  227.         fatal("Usage: &dblogin([user[,pwd]])");
  228.     if (login)
  229.         fatal("&dblogin() called twice.");
  230.     else
  231.     {
  232.         int retval;
  233.  
  234.         login = dblogin();
  235.         if(items)
  236.         {
  237.         DBSETLUSER(login, (char *)str_get(STACK(sp)[1]));
  238.         if(items > 1)
  239.             DBSETLPWD(login, (char *)str_get(STACK(sp)[2]));
  240.         }
  241.  
  242.         dbproc[0] = dbopen(login, NULL);
  243.         str_numset(STACK(sp)[0], (double) 0);
  244.     }
  245.     break;
  246.       case US_dbopen:
  247.     if (items != 0)
  248.         fatal("Usage: $dbproc = &dbopen;");
  249.     else
  250.     {
  251.         int j;
  252.         for(j = 0; j < MAX_DBPROCS; ++j)
  253.         if(dbproc[j] == NULL)
  254.             break;
  255.         if(j == MAX_DBPROCS)
  256.         fatal("&dbopen: No more dbprocs available.");
  257.         dbproc[j] = dbopen(login, NULL);
  258.         str_numset(STACK(sp)[0], (double) j);
  259.     }
  260.     break;
  261.       case US_dbclose:
  262.     if (items != 1)
  263.         fatal("Usage: $ret = &dbclose($dbproc);");
  264.     else
  265.     {
  266.         inx = getDbProc(STACK(sp)[1]);
  267.  
  268.         dbclose(dbproc[inx]);
  269.         dbproc[inx] = (DBPROCESS *)NULL;
  270.     }
  271.     break;
  272.       case US_dbcancel:
  273.     if (items > 1)
  274.         fatal("Usage: &dbcancel($dbproc)");
  275.     else
  276.     {
  277.         int retval;
  278. #if defined(BROKEN_DBCMD)
  279.         DBSTRING *ptr;
  280.         DBSTRING *old;
  281. #endif
  282.         if(items)
  283.         inx = getDbProc(STACK(sp)[1]);
  284.         else
  285.         inx = 0;
  286.  
  287.         retval = dbcancel(dbproc[inx]);
  288.         str_numset(STACK(sp)[0], (double) retval);
  289. #if defined(BROKEN_DBCMD)
  290.         ptr = dbproc[inx]->dbcmdbuf;
  291.         while(ptr)
  292.         {
  293.         old = ptr;
  294.         ptr = ptr->strnext;
  295.         free(old->strtext);
  296.         free(old);
  297.         }
  298.         dbproc[inx]->dbcmdbuf = NULL;
  299. #endif
  300.     }
  301.     break;
  302.  
  303.       case US_dbcanquery:
  304.     if (items > 1)
  305.         fatal("Usage: &dbcanquery($dbproc)");
  306.     else
  307.     {
  308.         int retval;
  309.  
  310.         if(items)
  311.         inx = getDbProc(STACK(sp)[1]);
  312.         else
  313.         inx = 0;
  314.  
  315.         retval = dbcanquery(dbproc[inx]);
  316.         str_numset(STACK(sp)[0], (double) retval);
  317.     }
  318.     break;
  319.  
  320.       case US_dbexit:
  321.     if (items != 0)
  322.         fatal("Usage: &dbexit()");
  323.     else
  324.     {
  325.         dbexit(dbproc[0]);
  326.         exitCalled++;
  327.         str_numset(STACK(sp)[0], (double) 1);
  328.     }
  329.     break;
  330.  
  331.       case US_dbuse:
  332.     if (items > 2)
  333.         fatal("Usage: &dbuse($dbproc, $database)");
  334.     else
  335.     {
  336. #if defined(BROKEN_DBCMD)
  337.         /* 
  338.          * Why doesn't this $@#! dbuse() call not work from within 
  339.          * Perl????? (So we emulate it here, but I sure can't 
  340.          * guarantee anything about portability to future versions 
  341.          * of DB-Library!
  342.          */
  343.         DBSTRING *new;
  344.         DBSTRING *sav;
  345.         char buff[256];
  346.         int ret, off;
  347.  
  348.         if(items == 2)
  349.         {
  350.         inx = getDbProc(STACK(sp)[1]);
  351.         off = 2;
  352.         }
  353.         else
  354.         inx = 0, off = 1;
  355.  
  356.         strcpy(buff, "use ");
  357.         strcat(buff, (char *)str_get(STACK(sp)[off]));
  358.         sav = dbproc[inx]->dbcmdbuf;
  359.  
  360.         Newz(902, new, 1, DBSTRING);
  361.         New(902, new->strtext, strlen(buff) + 1, BYTE);
  362.         strcpy(new->strtext, buff);
  363.         new->strtotlen = strlen(new->strtext)+1;
  364.         dbproc[inx]->dbcmdbuf = new;
  365.  
  366.         ret = dbsqlexec(dbproc[inx]);
  367.         ret = dbresults(dbproc[inx]);
  368.         while((ret = dbnextrow(dbproc[inx])) != NO_MORE_ROWS)
  369.         ;
  370.  
  371.         Safefree(new->strtext);
  372.         Safefree(new);
  373.         
  374.         dbproc[inx]->dbcmdbuf = sav;
  375.         str_numset(STACK(sp)[0], (double) SUCCEED);
  376. #else
  377.         int retval, off;
  378.         char str[255];
  379.         
  380.         if(items == 2)
  381.         {
  382.         inx = getDbProc(STACK(sp)[1]);
  383.         off = 2;
  384.         }
  385.         else
  386.         inx = 0, off = 1;
  387.         
  388.         strcpy(str, (char *)str_get(STACK(sp)[off]));
  389.  
  390.  
  391.         retval = dbuse(dbproc[inx], str);
  392.         str_numset(STACK(sp)[0], (double) retval);
  393. #endif
  394.     }
  395.     break;
  396.  
  397.       case US_dbsqlexec:
  398.     if (items > 1)
  399.         fatal("Usage: &dbsqlexec($dbproc)");
  400.     else
  401.     {
  402.         int retval;
  403.         if(items)
  404.         inx = getDbProc(STACK(sp)[1]);
  405.         else
  406.         inx = 0;
  407.  
  408.         retval = dbsqlexec(dbproc[inx]);
  409.         str_numset(STACK(sp)[0], (double) retval);
  410.     }
  411.     break;
  412.  
  413.       case US_dbresults:
  414.     if (items > 1)
  415.         fatal("Usage: &dbresults($dbproc)");
  416.     else
  417.     {
  418.         int retval;
  419.  
  420.         if(items)
  421.         inx = getDbProc(STACK(sp)[1]);
  422.         else
  423.         inx = 0;
  424.  
  425.         retval = dbresults(dbproc[inx]);
  426.         str_numset(STACK(sp)[0], (double) retval);
  427. #if defined(BROKEN_DBCMD)
  428.         if(retval==NO_MORE_RESULTS)
  429.         {
  430.         DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
  431.         DBSTRING *old;
  432.  
  433.         while(ptr)
  434.         {
  435.             old = ptr;
  436.             ptr = ptr->strnext;
  437.             Safefree(old->strtext);
  438.             Safefree(old);
  439.         }
  440.         dbproc[inx]->dbcmdbuf = NULL;
  441.         }
  442. #endif
  443.     }
  444.     break;
  445.  
  446.       case US_dbcmd:
  447.     if (items > 2)
  448.         fatal("Usage: &dbcmd($dbproc, $str)");
  449.     else
  450.     {
  451.         int retval, off;
  452. #if defined(BROKEN_DBCMD)
  453.         DBSTRING *ptr;
  454.         DBSTRING *new, *old;
  455.         char *strdup();
  456. #endif
  457.         if(items == 2)
  458.         {
  459.         inx = getDbProc(STACK(sp)[1]);
  460.         off = 2;
  461.         }
  462.         else
  463.         inx = 0, off = 1;
  464.         
  465. #if defined(BROKEN_DBCMD)
  466.         ptr = dbproc[inx]->dbcmdbuf;
  467.  
  468.         Newz(902, new, 1, DBSTRING);
  469.         New(902, new->strtext, strlen((char *)str_get(STACK(sp)[off])) + 1, BYTE);
  470.         strcpy(new->strtext, (char *)str_get(STACK(sp)[off]));
  471.         new->strtotlen = strlen(new->strtext)+1;
  472.         if(!ptr)
  473.         dbproc[inx]->dbcmdbuf = new;
  474.         else
  475.         {
  476.         while(ptr->strnext)
  477.             ptr = ptr->strnext;
  478.         ptr->strnext = new;
  479.         }
  480. #else
  481.         retval = dbcmd(dbproc[inx], (char *)str_get(STACK(sp)[off]));
  482. #endif
  483.         str_numset(STACK(sp)[0], (double) retval);
  484.     }
  485.     break;
  486.  
  487.     case US_dbnextrow:
  488.     if (items > 1)
  489.         fatal("Usage: @arr = &dbnextrow($dbproc)");
  490.     else
  491.     {
  492.         int retval;
  493.         if(items)
  494.         inx = getDbProc(STACK(sp)[1]);
  495.         else
  496.         inx = 0;
  497.  
  498.         --sp;        /* otherwise you get an empty element at the beginning of the results array! */
  499.  
  500.         DBstatus = retval = dbnextrow(dbproc[inx]);
  501.         if(retval == REG_ROW)
  502.         {
  503.             char buff[1024], *p = NULL, *t;
  504.         BYTE *data;
  505.         int col, type, numcols = dbnumcols(dbproc[inx]);
  506.         int len;
  507.         DBFLT8 tmp;
  508.  
  509.         ComputeId = 0;
  510.  
  511.         for(col = 1, buff[0] = 0; col <= numcols; ++col)
  512.         {
  513.             type = dbcoltype(dbproc[inx], col);
  514.             len = dbdatlen(dbproc[inx],col);
  515.             data = (BYTE *)dbdata(dbproc[inx],col);
  516.             t = &buff[0];
  517.             if(!data && !len)
  518.             {
  519.             strcpy(buff,"NULL");
  520.             }
  521.             else
  522.             {
  523.             switch(type)
  524.             {
  525.               case SYBCHAR:
  526.                 strncpy(buff,data,len);
  527.                 buff[len] = 0;
  528.                 break;
  529.               case SYBTEXT:
  530.                 New(902, p, len + 1, char);
  531.                 strncpy(p, data, len);
  532.                 p[len] = 0;
  533.                 t = p;
  534.                 break;
  535.               case SYBINT1:
  536.               case SYBBIT: /* a bit is at least a byte long... */
  537.                 sprintf(buff,"%u",*(unsigned char *)data);
  538.                 break;
  539.               case SYBINT2:
  540.                 sprintf(buff,"%d",*(short *)data);
  541.                 break;
  542.               case SYBINT4:
  543.                 sprintf(buff,"%d",*(long *)data);
  544.                 break;
  545.               case SYBFLT8:
  546.                 sprintf(buff,"%.6f",*(double *)data);
  547.                 break;
  548.               case SYBMONEY:
  549.                 dbconvert(dbproc[inx], SYBMONEY, data, len, SYBFLT8, &tmp, -1);
  550.                 sprintf(buff,"%.6f",tmp);
  551.                 break;
  552.               case SYBDATETIME:
  553.                 dbconvert(dbproc[inx], SYBDATETIME, data, len, SYBCHAR, buff, -1);
  554.                 break;
  555.               case SYBBINARY:
  556.                 dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
  557.                 break;
  558.               default:
  559.                 /* ignored for the moment */
  560.                 break;
  561.             }
  562.             }
  563.             (void)astore(ary,++sp,str_2static(str_make(t, 0)));
  564.             /* 
  565.              * If we've allocated some space to retrieve a 
  566.              * SYBTEXT field, then free it now.
  567.              */
  568.             if(t == p)
  569.             {
  570.             Safefree(p);
  571.             p = NULL;
  572.             }
  573.         }
  574.         }
  575.         if (retval > 0)
  576.         {
  577.             char buff[1024], *p = NULL, *t;
  578.         BYTE *data;
  579.         int col, type, numcols;
  580.         int len;
  581.         DBFLT8 tmp;
  582.  
  583.         ComputeId = retval;
  584.         numcols = dbnumalts(dbproc[inx], ComputeId);
  585.  
  586.         for(col = 1, buff[0] = 0; col <= numcols; ++col)
  587.         {
  588.             type = dbalttype(dbproc[inx], ComputeId, col);
  589.             len = dbadlen(dbproc[inx], ComputeId, col);
  590.             data = (BYTE *)dbadata(dbproc[inx], ComputeId, col);
  591.             t = &buff[0];
  592.             if(!data && !len)
  593.             {
  594.             strcpy(buff,"NULL");
  595.             }
  596.             else
  597.             {
  598.             switch(type)
  599.             {
  600.               case SYBCHAR:
  601.                 strncpy(buff,data,len);
  602.                 buff[len] = 0;
  603.                 break;
  604.               case SYBTEXT:
  605.                 New(902, p, len + 1, char);
  606.                 strncpy(p, data, len);
  607.                 p[len] = 0;
  608.                 t = p;
  609.                 break;
  610.               case SYBINT1:
  611.               case SYBBIT: /* a bit is at least a byte long... */
  612.                 sprintf(buff,"%d",*(char *)data);
  613.                 break;
  614.               case SYBINT2:
  615.                 sprintf(buff,"%d",*(short *)data);
  616.                 break;
  617.               case SYBINT4:
  618.                 sprintf(buff,"%d",*(long *)data);
  619.                 break;
  620.               case SYBFLT8:
  621.                 sprintf(buff,"%.6f",*(double *)data);
  622.                 break;
  623.               case SYBMONEY:
  624.                 dbconvert(dbproc[inx], SYBMONEY, data, len, SYBFLT8, &tmp, -1);
  625.                 sprintf(buff,"%.6f",tmp);
  626.                 break;
  627.               case SYBDATETIME:
  628.                 dbconvert(dbproc[inx], SYBDATETIME, data, len, SYBCHAR, buff, -1);
  629.                 break;
  630.               case SYBBINARY:
  631.                 dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
  632.                 break;
  633.               default:
  634.                 /* ignored at the moment... */
  635.                 break;
  636.             }
  637.             }
  638.             (void)astore(ary,++sp,str_2static(str_make(t, 0)));
  639.             /* 
  640.              * If we've allocated some space because the field 
  641.              * was a text field, then free it now:
  642.              */
  643.             if(t == p)
  644.             {
  645.             Safefree(p);
  646.             p = NULL;
  647.             }
  648.                 
  649.         }
  650.         }        
  651. #if defined(BROKEN_DBCMD)
  652.         /* 
  653.          * We can't rely on dbcmd(),dbresults() etc. to clean up 
  654.          * the dbcmdbuf linked list, so we have to it ourselves...
  655.          */
  656.         if(retval == NO_MORE_ROWS && !DBMORECMDS(dbproc[inx]))
  657.         {
  658.         DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
  659.         DBSTRING *new, *old;
  660.  
  661.         while(ptr)
  662.         {
  663.             old = ptr;
  664.             ptr = ptr->strnext;
  665.             Safefree(old->strtext);
  666.             Safefree(old);
  667.         }
  668.         dbproc[inx]->dbcmdbuf = NULL;
  669.         }
  670. #endif
  671.     }
  672.     break;
  673. #ifdef HAS_CALLBACK
  674.       case US_dberrhandle:
  675.     if (items > 1)
  676.         fatal ("Usage: &dberrhandle($handler)");
  677.     else
  678.     {
  679.         char *old = err_handler_sub;
  680.         if (items == 1)
  681.         {
  682.         if (STACK (sp)[1] == &str_undef)
  683.             err_handler_sub = 0;
  684.         else
  685.         {
  686.             char *sub = (char *) str_get (STACK (sp)[1]);    
  687.             New (902, err_handler_sub, strlen (sub) + 1, char);
  688.             strcpy (err_handler_sub, sub);
  689.         }
  690.         }
  691.  
  692.         if (old)
  693.         {
  694.         STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
  695.         if (items == 1)
  696.             Safefree (old);
  697.         }
  698.         else
  699.         STACK (sp)[0] = &str_undef;
  700.     }
  701.     break;
  702.       case US_dbmsghandle:
  703.     if (items > 1)
  704.         fatal ("Usage: &dbmsghandle($handler)");
  705.     else
  706.     {
  707.         char *old = msg_handler_sub;
  708.         if (items == 1)
  709.         {
  710.         if (STACK (sp)[1] == &str_undef)
  711.             msg_handler_sub = 0;
  712.         else
  713.         {
  714.             char *sub = (char *) str_get (STACK (sp)[1]);    
  715.             New (902, msg_handler_sub, strlen (sub) + 1, char);
  716.             strcpy (msg_handler_sub, sub);
  717.         }
  718.         }
  719.  
  720.         if (old)
  721.         {
  722.         STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
  723.         if (items == 1)
  724.             Safefree (old);
  725.         }
  726.         else
  727.         STACK (sp)[0] = &str_undef;
  728.     }
  729.     break;
  730. #endif                /* HAS_CALLBACK */
  731.       case US_dbstrcpy:
  732.     if (items > 1)
  733.         fatal("Usage: $string = &dbstrcpy($dbproc)");
  734.     else
  735.     {
  736.         int retval, len;
  737.         char *buff;
  738.  
  739.         if(items)
  740.         inx = getDbProc(STACK(sp)[1]);
  741.         else
  742.         inx = 0;
  743.  
  744.         if(dbproc[inx] && (len = dbstrlen(dbproc[inx])))
  745.         {
  746.         New(902, buff, len+1, char);
  747.         retval = dbstrcpy(dbproc[inx], 0, -1, buff);
  748.         str_set(STACK(sp)[0], buff);
  749.         Safefree(buff);
  750.         }
  751.         else
  752.         str_set(STACK(sp)[0], "");
  753.     }
  754.     break;
  755.  
  756.       default:
  757.     fatal("Unimplemented user-defined subroutine");
  758.     }
  759.     return sp;
  760. }
  761.  
  762. /* 
  763.  * Return the value of a userdefined variable. These variables are all 
  764.  * READ-ONLY in Perl.
  765.  */
  766. static int
  767. userval(ix, str)
  768. int ix;
  769. STR *str;
  770. {
  771.     char buff[24];
  772.     
  773.     switch (ix)
  774.     {
  775.       case UV_SUCCEED:
  776.     str_numset(str, (double)SUCCEED);
  777.     break;
  778.       case UV_FAIL:
  779.     str_numset(str, (double)FAIL);
  780.     break;
  781.       case UV_NO_MORE_ROWS:
  782.     str_numset(str, (double)NO_MORE_ROWS);
  783.     break;
  784.       case UV_NO_MORE_RESULTS:
  785.     str_numset(str, (double)NO_MORE_RESULTS);
  786.     break;
  787.       case UV_ComputeId:
  788.     str_numset(str, (double)ComputeId);
  789.     break;
  790.       case UV_SybperlVer:
  791.     sprintf(buff, "%d.%3.3d", VERSION, PATCHLEVEL);
  792.     str_set(str, buff);
  793.     break;
  794.       case UV_DBstatus:
  795.     str_numset(str, (double)DBstatus);
  796.     break;
  797.      }
  798.     return 0;
  799. }
  800.  
  801. static int
  802. userset(ix, str)        /* Not used. None of these variables are user-settable */
  803. int ix;
  804. STR *str;
  805. {
  806.     return 0;
  807. }
  808.  
  809.  
  810. /*ARGSUSED*/
  811. static int err_handler(db, severity, dberr, oserr, dberrstring, oserrstr)
  812.     DBPROCESS *db;
  813.     int severity;
  814.     int dberr;
  815.     int oserr;
  816.     char *dberrstring;
  817.     char *oserrstr;
  818. {
  819. #ifdef HAS_CALLBACK
  820.     /* If we have error handler subroutine, use it. */
  821.     if (err_handler_sub)
  822.     {
  823.     int sp = perl_sp;
  824.     int j;
  825.  
  826.     for(j = 0; j < MAX_DBPROCS; ++j)
  827.         if(db == dbproc[j])
  828.         break;
  829.     if(j == MAX_DBPROCS)
  830.         j = 0;
  831.     
  832.     /* Reserve spot for return value. */
  833.     astore (stack, ++ sp, Nullstr);
  834.     
  835.     /* Set up arguments. */
  836.     astore (stack, ++ sp,
  837.         str_2mortal (str_nmake ((double) j)));
  838.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
  839.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) dberr)));
  840.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) oserr)));
  841.     if (dberrstring && *dberrstring)
  842.         astore (stack, ++ sp, str_2mortal (str_make (dberrstring, 0)));
  843.     else
  844.         astore (stack, ++ sp, &str_undef);
  845.     if (oserrstr && *oserrstr)
  846.         astore (stack, ++ sp, str_2mortal (str_make (oserrstr, 0)));
  847.     else
  848.         astore (stack, ++ sp, &str_undef);
  849.     
  850.     /* Call it. */
  851.     sp = callback (err_handler_sub, sp, 0, 1, 6);
  852.     
  853.     /* Return whatever it returned. */
  854.     return (int) str_gnum (STACK (sp)[0]);
  855.     }
  856. #endif                /* HAS_CALLBACK */
  857.     if ((db == NULL) || (DBDEAD(db)))
  858.     return(INT_EXIT);
  859.     else 
  860.     {
  861.     fprintf(stderr,"DB-Library error:\n\t%s\n", dberrstring);
  862.     
  863.     if (oserr != DBNOERR)
  864.         fprintf(stderr,"Operating-system error:\n\t%s\n", oserrstr);
  865.     
  866.     return(INT_CANCEL);
  867.     }
  868. }
  869.  
  870. /*ARGSUSED*/
  871.  
  872. static int msg_handler(db, msgno, msgstate, severity, msgtext, srvname, procname, line)
  873.     DBPROCESS *db;
  874.     DBINT msgno;
  875.     int msgstate;
  876.     int severity;
  877.     char *msgtext;
  878.     char *srvname;
  879.     char *procname;
  880.     DBUSMALLINT line;
  881. {
  882. #ifdef HAS_CALLBACK
  883.     /* If we have message handler subroutine, use it. */
  884.     if (msg_handler_sub)
  885.     {
  886.     int sp = perl_sp;
  887.     int j;
  888.  
  889.     for(j = 0; j < MAX_DBPROCS; ++j)
  890.         if(db == dbproc[j])
  891.         break;
  892.     if(j == MAX_DBPROCS)
  893.         j = 0;
  894.     
  895.     /* Reserve spot for return value. */
  896.     astore (stack, ++ sp, Nullstr);
  897.     
  898.     /* Set up arguments. */
  899.     astore (stack, ++ sp,
  900.         str_2mortal (str_nmake ((double) j)));
  901.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgno)));
  902.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgstate)));
  903.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
  904.     if (msgtext && *msgtext)
  905.         astore (stack, ++ sp, str_2mortal (str_make (msgtext, 0)));
  906.     else
  907.         astore (stack, ++ sp, &str_undef);
  908.     if (srvname && *srvname)
  909.         astore (stack, ++ sp, str_2mortal (str_make (srvname, 0)));
  910.     else
  911.         astore (stack, ++ sp, &str_undef);
  912.     if (procname && *procname)
  913.         astore (stack, ++ sp, str_2mortal (str_make (procname, 0)));
  914.     else
  915.         astore (stack, ++ sp, &str_undef);
  916.     astore (stack, ++ sp, str_2mortal (str_nmake ((double) line)));
  917.     
  918.     /* Call it. */
  919.     sp = callback (msg_handler_sub, sp, 0, 1, 8);
  920.     
  921.     /* Return whatever it returned. */
  922.     return (int) str_gnum (STACK (sp)[0]);
  923.     }
  924. #endif                /* HAS_CALLBACK */
  925. #ifdef OLD_SYBPERL
  926.     if(!severity)
  927.     return 0;
  928. #endif
  929.     fprintf (stderr,"Msg %ld, Level %d, State %d\n", 
  930.          msgno, severity, msgstate);
  931.     if (strlen(srvname) > 0)
  932.     fprintf (stderr,"Server '%s', ", srvname);
  933.     if (strlen(procname) > 0)
  934.     fprintf (stderr,"Procedure '%s', ", procname);
  935.     if (line > 0)
  936.     fprintf (stderr,"Line %d", line);
  937.     
  938.     fprintf(stderr,"\n\t%s\n", msgtext);
  939.     
  940.     return(0);
  941. }
  942.  
  943. /* 
  944.  * Get the index into the dbproc[] array from a Perl STR datatype. 
  945.  * Check that the index is reasonably valid...
  946.  */
  947. int getDbProc(Str)
  948.     STR *Str;
  949. {
  950.     int ix = (int)str_gnum(Str);
  951.  
  952.     if(ix < 0 || ix >= MAX_DBPROCS)
  953.     fatal("$dbproc parameter is out of range.");
  954.     return ix;
  955. }
  956.  
  957. #ifdef HAS_CALLBACK
  958.  
  959. /* Taken from Perl 4.018 usub/usersub.c. mp. */
  960.  
  961. /* Be sure to refetch the stack pointer after calling these routines. */
  962.  
  963. int
  964. callback(subname, sp, gimme, hasargs, numargs)
  965. char *subname;
  966. int sp;            /* stack pointer after args are pushed */
  967. int gimme;        /* called in array or scalar context */
  968. int hasargs;        /* whether to create a @_ array for routine */
  969. int numargs;        /* how many args are pushed on the stack */
  970. {
  971.     static ARG myarg[3];    /* fake syntax tree node */
  972.     int arglast[3];
  973.     
  974.     arglast[2] = sp;
  975.     sp -= numargs;
  976.     arglast[1] = sp--;
  977.     arglast[0] = sp;
  978.  
  979.     if (!myarg[0].arg_ptr.arg_str)
  980.     myarg[0].arg_ptr.arg_str = str_make("",0);
  981.  
  982.     myarg[1].arg_type = A_WORD;
  983.     myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE);
  984.  
  985.     myarg[2].arg_type = hasargs ? A_EXPR : A_NULL;
  986.  
  987.     return do_subr(myarg, gimme, arglast);
  988. }
  989.  
  990. #endif                /* HAS_CALLBACK */
  991.  
  992.