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

Text File | 1993-05-04 | 53.3 KB | 1,998 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Michael Peppler)
Subject: v37i033:  sybperl - Sybase DB-library extensions to Perl, v1.6, Part01/02
Message-ID: <csm-v37i033=[e-mail]>
X-Md4-Signature: 7715119c3a5bb5d4ddf90672f2e3cb6b
Date: Wed, 28 Apr 1993 16:41:32 GMT
Approved: [e-mail]

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

This is Sybperl release 1.6.

Sybperl is an extension to Perl which allows you to access Sybase
databases directly from Perl scripts using standard OpenClient (aka
DB-Library) calls.

>From the CHANGES file:
    1.006    Added contributed patches: &dbwritetext(),
        &dbsafestr() and a modified &dblogin().
        Added &dbhasretstats() and &dbretstatus(), as well as
        some calls to DBlib macros such as DBCMD(),
        DBMORECMD(), etc.
        Received a patch to eg/space.pl from Wolfgang Richter.
        Code that was defined to compile if BROKER_DBCMD was
        defined has been removed. It was only a hack, making
        use of knowledge of the structure of the DBPROCESS
        data type.
        Added the possibility to return an associative array
        from &dbnextrow.
        Added support for new datatypes (SYBREAL, SYBDATETIME4).
        NULL values retrieved using &dbnextrow can be returned
        as 'undef' instead of 'NULL' (this is a compile-time
        option).

--
Michael Peppler                           [e-mail]
ITF Management SA                      [e-mail]
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".
# Contents:  README Makefile eg eg/dbschema.pl lib patchlevel.h
#   sybperl.1 sybperl.c t
# Wrapped by kent@sparky on Wed Apr 28 08:40:08 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 1 (of 2)."'
if test -f 'README' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'README'\"
else
  echo shar: Extracting \"'README'\" \(3696 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 (4.035 strongly suggested!).
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       DBLIB42          If this Makefile macro is defined, then the
X             newer datatypes (such as SYBREAL) will be
X             handled correctly, and dbsafestr() will be
X             implemented.
X       SET_VAL         If this macro is set, then attempts to set a
X             Sybperl user-variable (such as
X             $NO_MORE_RESULTS) will result in a fatal
X             error. Otherwise such attempts are silently
X             ignored.
X       NULL_UNDEF     If this macro is set, then NULL values
X             returned from a select statement will be
X             returned as 'undef' values. Otherwise, they
X             are returned as the string 'NULL'.
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.035
X
X   BUGS:
X
X   Both DBlibrary and Perl define a symbol named 'savestr', resulting
X   in the Perl version being called from DBlibrary. See the BUGS file
X   for ways to get around this problem.
X
X   Memory usage can also be a problem in certain cases. Again see the
X   BUGS file for details.
X
X   BCP functions are not available, but would probably be useful.
X
X   Access to IMAGE datatypes isn't handled in &dbnextrow().
X
X
X
X
X   Have fun using it and let me know of any improvements, problems,
X   whatever...
X
X   Michael Peppler            [e-mail]    [e-mail]
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, and suggesting
X   improvements:
X
X   Teemu Torma            Brent Milnor
X   Matthew Merzbacher        Eric Fifer
X   Dan Banay            Mark Lawrence
X   Jeffrey Wong            Wolfgang Richter
X   Anders Ardo            Gijs Mos
X   Minh Ton Ha            G. Roderick Singleton
X   Peter Gutmann
X
END_OF_FILE
  if test 3696 -ne `wc -c <'README'`; then
    echo shar: \"'README'\" unpacked with wrong size!
  fi
  # end of 'README'
fi
if test -f 'Makefile' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Makefile'\"
else
  echo shar: Extracting \"'Makefile'\" \(3245 characters\)
  sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X#    @(#)Makefile    1.13    4/6/93
X#
X
XCC = gcc
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#    - Recompile uperl.o with a -Dsavestr=psvestr (or something similar).
X#    - Edit an existing uperl.o and change _savestr to _psvestr.
X#
X#
X# To use the first 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
X#DBLIB42 = -DDBLIB42            # Comment this if your version
X                    # of DBlib is older than
X                    # version 4.2
X
X#SET_VAL = -DUSERVAL_SET_FATAL        # Uncomment this if you wish
X                    # to get a fatal error message
X                    # if you attempt to set on of
X                    # Sybperl's variables from a
X                    # script. Normally such
X                    # actions are silently ignored.
X
X#NULL_UNDEF = -DNULL_IS_UNDEF           # Uncomment this to get
X                    # 'undef' values returned by
X                    # &dbnextrow when NULL values
X                    # are retrieved. Otherwise,
X                    # the string 'NULL' is returned.
X
XCFLAGS = -O2 -g
XCPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) \
X        $(SAVESTR) $(HAS_CALLBACK) $(OLD_SYBPERL) $(DBLIB42) \
X        $(SET_VAL)
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    rm -f $(UPERL).bak
X
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 \
X    eg/dbschema.pl eg/dbtext.pl eg/README >sybperl.shar
X
X
Xtar:
X    rm -f sybperl.tar
X    tar cvfB sybperl.tar 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 \
X    eg/dbschema.pl eg/dbtext.pl eg/README
X
X
X
X
X
END_OF_FILE
  if test 3245 -ne `wc -c <'Makefile'`; then
    echo shar: \"'Makefile'\" unpacked with wrong size!
  fi
  # end of 'Makefile'
fi
if test ! -d 'eg' ; then
    echo shar: Creating directory \"'eg'\"
    mkdir 'eg'
fi
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'\" \(9358 characters\)
  sed "s/^X//" >'eg/dbschema.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X#
X#    @(#)dbschema.pl    1.3    6/24/92
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($dproc, $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 9358 -ne `wc -c <'eg/dbschema.pl'`; then
    echo shar: \"'eg/dbschema.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/dbschema.pl'
  # end of 'eg/dbschema.pl'
fi
if test ! -d 'lib' ; then
    echo shar: Creating directory \"'lib'\"
    mkdir 'lib'
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 6
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'\" \(5452 characters\)
  sed "s/^X//" >'sybperl.1' <<'END_OF_FILE'
X.\".po 4
X.TH SYBPERL 1 "2 April 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$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$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$DBReturnAssoc
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[, $server]]])\fP
X\fB&dbproc1 = &dbopen([$server])\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 [, $doAssoc])\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$string  = &dbsafestr($dbproc,$instring[,$quote_char])\fP
X\fB$old_handler  = &dberrhandle($handler)\fP
X\fB$old_handler  = &dbmsghandle($handler)\fP
X\fB$status  = &dbwritetext($dbproc_1, $col_name, $select_proc,
X$select_col, $text)\fP
X.fi
X
XDifferences with DB-Library:
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 and
X\fB&dbwritetext()\fP require explicit \fB$dbproc\fP parameters.)
X
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.
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\f and
X\fI$select_col\fP are the dbproc and column number of a currently
Xactive query. Logging is always off.
X
X
X.SH "UNIMPLEMENTED FEATURES"
X
XThe \fBSYBIMAGE\fP data type 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
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
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]
XBrent Milnor ([e-mail]) contributed &dbwritetext().
XEric Fifer ([e-mail]) contributed corrections to the
X&dblogin()/&dbopen() sequence
XMark Lawrence ([e-mail]) contributed &dbsafestr().
END_OF_FILE
  if test 5452 -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'\" \(25807 characters\)
  sed "s/^X//" >'sybperl.c' <<'END_OF_FILE'
Xstatic char SccsId[] = "@(#)sybperl.c    1.14    4/6/93";
X/************************************************************************/
X/*    Copyright 1991, 1992, 1993 by Michael Peppler            */
X/*                               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#include "EXTERN.h"
X#include "perl.h"
X#undef MAX
X#undef MIN
X
X#if defined(VERSION3)
X#define str_2mortal(s)        str_2static(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    US_DBMORECMDS,
X    US_DBCMDROW,
X    US_DBROWS,
X    US_DBCOUNT,
X    US_DBCURCMD,
X    US_dbhasretstat,
X    US_dbretstatus,
X#if defined(DBLIB42)
X    US_dbsafestr,
X#endif
X    US_dbwritetext,
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() */
Xstatic int DBReturnAssoc;    /* If true, dbnextrow returns an associative array */
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    make_usub("DBCURCMD", US_DBCURCMD, usersub, filename);
X    make_usub("DBMORECMDS", US_DBMORECMDS, usersub, filename);
X    make_usub("DBCMDROW", US_DBCMDROW, usersub, filename);
X    make_usub("DBROWS", US_DBROWS, usersub, filename);
X    make_usub("DBCOUNT", US_DBCOUNT, usersub, filename);
X    make_usub("dbhasretstat", US_dbhasretstat, usersub, filename);
X    make_usub("dbretstatus", US_dbretstatus, usersub, filename);
X#if defined(DBLIB42)
X    make_usub("dbsafestr", US_dbsafestr, usersub, filename);
X#endif
X    make_usub("dbwritetext", US_dbwritetext, usersub, filename);
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 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 > 3)
X        fatal("Usage: &dblogin([user[,pwd[,server]]])");
X    else
X    {
X        int j = 0;
X        char *server = NULL, *user = NULL, *pwd = NULL;
X
X        if (!login)
X        login = dblogin();
X        switch(items)
X        {
X          case 3:
X        server = (char *)str_get(STACK(sp)[3]);
X          case 2:
X        if(STACK(sp)[2] != &str_undef)
X        {
X            pwd = (char *)str_get(STACK(sp)[2]);
X            if(pwd && strlen(pwd))
X            DBSETLPWD(login, pwd);
X        }
X          case 1:
X        if(STACK(sp)[1] != &str_undef)
X        {
X            user = (char *)str_get(STACK(sp)[1]);
X            if(user && strlen(user))
X            DBSETLUSER(login, user);
X        }
X        }
X
X        for(j = 0; j < MAX_DBPROCS; ++j)
X        if(dbproc[j] == NULL)
X            break;
X        if(j == MAX_DBPROCS)
X        fatal ("&dblogin: No more dbprocs available.");
X        if((dbproc[j] = dbopen(login, server)) == NULL)
X        j = -1;
X
X        str_numset(STACK(sp)[0], (double) j);
X    }
X    break;
X      case US_dbopen:
X    if (items > 1)
X        fatal("Usage: $dbproc = &dbopen([server]);");
X    else
X    {
X        int j;
X        char *server = NULL;
X
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        if(items == 1)
X        server = (char *)str_get(STACK(sp)[1]);
X
X        dbproc[j] = dbopen(login, server);
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
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    }
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        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    }
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    }
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
X        if(items == 2)
X        {
X        inx = getDbProc(STACK(sp)[1]);
X        off = 2;
X        }
X        else
X        inx = 0, off = 1;
X        retval = dbcmd(dbproc[inx], (char *)str_get(STACK(sp)[off]));
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X
X    case US_dbnextrow:
X    if (items > 2)
X        fatal("Usage: @arr = &dbnextrow([$dbproc [, $returnAssoc]])");
X    else
X    {
X        int retval;
X        char buff[1024], *p = NULL, *t;
X        BYTE *data;
X        int col, type, numcols;
X        int len;
X        int doAssoc = 0;
X        DBFLT8 tmp;
X        char *colname;
X        char cname[64];
X
X        inx = 0;
X        switch(items)
X        {
X          case 2:
X        doAssoc = (int)str_gnum(STACK(sp)[2]);
X          case 1:
X        inx = getDbProc(STACK(sp)[1]);
X        break;
X        }
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        ComputeId = 0;
X        numcols = dbnumcols(dbproc[inx]);
X        }
X        else
X        {
X        ComputeId = retval;
X        numcols = dbnumalts(dbproc[inx], ComputeId);
X        }
X        for(col = 1, buff[0] = 0; col <= numcols; ++col)
X        {
X        colname = NULL;
X        if(!ComputeId)
X        {
X            type = dbcoltype(dbproc[inx], col);
X            len = dbdatlen(dbproc[inx],col);
X            data = (BYTE *)dbdata(dbproc[inx],col);
X            colname = dbcolname(dbproc[inx], col);
X            if(!colname || !colname[0])
X            {
X            sprintf(cname, "Col %d", col);
X            colname = cname;
X            }
X        }
X        else
X        {
X            int colid = dbaltcolid(dbproc[inx], ComputeId, col);
X            type = dbalttype(dbproc[inx], ComputeId, col);
X            len = dbadlen(dbproc[inx], ComputeId, col);
X            data = (BYTE *)dbadata(dbproc[inx], ComputeId, col);
X            if(colid > 0)
X            colname = dbcolname(dbproc[inx], colid);
X            if(!colname || !colname[0])
X            {
X            sprintf(cname, "Col %d", col);
X            colname = cname;
X            }
X        }
X        t = &buff[0];
X        if(!data && !len)
X        {
X#if defined(NULL_IS_UNDEF)
X            t = &str_undef;
X#else
X            strcpy(buff,"NULL");
X#endif
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#if defined(DBLIB42)
X              case SYBREAL:
X            sprintf(buff, "%.6f", *(float *)data);
X            break;
X              case SYBDATETIME4:
X            dbconvert(dbproc[inx], SYBDATETIME4, data, len, SYBCHAR, buff, -1);
X            break;
X#endif
X              case SYBIMAGE:
X            fatal ("&dbnextrow: SYBIMAGE datatypes are not handled at the moment!");
X            break;
X
X              default:
X            /*
X             * WARNING!
X             *
X             * We convert unknown data types to SYBCHAR
X             * without checking to see if the resulting
X             * string will fit in the 'buff' variable.
X             * This isn't very pretty...
X             */
X            dbconvert(dbproc[inx], type, data, len, SYBCHAR, buff, -1);
X            break;
X            }
X        }
X        if(doAssoc)
X            (void)astore(ary,++sp,str_2mortal(str_make(colname, 0)));
X
X        (void)astore(ary,++sp,str_2mortal(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    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      case US_DBCURCMD:
X    if (items > 1)
X        fatal("Usage: $num = &DBCURCMD($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = DBCURCMD(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_DBMORECMDS:
X    if (items > 1)
X        fatal("Usage: $rc = &DBMORECMDS($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = DBMORECMDS(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_DBCMDROW:
X    if (items > 1)
X        fatal("Usage: $rc = &DBCMDROW($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = DBCMDROW(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_DBROWS:
X    if (items > 1)
X        fatal("Usage: $rc = &DBROWS($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = DBROWS(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_DBCOUNT:
X    if (items > 1)
X        fatal("Usage: $ret = &DBCOUNT($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = DBCOUNT(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_dbhasretstat:
X    if (items > 1)
X        fatal("Usage: $rc = &dbhasretstat($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = dbhasretstat(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X      case US_dbretstatus:
X    if (items > 1)
X        fatal("Usage: $rc = &dbretstatus($dbproc)");
X    else
X    {
X        int retval = 0;
X
X        if(items)
X        inx = getDbProc(STACK(sp)[1]);
X        else
X        inx = 0;
X
X        if(dbproc[inx])
X        retval = dbretstatus(dbproc[inx]);
X
X        str_numset(STACK(sp)[0], (double) retval);
X    }
X    break;
X#if defined(DBLIB42)
X      case US_dbsafestr:
X    if (items > 3 || items != 2)
X        fatal ("Usage: $string = &dbsafestr($dbproc,$instring[,$quote_char])");
X    else
X    {
X        int retval, len, quote;
X        char *buff, *instr;
X
X        inx = getDbProc (STACK (sp)[1]);
X
X        instr = (char *) str_get (STACK (sp)[2]);
X        if (items != 3)
X        quote = DBBOTH;
X        else
X        {
X        char *quote_char = (char *) str_get (STACK (sp)[3]);
X        if (*quote_char == '\"')
X            quote = DBDOUBLE;
X        else if (*quote_char == '\'')
X            quote = DBSINGLE;
X        else
X        { /* invalid  */
X            str_set (STACK (sp)[0], "");
X            break;
X        }
X        }
X        if (dbproc[inx] && (len = strlen (instr)))
X        {
X        /* twice as much space needed worst case */
X        New (902, buff, len * 2 + 1, char);
X        retval = dbsafestr (dbproc[inx], instr, -1, buff, -1, quote);
X                str_set (STACK (sp)[0], buff);
X                Safefree (buff);
X        }
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], wcolname, dbtxptr(dbproc[inx2], wcolnum),
X                   DBTXPLEN, dbtxtimestamp(dbproc[inx2], wcolnum), 0,
X                   strlen(wtext), wtext);
X        str_numset(STACK(sp)[0], (double) ret);
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)
Xint ix;
XSTR *str;
X{
X#if defined(USERVAL_SET_FATAL)
X    fatal("sybperl: trying to write to a read-only variable.");
X#else
X    return 0;
X#endif
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    if(dbproc[ix] == NULL || DBDEAD(dbproc[ix]))
X    fatal("$dbproc parameter is NULL or the connection to the server has been closed.");
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 25807 -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
echo shar: End of archive 1 \(of 2\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked both 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...