Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/misc/volume28/sybperl/part01

Text File | 1992-02-09 | 58.3 KB | 2,221 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Michael Peppler)
Subject:  v28i033:  sybperl - Sybase DB-library extensions to Perl, Part01/01
Message-ID: <[e-mail]>
X-Md4-Signature: 32f35045753ff2ad364a1da4dab8a5c9
Date: Mon, 10 Feb 1992 17:08:28 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Michael Peppler)
Posting-number: Volume 28, Issue 33
Archive-name: sybperl/part01
Environment: UNIX, Perl, Sybase
Supersedes: sybperl: Volume 25, Issue 40

This is Sybperl, a set of subroutine extensions to Perl to interface
directly to a Sybase dataserver.

Sybperl is very usefull for writing ad-hoc reports, when other tools
are too cumbersome for the task. I use sybperl for all the reports in a
production environment here at ITF Management.

Sybperl has been tested at a number of sites, and should work with no
problem provided Perl works on your system.

This version adds support for Perl based error handlers (a la
dberrhandle()), limited support for SYBTEXT datatypes, and cleans up a
couple of loose ends. See the CHANGES file for details.

Michael Peppler                 [e-mail] {uunet,mcsun}!chsun!itf1!mpeppler
ITF Management SA            BIX:   mpeppler
13 Rue de la Fontaine        Phone: [phone]
CH-1204 Geneva, Switzerland  Fax:   [phone]
------------
#! /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".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to [e-mail] if you want that tool.
# Contents:  README BUGS CHANGES Makefile PACKING.LST eg eg/capture.pl
#   eg/report.pl eg/space.pl eg/sql.pl lib lib/sybdb.ph lib/sybperl.pl
#   patchlevel.h sybperl.1 sybperl.c t t/sbex.pl
# Wrapped by kent@sparky on Mon Feb 10 11:01:39 1992
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo '          "shar: End of archive 1 (of 1)."'
if test -f 'README' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'README'\"
else
  echo shar: Extracting \"'README'\" \(2762 characters\)
  sed "s/^X//" >'README' <<'END_OF_FILE'
X
X                 Sybperl, version 1.0
X
X
X
X   Sybperl is a set of user-defined subroutines letting you access a
X   Sybase data server using Perl.
X
X   Requirements: Perl ver 3.0.27 or higher.
X         Sybase DB-Library (aka Open Client)
X
X
X   Compiling & Installing Sybperl:
X
X   Unshar somewhere convenient, and edit Makefile to reflect your
X   system setup. The following macros/defines may need to be set:
X
X       PERL_VERSION     Uncomment if you're using a Perl version
X             earlier than 4.03
X       UPERL/SAVESTR     See the comments in the Makefile, and the
X             BUGS file. The defaults should work.
X       HAS_CALLBACK     This enables the use of Perl subroutines as
X             DB-Library error & message handlers. This is
X             a new feature of Perl 4.018, but it might
X             work with earlier versions.
X       OLD_SYBPERL     This is a backwards compatibility flag -
X             mainly for myself :-). It's main impact is to
X             silently call dblogin()/dbopen() with default
X             arguments if you omit to do so in the script.
X
X   The Makefile will not attempt to build uperl.o if it can't find it.
X
X   You may also need to edit the lib/sybperl.pl file to addapt it to
X   your environment.
X
X   There are some test scripts in the t directory which you can run to
X   see if all is well, and to get an idea of what can be done with
X   sybperl. There are also some example scripts in the 'eg' directory.
X
X   Sybperl has been tested succesfully in the following environments:
X
X   Sun Sparc, SunOS 4.1.1, Sybase 4.0.1, Perl 4.010
X   Sun 3/80, SunOS 4.0.3, Sybase 4.0.1, Perl 4.010
X   Sun Sparc, SunOS 4.1, Sybase 4.2, Perl 4.010
X   Pyramid MIServer 2/2, OSx V5.1a, Sybase 4.0, Perl 4.010
X
X   I use sybperl daily in a production environment on a Sun 4/65 under
X   SunOS 4.1.1, with Sybase version 4.0.1 and Perl 4.019
X
X   BUGS:
X
X   There seems to be a major incompatibility between Perl and
X   DB-Library, but I've been able to code around it. See the BUGS file
X   for details.
X
X
X
X   Have fun using it and let me know of any improvements, problems,
X   whatever...
X
X   Michael Peppler            [e-mail] {uunet,mcsun}!chsun!itf1!mpeppler
X   ITF Management SA            BIX:   mpeppler
X   13 Rue de la Fontaine        Phone: [phone]
X   CH-1204 Geneva, Switzerland  Fax:   [phone]
X
X
X
X                   NOTICE - Warranty and Copyright
X
X
X   Sybperl is not a product of ITF Management. There is no warranty,
X   and no official support.
X
X   Sybperl is copyright, but may be freely distributed under the
X   same terms as Perl itself.
X
X
X
X   My thanks to the following people for testing Perl:
X
X   Teemu Torma
X   Matthew Merzbacher
X   Dan Banay
X   Jeffrey Wong
X   Anders Ardo
X   Minh Ton Ha
X   Gijs Mos
X   G. Roderick Singleton
X   Peter Gutmann
X
END_OF_FILE
  if test 2762 -ne `wc -c <'README'`; then
    echo shar: \"'README'\" unpacked with wrong size!
  fi
  # end of 'README'
fi
if test -f 'BUGS' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'BUGS'\"
else
  echo shar: Extracting \"'BUGS'\" \(1734 characters\)
  sed "s/^X//" >'BUGS' <<'END_OF_FILE'
X
X
X    The Sybase DB-Library - Perl savestr() conflict
X    ------------------------------------------------
X
X
X    Ah! The joys of tying different packages together!
X
X    Both Perl and DB-Library have a function called savestr(). The
X    DB-Library version is used in dbcmd() to add an SQL command to the
X    list of commands pointed to by dpproc->dbcmdbuf, and in dbuse() as
X    well. Now there are several ways to work around this problem.
X
X    1) Compile sybperl.c with -DBROKEN_DBCMD. I've written some code
X       that emulates calls to dbcmd() and dbuse(). This works OK on my
X       machine/OS/Version of Perl/Version of DBlib, but it relies on
X       the internal storing method used by DBlib, and that might
X       change in the future.
X
X    2) Recompile Perl (specifically, uperl.o in the Perl source
X       directory) with some suitable flags (eg -Dsavestr=p_savestr).
X       This does not create any compatibility problems, but is a
X       lengthy procedure.
X
X    3) Do something like:
X       cc -c sybperl.c
X       ld -r -o sybperl2.o sybperl.o -lsybdb
X       [edit sybperl2.o and replace `_savestr' with something like `_savest1']
X       cc -o sybperl uperl.o sybperl2.o
X       This is not a bad solution, but won't work if you have shared
X       library versions of libsybdb.a
X
X    4) Edit uperl.o and replace savestr with something else. This is
X       the solution I've chosen as the default. It is relatively fast,
X       does not rely on any internal knowledge of DB-Library, and does
X       not require Perl to be recompiled.
X
X    The Makefile gives some information on how to achieve these
X    different options.
X
X    Thanks to Teemu Torma for providing the initial input on this problem.
X
X
X    Michael
END_OF_FILE
  if test 1734 -ne `wc -c <'BUGS'`; then
    echo shar: \"'BUGS'\" unpacked with wrong size!
  fi
  # end of 'BUGS'
fi
if test -f 'CHANGES' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'CHANGES'\"
else
  echo shar: Extracting \"'CHANGES'\" \(557 characters\)
  sed "s/^X//" >'CHANGES' <<'END_OF_FILE'
X    Sybperl CHANGES:
X
X
X    1.004    Added support for Perl based error and message
X        handlers (as made possible by Perl 4.018). Many Thanks
X        to Teemu Torma for this code.
X        Added limited support for SYBTEXT datatypes.
X        Added &dbstrcpy() to retrieve the current command buffer.
X        The DBPROCESS parameter to most &db*() calls can now
X        be omitted: it will default to the first DBPROCESS
X        opened (the one that is returned by &dblogin()).
X        Added lib/sybdb.ph
X        Added a couple of example scripts in eg/*.pl, courtesy
X        of Gijs Mos (Thank You!).
X    1.003    Base version.
END_OF_FILE
  if test 557 -ne `wc -c <'CHANGES'`; then
    echo shar: \"'CHANGES'\" unpacked with wrong size!
  fi
  # end of 'CHANGES'
fi
if test -f 'Makefile' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Makefile'\"
else
  echo shar: Extracting \"'Makefile'\" \(2598 characters\)
  sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X#    @(#)Makefile    1.6    11/25/91
X#
X
XCC = cc
XPERLSRC = ..                # where to find uperl.o
XSYBINCS = /usr/local/sybase/include    # where to find the sybase .h files
XLOCINCS =                # other includes ?
XSYBLIBDIR = /usr/local/lib        # Sybase libraries
XSYBLIBS = -lsybdb            # db-library
X
X# Uncomment this if you are compiling sybperl for Perl version 3.xx
X
X# PERL_VERSION = -DVERSION3
X
X# The Perl/Sybase savestr() conflict.
X# Both Perl and Sybase DB-Library have a function called savestr(),
X# and this creates a problem when using functions such as dbcmd().
X# There are several ways around this.
X# You can:
X#
X#    - define BROKEN_DBCMD: this enables some code emulating
X#      dbcmd() that I've written.
X#    - Recompile uperl.o with a -Dsavestr=psvestr (or something similar).
X#    - Edit an existing uperl.o and change _savestr to _psvestr.
X#
X# To use the first option, uncomment the following definitions for
X# SAVESTR and UPERL
X# SAVESTR = -DBROKEN_DBCMD
X# UPERL = $(PERLSRC)/uperl.o
X#
X# To use the second option, you have to reconfigure & recompile Perl
X# manually, and then set compile sybperl with the following line
X# uncommented:
X# UPERL = $(PERLSRC)/uperl.o
X#
X# The default is to use the third solution:
XUPERL = uperl2.o
X
X
XHAS_CALLBACK= -DHAS_CALLBACK        # Remove this if you don't
X                    # have Perl 4 patchlevel 18
X                    # User defined, perl based
X                    # error/message handlers are
X                    # not possible without this, however.
XOLD_SYBPERL= -DOLD_SYBPERL        # some backward compatibility stuff.
X
XCFLAGS = -O                 #
XCPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) \
X        $(SAVESTR) $(HAS_CALLBACK) $(OLD_SYBPERL)
XBINDIR = /usr/local/bin            # where does the executable go
XPERLLIB = /usr/local/lib/perl        # where does lib/sybperl.pl
X                    # and lib/sybdb.ph go
XMANDIR = /usr/local/man            # where do we put the manual page
XMANEXT = l
X
X
Xsybperl: $(UPERL) sybperl.o
X    $(CC) $(CFLAGS) -L$(SYBLIBDIR) $(UPERL) sybperl.o $(SYBLIBS) -lm -o sybperl
X
Xsybperl.o: sybperl.c
X    $(CC) -c $(CFLAGS) $(CPPFLAGS) sybperl.c
X
X# Create uperl.o IF you wish to use the 3rd way of resolving the
X# Perl/Sybase savestr conflict.
X$(UPERL): $(PERLSRC)/uperl.o
X    cp $(PERLSRC)/uperl.o $(UPERL)
X    perl -p -i.bak -e 's/savestr/psvestr/g;' $(UPERL)
X
Xclean:
X    rm -f sybperl *.o *~ core
X
Xinstall: sybperl
X    install -s -m 775 sybperl $(BINDIR)
X    cp lib/syb*.p? $(PERLLIB)/perllib.pl
X    cp sybperl.1 $(MANDIR)/man$(MANEXT)/sybperl.$(MANEXT)
X
Xshar:
X    rm -f sybperl.shar
X    shar.pl README PACKING.LST BUGS CHANGES Makefile sybperl.c \
X    sybperl.1 patchlevel.h lib/sybperl.pl lib/sybdb.ph t/sbex.pl \
X    eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl >sybperl.shar
X
X
X
END_OF_FILE
  if test 2598 -ne `wc -c <'Makefile'`; then
    echo shar: \"'Makefile'\" unpacked with wrong size!
  fi
  # end of 'Makefile'
fi
if test -f 'PACKING.LST' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'PACKING.LST'\"
else
  echo shar: Extracting \"'PACKING.LST'\" \(725 characters\)
  sed "s/^X//" >'PACKING.LST' <<'END_OF_FILE'
X
X
X
X    The Sybperl package should contain the following files:
X
X
X        PACKING.LST        This file
X        README        Read Me!
X        BUGS        Perl/DB-library incompatibility description
X        CHANGES
X        Makefile
X        sybperl.c        Sybperl source
X        sybperl.1        Man page
X        patchlevel.h
X        t/sbex.pl        Example of sybperl script
X        lib/sybperl.pl  A Perl library file.
X        lib/sybdb.ph    Some of the DB-Library include files, run
X                through h2ph.
X        eg/space.pl        How much space does your sybase databases use?
X        eg/capture.pl   Create a table extracted from /etc/passwd
X        eg/report.pl    Report from table created by capture.pl
X        eg/sql.pl        Utility routines used by the above example programs.
X
END_OF_FILE
  if test 725 -ne `wc -c <'PACKING.LST'`; then
    echo shar: \"'PACKING.LST'\" unpacked with wrong size!
  fi
  # end of 'PACKING.LST'
fi
if test ! -d 'eg' ; then
    echo shar: Creating directory \"'eg'\"
    mkdir 'eg'
fi
if test -f 'eg/capture.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/capture.pl'\"
else
  echo shar: Extracting \"'eg/capture.pl'\" \(1606 characters\)
  sed "s/^X//" >'eg/capture.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
X$d = &dblogin;
X
X&sql($d, "set statistics io on");
X&sql($d, "set statistics time on");
X
X#
X# Count the number off password tables.
X#
X@results = &sql($d, '
X        select count(*) from sysobjects
X        where name = "password" and type = "U"'
X       );
X
X#
X# If there is none create it else truncate it.
X#
Xif(@results[0] == 0) {
X    &sql($d, '
X        create table password(
X            username char(8),
X            uid int,
X            gid int,
X            shell varchar(30),
X            home varchar(30)
X        )'
X    );
X    print "The password table has been created.\n";
X} else {
X    &sql($d, 'truncate table password');
X    print "The password table already exists. Table truncated!\n";
X};
X
X#
X# Read the password entries and add them to the database.
X#
Xwhile (($n,$p,$u,$g,$q,$c,$gc,$d,$s)= getpwent) {
X    print "Adding $n.\n";
X    &sql($d, "
X        insert password
X        values(\"$n\", $u, $g, \"$s\", \"$d\")
X        "
X    );
X};
Xendpwent;
X
X#
X# Count the number off group tables.
X#
X@results = &sql($d, '
X        select count(*) from sysobjects
X        where name = "groups" and type = "U"'
X       );
X
X#
X# If there is none create it else truncate it.
X#
Xif(@results[0] == 0) {
X    &sql($d, '
X        create table groups(
X            groupname char(8),
X            gid int
X        )'
X    );
X    print "The groups table has been created.\n";
X} else {
X    &sql($d, 'truncate table groups');
X    print "The groups table already exists. Table truncated!\n";
X};
X
X#
X# Read the group entries and add them to the database.
X#
Xwhile (($gn,$gp,$gg,$gm)= getgrent) {
X    print "Adding group $gn.\n";
X    &sql($d, "
X        insert groups
X        values(\"$gn\", $gg)
X        "
X    );
X};
Xendgrent;
X
END_OF_FILE
  if test 1606 -ne `wc -c <'eg/capture.pl'`; then
    echo shar: \"'eg/capture.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/capture.pl'
  # end of 'eg/capture.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'\" \(720 characters\)
  sed "s/^X//" >'eg/report.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
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 720 -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 'eg/space.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/space.pl'\"
else
  echo shar: Extracting \"'eg/space.pl'\" \(1384 characters\)
  sed "s/^X//" >'eg/space.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
Xprint "Server: ";
X$server = <>; chop($server);
Xif($server ne '')
X{
X    $ENV{'DSQUERY'};
X}
Xelse
X{
X    $server = $ENV{'DSQUERY'};
X}
X
Xprint "SA password: ";
X$sapw = <>; chop($sapw);
X
X$d = &dblogin("sa", $sapw);
X
X
X$server = $server . '.';
X
X
X&sql($d, "use master");
X@dbs = &sql($d, "select name from sysdatabases order by name");
X
Xforeach $n (@dbs) {
X    &sql($d, "use $n");
X    $x = join('~', &sql($d, 'sp_spaceused'));
X    $x =~ s/ //g;
X    $x =~ s/MB|KB//g;
X    ($name, $size, $res, $data, $index, $free ) = split("~",$x);
X    $unused = $size * 1024 - $res;
X    write;
X    $ts += $size;
X    $tr += $res;
X    $td += $data;
X    $ti += $index;
X    $tf += $free;
X}
X
Xprint '-' x 78, "\n";
X$name = 'TOTAL';
X$size = $ts;
X$res = $tr;
X$data = $td;
X$index = $ti;
X$free = $tf;
X$unused = $size * 1024 - $res;
Xwrite;
X
Xformat top=
XSpace usage per database for server @<<<<<<<<<<<<<<<
X                    $server
XName             Size    Reserved       Data      Index       Free     Unused
X             (MB)        (KB)       (KB)       (KB)       (KB)       (KB)
X-----------------------------------------------------------------------------
X.
Xformat stdout=
X@<<<<<<<<<  @>>>>>>>>  @>>>>>>>>>  @>>>>>>>>  @>>>>>>>>  @>>>>>>>>  @>>>>>>>>
X$name,      $size,     $res,       $data,     $index,    $free,     $unused
X.
X
X
END_OF_FILE
  if test 1384 -ne `wc -c <'eg/space.pl'`; then
    echo shar: \"'eg/space.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/space.pl'
  # end of 'eg/space.pl'
fi
if test -f 'eg/sql.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/sql.pl'\"
else
  echo shar: Extracting \"'eg/sql.pl'\" \(1708 characters\)
  sed "s/^X//" >'eg/sql.pl' <<'END_OF_FILE'
Xsub sql {
X    local($db,$sql,$sep)=@_;            # local copy parameters
X
X    $sep = '~' unless $sep;            # provide default for sep
X
X    @res = ();                    # clear result array
X
X    &dbcmd($db,$sql);                # pass sql to server
X    &dbsqlexec($db);                # execute sql
X
X    while(&dbresults($db) != $NO_MORE_RESULTS) {    # copy all results
X    while (@data = &dbnextrow($db1)) {
X        push(@res,join($sep,@data));
X    }
X    }
X
X    @res;                    # return the result array
X}
X
X
X# Message and error handlers.
X
Xsub sql_message_handler
X{
X    local ($db, $message, $state, $severity, $text, $server, $procedure, $line)
X    = @_;
X
X    if ($severity > 0)
X    {
X    print ("Sybase message ", $message, ", Severity ", $severity,
X           ", state ", $state);
X    print ("\nServer `", $server, "'") if defined ($server);
X    print ("\nProcedure `", $procedure, "'") if defined ($procedure);
X    print ("\nLine ", $line) if defined ($line);
X    print ("\n    ", $text, "\n\n");
X
X# &dbstrcpy returns the command buffer.
X
X    local ($lineno) = 1;    #
X    foreach $row (split (/\n/, &dbstrcpy ($db)))
X    {
X        print (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
X    }
X    }
X    elsif ($message == 0)
X    {
X    print ($text, "\n");
X    }
X
X    0;
X}
X
Xsub sql_error_handler {
X    # Check the error code to see if we should report this.
X    if ($_[2] != &SYBESMSG) {
X    local ($db, $severity, $error, $os_error, $error_msg, $os_error_msg)
X        = @_;
X    print ("Sybase error: ", $error_msg, "\n");
X    print ("OS Error: ", $os_error_msg, "\n") if defined ($os_error_msg);
X    }
X
X    &INT_CANCEL;
X}
X
X
Xif( defined(&dbmsghandle))    # Is this a modern version of sybperl? ;-)
X{
X    &dbmsghandle ("sql_message_handler"); # Some user defined error handlers
X    &dberrhandle ("sql_error_handler");
X}
X
X
X1;
X
END_OF_FILE
  if test 1708 -ne `wc -c <'eg/sql.pl'`; then
    echo shar: \"'eg/sql.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/sql.pl'
  # end of 'eg/sql.pl'
fi
if test ! -d 'lib' ; then
    echo shar: Creating directory \"'lib'\"
    mkdir 'lib'
fi
if test -f 'lib/sybdb.ph' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'lib/sybdb.ph'\"
else
  echo shar: Extracting \"'lib/sybdb.ph'\" \(2788 characters\)
  sed "s/^X//" >'lib/sybdb.ph' <<'END_OF_FILE'
X;#    @(#)sybdb.ph    1.1    11/8/91
X;#
X;#
X
Xsub SYBESYNC {20001;}
Xsub SYBEFCON {20002;}
Xsub SYBETIME {20003;}
Xsub SYBEREAD {20004;}
Xsub SYBEBUFL {20005;}
Xsub SYBEWRIT {20006;}
Xsub SYBEVMS {20007;}
Xsub SYBESOCK {20008;}
Xsub SYBECONN {20009;}
Xsub SYBEMEM {20010;}
Xsub SYBEDBPS {20011;}
Xsub SYBEINTF {20012;}
Xsub SYBEUHST {20013;}
Xsub SYBEPWD {20014;}
Xsub SYBEOPIN {20015;}
Xsub SYBEINLN {20016;}
Xsub SYBESEOF {20017;}
Xsub SYBESMSG {20018;}
Xsub SYBERPND {20019;}
Xsub SYBEBTOK {20020;}
Xsub SYBEITIM {20021;}
Xsub SYBEOOB {20022;}
Xsub SYBEBTYP {20023;}
Xsub SYBEBNCR {20024;}
Xsub SYBEIICL {20025;}
Xsub SYBECNOR {20026;}
Xsub SYBENPRM {20027;}
Xsub SYBEUVDT {20028;}
Xsub SYBEUFDT {20029;}
Xsub SYBEWAID {20030;}
Xsub SYBECDNS {20031;}
Xsub SYBEABNC {20032;}
Xsub SYBEABMT {20033;}
Xsub SYBEABNP {20034;}
Xsub SYBEAAMT {20035;}
Xsub SYBENXID {20036;}
Xsub SYBERXID {20037;}
Xsub SYBEICN {20038;}
Xsub SYBENMOB {20039;}
Xsub SYBEAPUT {20040;}
Xsub SYBEASNL {20041;}
Xsub SYBENTLL {20042;}
Xsub SYBEASUL {20043;}
Xsub SYBERDNR {20044;}
Xsub SYBENSIP {20045;}
Xsub SYBEABNV {20046;}
Xsub SYBEDDNE {20047;}
Xsub SYBECUFL {20048;}
Xsub SYBECOFL {20049;}
Xsub SYBECSYN {20050;}
Xsub SYBECLPR {20051;}
Xsub SYBECNOV {20052;}
Xsub SYBERDCN {20053;}
Xsub SYBESFOV {20054;}
Xsub SYBEUNT {20055;}
Xsub SYBECLOS {20056;}
Xsub SYBEUAVE {20057;}
Xsub SYBEUSCT {20058;}
Xsub SYBEEQVA {20059;}
Xsub SYBEUDTY {20060;}
Xsub SYBETSIT {20061;}
Xsub SYBEAUTN {20062;}
Xsub SYBEBDIO {20063;}
Xsub SYBEBCNT {20064;}
Xsub SYBEIFNB {20065;}
Xsub SYBETTS {20066;}
Xsub SYBEKBCO {20067;}
Xsub SYBEBBCI {20068;}
Xsub SYBEKBCI {20069;}
Xsub SYBEBCRE {20070;}
Xsub SYBETPTN {20071;}
Xsub SYBEBCWE {20072;}
Xsub SYBEBCNN {20073;}
Xsub SYBEBCOR {20074;}
Xsub SYBEBCIS {20075;}
Xsub SYBEBCPI {20076;}
Xsub SYBEBCPN {20077;}
Xsub SYBEBCPB {20078;}
Xsub SYBEVDPT {20079;}
Xsub SYBEBIVI {20080;}
Xsub SYBEBCBC {20081;}
Xsub SYBEBCFO {20082;}
Xsub SYBEBCVH {20083;}
Xsub SYBEBCUO {20084;}
Xsub SYBEBCUC {20085;}
Xsub SYBEBUOE {20086;}
Xsub SYBEBUCE {20087;}
Xsub SYBEBWEF {20088;}
Xsub SYBEASTF {20089;}
Xsub SYBEUACS {20090;}
Xsub SYBEASEC {20091;}
Xsub SYBETMTD {20092;}
Xsub SYBENTTN {20093;}
Xsub SYBEDNTI {20094;}
Xsub SYBEBTMT {20095;}
Xsub SYBEORPF {20096;}
Xsub SYBEUVBF {20097;}
Xsub SYBEBUOF {20098;}
Xsub SYBEBUCF {20099;}
Xsub SYBEBRFF {20100;}
Xsub SYBEBWFF {20101;}
Xsub SYBEBUDF {20102;}
Xsub SYBEBIHC {20103;}
Xsub SYBEBEOF {20104;}
Xsub SYBEBCNL {20105;}
Xsub SYBEBCSI {20106;}
Xsub SYBEBCIT {20107;}
Xsub SYBEBCSA {20108;}
Xsub SYBENULL {20109;}
Xsub SYBEUNAM {20110;}
Xsub SYBEBCRO {20111;}
Xsub SYBEMPLL {20112;}
Xsub SYBERPIL {20113;}
Xsub SYBERPUL {20114;}
Xsub SYBEUNOP {20115;}
Xsub SYBECRNC {20116;}
Xsub SYBERTCC {20117;}
Xsub SYBERTSC {20118;}
Xsub SYBEUCRR {20119;}
Xsub SYBERPNA {20120;}
Xsub SYBEOPNA {20121;}
X
Xsub SUCCEED {1;}
Xsub FAIL {0;}
X
Xsub INT_EXIT {0;}
Xsub INT_CONTINUE {1;}
Xsub INT_CANCEL {2;}
X
X1;
X
END_OF_FILE
  if test 2788 -ne `wc -c <'lib/sybdb.ph'`; then
    echo shar: \"'lib/sybdb.ph'\" unpacked with wrong size!
  fi
  # end of 'lib/sybdb.ph'
fi
if test -f 'lib/sybperl.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'lib/sybperl.pl'\"
else
  echo shar: Extracting \"'lib/sybperl.pl'\" \(464 characters\)
  sed "s/^X//" >'lib/sybperl.pl' <<'END_OF_FILE'
X;#     @(#)sybperl.pl    1.2    11/25/91
X
X;# This file, when interpreted, sets the appropriate environment
X;# variables for Sybase's use DB-Library & isql.
X;#
X;# usage:
X;#    require 'sybperl.pl';
X;#
X;# We don't set the environment if it is already set.
X
Xrequire 'sybdb.ph';
X
X$ENV{'SYBASE'} = "/usr/local/sybase" unless $ENV{'SYBASE'};
X$ENV{'DSQUERY'}= "SYBASE" unless $ENV{'DSQUERY'};
X$ENV{'PATH'}="$ENV{'PATH'}:$ENV{'SYBASE'}/bin" unless $ENV{'PATH'} =~ /$ENV{'SYBASE'}/;
X
X
END_OF_FILE
  if test 464 -ne `wc -c <'lib/sybperl.pl'`; then
    echo shar: \"'lib/sybperl.pl'\" unpacked with wrong size!
  fi
  # end of 'lib/sybperl.pl'
fi
if test -f 'patchlevel.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'patchlevel.h'\"
else
  echo shar: Extracting \"'patchlevel.h'\" \(41 characters\)
  sed "s/^X//" >'patchlevel.h' <<'END_OF_FILE'
X#define VERSION 1
X#define PATCHLEVEL 4
X
X
END_OF_FILE
  if test 41 -ne `wc -c <'patchlevel.h'`; then
    echo shar: \"'patchlevel.h'\" unpacked with wrong size!
  fi
  # end of 'patchlevel.h'
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'\" \(3426 characters\)
  sed "s/^X//" >'sybperl.1' <<'END_OF_FILE'
X.\".po 4
X.TH SYBPERL 1 "3 September 1991"
X.ad
X.nh
X.SH NAME
Xsybperl \- Perl access to Sybase databases
X.SH SYNOPSIS
X.nf
X$dbproc  = &dblogin([$user[, $pwd]])
X$dbproc1 = &dbopen()
X       &dbclose($dbproc)
X$ret     = &dbcmd($dbproc, $sql_cmd)
X$ret     = &dbsqlexec($dbproc)
X$ret     = &dbresults($dbproc)
X@data    = &dbnextrow($dbproc)
X$ret     = &dbuse($dbproc, $database)
X$ret     = &dbcancel($dbproc)
X$ret     = &dbcanquery($dbproc)
X$ret     = &dbexit($dbproc)
X$string  = &dbstrcpy($dbproc)
X$ret     = &dberrhandle($handler)
X$ret     = &dbmsghandle($handler)
X
X$SUCCEED
X$FAIL
X$NO_MORE_ROWS
X$NO_MORE_RESULTS
X$ComputeId
X$DBstatus
X$SybperlVer
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.SH Functions
X\fBSybperl\fP basically maps the calls existing in the \fISybase
XDB-Library\fP to \fIPerl\fP. The usage of these functions is the same
Xas in \fIDB-Library\fP, unless specifically noted.
X
XThe following functions are provided:
X
X.nf
X\fB$dbproc  = &dblogin([$user[, $pwd]])\fP
X\fB&dbproc1 = &dbopen()\fP
X\fB          &dbclose($dbproc)\fP
X\fB$status  = &dbcmd($dbproc, $sql_cmd)\fP
X\fB$status  = &dbsqlexec($dbproc)\fP
X\fB$status  = &dbresults($dbproc)\fP
X\fB@data    = &dbnextrow($dbproc)\fP
X\fB$status  = &dbuse($dbproc, $database)\fP
X\fB$status  = &dbcancel($dbproc)\fP
X\fB$status  = &dbcanquery($dbproc)\fP
X\fB$status  = &dbexit($dbproc)\fP
X\fB$string  = &dbstrcpy($dbproc)\fP
X\fB$old_handler  = &dberrhandle($handler)\fP
X\fB$old_handler  = &dbmsghandle($handler)\fP
X.fi
X
XDifferences with DB-Library:
X
X\fB&dblogin\fP takes 2 optional arguements (the userid and the
Xpassword). These default to the Unix userid, and the null password.
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. Further \fBDBPROCESSes\fP can be opened using
X\fB&dbopen()\fP (No arguments). 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 is optional, and defaults to the DBPROCESS returned
Xby \fB&dblogin\fP.
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).
X
X.SH "UNIMPLEMENTED FEATURES"
X
XThe \fBSYBIMAGE\fP data type is not implemented.
X
XThe \fBSYBTEXT\fP data type is only implemented for reading (ie
X\fIdbmoretext()\fP is not implemented).
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
XOne cannot log in to a specific server (ie \fIdbopen()\fP is always
Xcalled with a \fINULL\fP second parameter. However, setting the
X\fBDSQUERY\fP environment variable (as in \fI$ENV{'DSQUERY'} =
X$server\fP) will work.
X
X.SH OPTIONS
X
XSee the \fIPerl(1)\fP manual page.
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
XMichael Peppler, ITF Management SA \- [e-mail]
END_OF_FILE
  if test 3426 -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' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'sybperl.c'\"
else
  echo shar: Extracting \"'sybperl.c'\" \(23786 characters\)
  sed "s/^X//" >'sybperl.c' <<'END_OF_FILE'
Xstatic char SccsId[] = "@(#)sybperl.c    1.9    12/20/91";
X/************************************************************************/
X/*    Copyright 1991 by Michael Peppler and ITF Management SA     */
X/*                                    */
X/*    Full ownership of this software, and all rights pertaining to     */
X/*    the for-profit distribution of this software, are retained by     */
X/*    Michael Peppler and ITF Management SA.  You are permitted to     */
X/*    use this software without fee.  This software is provided "as     */
X/*    is" without express or implied warranty.  You may redistribute     */
X/*    this software, provided that this copyright notice is retained,    */
X/*    and that the software is not distributed for profit.  If you     */
X/*    wish to use this software in a profit-making venture, you must     */
X/*    first license this code and its underlying technology from     */
X/*    ITF Management SA.                         */
X/*                                    */
X/*    Bottom line: you can have this software, you can use it, you     */
X/*    can give it away.  You just can't sell any or all parts of it     */
X/*    without prior permission from ITF Management SA.        */
X/************************************************************************/
X
X/* sybperl.c
X *
X * Call Sybase DB-Library functions from Perl.
X * Written by Michael Peppler ([e-mail])
X * ITF Management SA, 13 rue de la Fontaine
X * CH-1204 Geneva, Switzerland
X * Tel: [phone] Fax: [phone]
X */
X
X
X/*
X * The Perl/Sybase savestr() conflict.
X * Both Perl and Sybase DB-Library have a function called savestr().
X * This creates a problem when calling dbcmd() and dbuse(). There are
X * several ways to work around this, one of which is to #define
X * BROKEN_DBCMD, which enables some code that I've written to simulate
X * dbcmd() locally. See Makefile and BUGS for details.
X */
X#include "EXTERN.h"
X#include "perl.h"
X#undef MAX
X#undef MIN
X
X#if !defined(VERSION3)
X#define str_2static(s)        str_2mortal(s)
X#endif
X
X#include <sybfront.h>
X#include <sybdb.h>
X#include <syberror.h>
X
X#include "patchlevel.h"
X
Xextern int wantarray;
X
X/*
X * The variables that the Sybase routines set, and that you may want
X * to test in your Perl script. These variables are READ-ONLY.
X */
Xstatic enum uservars
X{
X    UV_SUCCEED,            /* Returns SUCCEED */
X    UV_FAIL,            /* Returns FAIL */
X    UV_NO_MORE_ROWS,        /* Returns NO_MORE_ROWS */
X    UV_NO_MORE_RESULTS,        /* Returns NO_MORE_RESULTS */
X    UV_ComputeId,        /* Returns the compute id of the row (in dbnextrow()) */
X    UV_SybperlVer,        /* Returns Sybperl Version/Patchlevel */
X    UV_DBstatus,        /* The value status value of the last dbnextrow() call */
X};
X
X/*
X * User subroutines that we have implemented. I've found that I can do
X * all the stuff I want to with this subset of DB-Library. Let me know
X * if you implement further routines.
X * The names are self-explanatory.
X */
Xstatic enum usersubs
X{
X    US_dblogin,            /* This also performs the first dbopen()  */
X    US_dbopen,
X    US_dbclose,
X    US_dbcmd,
X    US_dbsqlexec,
X    US_dbresults,
X    US_dbnextrow,
X    US_dbcancel,
X    US_dbcanquery,
X    US_dbexit,
X    US_dbuse,
X#ifdef HAS_CALLBACK
X    US_dberrhandle,
X    US_dbmsghandle,
X#endif
X    US_dbstrcpy,
X};
X
X#ifndef MAX_DBPROCS
X#define MAX_DBPROCS 25        /* Change this if you really want your perl script to talk to */
X                /* more than 25 dataserver connections at a time ...*/
X#endif
X
Xstatic LOGINREC *login;
Xstatic DBPROCESS *dbproc[MAX_DBPROCS];
Xstatic int exitCalled = 0;    /* Set to 1 if dbexit() has been called. */
Xstatic int ComputeId;
Xstatic int DBstatus;        /* Set by dbnextrow() */
X
X/* Stack pointer for the error routines.  This is set to the stack pointer
X   when entering into the sybase subroutines.  Error and message
X   handling needs this.  */
X
Xstatic int perl_sp;
X
X/* Current error handler name. */
X
Xstatic char *err_handler_sub;
X
X/* Current message handler subroutine name */
X
Xstatic char *msg_handler_sub;
X
X/* Macro to access the stack.  This is necessary since error handlers may
X   call perl routines and thus the stack may change.  I hope most compilers
X   will optimize this reasonably. */
X
X#define STACK(SP) (stack->ary_array + (SP))
X
X
Xstatic int usersub();
Xstatic int userset();
Xstatic int userval();
Xstatic int err_handler(), msg_handler();
X
Xint userinit()
X{
X    init_sybase();
X}
X
Xint
Xinit_sybase()
X{
X    struct ufuncs uf;
X    char *filename = "sybase.c";
X
X    if (dbinit() == FAIL)    /* initialize dblibrary */
X    exit(ERREXIT);
X/*
X * Install the user-supplied error-handling and message-handling routines.
X * They are defined at the bottom of this source file.
X */
X    dberrhandle(err_handler);
X    dbmsghandle(msg_handler);
X
X    if(MAX_DBPROCS > 25)
X    dbsetmaxprocs(MAX_DBPROCS);
X
X    uf.uf_set = userset;
X    uf.uf_val = userval;
X
X#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
X
X    MAGICVAR("SUCCEED",    UV_SUCCEED);
X    MAGICVAR("FAIL",UV_FAIL);
X    MAGICVAR("NO_MORE_ROWS",    UV_NO_MORE_ROWS);
X    MAGICVAR("NO_MORE_RESULTS",    UV_NO_MORE_RESULTS);
X    MAGICVAR("ComputeId",    UV_ComputeId);
X    MAGICVAR("SybperlVer",    UV_SybperlVer);
X
X    make_usub("dblogin",    US_dblogin,    usersub, filename);
X    make_usub("dbopen",        US_dbopen,    usersub, filename);
X    make_usub("dbclose",    US_dbclose,    usersub, filename);
X    make_usub("dbcmd",        US_dbcmd,    usersub, filename);
X    make_usub("dbsqlexec",    US_dbsqlexec,    usersub, filename);
X    make_usub("dbresults",    US_dbresults,    usersub, filename);
X    make_usub("dbnextrow",    US_dbnextrow,    usersub, filename);
X    make_usub("dbcancel",    US_dbcancel,    usersub, filename);
X    make_usub("dbcanquery",    US_dbcanquery,    usersub, filename);
X    make_usub("dbexit",    US_dbexit,    usersub, filename);
X    make_usub("dbuse",    US_dbuse,    usersub, filename);
X#ifdef HAS_CALLBACK
X    make_usub("dberrhandle", US_dberrhandle, usersub, filename);
X    make_usub("dbmsghandle", US_dbmsghandle, usersub, filename);
X#endif
X    make_usub("dbstrcpy", US_dbstrcpy, usersub, filename);
X
X}
X
Xstatic int
Xusersub(ix, sp, items)
Xint ix;
Xregister int sp;
Xregister int items;
X{
X    STR **st = stack->ary_array + sp;
X    ARRAY *ary = stack;
X    register int i;
X    register STR *Str;        /* used in str_get and str_gnum macros */
X    int inx = -1;        /* Index into dbproc[] array. Passed as first parameter to nearly all &dbxxx() calls */
X
X
X    if(exitCalled)
X    fatal("&dbexit() has been called. Access to Sybase impossible.");
X
X    perl_sp = sp + items;
X
X    /*
X     * We're calling some dblib function, but dblogin has not been
X     * called. Two actions are possible: either fail the call, or call
X     * dblogin/dbopen with the default info. The second option is used
X     * to keep backwards compatibility with an older version of
X     * sybperl. A call to fatal(msg) is probably better.
X     */
X    if(!login && (ix != US_dblogin) && (ix != US_dbmsghandle) && (ix != US_dberrhandle))
X    {                /* You can call &dbmsghandle/errhandle before calling &dblogin */
X#ifdef OLD_SYBPERL
X    login = dblogin();
X    dbproc[0] = dbopen(login, NULL);
X#else
X    fatal("&dblogin has not been called yet!");
X#endif
X    }
X
X    switch (ix)
X    {
X      case US_dblogin:
X    if (items > 2)
X        fatal("Usage: &dblogin([user[,pwd]])");
X    if (login)
X        fatal("&dblogin() called twice.");
X    else
X    {
X        int retval;
X
X        login = dblogin();
X        if(items)
X        {
X        DBSETLUSER(login, (char *)str_get(STACK(sp)[1]));
X        if(items > 1)
X            DBSETLPWD(login, (char *)str_get(STACK(sp)[2]));
X        }
X
X        dbproc[0] = dbopen(login, NULL);
X        str_numset(STACK(sp)[0], (double) 0);
X    }
X    break;
X      case US_dbopen:
X    if (items != 0)
X        fatal("Usage: $dbproc = &dbopen;");
X    else
X    {
X        int j;
X        for(j = 0; j < MAX_DBPROCS; ++j)
X        if(dbproc[j] == NULL)
X            break;
X        if(j == MAX_DBPROCS)
X        fatal("&dbopen: No more dbprocs available.");
X        dbproc[j] = dbopen(login, NULL);
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X      case US_dbclose:
X    if (items != 1)
X        fatal("Usage: $ret = &dbclose($dbproc);");
X    else
X    {
X        inx = getDbProc(STACK(sp)[1]);
X
X        dbclose(dbproc[inx]);
X        dbproc[inx] = (DBPROCESS *)NULL;
X    }
X    break;
X      case US_dbcancel:
X    if (items > 1)
X        fatal("Usage: &dbcancel($dbproc)");
X    else
X    {
X        int retval;
X#if defined(BROKEN_DBCMD)
X        DBSTRING *ptr;
X        DBSTRING *old;
X#endif
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        retval = dbcancel(dbproc[inx]);
X        str_numset(STACK(sp)[0], (double) retval);
X#if defined(BROKEN_DBCMD)
X        ptr = dbproc[inx]->dbcmdbuf;
X        while(ptr)
X        {
X        old = ptr;
X        ptr = ptr->strnext;
X        free(old->strtext);
X        free(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X#endif
X    }
X    break;
X
X      case US_dbcanquery:
X    if (items > 1)
X        fatal("Usage: &dbcanquery($dbproc)");
X    else
X    {
X        int retval;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        retval = dbcanquery(dbproc[inx]);
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X
X      case US_dbexit:
X    if (items != 0)
X        fatal("Usage: &dbexit()");
X    else
X    {
X        dbexit(dbproc[0]);
X        exitCalled++;
X        str_numset(STACK(sp)[0], (double) 1);
X    }
X    break;
X
X      case US_dbuse:
X    if (items > 2)
X        fatal("Usage: &dbuse($dbproc, $database)");
X    else
X    {
X#if defined(BROKEN_DBCMD)
X        /*
X         * Why doesn't this $@#! dbuse() call not work from within
X         * Perl????? (So we emulate it here, but I sure can't
X         * guarantee anything about portability to future versions
X         * of DB-Library!
X         */
X        DBSTRING *new;
X        DBSTRING *sav;
X        char buff[256];
X        int ret, 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
X        strcpy(buff, "use ");
X        strcat(buff, (char *)str_get(STACK(sp)[off]));
X        sav = dbproc[inx]->dbcmdbuf;
X
X        Newz(902, new, 1, DBSTRING);
X        New(902, new->strtext, strlen(buff) + 1, BYTE);
X        strcpy(new->strtext, buff);
X        new->strtotlen = strlen(new->strtext)+1;
X        dbproc[inx]->dbcmdbuf = new;
X
X        ret = dbsqlexec(dbproc[inx]);
X        ret = dbresults(dbproc[inx]);
X        while((ret = dbnextrow(dbproc[inx])) != NO_MORE_ROWS)
X        ;
X
X        Safefree(new->strtext);
X        Safefree(new);
X
X        dbproc[inx]->dbcmdbuf = sav;
X        str_numset(STACK(sp)[0], (double) SUCCEED);
X#else
X        int retval, off;
X        char str[255];
X
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X        strcpy(str, (char *)str_get(STACK(sp)[off]));
X
X
X        retval = dbuse(dbproc[inx], str);
X        str_numset(STACK(sp)[0], (double) retval);
X#endif
X    }
X    break;
X
X      case US_dbsqlexec:
X    if (items > 1)
X        fatal("Usage: &dbsqlexec($dbproc)");
X    else
X    {
X        int retval;
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        retval = dbsqlexec(dbproc[inx]);
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X
X      case US_dbresults:
X    if (items > 1)
X        fatal("Usage: &dbresults($dbproc)");
X    else
X    {
X        int retval;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        retval = dbresults(dbproc[inx]);
X        str_numset(STACK(sp)[0], (double) retval);
X#if defined(BROKEN_DBCMD)
X        if(retval==NO_MORE_RESULTS)
X        {
X        DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
X        DBSTRING *old;
X
X        while(ptr)
X        {
X            old = ptr;
X            ptr = ptr->strnext;
X            Safefree(old->strtext);
X            Safefree(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X        }
X#endif
X    }
X    break;
X
X      case US_dbcmd:
X    if (items > 2)
X        fatal("Usage: &dbcmd($dbproc, $str)");
X    else
X    {
X        int retval, off;
X#if defined(BROKEN_DBCMD)
X        DBSTRING *ptr;
X        DBSTRING *new, *old;
X        char *strdup();
X#endif
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X
X#if defined(BROKEN_DBCMD)
X        ptr = dbproc[inx]->dbcmdbuf;
X
X        Newz(902, new, 1, DBSTRING);
X        New(902, new->strtext, strlen((char *)str_get(STACK(sp)[off])) + 1, BYTE);
X        strcpy(new->strtext, (char *)str_get(STACK(sp)[off]));
X        new->strtotlen = strlen(new->strtext)+1;
X        if(!ptr)
X        dbproc[inx]->dbcmdbuf = new;
X        else
X        {
X        while(ptr->strnext)
X            ptr = ptr->strnext;
X        ptr->strnext = new;
X        }
X#else
X        retval = dbcmd(dbproc[inx], (char *)str_get(STACK(sp)[off]));
X#endif
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X
X    case US_dbnextrow:
X    if (items > 1)
X        fatal("Usage: @arr = &dbnextrow($dbproc)");
X    else
X    {
X        int retval;
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        --sp;        /* otherwise you get an empty element at the beginning of the results array! */
X
X        DBstatus = retval = dbnextrow(dbproc[inx]);
X        if(retval == REG_ROW)
X        {
X            char buff[1024], *p = NULL, *t;
X        BYTE *data;
X        int col, type, numcols = dbnumcols(dbproc[inx]);
X        int len;
X        DBFLT8 tmp;
X
X        ComputeId = 0;
X
X        for(col = 1, buff[0] = 0; col <= numcols; ++col)
X        {
X            type = dbcoltype(dbproc[inx], col);
X            len = dbdatlen(dbproc[inx],col);
X            data = (BYTE *)dbdata(dbproc[inx],col);
X            t = &buff[0];
X            if(!data && !len)
X            {
X            strcpy(buff,"NULL");
X            }
X            else
X            {
X            switch(type)
X            {
X              case SYBCHAR:
X                strncpy(buff,data,len);
X                buff[len] = 0;
X                break;
X              case SYBTEXT:
X                New(902, p, len + 1, char);
X                strncpy(p, data, len);
X                p[len] = 0;
X                t = p;
X                break;
X              case SYBINT1:
X              case SYBBIT: /* a bit is at least a byte long... */
X                sprintf(buff,"%u",*(unsigned char *)data);
X                break;
X              case SYBINT2:
X                sprintf(buff,"%d",*(short *)data);
X                break;
X              case SYBINT4:
X                sprintf(buff,"%d",*(long *)data);
X                break;
X              case SYBFLT8:
X                sprintf(buff,"%.6f",*(double *)data);
X                break;
X              case SYBMONEY:
X                dbconvert(dbproc[inx], SYBMONEY, data, len, SYBFLT8, &tmp, -1);
X                sprintf(buff,"%.6f",tmp);
X                break;
X              case SYBDATETIME:
X                dbconvert(dbproc[inx], SYBDATETIME, data, len, SYBCHAR, buff, -1);
X                break;
X              case SYBBINARY:
X                dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
X                break;
X              default:
X                /* ignored for the moment */
X                break;
X            }
X            }
X            (void)astore(ary,++sp,str_2static(str_make(t, 0)));
X            /*
X             * If we've allocated some space to retrieve a
X             * SYBTEXT field, then free it now.
X             */
X            if(t == p)
X            {
X            Safefree(p);
X            p = NULL;
X            }
X        }
X        }
X        if (retval > 0)
X        {
X            char buff[1024], *p = NULL, *t;
X        BYTE *data;
X        int col, type, numcols;
X        int len;
X        DBFLT8 tmp;
X
X        ComputeId = retval;
X        numcols = dbnumalts(dbproc[inx], ComputeId);
X
X        for(col = 1, buff[0] = 0; col <= numcols; ++col)
X        {
X            type = dbalttype(dbproc[inx], ComputeId, col);
X            len = dbadlen(dbproc[inx], ComputeId, col);
X            data = (BYTE *)dbadata(dbproc[inx], ComputeId, col);
X            t = &buff[0];
X            if(!data && !len)
X            {
X            strcpy(buff,"NULL");
X            }
X            else
X            {
X            switch(type)
X            {
X              case SYBCHAR:
X                strncpy(buff,data,len);
X                buff[len] = 0;
X                break;
X              case SYBTEXT:
X                New(902, p, len + 1, char);
X                strncpy(p, data, len);
X                p[len] = 0;
X                t = p;
X                break;
X              case SYBINT1:
X              case SYBBIT: /* a bit is at least a byte long... */
X                sprintf(buff,"%d",*(char *)data);
X                break;
X              case SYBINT2:
X                sprintf(buff,"%d",*(short *)data);
X                break;
X              case SYBINT4:
X                sprintf(buff,"%d",*(long *)data);
X                break;
X              case SYBFLT8:
X                sprintf(buff,"%.6f",*(double *)data);
X                break;
X              case SYBMONEY:
X                dbconvert(dbproc[inx], SYBMONEY, data, len, SYBFLT8, &tmp, -1);
X                sprintf(buff,"%.6f",tmp);
X                break;
X              case SYBDATETIME:
X                dbconvert(dbproc[inx], SYBDATETIME, data, len, SYBCHAR, buff, -1);
X                break;
X              case SYBBINARY:
X                dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
X                break;
X              default:
X                /* ignored at the moment... */
X                break;
X            }
X            }
X            (void)astore(ary,++sp,str_2static(str_make(t, 0)));
X            /*
X             * If we've allocated some space because the field
X             * was a text field, then free it now:
X             */
X            if(t == p)
X            {
X            Safefree(p);
X            p = NULL;
X            }
X
X        }
X        }
X#if defined(BROKEN_DBCMD)
X        /*
X         * We can't rely on dbcmd(),dbresults() etc. to clean up
X         * the dbcmdbuf linked list, so we have to it ourselves...
X         */
X        if(retval == NO_MORE_ROWS && !DBMORECMDS(dbproc[inx]))
X        {
X        DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
X        DBSTRING *new, *old;
X
X        while(ptr)
X        {
X            old = ptr;
X            ptr = ptr->strnext;
X            Safefree(old->strtext);
X            Safefree(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X        }
X#endif
X    }
X    break;
X#ifdef HAS_CALLBACK
X      case US_dberrhandle:
X    if (items > 1)
X        fatal ("Usage: &dberrhandle($handler)");
X    else
X    {
X        char *old = err_handler_sub;
X        if (items == 1)
X        {
X        if (STACK (sp)[1] == &str_undef)
X            err_handler_sub = 0;
X        else
X        {
X            char *sub = (char *) str_get (STACK (sp)[1]);
X            New (902, err_handler_sub, strlen (sub) + 1, char);
X            strcpy (err_handler_sub, sub);
X        }
X        }
X
X        if (old)
X        {
X        STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
X        if (items == 1)
X            Safefree (old);
X        }
X        else
X        STACK (sp)[0] = &str_undef;
X    }
X    break;
X      case US_dbmsghandle:
X    if (items > 1)
X        fatal ("Usage: &dbmsghandle($handler)");
X    else
X    {
X        char *old = msg_handler_sub;
X        if (items == 1)
X        {
X        if (STACK (sp)[1] == &str_undef)
X            msg_handler_sub = 0;
X        else
X        {
X            char *sub = (char *) str_get (STACK (sp)[1]);
X            New (902, msg_handler_sub, strlen (sub) + 1, char);
X            strcpy (msg_handler_sub, sub);
X        }
X        }
X
X        if (old)
X        {
X        STACK (sp)[0] = str_2mortal (str_make (old, strlen (old)));
X        if (items == 1)
X            Safefree (old);
X        }
X        else
X        STACK (sp)[0] = &str_undef;
X    }
X    break;
X#endif                /* HAS_CALLBACK */
X      case US_dbstrcpy:
X    if (items > 1)
X        fatal("Usage: $string = &dbstrcpy($dbproc)");
X    else
X    {
X        int retval, len;
X        char *buff;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx] && (len = dbstrlen(dbproc[inx])))
X        {
X        New(902, buff, len+1, char);
X        retval = dbstrcpy(dbproc[inx], 0, -1, buff);
X        str_set(STACK(sp)[0], buff);
X        Safefree(buff);
X        }
X        else
X        str_set(STACK(sp)[0], "");
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 all
X * READ-ONLY in Perl.
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     }
X    return 0;
X}
X
Xstatic int
Xuserset(ix, str)        /* Not used. None of these variables are user-settable */
Xint ix;
XSTR *str;
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])
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])
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 */
Xint getDbProc(Str)
X    STR *Str;
X{
X    int ix = (int)str_gnum(Str);
X
X    if(ix < 0 || ix >= MAX_DBPROCS)
X    fatal("$dbproc parameter is out of range.");
X    return ix;
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
END_OF_FILE
  if test 23786 -ne `wc -c <'sybperl.c'`; then
    echo shar: \"'sybperl.c'\" unpacked with wrong size!
  fi
  # end of 'sybperl.c'
fi
if test ! -d 't' ; then
    echo shar: Creating directory \"'t'\"
    mkdir 't'
fi
if test -f 't/sbex.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'t/sbex.pl'\"
else
  echo shar: Extracting \"'t/sbex.pl'\" \(4974 characters\)
  sed "s/^X//" >'t/sbex.pl' <<'END_OF_FILE'
X#!../sybperl
X
X
X@nul = ('not null','null');
X@sysdb = ('master', 'model', 'tempdb');
X
Xrequire "../lib/sybperl.pl";
Xrequire "../lib/sybdb.ph";
X
Xprint "Sybperl version $SybperlVer\n\n";
X
Xprint "This script tests some of sybperl's functions, and prints out\n";
Xprint "description of the databases that are defined in your Sybase\n";
Xprint "dataserver.\n\n";
X
X
X$dbproc = &dblogin("sa");    # Login to sybase
X&dbmsghandle ("message_handler"); # Some user defined error handlers
X&dberrhandle ("error_handler");
X
X$dbproc2 = &dbopen;        # Get a second dbprocess, so that we can select from several
X                                # chanels simultaneously. We could code things so that this
X                # feature is unnecessary, but it's good to exercise it.
X
X                # First, find out what databases exist:
X&dbcmd($dbproc, "select name from sysdatabases order by crdate\n");
X&dbsqlexec($dbproc);
X&dbresults($dbproc);
X
Xdatabase: while((@db = &dbnextrow($dbproc)))
X{
X    foreach $nm (@sysdb)
X    {
X    if($db[0] =~ /$nm/)
X    {
X        print "'$db[0]' is a system database\n";
X        next database;
X    }
X    }
X    print "Finding user tables in user database $db[0]...";
X
X    &dbcmd($dbproc2, "select o.name, u.name, o.id\n"); #
X    &dbcmd($dbproc2, "from $db[0].dbo.sysobjects o, $db[0].dbo.sysusers u\n");
X    &dbcmd($dbproc2, "where o.type = 'U' and u.uid = o.uid\n");
X    &dbcmd($dbproc2, "order by o.name\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@dat = &dbnextrow($dbproc2)))
X    {
X    $tab = join('@', @dat);    # Save the information
X    push(@tables, $tab);    # for later use...
X    }
X    print "Done.\n";
X
X    print "Finding user defined datatypes in database $db[0]...\n";
X
X    &dbcmd($dbproc2, "select s.length,substring(s.name,1,30),substring(st.name,1,30)\n");
X    &dbcmd($dbproc2, "from $db[0].dbo.systypes s, $db[0].dbo.systypes st\n");
X    &dbcmd($dbproc2, "where  st.type = s.type\n");
X    &dbcmd($dbproc2, "and s.usertype > 100 and st.usertype < 100 and st.usertype != 18\n");
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@dat = &dbnextrow($dbproc2)))
X    {
X    print "sp_addtype $dat[1],";
X    if ($dat[2] =~ /char|binary/)
X    {
X        print "'$dat[2]($dat[0])'";
X    }
X    else
X    {
X        print "$dat[2]";
X    }
X    print "\n";
X
X    }
X    print "Done.\n";
X
X    print "Now we find the table definition for each user table\nin database $db[0]...\n";
X
X    foreach $ln (@tables)        # For each line in the list
X    {
X    @tab = split('@',$ln);
X
X    &dbcmd($dbproc2, "select Column_name = c.name, \n");
X    &dbcmd($dbproc2, "       Type = t.name, \n");
X    &dbcmd($dbproc2, "       Length = c.length, \n");
X    &dbcmd($dbproc2, "       Nulls = convert(bit, (c.status & 8))\n");
X    &dbcmd($dbproc2, "from   $db[0].dbo.syscolumns c, $db[0].dbo.systypes t\n");
X    &dbcmd($dbproc2, "where  c.id = $tab[2]\n");
X    &dbcmd($dbproc2, "and    c.usertype *= t.usertype\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    print "\nTABLE $db[0].$tab[1].$tab[0]\n (";
X    $first = 1;
X    while((@field = &dbnextrow($dbproc2)))
X    {
X        print ",\n" if !$first;        # add a , and a \n if not first field in table
X
X        print "\t$field[0] \t$field[1]";
X        print "($field[2])" if $field[1] =~ /char|bin/;
X        print " $nul[$field[3]]";
X
X        $first = 0 if $first;
X    }
X    print " )\n";
X
X# now get the indexes...
X#
X    print "\nIndexes on $db[0].$tab[0].$tab[1]...\n\n";
X    &dbuse($dbproc2, $db[0]);
X    &dbcmd($dbproc2, "sp_helpindex '$tab[1].$tab[0]'\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@field = &dbnextrow($dbproc2)))
X    {
X        print "unique " if $field[1] =~ /unique/;
X        print "clustered " if $field[1] =~ /^clust/;
X        print "index $field[0]\n";
X        @col = split(/,/,$field[2]);
X        print "on $db[0].$tab[1].$tab[0] (";
X        $first = 1;
X        foreach $ln1 (@col)
X        {
X        print ", " if !$first;
X        $first = 0;
X        print "$ln1";
X        }
X        print ")\n";
X    }
X    print "\nDone.\n";
X    }
X    &dbuse($dbproc2, "master");
X    @tables = ();
X}
X
X&dbexit;
X
X
X# Message and error handlers.
X
Xsub message_handler
X{
X    local ($db, $message, $state, $severity, $text, $server, $procedure, $line)
X    = @_;
X
X    if ($severity > 0)
X    {
X    print ("Sybase message ", $message, ", Severity ", $severity,
X           ", state ", $state);
X    print ("\nServer `", $server, "'") if defined ($server);
X    print ("\nProcedure `", $procedure, "'") if defined ($procedure);
X    print ("\nLine ", $line) if defined ($line);
X    print ("\n    ", $text, "\n\n");
X
X# &dbstrcpy returns the command buffer.
X
X    local ($lineno) = 1;    #
X    foreach $row (split (/\n/, &dbstrcpy ($db)))
X    {
X        print (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
X    }
X    }
X    elsif ($message == 0)
X    {
X    print ($text, "\n");
X    }
X
X    0;
X}
X
Xsub error_handler {
X    # Check the error code to see if we should report this.
X    if ($_[2] != &SYBESMSG) {
X    local ($db, $severity, $error, $os_error, $error_msg, $os_error_msg)
X        = @_;
X    print ("Sybase error: ", $error_msg, "\n");
X    print ("OS Error: ", $os_error_msg, "\n") if defined ($os_error_msg);
X    }
X
X    &INT_CANCEL;
X}
X
X
X
END_OF_FILE
  if test 4974 -ne `wc -c <'t/sbex.pl'`; then
    echo shar: \"'t/sbex.pl'\" unpacked with wrong size!
  fi
  chmod +x 't/sbex.pl'
  # end of 't/sbex.pl'
fi
echo shar: End of archive 1 \(of 1\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have the archive.
    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...