Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume43/sybperl/part01

Internet Message Format | 1994-06-27 | 87.2 KB

From: [e-mail] (Michael Peppler)
Newsgroups: comp.sources.misc
Subject: v43i046:  sybperl - Sybase DB-library extensions to Perl, v1.011, Part01/02
Date: 27 Jun 1994 16:13:09 -0500
Organization: Sterling Software
Sender: [e-mail]
Approved: [e-mail]
Message-ID: <csm-v43i046=[e-mail]>
X-Md4-Signature: ff5ffb78408ee15f219ae1bf64f3095c

Submitted-by: [e-mail] (Michael Peppler)
Posting-number: Volume 43, Issue 46
Archive-name: sybperl/part01
Environment: UNIX, Perl, Sybase
Supersedes: sybperl: Volume 39, Issue 101-103

This is sybperl release 1.011

   Sybperl is an extension to Perl which implements a sub-set of
   Sybase's DB-Library API. This enables you to write Perl scripts
   that have direct access to one or several Sybase servers.

   Requirements: Perl ver 3.0.27 or higher (4.036 strongly suggested!).
         Sybase DB-Library (aka Open Client), 4.0 or higher

Changes from release 1.009:

    1.011    Added &dbfreebuf().
        Added &dbsetopt() (contributed by Tom Kimpton).
        Added &DBSETLCHARSET() and &DBSETLNATLANG().
        Made sure the password and username fields of the
        LOGINREC are reset to NULL.
        Retrieving non-ascii TEXT data did not work.
        Reworked the man page a bit (hopefully to make it more
        readable!)
        Reworked the Makefile.
        Changed the method of testing for DBlib version to
        setting the numeric version in the Makefile and
        testing the revision level in the code.
    1.010   Changed the Copyright Notice to be in line with Perl's
        distribution arrangements.
        The OLD_SYBPERL define has been changed to AUTO_LOGIN
        (which is a bit more explicit!).
        eg/dbschema.pl now accepts a -s server parameter,
        prompts for SA password, and correctly extracts
        permissions for stored procs and views (thanks to Bill
        Papp).
        Casts of data retrieved via dbdata() are now done with
        DBlibrary typedefs instead of standard C types.
        The bug that prevented setting BCP_SETL() on the first
        DBPROCESS opened has been corrected (thanks to Peter
        Harrington).


I am always interested in hearing comments and suggestions for
improvements, and also porting attempts/problems/stories.


Enjoy!

Michael
--
Michael Peppler                | [e-mail]          | Sysadmin,
ITF Management SA           |                          |   DBA,
13 Rue de la Fontaine       | Phone: [phone]  | Programmer
CH-1204 Geneva, Switzerland | Fax:   [phone]  | & Trader...
--------
#! /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 BUGS CHANGES Makefile PACKING.LST eg eg/README
#   eg/capture.pl eg/dbschema.pl eg/dbtext.pl eg/report.pl eg/space.pl
#   eg/sql.pl eg/test_dbmoney.pl lib lib/sybdb.ph lib/sybdb_redefs.pl
#   lib/sybperl.pl patchlevel.h sybperl.1 t t/sbex.pl
# Wrapped by kent@sparky on Mon Jun 27 16:09:47 1994
PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin:$PATH ; 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'\" \(4126 characters\)
  sed "s/^X//" >'README' <<'END_OF_FILE'
X    @(#)README    1.6    6/8/94
X
X                 Sybperl, version 1.0
X                Patchlevel 11
X
X
X
X   Sybperl is an extension to Perl which implements a sub-set of
X   Sybase's DB-Library API. This enables you to write Perl scripts
X   that have direct access to one or several Sybase servers.
X
X   Requirements: Perl ver 3.0.27 or higher (4.036 strongly suggested!).
X         Sybase DB-Library (aka Open Client), 4.0 or higher
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       DBLIBVS          The version of your OpenClient library.
X             Set it to the revision level of your copy of
X             DBlibrary (eg DBlibrary version 4.2 set
X             DBLIBVS=420).
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       AUTO_LOGIN      This allows sybperl to silently call
X             dblogin()/dbopen() with default arguments if
X             you omit to do so in the script. This saves a
X             couple of keystrokes, which is nice for quick
X             hacks :-)
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       PACKAGE_BUG     There appears to be a weird bug when one
X             calls usersubs from within multiple Perl
X             packages. If you run into this problem, you
X             can enable this macro (see also the BUGS
X             file).
X       UPERL         See the comments in the Makefile, and the
X             BUGS file. The defaults should work.
X       PERL_VERSION     Uncomment if you're using a Perl version
X             earlier than 4.03
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 was initially tested in the following environments:
X
X   Sun Sparc, SunOS 4.1.3, Sybase 4.9.2, Perl 4.036
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   It is also known to run under Solaris 2.x, HP-UX, NeXT.
X
X   I use sybperl daily in a production environment on a Sun network
X   (Sun 4/65s and Axil HWS 310s) under SunOS 4.1.3, with Sybase
X   version 4.9.2 and Perl 4.036
X
X   FTP site: Sybperl and other DBMS related extensions to Perl can be
X   found on ftp.demon.co.uk:/pub/perl/db.
X
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
X   My thanks go first and foremost to Larry for Perl, and to the
X   following people for testing Sybperl, 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        Bill Papp
X
X
X   Have fun using it and let me know of any improvements, problems,
X   whatever...
X
X   Michael Peppler            [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   It is Copyright 1991, 1992, 1993, 1994 Michael Peppler & ITF Management
X   SA, but may be freely distributed under the same terms as Perl
X   itself, that is, under the terms of either the GNU Public License
X   or the Artistic License.
X
END_OF_FILE
  if test 4126 -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'\" \(4649 characters\)
  sed "s/^X//" >'BUGS' <<'END_OF_FILE'
X    @(#)BUGS    1.3    10/4/93
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) 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    2) 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    3) 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
X    Sybperl Memory Usage
X    --------------------
X
X    The general format of a Sybperl script usually looks somewhat like
X    this:
X
X    #!/usr/local/bin/sybperl
X
X    &dbcmd( query text );
X    &dbsqlexec;
X    &dbresults;
X
X    while(@data = &dbnextrow)
X    {
X       process data
X    }
X
X
X    If you are using a version of Perl prior to release 4, patchlevel
X    35, then this method will result in a rather important memory
X    leak. There are two ways around this problem:
X
X    1) Upgrade to Perl 4, patchlevel 35 :-)
X
X    2) Write a subroutine that calls &dbnextrow and stores the returned
X       array to a local variable, and which in turn returns that array to
X       the main while() loop, like so:
X
X    sub getRow
X    {
X        local(@data);
X
X    @data = &dbnextrow;
X
X    @data;
X    }
X
X    while(@data = &getRow)
X    {
X       etc.
X    }
X
X
X    This technique should keep the memory usage of Sybperl to a
X    manageable level.
X
X
X
X    Perl packages / usersubs bug
X    ----------------------------
X
X    The following is bug that was uncovered by Jeff Wong:
X
X------ begin excerpt -------
X
Xa: sybperl script z.pl has some *.pl required scripts.  Let's call
X   them x.pl and y.pl for convenience.
X
Xb: z.pl looks like this (basic structure):
X
X   ...
X   require "sybperl.pl";
X   require "x.pl";
X   require "y.pl";
X   ...
X
Xc: x.pl looks like this (basic structure):
X
X   ...
X   package x;
X   ...
X   < Sybperl functions with main package dereferencing, e.g. &main'dbcancel(), >
X   < &main'dbcancel( $dbproc ), &main'dbnextrow(), ...                        >
X   ...
X   package main;
X   ...
X
Xd: y.pl looks like x.pl or perhaps like other required packages (in format).
X
Xe: Bug surfaces in x.pl in that it suddenly cannot locate the sybperl
X   functions.
X
XMy guess is that the bug is caused by the way that usersub functions
Xare treated by the "require" and "package" operators.  I say this because:
X
X   - Usersub functions look very much like perl built-in functions, except that
X     usersub functions require an ampersand character in front of their names.
X
X   - Built-in functions are global to all packages.
X
X   - Perl user-defined functions are local to the package which contains their
X     name definition (i.e. where the namespace is).
X
X   - When I don't use the x.pl style package construct, the problem disappears.
X
X------ end excerpt -------
X
X
X    The way around this bug is to compile Sybperl with the PACKAGE_BUG
X    macro defined. When this is done, sybperl.pl creates a number of
X    'glue' routines (see lib/sybdb_redefs.pl') which bypass the bug.
X
X    It's not the cleanest of solutions, but it works...
X
X    However, be aware of the Perl @_ array assignement problems if you
X    call sybperl functions without a parameter list (as in &dbsqlexec;
X    instead of &dbsqlexec($dbproc);). When calling Sybperl functions
X    via the glue routines, the @_ array will default to the parameters
X    passed to last previously called Perl subroutine if it's called
X    without a parameter list. And that's almost certainly not what you
X    want.
X
X
X
X
X    Please let me know if you find any other problems with Sybperl so
X    that I can look into it.
X
X    Thank you.
X
X    Michael Peppler    <[e-mail]>
X
X
END_OF_FILE
  if test 4649 -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'\" \(4437 characters\)
  sed "s/^X//" >'CHANGES' <<'END_OF_FILE'
X    @(#)CHANGES    1.10    6/8/94
X
X
X    Sybperl CHANGES:
X
X    1.011    Added &dbfreebuf().
X        Added &dbsetopt() (contributed by Tom Kimpton).
X        Added &DBSETLCHARSET() and &DBSETLNATLANG().
X        Made sure the password and username fields of the
X        LOGINREC are reset to NULL.
X        Retrieving non-ascii TEXT data did not work.
X        Reworked the man page a bit (hopefully to make it more
X        readable!)
X        Reworked the Makefile.
X        Changed the method of testing for DBlib version to
X        setting the numeric version in the Makefile and
X        testing the revision level in the code.
X    1.010   Changed the Copyright Notice to be in line with Perl's
X        distribution arrangements.
X        The OLD_SYBPERL define has been changed to AUTO_LOGIN
X        (which is a bit more explicit!).
X        eg/dbschema.pl now accepts a -s server parameter,
X        prompts for SA password, and correctly extracts
X        permissions for stored procs and views (thanks to Bill
X        Papp).
X        Casts of data retrieved via dbdata() are now done with
X        DBlibrary typedefs instead of standard C types.
X        The bug that prevented setting BCP_SETL() on the first
X        DBPROCESS opened has been corrected (thanks to Peter
X        Harrington).
X    1.009   The script name is now used to set the application
X        name in sysprocesses via the DBSETLAPP() macro.
X        Calling &dbsafestr() with three arguments would result
X        in an erroneous fatal error message.
X        Sybperl now sets the application name in sysprocesses
X        (via DBSETLAPP()) to the name of the script that is
X        running.
X        Some problems with dbschema.pl which only showed up
X        when PACKAGE_BUG is defined have been corrected.
X    1.008   Added user settable variables to control whether
X        Sybperl returns 'NULL' or Perl's 'undef' value on NULL
X        values from a query, whether numeric results are kept
X        in native format, and whether binary data should be
X        preceded by '0x' (suggested by Steve Baumgarten).
X        Actually made $DBstatus visible (it was documented but
X        not usable up to now...).
X        Passing an undef'd variable to &bcp_sendrow will cause
X        a NULL value to be sent to the server for that column.
X    1.007   Added &dbmny* calls and code to circumvent weird
X        package/usub interaction bug, both contributed by Jeff
X        Wong.
X        Added &bcp_* calls.
X        Added &dbretdata() call (returns an array, possibly
X        associative, with the return parameters of a stored
X        proc).
X        Calls to any of the routines with an undefined
X        DBPROCESS will now elicit a warning; previously, such
X        calls defaulted to using the first (default)
X        DBPROCESS.
X        Data returned from queries is not converted to char
X        unless its necessary - this applies mainly to types
X        SYBFLOAT and SYBREAL which could loose some precision
X        on being converted to a string via sprintf().
X    1.006    Added contributed patches: &dbwritetext(),
X        &dbsafestr() and a modified &dblogin().
X        Added &dbhasretstats() and &dbretstatus(), as well as
X        some calls to DBlib macros such as DBCMD(),
X        DBMORECMD(), etc.
X        Received a patch to eg/space.pl from Wolfgang Richter.
X        Code that was defined to compile if BROKEN_DBCMD was
X        defined has been removed. It was only a hack, making
X        use of knowledge of the structure of the DBPROCESS
X        data type.
X        Added the possibility to return an associative array
X        from &dbnextrow.
X        Added support for new datatypes (SYBREAL, SYBDATETIME4).
X        NULL values retrieved using &dbnextrow can be returned
X        as 'undef' instead of 'NULL' (this is a compile-time
X        option).
X    1.005   Sybperl would core dump if you used a uninitialized
X            DBPROCESS.
X        A solution to the sometime pathological    memory usage
X        observed when using a release of Perl lower than 4.035
X        is also described in BUGS.
X        &dblogin now returns -1 if the dblogin() or dbopen()
X        calls fail.
X        Added the possibility to login to a specific server
X        without setting the DSQUERY environment variable.
X        Added a script to extract the information regarding
X        the database from the databases' system tables. See
X        eg/dbschema.pl.
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.
X
END_OF_FILE
  if test 4437 -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'\" \(3950 characters\)
  sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X#    @(#)Makefile    1.21    6/10/94
X#
X
X# Configuration stuff:
X
X# Where is the Perl source tree located. This is needed to find the
X# Perl include files, and uperl.o which sybperl needs to link with.
XPERLSRC = /usr/local/src/perl
X
X# Where are the sybase .h files located
XSYBINCS = /usr/local/sybase/include
X
X# Any other non-default directories that need to be searched ?
XLOCINCS = .
X
X# Where are the Sybase libraries located
XSYBLIBDIR = /usr/local/lib
XSYBLIBS = -lsybdb
X
X# Any extra libraries needed?
X# Solaris 2 needs -lsocket -lnsl
X# HP-UX seems to need -ldbm
XEXTRA_LIBS=
X
X# Where does the executable go
XBINDIR = /usr/local/bin
X
X# Where do the lib/*.pl go
XPERLLIB = /usr/local/lib/perl
X
X# where do we put the manual page
XMANDIR = /usr/local/man
XMANEXT = l
X
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 second solution:
XUPERL = uperl2.o
X
X# DBLIBVS: The DBlib version that you have.
X# Controls the inclusion of routines which are available
X# only in more recent versions of DB library.
XDBLIBVS = -DDBLIBVS=461
X
X# HAS_CALLBACK: This should be defined if you have Perl 4 patchlevel
X# 18 or later. User defined error/message handlers in Perl are not
X# possible if this is not defined, however.
XHAS_CALLBACK= -DHAS_CALLBACK
X
X# AUTO_LOGIN: When this is turned on, automatic logging in to Sybase
X# is enabled.
X# Otherwise, failing to call &dblogin is a fatal error.
XAUTO_LOGIN= -DAUTO_LOGIN
X
X# SET_VAL: If this is set, then assigning a value to Sybperl's
X# read-only variables is a fatal error. Normally, this would be
X# silently ignored.
X#SET_VAL = -DUSERVAL_SET_FATAL
X
X# PACKAGE_BUG: Controls whether code to circumvent a bug in Perl that
X# shows up when calling usubs from within nested packages is included.
X# See also the BUGS file.
X#PACKAGE_BUG = -DPACKAGE_BUG
X
X# RINDEX: Does your system know rindex(), but not strrchr() ?
X#RINDEX = -Dstrrchr=rindex
X
X# Uncomment this if you are compiling sybperl for Perl version 3.xx
X# I strongly recommend that you get Perl 4.036 if it is at all
X# available for your system!
X# PERL_VERSION = -DVERSION3
X
X# Which compiler to use
XCC = gcc
X
XCFLAGS = -O2 -g
XCPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) \
X        $(HAS_CALLBACK) $(AUTO_LOGIN) $(DBLIBVS) \
X        $(SET_VAL) $(PACKAGE_BUG) $(RINDEX)
X
Xsybperl: $(UPERL) sybperl.o
X    $(CC) $(CFLAGS) -L$(SYBLIBDIR) $(UPERL) sybperl.o $(SYBLIBS) $(EXTRA_LIBS) -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 2nd 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 755 sybperl $(BINDIR)
X    cp lib/syb*.p? $(PERLLIB)
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 \
X    lib/sybdb_redefs.pl t/sbex.pl \
X    eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl \
X    eg/dbschema.pl eg/dbtext.pl eg/test_dbmoney.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 \
X    lib/sybdb_redefs.pl t/sbex.pl \
X    eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl \
X    eg/dbschema.pl eg/dbtext.pl eg/test_dbmoney.pl eg/README
X
X
X
X
X
END_OF_FILE
  if test 3950 -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'\" \(1270 characters\)
  sed "s/^X//" >'PACKING.LST' <<'END_OF_FILE'
X    @(#)PACKING.LST    1.1    9/2/93
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
X        eg/dbtext.pl    Example of &dbwritetext() usage. This
X                script will NOT work out of the box. Read
X                the code to see what requires doing first.
X        eg/test_dbmoney.pl
X                    Example script using &dbmny*() calls.
X
X        eg/dbschema.pl  Create an Isql script that will to
X                        recreate your database(s) structure (data
X                types, tables, indexes, rules, defaults,
X                views, triggers and stored procedures),
X                extracting the information from the
X                database's system tables.
X
END_OF_FILE
  if test 1270 -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/README' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/README'\"
else
  echo shar: Extracting \"'eg/README'\" \(1797 characters\)
  sed "s/^X//" >'eg/README' <<'END_OF_FILE'
X    @(#)README    1.5    8/31/93
X
X
X    This directory contains a number of example scripts for Sybperl.
X
X
X
X    space.pl        Report the space used by your database.
X    capture.pl        Create a table with information from
X            /etc/passwd.
X    report.pl        Report information from the above table.
X    sql.pl        Utility used by the above three scripts.
X    dbschema.pl        Extract an Isql script to re-create a database
X    dbtext.pl        A very simple example of usage of dbwritetext.
X            Read the code before using!
X    test_dbmoney.pl    Example script using dbmny* calls.
X
X
X
X    Dbschema.pl Documentation:
X    --------------------------
X
X    This is a Sybperl script that extracts a Sybase database definition
X    and creates an Isql script to rebuild the database.
X
X    dbschema.pl is NOT a production script, in the sense that it does
X    not do ALL the necessary work. The script tries to do the right
X    thing, but in certain cases (mainly where the owner of an object
X    is not the DBO) it creates an invalid or incorrect Isql command. I
X    have tried to detect these cases, and log them both to stdout and to a
X    file, so that the script can be corrected.
X    Please note also that dbschema.pl logs in to Sybase with the
X    default (Unix) user id, and a NULL password. This behaviour is
X    maybe not OK for your site.
X
X    Usage:
X
X        itf1% dbschema.pl -d excalibur -o excalibur.isql -v
X
X    Run dbschema on database 'excalibur', place the resulting script
X    in 'excalibur.isql' (and the error log in 'excalibur.isql.log')
X    and turn on verbose output on the console. The default database is
X    'master', the default output file is 'script.isql'.
X
X
X    I hope this will prove of some use, and I would be more than happy
X    to hear of any improvements :-)
X
X
X    Michael Peppler        [e-mail]
X
END_OF_FILE
  if test 1797 -ne `wc -c <'eg/README'`; then
    echo shar: \"'eg/README'\" unpacked with wrong size!
  fi
  # end of 'eg/README'
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'\" \(1640 characters\)
  sed "s/^X//" >'eg/capture.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
X#
X#    @(#)capture.pl    1.1    6/24/92
X#
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
X$d = &dblogin;
X
X&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 1640 -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/dbschema.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/dbschema.pl'\"
else
  echo shar: Extracting \"'eg/dbschema.pl'\" \(9982 characters\)
  sed "s/^X//" >'eg/dbschema.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X#
X#    @(#)dbschema.pl    1.11    2/22/94
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:  22 Feb 1994
X#
X# Usage:    dbschema.pl -d database -o script.name -t pattern -s server -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: %), and server is
X#                the server to connect to (default, the value of $ENV{DSQUERY}).
X#
X#            -v turns on a verbose switch.
X#
X#    Changes:   11/18/93 - bpapp - Put in interactive SA password prompt
X#               11/18/93 - bpapp - Get protection information for views and
X#                                  stored procedures.
X#        02/22/94 - mpeppler - Merge bpapp's changes with itf version
X#
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:s:v');
X
X$opt_d = 'master' unless $opt_d;
X$opt_o = 'script.isql' unless $opt_o;
X$opt_t = '%' unless $opt_t;
X$opt_s = $ENV{DSQUERY} unless $opt_s;
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# Log us in to Sybase as 'sa' and prompt for admin password.
X#
Xprint "\nAdministrative account password: ";
Xsystem("stty -echo");
Xchop($sapw = <>);
Xsystem("stty echo");
X
X$dbproc = &dblogin("sa", $sapw, $opt_s);
X&dbuse($dbproc, $opt_d);
X
Xchop($date = &ctime(time));
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(%rule)))
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($dbproc);
X
X    $cnt = 0;
X    while(($ret = &dbresults($dbproc)) != $NO_MORE_RESULTS && $ret != $FAIL)
X    {
X    while(@dat = &dbnextrow($dbproc))
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($dbproc);
X    &dbresults($dbproc);
X
X    print SCRIPT
X        "/* $objname $vi[0], owner $vi[1] */\n";
X
X    while(($text) = &dbnextrow($dbproc))
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    if ($obj eq 'V' || $obj eq 'P')
X    {
X       &getPerms("$vi[0]") && print SCRIPT "go\n";
X    }
X
X    }
X}
X
X
END_OF_FILE
  if test 9982 -ne `wc -c <'eg/dbschema.pl'`; then
    echo shar: \"'eg/dbschema.pl'\" unpacked with wrong size!
  fi
  # end of 'eg/dbschema.pl'
fi
if test -f 'eg/dbtext.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/dbtext.pl'\"
else
  echo shar: Extracting \"'eg/dbtext.pl'\" \(738 characters\)
  sed "s/^X//" >'eg/dbtext.pl' <<'END_OF_FILE'
X#  Script which demonstrates dbwrite routine.
X#
X#  In isql do something like:
X#       create table text_table (t_index int, the_text text)
X#
X#    @(#)dbtext.pl    1.1    8/31/93
X#
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X$d = &dblogin;
X$d2 = &dbopen;
X
X&sql ($d, 'delete from text_table');
X&sql ($d, 'insert into text_table (t_index, the_text) values (5,"")');
X
X
X&dbcmd($d,'select the_text, t_index from text_table where t_index = 5');
X&dbsqlexec($d);                         # execute sql
X
X&dbresults($d);
X@data = &dbnextrow($d);
X
X&dbwritetext ($d2, "text_table.the_text", $d, 1, "This is text which was added with Sybperl");
X
X@result = &sql($d,'select t_index, the_text from text_table where t_index = 5');
X
Xprint @result, "\n";
X
X&dbclose($d);
X
END_OF_FILE
  if test 738 -ne `wc -c <'eg/dbtext.pl'`; then
    echo shar: \"'eg/dbtext.pl'\" unpacked with wrong size!
  fi
  # end of 'eg/dbtext.pl'
fi
if test -f 'eg/report.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/report.pl'\"
else
  echo shar: Extracting \"'eg/report.pl'\" \(753 characters\)
  sed "s/^X//" >'eg/report.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
X#
X#    @(#)report.pl    1.1    6/24/92
X#
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
X$d = &dblogin;
X
X#
X# define the format
X#
Xformat top=
X             PASSWORD FILE
XLogin      Uid Group      Shell                   Home directory
X-------- ----- ---------- ----------------------- ----------------------
X.
Xformat stdout=
X@<<<<<<< @>>>> @<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<
X$n,      $u,   $gn,       $s,                     $d
X.
X
X#
X# See if everything is there.
X#
X@results = &sql($d, '
X    select username, uid, isnull(groupname,convert(char,p.gid)), shell, home
X    from password p, groups g
X    where    p.gid *= g.gid
X    order by uid
X    ');
Xforeach $x (@results) {
X    ($n,$u,$gn,$s,$d) = split("~",$x);
X    write;
X}
X
END_OF_FILE
  if test 753 -ne `wc -c <'eg/report.pl'`; then
    echo shar: \"'eg/report.pl'\" unpacked with wrong size!
  fi
  chmod +x 'eg/report.pl'
  # end of 'eg/report.pl'
fi
if test -f 'eg/space.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/space.pl'\"
else
  echo shar: Extracting \"'eg/space.pl'\" \(1494 characters\)
  sed "s/^X//" >'eg/space.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X#
X#    @(#)space.pl    1.2    4/2/93
X
Xrequire "sybperl.pl";
Xrequire "sql.pl";
X
X#
X# Log us in to Sybase.
X#
Xprint "Name of Sybase server: ";
X$server = <>; chop($server);
Xif($server ne '')
X{
X    $ENV{'DSQUERY'} = $server;
X}
Xelse
X{
X    $server = $ENV{'DSQUERY'};
X}
X
Xprint "Administrative account password: ";
Xeval `stty -echo`;
X$sapw = <>; chop($sapw);
Xeval `stty echo`;
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 1494 -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'\" \(1736 characters\)
  sed "s/^X//" >'eg/sql.pl' <<'END_OF_FILE'
X#
X#    @(#)sql.pl    1.2    8/9/93
X#
X
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($db)) {
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 1736 -ne `wc -c <'eg/sql.pl'`; then
    echo shar: \"'eg/sql.pl'\" unpacked with wrong size!
  fi
  # end of 'eg/sql.pl'
fi
if test -f 'eg/test_dbmoney.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'eg/test_dbmoney.pl'\"
else
  echo shar: Extracting \"'eg/test_dbmoney.pl'\" \(5455 characters\)
  sed "s/^X//" >'eg/test_dbmoney.pl' <<'END_OF_FILE'
X#! /usr/local/bin/sybperl
X
X#    @(#)test_dbmoney.pl    1.3    6/1/94
X#
X
Xunshift(@INC, "../lib");    # to use the uninstalled require'd files
Xrequire "sybperl.pl";
Xrequire "getopts.pl";
X
X( !defined( $FALSE )) && ( $FALSE = 0 );
X( !defined( $TRUE ))  && ( $TRUE  = 1 );
X
X&Getopts( 'S:' );
X
Xif ( defined( $opt_S )) {
X   $server = $opt_S;
X}
Xelse {
X   $server = $ENV{ 'DSQUERY' };
X}
X
X$tty_test = system( "/bin/tty -s" ) / 256;
X
X(( $tty_test == 0 ) || ( $tty_test == 1 )) ||
X   die "Invalid options were specified to /bin/tty: $!\n";
X
Xif ( $tty_test == 0 ) {  # tty device attached to STDIN
X   system( "/bin/stty -echo" );
X   print "SA password: ";
X   $sybupw = scalar( <STDIN> );
X   system( "/bin/stty echo" );
X   print "\n";
X}
Xelse {
X   $sybupw = scalar( <STDIN> );
X}
X
Xchop $sybupw;
X
X$dbproc = &dblogin( "sa", $sybupw, $server );
X
X&dbuse( "master" );
X
X$money1 = '4.89';
X$money2 = '8.56';
X$money3 = '*';
X
Xprintf( "money1 = %.4f, money2 = %.4f\n", $money1, $money2 );
X
X($status, $money3) = &dbmnyzero( );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money3) = &dbmnyinc( $money3 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X($status, $money3) = &dbmnyinc( $money3 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X($status, $money3) = &dbmnyinc( $money3 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X($status, $money3) = &dbmnyinc( $money3 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X$money3 = '0.0001';
X($status, $money3) = &dbmnyscale( $money3, 100, 1 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X( $money3, $money4 ) = ( '0.0001', '0.0002' );
X($status, $money3) = &dbmnyadd( $money4, $money3 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X$money3 = '0.0004'; $money4 = '0.0003'; $money5 = '0.0005';
X$money6 = '0.0004';
Xprintf( "status = %d, money3 = %.4f, money4 = %.4f\n",
X    &dbmnycmp( $money3, $money4 ), $money3, $money4 );
Xprintf( "status = %d, money3 = %.4f, money5 = %.4f\n",
X    &dbmnycmp( $money3, $money5 ), $money3, $money5 );
Xprintf( "status = %d, money3 = %.4f, money6 = %.4f\n",
X    &dbmnycmp( $money3, $money6 ), $money3, $money6 );
Xprintf( "status = %d, money4 = %.4f, money5 = %.4f\n",
X    &dbmnycmp( $money4, $money5 ), $money4, $money5 );
Xprintf( "status = %d, money4 = %.4f, money6 = %.4f\n",
X    &dbmnycmp( $money4, $money6 ), $money4, $money6 );
Xprintf( "status = %d, money5 = %.4f, money6 = %.4f\n",
X    &dbmnycmp( $money5, $money6 ), $money5, $money6 );
X
X($status, $money3) = &dbmnyadd( $money1, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money3) = &dbmnysub( $money1, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money3) = &dbmnydivide( $money3, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money4) = &dbmnymaxneg( );
Xprintf( "status = %d, money4 = %.4f\n", $status, $money4 );
X
X($status, $money3) = &dbmnymaxpos( );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money4) = &dbmnyzero( );
X
X@tbal = ( '4.89', '8.92', '7.77', '11.11', '0.01' );
X
Xfor ( $cntr = 0 ; $cntr <= $#tbal ; $cntr++ ) {
X  printf( "Item %d - %s\n", $cntr, $tbal[ $cntr ] );
X  ($status, $money4) = &dbmnyadd( $tbal[ $cntr ], $money4 );
X}
X
Xprintf( "status = %d, total = %.4f\n", $status, $money4 );
X
X$cntr = $#tbal + 1;
X
X($status, $money4) = &dbmnydivide( $money4, "$cntr" );
Xprintf( "status = %d, avg = %.4f\n", $status, $money4 );
X
Xprint "-------------------------\n";
X
X$money1 = '4.89';
X$money2 = '8.56';
X$money3 = '*';
X
Xprintf( "money1 = %.4f, money2 = %.4f\n", $money1, $money2 );
X
X($status, $money3) = &dbmny4zero( );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X( $money3, $money4 ) = ( '0.0001', '0.0002' );
X($status, $money3) = &dbmny4add( $money3, $money4 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X$money3 = '0.0004'; $money4 = '0.0003'; $money5 = '0.0005';
X$money6 = '0.0004';
Xprintf( "status = %d, money3 = %.4f, money4 = %.4f\n",
X    &dbmny4cmp( $money3, $money4 ), $money3, $money4 );
Xprintf( "status = %d, money3 = %.4f, money5 = %.4f\n",
X    &dbmny4cmp( $money3, $money5 ), $money3, $money5 );
Xprintf( "status = %d, money3 = %.4f, money6 = %.4f\n",
X    &dbmny4cmp( $money3, $money6 ), $money3, $money6 );
Xprintf( "status = %d, money4 = %.4f, money5 = %.4f\n",
X    &dbmny4cmp( $money4, $money5 ), $money4, $money5 );
Xprintf( "status = %d, money4 = %.4f, money6 = %.4f\n",
X    &dbmny4cmp( $money4, $money6 ), $money4, $money6 );
Xprintf( "status = %d, money5 = %.4f, money6 = %.4f\n",
X    &dbmny4cmp( $money5, $money6 ), $money5, $money6 );
X
X($status, $money3) = &dbmny4add( $money1, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money3) = &dbmny4sub( $money1, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money3) = &dbmny4divide( $money3, $money2 );
Xprintf( "status = %d, money3 = %.4f\n", $status, $money3 );
X
X($status, $money4) = &dbmny4zero( $money4 );
X
X@tbal = ( '4.89', '8.92', '7.77', '11.11', '0.01' );
X
Xfor ( $cntr = 0 ; $cntr <= $#tbal ; $cntr++ ) {
X  printf( "Item %d - %s\n", $cntr, $tbal[ $cntr ] );
X  ($status, $money4) = &dbmny4add( $tbal[ $cntr ], $money4 );
X}
X
Xprintf( "status = %d, total = %.4f\n", $status, $money4 );
X
X$cntr = $#tbal + 1;
X
X($status, $money4) = &dbmny4divide( $money4, "$cntr" );
Xprintf( "status = %d, avg = %.4f\n", $status, $money4 );
X
X&dbclose;
X
X&dbexit;
X
Xexit( $STDEXIT );
X
END_OF_FILE
  if test 5455 -ne `wc -c <'eg/test_dbmoney.pl'`; then
    echo shar: \"'eg/test_dbmoney.pl'\" unpacked with wrong size!
  fi
  # end of 'eg/test_dbmoney.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'\" \(5260 characters\)
  sed "s/^X//" >'lib/sybdb.ph' <<'END_OF_FILE'
X;#    @(#)sybdb.ph    1.2    8/30/93
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;}
Xsub SYBEFGTL {20122;}
Xsub SYBECWLL {20123;}
Xsub SYBEUFDS {20124;}
Xsub SYBEUCPT {20125;}
Xsub SYBETMCF {20126;}
Xsub SYBEAICF {20127;}
Xsub SYBEADST {20128;}
Xsub SYBEALTT {20129;}
Xsub SYBEAPCT {20130;}
Xsub SYBEXOCI {20131;}
Xsub SYBEFSHD {20132;}
Xsub SYBEAOLF {20133;}
Xsub SYBEARDI {20134;}
Xsub SYBEURCI {20135;}
Xsub SYBEARDL {20136;}
Xsub SYBEURMI {20137;}
Xsub SYBEUREM {20138;}
Xsub SYBEURES {20139;}
Xsub SYBEUREI {20140;}
Xsub SYBEOREN {20141;}
Xsub SYBEISOI {20142;}
Xsub SYBEIDCL {20143;}
Xsub SYBEIMCL {20144;}
Xsub SYBEIFCL {20145;}
Xsub SYBEUTDS {20146;}
Xsub SYBEBUFF {20147;}
Xsub SYBEACNV {20148;}
Xsub SYBEDPOR {20149;}
Xsub SYBENDC {20150;}
Xsub SYBEMVOR {20151;}
Xsub SYBEDVOR {20152;}
Xsub SYBENBVP {20153;}
Xsub SYBESPID {20154;}
Xsub SYBENDTP {20155;}
Xsub SYBEXTN {20156;}
Xsub SYBEXTDN {20157;}
Xsub SYBEXTSN {20158;}
Xsub SYBENUM {20159;}
Xsub SYBETYPE {20160;}
Xsub SYBEGENOS {20161;}
Xsub SYBEPAGE {20162;}
Xsub SYBEOPTNO {20163;}
Xsub SYBEETD {20164;}
Xsub SYBERTYPE {20165;}
Xsub SYBERFILE {20166;}
Xsub SYBEFMODE {20167;}
Xsub SYBESLCT {20168;}
Xsub SYBEZTXT {20169;}
Xsub SYBENTST {20170;}
Xsub SYBEOSSL {20171;}
Xsub SYBEESSL {20172;}
Xsub SYBENLNL {20173;}
Xsub SYBENHAN {20174;}
Xsub SYBENBUF {20175;}
Xsub SYBENULP {20176;}
Xsub SYBENOTI {20177;}
Xsub SYBEEVOP {20178;}
Xsub SYBENEHA {20179;}
Xsub SYBETRAN {20180;}
Xsub SYBEEVST {20181;}
Xsub SYBEEINI {20182;}
Xsub SYBEECRT {20183;}
Xsub SYBEECAN {20184;}
Xsub SYBEEUNR {20185;}
Xsub SYBERPCS {20186;}
Xsub SYBETPAR {20187;}
Xsub SYBETEXS {20188;}
Xsub SYBETRAC {20189;}
Xsub SYBETRAS {20190;}
Xsub SYBEPRTF {20191;}
Xsub SYBETRSN {20192;}
Xsub SYBEBPKS {20193;}
Xsub SYBEIPV {20194;}
Xsub SYBEMOV {20195;}
Xsub SYBEDIVZ {20196;}
Xsub SYBEASTL {20197;}
Xsub SYBESEFA {20198;}
Xsub SYBEPOLL {20199;}
Xsub SYBENOEV {20200;}
Xsub SYBEBADPK {20201;}
Xsub DBERRCOUNT {201;}
X
X# sybperl standard definitions (and some new additions)
X#
X# From sybfront.h
X#
X
X# sybperl standard definitions (and some new additions)
X#
X# From sybdb.h
X#
X
X# sybperl standard definitions (and some new additions)
X#
X# From syberror.h
X#
X
X# Other definitions (optional)
X#
X# From sybdb.h
X#
Xsub DBSINGLE {0;}
Xsub DBDOUBLE {1;}
Xsub DBBOTH {2;}
Xsub DBXLATE_XOK {0;}
Xsub DBXLATE_XOF {1;}
Xsub DBXLATE_XPAT {2;}
Xsub DBRESULT {1;}
Xsub DBNOTIFICATION {2;}
Xsub DBTIMEOUT {3;}
Xsub DBINTERRUPT {4;}
Xsub DBMAXMNYSYM {5;}
Xsub DBMAXECLEN {8;}
Xsub DBMAXESLEN {256;}
Xsub DBMAXCPYRTLEN {512;}
Xsub DBTDS_UNKNOWN {0;}
Xsub DBTDS_2_0 {1;}
Xsub DBTDS_3_4 {2;}
Xsub DBTDS_4_0 {3;}
Xsub DBTDS_4_2 {4;}
Xsub DBTDS_4_6 {5;}
X
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 5260 -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/sybdb_redefs.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'lib/sybdb_redefs.pl'\"
else
  echo shar: Extracting \"'lib/sybdb_redefs.pl'\" \(9685 characters\)
  sed "s/^X//" >'lib/sybdb_redefs.pl' <<'END_OF_FILE'
X#    @(#)sybdb_redefs.pl    1.3    6/10/94
X#
X# Adapted from Jeff Wongs version.
X# sybdb_redefs.pl - sybperl redefinitions to defeat weird package/user-defined
X#                   built-in subroutine bug.
X#
X# mpeppler 09/06/94, V1.6 - add &dbsetopt, &DBSETLNATLANG, &DBSETLCHARSET.
X# mpeppler 12/05/94, V1.5 - add &dbfreebuf (1.011)
X# jtw, 09/06/93, V1.4 - defer omission of $dbproc for all routines
X# jtw, 09/06/93, V1.3 - add OpenClient R4.6.1 money routines
X# jtw, 14/05/93, V1.2 - change argument test in &dbnextrow to == 0
X# jtw, 13/05/93, V1.1 - synchronise with sybperl V1.6
X# jtw, 18/03/93, V1.0 - original
X#
X#
Xpackage main;
X
Xsub dblogin {
X   local( @param_array ) = @_;
X   local( $dbproc );
X
X   $dbproc = &dbLOGIN( @param_array );
X
X   return $dbproc;
X}
X
Xsub dbopen {
X   local( $server ) = @_;
X   local( $dbproc );
X
X   $dbproc = &dbOPEN( $server );
X
X   return $dbproc;
X}
X
Xsub dbclose {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbCLOSE( $dbproc );
X
X   return $ret;
X}
X
Xsub dbcmd {
X   local( @param_array ) = @_;
X   local( $ret );
X
X   $ret = &dbCMD( @param_array );
X
X   return $ret;
X}
X
Xsub dbsqlexec {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbSQLEXEC( $dbproc );
X
X   return $ret;
X}
X
Xsub dbresults {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbRESULTS( $dbproc );
X
X   return $ret;
X}
X
Xsub dbnextrow {
X   local( @param_array ) = @_;
X   local( @dvec, %avec );
X
X   if (( $#param_array     == 1 )  &&
X       ( $param_array[ 1 ] != 0 ))    {  # associative array
X      %avec = &dbNEXTROW( @param_array );
X
X      return %avec;
X   }
X   else {  # normal array
X      @dvec = &dbNEXTROW( @param_array );
X
X      return @dvec;
X   }
X}
X
Xsub dbcancel {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbCANCEL( $dbproc );
X
X   return $ret;
X}
X
Xsub dbcanquery {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbCANQUERY( $dbproc );
X
X   return $ret;
X}
X
Xsub dbfreebuf {
X   local( $dbproc ) = @_;
X   local( $ret );
X
X   $ret = &dbFREEBUF( $dbproc );
X
X   return $ret;
X}
X
Xsub dbsetopt {
X   local( @param_array ) = @_;
X   local( $ret );
X
X   $ret = &dbSETOPT( @param_array );
X
X   return $ret;
X}
X
Xsub dbexit {
X   &dbEXIT;
X}
X
Xsub dbuse {
X   local( @param_array ) = @_;
X   local( $ret );
X
X   $ret = &dbUSE( @param_array );
X
X   return $ret;
X}
X
Xsub dberrhandle {
X   local( $handler ) = @_;
X   local( $old_handler );
X
X   $old_handler = &dbERRHANDLE( $handler );
X
X   return $old_handler;
X}
X
Xsub dbmsghandle {
X   local( $handler ) = @_;
X   local( $old_handler );
X
X   $old_handler = &dbMSGHANDLE( $handler );
X
X   return $old_handler;
X}
X
Xsub dbstrcpy {
X   local( $dbproc ) = @_;
X   local( $string );
X
X   $string = &dbSTRCPY( $dbproc );
X
X   return $string;
X}
X
Xsub dbsafestr {
X   local( @param_array ) = @_;
X   local( $string );
X
X   $string = &dbSAFESTR( @param_array );
X
X   return $string;
X}
X
Xsub dbwritetext {
X   local( @param_array ) = @_;
X   local( $status );
X
X   $status = &dbWRITETEXT( @param_array );
X
X   return $status;
X}
X
Xsub DBSETLCHARSET {
X   local( @param_array ) = @_;
X   local( $status );
X
X   $status = &dbSETLCHARSET( @param_array );
X
X   return $status;
X}
X
Xsub DBSETLNATLANG {
X   local( @param_array ) = @_;
X   local( $status );
X
X   $status = &dbSETLNATLANG( @param_array );
X
X   return $status;
X}
X
Xsub DBCURCMD {
X   local( $dbproc ) = @_;
X   local( $cmd_no );
X
X   $cmd_no = &dbCURCMD( $dbproc );
X
X   return $cmd_no;
X}
X
Xsub DBCURROW {
X   local( $dbproc ) = @_;
X   local( $row_no );
X
X   $row_no = &dbCURROW( $dbproc );
X
X   return $row_no;
X}
X
Xsub DBMORECMDS {
X   local( $dbproc ) = @_;
X   local( $status );
X
X   $status = &dbMORECMDS( $dbproc );
X
X   return $status;
X}
X
Xsub DBCMDROW {
X   local( $dbproc ) = @_;
X   local( $status );
X
X   $status = &dbCMDROW( $dbproc );
X
X   return $status;
X}
X
Xsub DBROWS {
X   local( $dbproc ) = @_;
X   local( $status );
X
X   $status = &dbROWS( $dbproc );
X
X   return $status;
X}
X
Xsub DBCOUNT {
X   local( $dbproc ) = @_;
X   local( $no_rows );
X
X   $no_rows = &dbCOUNT( $dbproc );
X
X   return $no_rows;
X}
X
Xsub dbhasretstat {
X   local( $dbproc ) = @_;
X   local( $status );
X
X   $status = &dbHASRETSTAT( $dbproc );
X
X   return $status;
X}
X
Xsub dbretstatus {
X   local( $dbproc ) = @_;
X   local( $status );
X
X   $status = &dbRETSTATUS( $dbproc );
X
X   return $status;
X}
X
Xsub dbmny4add {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4ADD( @param_array );
X
X   return @status;
X}
X
Xsub dbmny4cmp {
X   local( @param_array ) = @_;
X   local( $status );
X
X   $status = &dbMNY4CMP( @param_array );
X
X   return $status;
X}
X
Xsub dbmny4divide {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4DIVIDE( @param_array );
X
X   return @status;
X}
X
Xsub dbmny4minus {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4MINUS( @param_array );
X
X   return @status;
X}
X
Xsub dbmny4mul {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4MUL( @param_array );
X
X   return @status;
X}
X
Xsub dbmny4sub {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4SUB( @param_array );
X
X   return @status;
X}
X
Xsub dbmny4zero {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNY4ZERO( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyadd {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYADD( @param_array );
X
X   return @status;
X}
X
Xsub dbmnycmp {
X   local( @param_array ) = @_;
X   local( $status );
X
X   $status = &dbMNYCMP( @param_array );
X
X   return $status;
X}
X
Xsub dbmnydivide {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYDIVIDE( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyminus {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYMINUS( @param_aray );
X
X   return @status;
X}
X
Xsub dbmnymul {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYMUL( @param_array );
X
X   return @status;
X}
X
Xsub dbmnysub {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYSUB( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyzero {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYZERO( @param_array );
X
X   return @status;
X}
X
Xsub dbmnydec {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYDEC( @param_array );
X
X   return @status;
X}
X
Xsub dbmnydown {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYDOWN( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyinc {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYINC( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyinit {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYINIT( @param_array );
X
X   return @status;
X}
X
Xsub dbmnymaxneg {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYMAXNEG( @param_array );
X
X   return @status;
X}
X
Xsub dbmnymaxpos {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYMAXPOS( @param_array );
X
X   return @status;
X}
X
Xsub dbmnyndigit {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYNDIGIT( @param_array );
X
X   return @array;
X}
X
Xsub dbmnyscale {
X   local( @param_array ) = @_;
X   local( @status );
X
X   @status = &dbMNYSCALE( @param_array );
X
X   return @status;
X}
X
Xsub dbcoltype
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &dbCOLTYPE( @param_array );
X
X    return $status;
X}
X
Xsub dbcolname
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &dbCOLNAME( @param_array );
X
X    return $status;
X}
X
Xsub dbcollen
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &dbCOLLEN( @param_array );
X
X    return $status;
X}
X
Xsub dbnumcols
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &dbNUMCOLS( @param_array );
X
X    return $status;
X}
X
Xsub dbrecftos
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &dbRECFTOS( @param_array );
X
X    return $status;
X}
X
Xsub BCP_SETL
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_SETL( @param_array );
X
X    return $status;
X}
X
Xsub bcp_getl
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_GETL( @param_array );
X
X    return $status;
X}
X
Xsub bcp_init
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_INIT( @param_array );
X
X    return $status;
X}
X
Xsub bcp_meminit
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_MEMINIT( @param_array );
X
X    return $status;
X}
X
Xsub bcp_sendrow
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_SENDROW( @param_array );
X
X    return $status;
X}
X
Xsub bcp_batch
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_BATCH( @param_array );
X
X    return $status;
X}
X
Xsub bcp_done
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_DONE( @param_array );
X
X    return $status;
X}
X
Xsub bcp_control
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_CONTROL( @param_array );
X
X    return $status;
X}
X
Xsub bcp_columns
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_COLUMNS( @param_array );
X
X    return $status;
X}
X
Xsub bcp_colfmt
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_COLFMT( @param_array );
X
X    return $status;
X}
X
Xsub bcp_exec
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_EXEC( @param_array );
X
X    return $status;
X}
X
Xsub bcp_readfmt
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_READFMT( @param_array );
X
X    return $status;
X}
X
Xsub bcp_writefmt
X{
X    local( @param_array ) = @_;
X    local( $status );
X
X    $status = &bcp_WRITEFMT( @param_array );
X
X    return $status;
X}
X
X# ----- end of sybdb_redefs.pl -----
X
X1;
X
END_OF_FILE
  if test 9685 -ne `wc -c <'lib/sybdb_redefs.pl'`; then
    echo shar: \"'lib/sybdb_redefs.pl'\" unpacked with wrong size!
  fi
  # end of 'lib/sybdb_redefs.pl'
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'\" \(1865 characters\)
  sed "s/^X//" >'lib/sybperl.pl' <<'END_OF_FILE'
X;#     @(#)sybperl.pl    1.5    9/23/93
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# 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 STDERR ("Sybase message ", $message, ", Severity ", $severity,
X           ", state ", $state);
X    print STDERR ("\nServer `", $server, "'") if defined ($server);
X    print STDERR ("\nProcedure `", $procedure, "'") if defined ($procedure);
X    print STDERR ("\nLine ", $line) if defined ($line);
X    print STDERR ("\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 STDERR (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
X    }
X    }
X    elsif ($message == 0)
X    {
X    print STDERR ($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 STDERR ("Sybase error: ", $error_msg, "\n");
X    print STDERR ("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 ("message_handler"); # Some user defined error handlers
X    &dberrhandle ("error_handler");
X}
X
X
Xif (defined($SybPackageBug) && $SybPackageBug == 1)
X{
X    require 'sybdb_redefs.pl';
X}
X
X
X1;
X
END_OF_FILE
  if test 1865 -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'\" \(81 characters\)
  sed "s/^X//" >'patchlevel.h' <<'END_OF_FILE'
X
X/*     @(#)patchlevel.h    1.5    5/12/94     */
X
X#define VERSION 1
X#define PATCHLEVEL 11
X
X
END_OF_FILE
  if test 81 -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'\" \(11205 characters\)
  sed "s/^X//" >'sybperl.1' <<'END_OF_FILE'
X.\".po 4
X.\"    @(#)sybperl.1    1.6    6/8/94
X.TH SYBPERL 1 "25 May 1994"
X.ad
X.nh
X.SH NAME
Xsybperl \- Perl access to Sybase databases
X.SH SYNOPSIS
X.nf
X$ret     = &dbcancel([$dbproc])
X$ret     = &dbcanquery([$dbproc])
X$ret     = &dbcmd([$dbproc,] $sql_cmd)
X       &dbclose([$dbproc])
X$len     = &dbcollen([$dbproc], $colid)
X$name    = &dbcolname([$dbproc], $colid)
X$type    = &dbcoltype([$dbproc], $colid)
X$ret     = &dberrhandle($handler)
X$ret     = &dbexit()
X$ret     = &dbfreebuf([$dbproc])
X$status  = &dbhasretstat([$dbproc])
X$dbproc  = &dblogin([$user[, $pwd[, $server]]])
X$ret     = &dbmsghandle($handler)
X@data    = &dbnextrow([$dbproc [, $doAssoc]])
X$count   = &dbnumcols([$dbproc])
X$dbproc1 = &dbopen([$server])
X$ret     = &dbresults([$dbproc])
X@data    = &dbretdata([$dbproc [, $doAssoc]])
X$status  = &dbretstatus([$dbproc])
X$string  = &dbsafestr($dbproc, $instring [,$quote_char])
X$ret       = &dbsetopt($dbproc, $option, $char_param [,$int_param])
X$ret     = &dbsqlexec([$dbproc])
X$string  = &dbstrcpy([$dbproc])
X$ret     = &dbuse([$dbproc,] $database)
X$status  = &dbwritetext($dbproc_1, $col_name, $dbproc_2, $select_col, $text)
X$ret     = &DBCURCMD([$dbproc])
X$status  = &DBMORECMD([$dbproc])
X$status  = &DBCMDROW([$dbproc])
X$status  = $DBROWS([$dbproc])
X$ret     = $DBCOUNT([$dbproc])
X$ret     = $DBSETLCHARSET(char-set)
X$ret     = $DBSETLNATLANG(language)
X
X($status, $sum)    = &dbmny4add([$dbproc,] $m1, $m2)
X$status        = &dbmny4cmp([$dbproc,] $m1, $m2)
X($status, $quotient)    = &dbmny4divide([$dbproc,] $m1, $m2)
X($status, $dest)    = &dbmny4minus([$dbproc,] $source)
X($status, $product)    = &dbmny4mul([$dbproc,] $m1, $m2)
X($status, $difference)    = &dbmny4sub([$dbproc,] $m1, $m2)
X($status, $ret)    = &dbmny4zero([$dbproc])
X($status, $sum)    = &dbmnyadd([$dbproc,] $m1, $m2)
X$status        = &dbmnycmp([$dbproc,] $m1, $m2)
X($status, $ret)    = &dbmnydec([$dbproc,] $m1)
X($status, $quotient)    = &dbmnydivide([$dbproc,] $m1, $m2)
X($status, $ret, $remainder) = &dbmnydown([$dbproc,] $m1, $divisor)
X($status, $ret)    = &dbmnyinc([$dbproc,] $m1)
X($status, $ret, $remain)    = &dbmnyinit([$dbproc,] $m1, $trim)
X($status, $ret)        = &dbmnymaxneg([$dbproc])
X($status, $ret)        = &dbmnymaxpos([$dbproc])
X($status, $dest) = &dbmnyminus([$dbproc,] $source)
X($status, $product)    = &dbmnymul([$dbproc,] $m1, $m2)
X($status, $m1, $digits, $remain)    = &dbmnyndigit([$dbproc,] $m1)
X($status, $ret)        = &dbmnyscale([$dbproc,] $m1, $multiplier,
X                $addend)
X($status, $difference)    = &dbmnysub([$dbproc,] $m1, $m2)
X($status, $ret)    = &dbmnyzero([$dbproc])
X
X$status    = &BCP_SETL($state)
X$status = &bcp_getl;
X$status = &bcp_init([$dbproc,] $tblname, $hostfile, $errfile, $dir)
X$status = &bcp_meminit([$dbproc,] $numcols)
X$status = &bcp_sendrow($dbproc, $col1, $col2, ...)
X$status = &bcp_batch([$dbproc])
X$status = &bcp_done([$dbproc])
X$status = &bcp_control([$dbproc,] $field, $value)
X$status = &bcp_columns([$dbproc,] $host_columns)
X$status = &bcp_colfmt([$dbproc,] $host_column, $host_type,
X              $host_prefixlen, $host_collen, $host_term,
X              $host_termlen, $table_colnum)
X($status, $rows_copied) = &bcp_exec([$dbproc])
X$status = &bcp_readfmt([$dbproc,] $filename)
X$status = &bcp_writefmt([$dbproc,] $filename)
X
X$SUCCEED        $MORE_ROWS            $EXCEPTION    $EXPROGRAM
X$FAIL            $REG_ROW            $EXSIGNAL    $EXSERVER
X$NO_MORE_ROWS    $BUF_FULL            $EXINFO    $EXCOMM
X$NO_MORE_RESULTS    $NO_MORE_PARAMS        $EXDBLIB    $EXTIME
X$ComputeId        $DBSAVE            $EXFORMS    $EXFATAL
X$DBstatus        $DBNOSAVE            $EXUSER
X$SybperlVer        $DBNOERR            $EXLOOKUP
X$STDEXIT        $DB_PASSTHRU_MORE    $EXSCREENIO
X$ERREXIT        $DB_PASSTHRU_EOM        $EXCLIPBOARD
X$INT_EXIT        $DBNOPROC            $EXNONFATAL
X$INT_CONTINUE                    $EXCONVERSION
X$INT_CANCEL                        $EXRESOURCE
X$INT_TIMEOUT                        $EXCONSISTENCY
X$DB_IN        $DB_OUT
X$BCPMAXERRS    $BCPFIRST    $BCPLAST    $BCPBATCH
X$DBTRUE        $DBFALSE
X$SybPackageBug
X$dbNullIsUndef    $dbKeepNumeric    $dbBin0x
X.fi
X.SH DESCRIPTION
X\fBSybperl\fP is a version of \fIPerl\fP which has been extended (via
Xthe \fIusersubs\fP feature) to allow access to \fISybase\fP databases.
X
X\fBSybperl\fP maps a subset of the \fISybase
XDB-Library\fP API to \fIPerl\fP. The usage of these functions is the same
Xas in \fIDB-Library\fP, unless specifically noted.
X
X\fBDifferences with DB-Library:\fP
X
X\fB&dblogin\fP takes 3 optional arguements (the userid, the
Xpassword and the server to connect to). These default to the Unix
Xuserid, the null password and the default server (from the DSQUERY
Xenvironment variable).
X
X\fB&dblogin\fP returns a \fBDBPROCESS\fP, not a \fBLOGINREC\fP. This
Xsimplifies the call to open a connection to a Sybase dataserver
Xsomewhat. If the login fails for any reason \fB&dblogin\fP returns -1.
X\fB&dblogin\fP can be called multiple times to login to different
Xservers, or to login as several users simultaneously.
X
XFurther \fBDBPROCESSes\fP can be opened using
X\fB&dbopen([$server])\fP, using the login information from the
Xlast call to \fB&dblogin()\fP. The number of simultaneous DBPROCESSes
Xis limited to 25 (This can be changed by altering a #define in sybperl.c).
X
XThe \fB$dbproc\fP parameter used by most subroutines is optional,
Xand defaults to the DBPROCESS returned
Xby the first call to \fB&dblogin\fP (exceptions: \fB&dbsafestr()\fP,
X\fB&dbwritetext()\fP and \fB&bcp_sendrow()\fP require explicit \fB$dbproc\fP parameters.)
X
X\fB&dbnextrow\fP returns an array of formatted data, based on the
Xdatatype of the corresponding columns. \fB&dbnextrow\fP sets the
Xvariable \fB$ComputeId\fP when the result row is a computed row (the
Xresult of a \fIcompute by\fP clause). If the optional \fB$doAssoc\fP
Xparameter is non-zero \fB&dbnextrow\fP returns an
Xassociative array keyed on the column name of each returned field. If
Xthe column name is null (as for example in the case of an aggregate),
Xthen \fB&dbnextrow\fP assigns a column name based on the column number.
X
X\fB&dbretdata\fP returns an array of the parameters
Xdeclared as \fBOUTput\fP in an \fBEXEC\fP stored procedure statement.
XIf the ooptional \fB$doAssoc\fP parameter is non-zero, then an
Xassociative array keyed on the name of the parameters is returned
X(again, if the parameters are unnamed, the key is based on the
Xparamter number). A single call will
Xreturn all the parameters for the last \fBEXEC\fP statement.
X
X\fB&dbsafestr\fP takes a string literal ' or " as the third [optional] argument
Xand means \fBDBSINGLE\fP or \fBDBDOUBLE\fP, respectively.
XOmission of the third argument means \fBDBBOTH\fP.
X
XIn order to simplify its use somewhat, the calling sequence of
X\fB&dbwritetext\fP has been changed. \fI$select_proc\fP and
X\fI$select_col\fP are the dbproc and column number of a currently
Xactive query. Logging is always off.
X
XNote that all DBMONEY routines which in the C version take pointers to
Xarguments (in order to return values) return these values in an array
Xinstead (eg: status = dbmnyadd(dbproc, m1, m2, result) becomes
X($status, $result) = &dbmnyadd($dbproc, $m1, $m2))
X
XCopying data from program variables into a Sybase table using BCP has
Xbeen implemented in a slightly different manner. Instead of using
Xbcp_bind(), you need to call &bcp_meminit() to determine the number of
Xcolumns that will be sent to the server, and the call &bcp_sendrow()
Xwith the data for each row (see \fBEXAMPLES\fP, below). Passing
X\fBundef\fP as one of the data
Xvalues will result in a \fBNULL\fP value being sent to the server for
Xthat column.
X
X\fBVariables:\fP
X
X\fBSybperl\fP defines a number of Read-Only variables, and three
XRead-Write variables. Most of the variables correspond to #define's in
Xthe \fIOpenClient\fP include files (see the Sybase documentation for
Xmore information).
X
XThe \fBSybperl\fP specific variables are:
X
X\fB$ComputeId\fP \- Set by \fB&dbnextrow\fP when it processes a
X\fIcompute row\fP as opposed to a normal results row.
X.br
X\fB$DBstatus\fP \- The status returned by the last call to
X\fBdbnextrow()\fP.
X.br
X\fB$SybperlVer\fP \- The Sybperl release version.
X.br
X\fB$SybPackageBug\fP \- Set to TRUE if \fBSybperl\fP was compiled with
Xthe option to circumvent a bug in \fBPerl's\fP implementation of
Xpackages. This variable is undefined otherwise.
X.br
X\fB$dbNullIsUndef\fP \- This variable controls whether NULL values
Xreturned from a query will be returned as the string '\fINULL\fP' (the
Xdefault) or as the \fBPerl\fP \fIundef\fP value.
X.br
X\fB$dbKeepNumeric\fP \- This variable controls whether numeric
Xdatatypes returned by queries are converted to strings (the default)
Xor left in native format.
X.br
X\fB$dbBin0x\fP \- This variable controls whether variables of type
X\fBSYBBINARY\fP are returned with a leading \fB0x\fP or not (the
Xdefault).
X
XThese last three variables are all boolean.
X
X.SH "UNIMPLEMENTED FEATURES"
X
X\fB&dbfcmd\fP is not implemented, but can be emulated by using
X\fIsprintf\fP as in \fI&dbcmd($dbproc, sprintf("%d", $num_val))\;\fP
X
X.SH EXAMPLES
X
XUsing &dbretdata():
X
X.nf
X    &dbcmd($dbproc, "declare @data int\n");
X    &dbcmd($dbproc, "exec my_stored_proc @data out\n");
X    &dbsqlexec($dbproc);
X    &dbresults($dbproc);
X    while(&dbnextrow($dbproc))
X    {
X        ;    # empty loop...
X    }
X    ($ret) = &dbretdata($dbproc);
X.fi
X
XDoing a Bulk Copy from program variables into a Sybase table:
X
X.nf
X    &BCP_SETL($DBTRUE);
X    $dbproc = &dblogin;
X    &bcp_init($dbproc, "test.dbo.t2", '', 'bcp.err', $DB_IN);
X    &bcp_meminit($dbproc, 3);   # we wish to copy three columns into
X                    # the 't2' table
X    while(<>)
X    {
X        chop;
X        @dat = split(' ', $_);
X        &bcp_sendrow($dbproc, @dat);
X    }
X    $ret = &bcp_done($dbproc);
X.fi
X
X
X
X.SH OPTIONS
X
XSee the \fIPerl(1)\fP manual page.
X
X.SH BUGS
X
XMemory usage can become very large in certain conditions when
Xusing a version of Perl prior to 4.035. This
Xcan be circumvented - see the BUGS file in the Sybperl distribution.
X
XIf \fB&dbnextrow\fP encounters a datatype that it does not know about,
Xit tries to convert it to SYBCHAR, and to store it in a 256 byte
Xbuffer - without checking for overflow.
X
XThe handling of multiple logins isn't really clean. A call to
X\fB&dblogin\fP sets the values for the User name and Password. These
Xvalues are remembered - and used in calls to \fB&dbopen\fP - until
Xthey are changed in a new call to \fB&dblogin()\fP. It is possible to
Xavoid the use of \fB&dbopen\fP alltogether, and simply call
X\fB&dblogin\fP each time a new \fBDBPROCESS\fP is required.
X
XThis man page only covers \fBdifferences\fP between \fBsybperl\fP's
Ximplementation of the API and \fBDBlibrary\fP itself. A form of
Xtutorial in using \fBsybperl\fP is probably needed.
X
X.SH FILES
X
X\fI$PERLLIB/sybperl.pl\fP should be called in all \fBsybperl\fP
Xscripts to set the correct environment variables used by DB-Library.
XA sample \fI$PERLLIB/sybdb.ph\fP is provided with sybperl. You may
Xwant to use \fBh2ph\fP to add definitions to this file.
X
X.SH "SEE ALSO"
X
X\fIPerl(1L), Sybase Open Client DB Library Reference Manual, h2ph(1L).\fP
X
X.SH AUTHOR
X
X.nf
XMichael Peppler, ITF Management SA \- [e-mail]
X.fi
XJeffrey Wong ([e-mail]) contributed the
XOpenClient R4.6.1 DBMONEY routines
XBrent Milnor ([e-mail]) contributed &dbwritetext().
XEric Fifer ([e-mail]) contributed corrections to the
X&dblogin()/&dbopen() sequence.
XMark Lawrence ([e-mail]) contributed &dbsafestr().
XMichael Bloom ([e-mail]) contributed code to handle SYBIMAGE data.
XDon Preuss ([e-mail]) contributed the &dbcolXXX() calls.
X
END_OF_FILE
  if test 11205 -ne `wc -c <'sybperl.1'`; then
    echo shar: \"'sybperl.1'\" unpacked with wrong size!
  fi
  # end of 'sybperl.1'
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'\" \(5086 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
Xunshift(@INC, '../lib');
X
Xrequire "sybperl.pl";
X
Xprint "Sybperl version $SybperlVer\n\n";
Xprint "PACKAGE_BUG is defined - sybdb_redefs.pl has been loaded\n" if (defined($SybPackageBug) && $SybPackageBug == 1);
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[1].$tab[0]...\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 5086 -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 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...