package Apache::Sybase::DBlib;


use Sybase::DBlib;
use strict;

sub message_handler
{
   my ($db, $message, $state, $severity, $text, $server, $procedure, $line)
       = @_;

       my($row);
   if ($severity > 0)
   {
       print STDERR ("Sybase message ", $message, ", Severity ", $severity,
              ", state ", $state);
       print STDERR ("\nServer `", $server, "'") if defined ($server);
       print STDERR ("\nProcedure `", $procedure, "'") if defined ($procedure);
       print STDERR ("\nLine ", $line) if defined ($line);
       print STDERR ("\n    ", $text, "\n\n");

       if(defined($db))
       {
           my ($lineno, $cmdbuff) = (1, undef);

           $cmdbuff = &Sybase::DBlib::dbstrcpy($db);

           foreach $row (split (/\n/, $cmdbuff))
           {
               print STDERR (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
           }
       }
   }
   elsif ($message == 0)
   {
       print STDERR ($text, "\n");
   }

   0;
}

sub error_handler {
   my ($db, $severity, $error, $os_error, $error_msg, $os_error_msg)
       = @_;
   # Check the error code to see if we should report this.
   if ($error != SYBESMSG) {
       print STDERR ("Sybase error: ", $error_msg, "\n");
       print STDERR ("OS Error: ", $os_error_msg, "\n") if defined ($os_error_msg);
   }

   INT_CANCEL;
}

&dbmsghandle ("message_handler"); # Some user defined error handlers
&dberrhandle ("error_handler");

my(%Connected);

sub connect {
   my($self, @args) = @_;
       my($Uid, $Pwd, $Srv) = @args;
   my $idx = join ":", (@args) || (@{$self});
   return $Connected{$idx} if $Connected{$idx};
   print STDERR "connecting to $idx...\n" if $main::DEBUG;
   $Connected{$idx} = Sybase::DBlib->dblogin($Uid, $Pwd, $Srv);
}

sub DESTROY {
}

1;

__END__

=head1 NAME

Apache::Sybase::DBlib - persistent database connection via DBlib

=head1 SYNOPSIS

use Apache::Sybase::DBlib;

$dbh = Apache::Sybase::DBlib->connect($Uid, $Pwd, $Srv);

=head1 DESCRIPTION

This module provides a persistent database connection via Sybase DBlib.

All you really need is to replace Sybase::Ctlib with Apache::Sybase.
When connecting to a database the module looks if a database
handle from a previous connect request is already stored. If
not, a new connection is established and the handle is stored
for later re-use. The destroy method has been intentionally
left empty.

=head1 SEE ALSO

Apache(3)

=head1 AUTHORS

mod_perl by Doug MacEachern <[email protected]>
Apache::DBI by Edmund Mergl <[email protected]>

----------------------------------------------------
#       @(#)dblib.t     1.17    2/20/96

package TEST;

use CGI::Switch;
use Apache::Sybase::DBlib;

$obj = new CGI::Switch;

$ENV{'SYBASE'}="xxxxxxxx"; Sorry, let you fill in the xxxxx!!
$ENV{'DSQUERY'}="xxxxxxxx";
$Srv = $ENV{'DSQUERY'};
$Uid = "xxxx";
$Pwd = "xxxxxxxx";
$database = "xxx";

my($rows,$count, $ref);
$rows=0; $count=0; $ref="";

print $obj->header();
print $obj->start_html("Test of Apache::Sybase::DBlib");

# This test file is still under construction...
$Version = $SybperlVer;
$Version = $Sybase::DBlib::Version;
$Sybase::DBlib::Att{UseDateTime} = TRUE;

print "<H1>Test of Apache::Sybase::DBlib</H1>\n";
print "<PRE>\nSybperl Version $Version\n";

( $X = Apache::Sybase::DBlib->connect($Uid, $Pwd, $Srv) )
   and print("ok 1\n")
   or print "not ok 1
-- The supplied login id/password combination may be invalid\n";

( $X->dbuse('master') == &Apache::Sybase::DBlib::SUCCEED )
   and print("ok 2\n")
   or print "not ok 2\n";

($X->dbcmd("select count(*) from systypes") == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 3\n")
   or print "not ok 3\n";

($X->dbsqlexec == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 4\n")
   or print "not ok 4\n";

($X->dbresults == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 5\n")
   or print "not ok 5\n";

($count) = $X->dbnextrow;
($X->{DBstatus} == &Apache::Sybase::DBlib::REG_ROW)
   and print "ok 6\n"
   or print "not ok 6\n";

$X->dbnextrow;
($X->{DBstatus} == &Apache::Sybase::DBlib::NO_MORE_ROWS)
   and print "ok 7\n"
   or print "not ok 7\n";

($X->dbresults == &Apache::Sybase::DBlib::NO_MORE_RESULTS)
   and print("ok 8\n")
   or print "not ok 8\n";

($X->dbcmd("select * from systypes") == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 9\n")
   or print "not ok 9\n";

($X->dbsqlexec == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 10\n")
   or print "not ok 10\n";

($X->dbresults == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 11\n")
   or print "not ok 11\n";

$err = 0;
while(@row = $X->dbnextrow) {
       $rows++;
       ++$err if($X->{DBstatus} != &Apache::Sybase::DBlib::REG_ROW);
}
($err == 0)
   and print("ok 12\n")
   or print "not ok 12\n";

($count == $rows)
   and print "ok 13\n"
   or print "not ok 13, count=|$count|, rows=|$rows|\n";

# Now we make a syntax error, to test the callbacks:

&Sybase::DBlib::dbmsghandle (\&msg_handler); # different handler to check callbacks

($X->dbcmd("select * from systypes\nwhere") == &Apache::Sybase::DBlib::SUCCEED)
   and print("ok 14\n")
   or print "not ok 14\n";

($X->dbsqlexec == &Apache::Sybase::DBlib::FAIL)
   and print("ok 16\n")
   or print "not ok 16\n";

&Apache::Sybase::DBlib::dbmsghandle ("message_handler"); # Some user defined error handlers

$date1 = $X->newdate('Jan 1 1995');
$date2 = $X->newdate('Jan 3 1995');

($date1 < $date2)
   and print "ok 17\n"
   or print "not ok 17\n";

($days, $msecs) = $date1->diff($date2);
($days == 2 && $msecs == 0)
   and print "ok 18\n"
   or print "not ok 18\n";

$ref = $X->sql("select getdate()");
(ref (${$$ref[0]}[0]) eq 'Apache::Sybase::DBlib::DateTime')
       and print "ok 19\n"
   or print "not ok 19, ref=|",ref(${$$ref[0]}[0]),"|, value=|",${$$ref[0]}[0],"|\n";

print "</PRE></BODY></HTML>\n";

sub message_handler {
       my ($db, $message, $state, $severity, $text, $server, $procedure, $line)
               = @_;

       if ($severity > 0) {
               print STDERR ("Sybase message ", $message, ", Severity ", $severity,
                                         ", state ", $state);
               print STDERR ("\nServer `", $server, "'") if defined ($server);
               print STDERR ("\nProcedure `", $procedure, "'") if defined ($procedure);
               print STDERR ("\nLine ", $line) if defined ($line);
               print STDERR ("\n    ", $text, "\n\n");

               # &dbstrcpy returns the command buffer.

               if(defined($db)) {
                       my ($lineno, $cmdbuff) = (1, undef);

                       $cmdbuff = &Apache::Sybase::DBlib::dbstrcpy($db);

                       foreach $row (split (/\n/, $cmdbuff)) {
                               print STDERR (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
                       }
               }
       } elsif ($message == 0) {
               print STDERR ($text, "\n");
       }

   1;
}

sub error_handler {
   my ($db, $severity, $error, $os_error, $error_msg, $os_error_msg)
               = @_;
   # Check the error code to see if we should report this.
   if ($error != SYBESMSG) {
               print STDERR ("Sybase error: ", $error_msg, "\n");
               print STDERR ("OS Error: ", $os_error_msg, "\n") if defined ($os_error_msg);
   }

   INT_CANCEL;
}

sub msg_handler {
       my ($db, $message, $state, $severity, $text, $server, $procedure, $line)
               = @_;

       if ($severity > 0) {
               ($message == 102)
                       and print("ok 15\n")
                               or print("not ok 15\n");
       }
       1;
}

----------------------------------
Last but not least, the screen dump from Netscape:
Test of Apache::Sybase::DBlib

Sybperl Version This is sybperl, version 2.07

Sybase::DBlib version 1.31 02/04/97

Copyright (c) 1991-1997 Michael Peppler


ok 1
ok 2
ok 3
ok 4
ok 5
ok 6
ok 7
ok 8
ok 9
ok 10
ok 11
ok 12
ok 13
ok 14
ok 15
ok 16
ok 17
ok 18
not ok 19, ref=||, value=|Mar 19 1997  8:12:42:713PM|

Now I have a BIG question about test 19.  The ref item is a date, but
ref(date) is null.  ??????

Sorry, but I will not have any time to maintain or update this
module.  ANYONE who wants to take it over and put their name on it is
OK with me.

--
Brian Millett
Technology Applications Inc.     "Heaven can not exist,
(314) 530-1981                          If the family is not eternal"
[email protected]                   F. Ballard Washburn