DBD-ODBC
10 results

 view release on metacpan or  search on metacpan

examples/DbiTest.pl  view on Meta::CPAN 

	DbSrcLoginName    => 'sa',
	DbSrcPassword     => '',
);

my @dbhPool;

##########################################
### Functions
##########################################

sub newDbh()
{my $dbh;
	if(defined($options{DbSrcServer}) && defined($options{DbSrcLoginName}) && defined($options{DbSrcDatabase}))
	{	my $dsn = "DRIVER={SQL Server};SERVER=$options{DbSrcServer};DATABASE=$options{DbSrcDatabase};NETWORK=dbmssocn;UID=$options{DbSrcLoginName};PWD=$options{DbSrcPassword}";
#		print "DSN: $dsn\n\n";
		
		$dbh = DBI->connect("DBI:ODBC:$dsn") || die "DBI connect failed: $DBI::errstr\n";
		$dbh->{AutoCommit} = 0;	# enable transactions, if possible
		$dbh->{RaiseError} = 0;
		$dbh->{PrintError} = 1;	# use RaiseError instead
		$dbh->{ShowErrorStatement} = 1;
		
		push @dbhPool, $dbh;
		return($dbh);
	}
}


sub test($;$)
{	my ($outputTempate, $recurse) = @_;
	
	my $dbh = newDbh();
	my $queryInputParameter1 = 2222;
	my $queryOutputParameter = $outputTempate;
	
	my $sth = $dbh->prepare('{? = call testPrc(?) }');
	$sth->bind_param_inout(1, \$queryOutputParameter, 30, { TYPE => DBI::SQL_INTEGER });
	$sth->bind_param(2, $queryInputParameter1, { TYPE => DBI::SQL_INTEGER });

examples/DbiTest2.pl  view on Meta::CPAN 

	DbSrcLoginName    => 'sa',
	DbSrcPassword     => '',
);

my @dbhPool;

##########################################
### Functions
##########################################

sub newDbh()
{my $dbh;
	if(defined($options{DbSrcServer}) && defined($options{DbSrcLoginName}) && defined($options{DbSrcDatabase}))
	{	my $dsn = "DRIVER={SQL Server};SERVER=$options{DbSrcServer};DATABASE=$options{DbSrcDatabase};NETWORK=dbmssocn;UID=$options{DbSrcLoginName};PWD=$options{DbSrcPassword}";
#		print "DSN: $dsn\n\n";

		$dbh = DBI->connect("DBI:ODBC:$dsn") || die "DBI connect failed: $DBI::errstr\n";
		$dbh->{AutoCommit} = 0;	# enable transactions, if possible
		$dbh->{RaiseError} = 0;
		$dbh->{PrintError} = 1;	# use RaiseError instead
		$dbh->{ShowErrorStatement} = 1;

		push @dbhPool, $dbh;
		return($dbh);
	}
}


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

	my $dbh = newDbh();
	my $sth = $dbh->prepare('select ID from (select 1 as ID union select 2 as ID union select 3 as ID) tmp order by ID');

	$sth->execute();

#	print '$sth->{Active}: ', $sth->{Active}, "\n";
	do
	{	for(my $rowRef = undef; $rowRef = $sth->fetchrow_hashref('NAME'); )
		{	#print '%$rowRef ', Dumper(\%$rowRef), "\n";
			innerTest($outputTempate);
		}
	} while($sth->{odbc_more_results});
}



my $innerTestSth;

sub innerTest($)
{	my ($outputTempate) = @_;

	my %outputData;
	my $queryInputParameter1 = 2222;
	my $queryOutputParameter = $outputTempate;

	my $sth;

	if(!defined $innerTestSth)
	{	my $dbh = newDbh();

examples/longbin.pl  view on Meta::CPAN 

   if ($digest ne $md5sums[$row[0]]) {
      print "$row[0]: Digests don't match $digest, $md5sums[$row[0]]!\n";
   } else {
      print "Good read!\n";
   }
}


$dbh->disconnect();

sub readblobfile($) {
   my $filename = shift;
   local(*FILE, $\);	# automatically close file at end of scope
   open(FILE, "<$filename") or die "Can't open file $!\n";
   binmode(FILE);
   <FILE>;
}

sub getFileMD5 ($) {
    my $filename = shift;

    open(F, $filename) or die "Can't open file name $filename\n";
    binmode(F);
    my $md5 = new MD5;
    seek(F, 0, 0);	# just in case?  part of docs, I left in.
    $md5->reset;
    $md5->addfile(\*F);
    close(F);
    $md5->hexdigest;
}

sub get_first_type_info($$) {
   my $dbh = shift;
   my $type = shift;

   my @typeinfo = $dbh->type_info($type);

   return $typeinfo[0]->{TYPE_NAME};
   
}

examples/proctest2.pl  view on Meta::CPAN 

\@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)");

my $innerTestSth;

sub innerTest($)
{
   my ($outputTempate) = @_;

   my %outputData;
   my $queryInputParameter1 = 2222;
   my $queryOutputParameter = $outputTempate;

   if(!defined $innerTestSth) {
      $innerTestSth = $dbh2->prepare('{? = call PERL_DBD_TESTPRC(?) }');
   }

examples/proctest2.pl  view on Meta::CPAN 

      print "Columns: ", join(', ', @{$innerTestSth->{NAME}}), "\n";
      for(;$rowRef = $innerTestSth->fetchrow_hashref(); ) {
	 print '%$rowRef2 ', Dumper(\%$rowRef), "\n";
      }
   } while($innerTestSth->{odbc_more_results});

   print '$queryOutputParameter: \'', $queryOutputParameter, '\' expected: (', $queryInputParameter1 + 1, ")\n\n";
}


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

   my $queryInputParameter1 = 2222;
   my $queryOutputParameter = $outputTempate;
   my $sth = $dbh->prepare('select ID from (select 1 as ID union select 2 as ID union select 3 as ID) tmp order by ID');

   $sth->execute();
   do {
      for(my $rowRef = undef; $rowRef = $sth->fetchrow_hashref('NAME'); ) {

examples/proctest3.pl  view on Meta::CPAN 

};

$dbh->do("CREATE PROCEDURE  PERL_DBD_TESTPRC
\@parameter1 int = 0
AS
	if (\@parameter1 >= 0)
	    select * from systypes
        RETURN(\@parameter1)
	");

sub test()
{
   my $sth = $dbh->prepare("{call PERL_DBD_TESTPRC(?)}");

   $sth->bind_param(1, -1, { TYPE => 4 });
   $sth->execute();

   print '$sth->{NUM_OF_FIELDS}: ', $sth->{NUM_OF_FIELDS}, " expected: 0\n";
   if($sth->{NUM_OF_FIELDS}) {
      my @row;
      while (@row = $sth->fetchrow_array()) {

examples/raiserror.pl  view on Meta::CPAN 

};

$dbh->do(<<'EOT');
CREATE PROCEDURE  t_raiserror (@p1 varchar(50), @p2 int output)
AS
set @p2=45;
raiserror ('An error was raised. Input was "%s".', 16, 1, @p1)
return 55
EOT

sub test()
{
   my $sth = $dbh->prepare("{? = call t_raiserror(?,?)}");

   my ($p1, $p2) = ('fred', undef);
   $sth->bind_param_inout(1, \my $retval, 4000);
   $sth->bind_param(2, $p1);
   $sth->bind_param_inout(3, \$p2, 32);
   $sth->execute();
   print qq/After execute:\n/;
   print "err=", $sth->err(), "\n";

examples/testconn.pl  view on Meta::CPAN 

	return undef;
    }

    if (ref($res) eq 'ARRAY') {
	return $res;
    } else {
	return $sth;
    }
}

sub conn() {
#    print STDERR "Connecting (to $sid as $user/$passwd)...";
    my $db = DBI->connect_cached("dbi:SAP_DB:$sid", $user, $passwd,
			  {
			      AutoCommit=>0,
			      LongReadLen=>10000,
			  }
			  );

    unless ($db) {
	die "Failed to connect to the database $sid as user $user with password $passwd: ".$DBI::errstr;
    }
#    print STDERR "Done.\n";
    return $db;
}

sub status($) {
    my $line = shift;

    open STATUS, "</proc/self/status";
    my %status;
    while (my $l = <STATUS>) {
	if ($l =~ /^([^:]+):\s+(\S+)/) {
	    $status{$1} = $2;
	}
    }
    close STATUS;

examples/testmoney.pl  view on Meta::CPAN 

#!perl -w
# $Id$


use strict;
use DBI;

sub printtable($) {
   my $dbh = shift;
   my $sthread = $dbh->prepare("select TypeName, ProvLevel1, ProvLevel2, Action from perl_test_dbd1 order by typename");
   $sthread->execute;
   my @row;
   while (@row = $sthread->fetchrow_array) {
      print join(', ', @row), "\n";
   }
   print "-----\n";
}

t/UChelp.pm  view on Meta::CPAN 

use Test::More;

BEGIN {
    use Exporter();
    @ISA = qw(Exporter);
    @EXPORT=qw(&dumpstr &utf_eq_ok);
}
use strict;
use warnings;

sub dumpstr($)
{
	my $str=shift;
	if (defined $str) {
		my ($f,$u)=utf8::is_utf8($str) ? ('\\x{%04X}','utf8') : ('\\x%02X','bytes');
		(my $d=$str)=~s/([^\x20-\x7E])/sprintf($f,ord $1)/gse;
		return sprintf("[%s, %i chars] '%s'",$u,length($str),$d);
	} else {
		return 'undef';
	}
}

sub utf_eq_ok($$$)
{
	my ($a,$b,$msg)=@_;
	
	# I want to call Test::More routines in a way that makes this package invisible,
	# and shows the failed or passed line of the caller instead.
	# So I manipulate @_ and use goto \&func.

	(!defined($a) and !defined($b)) and return pass($msg);
	unless (defined($a) and defined($b)) {
		diag(defined($a) ? "Expected undef, got '$a'" : "Got undef, expected '$b'");

t/rt_78838.t  view on Meta::CPAN 

        $sth->bind_param(1, $obj);
    };
    ok($@, "cannot bind a plain reference"); # 4

    $sth = undef;
}
$dbh->disconnect;

package Object;
use overload '""' => 'to_s';
sub new() { bless { }, shift };
sub to_s() { my $self = shift; ref($self); }



( run in 0.365 second using v1.01-cache-2.11-cpan-1f129e94a17 )