Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/misc/volume39/sybperl/part02

Text File | 1993-09-25 | 61.4 KB | 2,359 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Michael Peppler)
Subject: v39i102:  sybperl - Sybase DB-library extensions to Perl, v1.8, Part02/03
Message-ID: <[e-mail]>
X-Md4-Signature: 8f6c6b86ed41cf7a499641a9deccac21
Sender: [e-mail] (Kent Landfield)
Organization: Sterling Software
Date: Sat, 25 Sep 1993 18:26:43 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Michael Peppler)
Posting-number: Volume 39, Issue 102
Archive-name: sybperl/part02
Environment: UNIX, Perl, Sybase
Supersedes: sybperl: Volume 37, Issue 33-34

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then feed it
# into a shell via "sh file" or similar.  To overwrite existing files,
# type "sh file -c".
# Contents:  eg/dbschema.pl eg/report.pl sybperl.1 sybperl.c.B
# Wrapped by kent@sparky on Sat Sep 25 13:16:00 1993
PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH
echo If this archive is complete, you will see the following message:
echo '          "shar: End of archive 2 (of 3)."'
if test -f 'eg/dbschema.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/dbschema.pl'\"
else
  echo shar: Extracting \"'eg/dbschema.pl'\" \(9359 characters\)
  sed "s/^X//" >'eg/dbschema.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X#
X#    @(#)dbschema.pl    1.5    9/10/93
X#
X#
X#    dbschema.pl    A script to extract a database structure from
X#            a Sybase database
X#
X#    Written by:    Michael Peppler ([e-mail])
X#    Last Modified:  24 June 1992
X#
X#    Usage:        dbschema.pl -d database -o script.name -t pattern -v
X#                where   database is self-explanatory (default: master)
X#                                   script.name is the output file (default: script.isql)
X#                                   pattern is the pattern of object names (in sysobjects)
X#                                           that we will look at (default: %)
X#
X#                -v turns on a verbose switch.
X#
X
X
Xrequire 'sybperl.pl';
Xrequire 'getopts.pl';
Xrequire 'ctime.pl';
X
X@nul = ('not null','null');
X
Xselect(STDOUT); $| = 1;        # make unbuffered
X
Xdo Getopts('d:t:o:v');
X
X$opt_d = 'master' unless $opt_d;
X$opt_o = 'script.isql' unless $opt_o;
X$opt_t = '%' unless $opt_t;
X
Xopen(SCRIPT, "> $opt_o") || die "Can't open $opt_o: $!\n";
Xopen(LOG, "> $opt_o.log") || die "Can't open $opt_o.log: $!\n";
X
X#
X# NOTE: We login to Sybase with the default (Unix) user id.
X#       We should probably login as 'SA', and get the passwd
X#       from the user at run time.
X#
X$dbproc = &dblogin;
X&dbuse($dbproc, $opt_d);
X
Xchop($date = &ctime(time));
X
X
Xprint "dbschema.pl on Database $opt_d\n";
X
Xprint LOG "Error log from dbschema.pl on Database $opt_d on $date\n\n";
Xprint LOG "The following objects cannot be reliably created from the script in $opt_o.
XPlease correct the script to remove any inconsistencies.\n\n";
X
Xprint SCRIPT
X    "/* This Isql script was generated by dbschema.pl on $date.
X** The indexes need to be checked: column names & index names
X** might be truncated!
X*/\n";
X
Xprint SCRIPT "\nuse $opt_d\ngo\n"; # Change to the appropriate database
X
X
X# first, Add the appropriate user data types:
X#
X
Xprint "Add user-defined data types...";
Xprint SCRIPT
X    "/* Add user-defined data types: */\n\n";
X
X&dbcmd($dbproc, "select s.length, s.name, st.name,\n");
X&dbcmd($dbproc, "       object_name(s.tdefault),\n");
X&dbcmd($dbproc, "       object_name(s.domain)\n");
X&dbcmd($dbproc, "from   $opt_d.dbo.systypes s, $opt_d.dbo.systypes st\n");
X&dbcmd($dbproc, "where  st.type = s.type\n");
X&dbcmd($dbproc, "and s.usertype > 100 and st.usertype < 100 and st.usertype != 18\n");
X&dbsqlexec($dbproc);
X&dbresults($dbproc);
X
X
Xwhile((@dat = &dbnextrow($dbproc)))
X{
X    print SCRIPT "sp_addtype $dat[1],";
X    if ($dat[2] =~ /char|binary/)
X    {
X        print SCRIPT "'$dat[2]($dat[0])'";
X    }
X    else
X    {
X        print SCRIPT "$dat[2]";
X    }
X    print SCRIPT "\ngo\n";
X                # Now remeber the default & rule for later.
X    $urule{$dat[1]} = $dat[4] if $dat[4] !~ /NULL/;
X    $udflt{$dat[1]} = $dat[3] if $dat[3] !~ /NULL/;
X}
X
Xprint "Done\n";
X
Xprint "Create rules...";
Xprint SCRIPT
X    "\n/* Now we add the rules... */\n\n";
X
X&getObj('Rule', 'R');
Xprint "Done\n";
X
Xprint "Create defaults...";
Xprint SCRIPT
X    "\n/* Now we add the defaults... */\n\n";
X
X&getObj('Default', 'D');
Xprint "Done\n";
X
Xprint "Bind rules & defaults to user data types...";
Xprint SCRIPT "/* Bind rules & defaults to user data types... */\n\n";
X
Xwhile(($dat, $dflt)=each(%udflt))
X{
X    print SCRIPT "sp_bindefault $dflt, $dat\ngo\n";
X}
Xwhile(($dat, $rule) = each(%urule))
X{
X    print SCRIPT "sp_bindrule $rule, $dat\ngo\n";
X}
Xprint "Done\n";
X
Xprint "Create Tables & Indices...";
Xprint "\n" if $opt_v;
X
X&dbcmd($dbproc, "select o.name,u.name, o.id\n");
X&dbcmd($dbproc, "from $opt_d.dbo.sysobjects o, $opt_d.dbo.sysusers u\n");
X&dbcmd($dbproc, "where o.type = 'U' and o.name like '$opt_t' and u.uid = o.uid\n");
X&dbcmd($dbproc, "order by o.name\n");
X
X&dbsqlexec($dbproc);
X&dbresults($dbproc);
X
Xwhile((@dat = &dbnextrow($dbproc)))
X{
X    $_ = join('@', @dat);    # join the data together on a line
X    push(@tables,$_);        # and save it in a list
X}
X
X
Xforeach (@tables)        # For each line in the list
X{
X    @tab = split(/@/, $_);
X
X    print "Creating table $tab[0], owner $tab[1]\n" if $opt_v;
X
X    print SCRIPT "/* Start of description of table $tab[1].$tab[0] */\n\n";
X
X    &dbcmd($dbproc, "select Column_name = c.name, \n");
X    &dbcmd($dbproc, "       Type = t.name, \n");
X    &dbcmd($dbproc, "       Length = c.length, \n");
X    &dbcmd($dbproc, "       Nulls = convert(bit, (c.status & 8)),\n");
X    &dbcmd($dbproc, "       Default_name = object_name(c.cdefault),\n");
X    &dbcmd($dbproc, "       Rule_name = object_name(c.domain)\n");
X    &dbcmd($dbproc, "from   $opt_d.dbo.syscolumns c, $opt_d.dbo.systypes t\n");
X    &dbcmd($dbproc, "where  c.id = $tab[2]\n");
X    &dbcmd($dbproc, "and    c.usertype *= t.usertype\n");
X
X    &dbsqlexec($dbproc);
X    &dbresults($dbproc);
X
X    undef(%rule);
X    undef(%dflt);
X
X    print SCRIPT "\n\nCREATE TABLE $opt_d.$tab[1].$tab[0]\n (";
X    $first = 1;
X    while((@field = &dbnextrow($dbproc)))
X    {
X        print SCRIPT ",\n" if !$first;        # add a , and a \n if not first field in table
X
X        print SCRIPT "\t$field[0] \t$field[1]";
X        print SCRIPT "($field[2])" if $field[1] =~ /char|bin/;
X        print SCRIPT " $nul[$field[3]]";
X
X    $rule{"$tab[0].$field[0]"} = $field[5] if ($field[5] !~ /NULL/ && $urule{$field[1]} ne $field[5]);
X    $dflt{"$tab[0].$field[0]"} = $field[4] if ($field[4] !~ /NULL/ && $udflt{$field[1]} ne $field[4]);;
X        $first = 0 if $first;
X
X    }
X    print SCRIPT " )\n";
X
X# now get the indexes...
X#
X
X    print "Indexes for table $tab[1].$tab[0]\n" if $opt_v;
X
X    &dbcmd($dbproc, "sp_helpindex '$tab[1].$tab[0]'\n");
X
X    &dbsqlexec($dbproc);
X    &dbresults($dbproc);
X
X    while((@field = &dbnextrow($dbproc)))
X    {
X        print SCRIPT "\nCREATE ";
X        print SCRIPT "unique " if $field[1] =~ /unique/;
X        print SCRIPT "clustered " if $field[1] =~ /^clust/;
X        print SCRIPT "index $field[0]\n";
X        @col = split(/,/,$field[2]);
X        print SCRIPT "on $opt_d.$tab[1].$tab[0] (";
X        $first = 1;
X        foreach (@col)
X        {
X            print SCRIPT ", " if !$first;
X            $first = 0;
X            print SCRIPT "$_";
X        }
X        print SCRIPT ")\n";
X    }
X
X    &getPerms("$tab[1].$tab[0]");
X
X    print SCRIPT "go\n";
X
X    print "Bind rules & defaults to columns...\n" if $opt_v;
X    print SCRIPT "/* Bind rules & defaults to columns... */\n\n";
X
X    if($tab[1] ne 'dbo' && (keys(%dflt) || keys(%rules)))
X    {
X    print SCRIPT "/* The owner of the table is $tab[1].
X** I can't bind the rules/defaults to a table of which I am not the owner.
X** The procedures below will have to be run manualy by user $tab[1].
X*/";
X    print LOG "Defaults/Rules for $tab[1].$tab[0] could not be bound\n";
X    }
X
X    while(($dat, $dflt)=each(%dflt))
X    {
X    print SCRIPT "/* " if $tab[1] ne 'dbo';
X    print SCRIPT "sp_bindefault $dflt, '$dat'";
X    if($tab[1] ne 'dbo')
X    {
X        print SCRIPT " */\n";
X    }
X    else
X    {
X        print SCRIPT "\ngo\n";
X    }
X    }
X    while(($dat, $rule) = each(%rule))
X    {
X    print SCRIPT "/* " if $tab[1] ne 'dbo';
X    print SCRIPT "sp_bindrule $rule, '$dat'";
X    if($tab[1] ne 'dbo')
X    {
X        print SCRIPT " */\n";
X    }
X    else
X    {
X        print SCRIPT "\ngo\n";
X    }
X    }
X    print SCRIPT "\n/* End of description of table $tab[1].$tab[0] */\n";
X
X}
X
Xprint "Done\n";
X
X
X#
X# Now create any views that might exist
X#
X
Xprint "Create views...";
Xprint SCRIPT
X    "\n/* Now we add the views... */\n\n";
X
X&getObj('View', 'V');
X
Xprint "Done\n";
X
X#
X# Now create any stored procs that might exist
X#
X
Xprint "Create stored procs...";
Xprint SCRIPT
X    "\n/* Now we add the stored procedures... */\n\n";
X&getObj('Stored Proc', 'P');
X
Xprint "Done\n";
X
X#
X# Now create the triggers
X#
X
Xprint "Create triggers...";
Xprint SCRIPT
X    "\n/* Now we add the triggers... */\n\n";
X
X&getObj('Trigger', 'TR');
X
X
Xprint "Done\n";
X
Xprint "\nLooks like I'm all done!\n";
Xclose(SCRIPT);
Xclose(LOG);
X
X&dbexit;
X
X
Xsub getPerms
X{
X    local($obj) = $_[0];
X    local($ret, @dat, $act, $cnt);
X
X    &dbcmd($dbproc, "sp_helprotect '$obj'\n");
X    &dbsqlexec;
X
X    $cnt = 0;
X    while(($ret = &dbresults) != $NO_MORE_RESULTS && $ret != $FAIL)
X    {
X    while(@dat = &dbnextrow)
X    {
X        $act = 'to';
X        $act = 'from' if $dat[0] =~ /Revoke/;
X        print SCRIPT "$dat[0] $dat[1] on $obj $act $dat[2]\n";
X        ++$cnt;
X    }
X    }
X    $cnt;
X}
X
Xsub getObj
X{
X    local($objname, $obj) = @_;
X    local(@dat, @items, @vi, $found);
X
X    &dbcmd($dbproc, "select o.name, u.name, o.id\n");
X    &dbcmd($dbproc, "from $opt_d.dbo.sysobjects o, $opt_d.dbo.sysusers u\n");
X    &dbcmd($dbproc, "where o.type = '$obj' and o.name like '$opt_t' and u.uid = o.uid\n");
X    &dbcmd($dbproc, "order by o.name\n");
X
X    &dbsqlexec($dbproc);
X    &dbresults($dbproc);
X
X    while((@dat = &dbnextrow($dbproc)))
X    {                #
X    $_ = join('@', @dat);    # join the data together on a line
X    push(@items, $_);    # and save it in a list
X    }
X
X    foreach (@items)
X    {
X    @vi = split(/@/, $_);
X    $found = 0;
X
X    &dbcmd($dbproc, "select text from syscomments where id = $vi[2]");
X    &dbsqlexec;
X    &dbresults;
X
X    print SCRIPT
X        "/* $objname $vi[0], owner $vi[1] */\n";
X
X    while(($text) = &dbnextrow)
X    {
X        if(!$found && $vi[1] ne 'dbo')
X        {
X        ++$found if($text =~ /$vi[1]/);
X        }
X        print SCRIPT $text;
X    }
X    print SCRIPT "\ngo\n";
X    if(!$found && $vi[1] ne 'dbo')
X    {
X        print "**Warning**\n$objname $vi[0] has owner $vi[1]\nbut this is not mentioned in the CREATE PROC statement!!\n";
X        print LOG "$objname $vi[0] (owner $vi[1])\n";
X    }
X    }
X}
X
X
END_OF_FILE
  if test 9359 -ne `wc -c <'eg/dbschema.pl'`; then
    echo shar: \"'eg/dbschema.pl'\" unpacked with wrong size!
  fi
  # end of 'eg/dbschema.pl'
fi
if test -f 'eg/report.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/report.pl'\"
else
  echo shar: Extracting \"'eg/report.pl'\" \(753 characters\)
  sed "s/^X//" >'eg/report.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
X#
X#    @(#)report.pl    1.1    6/24/92
X#
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
X$d = &dblogin;
X
X#
X# define the format
X#
Xformat top=
X             PASSWORD FILE
XLogin      Uid Group      Shell                   Home directory
X-------- ----- ---------- ----------------------- ----------------------
X.
Xformat stdout=
X@<<<<<<< @>>>> @<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<
X$n,      $u,   $gn,       $s,                     $d
X.
X
X#
X# See if everything is there.
X#
X@results = &sql($d, '
X    select username, uid, isnull(groupname,convert(char,p.gid)), shell, home
X    from password p, groups g
X    where    p.gid *= g.gid
X    order by uid
X    ');
Xforeach $x (@results) {
X    ($n,$u,$gn,$s,$d) = split("~",$x);
X    write;
X}
X
END_OF_FILE
  if test 753 -ne `wc -c <'eg/report.pl'`; then
    echo shar: \"'eg/report.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/report.pl'
  # end of 'eg/report.pl'
fi
if test -f 'sybperl.1' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'sybperl.1'\"
else
  echo shar: Extracting \"'sybperl.1'\" \(10929 characters\)
  sed "s/^X//" >'sybperl.1' <<'END_OF_FILE'
X.\".po 4
X.\"    @(#)sybperl.1    1.4    9/7/93
X.TH SYBPERL 1 "31 Aug 1993"
X.ad
X.nh
X.SH NAME
Xsybperl \- Perl access to Sybase databases
X.SH SYNOPSIS
X.nf
X$dbproc  = &dblogin([$user[, $pwd[, $server]]])
X$dbproc1 = &dbopen([$server])
X       &dbclose($dbproc)
X$ret     = &dbcmd($dbproc, $sql_cmd)
X$ret     = &dbsqlexec($dbproc)
X$ret     = &dbresults($dbproc)
X@data    = &dbnextrow($dbproc [, $doAssoc])
X@data    = &dbretdata($dbproc [, $doAssoc])
X$ret     = &dbuse($dbproc, $database)
X$ret     = &dbcancel($dbproc)
X$ret     = &dbcanquery($dbproc)
X$ret     = &dbexit($dbproc)
X$string  = &dbstrcpy($dbproc)
X$string  = &dbsafestr($dbproc,$instring[,$quote_char])
X$status  = &dbwritetext($dbproc_1, $col_name, $dbproc_2, $select_col, $text)
X$count   = &dbnumcol($dbproc)
X$type    = &dbcoltype($dbproc, $colid)
X$name    = &dbcolname($dbproc, $colid)
X$len     = &dbcollen($dbproc, $colid)
X$status  = &dbhasretstat($dbproc)
X$status  = &dbretstatus($dbproc)
X$ret     = &dberrhandle($handler)
X$ret     = &dbmsghandle($handler)
X$ret     = &DBCURCMD($dbproc)
X$status  = &DBMORECMD($dbproc)
X$status  = &DBCMDROW($dbproc)
X$status  = $DBROWS($dbproc)
X$ret     = $DBCOUNT($dbproc)
X($status, $sum)    = &dbmny4add($dbproc,$m1,$m2)
X$status        = &dbmny4cmp($dbproc,$m1,$m2)
X($status, $quotient)    = &dbmny4divide($dbproc,$m1,$m2)
X($status, $dest)    = &dbmny4minus($dbproc,$source)
X($status, $product)    = &dbmny4mul($dbproc,$m1,$m2)
X($status, $difference)    = &dbmny4sub($dbproc,$m1,$m2)
X($status, $ret)    = &dbmny4zero($dbproc)
X($status, $sum)    = &dbmnyadd($dbproc,$m1,$m2)
X$status        = &dbmnycmp($dbproc,$m1,$m2)
X($status, $ret)    = &dbmnydec($dbproc, $m1)
X($status, $quotient)    = &dbmnydivide($dbproc,$m1,$m2)
X($status, $ret, $remainder) = &dbmnydown($dbproc,$m1, $divisor)
X($status, $ret)    = &dbmnyinc($dbproc, $m1)
X($status, $ret, $remain)    = &dbmnyinit($dbproc, $m1,$trim)
X($status, $ret)        = &dbmnymaxneg($dbproc)
X($status, $ret)        = &dbmnymaxpos($dbproc)
X($status, $dest) = &dbmnyminus($dbproc,$source)
X($status, $product)    = &dbmnymul($dbproc,$m1,$m2)
X($status, $m1, $digits, $remain)    = &dbmnyndigit($dbproc,$m1)
X($status, $ret)        = &dbmnyscale($dbproc,$m1,$multiplier,
X                $addend)
X($status, $difference)    = &dbmnysub($dbproc,$m1,$m2)
X($status, $ret)    = &dbmnyzero($dbproc)
X
X$status    = &BCP_SETL($state)
X$status = &bcp_getl;
X$status = &bcp_init($dbproc, $tblname, $hostfile, $errfile, $dir)
X$status = &bcp_meminit($dbproc, $numcols)
X$status = &bcp_sendrow($dbproc, $col1, $col2, ...)
X$status = &bcp_batch($dbproc)
X$status = &bcp_done($dbproc)
X$status = &bcp_control($dbproc, $field, $value)
X$status = &bcp_columns($dbproc, $host_columns)
X$status = &bcp_colfmt($dbproc, $host_column, $host_type,
X              $host_prefixlen, $host_collen, $host_term,
X              $host_termlen, $table_colnum)
X($status, $rows_copied) = &bcp_exec($dbproc)
X$status = &bcp_readfmt($dbproc, $filename)
X$status = &bcp_writefmt($dbproc, $filename)
X
X$SUCCEED        $MORE_ROWS            $EXCEPTION    $EXPROGRAM
X$FAIL            $REG_ROW            $EXSIGNAL    $EXSERVER
X$NO_MORE_ROWS    $BUF_FULL            $EXINFO    $EXCOMM
X$NO_MORE_RESULTS    $NO_MORE_PARAMS        $EXDBLIB    $EXTIME
X$ComputeId        $DBSAVE            $EXFORMS    $EXFATAL
X$DBstatus        $DBNOSAVE            $EXUSER
X$SybperlVer        $DBNOERR            $EXLOOKUP
X$STDEXIT        $DB_PASSTHRU_MORE    $EXSCREENIO
X$ERREXIT        $DB_PASSTHRU_EOM        $EXCLIPBOARD
X$INT_EXIT        $DBNOPROC            $EXNONFATAL
X$INT_CONTINUE                    $EXCONVERSION
X$INT_CANCEL                        $EXRESOURCE
X$INT_TIMEOUT                        $EXCONSISTENCY
X$DB_IN        $DB_OUT
X$BCPMAXERRS    $BCPFIRST    $BCPLAST    $BCPBATCH
X$DBTRUE        $DBFALSE
X$SybPackageBug
X$dbNullIsUndef    $dbKeepNumeric    $dbBin0x
X.fi
X.SH DESCRIPTION
X\fBSybperl\fP is a version of \fIPerl\fP which has been extended (via
Xthe \fIusersubs\fP feature) to allow access to \fISybase\fP databases.
X
X\fBSybperl\fP maps a subset of the \fISybase
XDB-Library\fP API to \fIPerl\fP. The usage of these functions is the same
Xas in \fIDB-Library\fP, unless specifically noted.
X
X\fBDifferences with DB-Library:\fP
X
X\fB&dblogin\fP takes 3 optional arguements (the userid, the
Xpassword and the server to connect to). These default to the Unix
Xuserid, the null password and the default server (from the DSQUERY
Xenvironment variable).
X
X\fB&dblogin\fP returns a \fBDBPROCESS\fP, not a \fBLOGINREC\fP. This
Xsimplifies the call to open a connection to a Sybase dataserver
Xsomewhat. If the login fails for any reason \fB&dblogin\fP returns -1.
X\fB&dblogin\fP can be called multiple times to login to different
Xservers, or to login as several users simultaneously.
X
XFurther \fBDBPROCESSes\fP can be opened using
X\fB&dbopen([$server])\fP, using the login information from the
Xlast call to \fB&dblogin()\fP. The number of simultaneous DBPROCESSes
Xis limited to 25 (This can be changed by altering a #define in sybperl.c).
X
XThe \fB$dbproc\fP parameter used by most subroutines is optional,
Xand defaults to the DBPROCESS returned
Xby the first call to \fB&dblogin\fP (exceptions: \fB&dbsafestr()\fP,
X\fB&dbwritetext()\fP and \fB&bcp_sendrow()\fP require explicit \fB$dbproc\fP parameters.)
X
X\fB&dbnextrow\fP returns an array of formatted data, based on the
Xdatatype of the corresponding columns. \fB&dbnextrow\fP sets the
Xvariable \fB$ComputeId\fP when the result row is a computed row (the
Xresult of a \fIcompute by\fP clause). If the optional \fB$doAssoc\fP
Xparameter is non-zero \fB&dbnextrow\fP returns an
Xassociative array keyed on the column name of each returned field. If
Xthe column name is null (as for example in the case of an aggregate),
Xthen \fB&dbnextrow\fP assigns a column name based on the column number.
X
X\fB&dbretdata\fP returns an array of the parameters
Xdeclared as \fBOUTput\fP in an \fBEXEC\fP stored procedure statement.
XIf the ooptional \fB$doAssoc\fP parameter is non-zero, then an
Xassociative array keyed on the name of the parameters is returned
X(again, if the parameters are unnamed, the key is based on the
Xparamter number). A single call will
Xreturn all the parameters for the last \fBEXEC\fP statement.
X
X\fB&dbsafestr\fP takes a string literal ' or " as the third [optional] argument
Xand means \fBDBSINGLE\fP or \fBDBDOUBLE\fP, respectively.
XOmission of the third argument means \fBDBBOTH\fP.
X
XIn order to simplify its use somewhat, the calling sequence of
X\fB&dbwritetext\fP has been changed. \fI$select_proc\fP and
X\fI$select_col\fP are the dbproc and column number of a currently
Xactive query. Logging is always off.
X
XNote that all DBMONEY routines which in the C version take pointers to
Xarguments (in order to return values) return these values in an array
Xinstead (eg: status = dbmnyadd(dbproc, m1, m2, result) becomes
X($status, $result) = &dbmnyadd($dbproc, $m1, $m2))
X
XCopying data from program variables into a Sybase table using BCP has
Xbeen implemented in a slightly different manner. Instead of using
Xbcp_bind(), you need to call &bcp_meminit() to determine the number of
Xcolumns that will be sent to the server, and the call &bcp_sendrow()
Xwith the data for each row (see \fBEXAMPLES\fP, below). Passing
X\fBundef\fP as one of the data
Xvalues will result in a \fBNULL\fP value being sent to the server for
Xthat column.
X
X\fBVariables:\fP
X
X\fBSybperl\fP defines a number of Read-Only variables, and three
XRead-Write variables. Most of the variables correspond to #define's in
Xthe \fIOpenClient\fP include files (see the Sybase documentation for
Xmore information).
X
XThe \fBSybperl\fP specific variables are:
X
X\fB$ComputeId\fP \- Set by \fB&dbnextrow\fP when it processes a
X\fIcompute row\fP as opposed to a normal results row.
X.br
X\fB$DBstatus\fP \- The status returned by the last call to
X\fBdbnextrow()\fP.
X.br
X\fB$SybperlVer\fP \- The Sybperl release version.
X.br
X\fB$SybPackageBug\fP \- Set to TRUE if \fBSybperl\fP was compiled with
Xthe option to circumvent a bug in \fBPerl's\fP implementation of
Xpackages. This variable is undefined otherwise.
X.br
X\fB$dbNullIsUndef\fP \- This variable controls whether NULL values
Xreturned from a query will be returned as the string '\fINULL\fP' (the
Xdefault) or as the \fBPerl\fP \fIundef\fP value.
X.br
X\fB$dbKeepNumeric\fP \- This variable controls whether numeric
Xdatatypes returned by queries are converted to strings (the default)
Xor left in native format.
X.br
X\fB$dbBin0x\fP \- This variable controls whether variables of type
X\fBSYBBINARY\fP are returned with a leading \fB0x\fP or not (the
Xdefault).
X
XThese last three variables are all boolean.
X
X.SH "UNIMPLEMENTED FEATURES"
X
X\fB&dbfcmd\fP is not implemented, but can be emulated by using
X\fIsprintf\fP as in \fI&dbcmd($dbproc, sprintf("%d", $num_val))\;\fP
X
X.SH EXAMPLES
X
XUsing &dbretdata():
X
X.nf
X    &dbcmd($dbproc, "declare @data int\n");
X    &dbcmd($dbproc, "exec my_stored_proc @data out\n");
X    &dbsqlexec($dbproc);
X    &dbresults($dbproc);
X    while(&dbnextrow($dbproc))
X    {
X        ;    # empty loop...
X    }
X    ($ret) = &dbretdata($dbproc);
X.fi
X
XDoing a Bulk Copy from program variables into a Sybase table:
X
X.nf
X    &BCP_SETL($DBTRUE);
X    $dbproc = &dbopen;
X    &bcp_init($dbproc, "test.dbo.t2", '', 'bcp.err', $DB_IN);
X    &bcp_meminit($dbproc, 3);   # we wish to copy three columns into
X                    # the 't2' table
X    while(<>)
X    {
X        chop;
X        @dat = split(' ', $_);
X        &bcp_sendrow($dbproc, @dat);
X    }
X    $ret = &bcp_done($dbproc);
X.fi
X
X
X
X.SH OPTIONS
X
XSee the \fIPerl(1)\fP manual page.
X
X.SH BUGS
X
XMemory usage can become very large in certain conditions when
Xusing a version of Perl prior to 4.035. This
Xcan be circumvented - see the BUGS file in the Sybperl distribution.
X
XIf \fB&dbnextrow\fP encounters a datatype that it does not know about,
Xit tries to convert it to SYBCHAR, and to store it in a 256 byte
Xbuffer - without checking for overflow.
X
XThe handling of multiple logins isn't really clean. A call to
X\fB&dblogin\fP sets the values for the User name and Password. These
Xvalues are remembered - and used in calls to \fB&dbopen\fP - until
Xthey are changed in a new call to \fB&dblogin()\fP. It is possible to
Xavoid the use of \fB&dbopen\fP alltogether, and simply call
X\fB&dblogin\fP each time a new \fBDBPROCESS\fP is required.
X
XIt is not possible to call \fB&BCP_SETL\fP for the first
X\fBDBPROCESS\fP. You have to call \fB&dblogin\fP, then
X\fB&BCP_SETL\fP, then \fB&dbopen\fP to get a \fBDBPROCESS\fP with
X\fBBCP_IN\fP enabled.
X
X.SH FILES
X
X\fI$PERLLIB/sybperl.pl\fP should be called in all \fBsybperl\fP
Xscripts to set the correct environment variables used by DB-Library.
XA sample \fI$PERLLIB/sybdb.ph\fP is provided with sybperl. You may
Xwant to use \fBh2ph\fP to add definitions to this file.
X
X.SH "SEE ALSO"
X
X\fIPerl(1L), Sybase Open Client DB Library Reference Manual, h2ph(1L).\fP
X
X.SH AUTHOR
X
X.nf
XMichael Peppler, ITF Management SA \- [e-mail]
X.fi
XBrent Milnor ([e-mail]) contributed &dbwritetext().
XEric Fifer ([e-mail]) contributed corrections to the
X&dblogin()/&dbopen() sequence.
XMark Lawrence ([e-mail]) contributed &dbsafestr().
XMichael Bloom ([e-mail]) contributed code to handle SYBIMAGE data.
XDon Preuss ([e-mail]) contributed the &dbcolXXX() calls.
XJeffrey Wong ([e-mail]) contributed the
XOpenClient R4.6.1 DBMONEY routines
X
END_OF_FILE
  if test 10929 -ne `wc -c <'sybperl.1'`; then
    echo shar: \"'sybperl.1'\" unpacked with wrong size!
  fi
  # end of 'sybperl.1'
fi
if test -f 'sybperl.c.B' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'sybperl.c.B'\"
else
  echo shar: Extracting \"'sybperl.c.B'\" \(36266 characters\)
  sed "s/^X//" >'sybperl.c.B' <<'END_OF_FILE'
X      case US_dbmnycmp:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: &dbmnycmp($dbproc, $m1, $m2)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        DBMONEY m1, m2;
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnycmp $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m2, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnycmp $m2 parameter");
X            }
X
X        retval = dbmnycmp(dbProc[inx].dbproc, &m1, &m2);
X
X        str_numset(STACK(sp)[0], (double)retval);
X    }
X    break;
X      case US_dbmnydivide:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: @arr = &dbmnydivide($dbproc, $m1, $m2)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        DBMONEY m1, m2, mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnydivide $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m2, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnydivide $m2 parameter");
X            }
X
X        retval = dbmnydivide(dbProc[inx].dbproc, &m1, &m2, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnyminus:
X    if ((items > 2) || (items < 1 ))
X        {
X        fatal("Usage: @arr = &dbmnyminus($dbproc, $m1)");
X        }
X    else
X    {
X        int     retval, off1;
X        DBMONEY m1, mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 2)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyminus $m1 parameter");
X            }
X
X        retval = dbmnyminus(dbProc[inx].dbproc, &m1, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnymul:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: @arr = &dbmnymul($dbproc, $m1, $m2)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        DBMONEY m1, m2, mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnymul $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m2, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnymul $m2 parameter");
X            }
X
X        retval = dbmnymul(dbProc[inx].dbproc, &m1, &m2, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnysub:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: @arr = &dbmnysub($dbproc, $m1, $m2)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        DBMONEY m1, m2, mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnysub $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&m2, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnysub $m2 parameter");
X            }
X
X        retval = dbmnysub(dbProc[inx].dbproc, &m1, &m2, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnyzero:
X    if (items > 1)
X        {
X        fatal("Usage: @arr = &dbmnyzero($dbproc)");
X        }
X    else
X    {
X        int     retval;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 1)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        }
X        else
X        {
X        inx = 0;
X            }
X
X        retval = dbmnyzero(dbProc[inx].dbproc, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnydec:
X    if ((items > 2) || (items < 1 ))
X        {
X        fatal("Usage: @arr = &dbmnydec($dbproc, $m1)");
X        }
X    else
X    {
X        int     retval, off1;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 2)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE *)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnydec $m1 parameter");
X            }
X
X        retval = dbmnydec(dbProc[inx].dbproc, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnydown:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: @arr = &dbmnydown($dbproc, $m1, $i1)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        int   i1, iresult = 0;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnydown $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBINT4, (BYTE*)&i1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnydown $i1 parameter");
X            }
X
X        retval = dbmnydown(dbProc[inx].dbproc, &mresult, i1, &iresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)iresult)));
X    }
X    break;
X      case US_dbmnyinc:
X    if ((items > 2) || (items < 1 ))
X        {
X        fatal("Usage: @arr = &dbmnyinc($dbproc, $m1)");
X        }
X    else
X    {
X        int     retval, off1;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 2)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyinc $m1 parameter");
X            }
X
X        retval = dbmnyinc(dbProc[inx].dbproc, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnyinit:
X    if ((items > 3) || (items < 2 ))
X        {
X        fatal("Usage: @arr = &dbmnyinit($dbproc, $m1, $i1)");
X        }
X    else
X    {
X        int     retval, off1, off2;
X        DBINT   i1, iresult;
X        DBMONEY mresult;
X        DBBOOL  bresult = (DBBOOL)FALSE;
X            DBCHAR  mnybuf[40];
X
X        if(items == 3)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyinit $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBINT4, (BYTE*)&i1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyinit $i1 parameter");
X            }
X
X        retval = dbmnyinit(dbProc[inx].dbproc, &mresult, i1, &bresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X        iresult = (DBINT)bresult;
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)iresult)));
X    }
X    break;
X      case US_dbmnymaxneg:
X    if (items > 1)
X        {
X        fatal("Usage: @arr = &dbmnymaxneg($dbproc)");
X        }
X    else
X    {
X        int     retval;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 1)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        }
X        else
X        {
X        inx = 0;
X            }
X
X        retval = dbmnymaxneg(dbProc[inx].dbproc, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnymaxpos:
X    if (items > 1)
X        {
X        fatal("Usage: @arr = &dbmnymaxpos($dbproc)");
X        }
X    else
X    {
X        int     retval;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 1)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        }
X        else
X        {
X        inx = 0;
X            }
X
X        retval = dbmnymaxpos(dbProc[inx].dbproc, &mresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X      case US_dbmnyndigit:
X    if ((items > 2) || (items < 1 ))
X        {
X        fatal("Usage: @arr = &dbmnyndigit($dbproc, $m1)");
X        }
X    else
X    {
X        int     retval, off1;
X        DBMONEY mresult;
X        DBINT   iresult;
X        DBBOOL  bresult = (DBBOOL)FALSE;
X            DBCHAR  mnybuf[40], dgtbuf[ 10 ];
X
X        if(items == 2)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyndigit $m1 parameter");
X            }
X
X        retval = dbmnyndigit(dbProc[inx].dbproc, &mresult, dgtbuf, &bresult);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X        iresult = (DBINT)bresult;
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X        (void)astore(ary,++sp,str_2mortal(str_make(dgtbuf, 0)));
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)iresult)));
X    }
X    break;
X      case US_dbmnyscale:
X    if ((items > 4) || (items < 3 ))
X        {
X        fatal("Usage: @arr = &dbmnyscale($dbproc, $m1, $i1, $i2)");
X        }
X    else
X    {
X        int     retval, off1, off2, off3;
X        DBINT   i1, i2;
X        DBMONEY mresult;
X            DBCHAR  mnybuf[40];
X
X        if(items == 4)
X        {
X        inx  = getDbProc(STACK(sp)[1]);
X        off1 = 2;
X        off2 = 3;
X        off3 = 4;
X        }
X        else
X        {
X        inx  = 0;
X        off1 = 1;
X        off2 = 2;
X        off3 = 3;
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off1]), (DBINT)-1,
X              SYBMONEY, (BYTE*)&mresult, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyscale $m1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off2]), (DBINT)-1,
X              SYBINT4, (BYTE*)&i1, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyscale $i1 parameter");
X            }
X
X        if (dbconvert(dbProc[inx].dbproc, SYBCHAR,
X              (char *)str_get(STACK(sp)[off3]), (DBINT)-1,
X              SYBINT4, (BYTE*)&i2, (DBINT)-1) == -1)
X            {
X           fatal("Invalid dbconvert() for &dbmnyscale $i2 parameter");
X            }
X
X        retval = dbmnyscale(dbProc[inx].dbproc, &mresult, i1, i2);
X
X            new_mnytochar(dbProc[inx].dbproc, &mresult, mnybuf);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)retval)));
X        (void)astore(ary,++sp,str_2mortal(str_make(mnybuf, 0)));
X    }
X    break;
X#endif
X      case US_dbwritetext:
X        if (items != 5)
X            fatal ("Usage: dbwritetext($dbproc1,$column,$dbproc2,$col,$text");
X    else
X    {
X        int inx2, wcolnum;
X        char *wcolname, *wtext;
X        int ret;
X
X        inx = getDbProc(STACK(sp)[1]);
X        wcolname = str_get(STACK(sp)[2]);
X        inx2 = getDbProc(STACK(sp)[3]);
X        wcolnum = (int)str_gnum(STACK(sp)[4]);
X        wtext = str_get(STACK(sp)[5]);
X        ret = dbwritetext (dbProc[inx].dbproc, wcolname, dbtxptr(dbProc[inx2].dbproc, wcolnum),
X                   DBTXPLEN, dbtxtimestamp(dbProc[inx2].dbproc, wcolnum), 0,
X                   strlen(wtext), wtext);
X        str_numset(STACK(sp)[0], (double) ret);
X    }
X        break;
X      case US_dbnumcols:
X    if (items > 1)
X        fatal("Usage: $dbnumcols = &dbnumcols($dbproc);");
X    else
X    {
X        int j;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        j = dbnumcols(dbProc[inx].dbproc);
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X      case US_dbcoltype:
X    if (items > 2 || items < 1)
X        fatal("Usage: $dbcoltype = &dbcoltype($dbproc, columnid);");
X    else
X    {
X        int j, off;
X
X        if(items)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X
X        j = dbcoltype(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X      case US_dbcolname:
X    if (items > 2 || items < 1)
X        fatal("Usage: $dbcolname = &dbcolname($dbproc, columnid);");
X    else
X    {
X        int j, off;
X        char *colname;
X
X        if(items)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X
X        colname = dbcolname(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]));
X        str_set (STACK (sp)[0], colname);
X    }
X    break;
X      case US_dbcollen:
X    if (items > 2)
X        fatal("Usage: $dbcollen = &dbcollen($dbproc, columnid);");
X    else
X    {
X        int j, off;
X
X        if(items)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X
X        j = dbcollen(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X      case US_dbrecftos:
X    if (items != 1)
X        fatal("Usage: &dbrecftos($filename);");
X    else
X    {
X        dbrecftos((char *)str_get(STACK(sp)[1]));
X
X        str_numset(STACK(sp)[0], (double) 0);
X    }
X    break;
X
X      case US_BCP_SETL:
X    if (items != 1)
X        fatal("Usage: &BCP_SETL($state);");
X    else
X    {
X        BCP_SETL(login, (int)str_gnum(STACK(sp)[1]));
X        str_numset(STACK(sp)[0], (double) 0);
X    }
X    break;
X
X      case US_bcp_getl:
X    if (items)
X        fatal("Usage: $state = &bcp_getl();");
X    else
X    {
X        int ret;
X        ret = bcp_getl(login);
X        str_numset(STACK(sp)[0], (double) ret);
X    }
X    break;
X
X      case US_bcp_init:
X    if (items < 4 || items > 5)
X        fatal("Usage: &bcp_init($dbproc, $tblname, $hfile, $errfile, $dir);");
X    else
X    {
X        int j, off;
X        char *hfile;
X
X        if(items == 5)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X        hfile = str_get(STACK(sp)[off+1]);
X        if((Str = STACK(sp)[off+1]) == &str_undef ||
X           ((hfile = str_get(Str)) && strlen(hfile) == 0))
X        hfile = NULL;
X        j = bcp_init(dbProc[inx].dbproc, str_get(STACK(sp)[off]),
X             hfile,
X             str_get(STACK(sp)[off+2]),
X             (int)str_gnum(STACK(sp)[off+3]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_meminit:
X    if (items < 1 || items > 2)
X        fatal("Usage: &bcp_meminit($dbproc, $num_cols);");
X    else
X    {
X        int j, off, numcols;
X        BYTE dummy;
X
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        numcols = str_gnum(STACK(sp)[off]);
X        for(j = 1; j <= numcols; ++j)
X        bcp_bind(dbProc[inx].dbproc, &dummy, 0, -1, "", 1, SYBCHAR, j);
X
X        if(dbProc[inx].colPtr) /* avoid a potential memory leak */
X        Safefree(dbProc[inx].colPtr);
X        New (902, dbProc[inx].colPtr, numcols, BYTE *);
X
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_sendrow:    /* WARNING: the dbproc param is NOT */
X                /* optional for this call!!! */
X    if (items < 2)
X        fatal("Usage: &bcp_sendrow($dbproc, LIST);");
X    else
X    {
X        int j, off;
X
X        inx = getDbProc(STACK(sp)[1]);
X        for(j = 1; j < items; ++j)
X        {
X        Str = STACK(sp)[j+1];
X        if(Str == &str_undef) /* it's a NULL data value */
X            bcp_collen(dbProc[inx].dbproc, 0, j);
X        else
X            bcp_collen(dbProc[inx].dbproc, -1, j);
X        dbProc[inx].colPtr[j] = (BYTE *)str_get(Str);
X        bcp_colptr(dbProc[inx].dbproc, dbProc[inx].colPtr[j], j);
X        }
X        j = bcp_sendrow(dbProc[inx].dbproc);
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_batch:
X    if (items > 1)
X        fatal("Usage: $ret = &bcp_batch($dbproc);");
X    else
X    {
X        int j;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        j = bcp_batch(dbProc[inx].dbproc);
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_done:
X    if (items > 1)
X        fatal("Usage: $ret = &bcp_done($dbproc);");
X    else
X    {
X        int j;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X        if(dbProc[inx].colPtr)
X        {
X        Safefree(dbProc[inx].colPtr);
X        dbProc[inx].colPtr = NULL;
X        }
X        j = bcp_done(dbProc[inx].dbproc);
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_control:
X    if (items < 2 || items > 3)
X        fatal("Usage: $ret = &bcp_control($dbproc, $field, $value);");
X    else
X    {
X        int j, off;
X
X        if(items == 3)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        j = bcp_control(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]),
X                (int)str_gnum(STACK(sp)[off+1]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_columns:
X    if (items < 1 || items > 2)
X        fatal("Usage: $ret = &bcp_columns($dbproc, $host_colcount);");
X    else
X    {
X        int j, off;
X
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        j = bcp_columns(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_colfmt:
X    if (items < 7 || items > 8)
X        fatal("Usage: $ret = &bcp_colfmt($dbproc, $host_colnum, $host_type, $host_prefixlen, $host_collen, $host_term, $host_termlen, $table_colnum);");
X    else
X    {
X        int j, off;
X        char *host_term;
X
X        if(items == 8)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X        if(STACK(sp)[off+4] == &str_undef)
X        host_term = NULL;
X        else
X        host_term = str_get(STACK(sp)[off+4]);
X
X        j = bcp_colfmt(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]),
X               (int)str_gnum(STACK(sp)[off+1]),
X               (int)str_gnum(STACK(sp)[off+2]),
X               (int)str_gnum(STACK(sp)[off+3]),
X               host_term,
X               (int)str_gnum(STACK(sp)[off+5]),
X               (int)str_gnum(STACK(sp)[off+6]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_collen:
X    if (items < 2 || items > 3)
X        fatal("Usage: $ret = &bcp_collen($dbproc, $varlen, $table_column);");
X    else
X    {
X        int j, off;
X
X        if(items == 3)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        j = bcp_collen(dbProc[inx].dbproc, (int)str_gnum(STACK(sp)[off]),
X               (int)str_gnum(STACK(sp)[off+1]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_exec:
X    if (items > 1)
X        fatal("Usage: ($ret, $rows_copied) = &bcp_exec($dbproc);");
X    else
X    {
X        int j;
X        DBINT rows;
X
X        if(items == 1)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X        j = bcp_exec(dbProc[inx].dbproc, &rows);
X
X            --sp;  /* readjust to get rid of space preallocation */
X
X            (void)astore(ary,++sp,str_2mortal(str_nmake((double)j)));
X        (void)astore(ary,++sp,str_2mortal(str_nmake((double)rows)));
X    }
X    break;
X
X      case US_bcp_readfmt:
X    if (items < 1 || items > 2)
X        fatal("Usage: $ret = &bcp_readfmt($dbproc, $filename);");
X    else
X    {
X        int j, off;
X
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        j = bcp_readfmt(dbProc[inx].dbproc, str_get(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      case US_bcp_writefmt:
X    if (items < 1 || items > 2)
X        fatal("Usage: $ret = &bcp_writefmt($dbproc, $filename);");
X    else
X    {
X        int j, off;
X
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        j = bcp_writefmt(dbProc[inx].dbproc, str_get(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X
X      default:
X    fatal("Unimplemented user-defined subroutine");
X    }
X    return sp;
X}
X
X/*
X * Return the value of a userdefined variable. These variables are nearly all
X * READ-ONLY.
X */
Xstatic int
Xuserval(ix, str)
Xint ix;
XSTR *str;
X{
X    char buff[24];
X
X    switch (ix)
X    {
X      case UV_SUCCEED:
X    str_numset(str, (double)SUCCEED);
X    break;
X      case UV_FAIL:
X    str_numset(str, (double)FAIL);
X    break;
X      case UV_NO_MORE_ROWS:
X    str_numset(str, (double)NO_MORE_ROWS);
X    break;
X      case UV_NO_MORE_RESULTS:
X    str_numset(str, (double)NO_MORE_RESULTS);
X    break;
X      case UV_ComputeId:
X    str_numset(str, (double)ComputeId);
X    break;
X      case UV_SybperlVer:
X    sprintf(buff, "%d.%3.3d", VERSION, PATCHLEVEL);
X    str_set(str, buff);
X    break;
X      case UV_DBstatus:
X    str_numset(str, (double)DBstatus);
X    break;
X#if defined(DBLIB461)
X      case UV_STDEXIT:
X    str_numset(str, (double)STDEXIT);
X    break;
X      case UV_ERREXIT:
X    str_numset(str, (double)ERREXIT);
X    break;
X      case UV_INT_EXIT:
X    str_numset(str, (double)INT_EXIT);
X    break;
X      case UV_INT_CONTINUE:
X    str_numset(str, (double)INT_CONTINUE);
X    break;
X      case UV_INT_CANCEL:
X    str_numset(str, (double)INT_CANCEL);
X    break;
X      case UV_INT_TIMEOUT:
X    str_numset(str, (double)INT_TIMEOUT);
X    break;
X      case UV_MORE_ROWS:
X    str_numset(str, (double)MORE_ROWS);
X    break;
X      case UV_REG_ROW:
X    str_numset(str, (double)REG_ROW);
X    break;
X      case UV_BUF_FULL:
X    str_numset(str, (double)BUF_FULL);
X    break;
X      case UV_NO_MORE_PARAMS:
X    str_numset(str, (double)NO_MORE_PARAMS);
X    break;
X      case UV_DBSAVE:
X    str_numset(str, (double)DBSAVE);
X    break;
X      case UV_DBNOSAVE:
X    str_numset(str, (double)DBNOSAVE);
X    break;
X      case UV_DBNOERR:
X    str_numset(str, (double)DBNOERR);
X    break;
X      case UV_DB_PASSTHRU_MORE:
X    str_numset(str, (double)DB_PASSTHRU_MORE);
X    break;
X      case UV_DB_PASSTHRU_EOM:
X    str_numset(str, (double)DB_PASSTHRU_EOM);
X    break;
X      case UV_DBNOPROC:
X    str_numset(str, (double)DBNOPROC);
X    break;
X      case UV_EXCEPTION:
X    str_numset(str, (double)EXCEPTION);
X    break;
X      case UV_EXSIGNAL:
X    str_numset(str, (double)EXSIGNAL);
X    break;
X      case UV_EXSCREENIO:
X    str_numset(str, (double)EXSCREENIO);
X    break;
X      case UV_EXDBLIB:
X    str_numset(str, (double)EXDBLIB);
X    break;
X      case UV_EXFORMS:
X    str_numset(str, (double)EXFORMS);
X    break;
X      case UV_EXCLIPBOARD:
X    str_numset(str, (double)EXCLIPBOARD);
X    break;
X      case UV_EXLOOKUP:
X    str_numset(str, (double)EXLOOKUP);
X    break;
X      case UV_EXINFO:
X    str_numset(str, (double)EXINFO);
X    break;
X      case UV_EXUSER:
X    str_numset(str, (double)EXUSER);
X    break;
X      case UV_EXNONFATAL:
X    str_numset(str, (double)EXNONFATAL);
X    break;
X      case UV_EXCONVERSION:
X    str_numset(str, (double)EXCONVERSION);
X    break;
X      case UV_EXSERVER:
X    str_numset(str, (double)EXSERVER);
X    break;
X      case UV_EXTIME:
X    str_numset(str, (double)EXTIME);
X    break;
X      case UV_EXPROGRAM:
X    str_numset(str, (double)EXPROGRAM);
X    break;
X      case UV_EXRESOURCE:
X    str_numset(str, (double)EXRESOURCE);
X    break;
X      case UV_EXCOMM:
X    str_numset(str, (double)EXCOMM);
X    break;
X      case UV_EXFATAL:
X    str_numset(str, (double)EXFATAL);
X    break;
X      case UV_EXCONSISTENCY:
X    str_numset(str, (double)EXCONSISTENCY);
X    break;
X#endif
X      case UV_DB_IN:
X    str_numset(str, (double)DB_IN);
X    break;
X      case UV_DB_OUT:
X    str_numset(str, (double)DB_OUT);
X    break;
X      case UV_BCPMAXERRS:
X    str_numset(str, (double)BCPMAXERRS);
X    break;
X      case UV_BCPFIRST:
X    str_numset(str, (double)BCPFIRST);
X    break;
X      case UV_BCPLAST:
X    str_numset(str, (double)BCPLAST);
X    break;
X      case UV_BCPBATCH:
X    str_numset(str, (double)BCPBATCH);
X    break;
X      case UV_DBTRUE:
X    str_numset(str, (double)TRUE);
X    break;
X      case UV_DBFALSE:
X    str_numset(str, (double)FALSE);
X    break;
X#if defined(PACKAGE_BUG)
X      case UV_PACKAGE_BUG:
X    str_numset(str, 1.0);
X    break;
X#endif
X      case UV_dbNullIsUndef:
X    str_numset(str, (double)dbNullIsUndef);
X    break;
X      case UV_dbKeepNumeric:
X    str_numset(str, (double)dbKeepNumeric);
X    break;
X      case UV_dbBin0x:
X    str_numset(str, (double)dbBin0x);
X    break;
X     }
X    return 0;
X}
X
Xstatic int
Xuserset(ix, str)
Xint ix;
XSTR *str;
X{
X    switch (ix)
X    {
X      case UV_dbNullIsUndef:
X    dbNullIsUndef = str_gnum(str);
X    break;
X      case UV_dbKeepNumeric:
X    dbKeepNumeric = str_gnum(str);
X    break;
X      case UV_dbBin0x:
X    dbBin0x = str_gnum(str);
X    break;
X      default:
X#if defined(USERVAL_SET_FATAL)
X    fatal("sybperl: trying to write to a read-only variable.");
X#else
X    warn("sybperl: trying to write to a read-only variable.");
X#endif
X    break;
X    }
X    return 0;
X}
X
X
X/*ARGSUSED*/
Xstatic int err_handler(db, severity, dberr, oserr, dberrstring, oserrstr)
X    DBPROCESS *db;
X    int severity;
X    int dberr;
X    int oserr;
X    char *dberrstring;
X    char *oserrstr;
X{
X#ifdef HAS_CALLBACK
X    /* If we have error handler subroutine, use it. */
X    if (err_handler_sub)
X    {
X    int sp = perl_sp;
X    int j;
X
X    for(j = 0; j < MAX_DBPROCS; ++j)
X        if(db == dbProc[j].dbproc)
X        break;
X    if(j == MAX_DBPROCS)
X        j = 0;
X
X    /* Reserve spot for return value. */
X    astore (stack, ++ sp, Nullstr);
X
X    /* Set up arguments. */
X    astore (stack, ++ sp,
X        str_2mortal (str_nmake ((double) j)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) dberr)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) oserr)));
X    if (dberrstring && *dberrstring)
X        astore (stack, ++ sp, str_2mortal (str_make (dberrstring, 0)));
X    else
X        astore (stack, ++ sp, &str_undef);
X    if (oserrstr && *oserrstr)
X        astore (stack, ++ sp, str_2mortal (str_make (oserrstr, 0)));
X    else
X        astore (stack, ++ sp, &str_undef);
X
X    /* Call it. */
X    sp = callback (err_handler_sub, sp, 0, 1, 6);
X
X    /* Return whatever it returned. */
X    return (int) str_gnum (STACK (sp)[0]);
X    }
X#endif                /* HAS_CALLBACK */
X    if ((db == NULL) || (DBDEAD(db)))
X    return(INT_EXIT);
X    else
X    {
X    fprintf(stderr,"DB-Library error:\n\t%s\n", dberrstring);
X
X    if (oserr != DBNOERR)
X        fprintf(stderr,"Operating-system error:\n\t%s\n", oserrstr);
X
X    return(INT_CANCEL);
X    }
X}
X
X/*ARGSUSED*/
X
Xstatic int msg_handler(db, msgno, msgstate, severity, msgtext, srvname, procname, line)
X    DBPROCESS *db;
X    DBINT msgno;
X    int msgstate;
X    int severity;
X    char *msgtext;
X    char *srvname;
X    char *procname;
X    DBUSMALLINT line;
X{
X#ifdef HAS_CALLBACK
X    /* If we have message handler subroutine, use it. */
X    if (msg_handler_sub)
X    {
X    int sp = perl_sp;
X    int j;
X
X    for(j = 0; j < MAX_DBPROCS; ++j)
X        if(db == dbProc[j].dbproc)
X        break;
X    if(j == MAX_DBPROCS)
X        j = 0;
X
X    /* Reserve spot for return value. */
X    astore (stack, ++ sp, Nullstr);
X
X    /* Set up arguments. */
X    astore (stack, ++ sp,
X        str_2mortal (str_nmake ((double) j)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgno)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) msgstate)));
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) severity)));
X    if (msgtext && *msgtext)
X        astore (stack, ++ sp, str_2mortal (str_make (msgtext, 0)));
X    else
X        astore (stack, ++ sp, &str_undef);
X    if (srvname && *srvname)
X        astore (stack, ++ sp, str_2mortal (str_make (srvname, 0)));
X    else
X        astore (stack, ++ sp, &str_undef);
X    if (procname && *procname)
X        astore (stack, ++ sp, str_2mortal (str_make (procname, 0)));
X    else
X        astore (stack, ++ sp, &str_undef);
X    astore (stack, ++ sp, str_2mortal (str_nmake ((double) line)));
X
X    /* Call it. */
X    sp = callback (msg_handler_sub, sp, 0, 1, 8);
X
X    /* Return whatever it returned. */
X    return (int) str_gnum (STACK (sp)[0]);
X    }
X#endif                /* HAS_CALLBACK */
X#ifdef OLD_SYBPERL
X    if(!severity)
X    return 0;
X#endif
X    fprintf (stderr,"Msg %ld, Level %d, State %d\n",
X         msgno, severity, msgstate);
X    if (strlen(srvname) > 0)
X    fprintf (stderr,"Server '%s', ", srvname);
X    if (strlen(procname) > 0)
X    fprintf (stderr,"Procedure '%s', ", procname);
X    if (line > 0)
X    fprintf (stderr,"Line %d", line);
X
X    fprintf(stderr,"\n\t%s\n", msgtext);
X
X    return(0);
X}
X
X/*
X * Get the index into the dbproc[] array from a Perl STR datatype.
X * Check that the index is reasonably valid...
X */
Xstatic int
XgetDbProc(Str)
X    STR *Str;
X{
X    int ix;
X
X    if (Str == &str_undef || !Str->str_nok) /* This may be getting a bit too */
X                        /* close with the internals of */
X                        /* the 'str' workings... */
X    warn("The $dbproc parameter has not been properly initialized - it defaults to 0");
X
X    ix = (int)str_gnum(Str);
X
X    if(ix < 0 || ix >= MAX_DBPROCS)
X    fatal("$dbproc parameter is out of range");
X    if(dbProc[ix].dbproc == NULL || DBDEAD(dbProc[ix].dbproc))
X    fatal("$dbproc parameter is NULL or the connection to the server has been closed");
X    return ix;
X}
X
X
X#ifdef HAS_CALLBACK
X
X/* Taken from Perl 4.018 usub/usersub.c. mp. */
X
X/* Be sure to refetch the stack pointer after calling these routines. */
X
Xint
Xcallback(subname, sp, gimme, hasargs, numargs)
Xchar *subname;
Xint sp;            /* stack pointer after args are pushed */
Xint gimme;        /* called in array or scalar context */
Xint hasargs;        /* whether to create a @_ array for routine */
Xint numargs;        /* how many args are pushed on the stack */
X{
X    static ARG myarg[3];    /* fake syntax tree node */
X    int arglast[3];
X
X    arglast[2] = sp;
X    sp -= numargs;
X    arglast[1] = sp--;
X    arglast[0] = sp;
X
X    if (!myarg[0].arg_ptr.arg_str)
X    myarg[0].arg_ptr.arg_str = str_make("",0);
X
X    myarg[1].arg_type = A_WORD;
X    myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE);
X
X    myarg[2].arg_type = hasargs ? A_EXPR : A_NULL;
X
X    return do_subr(myarg, gimme, arglast);
X}
X
X#endif                /* HAS_CALLBACK */
X
X
X#if defined(DBLIB461)
X
X/* The following routines originate from the OpenClient R4.6.1 reference  */
X/* manual, pages 2-165 to 2-168 both inclusive.  It has been subsequently */
X/* modified (slightly) to suit local conditions.                          */
X
X#define PRECISION 4
X
Xstatic void new_mny4tochar(dbproc, mny4ptr, buf_ptr)
XDBPROCESS *dbproc;
XDBMONEY4  *mny4ptr;
XDBCHAR    *buf_ptr;
X{
X   DBMONEY local_mny;
X   DBCHAR  value;
X   char    temp_buf[40];
X
X   int     bytes_written = 0;
X   int     i             = 0;
X   DBBOOL  negative      = (DBBOOL)FALSE;
X   DBBOOL  zero          = (DBBOOL)FALSE;
X
X   if (dbconvert(dbproc, SYBMONEY4, (BYTE*)mny4ptr, (DBINT)-1,
X                 SYBMONEY, (BYTE*)&local_mny, (DBINT)-1) == -1)
X   {
X      fatal("dbconvert() failed in routine new_mny4tochar()");
X   }
X
X   if (dbmnyinit(dbproc, &local_mny, 4 - PRECISION, &negative) == FAIL)
X   {
X      fatal("dbmnyinit() failed in routine new_mny4tochar()");
X   }
X
X   while (zero == FALSE)
X   {
X      if (dbmnyndigit(dbproc, &local_mny, &value, &zero) == FAIL)
X      {
X         fatal("dbmnyndigit() failed in routine new_mny4tochar()");
X      }
X
X      temp_buf[bytes_written++] = value;
X
X      if (zero == FALSE)
X      {
X         if (bytes_written == PRECISION)
X         {
X            temp_buf[bytes_written++] = '.';
X         }
X      }
X   }
X
X   while (bytes_written < PRECISION)
X   {
X      temp_buf[bytes_written++] = '0';
X   }
X
X   if (bytes_written == PRECISION)
X   {
X      temp_buf[bytes_written++] = '.';
X      temp_buf[bytes_written++] = '0';
X   }
X
X   if (negative == TRUE)
X   {
X      buf_ptr[i++] = '-';
X   }
X
X   while (bytes_written--)
X   {
X      buf_ptr[i++] = temp_buf[bytes_written];
X   }
X
X   buf_ptr[i] = '\0';
X
X   return;
X}
X
Xstatic void new_mnytochar(dbproc, mnyptr, buf_ptr)
XDBPROCESS *dbproc;
XDBMONEY   *mnyptr;
XDBCHAR    *buf_ptr;
X{
X   DBMONEY local_mny;
X   DBCHAR  value;
X   char    temp_buf[40];
X
X   int     bytes_written = 0;
X   int     i             = 0;
X   DBBOOL  negative      = (DBBOOL)FALSE;
X   DBBOOL  zero          = (DBBOOL)FALSE;
X
X   if (dbmnycopy(dbproc, mnyptr, &local_mny) == FAIL)
X   {
X      fatal("dbmnycopy() failed in routine new_mnytochar()");
X   }
X
X   if (dbmnyinit(dbproc, &local_mny, 4 - PRECISION, &negative) == FAIL)
X   {
X      fatal("dbmnyinit() failed in routine new_mnytochar()");
X   }
X
X   while (zero == FALSE)
X   {
X      if (dbmnyndigit(dbproc, &local_mny, &value, &zero) == FAIL)
X      {
X         fatal("dbmnyndigit() failed in routine new_mnytochar()");
X      }
X
X      temp_buf[bytes_written++] = value;
X
X      if (zero == FALSE)
X      {
X         if (bytes_written == PRECISION)
X         {
X            temp_buf[bytes_written++] = '.';
X         }
X      }
X   }
X
X   while (bytes_written < PRECISION)
X   {
X      temp_buf[bytes_written++] = '0';
X   }
X
X   if (bytes_written == PRECISION)
X   {
X      temp_buf[bytes_written++] = '.';
X      temp_buf[bytes_written++] = '0';
X   }
X
X   if (negative == TRUE)
X   {
X      buf_ptr[i++] = '-';
X   }
X
X   while (bytes_written--)
X   {
X      buf_ptr[i++] = temp_buf[bytes_written];
X   }
X
X   buf_ptr[i] = '\0';
X
X   return;
X}
X
X#endif  /* DBLIB461 */
X
END_OF_FILE
  if test 36266 -ne `wc -c <'sybperl.c.B'`; then
    echo shar: \"'sybperl.c.B'\" unpacked with wrong size!
  elif test -f 'sybperl.c.A' ; then
    echo shar: Combining  \"'sybperl.c'\" \(84305 characters\)
    cat 'sybperl.c.A' 'sybperl.c.B' > 'sybperl.c'
    if test 84305 -ne `wc -c <'sybperl.c'`; then
      echo shar: \"'sybperl.c'\" combined with wrong size!
    else
      rm sybperl.c.A sybperl.c.B
    fi
  fi
  # end of 'sybperl.c.B'
fi
echo shar: End of archive 2 \(of 3\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 3 archives.
    rm -f ark[1-9]isdone
else
    echo You still must unpack the following archives:
    echo "        " ${MISSING}
fi
exit 0
exit 0 # Just in case...