libdbd-odbc-perl 1.56-1 / usr / share / doc / libdbd-odbc-perl / examples / proctest1.pl

#!/usr/bin/perl -w
# $Id$


use DBI;
use strict;
use Data::Dumper;
use warnings;

my $dbh = DBI->connect();

eval {
   local $dbh->{PrintError} = 0;
   $dbh->do("drop procedure PERL_DBD_TESTPRC");
};

$dbh->do("CREATE PROCEDURE  PERL_DBD_TESTPRC
\@parameter1 int = 22
AS
	/* SET NOCOUNT ON */
	select 1 as some_data
	select isnull(\@parameter1, 0) as parameter1, 3 as some_more_data
print 'kaboom'
	RETURN(\@parameter1 + 1)");

$dbh->disconnect;

sub test
{
   my ($outputTempate, $recurse) = @_;

   my $queryInputParameter1 = 2222;
   my $queryOutputParameter = $outputTempate;
   my $dbh = DBI->connect;
   local $dbh->{odbc_async_exec} = 1;
   my $testpass = 0;
   sub err_handler {
      my ($state, $msg) = @_;
      # Strip out all of the driver ID stuff
      $msg =~ s/^(\[[\w\s]*\])+//;
      print "===> state: $state msg: $msg\n";
      $testpass++;
      return 0;
   }
   local $dbh->{odbc_err_handler} = \&err_handler;

   my $sth = $dbh->prepare('{? = call PERL_DBD_TESTPRC(?) }');
   $sth->bind_param_inout(1, \$queryOutputParameter, 30, { TYPE => DBI::SQL_INTEGER });
   $sth->bind_param(2, $queryInputParameter1, { TYPE => DBI::SQL_INTEGER });

   $sth->execute();

	print '$sth->{Active}: ', $sth->{Active}, "\n";
	if (1) {
	   do {
		 for(my $rowRef; $rowRef = $sth->fetchrow_hashref('NAME'); )  {
		    my %outputData = %$rowRef;

		    print 'outputData ', Dumper(\%outputData), "\n";
		    if($recurse > 0)  {
		       test($dbh, --$recurse);
		    }
		 }
	   } while($sth->{odbc_more_results});
	}
	print '$queryOutputParameter: \'', $queryOutputParameter,
		'\' expected: (', $queryInputParameter1 + 1, ")\n\n";
	print "Err handler called $testpass times\n";
}




##########################################
### Test
##########################################

unlink("dbitrace.log") if (-e "dbitrace.log");
$dbh->trace(9, "dbitrace.log");
test(0,       0);
test(10,      0);
test(100,     0);
test('     ', 0);

test(0, 1);	#recusion

##########################################
### Cleanup...
##########################################



$dbh->disconnect;