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