This is sybperl.c in view mode; [Download] [Up]
static char SccsId[] = "@(#)sybperl.c 1.14 4/6/93";
/************************************************************************/
/* Copyright 1991, 1992, 1993 by Michael Peppler */
/* and ITF Management SA */
/* */
/* Full ownership of this software, and all rights pertaining to */
/* the for-profit distribution of this software, are retained by */
/* Michael Peppler and ITF Management SA. You are permitted to */
/* use this software without fee. This software is provided "as */
/* is" without express or implied warranty. You may redistribute */
/* this software, provided that this copyright notice is retained, */
/* and that the software is not distributed for profit. If you */
/* wish to use this software in a profit-making venture, you must */
/* first license this code and its underlying technology from */
/* ITF Management SA. */
/* */
/* Bottom line: you can have this software, you can use it, you */
/* can give it away. You just can't sell any or all parts of it */
/* without prior permission from ITF Management SA. */
/************************************************************************/
/* sybperl.c
*
* Call Sybase DB-Library functions from Perl.
* Written by Michael Peppler (mpeppler@itf.ch)
* ITF Management SA, 13 rue de la Fontaine
* CH-1204 Geneva, Switzerland
* Tel: (+4122) 312 1311 Fax: (+4122) 312 1322
*/
#include "EXTERN.h"
#include "perl.h"
#undef MAX
#undef MIN
#if defined(VERSION3)
#define str_2mortal(s) str_2static(s)
#endif
#include <sybfront.h>
#include <sybdb.h>
#include <syberror.h>
#include "patchlevel.h"
extern int wantarray;
/*
* The variables that the Sybase routines set, and that you may want
* to test in your Perl script. These variables are READ-ONLY.
*/
static enum uservars
{
UV_SUCCEED, /* Returns SUCCEED */
UV_FAIL, /* Returns FAIL */
UV_NO_MORE_ROWS, /* Returns NO_MORE_ROWS */
UV_NO_MORE_RESULTS, /* Returns NO_MORE_RESULTS */
UV_ComputeId, /* Returns the compute id of the row (in dbnextrow()) */
UV_SybperlVer, /* Returns Sybperl Version/Patchlevel */
UV_DBstatus, /* The value status value of the last dbnextrow() call */
};
/*
* User subroutines that we have implemented. I've found that I can do
* all the stuff I want to with this subset of DB-Library. Let me know
* if you implement further routines.
* The names are self-explanatory.
*/
static enum usersubs
{
US_dblogin, /* This also performs the first dbopen() */
US_dbopen,
US_dbclose,
US_dbcmd,
US_dbsqlexec,
US_dbresults,
US_dbnextrow,
US_dbcancel,
US_dbcanquery,
US_dbexit,
US_dbuse,
#ifdef HAS_CALLBACK
US_dberrhandle,
US_dbmsghandle,
#endif
US_dbstrcpy,
US_DBMORECMDS,
US_DBCMDROW,
US_DBROWS,
US_DBCOUNT,
US_DBCURCMD,
US_dbhasretstat,
US_dbretstatus,
#if defined(DBLIB42)
US_dbsafestr,
#endif
US_dbwritetext,
};
#ifndef MAX_DBPROCS
#define MAX_DBPROCS 25 /* Change this if you really want your perl script to talk to */
/* more than 25 dataserver connections at a time ...*/
#endif
static LOGINREC *login;
static DBPROCESS *dbproc[MAX_DBPROCS];
static int exitCalled = 0; /* Set to 1 if dbexit() has been called. */
static int ComputeId;
static int DBstatus; /* Set by dbnextrow() */
static int DBReturnAssoc; /* If true, dbnextrow returns an associative array */
/* Stack pointer for the error routines. This is set to the stack pointer
when entering into the sybase subroutines. Error and message
handling needs this. */
static int perl_sp;
/* Current error handler name. */
static char *err_handler_sub;
/* Current message handler subroutine name */
static char *msg_handler_sub;
/* Macro to access the stack. This is necessary since error handlers may
call perl routines and thus the stack may change. I hope most compilers
will optimize this reasonably. */
#define STACK(SP) (stack->ary_array + (SP))
static int usersub();
static int userset();
static int userval();
static int err_handler(), msg_handler();
int userinit()
{
init_sybase();
}
int
init_sybase()
{
struct ufuncs uf;
char *filename = "sybase.c";
if (dbinit() == FAIL) /* initialize dblibrary */
exit(ERREXIT);
/*
* Install the user-supplied error-handling and message-handling routines.
* They are defined at the bottom of this source file.
*/
dberrhandle(err_handler);
dbmsghandle(msg_handler);
if(MAX_DBPROCS > 25)
dbsetmaxprocs(MAX_DBPROCS);
uf.uf_set = userset;
uf.uf_val = userval;
#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
MAGICVAR("SUCCEED", UV_SUCCEED);
MAGICVAR("FAIL",UV_FAIL);
MAGICVAR("NO_MORE_ROWS", UV_NO_MORE_ROWS);
MAGICVAR("NO_MORE_RESULTS", UV_NO_MORE_RESULTS);
MAGICVAR("ComputeId", UV_ComputeId);
MAGICVAR("SybperlVer", UV_SybperlVer);
make_usub("dblogin", US_dblogin, usersub, filename);
make_usub("dbopen", US_dbopen, usersub, filename);
make_usub("dbclose", US_dbclose, usersub, filename);
make_usub("dbcmd", US_dbcmd, usersub, filename);
make_usub("dbsqlexec", US_dbsqlexec, usersub, filename);
make_usub("dbresults", US_dbresults, usersub, filename);
make_usub("dbnextrow", US_dbnextrow, usersub, filename);
make_usub("dbcancel", US_dbcancel, usersub, filename);
make_usub("dbcanquery", US_dbcanquery, usersub, filename);
make_usub("dbexit", US_dbexit, usersub, filename);
make_usub("dbuse", US_dbuse, usersub, filename);
#ifdef HAS_CALLBACK
make_usub("dberrhandle", US_dberrhandle, usersub, filename);
make_usub("dbmsghandle", US_dbmsghandle, usersub, filename);
#endif
make_usub("dbstrcpy", US_dbstrcpy, usersub, filename);
make_usub("DBCURCMD", US_DBCURCMD, usersub, filename);
make_usub("DBMORECMDS", US_DBMORECMDS, usersub, filename);
make_usub("DBCMDROW", US_DBCMDROW, usersub, filename);
make_usub("DBROWS", US_DBROWS, usersub, filename);
make_usub("DBCOUNT", US_DBCOUNT, usersub, filename);
make_usub("dbhasretstat", US_dbhasretstat, usersub, filename);
make_usub("dbretstatus", US_dbretstatus, usersub, filename);
#if defined(DBLIB42)
make_usub("dbsafestr", US_dbsafestr, usersub, filename);
#endif
make_usub("dbwritetext", US_dbwritetext, usersub, filename);
}
static int
usersub(ix, sp, items)
int ix;
register int sp;
register int items;
{
STR **st = stack->ary_array + sp;
ARRAY *ary = stack;
register STR *Str; /* used in str_get and str_gnum macros */
int inx = -1; /* Index into dbproc[] array. Passed as first parameter to nearly all &dbxxx() calls */
if(exitCalled)
fatal("&dbexit() has been called. Access to Sybase impossible.");
perl_sp = sp + items;
/*
* We're calling some dblib function, but dblogin has not been
* called. Two actions are possible: either fail the call, or call
* dblogin/dbopen with the default info. The second option is used
* to keep backwards compatibility with an older version of
* sybperl. A call to fatal(msg) is probably better.
*/
if(!login && (ix != US_dblogin) && (ix != US_dbmsghandle) && (ix != US_dberrhandle))
{ /* You can call &dbmsghandle/errhandle before calling &dblogin */
#ifdef OLD_SYBPERL
login = dblogin();
dbproc[0] = dbopen(login, NULL);
#else
fatal("&dblogin has not been called yet!");
#endif
}
switch (ix)
{
case US_dblogin:
if (items > 3)
fatal("Usage: &dblogin([user[,pwd[,server]]])");
else
{
int j = 0;
char *server = NULL, *user = NULL, *pwd = NULL;
if (!login)
login = dblogin();
switch(items)
{
case 3:
server = (char *)str_get(STACK(sp)[3]);
case 2:
if(STACK(sp)[2] != &str_undef)
{
pwd = (char *)str_get(STACK(sp)[2]);
if(pwd && strlen(pwd))
DBSETLPWD(login, pwd);
}
case 1:
if(STACK(sp)[1] != &str_undef)
{
user = (char *)str_get(STACK(sp)[1]);
if(user && strlen(user))
DBSETLUSER(login, user);
}
}
for(j = 0; j < MAX_DBPROCS; ++j)
if(dbproc[j] == NULL)
break;
if(j == MAX_DBPROCS)
fatal ("&dblogin: No more dbprocs available.");
if((dbproc[j] = dbopen(login, server)) == NULL)
j = -1;
str_numset(STACK(sp)[0], (double) j);
}
break;
case US_dbopen:
if (items > 1)
fatal("Usage: $dbproc = &dbopen([server]);");
else
{
int j;
char *server = NULL;
for(j = 0; j < MAX_DBPROCS; ++j)
if(dbproc[j] == NULL)
break;
if(j == MAX_DBPROCS)
fatal("&dbopen: No more dbprocs available.");
if(items == 1)
server = (char *)str_get(STACK(sp)[1]);
dbproc[j] = dbopen(login, server);
str_numset(STACK(sp)[0], (double) j);
}
break;
case US_dbclose:
if (items != 1)
fatal("Usage: $ret = &dbclose($dbproc);");
else
{
inx = getDbProc(STACK(sp)[1]);
dbclose(dbproc[inx]);
dbproc[inx] = (DBPROCESS *)NULL;
}
break;
case US_dbcancel:
if (items > 1)
fatal("Usage: &dbcancel($dbproc)");
else
{
int retval;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
retval = dbcancel(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbcanquery:
if (items > 1)
fatal("Usage: &dbcanquery($dbproc)");
else
{
int retval;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
retval = dbcanquery(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbexit:
if (items != 0)
fatal("Usage: &dbexit()");
else
{
dbexit(dbproc[0]);
exitCalled++;
str_numset(STACK(sp)[0], (double) 1);
}
break;
case US_dbuse:
if (items > 2)
fatal("Usage: &dbuse($dbproc, $database)");
else
{
int retval, off;
char str[255];
if(items == 2)
{
inx = getDbProc(STACK(sp)[1]);
off = 2;
}
else
inx = 0, off = 1;
strcpy(str, (char *)str_get(STACK(sp)[off]));
retval = dbuse(dbproc[inx], str);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbsqlexec:
if (items > 1)
fatal("Usage: &dbsqlexec($dbproc)");
else
{
int retval;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
retval = dbsqlexec(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbresults:
if (items > 1)
fatal("Usage: &dbresults($dbproc)");
else
{
int retval;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
retval = dbresults(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbcmd:
if (items > 2)
fatal("Usage: &dbcmd($dbproc, $str)");
else
{
int retval, off;
if(items == 2)
{
inx = getDbProc(STACK(sp)[1]);
off = 2;
}
else
inx = 0, off = 1;
retval = dbcmd(dbproc[inx], (char *)str_get(STACK(sp)[off]));
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbnextrow:
if (items > 2)
fatal("Usage: @arr = &dbnextrow([$dbproc [, $returnAssoc]])");
else
{
int retval;
char buff[1024], *p = NULL, *t;
BYTE *data;
int col, type, numcols;
int len;
int doAssoc = 0;
DBFLT8 tmp;
char *colname;
char cname[64];
inx = 0;
switch(items)
{
case 2:
doAssoc = (int)str_gnum(STACK(sp)[2]);
case 1:
inx = getDbProc(STACK(sp)[1]);
break;
}
--sp; /* otherwise you get an empty element at the beginning of the results array! */
DBstatus = retval = dbnextrow(dbproc[inx]);
if(retval == REG_ROW)
{
ComputeId = 0;
numcols = dbnumcols(dbproc[inx]);
}
else
{
ComputeId = retval;
numcols = dbnumalts(dbproc[inx], ComputeId);
}
for(col = 1, buff[0] = 0; col <= numcols; ++col)
{
colname = NULL;
if(!ComputeId)
{
type = dbcoltype(dbproc[inx], col);
len = dbdatlen(dbproc[inx],col);
data = (BYTE *)dbdata(dbproc[inx],col);
colname = dbcolname(dbproc[inx], col);
if(!colname || !colname[0])
{
sprintf(cname, "Col %d", col);
colname = cname;
}
}
else
{
int colid = dbaltcolid(dbproc[inx], ComputeId, col);
type = dbalttype(dbproc[inx], ComputeId, col);
len = dbadlen(dbproc[inx], ComputeId, col);
data = (BYTE *)dbadata(dbproc[inx], ComputeId, col);
if(colid > 0)
colname = dbcolname(dbproc[inx], colid);
if(!colname || !colname[0])
{
sprintf(cname, "Col %d", col);
colname = cname;
}
}
t = &buff[0];
if(!data && !len)
{
#if defined(NULL_IS_UNDEF)
t = &str_undef;
#else
strcpy(buff,"NULL");
#endif
}
else
{
switch(type)
{
case SYBCHAR:
strncpy(buff,data,len);
buff[len] = 0;
break;
case SYBTEXT:
New(902, p, len + 1, char);
strncpy(p, data, len);
p[len] = 0;
t = p;
break;
case SYBINT1:
case SYBBIT: /* a bit is at least a byte long... */
sprintf(buff,"%u",*(unsigned char *)data);
break;
case SYBINT2:
sprintf(buff,"%d",*(short *)data);
break;
case SYBINT4:
sprintf(buff,"%d",*(long *)data);
break;
case SYBFLT8:
sprintf(buff,"%.6f",*(double *)data);
break;
case SYBMONEY:
dbconvert(dbproc[inx], SYBMONEY, data, len, SYBFLT8, &tmp, -1);
sprintf(buff,"%.6f",tmp);
break;
case SYBDATETIME:
dbconvert(dbproc[inx], SYBDATETIME, data, len, SYBCHAR, buff, -1);
break;
case SYBBINARY:
dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
break;
#if defined(DBLIB42)
case SYBREAL:
sprintf(buff, "%.6f", *(float *)data);
break;
case SYBDATETIME4:
dbconvert(dbproc[inx], SYBDATETIME4, data, len, SYBCHAR, buff, -1);
break;
#endif
case SYBIMAGE:
fatal ("&dbnextrow: SYBIMAGE datatypes are not handled at the moment!");
break;
default:
/*
* WARNING!
*
* We convert unknown data types to SYBCHAR
* without checking to see if the resulting
* string will fit in the 'buff' variable.
* This isn't very pretty...
*/
dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
break;
}
}
if(doAssoc)
(void)astore(ary,++sp,str_2mortal(str_make(colname, 0)));
(void)astore(ary,++sp,str_2mortal(str_make(t, 0)));
/*
* If we've allocated some space to retrieve a
* SYBTEXT field, then free it now.
*/
if(t == p)
{
Safefree(p);
p = NULL;
}
}
}
break;
#ifdef HAS_CALLBACK
case US_dberrhandle:
if (items > 1)
fatal ("Usage: &dberrhandle($handler)");
else
{
char *old = err_handler_sub;
if (items == 1)
{
if (STACK (sp)[1] == &str_undef)
err_handler_sub = 0;
else
{
char *sub = (char *) str_get (STACK (sp)[1]);
New (902, err_handler_sub, strlen (sub) + 1, char);
strcpy (err_handler_sub, sub);
}
}
if (old)
{
STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
if (items == 1)
Safefree (old);
}
else
STACK (sp)[0] = &str_undef;
}
break;
case US_dbmsghandle:
if (items > 1)
fatal ("Usage: &dbmsghandle($handler)");
else
{
char *old = msg_handler_sub;
if (items == 1)
{
if (STACK (sp)[1] == &str_undef)
msg_handler_sub = 0;
else
{
char *sub = (char *) str_get (STACK (sp)[1]);
New (902, msg_handler_sub, strlen (sub) + 1, char);
strcpy (msg_handler_sub, sub);
}
}
if (old)
{
STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
if (items == 1)
Safefree (old);
}
else
STACK (sp)[0] = &str_undef;
}
break;
#endif /* HAS_CALLBACK */
case US_dbstrcpy:
if (items > 1)
fatal("Usage: $string = &dbstrcpy($dbproc)");
else
{
int retval, len;
char *buff;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx] && (len = dbstrlen(dbproc[inx])))
{
New(902, buff, len+1, char);
retval = dbstrcpy(dbproc[inx], 0, -1, buff);
str_set(STACK(sp)[0], buff);
Safefree(buff);
}
else
str_set(STACK(sp)[0], "");
}
break;
case US_DBCURCMD:
if (items > 1)
fatal("Usage: $num = &DBCURCMD($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = DBCURCMD(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_DBMORECMDS:
if (items > 1)
fatal("Usage: $rc = &DBMORECMDS($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = DBMORECMDS(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_DBCMDROW:
if (items > 1)
fatal("Usage: $rc = &DBCMDROW($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = DBCMDROW(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_DBROWS:
if (items > 1)
fatal("Usage: $rc = &DBROWS($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = DBROWS(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_DBCOUNT:
if (items > 1)
fatal("Usage: $ret = &DBCOUNT($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = DBCOUNT(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbhasretstat:
if (items > 1)
fatal("Usage: $rc = &dbhasretstat($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = dbhasretstat(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
case US_dbretstatus:
if (items > 1)
fatal("Usage: $rc = &dbretstatus($dbproc)");
else
{
int retval = 0;
if(items)
inx = getDbProc(STACK(sp)[1]);
else
inx = 0;
if(dbproc[inx])
retval = dbretstatus(dbproc[inx]);
str_numset(STACK(sp)[0], (double) retval);
}
break;
#if defined(DBLIB42)
case US_dbsafestr:
if (items > 3 || items != 2)
fatal ("Usage: $string = &dbsafestr($dbproc,$instring[,$quote_char])");
else
{
int retval, len, quote;
char *buff, *instr;
inx = getDbProc (STACK (sp)[1]);
instr = (char *) str_get (STACK (sp)[2]);
if (items != 3)
quote = DBBOTH;
else
{
char *quote_char = (char *) str_get (STACK (sp)[3]);
if (*quote_char == '\"')
quote = DBDOUBLE;
else if (*quote_char == '\'')
quote = DBSINGLE;
else
{ /* invalid */
str_set (STACK (sp)[0], "");
break;
}
}
if (dbproc[inx] && (len = strlen (instr)))
{
/* twice as much space needed worst case */
New (902, buff, len * 2 + 1, char);
retval = dbsafestr (dbproc[inx], instr, -1, buff, -1, quote);
str_set (STACK (sp)[0], buff);
Safefree (buff);
}
}
break;
#endif
case US_dbwritetext:
if (items != 5)
fatal ("Usage: dbwritetext($dbproc1,$column,$dbproc2,$col,$text");
else
{
int inx2, wcolnum;
char *wcolname, *wtext;
int ret;
inx = getDbProc(STACK(sp)[1]);
wcolname = str_get(STACK(sp)[2]);
inx2 = getDbProc(STACK(sp)[3]);
wcolnum = (int)str_gnum(STACK(sp)[4]);
wtext = str_get(STACK(sp)[5]);
ret = dbwritetext (dbproc[inx], wcolname, dbtxptr(dbproc[inx2], wcolnum),
DBTXPLEN, dbtxtimestamp(dbproc[inx2], wcolnum), 0,
strlen(wtext), wtext);
str_numset(STACK(sp)[0], (double) ret);
}
break;
default:
fatal("Unimplemented user-defined subroutine");
}
return sp;
}
/*
* Return the value of a userdefined variable. These variables are all
* READ-ONLY in Perl.
*/
static int
userval(ix, str)
int ix;
STR *str;
{
char buff[24];
switch (ix)
{
case UV_SUCCEED:
str_numset(str, (double)SUCCEED);
break;
case UV_FAIL:
str_numset(str, (double)FAIL);
break;
case UV_NO_MORE_ROWS:
str_numset(str, (double)NO_MORE_ROWS);
break;
case UV_NO_MORE_RESULTS:
str_numset(str, (double)NO_MORE_RESULTS);
break;
case UV_ComputeId:
str_numset(str, (double)ComputeId);
break;
case UV_SybperlVer:
sprintf(buff, "%d.%3.3d", VERSION, PATCHLEVEL);
str_set(str, buff);
break;
case UV_DBstatus:
str_numset(str, (double)DBstatus);
break;
}
return 0;
}
static int
userset(ix, str)
int ix;
STR *str;
{
#if defined(USERVAL_SET_FATAL)
fatal("sybperl: trying to write to a read-only variable.");
#else
return 0;
#endif
}
/*ARGSUSED*/
static int err_handler(db, severity, dberr, oserr, dberrstring, oserrstr)
DBPROCESS *db;
int severity;
int dberr;
int oserr;
char *dberrstring;
char *oserrstr;
{
#ifdef HAS_CALLBACK
/* If we have error handler subroutine, use it. */
if (err_handler_sub)
{
int sp = perl_sp;
int j;
for(j = 0; j < MAX_DBPROCS; ++j)
if(db == dbproc[j])
break;
if(j == MAX_DBPROCS)
j = 0;
/* Reserve spot for return value. */
astore (stack, ++ sp, Nullstr);
/* Set up arguments. */
astore (stack, ++ sp,
str_2mortal (str_nmake ((double) j)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) dberr)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) oserr)));
if (dberrstring && *dberrstring)
astore (stack, ++ sp, str_2mortal (str_make (dberrstring, 0)));
else
astore (stack, ++ sp, &str_undef);
if (oserrstr && *oserrstr)
astore (stack, ++ sp, str_2mortal (str_make (oserrstr, 0)));
else
astore (stack, ++ sp, &str_undef);
/* Call it. */
sp = callback (err_handler_sub, sp, 0, 1, 6);
/* Return whatever it returned. */
return (int) str_gnum (STACK (sp)[0]);
}
#endif /* HAS_CALLBACK */
if ((db == NULL) || (DBDEAD(db)))
return(INT_EXIT);
else
{
fprintf(stderr,"DB-Library error:\n\t%s\n", dberrstring);
if (oserr != DBNOERR)
fprintf(stderr,"Operating-system error:\n\t%s\n", oserrstr);
return(INT_CANCEL);
}
}
/*ARGSUSED*/
static int msg_handler(db, msgno, msgstate, severity, msgtext, srvname, procname, line)
DBPROCESS *db;
DBINT msgno;
int msgstate;
int severity;
char *msgtext;
char *srvname;
char *procname;
DBUSMALLINT line;
{
#ifdef HAS_CALLBACK
/* If we have message handler subroutine, use it. */
if (msg_handler_sub)
{
int sp = perl_sp;
int j;
for(j = 0; j < MAX_DBPROCS; ++j)
if(db == dbproc[j])
break;
if(j == MAX_DBPROCS)
j = 0;
/* Reserve spot for return value. */
astore (stack, ++ sp, Nullstr);
/* Set up arguments. */
astore (stack, ++ sp,
str_2mortal (str_nmake ((double) j)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgno)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgstate)));
astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
if (msgtext && *msgtext)
astore (stack, ++ sp, str_2mortal (str_make (msgtext, 0)));
else
astore (stack, ++ sp, &str_undef);
if (srvname && *srvname)
astore (stack, ++ sp, str_2mortal (str_make (srvname, 0)));
else
astore (stack, ++ sp, &str_undef);
if (procname && *procname)
astore (stack, ++ sp, str_2mortal (str_make (procname, 0)));
else
astore (stack, ++ sp, &str_undef);
astore (stack, ++ sp, str_2mortal (str_nmake ((double) line)));
/* Call it. */
sp = callback (msg_handler_sub, sp, 0, 1, 8);
/* Return whatever it returned. */
return (int) str_gnum (STACK (sp)[0]);
}
#endif /* HAS_CALLBACK */
#ifdef OLD_SYBPERL
if(!severity)
return 0;
#endif
fprintf (stderr,"Msg %ld, Level %d, State %d\n",
msgno, severity, msgstate);
if (strlen(srvname) > 0)
fprintf (stderr,"Server '%s', ", srvname);
if (strlen(procname) > 0)
fprintf (stderr,"Procedure '%s', ", procname);
if (line > 0)
fprintf (stderr,"Line %d", line);
fprintf(stderr,"\n\t%s\n", msgtext);
return(0);
}
/*
* Get the index into the dbproc[] array from a Perl STR datatype.
* Check that the index is reasonably valid...
*/
int getDbProc(Str)
STR *Str;
{
int ix = (int)str_gnum(Str);
if(ix < 0 || ix >= MAX_DBPROCS)
fatal("$dbproc parameter is out of range.");
if(dbproc[ix] == NULL || DBDEAD(dbproc[ix]))
fatal("$dbproc parameter is NULL or the connection to the server has been closed.");
return ix;
}
#ifdef HAS_CALLBACK
/* Taken from Perl 4.018 usub/usersub.c. mp. */
/* Be sure to refetch the stack pointer after calling these routines. */
int
callback(subname, sp, gimme, hasargs, numargs)
char *subname;
int sp; /* stack pointer after args are pushed */
int gimme; /* called in array or scalar context */
int hasargs; /* whether to create a @_ array for routine */
int numargs; /* how many args are pushed on the stack */
{
static ARG myarg[3]; /* fake syntax tree node */
int arglast[3];
arglast[2] = sp;
sp -= numargs;
arglast[1] = sp--;
arglast[0] = sp;
if (!myarg[0].arg_ptr.arg_str)
myarg[0].arg_ptr.arg_str = str_make("",0);
myarg[1].arg_type = A_WORD;
myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE);
myarg[2].arg_type = hasargs ? A_EXPR : A_NULL;
return do_subr(myarg, gimme, arglast);
}
#endif /* HAS_CALLBACK */
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.