DBD-Sybase-1.14/0040755000076500007650000000000011642076574013540 5ustar mpepplermpepplerDBD-Sybase-1.14/t/0040755000076500007650000000000011642076574014003 5ustar mpepplermpepplerDBD-Sybase-1.14/t/login.t0100644000076500007650000000136410607476107015275 0ustar mpepplermpeppler#!perl # # $Id: login.t,v 1.4 2007/04/12 16:09:36 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; use Test::More tests => 6; use vars qw($Pwd $Uid $Srv $Db); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError => 1}); #DBI->trace(0); ok($dbh, 'Connect'); ok $dbh->ping, "ping should pass after connect"; $dbh->disconnect if $dbh; ok !$dbh->ping, "ping should fail after disconnect"; $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", 'ohmygod', 'xzyzzy', {PrintError => 0}); ok(!$dbh, 'Connect fail'); $dbh->disconnect if $dbh; exit(0); DBD-Sybase-1.14/t/autocommit.t0100644000076500007650000000410410571606237016340 0ustar mpepplermpeppler#!/usr/bin/perl # # $Id: autocommit.t,v 1.6 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; use Test::More tests => 9; #use Test::More qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); #DBI->trace(2); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 11) { ok(0); } exit(0); } $dbh->do("create table #ttt (foo varchar(20), bar int)"); $dbh->{AutoCommit} = 0; $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->rollback; my $sth = $dbh->prepare("select * from #ttt"); $sth->execute; my $found = 0; while(my $d = $sth->fetch) { print "@$d\n"; ++$found; } ok(!$found, 'rollback'); $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->commit; $sth = $dbh->prepare("select * from #ttt"); $sth->execute; $found = 0; while(my $d = $sth->fetch) { print "@$d\n"; ++$found; } ok($found == 4, 'Commit'); # Add some tests to validate the begin_work() functionality $dbh->{AutoCommit} = 1; $dbh->begin_work; $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->commit; ok($dbh->{AutoCommit} == 1, "begin_work"); # Test to check for problems with non-chained mode. $dbh->{syb_chained_txn} = 0; $dbh->{AutoCommit} = 0; $sth = $dbh->prepare("select 5"); ok($sth, "Non-chained prepare"); my $rc = $sth->finish; ok($rc, "Finish"); $rc = $dbh->commit; ok($rc, "commit"); $dbh->disconnect; DBD-Sybase-1.14/t/utf8.t0100644000076500007650000001012711642076343015046 0ustar mpepplermpeppler#!perl # # $Id: utf8.t,v 1.5 2011/10/02 15:01:50 mpeppler Exp $ use lib 't'; use _test; use strict; use Test::More; BEGIN { plan skip_all => 'This test requires Perl 5.8+' unless $] >= 5.008; } use DBI; use DBD::Sybase; use Encode (); binmode( $_, 'utf8' ) for map { Test::Builder->new->$_() } qw( output failure_output todo_output ); use vars qw($Pwd $Uid $Srv $Db); ( $Uid, $Pwd, $Srv, $Db ) = _test::get_info(); my $dbh = DBI->connect( "dbi:Sybase:server=$Srv;database=$Db;charset=utf8", $Uid, $Pwd, { PrintError => 1 } ); $dbh->{syb_enable_utf8} = 1; unless ( $dbh->{syb_server_version} ge '15' && $dbh->{syb_enable_utf8}) { plan skip_all => 'This test requires ASE 15 or later, and OpenClient 15.x or later'; } plan tests => 11; $dbh->do("create table #utf8test (uv univarchar(510), ut unitext)"); my $ascii = 'Some text'; #my $utf8 = "पट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट"; my $utf8 = "\x{263A} - smiley1 - \x{263B} - smiley2" x 10; { my $quoted = $dbh->quote($ascii); $dbh->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => $ascii, ut => $ascii, } ], "got expected row back from #utf8test" ); ok( !Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag off' ); ok( !Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag off' ); } { $dbh->do("delete from #utf8test"); my $quoted = $dbh->quote($utf8); $dbh->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => $utf8, ut => $utf8, } ], "got expected row back from #utf8test" ); ok( Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag on' ); ok( Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag on' ); } $dbh->{syb_enable_utf8} = 0; { my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); ok( !Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag off (syb_enable_utf8 was false)' ); ok( !Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag off (syb_enable_utf8 was false)' ); } { my $dbh2 = DBI->connect( "dbi:Sybase:server=$Srv;database=$Db;charset=utf8", $Uid, $Pwd, { PrintError => 1, syb_enable_utf8 => 1 } ); $dbh2->do("create table #utf8test (uv univarchar(250), ut unitext)"); my $quoted = $dbh->quote($utf8); $dbh2->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh2->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => $utf8, ut => $utf8, } ], "got expected row back from #utf8test" ); ok( Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag on (syb_enable_utf8 passed to connect)' ); ok( Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag on (syb_enable_utf8 passed to connect)' ); } DBD-Sybase-1.14/t/exec.t0100644000076500007650000001057210571606237015111 0ustar mpepplermpeppler#!perl # # $Id: exec.t,v 1.9 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; #use Test::More qw(no_plan); use Test::More tests => 22; BEGIN { use_ok('DBI', ':sql_types'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); #DBI->trace(3); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError=>1}); #exit; ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 22) { ok(0); } exit(0); } $SIG{__WARN__} = sub { print @_; }; my $sth = $dbh->prepare("exec sp_helpindex \@objname = ?"); ok(defined($sth), 'Prepare sp_helpindex'); my $rc; $rc = $sth->execute("sysusers"); ok(defined($rc), "exec sysusers"); get_all_results($sth); #$dbh->do("use tempdb"); $dbh->do("set arithabort off"); $dbh->do("if object_id('dbitest') != NULL drop proc dbitest"); $rc = $dbh->do(qq{ create proc dbitest \@one varchar(20), \@two int, \@three numeric(5,2), \@four smalldatetime, \@five float output as select \@one, \@two, \@three, \@four select * from master..sysprocesses return \@two }); ok(defined($rc), "$rc (create proc)\n"); $sth = $dbh->prepare("exec dbitest \@one = ?, \@two = ?, \@three = ?, \@four = ?, \@five = ? output"); #$rc = $sth->execute("one", 2, 3.2, "jan 1 2001", 5.4); ok(defined($sth), "prepare dbitest"); $sth->bind_param(1, "one"); $sth->bind_param(2, 2, SQL_INTEGER); $sth->bind_param(3, 3.2, SQL_DECIMAL); $sth->bind_param(4, "jan 1 2001"); $sth->bind_param(5, 5.4, SQL_FLOAT); $rc = $sth->execute(); ok(defined($rc), "execute dbitest 1"); #DBI->trace(4); get_all_results($sth); $rc = $sth->execute("one", 25, 333.2, "jan 1 2001", 5.4); ok(defined($rc), "exec dbitest 2"); get_all_results($sth); $rc = $sth->execute(undef, 25, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "exec dbitest 3"); my @out = $sth->func('syb_output_params'); ok($out[0] == 5.4, "out param 1"); #print "@out\n"; #do { # local $^W = 0; # while(my $d = $sth->fetch) { # print "@$d\n"; # } #} while($sth->{syb_more_results}); # test various failure modes: $sth->{syb_do_proc_status} = 1; $dbh->{syb_flush_finish} = 0; $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 1"); get_all_results($sth); #DBI->trace(3); $rc = $sth->execute("raise", 1, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 2"); get_all_results($sth); $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); #DBI->trace(0); ok(defined($rc), "execute fail mode 3"); get_all_results($sth); $dbh->{syb_flush_finish} = 1; $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 4"); get_all_results($sth); #DBI->trace(3); $rc = $sth->execute(undef, 1, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 5"); get_all_results($sth); #DBI->trace(0); $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 6"); get_all_results($sth); $dbh->do("drop proc dbitest"); $dbh->do("if object_id('dbitest') != NULL drop proc dbitest"); $rc = $dbh->do(qq{ create proc dbitest \@one varchar(20), \@two int, \@three numeric(5,2), \@four smalldatetime --, \@five float = null output as select \@one, \@two, \@three, \@four }); ok(defined($rc), "$rc (create proc)\n"); $sth = $dbh->prepare("exec dbitest ?, ?, ?, ?"); $sth->bind_param(1, 'String 1', SQL_VARCHAR); $sth->bind_param(2, 1, SQL_INTEGER); $sth->bind_param(3, 3.25, SQL_DECIMAL); $sth->bind_param(4, '2005-06-27', SQL_DATETIME); for (0 .. 1) { $sth->execute('String 1', 1, 3.25, '2005-06-27'); while(my $row = $sth->fetch) { ok($row->[2] == 3.25, "Implicit finish handling"); } } $dbh->{syb_do_proc_status} = 1; $sth = $dbh->prepare("exec dbitest ?, ?, ?, ?"); $sth->bind_param(1, 'String 1', SQL_VARCHAR); $sth->bind_param(2, 1, SQL_INTEGER); $sth->bind_param(3, 3.25, SQL_DECIMAL); $sth->bind_param(4, '2005-06-27', SQL_DATETIME); for (0 .. 1) { $sth->execute('String 1', 1, 3.25, '2005-06-27'); while(my $row = $sth->fetch) { ok($row->[2] == 3.25, "Implicit finish handling"); } } $dbh->do("drop proc dbitest"); sub get_all_results { my $sth = shift; do { while(my $d = $sth->fetch) { #print "@$d\n"; ; } } while($sth->{syb_more_results}); } DBD-Sybase-1.14/t/place.t0100644000076500007650000000372511271404210015234 0ustar mpepplermpeppler#!perl # # $Id: place.t,v 1.10 2008/08/31 08:46:22 mpeppler Exp $ use lib 't'; use _test; use strict; use Test::More tests => 18; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} my ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError => 1}); plan skip_all => "No connection - did you set the user, password and server name correctly in PWD?\n" unless $dbh; #plan tests => 16; SKIP: { skip "?-style placeholders aren't supported with this SQL Server", 10 unless $dbh->{syb_dynamic_supported}; my $rc; $rc = $dbh->do("create table #t(string varchar(20), date datetime, val float, other_val numeric(9,3))"); ok($rc, 'Create table'); my $sth = $dbh->prepare("insert #t values(?, ?, ?, ?)"); ok($sth, 'prepare'); $rc = $sth->execute("test", "Jan 3 1998", 123.4, 222.3334); ok($rc, 'insert 1'); ok $sth->bind_param(1, "other test"); ok $sth->bind_param(2, "Jan 25 1998"); # the order of these two bind_param's is swapped on purpose ok $sth->bind_param(4, 2); ok $sth->bind_param(3, 4445123.4); $rc = $sth->execute(); ok($rc, 'insert 2'); do { local $sth->{PrintError} = 0; $rc = $sth->execute("test", "Feb 30 1998", 123.4, 222.3334); }; ok(!$rc, 'insert 3 (fail)'); $sth = $dbh->prepare("select * from #t where date > ? and val > ?"); ok($sth, 'prepare 2'); $rc = $sth->execute('Jan 1 1998', 120); ok($rc, 'select'); my $rows = $sth->fetchall_arrayref; is(@$rows, 2, 'fetch count'); is_deeply [ [ 'test', 'Jan 3 1998 12:00AM', '123.4', '222.333' ], [ 'other test', 'Jan 25 1998 12:00AM', '4445123.4', '2.000' ] ], $rows; ok $sth->execute('Jan 1 1998', 140); $rows = $sth->fetchall_arrayref; is(@$rows, 1, 'fetch 2'); is_deeply [ [ 'other test', 'Jan 25 1998 12:00AM', '4445123.4', '2.000' ] ], $rows; } $dbh->disconnect; exit(0); DBD-Sybase-1.14/t/multi_sth.t0100644000076500007650000001504210317504611016161 0ustar mpepplermpeppler# -*-Perl-*- # $Id: multi_sth.t,v 1.3 2005/10/01 13:05:13 mpeppler Exp $ # # # Multiple sth on single dbh test. use lib 't'; use _test; use strict; use Test::More tests => 43; #use Test::More qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError=>0, AutoCommit => 1,}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 43) { ok(0); } exit(0); } test1($dbh); test2($dbh); test3($dbh); test4($dbh); test5($dbh); test6($dbh); # Vanilla test - do the "correct" prepare/execute handling. sub test1 { my $dbh = shift; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses"); ok(defined($sth1), 'test1 prepare1'); my $sth2 = $dbh->prepare("select * from sysusers"); ok(defined($sth2), 'test1 prepare2'); $rc = $sth1->execute; ok(defined($rc), 'test1 execute1'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test1 fetch1"); $rc = $sth2->execute; ok(defined($rc), 'test1 execute2'); $rc = 0; while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test1 fetch2"); } # Same thing, with placeholders. sub test2 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok(defined($sth1), 'test2 prepare1'); my $sth2 = $dbh->prepare("select * from sysusers where suid = ?"); ok(defined($sth2), 'test2 prepare2'); $rc = $sth1->execute(1); ok(defined($rc), 'test2 execute1'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test2 fetch1"); $rc = $sth2->execute(1); ok(defined($rc), 'test2 execute2'); $rc = 0; while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test2 fetch2"); } # SKIP } # Same thing, with placeholders. sub test3 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok(defined($sth1), 'test3 prepare1'); my $sth2 = $dbh->prepare("select * from sysusers where suid = ?"); ok(defined($sth2), 'test3 prepare2'); $rc = $sth1->execute(1); ok(defined($rc), 'test3 execute1'); # Interleaved execute() $rc = $sth2->execute(1); ok(defined($rc), 'test3 execute2'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test3 fetch1"); $rc = 0; #DBI->trace(4); while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test3 fetch2"); } #SKIP } # Same thing, first with placeholders, second without sub test4 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok(defined($sth1), 'test4 prepare1'); my $sth2 = $dbh->prepare("select * from sysusers"); ok(defined($sth2), 'test4 prepare2'); $rc = $sth1->execute(1); ok(defined($rc), 'test4 execute1'); # Interleaved execute() $rc = $sth2->execute(); ok(defined($rc), 'test4 execute2'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test4 fetch1"); $rc = 0; #DBI->trace(4); while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test4 fetch2"); } #SKIP } # This time, set the "no_child_con" flag, and execute the statements # sequentially. sub test5 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 8 unless $dbh->{syb_dynamic_supported}; my $rc; $dbh->{syb_no_child_con} = 1; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok(defined($sth1), 'test5 prepare1'); $rc = $sth1->execute(1); ok(defined($rc), 'test5 execute1'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test5 fetch1"); my $sth2 = $dbh->prepare("select * from sysusers"); ok(defined($sth2), 'test5 prepare2'); $rc = $sth2->execute(); ok(defined($rc), 'test5 execute2'); $rc = 0; #DBI->trace(4); while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test5 fetch2"); $rc = $sth1->execute(1); ok(defined($rc), 'test5 execute3'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test5 fetch3"); } #SKIP $dbh->{syb_no_child_con} = 0; } # This time, set the "no_child_con" flag, and execute the statements # sequentially. Same as test5, but no dynamic SQL. sub test6 { my $dbh = shift; my $rc; $dbh->{syb_no_child_con} = 1; my $sth1 = $dbh->prepare("select * from master..sysprocesses"); ok(defined($sth1), 'test6 prepare1'); $rc = $sth1->execute(); ok(defined($rc), 'test6 execute1'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test6 fetch1"); my $sth2 = $dbh->prepare("select * from sysusers"); ok(defined($sth2), 'test6 prepare2'); $rc = $sth2->execute(); ok(defined($rc), 'test6 execute2'); $rc = 0; #DBI->trace(4); while(my $d = $sth2->fetch) { if($sth2->err) { $rc = $sth2->err; } } if($sth2->err) { $rc = $sth2->err; } ok($rc == 0, "test6 fetch2"); $rc = $sth1->execute(); ok(defined($rc), 'test6 execute3'); $rc = 0; while(my $d = $sth1->fetch) { if($sth1->err) { $rc = $sth1->err; } } if($sth1->err) { $rc = $sth1->err; } ok($rc == 0, "test6 fetch3"); $dbh->{syb_no_child_con} = 0; } DBD-Sybase-1.14/t/nsql.t0100644000076500007650000000253310571606237015140 0ustar mpepplermpeppler#!perl # # $Id: nsql.t,v 1.5 2005/10/01 13:05:13 mpeppler Exp $ use lib 't'; use _test; use strict; use Test::More tests => 7; #qw(no_plan); use vars qw($Pwd $Uid $Srv $Db); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {syb_deadlock_retry=>10, syb_deadlock_verbose=>1}); #exit; ok($dbh, 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 7) { ok(0); } exit(0); } my @d = $dbh->func("select * from sysusers", 'ARRAY', 'nsql'); ok(@d >= 1, 'array'); foreach (@d) { local $^W = 0; print "@$_\n"; } #print "ok 3\n"; @d = $dbh->func("select * from sysusers", 'ARRAY', \&cb, 'nsql'); ok(@d == 1, 'array 2'); foreach (@d) { print "$_\n"; } SKIP: { skip 'requires DBI 1.34', 2 unless $DBI::VERSION >= 1.34; @d = $dbh->syb_nsql("select * from sysusers", 'ARRAY'); ok(@d >= 1, 'syb_nsql 1'); foreach (@d) { local $^W = 0; print "@$_\n"; } # print "ok 5\n"; @d = $dbh->syb_nsql("select * from sysusers", 'ARRAY', \&cb); ok(@d == 1, 'syb_nsql 2'); foreach (@d) { print "$_\n"; } # print "ok 6\n"; } sub cb { my @data = @_; local $^W = 0; print "@data\n"; 1; } DBD-Sybase-1.14/t/screen.jpg0100644000076500007650000027504407506704567016001 0ustar mpepplermpepplerJFIFC  *3$&*<5?>;5:9CK`QCGZH9:SqTZcfklk@Pv~th}`ikgC11gE:Eggggggggggggggggggggggggggggggggggggggggggggggggggj" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?=};[DŚ $$G5b{&؁=D 1QFr#=ȈbaKy'UHnjĒ |ǿ@c'ݓ++Y4H-ӏRn¶E͜S83)'p9ǽE"1WfObzjRf(-~U/N@TάH#HoOR՘@(0{A9'Sxv#/@qd ?K%̍Z###'מp:8F#Oݣ28l6=E5Л'P_'N@S/k+Zlwn3nP3Г*|15`HFs=G?vC3@qd ?. wgM?(ɿ_7KK gDo7?÷q*=icbY2d*p ڋvGM?+0\~%ky둑=VKhW~sy OchF ?GN@8 aq YI a ut[[v`۟ ,>wgM?(?M8H.*${nqVS<ҳ:"A#S=84X=?'Pf(?8 [?+KkM 3ruV2_GlCtX9bN@Q/@qy-]zєēaǷN1T7i(geIq={w(a:?(?8 d7-c2gh:ߝ^$?ڰ@oEq,]{hFd ?:4RY٤%[hRy9sPi05mIUo* ,cb}d ?:4W4k5[m{`ĒsӧjkhrKI#G~X9a:4GN@TV-Yf1m'~Ks[B\Jqz6C篵wح3@qd ?+B Mvy|D! cufhJ9RG{ ,N@Q3@qm}>[US wݕI{ӃSG-F*OB1‹;V?8 ?uh?–O5e|!g(򴶹Yް7-G_QX9a?uh?C𬏶=OףS}>?8 ?uh?²>'?^=OעCz?8 l_z>'?^5uh?C𬏶=OףS}{o#_'Pf(?8 l_z>'?^5uh?C𬏶=OףS}{o#_'Pf(?8 l_z>'?^6?uQ/@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q/?±'?^=OעCz'Pf+#S}l_z,?8 ?uh?²>'?^=OעC?XmzGd`FM?(ɿ_cOmzEyW *~q?}Omld/?C~q?}Omld &~q?}Omld ?'N@VGd?X=3@q:XmzGd`FN@8 ?uV?d?X=/@q:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:YmzGd`FV@TWy(BQYmzL'=ע|"m'TvQȧkOZIN6ǁ~TҩZ{xa:$x0A4-ʼ8.0 ‘wW"4RRLr:6*QibsNbYtmJGwfAʥֲtMAnd6d.Geˋ="ԅLEx c'ݓ*]\V[t@TLhʼn>URG;̤#8 s4]̊;mS=9ǪW_h-͓“. @3ۨ/_Rou)(naXk۵>Owmmoim{kxwHrbP=@Y U0Y?7#bVFytak=D$ + ]AzPQ51u W?,6FG9aIP+vi[tF(ԬX/#]DۜjiJ;*t D_*IRKfqz% 4w~Kwb9v?Z%TahO/O3q9AQ m~C~j9n/-zFğ5؝CO/IO/G3?gmKUyF]Hgk\϶?gs{FO3|:yߕs38ϝoմM 唟_*)Uϰ{8|W$7QjkmKP/yP3q{v 꿱W=psu-hcYK⩟ٺ>9yj7B8cTTX#=yQDW&ݿ+|1ֺhX[KЕsJU.g|rjM:ɨTa\Ϲ # Ds!xk6:?/KSt7V>DhTs>r} {v]KUVWQgr{g\9 O{?nr >XjEV1~)P_=F3VNO/At@?s>(fy+jzC ׮;Pt y2zPLro:_*3?g70$mΥ_ }H&cC/W34>U(Ѵ3,ts>r1^0CFnU1q {P_+;06g95aO/AдDUL焿_*g=NG}ߦ7ϝo񮭴˼/@Ӵc.DUϰ{8M4o;]wVU9t bQ;FM5 B?/圿_*g=N+}ߦ7ϝo81K)Uϰ{8fM4o;]6?唿_*N:E/gu>wƍ_w~k?猿_*gYI}7ϝo}ߦDsg'gu>wƍ_w~k?真_.4M9`q8_w~hu>wƻ_=_*tMyr9`q8_w~hu>wƻ#O/IAm}ϝo}ߦΑe/?生_*g=NG}ߦ7ϝoi:!R_}y}ϝo}ߦ?4O'fhO/G3'%|7[?U(ҴS,dTs>r;7Ѿ|v/KSNe'gu>wƍ_w~kf唿_*4y}7ϝo}ߦJYU3;C?Uϰ{8M4o;]gfT.gTs>r{7Ѿ|v?:TҴ1,Ts>r7Ѿ|uLKRdhq_*g=NC}ߦ7ϝo0rO)Ogu>wƍ_w~k?真_*my}˯M4y_w~k6圃RC)'g.7\ϝoRcRch_/G3'\ϝo̹;]ѴC,THQ?w~h.7_UZQy?w~h.7b4)U_*g=N;}ߦ7ϝo񮽴!yOxKTs>r7бN8' ' 3C?_dgXKs>+hzzhv2,-7gpAg?vwPQu9SIXTxK⨻V[a̧'*AęjqgXKNϕ.}<.kuvQH{k q;tߥZT447)o>_*+I$̳@H;d@HzECqJ̼Fe6 `$Ot3.DUAykFb7Rri^c?.=ݏEE-h9g֊2w Tq)eE®:Gufc={SbNAi!PcnRu_Cv"IQI$M,A0ˌdI/.~/6\vqv}*ZbVap&G, yDl{WfMq'p4RG7-H)b%b rr3GKi.wE0d~w羙'xD\yyrH }lbU*Lbi~9׎ӂGoݿ^v⣒"IʹR2ry::q.#dEQ hnHDգgrϷ :hG*Di9|0zu熛+X(w|Ir 'Z80ݐqБОJ0$$~?Tv:ľG#>`ˍw~j/*8Ko988sϭ2-| #O@a(o_ΫNWNd}9um<MH9pTPh`ɸS,`g҉UhԺ-0S!=Բ4nI `8" 2<I gןNl2#u<06Bgt'?(qϮHl{GJM#iW12 =-PpK)'lZEkOԩÞPa]H\{I$pF261шh oNY{oUa(}pHP\۵h2& 8>mm–V2AW@/n mۼ1׏֤7F;X1=tqD`۸ݝvzgvsӏz6t8L ew(\~CӧlS:F:c{vPci >w0s@ { UYʑx X0$v?t pO )fP_t~Sҭ\+q#ۥW5F^[v2Y79'F'M$۳ `v?Bzo?49Hy^4aڀ'AULQ= $aji|DžYNOUD?/hАvMU|wch;N{P5\΍~oa@$#Ga@(l2;(UmnXҴw<5bqr{ΪnN('o7v&П@h?J~i:c@7sN jOR)Ā8 c@vޫǭ pUix4)jdRWv4it3_iaUo ';Z}fy<Pi?}G6:ҠM0f:d^@,q _4oZ)R f CZ4j[zG)sKWbģ%Oo &?Bԁ?2.}wmntqSqrC?RTТ$e}U?M4Ԥݮ&aaC _Uk_NzH{&IqXE?1V_g̻WB7Nm,&FMB|ޞʫjڄcyi{90s.8M: mߐ\*ԲB%~E9( iw*R _HtX{6#4?G4Ȩ4XJ @-z f !ƀ#]ʻA/{|U0h0gWK\11!w?G>ƚn=b`.iwU`У?B2~G5:EOӾs~O.]?R59U/`y_]iyq=N4sKrb'oaǿƃȋO>h:ds'R5? Blyt4j3i}ht8{Rbп\(ƣ7睇Ǝiw`afo*S|A.2,]h]Fa<4sOZ#QqWDpo*Ϯ4l1O.ʻ :$=wso񦶋go*TǮ4:isKfzqU ]{/ץ'hp!>TP@G_Hoؐp8gG4#֫ПͿtZ (um3ri?h)?yc8]XY RG R]p_+nC ?x/+d3='ȯf]QNcu@9kyf3m ңbGrPe #A[DŌ2tU*X^4ә8NX)IO~qҭ@lij<I^`lLfrGͷn~e  c ,"i~g^:sQ^֒Q- cӟjĪAsCsאsSL{k{ voNz/!/^FB̓ց13`ƪXjZ $j)fନ?2q 1[n{P2UKԻ 3-61H&rZ O;?BEt\H:eGfh!JsҬ=]8]\r.s?1=3~bbF1zT"VV 0_ƀIMRJM$0p"EQYKpzpZ HTn$7==;T?z 9A_ncOޔm K'+0H [:'BҼ＀8mv?I9N?px q-+fʓ?,-|'^*Ap(9Aa~P'?xԂ3oP8=N(F;/4qϵ?q@e>i<3R wa81N=hM'y_ɤ"9>\Afoe'i>7#2zBFp*_̼ҋI;>Ƙ<ӂ*s a\ǠS@X 7jBɧe &!o|bޙ~ZnʟI)al$L-2&m.?|b ._֦&2&m?Odi:y~?4g1 䞂kis ik8'h 8h cާ6ӟa/←O<% #x498u/j3kq a,xQTks>-AQ $. jhi0hx?*=?~_mnX%  IS;j?)a|r"y3SK.cs|b+IV͝4\= ;@S}c_ӾpOITh?x[`c{?_kZdҭa֓`@OpE-x@OpE-stp Ud(A?֪2@KH{IFT(V:jܺɼ/H4 ݁e׫ZٌxOQHj):/!$0g-mf1$Z-lYw?Z^9.Th_zqѧ~?^g_!E̗n ?^4k9k{A-o?7ɴ%{ffϞ/riW d[؟iw}ȟ;U'1p?^t;x?^?~R-Oe?;:-'ִCgf?60I?֬{AwFc]cJFӊؙE<ߝV j?-2+7AQҶmG{Ef t/'EP߳~R=gGR}~~q|My.5t{m))n3 clIj-GOW%Nc)x؃!&Z;_Ɠ˰?}ƎJe#p9Q'&aa$i<I}SsC. @xFtp3ssKYr_ƓeƎJeO}]Z!3;(w#zUF?|o£~w/fOZq4i+.i{$7m'j3s98I}6Xi}Ee?4Aq:.Zg i-tN;1,yCO4k5i{ N%q"gVf?5Om/Ɨѣ9xʧhv'Ա4yk5L-'hňDAsϘW'%5O6#FO$MĤ+FnfѪٴz'hE=,4`ֹٍW jN͢Fc!{DLSmڒSҤ9W"uOػYh2h<N<gbn Ąd'ȼU9ī2yT|w1׾2JiʔkcAUM! #I>bx=p(kCڥ1FA9Fp9ْ6\݌qӒsQ@Kw0?y{hkT3RW*A99괰ڷ %/;H}z=i@A <}AM/jN̿*O2/@Dڝ~|ex \q@/pTaj%N1"\Fe_e#cj)%lMUR 0qǽOSU6),c_΀.yɦM<X\CU>3 嗧c@S\OL-| НhRWm'vN?fxV"ڢ*Bkڻvx'?(?S@ dݏ Hbh$O$v8z.39Zv5ya<i nIj} X'Qjܗ/s@!?J8Yc*p?KHozo#EchcvinU4Xi 4M9w)RUsp34m @T.=zSdK]N(#u >Wr#h/`:vE !?9+pe!$u>֖<#Gv>X睪EI>$Kr*)Y<b|`Fw '݋d}PdsS瓁d^ eVR۲A%,rG$W|#O V@Co`lzS,7 Ǜ>[vz]u0e7r9 @>7f_ǑS01ه뗌t ҉J'5掸@$rOPk^7AG)A+QV<oP H2nN8-/BFB# ֘qFOȨ99<*<@ZoN@=sϯJVv3 Q(qqTFfEhMˏ wl "Ȫ#(gր,Ts*i{' 1#z8qsf˸ .ձq5w6QƱ,mȨ?QME# ەB )J:+ȔP5X/M֩j[ԟocĘ&K{Yw 5!` 'gҚ&# AOm $J]{o ) Kzoc I3 avZڍA7Rh4L fJ/ Q@!(=|;+/4*^2 ߍ5 }ҵ{q>SdG~-W ZFg=9Vo Q/YAEr9*ZΚu;?,3A'd34KMghhIm8 ;҃-Pѵ=%֝5_'Ỵ2HΎĥ܎'RT`8oڝ-ೂWqӷ ݼ>`9#j$s2;nnp?EJVcџ cqwT)TOPi|z%?i G^j+Fάt#@ Z.Dݠ~?.=1<1OaD q4併' ܼt'9?^Oh 7/hx*1>b;1un088Uݬ. )~X෹] %UB;Oz`TAy6\L IbpOQX0 Byʤck/=lӆIJ:Ue(1~E4O*INdqdc~$7w t̎ şu]=c#iOe\p1ZҒS3*I }l'SV}FA]&M ' Y16n9fhQOKjh;H {\SsV5ե8#[x[kGP9?Θ GO09qET ZGZ]fì: li0Cq% rW7ozƛw/e<*|h|,ҭաUWa:6† sӱ[y4čٴ/:5MX_Go Gi$sDҒdFۏ0*5;-2$4{LqNMgg++XiŬrL(zǵDhZp&#0Ocjv]Vрh^5-TK5K%Q2 c=1޵Ԓ>cv;Rgv7c\sNi#dc vJ%R}`-J˂ܽH;$|[EpG h]t8 sF6T{$#H􇺒Y'@\W;G|vz׫FFb&O%[VV ݏ=구%ͺL)IJ}8u5Ŧ<j 9P{8zsPY7+-\[G [&525âƱç(K)ޠd>ҤHŤDy5wP,| SCH`*ֵӦSk Mv8<'Nv/] OHt<O[TmoCRV@OGN@?W6އ KK OGeZ߅ F?+*fXp +O=tC?­oCQEt0?I:*?:(gwkzʍ*.6)4Y:\އkzʋ*:6V ܯ̰ OVއ m:%`e8#ьþyԶZd$V\X[ܧOd7V#RG(b9̶gaomLKEfXύ_2|-?[އkzʋ*e\-?V<3F.R(T ?ȭM*}k%q4r9=r@Z(5&h Ihhʌ>8߶n2Wh @K%r2FG92ҬoCQvO ei~*?]S+O iPJemxtT AR1z7f5F ?GrbubnB?Er602?suoSѹOUQٝVe$AO3-FI#z~&lqۛtnoSOK4jX_ {tnoSOK4jX_ e;wx͔ e8Zwڔc%I`rHږij5ҖvbV-gnVm;Rxj{8.%&S$ Or 6A-G"uB0GZ5K;v.Eh",aiRr2*]O{i;3b21d 'nzmJub5,9\s[^M=Q,3]B͹ُqս\}:yi/$C)eEwH)pys-;v}^(oE3ۆô(<>x?Tm$`B0xs9TD1:6b$,21mխª:4ـ1}zQfm32C#\c%2dGj*3c~V>\Fc@s <槺MJ,$rD# =cK0.jAi,'I}ל.5\=ES#լ1vK1,KxuZg]Rt(ŕJ L.G\4j&97NA8֟%E:#Hy8v0{gֱ 1'S3F%d }tK A]̭nR7xΨ ,ʫbzVd;p9`rA qYb+<ۆm vO2wr~LӞKhwXeg} [Mo Si!0f 8,CqMY(<̒1 3`0pqjK*?m?cTϘ6֍Wڂ,Sլ"Hd mۙC F3OR'6wG/QjxPOkom=1$T=d߾yq##nf8ez}46(HPE&wҋ04hcueVH##֬[-ۃe>GcϨUlK`A ?QU/,!m |yʫf?uSR?ږiiYosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yi[g1F|r;]wsHwo#¤n#Bj寅ЛA\mjCĐd:VΛƉkϊHtZ)YZY$$G\ rJ-o>lP>U?k mPY^ yƅTvVl(sgr@0Aq 20F8NK#-e$y#73"}jI)qyQdJyIN~= Ҙ]C*c cO<8xt2H3yJVo-Lq`k8V7gmlrvp:8c9mR} cQ̎j,g=ԩjpNB"`rSps،\ Ao,/ +V?9~#9Z,h[hʀNIZײ޶ڴHQ( Yϻ>8j} cr1)?fn@$iѣD.g[ @9;G##!wUuF&؛rSw ۶㧯fyBy!@$ÉFѰ s[1''y?1@-a?t} c̀Z)>y?1 AR} cG2h A7.dIGo??]7. 9 E'o??]a?ts O >y?1@-a?t} c̀Z)>y?1 AR} cG2h A7.dM.Yf-;K*U _a?tȴ˘PwP*f#ybÌO >y?1@-a?t} c̀k%Ē_HlGg )Ϸg钽Ɨi4I!FcdԱ1P93rpt˛x#+8*1ZQ̀yI̐#E#)$}juk6#+#F@ a@BNHZ]:< "d|APtG/y([f ALus #T=#-0ݟ-mʸ︫zeo#%m~ܜ== c̀Z)>y?1 AR} cG2h A7.dd73diIIeŴmPG:9SFfGo䲲9Xy;~|Ctom_paHy,]x`Jn[fkM&wMuq$I(T]W63n[='5z\/'o$AKfFڼV֮QijЍˀ&&?,Ą=r:\B84qb-ƪj+<&ss"cl.6qԧYKy Ēpl*mdqlC gd@3a?\WNE@P(@#QH#0Y}iM?Q%H ̂6ܹ>[?Kg\p9j6[2.IVd`[Dos+lxɜmx㚎̉2`7a\I˚OXe,y܍7qۚ\UqݘF]m@  =pFMm;KE0P෕28ǨL<HV /Xp#>}g=-!3"V}@F <`N3T.;_CQKΏtzh]Xd"92YZ09RFPϯ= itQKGP'['DgqV#6fy7ylJesy֞GE{EJ)r?(J)r?(#J)r?(#J)r?(#J)r?(#J)r?(#J)r?(#J)r?( ycbx{C9NOFrI1g]Ӷy.#XxWj?NQy 22z=i̒Tt8 [Σq%$e;>{#?xꝲ*{dc儅%ԅ2qqkW#",p8ϟڬXmԂY?Ёɩ&s@zib9<{YI pqU9-Wأl,J4d?`x'sV4$BK_8 7ePOQ)ȲF`<(V`T @ e_Ǿ;J&|G|˻=yȫ_k} ナ{ȱfÙ#hsp{ ĐYaQD @' 5; W;wu3b+NǍޓB] %sȭ;΍ls<ZGZ[jK ohMt=V<;\D rݏtUSFfpvIvG#?F9GƋFGooYoI奫 0f6yerF*[ʞiZQʷ0mu÷Lxp3l ZܷRLя0,@w q$\Erx&[ SA?ݮ.cY"I#i#dvDq'Bu 1\p0gTEePcD``X7 L5D̫p5@F9{Jx;yK[{*iL+3; (0DZ>b@L nT8Îq.[o.4fa߼:a+vf/fH+oxeI߸ku /<+`Nr( &q!~c9_^92yR5;,!I#wk=b9/v&I$^aAN㟓OsMQvV7yG}AX 4R>ߕHq}*J)woʍq}*ynCZv̉ fp՘"cU@UU GA$  ьRp6 n24}Vd?1$ בխq Ei+o fi`ǪQs4%ʴ 6c q3# r 肨 [h8Ojޠm"-Eg A'qL0If`'21WfY eB|`ߪ~+VDHLdP8'-gq0]qbH:=1CzјQXPeGn1b MIlX{·uD9meeb!N5Z\G5FNdw+p}pkЧ$F_o? f:+F%\'8=?QS]=.8Vpgk9i7hc-ĥՖ?U/Oj3_/s҅mYE6 ͐wnj4sQ l"Dw U]"q h?.@c &#y269t4T2=4R9B`q^yIʜd5mLF 0;FrAN?cGr*vgnO$g=;fYNMʌێ8?Yg3&$W8)_f7g zsG;FW9@iCo[ӿZۼ f2I1FSH&\*b:(2z9椺"hX̫e$\mi(ܱEEKJ! ˱ n3vqPZj\[HѼ譴s<qj,j\COdbLm-3DZŤyCaxH :EEf]_6̰V]TFHs󜎣iϵɵ )^oRer1 q`&6lIFI`2|[KOuYA#X Vءa36*1fpTc, {Gil9d`ӞzwMEV:@f\d`ˌdT q,D"7cg+:0{,* (]WDH9J7CB궯7 *7W'F=zhhX  +er4.{~c wH5 R4$̤y aT$Sv%ҋwy00qO=wW:]mbFb7 Os| SZ8[1MUI8?I[ǫaG NΪ2F`)!s[@$S7Ρ0V* 8 8:u(w:UbĪV!nyNfnPn) ;}ERoSѹOH q 5(@I^M wԶDC)ɑ 桏R (ۗvr#sێxҍQ$mbm܅^cFɅ!6Owp}3%4v2=*uX^ $xS䁷vLnQ O-;Fz:BA o`@㌏ګ; knۜOim-zN JciIR]v0p@>Ŀ+=?ΰ;]wKY32fWqڱبh*1<lZ۱EcQt 'W[=W-hx@7pE:tPL\*n_÷ Vʹ|h|,,/9iI2# ?ҙmdY=8Nl/"+ }q d*֢{nA::d6"mB+K`Ͼ?FC&mǓzsJ4ʉ^YyiY *{1V-٩Bd*AFSg'|85>y-4- ,F㢹>>P]A,`f5* spFJ)zmqA;; FN m]\ km-M.XQfi6_f;-&;>9TonqG1H٘pUzpNoCQIE kzʍ*J(vއ򤢀kzʍ*J(!9829@C9Θ׎ek; {lbXmp? {CklFF wn-,-vlY68ickzʍ*J)[UGSk,fF˕3CmltxcrUhcOl~UڭXi{ E;}|\Y;e=BL78szY'Qde[/m6̬0p#|U;ƨAդ=NrN'Kwqpd /j]E%q%#`lI<{@$F1y3ų׾qPhӛU 1| 1 <-$$Q6,JQ"G:9#=(ҵwLJ^_J]՚<$ ߕx}q{P[F}\(K6S$;drṹȬpR)_oC:ΥF ;GEԥi pY>\$ H^F2jizۉ.̏t*d @?3sz Ѕ 31rІ^BI88E9GA$]_jQ{iU}'Gpj4, #%vw p>Fzq#O:7 Qm7# >e 3Oьn' ;Sm #ghUʡx`xgWo%[pVFX|;{g -m lT7|ӎ榇MxnbfR͹J>x>ԷWRu ^Tw>]zOvR> RICn /h i2]Nx(mac't܃# N3ScB}ww #*6pw=2FGF1dn3^ӥy"ugT:ߔAGpjop!jqHaPTsp$MoeT]( 6pݲx4N[{o qFaq@>J-e͜41HFe3`Np [)VMw vSV3Knd/_ P YF@+sq co'Tx1Ig;PF}\(K6S$;d^JU-J&3"?ŒA~8Q<L]^z̙8 GBqzqš{v/Rq01&af;r=298XI/)FFP][ ۀx'Z-ΐ>=>U\j[&`iu 8뎆kK5 GVܹ%A=Po΍󤢤 q鮗LaWnsn[8#n0;s3[ڽ4I2#9b:gPn!%& q#LX%kBӸye]v*eYe1G) tuM=FYԀH۷#*/,^&uivy@ shKWkzHyK l {Md:o6J9!g=ǥYIA@bTc_tApy#Q5iP78 <  n'M$q"䏻q@-->i.9nׯz$ VͫnCK&Oޙ61Xu^CmUr*ݙƗU^ȩL~O (ns>,\#kE'Z[ip_+y'_`:}`_+{G*E𳝶Nٸ%i[:! Ueer6I)0vڿ n X/mn$d?³EGݚS!IesFOݯ9ɷLإ#m^s{+kWq(XYhF @BH dA{ ٷ,.9 ðqqhm7YKˇP%` 20@^0KB V{xyg.nbC;DWp̓0sڔ7o![y vV-9Ì\>Si Jb#9b9$g2*:l-ܭ*nT <xuhٍ@gf{H=5Ԟ! Xc_3$$/n'5m2J+0ځ@  z5vM=eX^VH$udǣąAH$hن`xqN:u,z[KBg E.xn fì]IvxE<#rcnH97 ]=m"⹗hڨ "/D86-ْY yIyac?SQzơ= hheg+7E/&s{"&CG\Xh)N̑ #ntFsb*daO'7uϿ ?fAKsrIB$FgǧZ$ioN3?{nbmm` v=qz~m'r>a } X䳋1IbE< 8 I]Sq{hYwgum(ެU3r>t"cjȱFurێxګ n9CƘU7lQzJs#\.zt'>F/j`8p$IO{ub7d:/ dy|ѵɢla̎"b71|:ueLjFIh833fvoD3b; ُ<=}jKXUHKT4n-\©r kfKB!@Bm\szus ˽pe\ $)dA&HYVCTr86KgN23Kp` u#wZMA6E+Jdse9Vc" F3qIg,yoa~P0Fޟ?ҧ{Et2̠R$ś8c8#)i60q+g`c==j $x 07 lpq>i,HJ˹_݆$dgW#WR[yO'^W::DK9U7.p }MSYHc Zc|qwk2@Br2d|zʁcj"%jHA!xG<`(1TcPHw#er?,\l92ͱNѐI;СuUE},muV `1/~ls=jA Bv:'HѬJar@lO~iL!̿ƻnri{W/(6zM%+$,U`.A#=MRQ26 0ws G`28[oyۊ|.ckp:p6ylkkWwX<vb2I$?*IJ4OΘ~޸[f&Tf/ qqi\Q7bT|򤢠Ѕ,mUm$ Ĩ' ryAq%U. Cƌ,zMaGwمm[l[tce!d-{±苼n2y$#M\B\a23]o!x@7pEx@:?pE̻\\]SV o` VUUSFf[fkM&wMuq$I(T]W63n[=n)"._65{(֧7vHyh-5<}:\B84qb-ē<7v{wgq,pF\GV%Ѱw.Iqco gd@3a?\WNE@P(@#QH#0Y}kiV(oS=hٌh!]y (^1IK@D2(pT`İ;X`0:#klZbm&qS~cn9j;k kW2$@K1݆rs'ϰ7jWrI3Fο0v6ƝYZp[n\c&~ڞRY䌤+Y,A ٟmՅ#=Ʈ,*r#09dI$e[g 7|P6t#6XAv88{ jYYkqWq\3dyq3 I\7nC<5{0vG!\U\#*N>@klmPy\sDVа1[h*`` tUYz )Ia`C$ʀr;6`{y/ suhWwLؠe-eRcS0FL1RC%I$&7u>T ǽd20[u %[!v98ҭ xeU2`O?@4?a-ľO%M+Ǜ|!s@+6h%`I `T!!@\(}G:lPxZwJ\@B,(1R7#O3# l Cvϸvu}MI#r0UEe7{0J,&rq`s)se܈q{J3Oy98i$!Aff`&ιȯ㰖h[ J`v&  H(rROrr 0 >_CαΧw5فa[i2@o.xk~_CΒW~_CΒ.7n~ RB9*yg?cxMt%E#b;wݸsTg$2X5Q'qP-zb-̮^uu,`%JB@g\FO$H,FHcuf<)a,]aRNlӚ֦rhhdtTmP z{tN *S"?SwKv b 1GZYXFGEf$;w9d &er<Wry2?+&KK>Y2~l0ORsϦMqfȍ[K*?6xn NOwŞ7`Nu4uIINP=3SYExcx<{cKrݬN+3(pzp,JEQԖUI{g=}M2 i~3oLJ_8(op}|S]h"U ȥ #oC%X@(h}z~/4Dx@2?}(i_qɫضLproa$GtU)`y4RH,_lMg#I&gJe sӠ$`%4?(謹8(/۟ޮG=:zTgNȷWqTb#29{O^wkػFGEEA۝T9N*JEdtRQJ.GEQp#J( kI\`2qdrG;l;pIX$g銷j[WmS=I$2zG *X7OSՔ2 Zw48WUV}WǡVAo( yw: w╗qIOyy{w瞘0y&FzU޳q ;v&Ԝaq$!VV3 ]9u#Ox?)E2n9sjZIӍb+ /Lm!1+|T*v-oi+ZZ?(褢&s@zib9<{YI pqUA,jP0AӱmբS#:'?[IlgI9.|ݖ=A=G"U Ȫ,u4lRsn}<~Z#Gi 8*(#nz.1 BHA9# ;Ϗ8=1\"6XA ;DY>][8ϯ?N:itD OpAkNe\qkB6ģk=?ιn|LwmXi7^+k$}麩鐅9欹y?VjK =sUVI iZGH4sL#kEtü oh` V`\?}zAyijG"s8=晬=qVYvlPq OLevvG4M)&Da]cSS-K#G:t|QYXoʫ-圊+=OA ,GN+r;ڱF2۩%o9rҪVvr5 5a-eY\!Qrzr9[dnp<+2=YZ@&ImWr=EvbvD [sO$UT|Ql(`69%$6i}P$O^:i[OpD2oCdc+߆ =EןT4³3P {.> N F@*1=s89h- av nHa~FEỘ6'#qQoq z#J,A^xVy.CP/ -LtCprsVLQQ;%FKTgX9o]DaRfǘdbNX-؊9RG&(;XuTP^Yb8'E P0:gzz>6]8]*!x$ZƕaAC jc(F^7pG#I;zQ`7WPicn`2J@^LԵR&RJF˯Zm6eUGpXR>Pϖ987ȷdaF.#uq;;s<ky *.+ң``iFʜv=ZU$KvtIa&y'#<^;m`Irڿ)nY+ɨz4&G993kq^%By2Yp6_*R- cYQV|F@98o%G'lWqUlp+݌`א,6*Xg?//=E5 UIZMG.F{Gg\kU Q6 ]{[?,G ġ `~ {qpIRQ C"I<8㹏O+IR Ee&Ӏ9T*7eE[X0%'/bzYuݬB"lpAϵXL{yݳnFwcv>LZ=2JD %$Ax-ȝQRd[(B~z]BբU+lî` } !5yʒ0yYO]=&؃͜cTrfQ䫌p6t6Iqd=1~Tn>ߕmoCR Wg8 '@XGPvdXw?Z xhPqFA?l8xxH T :c^9Ѭ-_ɉcݷ8)FQF?-@Ervߙ<$OSThZ9̊Uz`?thmoCVA$eYY^=+-8(m>1`p-ȂKYry eA=x8~U,-j󺓀2Hf <`c$oCP~Tn>ߕmoCRqӧQڍ*Bu'{ nsp=Hty1R*X6?0X3dkkSI}$r::Bk 㾴kiu p7vWq<I_"st$~5g[* K#tHm؞ 04tGSLvi c+8@p3ǁ5GVS(hԆ]'5zݮ-&Y fPdc%Ojo%-.jf}QhtT9*I+>Es1xVfQPK )~bmO㙣.¾g'gˡK{GͱOF?OF:AOT5v.$86g GQWoΨO {wUhR䐬 <D ] 'j21ߊ7͹qɜ:rpsgߴI!V\c?) 38G|yqLusU3o-h٭fL s‘9=(άO5m9?\gާާ,-^ wd1 Mm2{TOKP :77}:6o΍@77ާi}:5ާsz΍isz΍:6o΍P :77}:6o΍@77ާi}:5ާsz΍isz΍:6o΍P :77}:6o΍@77 J4G{Fl;TOP[h7̎?\QnoSѹOFѴ~tjOF?OFѨ#Ԯy!ʫ"H7dqym}l qӨ#F,nLkݩL#T᳴tZZVEyf}Tm\/'({5ǘۧQJ58(aqo8=7m`; Hůb?w]N֫II`reJ N?s@ ]K%IZSpNIOfiX%Q@9pZ3pd[]18ϣ~>M%yQ 9́1<mIت=sǡ?VL@a3m@lCqS[jq]_gzHamtcY'?cT߽l^?jN6co[:cvvs׏ހ.noSѹOFѴ~tzpLjdGߖܻs7owmhB#kvc].2&6ݜpG`vf{x i"ei2Gfru8Laf{ax~tB#;/L+ < py➚:B߸eO#dS3D6s-<)8N i4wܞGΤFݹq@զ3EO>^\#nޞRWGHHU| sGlUeQq422+cneKdr9ǧ2 Yf}`@\r9)U_<9aԁ\H܌ֺ[[ڤXm=!M8bC5Mi71>m2Ўῥfͣy.:֥ƕj??ҔE-NOş/?QoZ+5@̾@$b{q/O0_+{H]^zFg?^DV9yB P1᱑n>YZY$$G\ rJ-o>l@R^hʴ1)D~tV8_xܪ ȱK"@U$Ά Œ V)o`xR0(kA eErه#?<`t ?&`qXZ5A5qp4*?zq2F ^H%r)G]#p*TU\E@k[ƪ[r63×jWOHVDh&(cM0Ϸziq[۔1]9Kq{żKhRFSή-?=ݻuɻc]f}9ibA'TFdl}Y:дusrrpyV$sԌܛjQTRh3}tt2gjs.uV}L֨. TY.x`54cr1:Jr^q^ jo'Tx1Ig;S?|3L!>cV;;:9йYQuLme[M8C''wOLsZj/,o7HR0s1P?bc){|ӌmoЛh* 9lt$g878#&.>)?]]n\xq&IVt\)~hKVC J[^Bl@0Rv @=.x5x wH_t鎧f1ꚲXD,hyp !;pqɏV&\$Xf?O #nsQ"dI "'g8n1IL庚F1Pq}Hc) PJvJ$`ryz H0Ne'RYhmlOj=C.?,$l尥;94}Ri,X Hܠ1ӚGf3 [*xvqJHeEtsJYq 9.FJX7v9}xއ"$D:R R9ّpyC0h&`pF4\[-3ܹ'yfie{dӖIP$ezg=s$2u[bBnK~և>I!$ss=ijvb>c;N;:\|$=Ei.c2PDc 9bGۭXX䕒Eے#nGM!B #aш=8!13A(A˂WMH%̤u/jȑq+l7bg|qښ/TLd۴s{z Ek͜ATsr0:ˬQHmw WRL)d^r^2G^GZ//.ŅkX^0w.$ޠSjv TI zTq΍+q4oPpJ|V^H $r$/E$dSwT-0K§$1l BciH`qw9>[\TykM(9\ #ڗtӢO?—@pC)se*O Q΃Yj -F" &i~O'qRi+a>#yScrF9:$Uxd*w `r1zzR-E9̓?dFZ{Dp  1 `w<:gg[hesXr{%fI^]q㑑FzEFZl s,?(HQr2i59`[˔+:AV-KxHA9bnf>OaϠ >^{-i1(9Ni[M,ܨ;C`vx8=j5* 4Vb3g'#?I*Jvu9=srƕp6 ,epGb-䋳 '׵i}(U!!K3$ޤE|RވnAdI$f 16El\eͰf?*0w~|Չn@h=SW=O/8`mR 7`M ѽ-"Au)rm475<ĐGr{Su&HQw\DΉnb?pp[ge q efIZcȅrxѠ"4w/#$yTjz[7w:(Iv=MYD5 PIl.$Ēi/R? _t| Fmj*!ђсʐz18K%Αgdg Q=—햿ޓ?Z_`ir10^痐~7ZI|&Ŏ?;K?iQ.s'g|4kZ7^#'fHn-?_Cd|r0FQP.mM(X.dN:i$~v קf`I鶗+22'}OZٿi?sÙi9>i  :i#w;צe_wG+de=d}~_j^?;פ_^+22͹< ֥72B?Vp֐^+22 ?ߗR y?t^i8^+22 9i?:K'֭A-?/;ץ̌Y?4y?j:ÙlY?ƚo ?'ַ_?!ҿ;ק̌wzk 4V;s}vN|wG+ddŶI ?C[,ZF16??zQÙ"Y/-紟cZ`ir.JwO4{I|aci~_aG?紟imd:vN|v7z|\7HynO 'µeÙ?j~_'q-#ַW6KbFXizI'=~StHNm.V>de}ܜcHnµ;@pף:2lA>?Hn=L :i#w;צe_wG+de|O/µk7;ק̌snO&Aאґ_ҵоg^MXn=OQ;Z 'bFiCInc򑌮+liOwGvzǚ.V9$IRB{bt@z|j:!0)w`;QQ;VGh?Qh?Wa- V7TU!#@5z+ƍ "cQ1GOjswm$=Џ1r^Sk- KV>axFsA4al#̋bgzd~87PU>ɳ~ovqw\rk%I{eb] rT98 qYȫr0,@@Z H#XiL%f1Lv@K󟻊`7Ԣx%-ȡQK˖P9ak(|mA T?aHqĩ<ʠvoAj+VYk-r6 v[ꖶTFVfv*0Pab|ցbݽܨF'q=\ \iv+xu@ÒW 9ې96|^;ݴW7Ut$ʓq=c?Gdmی=1-Ssr<Οwר@ )Ia`C$ʀr; H"Vfa]EݴrNşdMYo\OO UIZMG.F{Gnvܺxr1ɓ'=k伂)9'c2BGAc[_G鉣WLwˀs=ppER֭,i(dMf+g81Y#f; > UH$KD.E;G46jI+\#H0Oc&7 xDJ Ā ~SbAffZ*p@9uGWv#՞;g u;1y@'?RԊ,*zj2ث(F^:gq(}*7oʐ E.Q~Tzg%hc&8B28POE<td,vPo/R#iTlLgs< qR>ߕEsrFaf'#QӹH%g-m$>T,e`OgF8sd v7y{6lg85K\<^8-)c 4>M<O@mЀz:5{f8عڝ`[!N38~T0]qz}E.QQړksOt_2Ev?1s, `U:*qYZM6^c*q Wm()Utttw-eu2 ۝ ;g&|?!?_ 凊g,1sijv4QEqQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEUnU1ظq>,F赢ȿZ]ff.t@L|LcùD ш31qW=O/evvG4M)&Da]cSS-K#G:tZEo㑧) Ei啥IRDxٟΑ-a/~xZky#ڧzĉyqX\mԂ iUa +;`c #KOYɯ[<PѻңjHbK'8# =YZ@&ImWr=EvbvD [sO$UT|Ql(ͻ]\Yd4Hʠ+3FO]d)7IT;!J8$1U%`H8[=&k;TWcJ1wߍu @$㡦-:GOqs&9/F2`igXgӆ@lj)5xGGwfqe(iz? M07$J0x?#s| dAvx8Ʌqץ]W)}+yf*2ŀ \r1阢ף{?;XJH&lr19=̶K0NBd. p9-p+iWª[`fJ\Q;rFx'"uxx*) ;uڟGtv&JvO8PG {yׂ!J ,ι¤%fUR%G(Q1N٥,P Uw6 INʱ ;H-Y$&hcZ]@!'')8ɨ5 hW ).w'wֺ-V[mHD_p 8,=͋YY13(2n%@!@ ` VR*R4epzӟP@./uhCP]u>yTjE;L tV.X%Q wOW14SĒQ0=%)y$:oPvG539kO_][Cs8NŐ,ws8aɦPb8! 1g8]"v ѲYS~ӬId[;p0rӺƯqErMfPʆ$q|=-W^A 4ƍv[ ;f'?w\I Ao3L[fS1V;%q$o8֛{j[ 2EbV^紽kc56FbTr? }{viL&FP2}?v^O&I2b̍xaX]Ģ9cf%LL~X 1 3.z +f޲K,H'3FG9yXdY/.M%@ T(x,M5Yq _16@8jSޥHbImo86X2Ar8Npjŧ-)Tn*FX͜vȪQHrPso/ r09'On. cH3 .OWs>u ̩-*UY5huXP~`i1z _٣f7 ##jRxZ,1c͍|̐pvno ն֧ʫm(2jd'2h 4a{Xq >lcC.I>{nV,mbHk}(̢)Gr *O^3ީbIo$?2Gq% Jc X9$ hݿS.b` XrsO):dȓ]e%*c(I O_LsRi]j,,tA23n;V+`xRQH’\ 0?)(’\ ϏCieDH7@6ܑE;6gsk,W@\QL’@.# 5F ?c]0#?JNY΢c? j+;|g3Gέjk>#ꍟO-nWEهF*GΣ~uVf[-+^ B!|n\G=EYA=ݽ̑w#nCǭy=KnM.ы!ڕ UmƟح[ːO#˝ᦚ |ɴw(8l{QA&ݢ1XĦ ʧ?{G9t}.6|m#>&y-ek\:ƻs߾4>LpQ['$$h;攘n->3ʜ^[ i~W3ǑYHp2} _|¿h۩rT)r9@ xYGU܆/FNA2Npr1'Uiwn;݉8$ɓ7_BU{-I lsw~nehmD2w'Aj_i(/Vd[Mxbp(z'H(G$>ٷ#wp88 x.Z$I[G( <:AI5~aU,Hß3Fnrcn#"]Yk/]O}/G)Oͬ\ɳk`e<:fMjՏU#O79WMj|src%p}*fY(d mۅ;H8H99yɫj{d\B!C> J,DGG僂 '^xOLkY g/{`r5<.v!!C,ftEynY^ ZY!jYxc9\C63[ݪ@#7 7HchsEs #9Pn!rFc=ĒI2חv9FU񍅶ixܘW#iR(ex+$USbBАGW\7:jg4$%Oݠf$Y4 L7̶blve`T0;bt6/ifPL1ϰ޻KKi'1T!g]>A-lY8dX{R wRD)Q]#o9A*gY"2@;ҙbEf>Cm'qmO9e%QS:/#:*M)h1ef* Hqg2J6J#k9 X!eǯb0ŇDRuG SITU1\$\˳qAaFJ'&\hm&# ud8FxSYr0.SDX3{wXF- ?yHjx9=68mYQ-0#vu+߷&5u%UiǑ8Shhq% 30MYfXX ^uUo?jgG\j|>\c`vz'&z64vԜvp"޶O3'nۂr?!/K>C, 3F\1'|goDl\qq!!Ba6o tF Nݥ𭱆l GBzw[i1KiޝIwn<OQ)'4)f>C, 3F\1'|g4 $[{k,%?~YT+d}_SZ$Zx$C 2FB,\4pXc%vơр.Oq+h So@X *0<|}r? 4Fb[ 1MX]brrX| a]mS#vrp<Oxl&O~lk.3s EQqrrhiu1dYM .S8 vӜH#djHײ[yRS*#OS4ih- S26A=ym#2ϚrWNsFg]$-}ͬN7NpqW./^+Xekyb2L`Ssc'T1v$bXUc޽}IM/ysYLMĩpWhɠR;R" mGlmSw/ uWVȦM@޼gs##tlr\LyWckk7qx\v3`Lʝ:@-E(((((((((((((((*WJ\78F赢-h3RO['ۯ*dxxtAn*EV((((((((((((((((((((O:u5?' 3CQq!<`SG`{nS |3+cq Wc\w?5?A߆/5gV5 A5Z>/]O}/G6q-uqO2AK`Yz/eYh m DѸ=kjV{\Z3]Gl("I-bAc>BHHcj󕭩%ί$U$1V8"C\I`!Q6ޡҳQٵ [9 '^^150ۤ #i0б`#;8CRiSi ䷒INO%{m\ǗǷw9 znouao,*$q R0qW9^TFDcl~L+8虶\|֐p6 Fzf1zzX]/?{s:$(!T@{ɠUkw-I5X+!#ǰ z7~wnyc 4$ 7t: ˇ-nd hRF S/!hM1MXc7G~ܮk-V̒*#)玿Y-S<&=Ww N1p`ƀiQE((((((((((((((((((((*?6QP#&?D.GZGZ]ffr|;\?` n뮾ƍ#R((((((((((((((((((((O:u5~#{ nb2va~j( f,x*<u SVC\w?5?A OEzo^u]SYj.rpOکQ]]Xc.Vv?woi7WEah_]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]T?2?jYğkΞǯ+-h-h3Q/ G@msѢYEP@QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQER7AΖt[>tmN̞?Aqp: Άj+ SB%7+Oj%]v*sV#^X?a_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯Mg3?hUQ^T=np+\#kE+\#kEu̽\D ?WV7[1?sѤ~jQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE}G󥣸Oa\}v΢zeM sC..gsޢ&ϓso3t*(.ciDL"X@1`PKVHBJ,8ǯ>訒3e2q88?1A h̡gӑϸ h+X%IcnEI@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@QWIJ\78G赢G赢G oh7`&84C'+ƍZ((((((((((((((((((((}hI5ٗIʥs1QDquq_\IY5&+s;4rʉgqz+)q̱a${^At}nk<nI #pNC($ӿQEb{b)Qi&1`sݒO\cJhU' :~t$ף͆{-"IGxfKJ)QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEUz?ڻv'pƋ_ 5( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( F8AΓks!*sϺ*+ *e|\ʹΖoUFԭ3:610Qs[;k3dyM䕝lmH׊G)EchD^gwyvvWwqsR{p1'|~a;E2N笗P{qw;ζ3PbWx0rj3=K(s)U$`FG1#n8Z,Zb~WXn>ocj}.UX-9l툆N~ܲс%3F o:ԕ}hZZe`;D2KGXr:g ǦEP{p. {S|߽t`:k:#(fU.v' ?cͨ ]!k7(-3vy3B3"A#T.# 1y$O@F(\/ 0X +կKyFS{mբ$`Pʕn\ZBdc1N ;^޾tõ+e1ڠn5[X-*q_{m .7wNz vwg5MFzF*l\\,$r! 9$cgry'[ؤXI Xg qN9\M<*DL*qXr凨ZBdc1N ;^޾PvlРQlVF_@/in{"FdllF7=X銖[aHd.fIx9z[cp̒U\`^VD[2+,rІu*ASsA4֧y?BK. Bn-PR5Uc!X$a,2FG#<YJm!H,Qc Hs9 oGl#1h킻uo'``rNӷ&~>Q&1"=47J/&M+RҖgki!Ve e T0L{䵕X.#'c$wg}x찴{fY$1? fn߼ugUPrA%f*67TAznXeY|Wp?2#_#"'eO,yAEU_Q<@4/pƤWw9p;85mDaJI$yk 1Q=&H*2bPzz&xwYĪPF6| q`-C6֑EQ0mcŒEK^ ?N(!v}{uӚ (8Z +`/9Mjݺ]m!`Fѱ^4ڼq][)") 3zTS2k.p꥓-Ap6r0 /"YdHB=d ؃zfɡmYuB#@5qe1 –ʀ@;Nt?y{eH) 82Ǫ0ÑzηA@34iTQEQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@QE![yG7q~qMQswե]Zkq5ys>s*7z)ب!8.f+yU^=s \=ċ a¦T񼓝ْ1Nَ|m'g P",[pHpƈf-f6nϮp3Mm:٬;#S cEۯ\C #wpq󍵛շ%X X2FYsĿxӡ+hJ%1!cTdc so[4[D8# :~ sFF_^ɭxsK-+j SaՃF'Ğ[ܛF<֋,ZzXE"*0031x9&ﯯwTHcdw,4cq:6q`dpY0UUK@2E\^9J.oE Ÿq8s-ݴ q rExav6?p\| N+ ! Qp)*M~x7g.$\˺"9984].- ;<Ƕi.A܀)F<3ֶr-M: )@YG<׹Fiym`g' t56WFzi6VFªiQEE M,``Fvq0 hޤwn# ȹ$)= E6x~]$ʀ$S#X_ yՊ wx)PyqVMN'd9v:8R@\%P2 >z4Qp1iSD9{eA;I8.<ZJyYI DIq&WL 9c t4Qp"᳆95V, sãItYdYJ-3b˰,KuzP/^c%FX#gr1Zz*gC Qm'y[%.g$㦢[O]Vlm{sg*}*i"E#e@01ޢ7K)`?!O'=/u;g8eV ʖ-^ #  (ӵ'Ybcq4.[%)^n)Kђ>RC| ME7E6?$Z IjSyx+fw ~S(6%1EK%Nyp0*mf.ͬhbRU%.O$}P+J.+i4MіL@"m'dWY[ew1>ann9(]G-!'h=# ?쫃$$ŃFQDeUT2arCp8m-[Qp24t}bviaq3*r1G" gErw{D 2ӹ淨swц餷0X-+$pORr $T_:>bd8`@'rEao-S(ihRDl>S˓MŸ'W3˵+' \ ;}`DB(ɔ)RNp<q&h]g8|q|A) r iQEώ ƪ|Xm:1H5e[,v.P ,$ H<:Qp0d+ݧ͂U2Ⴑ 0VO|jxB)$xcO7xc]vT ;ybvS-4& d7[w 8GoX)Kf+HҢ@QEQEQEQEQEQEQEQEQEQEQEDTqP_{#-h-h3Xüto/@Ǻ*E3N((((((((((((((((((((({ nsp=HtG$gU\nۀ$426H詥H#, H?1Nz>tEB$AUz|}9HhzQ-;N6q Xʪn;g$|t=.K/K8Xi גIyJ,it(v2qV|$Λ2`7r7qՊXn#Ynͣy1@- I|rAoyKQ\Ԯh]o.9WwC,p9Frd'y. DgE('#s/'V8±nm$ 31u$ %ܵjePyYt *Pg fCKawEH&@R?3\61P][4,7,Ef^k)ta38./,/\18, j(((((((((((((((((((((((((((((~?-hURԎ \78G赢G赢P37G0_+I 8`?@$jFfQL((((((((((((((((((()o?R{ n`RzP?:#ʥLdQc+s9&Uܧ9AImme" w1f,}KI`j(((((((((((((((((((((((((((((((((*S*T*>TObx@:?pE+\#kEuxs+wG*s Vʹ|h|,Ӣ( ((((((((((((((((((()KH:Oa((RçV^yr?`n.-ռAl|ˀ$dY)ehAs0si/,\\ƻ(Fm+3V=*QIv :@x-X!x`ȪWa% $ÜWNhb/+/*?W<9E uL[\n$w;'F{4u9YYf_13 gw9n@g$7ZXvv,wxy]v{)Ƌ˰rw/Ɣ\__yv .)7Xm$oGR^]˹?:] Z^]w6/I?:qiK:/.e޿.Iy)kG,{#V//shM`^]w6=h}{Z=e=GI?:3_Z Pv .to_αDڇS֔M^]˹?:7/X}@)Q8ch*mo_Γzx~u#ҙ5 KG9Wsgrx~tno3QzZ]ʿ^]w67F?:'Q (-tHz7Qww@Agm#;\yq\]ZWS'l.TGLT}bD# !s4JJ'7pq~7cբaۆ>_qLjLu|]F)/?¯DFdyt:ʲs)?, =C~]/Z6 }:U{#f_GZvs)? =E̿.˭/??“6~o9Yui?7(Ӭޟ!.˭N7P4okfwKցm^Ik?WQbw "!Zos S[WQb>FdZDG FI'85g˫`s)E^GHGKϰWR9{X#)yT/]v{/m\Gr2p[^sR;p? =GʾW֗5il?wӍ#^n=C'ޗ>}h6p{h#+OCS/wZp]~k{h#+g /?{Q.FEsi~F8=G1洞\'w}!BGRH@͗n;]25 +Dt8ߥgRe.1hA.fM#rw>{;ĩfFɓ qX6Fu2ך=L)$2&X,{žPEMhW rW(> Rl:J+?Wj?Z2#UgYj_X9rH87O?ZdEQ9ǓjG9YzLQ̃'RW=֤:?=֣+/T?=֥?Q̃GQZX1j9rIuˏԦ˟se*=֤:W=֣#vX;ǿse*pH֣G?Q̅U/e?=֣+4(_8B._jCs=֣#/QTU_ZdEgj/{G1ǿs fLڇ?{{G2VhQTFe}cǨA˴U#?ǿ>j9rGHO?:˟s e*2ǿi{G2V_K_Zx_ZdEP_ZD/{G2V^G~_jC`dAU%w.?R.Q΃(o_Z_ZxE*cǿQ΃('Q#Z/{G2+/QT?=֤?ZdТh _ZtEQW=֣Kj9rLڟQ̃V1ǿj9YEQ=֥+.TSSAGiGڊ\zg8RMq~+\#kE+\#kEvxw*Qp6Tw/u>W-o9<j_BTOw EV@O,Iߨq=3,9s(vc|-$;4#f 9HeݕUFI' ,w8f(;?EvWpaRny5Q-w 3(v ±٤?,_3vM7Na ϡ4sG(6m?4@z3+_֏W5\|¤TXTrc?9+?.WaM'/`~$Ӕ1,72/)֬-JiXz֣`8V$$zl_jG՚2#p?u #: ڋ ů߯'#o?XLW?!Z/a޴>սe_j_p??X8h,7?G_j?Gg_j P VP9!NdQ'4X,ok߯4꧴ XD0>oSEՏy?Zud'/sIӰYsğ @Հ_jIt-q/?Iq\G(gfr?M:dLW?ϩ=h΀j֤:ƒğ XܟΜ tX ì#a_j4$`5v~L/asҗkwjC5Qd?K8V&?4 N`X|I}ҰsZIW~ t'j/cIM#@nkC~j?s\ՄA±߯'S~ՆA4 zS~k' 4?4X,ojO֤:O֬<Q? ,7FRU1/`oZiZ,7G_jiq-Zqi#xjǼ Rk/g?s?hfН\kԟ =Z>@ڸs\ԑ럞^?Z9_֝t_n^? CI`/sߏJΗ(tZRZ֬,&r?yԣVl/b(c@lk8<_jwrV(V?SpjZj$z#,:%6FJ)MԠ}$p9>UG`3,7Гi ̪>{"3IXC`r3U9Eq&+?Q?Wq!@j34cUR^@KKIdFXL b?SjA")Nb'10Mn{sWEB.otOQXܽme1,3dUN6r0+ $qcqlb^ێhyw'NB3rd0^6S͟C &97u,J[ k\ZJ?Ӿ?AM2 GCM.TB8ddP]#]i)r 9;v9fm.41:0HrnG8]1 ^bn12,pe j?>q?qF"_T,svu!h숕vL*lltf J!qha!cqqFFp.D$bicp0Fw3⏱vRgif)1!R]vRƌ5Yi`n|1i(sGf#5-#_= !tC#8#21ðag) H#ܒ #D|yϯ:Fm'#YfM;y8 0`p{0 ֥MAsKw5&7nQSoo z8;##үT](G=j`_qO΋"l}?Q4ҍ ygqfp[?AFPz: hH4+"$oZ?W /GXW4 @lvt;,}1Gj?T\ 13g'j1}U>H#XTcOS(+@w:A_qG gzQEhawA}Ra5 ϥ&=ia1y˜hf 0k@藿'L3)}3ZؗYΗ!}Po>cڴ[BT+?:b()x>_?WTg =ha_cXc#04`֧k}Q_ꋠ2q1_G/I}hX L 1ihx䰈`֚t;TC#ғ?wT y=ia1x?L43p?Ȥ㸭vTwJ?Tr?: 5|WD kH70W~tCB}Ra^% vIӦ+C ?G c X)9??_GT]F5|=T]qO6>h`p~tAǩYcNnSy?GڧfgK6vC!tg)ϗdO7^k缟٣Sy?G`g}D|,vh7Kj$u_j{}>?4{(vyj?$t~O=j{}=;HփP#U?]Dc~?4}'hP.vzXA??nv_nSy?GڧfeK6 /O7IMG!yڧfO==-u]?+[j%?4}'hPo˲tPי}'hTO9zpRc?n}GyC?O=j{}=;?4}'hPϳjUcD+7^c缟٣Sy?G`oǗe~>ɨrך'hTO9d睗? }Dv?nSy?GڧfeNucʲtF?4{(fzaQ-8>n?睏2TO缟٣Cs+PV?nXy7^a缟٣Si?GaIjc˱tk,!yڧfO=Kڈ'?nuj{}>?4{(vvzQO/&luj{}>?4{8fzX?c7Joc0_י'hTO9PcO/Dv?nSy?Gڧfe#ӄ:t߳?ܱuj{}>?4{(vymG?n캇,%yڧf\yG`g}P 7Nj#YK\yGڮ?缿٣CsַXce_7L& 7^k/hU4{(vvz_5XKp@Wc/̾q=jfeNuc˱tF<%yڮ?缿٣w_9zcj @tִHG?5]4}{}={;=(Y#,!'"y[,z}yڮ?缿٣W_9fPz??m595U4}{}={3=0%C_#PV?nW_/hP=??畏Yy7^a/hU4{(vFq=Kڈ'vGQݟ.י{}>?4{(vvzQOY~>ɨc,!yڧfO==-u]?)K uj{}>?4{(vvz`v`Qoec̾?4}'hP=8A+#o>ͩ;/7^e缟٣Sy?G`fԿ睗?캏uj{}>?4{(vfzgٵ t?南I~?4}'hP=5&o5e>?4}'hPj?$to$u_j{}>?4{(vvzwUI>Ϩ+/י}'hTO9zcj,tִ'5TO缟٣GsE?块IO)eAU;I>36; #use Test::More qw(no_plan); use Data::Dumper; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my($switch) = DBI->internal; #DBI->trace(2); # 2=detailed handle trace print "Switch: $switch->{'Attribution'}, $switch->{'Version'}\n"; print "Available Drivers: ",join(", ",DBI->available_drivers()),"\n"; my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 33) { ok(0); } exit(0); } print "Connect to server version: ", $dbh->{syb_server_version}, "\n"; my $rc; $rc = $dbh->do("use master"); ok(defined($rc), 'use master'); my $sth; $sth = $dbh->prepare("select * from sysusers"); ok(defined($sth), 'prepare select sysusers'); $rc = $sth->execute; ok(defined($rc), 'execute'); ok($sth->{NUM_OF_FIELDS} > 0, 'FIELDS'); ok(@{$sth->{NAME}} > 0, 'NAME'); ok(@{$sth->{NULLABLE}} > 0, 'NULLABLE'); my $rows = 0; while(my @dat = $sth->fetchrow) { ++$rows; foreach (@dat) { $_ = '' unless defined $_; } print "@dat\n"; } ok($rows == $sth->rows, 'rows'); undef $sth; $sth = $dbh->prepare("select * from sys_users"); ok(defined($rc), 'prepare'); $rc = $sth->execute; ok(!defined($rc), 'execute (fail)'); ok($sth->err == 208, 'error code'); $sth = $dbh->prepare("select * from sysusers"); ok(defined($sth), 'prepare'); $rc = $sth->execute; ok($rc, 'execute'); my @fields = @{$sth->{NAME}}; $rows = 0; my $d; my $ok = 1; while($d = $sth->fetchrow_hashref) { ++$rows; foreach (@fields) { if(!exists($d->{$_})) { $ok = 0; } my $t = $d->{$_} || ''; print "$t "; } print "\n"; } ok($ok, 'fetch'); ok($rows == $sth->rows, 'rows'); undef $sth; $dbh->{LongReadLen} = 32000; $dbh->{syb_quoted_identifier} = 1; $rc = $dbh->do('create table #tmp("TR Number" int, "Answer Code" char(2))'); ok($rc, 'quoted identifier'); $rc = $dbh->do(qq(insert #tmp ("TR Number", "Answer Code") values(123, 'B'))); ok($rc, 'quoted identifier insert'); $dbh->{syb_quoted_identifier} = 0; # Test multiple result sets, varying column names $sth = $dbh->prepare(" select uid, name from sysusers where uid = -2 select spid, kpid, suid from master..sysprocesses where spid = \@\@spid "); ok($sth, 'prepare multiple'); $rc = $sth->execute; ok($rc, 'execute multiple'); my $result_set = 0; do { while(my $row = $sth->fetchrow_hashref) { if($result_set == 1) { ok(keys(%$row) == 3, 'number of columns, second result set'); ok($row->{spid} > 0, 'spid column in second result set'); } } ++$result_set; } while($sth->{syb_more_results}); # Test last_insert_id: SKIP: { skip 'requires DBI 1.43', 1 unless $DBI::VERSION > 1.42; # This will only work w/ DBI >= 1.43 $dbh->do("create table #idtest(id numeric(9,0) identity, c varchar(20))"); $dbh->do("insert #idtest (c) values ('123456')"); # DBI->trace(10); my $value = $dbh->last_insert_id(undef,undef,undef,undef); ok($value > 0, 'last insert id'); } #my $ti = $dbh->type_info_all; #foreach my @type_info = $dbh->type_info(DBI::SQL_CHAR); ok(@type_info > 1, 'type_info'); ok(exists($type_info[0]->{DATA_TYPE}), 'type_info DATA_TYPE'); SKIP: { skip 'requires DBI 1.34', 3 unless $DBI::VERSION >= 1.34; my $sth = $dbh->prepare("select * from master..sysprocesses"); $sth->execute; my @desc = $sth->syb_describe; ok($desc[0]->{NAME} eq 'spid', 'describe NAME'); ok($desc[0]->{STATUS} =~ /CS_UPDATABLE/, 'describe STATUS'); ok($desc[0]->{TYPE} == 8, 'describe TYPE'); } $sth = $dbh->prepare(q|select suid, suser_name(suid), cpu, physical_io from master..sysprocesses order by suid compute sum(cpu), sum(physical_io) by suid | ); ok($sth, "Prepare compute"); $rc = $sth->execute; ok($rc, "execute compute"); my %seen_result_type_width; while(my $row = $sth->fetch) { local $^W = 0; print "$sth->{syb_result_type}: @$row\n"; $seen_result_type_width{ $sth->{syb_result_type} }->{ scalar @$row } = 1; } use Data::Dumper; is_deeply( \%seen_result_type_width, { '4040' => { '4' => 1 }, # regular rows have 4 columns '4045' => { '2' => 1 } # compute row has 2 }) or print Dumper(\%seen_result_type_width); $sth->finish; # Test new datatypes available with ASE 12.5.3 # if($dbh->{syb_server_version} ge '12.5.3') { my $sth = $dbh->prepare("select convert(date, getdate()), convert(time, getdate())"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; } } # Test new datatypes available with ASE 15 # SKIP: { skip 'requires ASE 15 ', 2 unless $dbh->{syb_server_version} ge '15'; $dbh->{PrintError} = 1; my $sth = $dbh->prepare("select convert(unsigned smallint, power(2, 15)), convert(bigint, power(convert(bigint, 2), 32))"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; ok($r->[0] == 32768, "unsigned smallint"); ok($r->[1] == 4294967296, "bigint"); } } SKIP: { skip 'requires ASE 15.5 ', 2 unless $dbh->{syb_server_version} ge '15.5'; $dbh->{PrintError} = 1; $dbh->syb_date_fmt('LONGMS'); my $sth = $dbh->prepare("select current_bigdatetime(), current_bigtime()"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; ok(1 == 1, "bigdatetime"); ok(1 == 1, "bigtime"); } } $dbh->disconnect; DBD-Sybase-1.14/t/xblob.t0100644000076500007650000001070610571606237015272 0ustar mpepplermpeppler#!perl # # $Id: xblob.t,v 1.12 2007/03/01 17:17:44 mpeppler Exp $ use lib 't'; use strict; use _test; use Test::More tests=>11; #qw(no_plan); use vars qw($Pwd $Uid $Srv $Db $loaded); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError=>1}); #exit; ok($dbh, 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 11) { ok(0); } exit(0); } $dbh->do("if object_id('blob_test') != NULL drop table blob_test"); my $rc = $dbh->do("create table blob_test(id int, data image null, foo varchar(30))"); ok($rc, 'Create table'); open(IN, "t/screen.jpg") || die "Can't open t/screen.jpg: $!"; binmode(IN); my $image; { local $/; $image = ; } close(IN); my $heximg = unpack('H*', $image); $rc = $dbh->do("insert blob_test(id, data, foo) values(1, '', 'screen.jpg')"); ok($rc, 'Insert image'); #DBI->trace(3); my $sth = $dbh->prepare("select id, data from blob_test"); #$sth->{syb_no_bind_blob} = 1; $sth->execute; while($sth->fetch) { # my $d; # $sth->func(2, \$d, 0, 'ct_get_data'); $sth->func('CS_GET', 2, 'ct_data_info') || print $sth->errstr, "\n"; } $sth->func('ct_prepare_send') || print $sth->errstr, "\n"; $sth->func('CS_SET', 2, {total_txtlen => length($image), log_on_update=>1}, 'ct_data_info') || print $sth->errstr, "\n"; $sth->func($image, length($image), 'ct_send_data') || print $sth->errstr, "\n"; $sth->func('ct_finish_send') || print $sth->errstr, "\n"; $dbh->{LongReadLen} = 100000; $sth = $dbh->prepare("select id, data from blob_test"); #$dbh->{LongReadLen} = 100000; #DBI->trace(3); $sth->{syb_no_bind_blob} = 1; $sth->execute; my $heximg2 = ''; my $size = 0; while(my $d = $sth->fetch) { my $data; # open(OUT, ">/tmp/mp_conf.jpg") || die "Can't open /tmp/mp_conf.jpg: $!"; while(1) { my $read = $sth->func(2, \$data, 1024, 'ct_get_data'); $heximg2 .= unpack('H*', $data); $size += $read; last unless $read == 1024; # print OUT $data; } # close(OUT); } #warn "Got $size bytes\n"; ok($heximg eq $heximg2, 'Images are the same'); mkdir("./tmp", 0755); open(ONE, ">./tmp/hex1"); binmode(ONE); print ONE $heximg; close(ONE); open(TWO, ">./tmp/hex2"); binmode(TWO); print TWO $heximg2; close(TWO); $rc = $dbh->do("drop table blob_test"); ok($rc, 'Drop table'); SKIP: { skip 'Requires DBI 1.34', 4 unless $DBI::VERSION >= 1.34; my $rc = $dbh->do("create table blob_test(id int, data image null, foo varchar(30))"); ok($rc, 'Creat table'); open(IN, "t/screen.jpg") || die "Can't open t/screen.jpg: $!"; binmode(IN); my $image; { local $/; $image = ; } close(IN); my $heximg = unpack('H*', $image); $rc = $dbh->do("insert blob_test(id, data, foo) values(1, '', 'screen.jpg')"); ok($rc, 'Insert image'); #DBI->trace(3); my $sth = $dbh->prepare("select id, data from blob_test"); #$sth->{syb_no_bind_blob} = 1; $sth->execute; while($sth->fetch) { # my $d; # $sth->func(2, \$d, 0, 'ct_get_data'); $sth->syb_ct_data_info('CS_GET', 2) || print $sth->errstr, "\n"; } $sth->syb_ct_prepare_send() || print $sth->errstr, "\n"; $sth->syb_ct_data_info('CS_SET', 2, {total_txtlen => length($image), log_on_update=>1}) || print $sth->errstr, "\n"; $sth->syb_ct_send_data($image, length($image)) || print $sth->errstr, "\n"; $sth->syb_ct_finish_send() || print $sth->errstr, "\n"; #DBI->trace(4); $dbh->{LongReadLen} = 100000; $sth = $dbh->prepare("select id, data from blob_test"); #$dbh->{LongReadLen} = 100000; #DBI->trace(0); #DBI->trace(3); $sth->{syb_no_bind_blob} = 1; $sth->execute; my $heximg2 = ''; my $size = 0; while(my $d = $sth->fetch) { my $data; # open(OUT, ">/tmp/mp_conf.jpg") || die "Can't open /tmp/mp_conf.jpg: $!"; while(1) { my $read = $sth->syb_ct_get_data(2, \$data, 1024); $heximg2 .= unpack('H*', $data); $size += $read; last unless $read == 1024; # print OUT $data; } # close(OUT); } #warn "Got $size bytes\n"; ok($heximg eq $heximg2, 'Images are the same'); mkdir("./tmp"); open(ONE, ">./tmp/hex1"); binmode(ONE); print ONE $heximg; close(ONE); open(TWO, ">./tmp/hex2"); binmode(TWO); print TWO $heximg2; close(TWO); $rc = $dbh->do("drop table blob_test"); ok($rc, 'Drop table'); } DBD-Sybase-1.14/t/xblk.t0100644000076500007650000002470210571606237015125 0ustar mpepplermpeppler# -*-Perl-*- # $Id: xblk.t,v 1.11 2005/11/04 18:35:54 mpeppler Exp $ # # # Small BLK test script for DBD::Sybase use lib 't'; use _test; use strict; use Test::More tests => 62; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); sub cslib_cb { my ($layer, $origin, $severity, $number, $errmsg, $osmsg, $usermsg) = @_; print "cslib_cb: $layer $origin $severity $number $errmsg\n"; print "cslib_cb: User Message: $usermsg\n"; if($number == 36) { return 1; } return 0; } $SIG{__WARN__} = sub { print @_; }; DBD::Sybase::set_cslib_cb(\&cslib_cb); #DBI->trace(5); my $charset = get_charset($Srv, $Uid, $Pwd); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db;charset=$charset;bulkLogin=1", $Uid, $Pwd, {PrintError=>1, AutoCommit => 1,}); # syb_err_handler => sub { local $^W = 0; # print "@_\n"; # return 0}}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 62) { ok(1); } exit(0); } SKIP: { skip 'No BLK library available.', 59 unless $dbh->{syb_has_blk}; my $rc = $dbh->do("create table #tmp(x numeric(9,0) identity, a1 varchar(20), i int null, n numeric(6,2), d datetime, s smalldatetime, mn money, mn1 smallmoney, b varbinary(8), img image null)"); ok(defined($rc), 'Create table'); test1($dbh); test2($dbh); test3($dbh); test4($dbh); test5($dbh); test6($dbh); test7($dbh); test8($dbh); } sub test1 { my $dbh = shift; $dbh->begin_work; # DBI->trace(4); my $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'Prepare #1'); my @data = ([undef, "one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000], [undef, "two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100], [undef, "three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100]); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 1"); ++$i; } $rc = $dbh->commit(); ok($rc, 'Commit test 1'); my $rows = $sth->rows(); ok($rows == 3, 'Rows test 1'); $sth->finish; # DBI->trace(0); } sub test2 { my $dbh = shift; # Now test conversion failures. None of these rows should get loaded. $dbh->begin_work; my $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'prepare #2'); my @data = ([undef, "one b", 123, 123.4, 'feb 29 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 100], [undef, "two b", 123456789123456, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100], [undef, "three b", undef, 123456.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100], [undef, "four b", undef, 126.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, "34343434343434343434.23", '21212121', 'z' x 100], ); my $i = 1; my $rc; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(!defined($rc), "Execute row $i, test 2"); ++$i; } $rc = $dbh->commit; ok($rc, 'Commit test 2'); my $rows = $sth->rows; ok($rows == 0, 'Rows, test 2'); $sth->finish; } # Test explicit identity value inserts. sub test3 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 }}); ok(defined($sth), 'Prepare #3'); my @data = ([10, "one", 123, 123.4, 'Nov 1 2001 12:00', 'Nov 1 2001', 343434.3333, 34.23, 'deadbeef', 'z' x 100], [11, "two", -1, 123.456, '11/1/2001 12:00', '11/1/2001 11:21', 343434.3333, 34.23, '25252525', 'z' x 100], [12, "three", undef, 123, 'Nov 1 2001 12:00', 'Nov 1 2001', 343434.3333, 34.23, '43434343', 'z' x 100]); my $i = 1; my $rc; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Execute row $i, test 3"); ++$i; } $rc = $dbh->commit; ok($rc, 'Commit, test 3'); my $rows = $sth->rows; ok($rows == 3, 'Rows, test 3'); $sth->finish; } # Test for prepare failures sub test4 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare("insrt #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 }}); ok(!defined($sth), 'Prepare #4'); print $dbh->errstr, "\n"; # DBI->trace(5); my $sth1 = $dbh->prepare("select * from #tmp where foo = ?", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 }}); ok(!defined($sth1), 'Prepare #5'); my $sth2 = $dbh->prepare("select * from #tmp", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 }}); ok(!defined($sth2), 'Prepare #6'); print $dbh->errstr, "\n"; } # Test for missing commit/finish. sub test5 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'Prepare test 5'); my @data = ([undef, "test5 one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000], [undef, "test5 two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100], [undef, "test5 three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100]); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 5"); ++$i; } local $^W = 0; $sth->finish; } # Test for rollback. sub test6 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'Prepare test 6'); my @data = ([undef, "test6 one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000], [undef, "test6 two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100], [undef, "test6 three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100]); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 6"); ++$i; } $rc = $dbh->rollback; ok($rc, 'test 6 rollback'); $rc = $sth->finish; ok($rc, 'test 6 finish'); $sth = undef; $dbh->begin_work; my $sth2 = $dbh->prepare("select count(*) from #tmp where a1 like 'test6 %'"); ok(defined($sth2), 'test 6 prepare select'); $rc = $sth2->execute; ok($rc, 'test 6 execute select'); my $row = $sth2->fetch; ok($row && $row->[0] == 0, 'test 6 row value'); $sth2->finish; $sth2 = undef; $dbh->commit; $dbh->begin_work; $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'Prepare test 6 (2)'); foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 6"); ++$i; } $rc = $dbh->commit; ok($rc, 'test 6 commit'); foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 6"); ++$i; } $rc = $dbh->rollback; ok($rc, 'test 6 rollback'); $rc = $sth->finish; ok($rc, 'test 6 finish'); $sth = undef; # DBI->trace(0); } sub test7 { my $dbh = shift; $dbh->{AutoCommit} = 1; # Test some of the data in the #tmp table. my $sth = $dbh->prepare("select count(*), sum(i), sum(n) from #tmp"); ok(defined($sth), 'prepare test 7'); my $rc = $sth->execute; ok($rc, 'execute test 7'); my($c, $i, $n); while(my $row = $sth->fetch) { ($c, $i, $n) = @$row; print "@$row\n"; } ok($c == 9, 'Row count'); ok($i == 366, 'Sum(i)'); ok($n == 3333.11, 'Sum(n)'); } # Turn autocommit off, update some data, then try to run # a bcp operation. # This tests to make sure that the AutoCommit/CHAINED mode flip/flop # happens correctly sub test8 { my $dbh = shift; #DBI->trace(4); $dbh->begin_work; my $sth = $dbh->prepare("update #tmp set i = 20 where i = 123"); ok(defined($dbh), 'Prepare update test 8'); my $rc = $sth->execute; ok($rc, 'Execute update test 8'); $sth = undef; $sth = $dbh->prepare("insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 }}); ok(defined($sth), 'Prepare test 8'); my @data = ([undef, "one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000], [undef, "two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100], [undef, "three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100]); my $i = 1; foreach (@data) { $_->[8] = pack('H*', $_->[8]); $rc = $sth->execute(@$_); ok(defined($rc), "Send row $i - test 8"); ++$i; } $rc = $dbh->commit(); ok($rc, 'Commit test 8'); my $rows = $sth->rows(); ok($rows == 3, 'Rows test 8'); # $sth->finish; $sth = undef; } sub get_charset { my $srv = shift; my $uid = shift; my $pwd = shift; my $dbh = DBI->connect("dbi:Sybase:server=$srv", $uid, $pwd); die "Can't connect to $srv" unless $dbh; my $sth = $dbh->prepare("sp_configure 'default character set id'"); $sth->execute; my $id; while(my $r = $sth->fetch) { $id = $r->[4]; } $sth->finish; if(!$id) { warn "Can't find charset id - using iso_1"; return 'iso_1'; } $sth = $dbh->prepare("select name from master..syscharsets where id = $id"); $sth->execute; my $charset; while(my $r = $sth->fetch) { $charset = $r->[0]; } if(!defined($charset)) { warn "Can't find charset name - using iso_1"; return 'iso_1'; } return $charset; } DBD-Sybase-1.14/t/_test.pm0100644000076500007650000000125310571606237015450 0ustar mpepplermpeppler# $Id: _test.pm,v 1.2 2007/03/01 17:17:44 mpeppler Exp $ package _test; $|=1; #keep stdout in sync with stderr my ($Uid, $Pwd, $Srv, $Db); sub load_data { my @dirs = ('./.', './..', './../..', './../../..'); foreach (@dirs) { if(-f "$_/PWD") { open(PWD, "$_/PWD") || die "$_/PWD is not readable: $!\n"; while() { chop; s/^\s*//; next if(/^\#/ || /^\s*$/); ($l, $r) = split(/=/); $Uid = $r if($l eq UID); $Pwd = $r if($l eq PWD); $Srv = $r if($l eq SRV); $Db = $r if($l eq DB); } close(PWD); last; } } } sub get_info { load_data(); $Db = 'tempdb' unless $Db; return ($Uid, $Pwd, $Srv, $Db); } 1; DBD-Sybase-1.14/t/fail.t0100644000076500007650000000443410571606237015100 0ustar mpepplermpeppler#!/usr/local/bin/perl # # $Id: fail.t,v 1.9 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use strict; use lib 't'; use _test; use Test::More tests=>12; #qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0, syb_flush_finish => 1}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 12) { ok(0); } exit(0); } my $rc; #DBI->trace(4); my $sth = $dbh->prepare(" select * from sysusers select * from no_such_table select * from master..sysdatabases "); $rc = $sth->execute; ok(!defined($rc), 'Missing table'); $sth = $dbh->prepare("select * from sysusers\n"); $rc = $sth->execute; ok(defined($rc), 'Sysusers'); while(my $d = $sth->fetch) { ; } $rc = $dbh->do("create table #test(one int not null primary key, two int not null, three int not null check(two != three))"); ok(defined($rc), 'Create table'); SKIP: { skip '? placeholders not supported', 3 unless $dbh->{syb_dynamic_supported}; $sth = $dbh->prepare("insert #test (one, two, three) values(?,?,?)"); $rc = $sth->execute(3, 4, 5); ok(defined($rc), 'prepare w/placeholder'); $rc = $sth->execute(3, 4, 5); ok(!defined($rc), 'execute w/placeholder'); $rc = $sth->execute(5, 3, 3); ok(!defined($rc), 'execute w/placeholder'); } $sth = $dbh->prepare(" insert #test(one, two, three) values (1, 2, 3) insert #test(one, two, three) values (4, 5, 6) insert #test(one, two, three) values (1, 2, 3) insert #test(one, two, three) values (8, 9, 10) "); $rc = $sth->execute; ok(!defined($rc), 'prepare'); $sth = $dbh->prepare("select * from #test"); $rc = $sth->execute; ok(defined($rc), 'select'); while(my $d = $sth->fetch) { print "@$d\n"; } #print "ok 11\n"; $sth = $dbh->prepare(" insert #test(one, two, three) values (11, 12, 13) select * from #test insert #test(one, two, three) values (11, 12, 13) "); $rc = $sth->execute; ok(defined($rc), 'prepare/execute multi'); do { while(my $d = $sth->fetch) { print "@$d\n"; } } while($sth->{syb_more_results}); $dbh->do("drop table #test"); DBD-Sybase-1.14/t/thread.t0100644000076500007650000000500710571606237015431 0ustar mpepplermpeppler#!perl -w # $Id: thread.t,v 1.5 2005/10/01 13:05:13 mpeppler Exp $ # Test support for threads in DBD::Sybase. use strict; use Config qw(%Config); BEGIN { if (!$Config{useithreads} || $] < 5.008) { print "1..0 # Skipped: this perl $] not configured to support iThreads\n"; exit 0; } } use threads; use DBI; use DBD::Sybase; # REQUIRED!!! BEGIN { if (!DBD::Sybase::thread_enabled()) { print "1..0 # Skipped: this DBD::Sybase not configured to support iThreads\n"; exit 0; } } use Test::More tests => 10; use Thread::Queue; use lib 't'; use _test; use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $database = getDatabase(); print "Using database $database\n"; my $queue = Thread::Queue->new; my $rdr = threads->create(\&reader, $queue, $database); my @thr; foreach (1 .. 3) { push(@thr, threads->create(\&test_it, $queue, $database)); } my $count = $rdr->join; my $total = 0; foreach (@thr) { $total += $_->join; } is($count, $total); sub reader { my $queue = shift; my $db = shift; my $dbh = getDbh($db); ok(defined($dbh)); my $sth = $dbh->prepare("select id from sysobjects"); ok(defined($sth)); my $rc = $sth->execute; ok($rc); my $count = 0; while(my $row = $sth->fetch) { $queue->enqueue($row->[0]); ++$count; } return $count; } sub test_it { my $queue = shift; my $db = shift; my $dbh = getDbh($db); ok(defined($dbh)); my $sth = $dbh->prepare("select name, crdate, instrig, deltrig, type, uid, sysstat, updtrig from sysobjects where id = ?"); ok(defined($sth)); my $count = 0; my $rc; my $tid = threads->tid(); while(1) { my $id = $queue->dequeue_nb; last unless(defined($id)); $rc = $sth->execute($id); # ok($rc); while(my $row = $sth->fetch) { print "$tid - fetched($id) == $row->[0]\n"; ++$count; } } return $count; } sub getDbh { my $dbname = shift || 'master'; my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$dbname;timeout=60;loginTimeout=20", $Uid, $Pwd, {PrintError => 1}); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 10) { ok(0); } exit(0); } return $dbh; } sub getDatabase { my $dbh = getDbh(); my $sth = $dbh->prepare("select 1 from master..sysdatabases where name = 'sybsystemprocs'"); $sth->execute; my $database = 'master'; while(my $row = $sth->fetch) { $database = 'sybsystemprocs'; } return $database; } DBD-Sybase-1.14/t/base.t0100644000076500007650000000100307642152537015070 0ustar mpepplermpeppler#!/usr/local/bin/perl -w # # $Id: base.t,v 1.2 2003/03/31 23:55:11 mpeppler Exp $ # Base DBD Driver Test print "1..$tests\n"; require DBI; print "ok 1\n"; import DBI; print "ok 2\n"; $switch = DBI->internal; (ref $switch eq 'DBI::dr') ? print "ok 3\n" : print "not ok 3\n"; $drh = DBI->install_driver('Sybase'); (ref $drh eq 'DBI::dr') ? print "ok 4\n" : print "not ok 4\n"; print "ok 5\n" if $drh->{Version}; #my @d = DBI->data_sources('Sybase'); #print STDERR "@d\n"; BEGIN { $tests = 5 } exit 0; # end. DBD-Sybase-1.14/README.freetds0100644000076500007650000000404507643103124016037 0ustar mpepplermpeppler$Id: README.freetds,v 1.2 2003/04/03 19:07:00 mpeppler Exp $ Using DBD::Sybase with FreeTDS ============================== DBD::Sybase 1.00 or later works reasonably well with FreeTDS 0.61, but some capabilities are limited or not available. Build process: -------------- FreeTDS normally installs in /usr/local, with the libraries in /usr/local/lib and the include files in /usr/local/include. This location is assumed below. To build DBD::Sybase you need to set the SYBASE environment variable to /usr/local. When you now run "perl Makefile.PL" you will get warnings for a few missing libraries: Note (probably harmless): No library found for -lcs Note (probably harmless): No library found for -lsybtcl Note (probably harmless): No library found for -lcomn Note (probably harmless): No library found for -lintl This is OK because FreeTDS doesn't package the functions in the same libraries as Sybase. The "make test" process will fail for a number of tests: Failed Test Stat Wstat Total Fail Failed List of Failed ------------------------------------------------------------------------------- t/exec.t 0 139 ?? ?? % ?? t/main.t 16 2 12.50% 13-14 t/xblob.t 6 2 33.33% 5-6 13 subtests skipped. This is expected. Missing Features: ----------------- * ?-style placeholders are not supported. * Setting $dbh->{LongReadLen} doesn't work Use $dbh->do("set textsize ") instead. * The special text/image handling functions don't work (i.e. ct_fetch_data(), etc). * The $dbh->{syb_row_count} attribute doesn't work. Use $dbh->do("set rowcount ") instead. * The $dbh->{syb_quoted_identifier} attribute doesn't work. Use $dbh->do("set quoted_identifier ") instead. Bugs: ----- FreeTDS 0.61 has a bug when executing queries that return 0 rows, which manifests itself when trying to do a fetchrow_hashref() after such a query with the following error: Can't get DBI::st=HASH(0x811cfa8)->{NAME}: unrecognised attribute at... This is fixed in the 0.62-dev version of FreeTDS. DBD-Sybase-1.14/Sybase.h0100644000076500007650000001110611642075621015123 0ustar mpepplermpeppler/* $Id: Sybase.h,v 1.21 2011/10/02 14:53:49 mpeppler Exp $ Copyright (c) 1997 - 2011 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #define NEED_DBIXS_VERSION 93 #define PERL_NO_GET_CONTEXT #include /* installed by the DBI module */ #include "dbivport.h" #include #include /* These defines avoid name clashes for multiple statically linked DBD's */ #define dbd_init syb_init #define dbd_db_login6 syb_db_login #define dbd_db_do syb_db_do #define dbd_db_commit syb_db_commit #define dbd_db_rollback syb_db_rollback #define dbd_db_disconnect syb_db_disconnect #define dbd_discon_all syb_discon_all #define dbd_db_destroy syb_db_destroy #define dbd_db_STORE_attrib syb_db_STORE_attrib #define dbd_db_FETCH_attrib syb_db_FETCH_attrib #define dbd_st_prepare syb_st_prepare #define dbd_st_rows syb_st_rows #define dbd_st_execute syb_st_execute #define dbd_st_fetch syb_st_fetch #define dbd_st_finish syb_st_finish #define dbd_st_destroy syb_st_destroy #define dbd_st_blob_read syb_st_blob_read #define dbd_st_STORE_attrib syb_st_STORE_attrib #define dbd_st_FETCH_attrib syb_st_FETCH_attrib #define dbd_describe syb_describe #define dbd_bind_ph syb_bind_ph /* read in our implementation details */ #include "dbdimp.h" #if defined(CS_CURRENT_VERSION) #define CTLIB_VERSION CS_CURRENT_VERSION #else #if defined(CS_VERSION_157) #define CTLIB_VERSION CS_VERSION_157 #else #if defined(CS_VERSION_155) #define CTLIB_VERSION CS_VERSION_155 #else #if defined(CS_VERSION_150) #define CTLIB_VERSION CS_VERSION_150 #else #if defined(CS_VERSION_125) #define CTLIB_VERSION CS_VERSION_125 #else #if defined(CS_VERSION_120) #define CTLIB_VERSION CS_VERSION_120 #else #if defined(CS_VERSION_110) #define CTLIB_VERSION CS_VERSION_110 #else #define CTLIB_VERSION CS_VERSION_100 #endif #endif #endif #endif #endif #endif #endif #if defined(CS_UNICHAR_TYPE) && defined(CS_VERSION_150) #if defined (is_utf8_string) #define DBD_CAN_HANDLE_UTF8 #endif #endif /*#define CTLIB_VERSION CS_VERSION_100 */ #ifndef MAX #define MAX(X,Y) (((X) > (Y)) ? (X) : (Y)) #endif #ifndef MIN #define MIN(X,Y) (((X) < (Y)) ? (X) : (Y)) #endif #if !defined(Sybase_h) #define Sybase_h 1 void syb_init _((dbistate_t *dbistate)); int syb_discon_all _((SV *drh, imp_drh_t *imp_drh)); int syb_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV *attribs)); int syb_db_do _((SV *sv, char *statement)); int syb_db_commit _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh)); void syb_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)); SV *syb_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)); int syb_st_prepare _((SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs)); int syb_st_rows _((SV *sth, imp_sth_t *imp_sth)); int syb_st_execute _((SV *sth, imp_sth_t *imp_sth)); AV *syb_st_fetch _((SV *sth, imp_sth_t *imp_sth)); int syb_st_finish _((SV *sth, imp_sth_t *imp_sth)); void syb_st_destroy _((SV *sth, imp_sth_t *imp_sth)); int syb_st_blob_read _((SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)); int syb_ct_get_data _((SV *sth, imp_sth_t *imp_sth, int column, SV *bufrv, int buflen)); int syb_ct_data_info _((SV *sth, imp_sth_t *imp_sth, int action, int column, SV *attr)); int syb_ct_send_data _((SV *sth, imp_sth_t *imp_sth, char *buffer, int size)); int syb_ct_prepare_send _((SV *sth, imp_sth_t *)); int syb_ct_finish_send _((SV *sth, imp_sth_t *)); int syb_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)); SV *syb_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv)); int syb_describe _((SV *sth, imp_sth_t *imp_sth)); int syb_bind_ph _((SV *sth, imp_sth_t *imp_sth, SV *param, SV *value, IV sql_type, SV *attribs, int is_inout, IV maxlen)); /* prototypes for module-specific functions */ int syb_thread_enabled _((void)); int syb_set_timeout _((int timeout)); int syb_db_date_fmt _((SV *, imp_dbh_t *, char *)); SV * syb_set_cslib_cb ( SV *cb); #endif /* defined Sybase_h */ /* end of Sybase.h */ DBD-Sybase-1.14/MANIFEST0100644000076500007650000000070211555234074014657 0ustar mpepplermpepplerMANIFEST BUGS CHANGES CONFIG README README.vms README.freetds PWD.factory Sybase.h Sybase.pm Sybase.xs Makefile.PL dbdimp.c dbdimp.h dbd-sybase.pod t/autocommit.t t/base.t t/fail.t t/login.t t/main.t t/multi_sth.t t/place.t t/exec.t t/nsql.t t/thread.t t/utf8.t t/xblob.t t/xblk.t t/screen.jpg t/_test.pm eg/README eg/Show.cgi eg/dbschema.pl eg/check-space.pl dbivport.h META.yml Module meta-data (added by MakeMaker) DBD-Sybase-1.14/eg/0040755000076500007650000000000011642076574014133 5ustar mpepplermpepplerDBD-Sybase-1.14/eg/Show.cgi0100755000076500007650000000611707306712757015546 0ustar mpepplermpeppler#!/usr/local/bin/perl # $Id: Show.cgi,v 1.4 2001/06/04 14:06:39 mpeppler Exp $ # # Show a Sybase stored proc etc, in HTML. # Usage: http://host/cgi-bin/Show.cgi?server=SERVERNAME&database=DATABASE # where SERVERNAME is the server you wish to connect to (eg SYBASE) # and DATABASE is the database in which you wish to view the objects. use strict; use DBI; use CGI; my $query = new CGI; print $query->header; print $query->start_html(-title => "Show a Sybase Object"); my $server = $query->param('server'); my $database = $query->param('database'); my $state = $query->param('__state__') || 0; if(!$database) { error("Please supply the database parameter.

"); } my $dbh = DBI->connect("dbi:Sybase:$server", 'sa', ''); ($dbh->do("use $database") != -2) || error("The database $database deosn't exist"); SWITCH_STATE: while(1) { ($state == 0) && do { my($values, $labels) = getObjects(); print "

Show a Sybase objects definition:

\n"; print "

Please select an object:

\n"; print $query->start_form; print $query->scrolling_list(-name=>'object', '-values'=>$values, -labels=>$labels, -size=>10); $query->param(-name=>'__state__', '-values'=>1); print $query->hidden(-name=>'__state__'); print $query->hidden(-name=>'database'); print $query->hidden(-name=>'server'); print $query->submit; print $query->end_form; last SWITCH_STATE; }; ($state == 1) && do { print "

Show a Sybase object's definition:

\n"; my $objId = $query->param('object'); my $html = getText($objId); print $html; last SWITCH_STATE; }; } print $query->end_html; $dbh->disconnect; exit(0); sub getObjects { my $sth = $dbh->prepare(" select distinct 'obj' = o.name, 'user' = u.name, o.id, o.type from dbo.sysobjects o, dbo.sysusers u, dbo.sysprocedures p where u.uid = o.uid and o.id = p.id and p.status & 4096 != 4096 order by o.name "); $sth->execute; my $dat; my @values; my %labels; my $value; while($dat = $sth->fetchrow_hashref) { $value = "$dat->{id} - $dat->{type}"; push(@values, $value); $labels{$value} = "$dat->{user}.$dat->{obj}"; } $sth->finish; (\@values, \%labels); } sub getText { my $objId = shift; $objId =~ s/[\D\-\s]+$//; my $sth = $dbh->prepare("select text from dbo.syscomments where id = $objId"); $sth->execute; my $html = ''; my $text; while(($text) = $sth->fetchrow) { $html .= $text; } $sth->finish; TsqlToHtml($html); } sub TsqlToHtml { my $html = shift; $html =~ s/\n/
\n/g; $html =~ s/\b(as|begin|between|declare|delete|drop|else|end|exec|exists|go|if|insert|procedure|return|set|update|values|from|select|where|and|or|create|order by)\b/$1<\/b>/ig; $html =~ s/\b(tinyint|smallint|int|char|varchar|datetime|smalldatetime|money|smallmoney|numeric|decimal|text|binary|varbinary|image)\b/$1<\/i>/gi; $html =~ s/\t/\ \ \ \ /g; $html =~ s/ /\ /sg; $html; } sub error { print "

Error!

\n"; print @_; print $query->end_html; exit(0); } DBD-Sybase-1.14/eg/dbschema.pl0100755000076500007650000005240506427411451016234 0ustar mpepplermpeppler#!/usr/local/bin/perl -w # # $Id: dbschema.pl,v 1.1 1997/11/03 18:08:41 mpeppler Exp $ # # dbschema.pl A script to extract a database structure from # a Sybase database # # Written by: Michael Peppler (mpeppler@mbay.net) # Substantially rewritten by David Whitmarsh from a partial # System 10 implementation by Ashu Joglekar # Ported to DBI/DBD::Sybase by Michael Peppler # # Last Mods: 31 October 1997 # # Usage: dbschema.pl -d database -o script.name -t pattern -s server -v # where database is self-explanatory (default: master) # script.name is the output file (default: script.isql) # pattern is the pattern of object names (in sysobjects) # that we will look at (default: %), and server is # the server to connect to (default, the value of $ENV{DSQUERY}). # # -v turns on a verbose switch. # # Changes: 11/18/93 - bpapp - Put in interactive SA password prompt # 11/18/93 - bpapp - Get protection information for views and # stored procedures. # 02/22/94 - mpeppler - Merge bpapp's changes with itf version' # 09/15/94 - mpeppler - Minor changes for use with Sybperl2 # alpha1 # 13/10/95 - Ashu Joglekar - System 10 w/o RI # 11/11/96 - David Whitmarsh - # Use Sybase::DBlib # System 10 declarative RI # constraints # Eliminate key truncation problems # Optional password command line # Debugged and strictified # Some index/key options # 17/2/97 - Michael Peppler # Fixed small ',' problem in printKeys() # 11/3/97 - David Whitmarsh # bug handling user defined types used as # identity columns. # addtype now has scale, prec # removed spurious addtypes for nchar etc. # null/not null/identity on types # 12/3/97 - Michael Peppler # Added -i switch to set an alternate interfaces # file. # # If anyone knows a way to distinguish between key and reference # declarations made at column and table level, let me know. #------------------------------------------------------------------------------ use strict; use DBI; use Getopt::Std; sub getPerms; sub getObj; sub printKeys; sub getComment; sub PrintCols; sub DumpTable; my ($dbh, @dat, $dat, $udflt, $urule, %udflt, %urule, %tables, @tabnames, @col); my $sth; my ($rule, $dflt, $date, $name); select (STDOUT); $| = 1; # make unbuffered getopts ('u:p:d:t:o:s:i:v'); $Getopt::Std::opt_u = `whoami` unless $Getopt::Std::opt_u; $Getopt::Std::opt_d = 'master' unless $Getopt::Std::opt_d; $Getopt::Std::opt_o = 'script.isql' unless $Getopt::Std::opt_o; $Getopt::Std::opt_t = '%' unless $Getopt::Std::opt_t; $Getopt::Std::opt_s = $ENV{DSQUERY} unless $Getopt::Std::opt_s; open(SCRIPT, "> $Getopt::Std::opt_o") || die "Can't open $Getopt::Std::opt_o: $!\n"; open(LOG, "> $Getopt::Std::opt_o.log") || die "Can't open $Getopt::Std::opt_o.log: $!\n"; # # Log us in to Sybase as '$Getopt::Std::opt_u' and prompt for password. # if (!$Getopt::Std::opt_p) { print "\nPassword: "; system("stty -echo"); chop($Getopt::Std::opt_p = <>); system("stty echo"); } my $ifile = ''; if($Getopt::Std::opt_i) { $ifile = "interfaces=$Getopt::Std::opt_i"; } $dbh = DBI->connect("dbi:Sybase:server=$Getopt::Std::opt_s;$ifile", $Getopt::Std::opt_u, $Getopt::Std::opt_p); $dbh->do("use $Getopt::Std::opt_d"); $date = scalar(localtime); print "dbschema.pl on Database $Getopt::Std::opt_d\n"; print LOG "Error log from dbschema.pl on Database $Getopt::Std::opt_d on $date\n\n"; print LOG "The following objects cannot be reliably created from the script in $Getopt::Std::opt_o. Please correct the script to remove any inconsistencies.\n\n"; print SCRIPT "/* This Isql script was generated by dbschema.pl on $date. */\n"; print SCRIPT "\nuse $Getopt::Std::opt_d\ngo\n"; # Change to the appropriate database # first, Add the appropriate user data types: # print "Add user-defined data types..."; print SCRIPT "/* Add user-defined data types: */\n\n"; $sth = $dbh->prepare (< 100 and st.usertype < 100 and st.name not in ('intn', 'nvarchar', 'sysname', 'nchar') SQLEND ); $sth->execute; while((@dat = $sth->fetchrow)) { print SCRIPT "sp_addtype $dat[1], "; ($dat[2] =~ /char\b|binary\b/ and print SCRIPT "'$dat[2]($dat[0])'") or ($dat[2] =~ /\bnumeric\b|\bdecimal\b/ and print SCRIPT "'$dat[2]($dat[5],$dat[6])'") or print SCRIPT "$dat[2]"; (($dat[8] == 1) and print SCRIPT ", 'identity'") or (($dat[7] == 1) and print SCRIPT ", 'null'") or print SCRIPT ", 'not null'"; print SCRIPT "\ngo\n"; # Now remember the default & rule for later. $urule{$dat[1]} = $dat[4] if defined($dat[4]); $udflt{$dat[1]} = $dat[3] if defined($dat[3]); } $sth->finish(); print "Done\n"; print "Create rules..."; print SCRIPT "\n/* Now we add the rules... */\n\n"; getObj('Rule', 'R'); print "Done\n"; print "Create defaults..."; print SCRIPT "\n/* Now we add the defaults... */\n\n"; getObj('Default', 'D'); print "Done\n"; print "Bind rules & defaults to user data types..."; print SCRIPT "/* Bind rules & defaults to user data types... */\n\n"; while(($dat, $dflt)=each(%udflt)) { print SCRIPT "sp_bindefault $dflt, $dat\ngo\n"; } while(($dat, $rule) = each(%urule)) { print SCRIPT "sp_bindrule $rule, $dat\ngo\n"; } print "Done\n"; print "Create Tables & Indices..."; print "\n" if $Getopt::Std::opt_v; # the fourth column set to 'N' becomes the indicator that this table has been # printed $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { $tables{$dat[1] . "." . $dat[0]} = [ @dat ]; @tabnames = ( @tabnames, $dat[1] . "." . $dat[0] ); } $sth->finish; foreach $name (@tabnames) { DumpTable ($tables{$name}, ()); } print "Done\n"; # # The key definitions - sp_primarykey etc, not constraints # Primary keys first, then foreign and common # printKeys (); # # Now create any views that might exist # print "Create views..."; print SCRIPT "\n/* Now we add the views... */\n\n"; getObj('View', 'V'); print "Done\n"; # # Now create any stored procs that might exist # print "Create stored procs..."; print SCRIPT "\n/* Now we add the stored procedures... */\n\n"; getObj('Stored Proc', 'P'); print "Done\n"; # # Now create the triggers # print "Create triggers..."; print SCRIPT "\n/* Now we add the triggers... */\n\n"; getObj('Trigger', 'TR'); print "Done\n"; print "\nLooks like I'm all done!\n"; close(SCRIPT); close(LOG); $dbh->disconnect; sub getPerms { my ($obj) = $_[0]; my ($ret, @dat, $act, $cnt); $sth = $dbh->prepare ("sp_helprotect '$obj'\n"); $sth->execute; $cnt = 0; while(@dat = $sth->fetchrow) { $act = 'to'; $act = 'from' if $dat[0] =~ /Revoke/; print SCRIPT "$dat[2] $dat[3] on $obj $act $dat[1]\n"; ++$cnt; } $sth->finish; $cnt; } sub getObj { my ($objname, $obj) = @_; my (@dat, @items, @vi, $found, $text); $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { push (@items, [ @dat ]); # and save it in a list } $sth->finish; foreach (@items) { @vi = @$_; $found = 0; $sth = $dbh->prepare ("select text from dbo.syscomments where id = $vi[2]"); $sth->execute; print SCRIPT "/* $objname $vi[0], owner $vi[1] */\n"; while(($text) = $sth->fetchrow) { if(!$found && $vi[1] ne 'dbo') { ++$found if($text =~ /$vi[1]/); } print SCRIPT $text; } $sth->finish; print SCRIPT "\ngo\n"; if(!$found && $vi[1] ne 'dbo') { print "**Warning**\n$objname $vi[0] has owner $vi[1]\nbut this is not mentioned in the CREATE PROC statement!!\n"; print LOG "$objname $vi[0] (owner $vi[1])\n"; } if ($obj eq 'V' || $obj eq 'P') { getPerms("$vi[0]") && print SCRIPT "go\n"; } } } sub printKeys { print "Create sp_*key definitions..."; print SCRIPT "\n/* Now create the key definitions ...*/\n\n"; $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { if ($dat[0] eq "primary") { print SCRIPT "sp_primarykey $dat[1],"; PrintCols (@dat[3..10]); print SCRIPT "\ngo\n"; } if ($dat[0] eq "foreign") { print SCRIPT "sp_foreignkey $dat[1], $dat[2],"; PrintCols (@dat[11..18]); print SCRIPT "\ngo\n"; } if ($dat[0] eq "common") { print SCRIPT "sp_commonkey $dat[1], $dat[2],"; PrintCols (@dat[3..10]); print SCRIPT "\ngo\n"; } } $sth->finish; print "done\n" } sub getComment { my ($objid) = @_; my ($line, $text); $sth = $dbh->prepare ( qq(select text from dbo.syscomments where id = $objid)); $sth->execute; $text = ""; while(($line) = $sth->fetchrow) { $text = $text . $line; } $sth->finish; return $text; } sub PrintCols { my ($col, $first); $first = 1; while ($col = shift (@_)) { last if ($col eq '*'); print SCRIPT ", " if !$first; $first = 0; print SCRIPT "$col"; } } # Note: this is a recursive subroutine. # If the current table references another that is in the list of # tables to be dumped, and if that table has not yet been dumped, # then DumpTable is called to dump it before proceeding sub DumpTable { my ($tabref, @referers) = @_; return if @$tabref[3] eq "Y"; my @nul = ('not null','null'); my (@dat, $dat, @col); my (@refcols, @reflist, @field, $rule, $dflt, %rule, %dflt, $ddlrule, $ddldflt); my ($refname, $first, $matchstring, $field, @constrids, $constrid); my ($frgntabref); my ($nultype); # first, get any reference and ensure that dependent tables have already been # created $sth = $dbh->prepare (<execute; while((@refcols = $sth->fetchrow)) { push (@reflist, [ @refcols ]); } $sth->finish; foreach (@reflist) { @refcols = @$_; # if the foreign table is in a foreign database or is not in # our table list, then don't do any more than add it to the list next if $refcols[0] ne $Getopt::Std::opt_d; $refname = $refcols[3] . "." . $refcols[2]; next if not defined ($tables{$refname}); $frgntabref = $tables{$refname}; # otherwise check if it's already been dumped, if so, continue next if @$frgntabref[3] eq "Y"; # make sure we aren't in a refernce loop by checking to see if this table is # already in the heirarchy of refering tables that led to the current invocation grep ($refname, @referers) && print SCRIPT "/* WARNING: circular foreign key reference to $refname */\n" && print LOG "@$tabref[1].@$tabref[0] in circular foreign key reference to $refname\n"; # so dump the referenced tables first DumpTable ($frgntabref, @referers, $refname); } print "Creating table @$tabref[0], owner @$tabref[1]\n" if $Getopt::Std::opt_v; print SCRIPT "/* Start of description of table @$tabref[1].@$tabref[0] */\n\n"; $sth = $dbh->prepare (<execute; undef(%rule); undef(%dflt); print SCRIPT "\n\nCREATE TABLE @$tabref[1].@$tabref[0] (\n"; $first = 1; @col = (); while (@field = $sth->fetchrow) { push @col, [ @field ]; } $sth->finish; foreach (@col) { @field = @$_; print SCRIPT ",\n" if !$first; # add a , and a \n if not first field in table # get the declarative rule and default (if set) if ($field[9] != 0) { $ddldflt = getComment ($field[11]); } else { $ddldflt = ""; } if ($field[10] != 0) { $ddlrule = getComment ($field[12]); } else { $ddlrule = ""; } # Check if its an identity column if ($field[8] == 1) { $nultype = "identity"; } else { $nultype = $nul[$field[5]]; } print SCRIPT "\t$field[0] \t$field[1]"; print SCRIPT "($field[2])" if $field[1] =~ /char|bin/; print SCRIPT "($field[3],$field[4])" if $field[1] =~ /\bnumeric\b|\bdecimal\b/; print SCRIPT " $ddldflt $nultype $ddlrule"; if (defined ($field[7]) && ((!defined ($urule{$field[1]})) || $urule{$field[1]} ne $field[7]) && ($field[10] == 0)) { $rule{"@$tabref[0].$field[0]"} = $field[7]; } if (defined ($field[6]) && ((!defined ($udflt{$field[1]})) || $udflt{$field[1]} ne $field[6]) && ($field[9] == 0)) { $dflt{"@$tabref[0].$field[0]"} = $field[6]; } $first = 0 if $first; } # references foreach (@reflist) { @refcols = @$_; print SCRIPT ","; $refname = $refcols[3] . "." . $refcols[2]; if ($refcols[0] ne $Getopt::Std::opt_d) { print SCRIPT "\n/* The following reference is in database ** $refcols[0], edit the script to create the reference manually "; print LOG "Reference for @$tabref[1].@$tabref[0] in foreign database\n\t"; $refname = $refcols[0] . "." . $refname; } print SCRIPT "\n\t"; $matchstring = substr($refcols[1], 0, 8) . "[_0-9][_0-9]*"; $refcols[1] !~ /$matchstring/ && print SCRIPT "CONSTRAINT $refcols[1] "; print SCRIPT "FOREIGN KEY ("; PrintCols (@refcols[4..19]); print SCRIPT ") REFERENCES $refname ("; PrintCols (@refcols[20..35]); print SCRIPT ")"; if ($refcols[0] ne $Getopt::Std::opt_d) { print SCRIPT "*/"; } } # now get the indexes and keys... # print "Indexes for table @$tabref[1].@$tabref[0]\n" if $Getopt::Std::opt_v; $sth = $dbh->prepare (<execute; @col = (); while((@field = $sth->fetchrow)) { # if this is a key or unique constraint, print out the details # otherwise buffer it up to print as an index afterwards if ($field[3] & 2) { print (SCRIPT ",\n\t"); print SCRIPT "CONSTRAINT $field[0] " unless ($field[3] & 8); if ($field[2] & 2048) { print SCRIPT "PRIMARY KEY "; print SCRIPT "NONCLUSTERED " if ($field[1] != 1); } else { print SCRIPT "UNIQUE "; print SCRIPT "CLUSTERED " if ($field[1] == 1); } print SCRIPT "("; PrintCols (@field[4..19]); print SCRIPT ")"; } else { push @col, [ @field ]; } } $sth->finish; # Now do the table level check constraints @constrids = (); $sth = $dbh->prepare (<execute; while (@field = $sth->fetchrow) { @constrids = (@constrids, $field[0]); } $sth->finish; foreach $constrid (@constrids) { print SCRIPT ",\n\t" . getComment ($constrid); } print SCRIPT "\n)\ngo\n"; # end of CREATE TABLE foreach (@col) { # now print the indexes @field = @$_; print SCRIPT "\nCREATE "; print SCRIPT "UNIQUE " if $field[2] & 2; print SCRIPT "CLUSTERED " if $field[1] == 1; print SCRIPT "INDEX $field[0]\n"; print SCRIPT "ON @$tabref[1].@$tabref[0] ("; PrintCols (@field[4..19]); print SCRIPT ")"; $first = 1; if ($field[2] & 64) { print SCRIPT " WITH ALLOW_DUP_ROW"; $first = 0; } if ($field[2] & 1) { print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_KEY"; $first = 0; } if ($field[2] & 4) { print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_ROW"; $first = 0; } print SCRIPT "\ngo\n"; } getPerms("@$tabref[1].@$tabref[0]") && print SCRIPT "go\n"; print "Bind rules & defaults to columns...\n" if $Getopt::Std::opt_v; print SCRIPT "/* Bind rules & defaults to columns... */\n\n"; if(@$tabref[1] ne 'dbo' && (keys(%dflt) || keys(%rule))) { print SCRIPT "/* The owner of the table is @$tabref[1]. * I can't bind the rules/defaults to a table of which I am not the owner. * The procedures below will have to be run manualy by user @$tabref[1]. */"; print LOG "Defaults/Rules for @$tabref[1].@$tabref[0] could not be bound\n"; } while(($dat, $dflt)=each(%dflt)) { print SCRIPT "/* " if @$tabref[1] ne 'dbo'; print SCRIPT "sp_bindefault $dflt, '$dat'"; if(@$tabref[1] ne 'dbo') { print SCRIPT " */\n"; } else { print SCRIPT "\ngo\n"; } } while(($dat, $rule) = each(%rule)) { print SCRIPT "/* " if @$tabref[1] ne 'dbo'; print SCRIPT "sp_bindrule $rule, '$dat'"; if(@$tabref[1] ne 'dbo') { print SCRIPT " */\n"; } else { print SCRIPT "\ngo\n"; } } print SCRIPT "\n/* End of description of table @$tabref[1].@$tabref[0] */\n"; @$tabref[3] = "Y"; } DBD-Sybase-1.14/eg/check-space.pl0100755000076500007650000000540007405777326016642 0ustar mpepplermpeppler#!/usr/bin/perl -w # # $Id: check-space.pl,v 1.1 2001/12/13 01:05:26 mpeppler Exp $ # # List the spaceusage of a database, and the space usage of each # user table in the DB. use strict; use DBI; use Getopt::Long; my %args; GetOptions(\%args, '-U=s', '-P=s', '-S=s', '-D=s'); my $dbh = DBI->connect("dbi:Sybase:server=$args{S};database=$args{D}", $args{U}, $args{P}); $dbh->{syb_do_proc_status} = 1; my $dbinfo; # First check space in the DB: my $sth = $dbh->prepare("sp_spaceused"); $sth->execute; do { while(my $d = $sth->fetch) { if($d->[0] =~ /$args{D}/) { $d->[1] =~ s/[^\d.]//g; $dbinfo->{size} = $d->[1]; } else { foreach (@$d) { s/\D//g; } $dbinfo->{reserved} = $d->[0] / 1024; $dbinfo->{data} = $d->[1] / 1024; $dbinfo->{index} = $d->[2] / 1024; } # print "@$d\n"; } } while($sth->{syb_more_results}); # Get the actual device usage from sp_helpdb to get the free log space $sth = $dbh->prepare("sp_helpdb $args{D}"); $sth->execute; do { while(my $d = $sth->fetch) { #print "@$d\n"; if($d->[2] && $d->[2] =~ /log only/) { $d->[1] =~ s/[^\d\.]//g; $dbinfo->{log} += $d->[1]; } if($d->[0] =~ /log only .* (\d+)/) { $dbinfo->{logfree} = $1 / 1024; } } } while($sth->{syb_more_results}); $dbinfo->{size} -= $dbinfo->{log}; #if(($dbinfo->{reserved} / $dbinfo->{size}) > 0.75) { # warn "WARNING: smlive free space is below 25%\n"; #} my $freepct = ($dbinfo->{size} - $dbinfo->{reserved}) / $dbinfo->{size}; print "$args{S}/$args{D} spaceusage report\n\n"; printf "Database size: %10.2f MB\n", $dbinfo->{size}; printf "Log size: %10.2f MB\n", $dbinfo->{log}; printf "Free Log: %10.2f MB\n", $dbinfo->{logfree}; printf "Reserved: %10.2f MB\n", $dbinfo->{reserved}; printf "Data: %10.2f MB\n", $dbinfo->{data}; printf "Indexes: %10.2f MB\n", $dbinfo->{index}; printf "Free space: %10.2f %%\n", $freepct * 100; if($freepct < .25) { printf "**WARNING**: Free space is below 25%% (%.2f%%)\n\n", $freepct * 100; } print "\nTable information (in MB):\n\n"; printf "%15s %15s %10s %10s %10s\n\n", "Table", "Rows", "Reserved", "Data", "Indexes"; my @tables = getTables($dbh); foreach (@tables) { my $sth = $dbh->prepare("sp_spaceused $_"); $sth->execute; do { while(my $d = $sth->fetch) { foreach (@$d) { s/KB//; s/\s//g; } printf("%15.15s %15d %10.2f %10.2f %10.2f\n", $d->[0], $d->[1], $d->[2] / 1024, $d->[3] / 1024, $d->[4] / 1024); # print "@$d\n"; } } while($sth->{syb_more_results}); } sub getTables { my $dbh = shift; my $sth = $dbh->table_info; my @tables; do { while(my $d = $sth->fetch) { push(@tables, $d->[2]) unless $d->[3] =~ /SYSTEM|VIEW/; } } while($sth->{syb_more_results}); @tables; } DBD-Sybase-1.14/eg/README0100644000076500007650000000053007251035241014771 0ustar mpepplermpeppler$Id: README,v 1.1 2001/03/06 01:17:21 mpeppler Exp $ The files in this directory are *examples*. In particular, dbschema.pl is a quick port I did from the dbschema.pl version using Sybase::DBlib, and has not been updated with recent enhancements and bug fixes to dbschema.pl (now maintained by David Owen, http://www.midsomer.org). Michael DBD-Sybase-1.14/dbdimp.c0100644000076500007650000047716111642075621015150 0ustar mpepplermpeppler/* $Id: dbdimp.c,v 1.113 2011/10/02 14:54:07 mpeppler Exp $ Copyright (c) 1997-2011 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Based on DBD::Oracle dbdimp.c, Copyright (c) 1994,1995 Tim Bunce */ #include "Sybase.h" /* Defines needed for perl 5.005 / threading */ #if defined(op) #undef op #endif #if !defined(PATCHLEVEL) #include "patchlevel.h" /* this is the perl patchlevel.h */ #endif #if PATCHLEVEL < 5 && SUBVERSION < 5 #define PL_na na #define PL_sv_undef sv_undef #define PL_dirty dirty #endif #ifndef PerlIO # define PerlIO FILE # define PerlIO_printf fprintf # define PerlIO_stderr() stderr # define PerlIO_close(f) fclose(f) # define PerlIO_open(f,m) fopen(f,m) # define PerlIO_flush(f) fflush(f) # define PerlIO_puts(f,s) fputs(s,f) #endif /* Requested by Alex Fridman */ #ifdef WIN32 # define strncasecmp _strnicmp #endif /*#define NO_CHAINED_TRAN 1*/ #if !defined(NO_CHAINED_TRAN) #define NO_CHAINED_TRAN 0 #endif /* some systems have trouble with ct_cancel(). If FLUSH_FINISH is 1 then the default behavior is to fetch all results from the server when $sth->finish() is called instead of the normal ct_cancel(CS_CANCEL_ALL) call. */ #if !defined(FLUSH_FINISH) #define FLUSH_FINISH 0 #endif #if !defined(PROC_STATUS) #define PROC_STATUS 0 #endif /* * In DBD::Sybase 1.09 and before, certain large numeric types (money, bigint) * were being kept in native format, and then returned to the caller as a perl NV * data item. An NV is really a float, so there was loss of precision, especially for bigint * data which is a 64bit int. * In 1.10 these datatypes behave the same way as numeric/decimal - converted to a char string * and returned that way to the caller, who can then use Math::BigInt, etc. * If you want to revert to the previous behavior, you need to define SYB_NATIVE_NUM. * * #define SYB_NATIVE_NUM */ /* FreeTDS doesn't always define these symbols */ #if defined(CS_VERSION_110) #if !defined BLK_VERSION_110 #define BLK_VERSION_110 BLK_VERSION_100 #endif #endif #if defined(CS_VERSION_120) #if !defined BLK_VERSION_120 #define BLK_VERSION_120 BLK_VERSION_110 #endif #endif #if defined(CS_VERSION_125) #if !defined BLK_VERSION_125 #define BLK_VERSION_125 BLK_VERSION_120 #endif #endif #if defined(CS_VERSION_150) #if !defined BLK_VERSION_150 #define BLK_VERSION_150 BLK_VERSION_125 #endif #endif #if defined(CS_VERSION_155) #if !defined BLK_VERSION_155 #define BLK_VERSION_155 BLK_VERSION_150 #endif #endif #if defined(CS_VERSION_157) #if !defined BLK_VERSION_157 #define BLK_VERSION_157 BLK_VERSION_155 #endif #endif #if !defined(CS_LONGCHAR_TYPE) #define CS_LONGCHAR_TYPE CS_CHAR_TYPE #endif DBISTATE_DECLARE; static void cleanUp _((imp_sth_t *)); static char *GetAggOp _((CS_INT)); static CS_INT get_cwidth _((CS_DATAFMT *)); static CS_INT display_dlen _((CS_DATAFMT *)); static CS_RETCODE display_header _((imp_dbh_t *, CS_INT, CS_DATAFMT*)); static CS_RETCODE describe _((SV *sth, imp_sth_t *, int)); static CS_RETCODE fetch_data _((imp_dbh_t *, CS_COMMAND*)); static CS_RETCODE CS_PUBLIC clientmsg_cb _((CS_CONTEXT*, CS_CONNECTION*, CS_CLIENTMSG*)); static CS_RETCODE CS_PUBLIC servermsg_cb _((CS_CONTEXT*, CS_CONNECTION*, CS_SERVERMSG*)); static CS_RETCODE CS_PUBLIC cslibmsg_cb(CS_CONTEXT *context, CS_CLIENTMSG *errmsg); static CS_COMMAND *syb_alloc_cmd _((imp_dbh_t *, CS_CONNECTION*)); static void dealloc_dynamic _((imp_sth_t *)); static int map_syb_types _((int)); static int map_sql_types _((int)); static CS_CONNECTION *syb_db_connect _((struct imp_dbh_st *)); static int syb_db_use _((imp_dbh_t *, CS_CONNECTION *)); static int syb_st_describe_proc _((imp_sth_t *, char *)); static void syb_set_error(imp_dbh_t *, int, char *); static char *my_strdup _((char *)); static void fetchKerbTicket(imp_dbh_t *imp_dbh); static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth); static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh); static int getTableName(char *statement, char *table, int maxwidth); static int toggle_autocommit(SV *dbh, imp_dbh_t *imp_dbh, int flag); static int datetime2str(CS_DATETIME *dt, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); #if defined(CS_DATE_TYPE) static int date2str(CS_DATE *dt, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); static int time2str(CS_TIME *dt, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); #endif static int syb_get_date_fmt(imp_dbh_t *imp_dbh, char *fmt); static int cmd_execute(SV *sth, imp_sth_t *imp_sth); #if defined(DBD_CAN_HANDLE_UTF8) static int is_high_bit_set(const unsigned char *val, STRLEN size); #endif static CS_BINARY *to_binary(char *str, STRLEN *outlen); static int get_server_version(SV *dbh, imp_dbh_t *imp_dbh, CS_CONNECTION *con); static void clear_cache(SV *sth, imp_sth_t *imp_sth); static int _dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int maxlen); static CS_INT BLK_VERSION; #if PERL_VERSION >= 8 && defined(_REENTRANT) static perl_mutex context_alloc_mutex[1]; #endif /*#define USE_CSLIB_CB 1 */ static CS_CONTEXT *context; static CS_LOCALE *locale; static char scriptName[255]; static char hostname[255]; static char *ocVersion; #define LOCALE(s) ((s)->locale ? (s)->locale : locale) static SV *cslib_cb; static int syb_set_options(imp_dbh_t *imp_dbh, CS_INT action, CS_INT option, CS_VOID *value, CS_INT len, CS_INT *outlen) { if (DBIc_DBISTATE(imp_dbh)->debug >= 5) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_set_options: optSupported = %d\n", imp_dbh->optSupported); if (!imp_dbh->optSupported) return CS_FAIL; return ct_options(imp_dbh->connection, action, option, value, len, outlen); } static void syb_set_error(imp_dbh_t *imp_dbh, int err, char *errstr) { dTHX; sv_setiv(DBIc_ERR(imp_dbh), err); if (SvOK(DBIc_ERRSTR(imp_dbh))) sv_catpv(DBIc_ERRSTR(imp_dbh), errstr); else sv_setpv(DBIc_ERRSTR(imp_dbh), errstr); } static CS_RETCODE CS_PUBLIC cslibmsg_cb(CS_CONTEXT *context, CS_CLIENTMSG *errmsg) { dTHX; #if 0 if(DBIS->debug >= 4) { PerlIO_printf(DBILOGFP, " cslibmsg_cb -> %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(DBILOGFP, " cslibmsg_cb -> %s\n", errmsg->osstring); } } #endif if (cslib_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_LAYER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_ORIGIN(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSVpv(errmsg->msgstring, 0))); if (errmsg->osstringlen > 0) XPUSHs(sv_2mortal(newSVpv(errmsg->osstring, 0))); else XPUSHs(&PL_sv_undef); PUTBACK; if ((count = perl_call_sv(cslib_cb, G_SCALAR)) != 1) croak("A cslib handler cannot return a LIST"); SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; return retval; } PerlIO_printf(PerlIO_stderr(), "\nCS Library Message:\n"); PerlIO_printf(PerlIO_stderr(), "Message number: LAYER = (%ld) ORIGIN = (%ld) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "SEVERITY = (%ld) NUMBER = (%ld)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "Message String: %s\n", errmsg->msgstring); if (errmsg->osstringlen > 0) { PerlIO_printf(PerlIO_stderr(), "Operating System Error: %s\n", errmsg->osstring); } return CS_SUCCEED; } static CS_RETCODE CS_PUBLIC clientmsg_cb(CS_CONTEXT *context, CS_CONNECTION *connection, CS_CLIENTMSG *errmsg) { dTHX; imp_dbh_t *imp_dbh = NULL; char buff[255]; if (connection) { if ((ct_con_props(connection, CS_GET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) croak("Panic: clientmsg_cb: Can't find handle from connection"); if(DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clientmsg_cb -> %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clientmsg_cb -> %s\n", errmsg->osstring); } } /* if LongTruncOK is set then ignore this error. */ if(DBIc_is(imp_dbh, DBIcf_LongTruncOk) && CS_NUMBER(errmsg->msgnumber) == 132) return CS_SUCCEED; if(imp_dbh->err_handler) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(0))); XPUSHs(sv_2mortal(newSViv(0))); XPUSHs(&PL_sv_undef); XPUSHs(&PL_sv_undef); XPUSHs(sv_2mortal(newSVpv(errmsg->msgstring, 0))); if(imp_dbh->sql) XPUSHs(sv_2mortal(newSVpv(imp_dbh->sql, 0))); else XPUSHs(&PL_sv_undef); XPUSHs(sv_2mortal(newSVpv("client", 0))); PUTBACK; if((count = perl_call_sv(imp_dbh->err_handler, G_SCALAR | G_EVAL)) != 1) croak("An error handler can't return a LIST."); SPAGAIN; if(SvTRUE(ERRSV)) { POPs; retval = 1; } else { retval = POPi; } PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then ignore this error */ if(retval == 0) return CS_SUCCEED; } sv_setiv(DBIc_ERR(imp_dbh), (IV)CS_NUMBER(errmsg->msgnumber)); if(SvOK(DBIc_ERRSTR(imp_dbh))) sv_catpv(DBIc_ERRSTR(imp_dbh), "OpenClient message: "); else sv_setpv(DBIc_ERRSTR(imp_dbh), "OpenClient message: "); sprintf(buff, "LAYER = (%ld) ORIGIN = (%ld) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "SEVERITY = (%ld) NUMBER = (%ld)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "Server %s, database %s\n", imp_dbh->server, imp_dbh->curr_db); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sv_catpv(DBIc_ERRSTR(imp_dbh), "Message String: "); sv_catpv(DBIc_ERRSTR(imp_dbh), errmsg->msgstring); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); if (errmsg->osstringlen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), "Operating System Error: "); sv_catpv(DBIc_ERRSTR(imp_dbh), errmsg->osstring); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); } if(CS_NUMBER(errmsg->msgnumber) == 6) { /* disconnect */ imp_dbh->isDead = 1; } /* If this is a timeout message, cancel the current request. If the cancel fails, then return CS_FAIL, and mark the connection dead. Do NOT return CS_FAIL in all cases, as this makes the connection unusable, and that may not be the correct behavior in all situations. */ if (CS_SEVERITY(errmsg->msgnumber) == CS_SV_RETRY_FAIL && CS_NUMBER(errmsg->msgnumber) == 63 && CS_ORIGIN(errmsg->msgnumber) == 2 && CS_LAYER(errmsg->msgnumber) == 1) { CS_INT status; status = 0; if (ct_con_props(connection, CS_GET, CS_LOGIN_STATUS, (CS_VOID *)&status, CS_UNUSED, NULL) != CS_SUCCEED) { imp_dbh->isDead = 1; return CS_FAIL; } if (!status) { /* We're not logged in, so just return CS_FAIL to abort the login request */ imp_dbh->isDead = 1; return CS_FAIL; } if(ct_cancel(connection, NULL, CS_CANCEL_ATTN) == CS_FAIL) { imp_dbh->isDead = 1; return CS_FAIL; } return CS_SUCCEED; } } else { /* !connection */ PerlIO_printf(PerlIO_stderr(), "OpenClient message: "); PerlIO_printf(PerlIO_stderr(), "LAYER = (%ld) ORIGIN = (%ld) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "SEVERITY = (%ld) NUMBER = (%ld)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "Message String: %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(PerlIO_stderr(), "Operating System Error: %s\n", errmsg->osstring); } } return CS_SUCCEED; } static CS_RETCODE CS_PUBLIC servermsg_cb(CS_CONTEXT *context, CS_CONNECTION *connection, CS_SERVERMSG *srvmsg) { CS_COMMAND *cmd; CS_RETCODE retcode; imp_dbh_t *imp_dbh = NULL; char buff[1024]; dTHX; /* add check on connection not being NULL (PR/477) just to be on the safe side - freetds can call the server callback with a NULL connection */ if (connection && (ct_con_props(connection, CS_GET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) croak("Panic: servermsg_cb: Can't find handle from connection"); if(imp_dbh && DBIc_DBISTATE(imp_dbh)->debug >= 4) { if(srvmsg->msgnumber) { PerlIO_printf(DBIc_LOGPIO(imp_dbh)," servermsg_cb -> number=%ld severity=%ld ", srvmsg->msgnumber, srvmsg->severity); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "state=%ld line=%ld ", srvmsg->state, srvmsg->line); if (srvmsg->svrnlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "server=%s ", srvmsg->svrname); } if (srvmsg->proclen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "procedure=%s ", srvmsg->proc); } PerlIO_printf(DBIc_LOGPIO(imp_dbh), "text=%s\n", srvmsg->text); } else { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " servermsg_cb -> %s\n", srvmsg->text); } } /* Track the "current" database */ /* Borrowed from sqsh's cmd_connect.c */ if(srvmsg->msgnumber == 5701 || srvmsg->msgnumber == 5703 || srvmsg->msgnumber == 5704) { char *c; int i; if(srvmsg->text != NULL && (c = strchr( srvmsg->text, '\'' )) != NULL) { i = 0; for( ++c; i <= 30 && *c != '\0' && *c != '\''; ++c ) buff[i++] = *c; buff[i] = '\0'; /* * On some systems, if the charset is mis-configured in the * SQL Server, it will come back as the string "". If * this is the case, then we want to ignore this value. */ if (strcmp( buff, "" ) != 0) { switch (srvmsg->msgnumber) { case 5701: if(imp_dbh && DBIc_ACTIVE(imp_dbh) && imp_dbh->connection == connection) { strcpy(imp_dbh->curr_db, buff); } break; case 5703: /* Language */ break; case 5704: /* charset */ break; default: break; } } } return CS_SUCCEED; } /* Trap msg 17001 (No SRV_OPTION handler installed.) */ if(imp_dbh && srvmsg->msgnumber == 17001) { imp_dbh->optSupported = 0; if(DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " servermsg_cb() -> ct_option is %ssupported\n", imp_dbh->optSupported == 1 ?"":"not "); } } if(imp_dbh && imp_dbh->err_handler) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(srvmsg->msgnumber))); XPUSHs(sv_2mortal(newSViv(srvmsg->severity))); XPUSHs(sv_2mortal(newSViv(srvmsg->state))); XPUSHs(sv_2mortal(newSViv(srvmsg->line))); if(srvmsg->svrnlen> 0) XPUSHs(sv_2mortal(newSVpv(srvmsg->svrname, 0))); else XPUSHs(&PL_sv_undef); if(srvmsg->proclen> 0) XPUSHs(sv_2mortal(newSVpv(srvmsg->proc, 0))); else XPUSHs(&PL_sv_undef); XPUSHs(sv_2mortal(newSVpv(srvmsg->text, 0))); if(imp_dbh->sql) XPUSHs(sv_2mortal(newSVpv(imp_dbh->sql, 0))); else XPUSHs(&PL_sv_undef); XPUSHs(sv_2mortal(newSVpv("server", 0))); PUTBACK; if((count = perl_call_sv(imp_dbh->err_handler, G_SCALAR | G_EVAL)) != 1) croak("An error handler can't return a LIST."); SPAGAIN; if(SvTRUE(ERRSV)) { POPs; retval = 1; } else { retval = POPi; } PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then ignore this error */ if(retval == 0) return CS_SUCCEED; } if(imp_dbh && srvmsg->msgnumber) { /* error 5702 (severity=10 state=1 text=ASE is terminating this process) * may be delivered only via servermsg_cb. If we don't deal with it here * the command can appear to complete successfully. errstr will contain * the error message but err will be false. */ if(srvmsg->severity> 10 || srvmsg->msgnumber == 5702) { sv_setiv(DBIc_ERR(imp_dbh), (IV)srvmsg->msgnumber); imp_dbh->lasterr = srvmsg->msgnumber; imp_dbh->lastsev = srvmsg->severity; if (srvmsg->msgnumber == 5702) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } } if(SvOK(DBIc_ERRSTR(imp_dbh))) sv_catpv(DBIc_ERRSTR(imp_dbh), "Server message "); else sv_setpv(DBIc_ERRSTR(imp_dbh), "Server message "); sprintf(buff, "number=%ld severity=%ld ", srvmsg->msgnumber, srvmsg->severity); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "state=%ld line=%ld", srvmsg->state, srvmsg->line); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); if (srvmsg->svrnlen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), " server="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->svrname); } if (srvmsg->proclen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), " procedure="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->proc); } sv_catpv(DBIc_ERRSTR(imp_dbh), " text="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->text); if(imp_dbh->showSql) { sv_catpv(DBIc_ERRSTR(imp_dbh), " Statement="); sv_catpv(DBIc_ERRSTR(imp_dbh), imp_dbh->sql); } if (imp_dbh->showEed && srvmsg->status & CS_HASEED) { sv_catpv(DBIc_ERRSTR(imp_dbh), "\n[Start Extended Error]\n"); if (ct_con_props(connection, CS_GET, CS_EED_CMD, &cmd, CS_UNUSED, NULL) != CS_SUCCEED) { warn("servermsg_cb: ct_con_props(CS_EED_CMD) failed"); return CS_FAIL; } retcode = fetch_data(imp_dbh, cmd); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n[End Extended Error]\n"); } else retcode = CS_SUCCEED; sv_catpv(DBIc_ERRSTR(imp_dbh), " "); return retcode; } else { if(srvmsg->msgnumber) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Server message: number=%ld severity=%ld ", srvmsg->msgnumber, srvmsg->severity); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "state=%ld line=%ld ", srvmsg->state, srvmsg->line); if (srvmsg->svrnlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "server=%s ", srvmsg->svrname); } if (srvmsg->proclen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "procedure=%s ", srvmsg->proc); } PerlIO_printf(DBIc_LOGPIO(imp_dbh), "text=%s\n", srvmsg->text); } else { warn("%s\n", srvmsg->text); } PerlIO_flush(DBIc_LOGPIO(imp_dbh)); } return CS_SUCCEED; } static CS_CHAR * GetAggOp(CS_INT op) { CS_CHAR *name; switch ((int) op) { case CS_OP_SUM: name = "sum"; break; case CS_OP_AVG: name = "avg"; break; case CS_OP_COUNT: name = "count"; break; case CS_OP_MIN: name = "min"; break; case CS_OP_MAX: name = "max"; break; default: name = "unknown"; break; } return name; } static CS_INT get_cwidth(CS_DATAFMT *column) { CS_INT len; switch ((int) column->datatype) { case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: len = column->maxlength; break; case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: case CS_LONGBINARY_TYPE: //#if defined(CS_UNICHAR_TYPE) // case CS_UNICHAR_TYPE: // case CS_UNITEXT_TYPE: //#endif len = (2 * column->maxlength) + 2; break; case CS_BIT_TYPE: case CS_TINYINT_TYPE: len = 3; break; case CS_SMALLINT_TYPE: #if defined(CS_USMALLINT_TYPE) case CS_USMALLINT_TYPE: #endif len = 6; break; case CS_INT_TYPE: #if defined(CS_UINT_TYPE) case CS_UINT_TYPE: #endif len = 11; break; #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: case CS_UBIGINT_TYPE: len = 22; #endif case CS_REAL_TYPE: case CS_FLOAT_TYPE: len = 20; break; case CS_MONEY_TYPE: case CS_MONEY4_TYPE: len = 24; break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: case CS_TIME_TYPE: #endif #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: case CS_BIGTIME_TYPE: #endif len = 40; break; #ifdef CS_UNIQUE_TYPE case CS_UNIQUE_TYPE: len = 40; break; #endif default: len = column->maxlength; break; } return len; } static CS_INT display_dlen(CS_DATAFMT *column) { CS_INT len; len = get_cwidth(column); switch ((int) column->datatype) { case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: len = MIN(len, MAX_CHAR_BUF); break; default: break; } return MAX(strlen(column->name) + 1, len); } static CS_RETCODE display_header(imp_dbh_t *imp_dbh, CS_INT numcols, CS_DATAFMT *columns) { dTHX; CS_INT i; CS_INT l; CS_INT j; CS_INT disp_len; sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); for (i = 0; i < numcols; i++) { disp_len = display_dlen(&columns[i]); sv_catpv(DBIc_ERRSTR(imp_dbh), columns[i].name); l = disp_len - strlen(columns[i].name); for (j = 0; j < l; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); for (i = 0; i < numcols; i++) { disp_len = display_dlen(&columns[i]); l = disp_len - 1; for (j = 0; j < l; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), "-"); } sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); return CS_SUCCEED; } void syb_init(dbistate_t *dbistate) { dTHX; SV *sv; CS_INT netio_type = CS_SYNC_IO; STRLEN lna; CS_INT outlen; CS_RETCODE retcode = CS_FAIL; CS_INT cs_ver; CS_INT boolean = CS_FALSE; DBIS = dbistate; #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_INIT (context_alloc_mutex); #endif #if 0 /* Do signal handling stuff... */ /* Set up signal set with just SIGUSR1. */ sigemptyset(&set); sigaddset(&set, SIGINT); /* Block SIGINT */ sigprocmask(SIG_BLOCK, &set, NULL); #endif #if defined(CS_CURRENT_VERSION) if (retcode != CS_SUCCEED) { cs_ver = CS_CURRENT_VERSION; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_150) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_150; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_125) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_125; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_120) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_120; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_110) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_110; retcode = cs_ctx_alloc(cs_ver, &context); } #endif if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_100; retcode = cs_ctx_alloc(cs_ver, &context); } if (retcode != CS_SUCCEED) croak("DBD::Sybase initialize: cs_ctx_alloc(%d) failed", cs_ver); #if defined(CS_CURRENT_VERSION) if (cs_ver = CS_CURRENT_VERSION) BLK_VERSION = CS_CURRENT_VERSION; #endif #if defined(CS_VERSION_150) if (cs_ver == CS_VERSION_150) BLK_VERSION = BLK_VERSION_150; #endif #if defined(CS_VERSION_125) if (cs_ver == CS_VERSION_125) BLK_VERSION = BLK_VERSION_125; #endif #if defined(CS_VERSION_120) if (cs_ver == CS_VERSION_120) BLK_VERSION = BLK_VERSION_120; #endif #if defined(CS_VERSION_110) if (cs_ver == CS_VERSION_110) BLK_VERSION = BLK_VERSION_110; #endif if (cs_ver == CS_VERSION_100) BLK_VERSION = BLK_VERSION_100; #if USE_CSLIB_CB if (cs_config(context, CS_SET, CS_MESSAGE_CB, (CS_VOID *)cslibmsg_cb, CS_UNUSED, NULL) != CS_SUCCEED) { /* Release the context structure. */ (void)cs_ctx_drop(context); croak("DBD::Sybase initialize: cs_config(CS_MESSAGE_CB) failed"); } #else if (cs_diag(context, CS_INIT, CS_UNUSED, CS_UNUSED, NULL) != CS_SUCCEED) warn("cs_diag(CS_INIT) failed"); #endif #if defined(CS_EXTERNAL_CONFIG) if (cs_config(context, CS_SET, CS_EXTERNAL_CONFIG, &boolean, CS_UNUSED, NULL) != CS_SUCCEED) { /* Ignore this error... */ /* warn("Can't set CS_EXTERNAL_CONFIG to false"); */ } #endif if ((retcode = ct_init(context, cs_ver)) != CS_SUCCEED) { #if 1 cs_ctx_drop(context); #endif context = NULL; croak("DBD::Sybase initialize: ct_init(%d) failed", cs_ver); } if ((retcode = ct_callback(context, NULL, CS_SET, CS_CLIENTMSG_CB, (CS_VOID *) clientmsg_cb)) != CS_SUCCEED) croak("DBD::Sybase initialize: ct_callback(clientmsg) failed"); if ((retcode = ct_callback(context, NULL, CS_SET, CS_SERVERMSG_CB, (CS_VOID *) servermsg_cb)) != CS_SUCCEED) croak("DBD::Sybase initialize: ct_callback(servermsg) failed"); if ((retcode = ct_config(context, CS_SET, CS_NETIO, &netio_type, CS_UNUSED, NULL)) != CS_SUCCEED) croak("DBD::Sybase initialize: ct_config(netio) failed"); #if defined(MAX_CONNECT) netio_type = MAX_CONNECT; if((retcode = ct_config(context, CS_SET, CS_MAX_CONNECT, &netio_type, CS_UNUSED, NULL)) != CS_SUCCEED) croak("DBD::Sybase initialize: ct_config(max_connect) failed"); #endif { char out[1024], *p; retcode = ct_config(context, CS_GET, CS_VER_STRING, (CS_VOID*) out, 1024, &outlen); if ((p = strchr(out, '\n'))) *p = 0; ocVersion = my_strdup(out); } if ((sv = perl_get_sv("0", FALSE))) { char *p; strcpy(scriptName, SvPV(sv, lna)); if ((p = strrchr(scriptName, '/'))) { char tmp[255]; ++p; strncpy(tmp, p, 250); strcpy(scriptName, tmp); } /* PR 506 */ if (!strcmp(scriptName, "-e")) { strcpy(scriptName, "perl -e"); } } /* PR 506 - get hostname */ if ((sv = perl_get_sv("DBD::Sybase::hostname", FALSE))) { strcpy(hostname, SvPV(sv, lna)); /*fprintf(stderr, "Got hostname: %s\n", hostname);*/ } if (dbistate->debug >= 3) { char *p = ""; if ((sv = perl_get_sv("DBD::Sybase::VERSION", FALSE))) p = SvPV(sv, lna); PerlIO_printf(dbistate->logfp, " syb_init() -> DBD::Sybase %s initialized\n", p); PerlIO_printf(dbistate->logfp, " OpenClient version: %s\n", ocVersion); } if ((retcode = cs_loc_alloc(context, &locale)) != CS_SUCCEED) { warn("cs_loc_alloc failed"); } if (retcode == CS_SUCCEED) { if ((retcode = cs_locale(context, CS_SET, locale, CS_LC_ALL, (CS_CHAR*) NULL, CS_UNUSED, (CS_INT*) NULL)) != CS_SUCCEED) { warn("cs_locale(CS_LC_ALL) failed"); } } /* Set default charset to utf8. The charset can still be overridden * via the charset=xxxx connection attribute. */ /* if (retcode == CS_SUCCEED) { if ((retcode = cs_locale(context, CS_SET, locale, CS_SYB_CHARSET, "utf8", CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("cs_locale(CS_SYB_CHARSET) failed"); } }*/ if (retcode == CS_SUCCEED) { CS_INT type = CS_DATES_SHORT; if ((retcode = cs_dt_info(context, CS_SET, locale, CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL)) != CS_SUCCEED) warn("cs_dt_info() failed"); } if (retcode == CS_SUCCEED) { if ((retcode = cs_config(context, CS_SET, CS_LOC_PROP, locale, CS_UNUSED, NULL)) != CS_SUCCEED) { /* warn("cs_config(CS_LOC_PROP) failed"); */ } } } int syb_thread_enabled(void) { int retcode = 0; #if PERL_VERSION >= 8 && defined(_REENTRANT) && !defined(NO_THREADS) retcode = 1; #endif return retcode; } int syb_set_timeout(int timeout) { dTHX; CS_RETCODE retcode; if (timeout <= 0) timeout = CS_NO_LIMIT; /* set negative or 0 length timeout to default no limit */ /* XXX: DBIS and DBILOGFP need to be fixed */ if (DBIS->debug >= 3) PerlIO_printf(DBILOGFP, " syb_set_timeout() -> ct_config(CS_TIMEOUT,%d)\n", timeout); #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK (context_alloc_mutex); #endif if ((retcode = ct_config(context, CS_SET, CS_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) warn("ct_config(CS_SET, CS_TIMEOUT) failed"); #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK (context_alloc_mutex); #endif return retcode; } static int extractFromDsn(char *tag, char *source, char *dest, int size) { char *p = strstr(source, tag); char *q = dest; if (!p) return 0; p += strlen(tag); while (p && *p && *p != ';' && --size) *q++ = *p++; *q = 0; return 1; } static int fetchAttrib(SV *attribs, char *key) { dTHX; if (attribs) { SV **svp; if ((svp = hv_fetch((HV*) SvRV(attribs), key, strlen(key), 0)) != NULL) { return SvIV(*svp); } } return 0; } static SV * fetchSvAttrib(SV *attribs, char *key) { dTHX; if (attribs) { SV **svp; if ((svp = hv_fetch((HV*) SvRV(attribs), key, strlen(key), 0)) != NULL) { return newSVsv(*svp); } } return NULL; } /* side-effect: sets the BCP related flags in imp_sth */ static void getBcpAttribs(imp_sth_t *imp_sth, SV *attribs) { dTHX; SV **svp; #define BCP_ATTRIB "syb_bcp_attribs" if (!attribs || !SvOK(attribs)) { return; } if ((svp = hv_fetch((HV*) SvRV(attribs), BCP_ATTRIB, strlen(BCP_ATTRIB), 0)) != NULL) { imp_sth->bcpFlag = 1; imp_sth->bcpIdentityFlag = fetchAttrib(*svp, "identity_flag"); imp_sth->bcpIdentityCol = fetchAttrib(*svp, "identity_column"); } } int syb_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dsn, char *uid, char *pwd, SV *attribs) { dTHX; int retval; imp_dbh->server[0] = 0; imp_dbh->charset[0] = 0; imp_dbh->packetSize[0] = 0; imp_dbh->language[0] = 0; imp_dbh->ifile[0] = 0; imp_dbh->loginTimeout[0] = 0; imp_dbh->timeout[0] = 0; imp_dbh->hostname[0] = 0; imp_dbh->scriptName[0] = 0; imp_dbh->database[0] = 0; imp_dbh->curr_db[0] = 0; imp_dbh->encryptPassword[0] = 0; imp_dbh->showSql = 0; imp_dbh->showEed = 0; imp_dbh->flushFinish = FLUSH_FINISH; imp_dbh->doRealTran = NO_CHAINED_TRAN; /* default to use chained transaction mode */ imp_dbh->chainedSupported = 1; imp_dbh->quotedIdentifier = 0; imp_dbh->rowcount = 0; imp_dbh->doProcStatus = PROC_STATUS; imp_dbh->useBin0x = 0; imp_dbh->binaryImage = 0; imp_dbh->deadlockRetry = 0; imp_dbh->deadlockSleep = 0; imp_dbh->deadlockVerbose = 0; imp_dbh->nsqlNoStatus = 0; imp_dbh->noChildCon = 0; imp_dbh->failedDbUseFatal = fetchAttrib(attribs, "syb_failed_db_fatal"); imp_dbh->bindEmptyStringNull = fetchAttrib(attribs, "syb_bind_empty_string_as_null"); imp_dbh->err_handler = fetchSvAttrib(attribs, "syb_err_handler"); imp_dbh->alwaysForceFailure = 1; imp_dbh->kerberosPrincipal[0] = 0; imp_dbh->kerbGetTicket = fetchSvAttrib(attribs, "syb_kerberos_serverprincipal"); imp_dbh->disconnectInChild = fetchAttrib(attribs, "syb_disconnect_in_child"); imp_dbh->host[0] = 0; imp_dbh->port[0] = 0; imp_dbh->enable_utf8 = fetchAttrib(attribs, "syb_enable_utf8"); #if !defined(DBD_CAN_HANDLE_UTF8) if (imp_dbh->enable_utf8) { warn("The current version of OpenClient can't handle utf8 data."); } imp_dbh->enable_utf8 = 0; #endif imp_dbh->blkLogin[0] = 0; imp_dbh->dateFmt = 0; imp_dbh->inUse = 0; imp_dbh->init_done = 0; if (strchr(dsn, '=')) { extractFromDsn("server=", dsn, imp_dbh->server, 64); extractFromDsn("charset=", dsn, imp_dbh->charset, 64); extractFromDsn("database=", dsn, imp_dbh->database, 36); extractFromDsn("packetSize=", dsn, imp_dbh->packetSize, 64); extractFromDsn("language=", dsn, imp_dbh->language, 64); extractFromDsn("interfaces=", dsn, imp_dbh->ifile, 255); extractFromDsn("loginTimeout=", dsn, imp_dbh->loginTimeout, 64); extractFromDsn("timeout=", dsn, imp_dbh->timeout, 64); extractFromDsn("scriptName=", dsn, imp_dbh->scriptName, 255); extractFromDsn("hostname=", dsn, imp_dbh->hostname, 255); extractFromDsn("tdsLevel=", dsn, imp_dbh->tdsLevel, 30); extractFromDsn("encryptPassword=", dsn, imp_dbh->encryptPassword, 10); extractFromDsn("kerberos=", dsn, imp_dbh->kerberosPrincipal, 255); extractFromDsn("host=", dsn, imp_dbh->host, 64); extractFromDsn("port=", dsn, imp_dbh->port, 20); extractFromDsn("maxConnect=", dsn, imp_dbh->maxConnect, 25); extractFromDsn("sslCAFile=", dsn, imp_dbh->sslCAFile, 255); extractFromDsn("bulkLogin=", dsn, imp_dbh->blkLogin, 10); extractFromDsn("tds_keepalive=", dsn, imp_dbh->tds_keepalive, 10); extractFromDsn("serverType=", dsn, imp_dbh->serverType, 30); } else { strncpy(imp_dbh->server, dsn, 64); imp_dbh->server[63] = 0; } strncpy(imp_dbh->uid, uid, 32); imp_dbh->uid[31] = 0; strncpy(imp_dbh->pwd, pwd, 32); imp_dbh->pwd[31] = 0; sv_setpv(DBIc_ERRSTR(imp_dbh), ""); if (imp_dbh->kerbGetTicket) { fetchKerbTicket(imp_dbh); } imp_dbh->pid = getpid(); #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK(context_alloc_mutex); #endif if ((imp_dbh->connection = syb_db_connect(imp_dbh)) == NULL) retval = 0; else retval = 1; #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK(context_alloc_mutex); #endif if (!retval) return retval; if (!imp_dbh->serverType[0] || !strncasecmp(imp_dbh->serverType, "ase", 3)) get_server_version(dbh, imp_dbh, imp_dbh->connection); DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */ DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing*/ DBIc_LongReadLen(imp_dbh) = 32768; return 1; } static CS_CONNECTION *syb_db_connect(imp_dbh_t *imp_dbh) { dTHR; CS_RETCODE retcode; CS_CONNECTION *connection = NULL; CS_LOCALE *locale = NULL; char ofile[255]; int len; /* Allow increase of the max number of connections - patch supplied by Ed Avis */ if (imp_dbh->maxConnect[0]) { /* Maximum number of connections. */ const char * const s = imp_dbh->maxConnect; int i; i = atoi(s); if (i < 1) { warn("maxConnect must be positive, not '%s'", s); return 0; } #if defined(CS_MAX_CONNECT) if ((retcode = ct_config(context, CS_SET, CS_MAX_CONNECT, (CS_VOID*) &i, CS_UNUSED, NULL)) != CS_SUCCEED) croak("ct_config(max_connect) failed"); #else warn("ct_config(max_connect) not supported"); #endif } if (imp_dbh->ifile[0]) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_config(CS_IFILE,%s)\n", imp_dbh->ifile); if ((retcode = ct_config(context, CS_GET, CS_IFILE, ofile, 255, NULL)) != CS_SUCCEED) warn("ct_config(CS_GET, CS_IFILE) failed"); if (retcode == CS_SUCCEED) { if ((retcode = ct_config(context, CS_SET, CS_IFILE, imp_dbh->ifile, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_IFILE, %s) failed", imp_dbh->ifile); return NULL; } } } if (imp_dbh->loginTimeout[0]) { int timeout = atoi(imp_dbh->loginTimeout); if (timeout <= 0) timeout = 60; /* set negative or 0 length timeout to default 60 seconds */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_config(CS_LOGIN_TIMEOUT,%d)\n", timeout); if ((retcode = ct_config(context, CS_SET, CS_LOGIN_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) warn("ct_config(CS_SET, CS_LOGIN_TIMEOUT) failed"); } if (imp_dbh->timeout[0]) { int timeout = atoi(imp_dbh->timeout); if (timeout <= 0) timeout = CS_NO_LIMIT; /* set negative or 0 length timeout to default no limit */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_config(CS_TIMEOUT,%d)\n", timeout); if ((retcode = ct_config(context, CS_SET, CS_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) warn("ct_config(CS_SET, CS_TIMEOUT) failed"); } if (imp_dbh->language[0] != 0 || imp_dbh->charset[0] != 0) { CS_INT type = CS_DATES_SHORT; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> using private CS_LOCALE data\n"); /* Set up the proper locale - to handle character sets, etc. */ if ((retcode = cs_loc_alloc(context, &imp_dbh->locale) != CS_SUCCEED)) { warn("cs_loc_alloc failed"); return 0; } if (cs_locale(context, CS_SET, imp_dbh->locale, CS_LC_ALL, (CS_CHAR*) NULL, CS_UNUSED, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_LC_ALL) failed"); return 0; } if (imp_dbh->language[0] != 0) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> cs_locale(CS_SYB_LANG,%s)\n", imp_dbh->language); if (cs_locale(context, CS_SET, imp_dbh->locale, CS_SYB_LANG, (CS_CHAR*) imp_dbh->language, CS_NULLTERM, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_SYB_LANG, %s) failed", imp_dbh->language); return 0; } } if (imp_dbh->charset[0] != 0) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> cs_locale(CS_SYB_CHARSET,%s)\n", imp_dbh->charset); if (cs_locale(context, CS_SET, imp_dbh->locale, CS_SYB_CHARSET, (CS_CHAR*) imp_dbh->charset, CS_NULLTERM, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_SYB_CHARSET, %s) failed", imp_dbh->charset); return 0; } } if (cs_dt_info(context, CS_SET, imp_dbh->locale, CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) warn("cs_dt_info() failed"); } else { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh)," syb_db_login() -> using global CS_LOCALE data\n"); } #if defined(CS_CON_KEEPALIVE) if (imp_dbh->tds_keepalive[0]) { int tds_keepalive = atoi(imp_dbh->tds_keepalive); if (tds_keepalive != 1) { tds_keepalive = 0; } if(DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "syb_db_login() -> ct_config(CS_CON_KEEPALIVE,%d)\n", tds_keepalive); if((retcode = ct_config(context, CS_SET, CS_CON_KEEPALIVE, &tds_keepalive, CS_UNUSED, NULL)) != CS_SUCCEED) warn("ct_config(CS_SET, CS_CON_KEEPALIVE) failed"); } #endif if ((retcode = ct_con_alloc(context, &connection)) != CS_SUCCEED) { warn("ct_con_alloc failed"); return 0; } if (imp_dbh->locale) { if (ct_con_props(connection, CS_SET, CS_LOC_PROP, (CS_VOID*)imp_dbh->locale, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_LOC_PROP) failed"); return 0; } } if ((retcode = ct_con_props(connection, CS_SET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_USERDATA) failed"); return 0; } if (imp_dbh->tdsLevel[0] != 0) { CS_INT value = 0; if (strEQ(imp_dbh->tdsLevel, "CS_TDS_40")) value = CS_TDS_40; else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_42")) value = CS_TDS_42; else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_46")) value = CS_TDS_46; else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_495")) value = CS_TDS_495; else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_50")) value = CS_TDS_50; if (value) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_TDS_VERSION,%s)\n", imp_dbh->tdsLevel); if (ct_con_props(connection, CS_SET, CS_TDS_VERSION, (CS_VOID*)&value, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_TDS_VERSION, %s) failed", imp_dbh->tdsLevel); } } else { warn("Unkown tdsLevel value %s found", imp_dbh->tdsLevel); } } if (imp_dbh->packetSize[0] != 0) { int i = atoi(imp_dbh->packetSize); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_PACKETSIZE,%d)\n", i); if (ct_con_props(connection, CS_SET, CS_PACKETSIZE, (CS_VOID*)&i, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_PACKETSIZE, %d) failed", i); return 0; } } #if defined(CS_SEC_NETWORKAUTH) if(imp_dbh->kerberosPrincipal[0] == 0) { #endif if (retcode == CS_SUCCEED && *imp_dbh->uid) { if ((retcode = ct_con_props(connection, CS_SET, CS_USERNAME, imp_dbh->uid, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_USERNAME) failed"); return 0; } } if (retcode == CS_SUCCEED && *imp_dbh->pwd) { if ((retcode = ct_con_props(connection, CS_SET, CS_PASSWORD, imp_dbh->pwd, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_PASSWORD) failed"); return 0; } } #if defined(CS_SEC_NETWORKAUTH) } else { /* ** If we're using Kerberos, set the appropriate connection properties ** (which requires the Sybase Kerberos principal name). */ CS_INT i = CS_TRUE; if(DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_SERVERPRINCIPAL,%s)\n", imp_dbh->kerberosPrincipal); /*warn( imp_dbh->kerberosPrincipal);*/ if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_NETWORKAUTH, (CS_VOID *) &i, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_NETWORKAUTH) failed"); return 0; } if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_SERVERPRINCIPAL, imp_dbh->kerberosPrincipal, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_SERVERPRINCIPAL) failed"); return 0; } } #endif if (retcode == CS_SUCCEED) { if ((retcode = ct_con_props(connection, CS_SET, CS_APPNAME, *imp_dbh->scriptName ? imp_dbh->scriptName : scriptName, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_APPNAME, %s) failed", imp_dbh->scriptName); return 0; } if ((retcode = ct_con_props(connection, CS_SET, CS_HOSTNAME, *imp_dbh->hostname ? imp_dbh->hostname : hostname, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_HOSTNAME, %s) failed", imp_dbh->hostname); return 0; } } if (retcode == CS_SUCCEED) { if (imp_dbh->encryptPassword[0] != 0) { int i = CS_TRUE; if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_ENCRYPTION, (CS_VOID*)&i, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_ENCRYPTION, true) failed"); return 0; } } } #if defined(CS_PROP_SSL_CA) if(retcode == CS_SUCCEED) { if(imp_dbh->sslCAFile[0] != 0) { if((retcode = ct_con_props(connection, CS_SET, CS_PROP_SSL_CA, imp_dbh->sslCAFile, CS_NULLTERM, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_PROP_SSL_CA, %s) failed", imp_dbh->sslCAFile); return 0; } } } #endif if (retcode == CS_SUCCEED && imp_dbh->host[0] && imp_dbh->port[0]) { #if defined(CS_SERVERADDR) char buff[255]; sprintf(buff, "%.64s %.20s", imp_dbh->host, imp_dbh->port); if((retcode = ct_con_props(connection, CS_SET, CS_SERVERADDR, (CS_VOID*)buff, CS_NULLTERM, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SERVERADDR) failed"); return 0; } #else croak("This version of OpenClient doesn't support CS_SERVERADDR"); #endif } if (retcode == CS_SUCCEED && imp_dbh->blkLogin[0] != 0) { CS_INT flag = CS_TRUE; if ((retcode = ct_con_props(connection, CS_SET, CS_BULK_LOGIN, (CS_VOID*)&flag, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_BULK_LOGIN) failed"); return 0; } } if (retcode == CS_SUCCEED) { len = *imp_dbh->server == 0 ? 0 : CS_NULLTERM; if ((retcode = ct_connect(connection, imp_dbh->server, len)) != CS_SUCCEED) { if (locale != NULL) cs_loc_drop(context, locale); ct_con_drop(connection); return 0; } } if (imp_dbh->ifile[0]) { if ((retcode = ct_config(context, CS_SET, CS_IFILE, ofile, CS_NULLTERM, NULL)) != CS_SUCCEED) warn("ct_config(CS_SET, CS_IFILE, %s) failed", ofile); } if (imp_dbh->database[0] || imp_dbh->curr_db[0]) { int ret = syb_db_use(imp_dbh, connection); if (imp_dbh->failedDbUseFatal && ret < 0) { /* cleanup, and return NULL */ ct_close(connection, CS_FORCE_CLOSE); if (locale != NULL) cs_loc_drop(context, locale); ct_con_drop(connection); return 0; } } if (imp_dbh->chainedSupported) { CS_BOOL value = CS_FALSE; /* Default to ct_option supported... */ imp_dbh->optSupported = 1; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> checking for chained transactions\n"); retcode = ct_options(connection, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (retcode == CS_FAIL) { imp_dbh->doRealTran = 1; imp_dbh->chainedSupported = 0; } #if 0 /* This appears not to work - and hides the assignement to optSupported done in the server callback */ /* No SRV_OPTION handler on the server... */ if (imp_dbh->lasterr == 17001) imp_dbh->optSupported = 0; else imp_dbh->optSupported = 1; #endif if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_option is %ssupported\n", imp_dbh->optSupported == 1 ?"":"not "); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> chained transactions are %s supported\n", retcode == CS_FAIL ? "not" : ""); } #if 0 if(!imp_dbh->optSupported) { imp_dbh->chainedSupported = 0; imp_dbh->doRealTran = 1; /* XXX ??? */ } #endif if (imp_dbh->connection) { /* we're setting a sub-connection, so make sure that any attributes such as syb_quoted_identifier and syb_rowcount are set here too */ if (imp_dbh->quotedIdentifier && imp_dbh->optSupported) { CS_INT value = 1; retcode = ct_options(connection, CS_SET, CS_OPT_QUOTED_IDENT, &value, CS_UNUSED, NULL); if (retcode != CS_SUCCEED) { warn("Setting of CS_OPT_QUOTED_IDENT failed."); } } #if defined(CS_OPT_ROWCOUNT) if(imp_dbh->rowcount && imp_dbh->optSupported) { CS_INT value = imp_dbh->rowcount; retcode = ct_options(connection, CS_SET, CS_OPT_ROWCOUNT, &value, CS_UNUSED, NULL); if(retcode != CS_SUCCEED) { warn("Setting of CS_OPT_ROWCOUNT failed."); } } #endif } return connection; } static int syb_db_use(imp_dbh_t *imp_dbh, CS_CONNECTION *connection) { CS_COMMAND *cmd = syb_alloc_cmd(imp_dbh, connection); CS_RETCODE ret; CS_INT restype; char statement[255]; int retval = 0; char *db; if (!cmd) return -1; if (DBIc_ACTIVE(imp_dbh) && imp_dbh->curr_db[0]) db = imp_dbh->curr_db; else db = imp_dbh->database; sprintf(statement, "use %s", db); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_use() -> ct_command(%s)\n", statement); ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { warn("ct_command failed for '%s'", statement); return -1; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { warn("ct_send failed for '%s'", statement); return -1; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_use() -> ct_results(%d)\n", restype); if (restype == CS_CMD_FAIL) { warn("DBD::Sybase - can't change context to database %s\n", imp_dbh->database); retval = -1; } } ct_cmd_drop(cmd); return retval; } static int extract_version(char *buff, char *ver) { if (!strncmp(buff, "Adaptive", 8) || !strncmp(buff, "SQL Server", 10)) { char *p, *s; if ((p = strchr(buff, '/'))) { ++p; if ((s = strchr(p, '/'))) { strncpy(ver, p, s - p); } else { strncpy(ver, p, 10); } } } else { strcpy(ver, "Unknown"); } return 0; } static int get_server_version(SV *dbh, imp_dbh_t *imp_dbh, CS_CONNECTION *con) { CS_COMMAND *cmd = syb_alloc_cmd(imp_dbh, con); CS_RETCODE ret; CS_INT restype; char statement[60]; char buff[255]; char version[sizeof(imp_dbh->serverVersion)]; int retval = 0; char *db; if (!cmd) return -1; memset(version, 0, sizeof(imp_dbh->serverVersion)); sprintf(statement, "select @@version"); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> ct_command(%s)\n", statement); ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { warn("ct_command failed for '%s'", statement); return -1; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { warn("ct_send failed for '%s'", statement); return -1; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> ct_results(%d)\n", restype); if (restype == CS_CMD_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> Can't get version value\n"); retval = -1; } if (restype == CS_ROW_RESULT) { CS_DATAFMT datafmt; CS_INT len; CS_SMALLINT indicator; CS_INT retcode; CS_INT rows; ct_describe(cmd, 1, &datafmt); datafmt.format = CS_FMT_NULLTERM; datafmt.maxlength = sizeof(buff); ct_bind(cmd, 1, &datafmt, buff, &len, &indicator); while ((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> version = %s\n", buff); strncpy(imp_dbh->serverVersionString, buff, sizeof(imp_dbh->serverVersionString)); extract_version(buff, version); strncpy(imp_dbh->serverVersion, version, sizeof(imp_dbh->serverVersion)); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> version = %s\n", imp_dbh->serverVersion); } } } ct_cmd_drop(cmd); return retval; } int syb_ping(SV *dbh, imp_dbh_t *imp_dbh) { dTHX; CS_COMMAND *cmd; CS_RETCODE ret; CS_INT restype; char *statement = "/* ping */"; if (DBIc_ACTIVE_KIDS(imp_dbh)) { DBIh_SET_ERR_CHAR(dbh, (imp_xxh_t *)imp_dbh, NULL, -1, "Can't call ping() with active statement handles", NULL, NULL); return -1; } DBIh_CLEAR_ERROR(imp_dbh); cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection); if (!cmd) return 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_ping() -> ct_command(%s)\n", statement); ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { ct_cmd_drop(cmd); return 0; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { ct_cmd_drop(cmd); return 0; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_ping() -> ct_results(%d)\n", restype); if (imp_dbh->isDead) { ct_cmd_drop(cmd); return 0; } /* Ignored - we don't care if there is a syntax error - only that the communication with the server worked */ } DBIh_CLEAR_ERROR(imp_dbh); ct_cmd_drop(cmd); return 1; } int syb_db_date_fmt(SV *dbh, imp_dbh_t *imp_dbh, char *fmt) { CS_INT type; if (!strncmp(fmt, "ISO_strict", 10)) { imp_dbh->dateFmt = 2; return 1; } if (!strcmp(fmt, "ISO")) { imp_dbh->dateFmt = 1; return 1; } imp_dbh->dateFmt = 0; if (!strcmp(fmt, "LONG")) { type = CS_DATES_LONG; } else if (!strcmp(fmt, "SHORT")) { type = CS_DATES_SHORT; } else if (!strcmp(fmt, "DMY4_YYYY")) { type = CS_DATES_DMY4_YYYY; } else if (!strcmp(fmt, "MDY1_YYYY")) { type = CS_DATES_MDY1_YYYY; } else if (!strcmp(fmt, "DMY1_YYYY")) { type = CS_DATES_DMY1_YYYY; } else if (!strcmp(fmt, "DMY2_YYYY")) { type = CS_DATES_DMY2_YYYY; } else if (!strcmp(fmt, "YMD3_YYYY")) { type = CS_DATES_YMD3_YYYY; } else if (!strcmp(fmt, "HMS")) { type = CS_DATES_HMS; } else if (!strcmp(fmt, "LONGMS")) { #if defined(CS_DATES_LONGUSA_YYYY) type = CS_DATES_LONGUSA_YYYY; #else type = CS_DATES_LONG; #endif } else { warn("Invalid format %s in _date_fmt", fmt); return 0; } if (cs_dt_info(context, CS_SET, LOCALE(imp_dbh), CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) { warn("cs_dt_info() failed"); return 0; } return 1; } static int syb_get_date_fmt(imp_dbh_t *imp_dbh, char *fmt) { CS_INT type; char *p; if (imp_dbh->dateFmt == 2) { strcpy(fmt, "ISO_strict"); return 1; } if (imp_dbh->dateFmt == 1) { strcpy(fmt, "ISO"); return 1; } if (cs_dt_info(context, CS_GET, LOCALE(imp_dbh), CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) { warn("cs_dt_info() failed"); return 0; } switch (type) { case CS_DATES_LONG: p = "LONG"; break; case CS_DATES_SHORT: p = "SHORT"; break; case CS_DATES_DMY4_YYYY: p = "DMY4_YYYY"; break; case CS_DATES_MDY1_YYYY: p = "MDY1_YYYY"; break; case CS_DATES_DMY1_YYYY: p = "DMY1_YYYY"; break; case CS_DATES_DMY2_YYYY: p = "DMY2_YYYY"; break; case CS_DATES_YMD3_YYYY: p = "YMD3_YYYY"; break; case CS_DATES_HMS: p = "HMS"; break; default: p = "Unknown"; break; } strcpy(fmt, p); return 1; } int syb_discon_all(SV *drh, imp_drh_t *imp_drh) { /* disconnect_all is not implemented */ return 1; } #if defined(NO_BLK) static int syb_blk_done(imp_sth_t *imp_sth, CS_INT type) { return 1; } #else static int syb_blk_done(imp_sth_t *imp_sth, CS_INT type) { CS_RETCODE ret; /* if $dbh->commit is called but no rows have been successfully sent to the server then blk_done(CS_BLK_BATCH) fails. Avoid the failure by simply not calling blk_done() in that situation. */ if (type == CS_BLK_BATCH && !imp_sth->bcpRows) { return 1; } ret = blk_done(imp_sth->bcp_desc, type, &imp_sth->numRows); if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_blk_done -> blk_done(%d, %d, %d) = %d\n", imp_sth->bcp_desc, type, imp_sth->numRows, ret); /* reset row counter if blk_done was successful */ if (ret == CS_SUCCEED) { if (type == CS_BLK_CANCEL) imp_sth->bcpRows = -1; else imp_sth->bcpRows = 0; } if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_blk_done(%d) -> ret = %d, rows = %d\n", type, ret, imp_sth->numRows); return ret == CS_SUCCEED; } #endif int syb_db_commit(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> bcp op, calling syb_blk_done()\n"); return syb_blk_done(imp_dbh->imp_sth, CS_BLK_BATCH); } if (imp_dbh->doRealTran && !imp_dbh->inTransaction) return 1; if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) { warn("commit ineffective with AutoCommit"); return 1; } cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection); if (imp_dbh->doRealTran) sprintf(buff, "\nCOMMIT TRAN %s\n", imp_dbh->tranName); else strcpy(buff, "\nCOMMIT TRAN\n"); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_command(%s)\n", buff); retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (retcode != CS_SUCCEED) return 0; if (ct_send(cmd) != CS_SUCCEED) return 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_send() OK\n"); while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_results(%d) == %d\n", restype, retcode); if (restype == CS_CMD_FAIL) failFlag = 1; } ct_cmd_drop(cmd); imp_dbh->inTransaction = 0; return !failFlag; } int syb_db_rollback(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> bcp op, calling syb_blk_done()\n"); return syb_blk_done(imp_dbh->imp_sth, CS_BLK_CANCEL); } if (imp_dbh->doRealTran && !imp_dbh->inTransaction) return 1; if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) { warn("rollback ineffective with AutoCommit"); return 1; } cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection); if (imp_dbh->doRealTran) sprintf(buff, "\nROLLBACK TRAN %s\n", imp_dbh->tranName); else strcpy(buff, "\nROLLBACK TRAN\n"); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_command(%s)\n", buff); retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (retcode != CS_SUCCEED) return 0; if (ct_send(cmd) != CS_SUCCEED) return 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_send() OK\n"); while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_results(%d) == %d\n", restype, retcode); if (restype == CS_CMD_FAIL) failFlag = 1; } ct_cmd_drop(cmd); imp_dbh->inTransaction = 0; return !failFlag; } static int syb_db_opentran(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (DBIc_is(imp_dbh, DBIcf_AutoCommit) || imp_dbh->inTransaction) return 1; cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection); sprintf(imp_dbh->tranName, "DBI%x", imp_dbh); sprintf(buff, "\nBEGIN TRAN %s\n", imp_dbh->tranName); retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_command(%s) = %d\n", buff, retcode); if (retcode != CS_SUCCEED) return 0; retcode = ct_send(cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_send() = %d\n", retcode); if (retcode != CS_SUCCEED) return 0; while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_results(%d) == %d\n", restype, retcode); if (restype == CS_CMD_FAIL) failFlag = 1; } ct_cmd_drop(cmd); if (!failFlag) imp_dbh->inTransaction = 1; return !failFlag; } int syb_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh) { dTHX; CS_RETCODE retcode; /* If we are called in a process that is different from the one where the handle * was created then we do NOT disconnect. */ if (imp_dbh->disconnectInChild = 0 && imp_dbh->pid != getpid()) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_db_disconnect() -> imp_dbh->pid (%d) != pid (%d) - not closing connection\n", imp_dbh->pid, getpid()); return 0; } /* rollback if we get disconnected and no explicit commit has been called (when in non-AutoCommit mode) */ if (imp_dbh->isDead == 0) { /* only call if connection still active */ if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) syb_db_rollback(dbh, imp_dbh); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect() -> ct_close()\n"); if ((retcode = ct_close(imp_dbh->connection, CS_FORCE_CLOSE)) != CS_SUCCEED) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): ct_close() failed\n"); if (imp_dbh->locale && (retcode = cs_loc_drop(context, imp_dbh->locale)) != CS_SUCCEED) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): cs_loc_drop() failed\n"); if ((retcode = ct_con_drop(imp_dbh->connection)) != CS_SUCCEED) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): ct_con_drop() failed\n"); DBIc_ACTIVE_off(imp_dbh); return 1; } void syb_db_destroy(SV *dbh, imp_dbh_t *imp_dbh) { if (DBIc_ACTIVE(imp_dbh)) syb_db_disconnect(dbh, imp_dbh); /* Nothing in imp_dbh to be freed */ DBIc_IMPSET_off(imp_dbh); } /* NOTE: if you set any new attributes here that need to be passed on to Sybase (for example via ct_options()) then make sure that you also code the same thing in syb_db_connect() so that connections opened for nested statement handles correctly handle this issue */ int syb_db_STORE_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv) { dTHX; STRLEN kl; int on; char *key = SvPV(keysv, kl); if (kl == 15 && strEQ(key, "syb_chained_txn")) { on = SvTRUE(valuesv); if (imp_dbh->chainedSupported) { int autocommit = DBIc_is(imp_dbh, DBIcf_AutoCommit); if (!autocommit) syb_db_commit(dbh, imp_dbh); if (on) { imp_dbh->doRealTran = 0; } else { imp_dbh->doRealTran = 1; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_STORE() -> syb_chained_txn => %d\n", on); if (!autocommit && imp_dbh->optSupported) { CS_BOOL value = on ? CS_TRUE : CS_FALSE; CS_RETCODE ret; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_db_STORE() -> syb_chained_txn AutoCommit off CS_OPT_CHAINXACTS(%d) => %d\n", value, ret); } } else { /* XXX - should this issue a warning???? */ } return TRUE; } if (kl == 10 && strEQ(key, "AutoCommit")) { int crnt = (DBIc_has(imp_dbh, DBIcf_AutoCommit) > 0); int ret; /* Move the check for ACTIVE_KIDS below the check for the bcp flag * as that inhibits the setting of the autocommit variable anyway. */ if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_STORE(): AutoCommit value changes inhibitted during BCP ops\n"); return TRUE; } on = SvTRUE(valuesv); if (DBIc_ACTIVE_KIDS(imp_dbh) && ((on && !crnt) || (!on && crnt))) { croak( "panic: can't change AutoCommit (from %d to %d) with active statement handles", on, crnt); } ret = toggle_autocommit(dbh, imp_dbh, on); DBIc_set(imp_dbh, DBIcf_AutoCommit, on); return TRUE; } if (kl == 11 && strEQ(key, "LongTruncOK")) { DBIc_set(imp_dbh, DBIcf_LongTruncOk, SvTRUE(valuesv)); return TRUE; } if (kl == 11 && strEQ(key, "LongReadLen")) { CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn("Can't set LongReadLen because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_TEXTSIZE, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_TEXTSIZE failed."); return FALSE; } DBIc_LongReadLen(imp_dbh) = value; return TRUE; } if (kl == 21 && strEQ(key, "syb_quoted_identifier")) { CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn( "Can't set syb_quoted_identifier because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_QUOTED_IDENT, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_QUOTED_IDENT failed."); return FALSE; } imp_dbh->quotedIdentifier = value; return TRUE; } if (kl == 12 && strEQ(key, "syb_show_sql")) { on = SvTRUE(valuesv); if (on) { imp_dbh->showSql = 1; } else { imp_dbh->showSql = 0; } return TRUE; } if (kl == 12 && strEQ(key, "syb_show_eed")) { on = SvTRUE(valuesv); if (on) { imp_dbh->showEed = 1; } else { imp_dbh->showEed = 0; } return TRUE; } if (kl == 15 && strEQ(key, "syb_err_handler")) { if (!SvOK(valuesv)) { imp_dbh->err_handler = NULL; } else if (imp_dbh->err_handler == (SV*) NULL) { imp_dbh->err_handler = newSVsv(valuesv); } else { sv_setsv(imp_dbh->err_handler, valuesv); } return TRUE; } if (kl == 15 && strEQ(key, "syb_enable_utf8")) { #if !defined(DBD_CAN_HANDLE_UTF8) warn("The current version of OpenClient can't handle utf8 data."); return FALSE; #else on = SvTRUE(valuesv); if (on) { imp_dbh->enable_utf8 = 1; } else { imp_dbh->enable_utf8 = 0; } return TRUE; #endif } if (kl == 16 && strEQ(key, "syb_row_callback")) { if (!SvOK(valuesv)) { imp_dbh->row_cb = NULL; } else if (imp_dbh->row_cb == (SV*) NULL) { imp_dbh->row_cb = newSVsv(valuesv); } else { sv_setsv(imp_dbh->row_cb, valuesv); } return TRUE; } if (kl == 16 && strEQ(key, "syb_flush_finish")) { on = SvTRUE(valuesv); if (on) { imp_dbh->flushFinish = 1; } else { imp_dbh->flushFinish = 0; } return TRUE; } if (kl == 12 && strEQ(key, "syb_rowcount")) { #if defined(CS_OPT_ROWCOUNT) CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn( "Can't set syb_rowcount because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_ROWCOUNT, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_ROWCOUNT failed."); return FALSE; } imp_dbh->rowcount = value; return TRUE; #else return FALSE; #endif } if (kl == 21 && strEQ(key, "syb_dynamic_supported")) { warn("'syb_dynamic_supported' is a read-only attribute"); return TRUE; } if (kl == 18 && strEQ(key, "syb_do_proc_status")) { on = SvTRUE(valuesv); if (on) { imp_dbh->doProcStatus = 1; } else { imp_dbh->doProcStatus = 0; } return TRUE; } if (kl == 14 && strEQ(key, "syb_use_bin_0x")) { on = SvTRUE(valuesv); if (on) { imp_dbh->useBin0x = 1; } else { imp_dbh->useBin0x = 0; } return TRUE; } if (kl == 17 && strEQ(key, "syb_binary_images")) { on = SvTRUE(valuesv); if (on) { imp_dbh->binaryImage = 1; } else { imp_dbh->binaryImage = 0; } return TRUE; } if (kl == 18 && strEQ(key, "syb_deadlock_retry")) { int value = SvIV(valuesv); imp_dbh->deadlockRetry = value; return TRUE; } if (kl == 18 && strEQ(key, "syb_deadlock_sleep")) { int value = SvIV(valuesv); imp_dbh->deadlockSleep = value; return TRUE; } if (kl == 20 && strEQ(key, "syb_deadlock_verbose")) { int value = SvIV(valuesv); imp_dbh->deadlockVerbose = value; return TRUE; } if (kl == 17 && strEQ(key, "syb_nsql_nostatus")) { int value = SvIV(valuesv); imp_dbh->nsqlNoStatus = value; return TRUE; } if (kl == 16 && strEQ(key, "syb_no_child_con")) { imp_dbh->noChildCon = SvIV(valuesv); return TRUE; } if (kl == 19 && strEQ(key, "syb_failed_db_fatal")) { imp_dbh->failedDbUseFatal = SvIV(valuesv); return TRUE; } if (kl == 29 && strEQ(key, "syb_bind_empty_string_as_null")) { imp_dbh->bindEmptyStringNull = SvIV(valuesv); return TRUE; } if (kl == 27 && strEQ(key, "syb_cancel_request_on_error")) { imp_dbh->alwaysForceFailure = SvIV(valuesv); return TRUE; } if (kl == 23 && strEQ(key, "syb_disconnect_in_child")) { imp_dbh->disconnectInChild = SvIV(valuesv); return TRUE; } if (kl == 18 && strEQ(key, "syb_server_version")) { strncpy(imp_dbh->serverVersion, SvPV(valuesv, PL_na), 15); return TRUE; } if (kl == 12 && strEQ(key, "syb_date_fmt")) { syb_db_date_fmt(dbh, imp_dbh, SvPV(valuesv, PL_na)); return TRUE; } return FALSE; } SV *syb_db_FETCH_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); SV *retsv = NULL; if (kl == 10 && strEQ(key, "AutoCommit")) { if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 11 && strEQ(key, "LongTruncOK")) { if (DBIc_is(imp_dbh, DBIcf_LongTruncOk)) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 11 && strEQ(key, "LongReadLen")) { retsv = newSViv(DBIc_LongReadLen(imp_dbh)); } if (kl == 12 && strEQ(key, "syb_show_sql")) { if (imp_dbh->showSql) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 12 && strEQ(key, "syb_show_eed")) { if (imp_dbh->showEed) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 8 && strEQ(key, "syb_dead")) { if (imp_dbh->isDead) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 15 && strEQ(key, "syb_err_handler")) { if (imp_dbh->err_handler) { retsv = newSVsv(imp_dbh->err_handler); } else { retsv = &PL_sv_undef; } } if (kl == 15 && strEQ(key, "syb_enable_utf8")) { if (imp_dbh->enable_utf8) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 16 && strEQ(key, "syb_row_callback")) { if (imp_dbh->row_cb) { retsv = newSVsv(imp_dbh->row_cb); } else { retsv = &PL_sv_undef; } } if (kl == 15 && strEQ(key, "syb_chained_txn")) { if (imp_dbh->doRealTran) retsv = newSViv(0); else retsv = newSViv(1); } if (kl == 18 && strEQ(key, "syb_check_tranmode")) { CS_INT value; CS_RETCODE ret; ret = syb_set_options(imp_dbh, CS_GET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) value = 0; retsv = newSViv(value); } if (kl == 16 && strEQ(key, "syb_flush_finish")) { if (imp_dbh->flushFinish) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 21 && strEQ(key, "syb_dynamic_supported")) { CS_BOOL val; CS_RETCODE ret = ct_capability(imp_dbh->connection, CS_GET, CS_CAP_REQUEST, CS_REQ_DYN, (CS_VOID*) &val); if (ret != CS_SUCCEED || val == CS_FALSE) retsv = newSViv(0); else retsv = newSViv(1); } if (kl == 21 && strEQ(key, "syb_quoted_identifier")) { if (imp_dbh->quotedIdentifier) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 12 && strEQ(key, "syb_rowcount")) { retsv = newSViv(imp_dbh->rowcount); } if (kl == 14 && strEQ(key, "syb_oc_version")) { retsv = newSVpv(ocVersion, strlen(ocVersion)); } if (kl == 18 && strEQ(key, "syb_do_proc_status")) { retsv = newSViv(imp_dbh->doProcStatus); } if (kl == 14 && strEQ(key, "syb_use_bin_0x")) { if (imp_dbh->useBin0x) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 17 && strEQ(key, "syb_binary_images")) { if (imp_dbh->binaryImage) retsv = newSViv(1); else retsv = newSViv(0); } if (kl == 18 && strEQ(key, "syb_deadlock_retry")) { retsv = newSViv(imp_dbh->deadlockRetry); } if (kl == 18 && strEQ(key, "syb_deadlock_sleep")) { retsv = newSViv(imp_dbh->deadlockSleep); } if (kl == 20 && strEQ(key, "syb_deadlock_verbose")) { retsv = newSViv(imp_dbh->deadlockVerbose); } if (kl == 17 && strEQ(key, "syb_nsql_nostatus")) { retsv = newSViv(imp_dbh->nsqlNoStatus); } if (kl == 16 && strEQ(key, "syb_no_child_con")) { retsv = newSViv(imp_dbh->noChildCon); } if (kl == 19 && strEQ(key, "syb_failed_db_fatal")) { retsv = newSViv(imp_dbh->failedDbUseFatal); } if (kl == 29 && strEQ(key, "syb_bind_empty_string_as_null")) { retsv = newSViv(imp_dbh->bindEmptyStringNull); } if (kl == 27 && strEQ(key, "syb_cancel_request_on_error")) { retsv = newSViv(imp_dbh->alwaysForceFailure); } if (kl == 23 && strEQ(key, "syb_disconnect_in_child")) { retsv = newSViv(imp_dbh->disconnectInChild); } if (kl == 18 && strEQ(key, "syb_server_version")) { retsv = newSVpv(imp_dbh->serverVersion, 0); } if (kl == 25 && strEQ(key, "syb_server_version_string")) { retsv = newSVpv(imp_dbh->serverVersionString, 0); } if (kl == 12 && strEQ(key, "syb_date_fmt")) { char buff[50]; syb_get_date_fmt(imp_dbh, buff); retsv = newSVpv(buff, 0); } if (kl == 11 && strEQ(key, "syb_has_blk")) { #if defined(NO_BLK) retsv = &PL_sv_no; #else retsv = &PL_sv_yes; #endif } if (retsv == &PL_sv_yes || retsv == &PL_sv_no || retsv == &PL_sv_undef) return retsv; return sv_2mortal(retsv); } static CS_COMMAND * syb_alloc_cmd(imp_dbh_t *imp_dbh, CS_CONNECTION *connection) { CS_COMMAND *cmd; CS_RETCODE retcode; if ((retcode = ct_cmd_alloc(connection, &cmd)) != CS_SUCCEED) { syb_set_error(imp_dbh, -1, "ct_cmd_alloc failed"); return NULL; } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_alloc_cmd() -> CS_COMMAND %x for CS_CONNECTION %x\n", cmd, connection); return cmd; } static void dbd_preparse(imp_sth_t *imp_sth, char *statement) { dTHX; enum { DEFAULT, LITERAL, COMMENT, LINE_COMMENT, VARIABLE } STATES; int state = DEFAULT; int next_state; char last_literal = 0; char *src, *start, *dest; phs_t phs_tpl; SV *phs_sv; int idx = 0; STRLEN namelen; #define VARNAME_LEN 255 char varname[VARNAME_LEN + 1]; int pos; /* allocate room for copy of statement with spare capacity */ imp_sth->statement = (char*) safemalloc(strlen(statement) * 3); /* initialise phs ready to be cloned per placeholder */ memset(&phs_tpl, 0, sizeof(phs_tpl)); phs_tpl.ftype = CS_VARCHAR_TYPE; varname[0] = 0; /* check for a leading EXEC. If it is present then set imp_sth->type to 1 to indicate that we are doing an RPC call. */ src = statement; while (isspace(*src) && *src) /* skip over leading whitespace */ ++src; if (!strncasecmp(src, "exec", 4)) imp_sth->type = 1; else if (imp_sth->bcpFlag) imp_sth->type = 2; else imp_sth->type = 0; src = statement; dest = imp_sth->statement; while (*src) { next_state = state; /* default situation */ switch (state) { case DEFAULT: if (*src == '\'' || *src == '"') { last_literal = *src; next_state = LITERAL; } else if (*src == '/' && *(src + 1) == '*') { next_state = COMMENT; } else if (*src == '-' && *(src + 1) == '-') { next_state = LINE_COMMENT; } else if (*src == '@') { varname[0] = '@'; pos = 1; next_state = VARIABLE; } break; case LITERAL: if (*src == last_literal) { next_state = DEFAULT; } break; case COMMENT: if (*(src - 1) == '*' && *src == '/') { next_state = DEFAULT; } break; case LINE_COMMENT: if (*src == '\n') { next_state = DEFAULT; } break; case VARIABLE: if (!isalnum(*src) && *src != '_') { varname[pos] = 0; next_state = DEFAULT; } else if (pos < VARNAME_LEN) { varname[pos++] = *src; } } /* printf("state = %d, *src = %c, next_state = %d\n", state, *src, next_state); */ if (state != DEFAULT || *src != '?') { *dest++ = *src++; state = next_state; continue; } state = next_state; start = dest; /* save name inc colon */ *dest++ = *src++; if (*start == '?') { /* X/Open standard */ sprintf(start, ":p%d", ++idx); /* '?' -> ':p1' (etc) */ dest = start + strlen(start); } else { /* not a placeholder, so just copy */ continue; } *dest = '\0'; /* handy for debugging */ namelen = (dest - start); if (imp_sth->all_params_hv == NULL) imp_sth->all_params_hv = newHV(); phs_tpl.sv = &PL_sv_undef; phs_sv = newSVpv((char*) &phs_tpl, sizeof(phs_tpl) + namelen + 1); hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0); strcpy(((phs_t*) (void*) SvPVX(phs_sv))->name, start); strcpy(((phs_t*) (void*) SvPVX(phs_sv))->varname, varname); if (imp_sth->type == 1) { /* if it's an EXEC call, check for OUTPUT */ char *p = src; do { if (*p == ',') break; if (isspace(*p)) continue; if (isalpha(*p)) { if (!strncasecmp(p, "out", 3)) { ((phs_t*) (void*) SvPVX(phs_sv))->is_inout = 1; } else { break; } } } while (*(++p)); } if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_preparse parameter %s (%s)\n", ((phs_t*) (void*) SvPVX(phs_sv))->name, ((phs_t*) (void*) SvPVX(phs_sv))->varname); /* warn("params_hv: '%s'\n", start); */ } *dest = '\0'; if (imp_sth->all_params_hv) { DBIc_NUM_PARAMS(imp_sth) = (int) HvKEYS(imp_sth->all_params_hv); if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_preparse scanned %d distinct placeholders\n", (int) DBIc_NUM_PARAMS(imp_sth)); } } static CS_RETCODE dyn_prepare(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, char* statement) { dTHX; CS_INT restype; static int tt = 1; int failed = 0; CS_BOOL val; CS_RETCODE ret; ret = ct_capability(imp_dbh->connection, CS_GET, CS_CAP_REQUEST, CS_REQ_DYN, (CS_VOID*) &val); if (ret != CS_SUCCEED || val == CS_FALSE) croak( "Panic: dynamic SQL (? placeholders) are not supported by the server you are connecting to"); sprintf(imp_sth->dyn_id, "DBD%d", (int) tt++); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_dynamic(CS_PREPARE) for %s\n", imp_sth->dyn_id); imp_sth->dyn_execed = 0; imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection); ret = ct_dynamic(imp_sth->cmd, CS_PREPARE, imp_sth->dyn_id, CS_NULLTERM, statement, CS_NULLTERM); if (ret != CS_SUCCEED) { warn("ct_dynamic(CS_PREPARE) returned %d", ret); return ret; } ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) { warn("ct_send(ct_dynamic(CS_PREPARE)) returned %d", ret); return ret; } while ((ret = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) if (restype == CS_CMD_FAIL) failed = 1; if (ret == CS_FAIL || failed) { warn("ct_result(ct_dynamic(CS_PREPARE)) returned %d", ret); return ret; } ret = ct_dynamic(imp_sth->cmd, CS_DESCRIBE_INPUT, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED); if (ret != CS_SUCCEED) warn("ct_dynamic(CS_DESCRIBE_INPUT) returned %d", ret); ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) warn("ct_send(CS_DESCRIBE_INPUT) returned %d", ret); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_dynamic(CS_DESCRIBE_INPUT) for %s\n", imp_sth->dyn_id); while ((ret = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_results(CS_DESCRIBE_INPUT) for %s - restype %d\n", imp_sth->dyn_id, restype); if (restype == CS_DESCRIBE_RESULT) { CS_INT num_param, outlen; int i; char name[50]; SV **svp; phs_t *phs; int ret; ret = ct_res_info(imp_sth->cmd, CS_NUMDATA, &num_param, CS_UNUSED, &outlen); if (ret != CS_SUCCEED) warn("ct_res_info(CS_DESCRIBE_INPUT) returned %d", ret); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_res_info(CS_DESCRIBE_INPUT) statement has %d parameters\n", num_param); for (i = 1; i <= num_param; ++i) { sprintf(name, ":p%d", i); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); ct_describe(imp_sth->cmd, i, &phs->datafmt); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_describe(CS_DESCRIBE_INPUT) col %d, type %d, name %s, status %d, length %d\n", i, phs->datafmt.datatype, phs->datafmt.name, phs->datafmt.status, phs->datafmt.maxlength); } } } if (ct_dynamic(imp_sth->cmd, CS_EXECUTE, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED) != CS_SUCCEED) ret = CS_FAIL; else { ret = CS_SUCCEED; imp_sth->dyn_execed = 1; } return ret; } int syb_st_prepare(SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs) { dTHX; D_imp_dbh_from_sth; CS_RETCODE ret; /* PerlIO_printf(DBIc_LOGPIO(imp_dbh), "st_prepare on %x\n", imp_sth); */ sv_setpv(DBIc_ERRSTR(imp_dbh), ""); /* Don't try to initiate a new command if the connection isn't active! */ if (!DBIc_ACTIVE(imp_dbh)) { syb_set_error(imp_dbh, -1, "Database disconnected"); return 0; } /* Check to see if the syb_bcp_attribs flag is set */ getBcpAttribs(imp_sth, attribs); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() -> inUse = %d\n", imp_dbh->inUse); if (DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_sth)) || imp_dbh->inUse) { int retval = 1; if (imp_dbh->noChildCon) { /* inhibit child connections to be created */ syb_set_error(imp_dbh, -1, "DBD::Sybase error: Can't create child connections when syb_no_chld_con is set"); return 0; } if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) croak( "Panic: Can't have multiple statement handles on a single database handle when AutoCommit is OFF"); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() parent has active kids - opening new connection\n"); #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK(context_alloc_mutex); #endif if ((imp_sth->connection = syb_db_connect(imp_dbh)) == NULL) retval = 0; #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK(context_alloc_mutex); #endif if (!retval) return retval; } if (imp_sth->statement != NULL) Safefree(imp_sth->statement); imp_sth->statement = NULL; dbd_preparse(imp_sth, statement); imp_dbh->sql = imp_sth->statement; if (!DBIc_is(imp_dbh, DBIcf_AutoCommit) && imp_dbh->doRealTran) if (syb_db_opentran(NULL, imp_dbh) == 0) return -2; if ((int) DBIc_NUM_PARAMS(imp_sth)) { /* regular dynamic sql */ if (imp_sth->type == 0) { ret = dyn_prepare(imp_dbh, imp_sth, statement); if (ret != CS_SUCCEED) { return 0; } } else if (imp_sth->type == 1) { /* RPC call - get the proc name */ /* We could possibly get the proc params from syscolumns, but there are a lot of issues with that which will break it */ if (!syb_st_describe_proc(imp_sth, statement)) { croak("DBD::Sybase: describe_proc failed!\n"); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " describe_proc: procname = %s\n", imp_sth->proc); imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection); ret = CS_SUCCEED; imp_sth->dyn_execed = 0; } else { /* BLK operation! */ ret = syb_blk_init(imp_dbh, imp_sth); } } else { /* If this is a blk request (i.e. the syb_bcp_attribs hash is set in the prepare() call, then force a failure, because no parameters (placeholders) have been defined. */ if (imp_sth->type == 2) { syb_set_error(imp_dbh, -1, "The syb_bcp_attribs attribute is set, but no placeholders found in the query"); return 0; } imp_sth->cmd = NULL; /* Early execution has some unwanted side effects - disabling it in 1.05_02. */ #if 0 if(cmd_execute(sth, imp_sth) != 0) { return 0; } #endif ret = CS_SUCCEED; } if (ret != CS_SUCCEED) return 0; imp_sth->doProcStatus = imp_dbh->doProcStatus; DBIc_on(imp_sth, DBIcf_IMPSET); if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() -> set inUse\n"); imp_dbh->inUse = 1; } /* Re-enable the active flag here (in 1.05_03) to fix bug with finish not getting called correctly */ DBIc_ACTIVE_on(imp_sth); return 1; } static int syb_st_describe_proc(imp_sth_t *imp_sth, char *statement) { char *buff = my_strdup(statement); char *tok; tok = strtok(buff, " \n\t"); if (strncasecmp(tok, "exec", 4)) { Safefree(buff); return 0; /* it's gotta start with exec(ute) */ } tok = strtok(NULL, " \n\t"); /* this is the proc name */ if (!tok || !*tok) { warn( "DBD::Sybase: describe_proc: didn't get a proc name in EXEC statement\n"); Safefree(buff); return 0; } strcpy(imp_sth->proc, tok); Safefree(buff); return 1; } int syb_st_rows(SV *sth, imp_sth_t *imp_sth) { return imp_sth->numRows; } static void cleanUp(imp_sth_t *imp_sth) { int i; int numCols = DBIc_NUM_FIELDS(imp_sth); for (i = 0; i < numCols; ++i) { if (imp_sth->coldata[i].type == CS_CHAR_TYPE || imp_sth->coldata[i].type == CS_LONGCHAR_TYPE || imp_sth->coldata[i].type == CS_TEXT_TYPE || imp_sth->coldata[i].type == CS_IMAGE_TYPE) { Safefree(imp_sth->coldata[i].value.c); } } if (imp_sth->datafmt) Safefree(imp_sth->datafmt); if (imp_sth->coldata) Safefree(imp_sth->coldata); imp_sth->numCols = 0; imp_sth->coldata = NULL; imp_sth->datafmt = NULL; } static CS_RETCODE describe(SV *sth, imp_sth_t *imp_sth, int restype) { dTHX; D_imp_dbh_from_sth; CS_RETCODE retcode; int i; int numCols; AV *av; if ((retcode = ct_res_info(imp_sth->cmd, CS_NUMDATA, &numCols, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_res_info() failed"); goto GoodBye; } if (numCols <= 0) { warn("ct_res_info() returned 0 columns"); DBIc_NUM_FIELDS(imp_sth) = numCols; imp_sth->numCols = 0; goto GoodBye; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_res_info() returns %d columns\n", numCols); /* According to Tim Bunce I shouldn't need the code below. However, if I remove it DBD::Sybase segfaults in some situations with DBI < 1.53, and there are still problems with COMPUTE BY statements with DBI >= 1.54. */ /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */ DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */ DBIc_DBISTATE(imp_sth)->set_attr_k(sth, sv_2mortal( newSVpvn("NUM_OF_FIELDS", 13)), 0, sv_2mortal(newSViv(numCols))); #if 1 /* for DBI <= 1.53 (and 1.54 which doesn't shrink properly) */ av = DBIc_FIELDS_AV(imp_sth); if (av && av_len(av) + 1 != numCols) { SvREADONLY_off(av); /* DBI sets this readonly */ av_clear(av); i = numCols; while (i--) { av_store(av, i, newSV(0)); } SvREADONLY_on(av); /* DBI sets this readonly */ } #endif imp_sth->numCols = numCols; New(902, imp_sth->coldata, numCols, ColData); New(902, imp_sth->datafmt, numCols, CS_DATAFMT); /* this routine may be called without the connection reference */ if (restype == CS_COMPUTE_RESULT) { CS_INT comp_id, outlen; if ((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_ID, CS_UNUSED, &comp_id, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } } for (i = 0; i < numCols; ++i) { if ((retcode = ct_describe(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i])) != CS_SUCCEED) { warn("ct_describe() failed"); cleanUp(imp_sth); goto GoodBye; } /* Make sure we have at least some sort of column name: */ if (imp_sth->datafmt[i].namelen == 0) sprintf(imp_sth->datafmt[i].name, "COL(%d)", i + 1); if (restype == CS_COMPUTE_RESULT) { CS_INT agg_op, outlen; CS_CHAR *agg_op_name; if ((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_OP, (i + 1), &agg_op, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } agg_op_name = GetAggOp(agg_op); if ((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_COLID, (i + 1), &agg_op, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } sprintf(imp_sth->datafmt[i].name, "%s(%d)", agg_op_name, agg_op); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_describe(%d): type = %d, maxlen = %d\n", i, imp_sth->datafmt[i].datatype, imp_sth->datafmt[i].maxlength); imp_sth->coldata[i].realType = imp_sth->datafmt[i].datatype; imp_sth->coldata[i].realLength = imp_sth->datafmt[i].maxlength; imp_sth->datafmt[i].locale = LOCALE(imp_dbh); switch (imp_sth->datafmt[i].datatype) { case CS_BIT_TYPE: case CS_TINYINT_TYPE: case CS_SMALLINT_TYPE: case CS_INT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_INT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_INT_TYPE; imp_sth->datafmt[i].datatype = CS_INT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.i, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #if defined(SYB_NATIVE_NUM) && defined(CS_UINT_TYPE) case CS_USMALLINT_TYPE: case CS_UINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_INT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_UINT_TYPE; imp_sth->datafmt[i].datatype = CS_UINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.ui, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #if defined(SYB_NATIVE_NUM) #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_BIGINT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_BIGINT_TYPE; imp_sth->datafmt[i].datatype = CS_BIGINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.bi, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #if defined(CS_UBIGINT_TYPE) case CS_UBIGINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_UBIGINT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_UBIGINT_TYPE; imp_sth->datafmt[i].datatype = CS_UBIGINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.ubi, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #endif #if defined(SYB_NATIVE_NUM) case CS_MONEY_TYPE: case CS_MONEY4_TYPE: #endif case CS_REAL_TYPE: case CS_FLOAT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_FLOAT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_FLOAT_TYPE; imp_sth->datafmt[i].datatype = CS_FLOAT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.f, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; case CS_TEXT_TYPE: case CS_IMAGE_TYPE: #if defined(CS_UNITEXT_TYPE) case CS_UNITEXT_TYPE: #endif New(902, imp_sth->coldata[i].value.c, imp_sth->datafmt[i].maxlength, char); imp_sth->datafmt[i].format = CS_FMT_UNUSED; /*CS_FMT_NULLTERM;*/ if (imp_dbh->binaryImage) imp_sth->coldata[i].type = imp_sth->datafmt[i].datatype; else { imp_sth->coldata[i].type = CS_TEXT_TYPE; imp_sth->datafmt[i].datatype = CS_TEXT_TYPE; } if (!imp_sth->noBindBlob) { retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], imp_sth->coldata[i].value.c, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); } break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_DATETIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_DATETIME_TYPE; imp_sth->datafmt[i].datatype = CS_DATETIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.dt, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_DATE); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_DATE_TYPE; imp_sth->datafmt[i].datatype = CS_DATE_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.d, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; case CS_TIME_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_TIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_TIME_TYPE; imp_sth->datafmt[i].datatype = CS_TIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.t, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: default: imp_sth->datafmt[i].maxlength = get_cwidth(&imp_sth->datafmt[i]) + 1; /*display_dlen(&imp_sth->datafmt[i]) + 1;*/ imp_sth->datafmt[i].format = CS_FMT_UNUSED; New(902, imp_sth->coldata[i].value.c, imp_sth->datafmt[i].maxlength, char); imp_sth->coldata[i].type = CS_CHAR_TYPE; imp_sth->datafmt[i].datatype = CS_CHAR_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], imp_sth->coldata[i].value.c, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); /* Now that we've accomplished the CHAR actions, set the type back to BINARY if appropriate, so the useBin0x actions work later. */ if (imp_sth->coldata[i].realType == CS_BINARY_TYPE || imp_sth->coldata[i].realType == CS_VARBINARY_TYPE) { imp_sth->coldata[i].type = imp_sth->datafmt[i].datatype = imp_sth->coldata[i].realType; } break; } /* check the return code of the call to ct_bind in the switch above: */ if (retcode != CS_SUCCEED) { warn("ct_bind() failed"); cleanUp(imp_sth); break; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " describe() -> col %d, type %d, realtype %d\n", i, imp_sth->coldata[i].type, imp_sth->coldata[i].realType); } GoodBye: ; if (retcode == CS_SUCCEED) { imp_sth->done_desc = 1; } return retcode == CS_SUCCEED; } static void clear_sth_flags(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " clear_sth_flags() -> resetting ACTIVE, moreResults, dyn_execed, exec_done\n"); imp_sth->moreResults = 0; imp_sth->dyn_execed = 0; imp_sth->exec_done = 0; if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clear_sth_flags() -> reset inUse flag\n"); imp_dbh->inUse = 0; } } static int st_next_result(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; imp_sth->numRows = -1; while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> ct_results(%d) == %d\n", restype, retcode); if (restype == CS_CMD_FAIL) failFlag = 1; if ((restype == CS_CMD_DONE || restype == CS_CMD_SUCCEED) && !failFlag) { ct_res_info(cmd, CS_ROW_COUNT, &imp_sth->numRows, CS_UNUSED, NULL); } switch (restype) { case CS_ROW_RESULT: case CS_PARAM_RESULT: case CS_STATUS_RESULT: case CS_CURSOR_RESULT: case CS_COMPUTE_RESULT: if (imp_sth->done_desc) { cleanUp(imp_sth); clear_cache(sth, imp_sth); } retcode = describe(sth, imp_sth, restype); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "describe() retcode = %d\n", retcode); if (restype == CS_STATUS_RESULT && (imp_sth->doProcStatus || (imp_sth->dyn_execed && imp_sth->type == 0))) { CS_INT rows_read; retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read); if (retcode == CS_SUCCEED) { imp_sth->lastProcStatus = imp_sth->coldata[0].value.i; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "describe() proc status code = %d\n", imp_sth->lastProcStatus); if (imp_sth->lastProcStatus != 0) { failFlag = 2; } } else { croak("ct_fetch() for proc status failed!"); } while ((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read))) { if (retcode == CS_END_DATA || retcode == CS_FAIL) break; } } else goto Done; /* exit from the ct_results() loop here if we are *NOT* in doProcStatus mode, and this is *NOT* a status result set */ } } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "ct_results(%d) final retcode = %d\n", restype, retcode); Done: /* The lasterr/lastsev is a hack to work around Sybase OpenClient, which does NOT return CS_CMD_FAIL for constraint errors when inserting/updating data using ?-style placeholders. */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> lasterr = %d, lastsev = %d\n", imp_dbh->lasterr, imp_dbh->lastsev); /* Only force a failure if there are no rows to be fetched (ie on a normal insert/update/delete operation */ if (!failFlag && imp_dbh->lasterr != 0 && imp_dbh->lastsev > 10) { if (imp_dbh->alwaysForceFailure || (restype != CS_STATUS_RESULT && restype != CS_ROW_RESULT && restype != CS_PARAM_RESULT && restype != CS_CURSOR_RESULT && restype != CS_COMPUTE_RESULT)) { failFlag = 3; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " st_next_result() -> restype is not data result or syb_cancel_request_on_error is TRUE, force failFlag\n"); } else { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> restype is data result, do NOT force failFlag\n"); } } /* Cancel the whole thing if we force a failure */ /* Blaise Lepeuple, 9/26/02 */ /* Only do the flush if the failure was forced rather than "normal". In the normal case the connection is in a stable/idle state */ /* XXX */ if (failFlag && (restype != CS_CMD_DONE && restype != CS_CMD_FAIL) && retcode != CS_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> failFlag set - clear request\n"); syb_st_finish(sth, imp_sth); } /* FreeTDS added a result code CS_END_RESULTS */ /* Do the right thing with it Frederick Staats, 6/26/03 */ if (retcode == CS_END_RESULTS) restype = CS_CMD_DONE; if (failFlag || retcode == CS_FAIL || retcode == CS_CANCELED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> force CS_CMD_FAIL return\n"); restype = CS_CMD_FAIL; } imp_sth->lastResType = restype; /* clear the handle here - to be sure to always have a consistent handle view after command completion. */ if (restype == CS_CMD_DONE || restype == CS_CMD_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " st_next_result() -> got %s: resetting ACTIVE, moreResults, dyn_execed, exec_done\n", restype == CS_CMD_DONE ? "CS_CMD_DONE" : "CS_CMD_FAIL"); clear_sth_flags(sth, imp_sth); DBIc_ACTIVE_off(imp_sth); } else { DBIc_ACTIVE_on(imp_sth); } return restype; } static int _convert(void *ptr, char *str, CS_LOCALE *locale, CS_DATAFMT *datafmt, CS_INT *len) { dTHX; CS_DATAFMT srcfmt; CS_INT retcode; CS_INT reslen; memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.maxlength = strlen(str); srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = locale; retcode = cs_convert(context, &srcfmt, str, datafmt, ptr, &reslen); /* FIXME - DBIS slow in threaded mode */ if (DBIS->debug >= 3 && retcode != CS_SUCCEED || reslen == CS_UNUSED) PerlIO_printf(DBILOGFP, "cs_convert failed (_convert(%s, %d))", str, datafmt->datatype); if (len) { *len = reslen; } return retcode; } static CS_RETCODE get_cs_msg(CS_CONTEXT *context, CS_CONNECTION *connection, char *msg, SV *sth, imp_sth_t *imp_sth) { dTHX; CS_CLIENTMSG errmsg; CS_INT lastmsg = 0; CS_RETCODE ret; memset((void*) &errmsg, 0, sizeof(CS_CLIENTMSG)); ret = cs_diag(context, CS_STATUS, CS_CLIENTMSG_TYPE, CS_UNUSED, &lastmsg); if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), "get_cs_msg -> cs_diag(CS_STATUS): lastmsg = %d (ret = %d)\n", lastmsg, ret); if (ret != CS_SUCCEED) { warn("cs_diag(CS_STATUS) failed"); return ret; } ret = cs_diag(context, CS_GET, CS_CLIENTMSG_TYPE, lastmsg, &errmsg); if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), "get_cs_msg -> cs_diag(CS_GET) ret = %d\n", ret); if (ret != CS_SUCCEED) { warn("cs_diag(CS_GET) failed"); return ret; } DBIh_SET_ERR_CHAR(sth, (imp_xxh_t *)imp_sth, NULL, CS_NUMBER(errmsg.msgnumber), errmsg.msgstring, NULL, NULL); if (cslib_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_LAYER(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_ORIGIN(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSVpv(errmsg.msgstring, 0))); if (errmsg.osstringlen > 0) XPUSHs(sv_2mortal(newSVpv(errmsg.osstring, 0))); else XPUSHs(&PL_sv_undef); if (msg) XPUSHs(sv_2mortal(newSVpv(msg, 0))); else XPUSHs(&PL_sv_undef); PUTBACK; if ((count = perl_call_sv(cslib_cb, G_SCALAR)) != 1) croak("A cslib handler cannot return a LIST"); SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; return retval == 1 ? CS_SUCCEED : CS_FAIL; } #if 0 PerlIO_printf(DBIc_LOGPIO(imp_dbh), "\nCS Library Message:\n"); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Message number: LAYER = (%ld) ORIGIN = (%ld) ", CS_LAYER(errmsg.msgnumber), CS_ORIGIN(errmsg.msgnumber)); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "SEVERITY = (%ld) NUMBER = (%ld)\n", CS_SEVERITY(errmsg.msgnumber), CS_NUMBER(errmsg.msgnumber)); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Message String: %s\n", errmsg.msgstring); if(msg) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "User Message: %s\n", msg); /*fflush(stderr);*/ #endif return CS_FAIL; } /* Allocate a buffer of the appropriate size for "datatype". Only works for fixed-size datatypes */ static void * alloc_datatype(CS_INT datatype, int *len) { void *ptr; int bytes; switch (datatype) { case CS_TINYINT_TYPE: bytes = sizeof(CS_TINYINT); break; case CS_SMALLINT_TYPE: bytes = sizeof(CS_SMALLINT); break; case CS_INT_TYPE: bytes = sizeof(CS_INT); break; case CS_REAL_TYPE: bytes = sizeof(CS_REAL); break; case CS_FLOAT_TYPE: bytes = sizeof(CS_FLOAT); break; case CS_BIT_TYPE: bytes = sizeof(CS_BIT); break; case CS_DATETIME_TYPE: bytes = sizeof(CS_DATETIME); break; case CS_DATETIME4_TYPE: bytes = sizeof(CS_DATETIME4); break; case CS_MONEY_TYPE: bytes = sizeof(CS_MONEY); break; case CS_MONEY4_TYPE: bytes = sizeof(CS_MONEY4); break; case CS_NUMERIC_TYPE: bytes = sizeof(CS_NUMERIC); break; case CS_DECIMAL_TYPE: bytes = sizeof(CS_DECIMAL); break; case CS_LONG_TYPE: bytes = sizeof(CS_LONG); break; #if 0 case CS_SENSITIVITY_TYPE: bytes = sizeof(CS_SENSITIVITY); break; case CS_BOUNDARY_TYPE: bytes = sizeof(CS_BOUNDARY); break; #endif case CS_USHORT_TYPE: bytes = sizeof(CS_USHORT); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: bytes = sizeof(CS_DATE); break; case CS_TIME_TYPE: bytes = sizeof(CS_TIME); break; #endif #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: bytes = sizeof(CS_BIGINT); break; case CS_USMALLINT_TYPE: bytes = sizeof(CS_USMALLINT); break; case CS_UINT_TYPE: bytes = sizeof(CS_UINT); break; case CS_UBIGINT_TYPE: bytes = sizeof(CS_UBIGINT); break; #endif default: warn("alloc_datatype: unkown type: %d", datatype); return NULL; } Newz(902, ptr, bytes, char); *len = bytes; return ptr; } #if defined(NO_BLK) static int syb_blk_execute(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { return -1; } #else static int syb_blk_execute(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { dTHX; int i; char name[32]; void *ptr; CS_CONNECTION *con = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; STRLEN slen; CS_INT vlen; SV **svp; phs_t *phs; CS_RETCODE ret; #if !defined(USE_CSLIB_CB) if (cs_diag(context, CS_CLEAR, CS_CLIENTMSG_TYPE, CS_UNUSED, NULL) != CS_SUCCEED) warn("cs_diag(CS_CLEAR) failed"); #endif for (i = 0; i < imp_sth->numCols; ++i) { sprintf(name, ":p%d", i + 1); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); phs->datafmt.format = CS_FMT_UNUSED; phs->datafmt.count = 1; if (!phs->sv || !SvOK(phs->sv) || phs->sv == &PL_sv_undef) { imp_sth->coldata[i].indicator = 0; ptr = ""; imp_sth->coldata[i].valuelen = 0; if (!imp_sth->bcpIdentityFlag && imp_sth->bcpIdentityCol == i + 1) continue; } else { imp_sth->coldata[i].ptr = SvPV(phs->sv, slen); imp_sth->coldata[i].indicator = 0; switch (phs->datafmt.datatype) { #if 0 case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: if(_convert(&imp_sth->coldata[i].value.num, imp_sth->coldata[i].ptr, LOCALE(imp_dbh), &phs->datafmt, &vlen) != CS_SUCCEED) { /* If the error handler returns CS_FAIL, then FAIL this row! */ #if !defined(USE_CSLIB_CB) if(get_cs_msg(context, con) != CS_SUCCEED) goto FAIL; #else warn("BLK _convert(CS_NUMERIC, %s) failed - see cslib error.", imp_sth->coldata[i].ptr); #endif } imp_sth->coldata[i].valuelen = (vlen != CS_UNUSED ? vlen : sizeof(imp_sth->coldata[i].value.num)); ptr = &imp_sth->coldata[i].value.num; break; #endif case CS_BINARY_TYPE: case CS_LONGBINARY_TYPE: case CS_LONGCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: case CS_CHAR_TYPE: /* For these types send data "as is" */ ptr = imp_sth->coldata[i].ptr; imp_sth->coldata[i].valuelen = slen; break; #if defined(CS_UNICHAR_TYPE) case CS_UNICHAR_TYPE: /* For these types send data "as is" */ ptr = imp_sth->coldata[i].ptr; imp_sth->coldata[i].valuelen = slen * 2; break; #endif default: /* for all others, call cs_convert() before sending */ if (!imp_sth->coldata[i].v_alloc) { imp_sth->coldata[i].value.p = alloc_datatype(phs->datafmt.datatype, &imp_sth->coldata[i].v_alloc); } if (_convert(imp_sth->coldata[i].value.p, imp_sth->coldata[i].ptr, LOCALE(imp_dbh), &phs->datafmt, &vlen) != CS_SUCCEED) { char msg[255]; /* If the error handler returns CS_FAIL, then FAIL this row! */ #if !defined(USE_CSLIB_CB) sprintf(msg, "cs_convert failed: column %d: (_convert(%s, %d))", i + 1, (char *) imp_sth->coldata[i].ptr, phs->datafmt.datatype); ret = get_cs_msg(context, con, msg, sth, imp_sth); if (ret == CS_FAIL) goto FAIL; #else warn("cs_convert failed: column %d: (_convert(%s, %d))", i + 1, imp_sth->coldata[i].ptr, phs->datafmt.datatype); ret = CS_FAIL; goto FAIL; #endif } imp_sth->coldata[i].valuelen = (vlen != CS_UNUSED ? vlen : imp_sth->coldata[i].v_alloc); ptr = imp_sth->coldata[i].value.p; break; } } ret = blk_bind(imp_sth->bcp_desc, i + 1, &phs->datafmt, ptr, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); if (DBIc_DBISTATE(imp_dbh)->debug >= 5) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "blk_bind %d -> '%s' (ret = %d)\n", i + 1, imp_sth->coldata[i].ptr, ret); if (ret != CS_SUCCEED) goto FAIL; } ret = blk_rowxfer(imp_sth->bcp_desc); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "blk_rowxfer() -> %d\n", ret); if (ret == CS_SUCCEED) imp_sth->bcpRows++; FAIL: ; return (ret == CS_SUCCEED ? -1 : -2); } #endif static int cmd_execute(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; if (!imp_sth->dyn_execed) { if (!imp_sth->cmd) { /* only allocate a CS_COMMAND struct if there isn't one already bug# 461 */ imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection); } if (ct_command(imp_sth->cmd, CS_LANG_CMD, imp_sth->statement, CS_NULLTERM, CS_UNUSED) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_command() failed (cmd=%x, statement=%s, imp_sth=%x)\n", imp_sth->cmd, imp_sth->statement, imp_sth); return -2; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_command() OK\n"); } if (ct_send(imp_sth->cmd) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_send() failed\n"); return -2; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_send() OK\n"); imp_sth->exec_done = 1; if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> set inUse flag\n"); imp_dbh->inUse = 1; } return 0; } int syb_st_execute(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; int restype; #if 0 /* XXX */ if(DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_sth))) { /* Need to detect a possible simultaneous call here and either inhibit it, or open a new connection */ } #endif imp_dbh->lasterr = 0; imp_dbh->lastsev = 0; if (imp_sth->type == 2) { return syb_blk_execute(imp_dbh, imp_sth, sth); } if (!imp_sth->exec_done) { /* bind parameters if there are any */ CS_INT rows; int i; SV **phs_svp; char namebuf[30]; int namelen; phs_t *phs; int num_params = (int) DBIc_NUM_PARAMS(imp_sth); int foundOutput = 0; boundparams_t *params = 0; /* malloc the maximum possible size for output parameters */ params = malloc(sizeof(boundparams_t) * num_params ); for (i = 1; i <= num_params; ++i) { sprintf(namebuf, ":p%d", i); namelen = strlen(namebuf); phs_svp = hv_fetch(imp_sth->all_params_hv, namebuf, namelen, 0); if (phs_svp == NULL) croak("Can't bind unknown placeholder '%s'", namebuf); phs = (phs_t*) SvPVX(*phs_svp); /* placeholder struct */ /* if the parameter is an output and it is bound as an inout, * store the pointer, so we can use it for ct_bind */ if ( phs->is_inout && phs->is_boundinout ) { params[foundOutput].phs = phs; foundOutput++; } if (!_dbd_rebind_ph(sth, imp_sth, phs, 0)) { free(params); return -2; } } if (cmd_execute(sth, imp_sth) != 0) { free(params); return -2; } /* if we have output parameters, fetch the result */ if( foundOutput > 0 ) { while (ct_results(imp_sth->cmd, &restype) == CS_SUCCEED && restype != CS_CMD_DONE) { if (restype == CS_CMD_FAIL) { free(params); return -2; } /* ignore restype == CS_STATUS_RESULT */ if (restype == CS_PARAM_RESULT) { /* Since we have a parameter result, bind all the output parameters */ for (i = 0; i < foundOutput; i++) { phs = params[i].phs; CS_DATAFMT datafmt; /* find the maxlenght through ct_describe */ if( ct_describe(imp_sth->cmd, i+1, &datafmt) != CS_SUCCEED) croak("ct_describe() failed"); phs->datafmt.maxlength = datafmt.maxlength; /* Force to string with SvPOK_only (maybe use SvPV_force ). */ SvPOK_only(phs->sv); /* grow the output SV to the max length fetch will return */ SvGROW(phs->sv, phs->datafmt.maxlength ); /* bind the SV through pointer to the physical string in the SV, * store the returned length in the params array for adjustment after fetch */ if( ct_bind(imp_sth->cmd, i+1, &phs->datafmt, SvPVX(phs->sv), ¶ms[i].len, 0) != CS_SUCCEED ) syb_set_error(imp_dbh, -1, "ct_bind() for output param failed!"); } } /* fetch all results */ while((ct_fetch(imp_sth->cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows)) == CS_SUCCEED) { } } /* set the output SV to the correct lenght */ for (i = 0; i < foundOutput; i++) { SvCUR_set(params[i].phs->sv, params[i].len); } } free(params); } restype = st_next_result(sth, imp_sth); if (restype == CS_CMD_FAIL) return -2; return imp_sth->numRows; } int syb_st_cancel(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; CS_CONNECTION *connection = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_cancel() -> ct_cancel(CS_CANCEL_ATTN)\n"); if (ct_cancel(connection, NULL, CS_CANCEL_ATTN) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } return 1; } static int fix_fbav(imp_sth_t *imp_sth, int num_fields, AV *av) { #if 0 int clear_cache = 0; int i; D_imp_dbh_from_sth; if(DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " fix_fbav() -> num_fields = %d, numCols = %d\n", num_fields, imp_sth->numCols); /* XXX The code in the if() below is likely to break with new versions of DBI!!! */ if(num_fields < imp_sth->numCols) { int isReadonly = SvREADONLY(av); ++clear_cache; if(isReadonly) SvREADONLY_off(av); /* DBI sets this readonly */ i = imp_sth->numCols - 1; while(i >= num_fields) av_store(av, i--, newSV(0)); num_fields = AvFILL(av)+1; if(isReadonly) SvREADONLY_on(av); /* protect against shift @$row etc */ } else if(num_fields> imp_sth->numCols) { int isReadonly = SvREADONLY(av); if(isReadonly) SvREADONLY_off(av); /* DBI sets this readonly */ av_fill(av, imp_sth->numCols - 1); num_fields = AvFILL(av)+1; if(isReadonly) SvREADONLY_on(av); /* protect against shift @$row etc */ ++clear_cache; } return clear_cache; #else return 1; #endif } static void clear_cache(SV *sth, imp_sth_t *imp_sth) { dTHX; /* Code from DBI::DBD */ /* Clear cached statement handle attributes, if necessary */ hv_delete((HV*) SvRV(sth), "NAME", 4, G_DISCARD); hv_delete((HV*) SvRV(sth), "NULLABLE", 8, G_DISCARD); hv_delete((HV*) SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD); hv_delete((HV*) SvRV(sth), "PRECISION", 9, G_DISCARD); hv_delete((HV*) SvRV(sth), "SCALE", 5, G_DISCARD); hv_delete((HV*) SvRV(sth), "TYPE", 4, G_DISCARD); } AV * syb_st_fetch(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_INT num_fields; int ChopBlanks; int i; AV *av; CS_RETCODE retcode; CS_INT rows_read, restype; int len; /* Check that execute() was executed sucessfully. This also implies */ /* that describe() executed sucessfuly so the memory buffers */ /* are allocated and bound. */ if (!DBIc_is(imp_sth, DBIcf_ACTIVE) || !imp_sth->exec_done) { return Nullav; } /* ** Find out how many columns there are in this result set. */ retcode = ct_res_info(cmd, CS_NUMDATA, &num_fields, CS_UNUSED, NULL); if (retcode != CS_SUCCEED) { croak(" syb_st_fetch(): ct_res_info() failed"); } ChopBlanks = DBIc_has(imp_sth, DBIcf_ChopBlanks); TryAgain: retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read); av = DBIc_DBISTATE(imp_dbh)->get_fbav(imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> ct_fetch() = %d (%d rows, %d cols)\n", retcode, rows_read, num_fields); } switch (retcode) { case CS_ROW_FAIL: /* if LongTruncOK is off, then discard this row */ if (!DBIc_is(imp_sth, DBIcf_LongTruncOk)) goto TryAgain; case CS_SUCCEED: for (i = 0; i < num_fields; ++i) { SV *sv = AvARRAY(av)[i]; /* Note: we (re)use the SV in the AV */ len = 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { /*char *text = neatsvpv(phs->sv,0);*/ PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> %d/%d/%d\n", i, imp_sth->coldata[i].valuelen, imp_sth->coldata[i].type); } /* If we're beyond the number of items in this result set or: the data is null or: noBindBlob is set and the data type is IMAGE or TEXT then: set sv to undef */ if (i >= imp_sth->numCols || imp_sth->coldata[i].indicator == CS_NULLDATA || (imp_sth->noBindBlob && (imp_sth->datafmt[i].datatype == CS_TEXT_TYPE || imp_sth->datafmt[i].datatype == CS_IMAGE_TYPE))) { /* NULL data */ (void) SvOK_off(sv); } else { #define DATE_BUFF_LEN 50 char buff[DATE_BUFF_LEN]; /* used for date conversions */ switch (imp_sth->coldata[i].type) { case CS_IMAGE_TYPE: case CS_TEXT_TYPE: case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: len = imp_sth->coldata[i].valuelen; sv_setpvn(sv, imp_sth->coldata[i].value.c, len); if ((imp_sth->coldata[i].realType == CS_CHAR_TYPE || imp_sth->coldata[i].realType == CS_LONGCHAR_TYPE) && ChopBlanks) { char *p = SvEND(sv); int len = SvCUR(sv); while (len && *--p == ' ') --len; if (len != SvCUR(sv)) { SvCUR_set(sv, len); *SvEND(sv) = '\0'; } } #if defined(DBD_CAN_HANDLE_UTF8) if (imp_dbh->enable_utf8 && (imp_sth->coldata[i].realType == CS_UNICHAR_TYPE #if defined(CS_UNITEXT_TYPE) || imp_sth->coldata[i].realType == CS_UNITEXT_TYPE #endif )) { U8 *value = SvPV_nolen(sv); STRLEN len = SvCUR(sv); SvUTF8_off(sv); if (is_high_bit_set(value, len) && is_utf8_string(value, len)) { SvUTF8_on(sv); } } #endif break; case CS_FLOAT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.f); break; case CS_INT_TYPE: sv_setiv(sv, imp_sth->coldata[i].value.i); break; #if defined(CS_UINT_TYPE) case CS_UINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.ui); break; #endif #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.bi); break; #endif #if defined(CS_UBIGINT_TYPE) case CS_UBIGINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.ubi); break; #endif case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: if (imp_dbh->useBin0x) { /* Add 0x to the front */ sv_setpv(sv, "0x"); } else { /* stick in empty string so the concat works */ sv_setpv(sv, ""); } len = imp_sth->coldata[i].valuelen; sv_catpvn(sv, imp_sth->coldata[i].value.c, len); break; case CS_DATETIME_TYPE: len = datetime2str(&imp_sth->coldata[i].value.dt, &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: len = date2str(&imp_sth->coldata[i].value.d, &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; case CS_TIME_TYPE: len = time2str(&imp_sth->coldata[i].value.t, &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; #endif default: croak("syb_st_fetch: unknown datatype: %d, column %d", imp_sth->datafmt[i].datatype, i + 1); } } } break; case CS_FAIL: /* ohmygod */ /* FIXME: Should we call ct_cancel() here, or should we let the programmer handle it? */ if (ct_cancel(imp_dbh->connection, NULL, CS_CANCEL_ALL) == CS_FAIL) { ct_close(imp_dbh->connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } return Nullav; break; case CS_END_DATA: /* we've seen all the data for this result set. So see if this is the end of the result sets */ restype = st_next_result(sth, imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> st_next_results() == %d\n", restype); if (restype == CS_CMD_DONE || restype == CS_CMD_FAIL) { return Nullav; } else { /* XXX What to do here??? */ /* if(fix_fbav(imp_sth, num_fields, av)) clear_cache(sth, imp_sth);*/ if (restype == CS_COMPUTE_RESULT) { goto TryAgain; } imp_sth->moreResults = 1; } return Nullav; break; case -4: /*TDS_INVALID_PARAMETER:*/ /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "TDS_INVALID_PARAMETER from ct_fetch", Nullch, Nullch); return Nullav; case -6: /* TDS_WRONG_STATE: */ /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "TDS_WRONG_STATE from ct_fetch", Nullch, Nullch); return Nullav; case CS_CANCELED: /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "Canceled", Nullch, Nullch); return Nullav; default: warn("ct_fetch() returned an unexpected retcode %ld", (long) retcode); /* treat as a failure to avoid risk of an endless loop */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "Unexpected retcode from ct_fetch", Nullch, Nullch); return Nullav; } if (imp_dbh->row_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newRV((SV*) av))); PUTBACK; if ((count = perl_call_sv(imp_dbh->row_cb, G_SCALAR)) != 1) croak("An error handler can't return a LIST."); SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then we don't return the result set to the caller, so instead try to fetch the next row... */ if (retval == 0) goto TryAgain; } return av; } #if defined(DBD_CAN_HANDLE_UTF8) static int is_high_bit_set(const unsigned char *val, STRLEN size) { while (*val && size--) if (*val++ & 0x80) return 1; return 0; } #endif #if defined(NO_BLK) static int sth_blk_finish(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { return 1; } #else static int sth_blk_finish(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " sth_blk_finish() -> Checking for pending rows\n"); /* If there are any pending rows they should be rolled back, based on the principle that only *explicitly* commited data should be kept. */ if (imp_sth->bcpRows > 0) { if (DBIc_WARN(imp_dbh)) { warn("finish: %d uncommited rows will be rolled back", imp_sth->bcpRows); } syb_blk_done(imp_sth, CS_BLK_CANCEL); } else if (imp_sth->bcpRows == 0) { syb_blk_done(imp_sth, CS_BLK_ALL); } blkCleanUp(imp_sth, imp_dbh); /* Reset autocommit for this handle (see syb_blk_init()) */ DBIc_set(imp_dbh, DBIcf_AutoCommit, imp_sth->bcpAutoCommit); toggle_autocommit(NULL, imp_dbh, imp_sth->bcpAutoCommit); clear_sth_flags(sth, imp_sth); imp_dbh->imp_sth = NULL; return 1; } #endif int syb_st_finish(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_CONNECTION *connection; if (imp_sth->bcp_desc) { return sth_blk_finish(imp_dbh, imp_sth, sth); } connection = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; /* The SvOK() test is from Henry Asseily. It is there to avoid a possible infinite loop in the case where the handle is active, but has been invalidated by OPenSwitch. */ /* Changed to check imp_dbh->lasterr instead */ /* if (imp_dbh->flushFinish && !(SvTRUE(DBIc_ERR(imp_dbh)))) { */ /* if (imp_dbh->flushFinish && !imp_dbh->lasterr) { */ /* It is believed that the fixes applied to st_next_result() makes the imp_dbh->lasterr check unnecessary */ if (imp_dbh->flushFinish) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> flushing\n"); DBIh_CLEAR_ERROR(imp_sth); /* so syb_st_fetch can tell us when something goes wrong */ while (DBIc_ACTIVE(imp_sth) && !imp_dbh->isDead && imp_sth->exec_done && !SvTRUE(DBIc_ERR(imp_sth))) { AV *retval; do { retval = syb_st_fetch(sth, imp_sth); } while (retval && retval != Nullav); } } else { if (DBIc_ACTIVE(imp_sth)) { #if defined(ROGUE) if(DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> ct_cancel(CS_CANCEL_CURRENT)\n"); if(ct_cancel(NULL, imp_sth->cmd, CS_CANCEL_CURRENT) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } #else if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> ct_cancel(CS_CANCEL_ALL)\n"); if (ct_cancel(connection, NULL, CS_CANCEL_ALL) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } #endif } } clear_sth_flags(sth, imp_sth); DBIc_ACTIVE_off(imp_sth); return 1; } static void dealloc_dynamic(imp_sth_t *imp_sth) { dTHX; CS_RETCODE ret; CS_INT restype; if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_dynamic(CS_DEALLOC) for %s\n", imp_sth->dyn_id); ret = ct_dynamic(imp_sth->cmd, CS_DEALLOC, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED); if (ret != CS_SUCCEED) { if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf( DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_dynamic(CS_DEALLOC) for %s FAILED\n", imp_sth->dyn_id); return; } ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) { if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_send(CS_DEALLOC) for %s FAILED\n", imp_sth->dyn_id); return; } while (ct_results(imp_sth->cmd, &restype) == CS_SUCCEED) ; if (imp_sth->all_params_hv) { HV *hv = imp_sth->all_params_hv; SV *sv; char *key; I32 retlen; hv_iterinit(hv); while ((sv = hv_iternextsv(hv, &key, &retlen)) != NULL) { if (sv != &PL_sv_undef) { phs_t *phs_tpl = (phs_t*) (void*) SvPVX(sv); sv_free(phs_tpl->sv); } } sv_free((SV*) imp_sth->all_params_hv); } if (imp_sth->out_params_av) sv_free((SV*) imp_sth->out_params_av); imp_sth->all_params_hv = NULL; imp_sth->out_params_av = NULL; } void syb_st_destroy(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; CS_RETCODE ret; dTHX; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy: called on %x...\n", imp_sth); if (PL_dirty) { DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy: dirty set, skipping\n"); return; } if (DBIc_ACTIVE(imp_dbh)) if (!strncmp(imp_sth->dyn_id, "DBD", 3)) { dealloc_dynamic(imp_sth); } /* moved from the prepare() call - as we need to have this around to re-execute non-dynamic statements... */ if (imp_sth->statement != NULL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): freeing imp_sth->statement\n"); } Safefree(imp_sth->statement); imp_sth->statement = NULL; imp_dbh->sql = NULL; } cleanUp(imp_sth); if (imp_sth->cmd) { /* Gene Ressler says that this call can fail because we've already dropped the connection. I'm not sure if this is really a problem or if it can be ignored. XXX */ if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_cmd_drop() -> CS_COMMAND %x\n", imp_sth->cmd); ret = ct_cmd_drop(imp_sth->cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): cmd dropped: %d\n", ret); } } /* reset BLK data, if needed */ if (imp_sth->bcp_desc) { /* XXX Should we call blk_done(CS_BLK_ALL) here??? */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): blkCleanUp()\n"); sth_blk_finish(imp_dbh, imp_sth, sth); } if (imp_sth->connection) { ret = ct_close(imp_sth->connection, CS_FORCE_CLOSE); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): connection closed: %d\n", ret); } ct_con_drop(imp_sth->connection); } else { if (DBIc_ACTIVE(imp_sth)) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): reset inUse flag\n"); } imp_dbh->inUse = 0; } } DBIc_ACTIVE_off(imp_sth); /* Don't want DBI warning about freeing active handle */ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ } int syb_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset) { return 1; } int syb_ct_get_data(SV *sth, imp_sth_t *imp_sth, int column, SV *bufrv, int buflen) { dTHX; CS_COMMAND *cmd = imp_sth->cmd; CS_VOID *buffer; /* CS_INT buflen = imp_sth->datafmt[column-1].maxlength; */ CS_INT outlen; CS_RETCODE ret; SV *bufsv; if (buflen == 0) buflen = imp_sth->datafmt[column - 1].maxlength; if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_get_data(%d): buflen = %d\n", column, buflen); /* Fix PR/444: segfault if passed a non-reference SV for buffer */ if (!SvROK(bufrv)) { warn("ct_get_data: buffer parameter is not a reference!"); return 0; } bufsv = SvRV(bufrv); Newz(902, buffer, buflen, char); ret = ct_get_data(cmd, column, (CS_VOID*) buffer, buflen, &outlen); if (outlen) { sv_setpvn(bufsv, buffer, outlen); } else { sv_setsv(bufsv, &PL_sv_undef); } if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_get_data(%d): got %d bytes (ret = %d)\n", column, outlen, ret); Safefree(buffer); return outlen; } int syb_ct_prepare_send(SV *sth, imp_sth_t *imp_sth) { return ct_command(imp_sth->cmd, CS_SEND_DATA_CMD, NULL, CS_UNUSED, CS_COLUMN_DATA) == CS_SUCCEED; } int syb_ct_finish_send(SV *sth, imp_sth_t *imp_sth) { CS_RETCODE retcode; CS_INT restype; D_imp_dbh_from_sth; retcode = ct_send(imp_sth->cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_send() = %d\n", retcode); if (retcode != CS_SUCCEED) { return 0; } while ((retcode = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_results(%d) = %d\n", restype, retcode); if (restype == CS_PARAM_RESULT) { CS_DATAFMT datafmt; CS_INT count; retcode = ct_describe(imp_sth->cmd, 1, &datafmt); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_describe() failed\n"); return 0; } datafmt.maxlength = sizeof(imp_dbh->iodesc.timestamp); datafmt.format = CS_FMT_UNUSED; if ((retcode = ct_bind(imp_sth->cmd, 1, &datafmt, (CS_VOID *) imp_dbh->iodesc.timestamp, &imp_dbh->iodesc.timestamplen, NULL)) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_bind() failed\n"); return 0; } retcode = ct_fetch(imp_sth->cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &count); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_fetch() failed\n"); return 0; } /* success... so cancel the rest of this result set */ retcode = ct_cancel(NULL, imp_sth->cmd, CS_CANCEL_CURRENT); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_fetch() failed\n"); return 0; } } } return 1; } int syb_ct_send_data(SV *sth, imp_sth_t *imp_sth, char *buffer, int size) { dTHX; if (DBIc_DBISTATE(imp_sth)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_send_data(): sending buffer size %d bytes\n", size); return ct_send_data(imp_sth->cmd, buffer, size) == CS_SUCCEED; } int syb_ct_data_info(SV *sth, imp_sth_t *imp_sth, int action, int column, SV *attr) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_RETCODE ret; if (action == CS_SET) { /* we expect the app to maybe modify certain fields of the CS_IODESC struct. This is done via the attr hash that is passed in here */ if (attr && attr != &PL_sv_undef && SvROK(attr)) { SV **svp; svp = hv_fetch((HV*) SvRV(attr), "total_txtlen", 12, 0); if (svp && SvGMAGICAL(*svp)) /* eg if from tainted expression */ mg_get(*svp); if (svp && SvIOK(*svp)) imp_dbh->iodesc.total_txtlen = SvIV(*svp); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): set total_txtlen to %d\n", imp_dbh->iodesc.total_txtlen); svp = hv_fetch((HV*) SvRV(attr), "log_on_update", 13, 0); if (svp && SvGMAGICAL(*svp)) /* eg if from tainted expression */ mg_get(*svp); if (svp && SvIOK(*svp)) imp_dbh->iodesc.log_on_update = SvIV(*svp); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): set log_on_update to %d\n", imp_dbh->iodesc.log_on_update); } } if (action == CS_SET) { column = CS_UNUSED; } else { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): get IODESC for column %d\n", column); } ret = ct_data_info(cmd, action, column, &imp_dbh->iodesc); if (action == CS_GET && DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): ret = %d, total_txtlen = %d\n", ret, imp_dbh->iodesc.total_txtlen); } else if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): ret = %d\n", ret); } return ret == CS_SUCCEED; } /* Borrowed from DBD::ODBC */ typedef struct { const char *str; unsigned len :8; unsigned array :1; unsigned filler :23; } T_st_params; #define s_A(str) { str, sizeof(str)-1 } static T_st_params S_st_fetch_params[] = { s_A("NUM_OF_PARAMS"), /* 0 */ s_A("NUM_OF_FIELDS"), /* 1 */ s_A("NAME"), /* 2 */ s_A("NULLABLE"), /* 3 */ s_A("TYPE"), /* 4 */ s_A("PRECISION"), /* 5 */ s_A("SCALE"), /* 6 */ s_A("syb_more_results"), /* 7 */ s_A("LENGTH"), /* 8 */ s_A("syb_types"), /* 9 */ s_A("syb_result_type"), /* 10 */ s_A("LongReadLen"), /* 11 */ s_A("syb_proc_status"), /* 12 */ s_A("syb_do_proc_status"), /* 13 */ s_A("syb_no_bind_blob"), /* 14 */ s_A("CursorName"), /* 15 - PR/394 */ s_A(""), /* END */ }; static T_st_params S_st_store_params[] = { s_A("syb_do_proc_status"), /* 0 */ s_A("syb_no_bind_blob"), /* 1 */ s_A(""), /* END */ }; #undef s_A SV * syb_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); int i; SV *retsv = NULL; T_st_params *par; for (par = S_st_fetch_params; par->len > 0; par++) if (par->len == kl && strEQ(key, par->str)) break; if (par->len <= 0) return Nullsv; /* NUM_OF_PARAMS is handled by DBI, and the answer is available even if done_desc is not set. Hence we need to handle this here rather than in the switch() below. Fixes PR 591, patch supplied by machj@ders.cz */ if (par - S_st_fetch_params == 0) return Nullsv; /* handled by DBI */ if (!imp_sth->done_desc && (par - S_st_fetch_params) < 10) { /* Because of the way Sybase returns information on returned values in a SELECT statement we can't call describe() here. */ /* Changed Nullsv to PL_sv_undef here to fix PR 541. */ return Nullsv; } i = DBIc_NUM_FIELDS(imp_sth); switch (par - S_st_fetch_params) { AV *av; case 0: /* NUM_OF_PARAMS */ return Nullsv; /* handled by DBI */ case 1: /* NUM_OF_FIELDS */ retsv = newSViv(i); break; case 2: /* NAME */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, newSVpv(imp_sth->datafmt[i].name, 0)); break; case 3: /* NULLABLE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, (imp_sth->datafmt[i].status & CS_CANBENULL) ? newSViv(1) : newSViv(0)); break; case 4: /* TYPE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, newSViv(map_syb_types(imp_sth->coldata[i].realType))); break; case 5: /* PRECISION */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, newSViv( imp_sth->datafmt[i].precision ? imp_sth->datafmt[i].precision : imp_sth->coldata[i].realLength)); break; case 6: /* SCALE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { switch (imp_sth->coldata[i].realType) { case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: av_store(av, i, newSViv(imp_sth->datafmt[i].scale)); break; default: av_store(av, i, newSVsv(&PL_sv_undef)); } } break; case 7: retsv = newSViv(imp_sth->moreResults); break; case 8: av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, newSViv(imp_sth->coldata[i].realLength)); break; case 9: /* syb_types: native datatypes */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) av_store(av, i, newSViv(imp_sth->coldata[i].realType)); break; case 10: retsv = newSViv(imp_sth->lastResType); break; case 11: retsv = newSViv(DBIc_LongReadLen(imp_sth)); break; case 12: retsv = newSViv(imp_sth->lastProcStatus); break; case 13: retsv = newSViv(imp_sth->doProcStatus); break; case 14: retsv = newSViv(imp_sth->noBindBlob); break; case 15: retsv = &PL_sv_undef; /* fix for PR/394 */ break; default: return Nullsv; } if (retsv == &PL_sv_no || retsv == &PL_sv_yes || retsv == &PL_sv_undef) return retsv; return sv_2mortal(retsv); } int syb_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); T_st_params *par; if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_st_STORE(): key = %s\n", key); } for (par = S_st_store_params; par->len > 0; par++) if (par->len == kl && strEQ(key, par->str)) break; if (par->len <= 0) return FALSE; if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_st_STORE(): storing %d for key = %s\n", SvTRUE(valuesv), key); } switch (par - S_st_store_params) { case 0: if (SvTRUE(valuesv)) { imp_sth->doProcStatus = 1; } else { imp_sth->doProcStatus = 0; } return TRUE; case 1: if (SvTRUE(valuesv)) { imp_sth->noBindBlob = 1; } else { imp_sth->noBindBlob = 0; } return TRUE; } return FALSE; } static int datetime2str(CS_DATETIME *dt, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, dt, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; cs_dt_crack(context, CS_DATETIME_TYPE, dt, &rec); if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } #if defined(CS_DATE_TYPE) static int date2str(CS_DATE *d, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, d, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; cs_dt_crack(context, CS_DATE_TYPE, d, &rec); if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } static int time2str(CS_TIME *t, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, t, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; cs_dt_crack(context, CS_TIME_TYPE, t, &rec); if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } #endif static CS_NUMERIC to_numeric(char *str, CS_LOCALE *locale, CS_DATAFMT *datafmt, int type) { CS_NUMERIC mn; CS_DATAFMT srcfmt; CS_INT reslen; char *p; memset(&mn, 0, sizeof(mn)); if (!str || !*str) str = "0"; /* warn("to_money(%s)\n", str); */ memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.maxlength = strlen(str); srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = locale; if (type) { /* RPC call */ if ((p = strchr(str, '.'))) datafmt->scale = strlen(p + 1); else datafmt->scale = 0; datafmt->precision = strlen(str); } else { /* dynamic SQL */ /* If the number of digits after the . is larger than the 'scale' value in datafmt, then we need to adjust it. Otherwise the conversion fails */ if ((p = strchr(str, '.'))) { int len = strlen(++p); if (len > datafmt->scale) { if (p[datafmt->scale] < '5') p[datafmt->scale] = 0; else { p[datafmt->scale] = 0; len = strlen(str); while (len--) { if (str[len] == '.') continue; if (str[len] < '9') { str[len]++; break; } str[len] = '0'; if (len == 0) { char buf[64]; buf[0] = '1'; buf[1] = 0; strcat(buf, str); strcpy(str, buf); break; } } } } } } if (cs_convert(context, &srcfmt, str, datafmt, &mn, &reslen) != CS_SUCCEED) warn("cs_convert failed (to_numeric(%s))", str); if (reslen == CS_UNUSED) warn("conversion failed: to_numeric(%s)", str); return mn; } static CS_MONEY to_money(char *str, CS_LOCALE *locale) { CS_MONEY mn; CS_DATAFMT srcfmt, destfmt; CS_INT reslen; memset(&mn, 0, sizeof(mn)); if (!str) return mn; memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.maxlength = strlen(str); srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = locale; memset(&destfmt, 0, sizeof(destfmt)); destfmt.datatype = CS_MONEY_TYPE; destfmt.locale = locale; destfmt.maxlength = sizeof(CS_MONEY); destfmt.format = CS_FMT_UNUSED; if (cs_convert(context, &srcfmt, str, &destfmt, &mn, &reslen) != CS_SUCCEED) warn("cs_convert failed (to_money(%s))", str); if (reslen == CS_UNUSED) warn("conversion failed: to_money(%s)", str); return mn; } static CS_BINARY * to_binary(char *str, STRLEN *outlen) { CS_BINARY *b, *b_ptr; char s[3], *strtol_end; STRLEN i, b_len; long int x; /* Advance past the 0x. We could use the value of syb_use_bin_0x to infer whether to advance or not, but it's just as easy to explicitly check. */ if (str[0] == '0' && str[1] == 'x') str += 2; /* The length of 'str' _should_ be even, but we go thru some acrobatics to handle an odd length. We won't flag it as invalid, just pretend it's okay. */ b_len = (strlen(str) + 1) / 2; b = (CS_BINARY *) safemalloc(b_len); memset(b, 0, b_len); memset(&s, '\0', 3); /* Pack the characters */ b_ptr = b; for (i = 0; i < b_len; i++, str += 2) { strncpy(s, str, 2); x = strtol(s, &strtol_end, 16); if (*strtol_end != '\0') { warn("conversion failed: invalid char '%c'", *strtol_end); break; } *b_ptr++ = x; } *outlen = b_len; return b; } static int _dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int maxlen) { dTHX; D_imp_dbh_from_sth; CS_RETCODE rc; STRLEN value_len; int i_value; double d_value; void *value; CS_NUMERIC n_value; CS_MONEY m_value; CS_INT datatype; int free_value = 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { char *text = neatsvpv(phs->sv, 0); PerlIO_printf(DBIc_LOGPIO(imp_dbh), " bind %s (%s) <== %s (", phs->name, phs->varname, text); if (SvOK(phs->sv)) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "size %ld/%ld/%ld, ", (long) SvCUR(phs->sv), (long) SvLEN(phs->sv), phs->maxlen); else PerlIO_printf(DBIc_LOGPIO(imp_dbh), "NULL, "); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "ptype %d, otype %d%s)\n", (int) SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : ""); } /* At the moment we always do sv_setsv() and rebind. */ /* Later we may optimise this so that more often we can */ /* just copy the value & length over and not rebind. */ #if 0 if (phs->is_inout) { /* XXX */ if (SvREADONLY(phs->sv)) croak(no_modify); /* phs->sv _is_ the real live variable, it may 'mutate' later */ /* pre-upgrade high to reduce risk of SvPVX realloc/move */ (void)SvUPGRADE(phs->sv, SVt_PVNV); /* ensure room for result, 28 is magic number (see sv_2pv) */ SvGROW(phs->sv, (phs->maxlen < 28) ? 28 : phs->maxlen+1); } else { /* phs->sv is copy of real variable, upgrade to at least string */ (void)SvUPGRADE(phs->sv, SVt_PV); } #else /* phs->sv is copy of real variable, upgrade to at least string */ (void) SvUPGRADE(phs->sv, SVt_PV); #endif /* At this point phs->sv must be at least a PV with a valid buffer, */ /* even if it's undef (null) */ /* Here we set phs->sv_buf, and value_len. */ /* determine the value, and length that we wish to pass to ct_param() */ datatype = phs->datafmt.datatype; if (SvOK(phs->sv)) { phs->sv_buf = SvPV(phs->sv, value_len); switch (phs->datafmt.datatype) { case CS_INT_TYPE: case CS_SMALLINT_TYPE: case CS_TINYINT_TYPE: case CS_BIT_TYPE: phs->datafmt.datatype = CS_INT_TYPE; i_value = atoi(phs->sv_buf); value = &i_value; value_len = 4; break; case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: n_value = to_numeric(phs->sv_buf, LOCALE(imp_dbh), &phs->datafmt, imp_sth->type); phs->datafmt.datatype = CS_NUMERIC_TYPE; value = &n_value; value_len = sizeof(n_value); break; case CS_MONEY_TYPE: case CS_MONEY4_TYPE: m_value = to_money(phs->sv_buf, LOCALE(imp_dbh)); phs->datafmt.datatype = CS_MONEY_TYPE; value = &m_value; value_len = sizeof(m_value); break; case CS_REAL_TYPE: case CS_FLOAT_TYPE: phs->datafmt.datatype = CS_FLOAT_TYPE; d_value = atof(phs->sv_buf); value = &d_value; value_len = sizeof(double); break; case CS_BINARY_TYPE: /* If this binary value is in hex format, with or without the leading 0x, then convert to actual binary value. Fix contributed by Tim Ayers */ phs->datafmt.datatype = CS_BINARY_TYPE; if ((phs->sv_buf[0] == '0' && phs->sv_buf[1] == 'x') || strspn( phs->sv_buf, "abcdefABCDEF0123456789") == value_len) { value = to_binary(phs->sv_buf, &value_len); /*warn("Got value = '%s'\n", value);*/ ++free_value; } else { value = phs->sv_buf; } /* value_len = SvCUR(phs->sv_buf); */ break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: phs->datafmt.datatype = CS_CHAR_TYPE; value = phs->sv_buf; value_len = CS_NULLTERM; /* PR/464: datetime values get converted to "jan 1 1900" if turned into a single space */ if (*(char*) value == 0) { value = NULL; value_len = CS_UNUSED; } break; default: phs->datafmt.datatype = CS_CHAR_TYPE; value = phs->sv_buf; /*value_len = CS_NULLTERM;*//*Allow embedded NUL bytes in strings?*/ /* PR/446: should an empty string cause a NULL, or not? */ if (*(char*) value == 0) { if (imp_dbh->bindEmptyStringNull) { value = NULL; value_len = CS_UNUSED; } else { value = " "; value_len = CS_NULLTERM; /* PR/624 */ } } break; } } else { /* it's null but point to buffer incase it's an out var */ phs->sv_buf = SvPVX(phs->sv); value_len = 0; value = NULL; } phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */ phs->maxlen = SvLEN(phs->sv) - 1; /* avail buffer space */ /* value_len has current value length */ if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " bind %s <== '%.100s' (size %d, ok %d)\n", phs->name, phs->sv_buf, (long) phs->maxlen, SvOK(phs->sv) ? 1 : 0); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " datafmt: type=%d, name=%s, status=%d, len=%d\n", phs->datafmt.datatype, phs->datafmt.name, phs->datafmt.status, value_len); PerlIO_printf(DBIc_LOGPIO(imp_dbh), " saved type: %d\n", datatype); } #if 0 /* If this handle is still active call finish()... */ if(DBIc_ACTIVE(imp_sth) && imp_sth->exec_done) { int finish = imp_dbh->flushFinish; imp_dbh->flushFinish = 1; syb_st_finish(sth, imp_sth); imp_dbh->flushFinish = finish; } #endif if (imp_sth->dyn_execed == 0) { if (imp_sth->type == 0) { if (ct_dynamic(imp_sth->cmd, CS_EXECUTE, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED) != CS_SUCCEED) return 0; } else if (imp_sth->type == 1) { if (ct_command(imp_sth->cmd, CS_RPC_CMD, imp_sth->proc, CS_NULLTERM, CS_NO_RECOMPILE) != CS_SUCCEED) { char errbuf[1024]; sprintf(errbuf, "ct_command(CS_RPC_CMD, %s) failed\n", imp_sth->proc); syb_set_error(imp_dbh, -1, errbuf); return 0; } } imp_sth->dyn_execed = 1; } if ((rc = ct_param(imp_sth->cmd, &phs->datafmt, value, value_len, 0)) != CS_SUCCEED) syb_set_error(imp_dbh, -1, "ct_param() failed!"); phs->datafmt.datatype = datatype; if (free_value && value != NULL) Safefree(value); return (rc == CS_SUCCEED); } int syb_bind_ph(SV *sth, imp_sth_t *imp_sth, SV *ph_namesv, SV *newvalue, IV sql_type, SV *attribs, int is_inout, IV maxlen) { dTHX; SV **phs_svp; STRLEN name_len; char *name; char namebuf[30]; phs_t *phs; STRLEN lna; D_imp_dbh_from_sth; #if 1 /* If this handle is still active call finish()... */ if (DBIc_ACTIVE(imp_sth) && imp_sth->exec_done) { int finish = imp_dbh->flushFinish; imp_dbh->flushFinish = 1; syb_st_finish(sth, imp_sth); imp_dbh->flushFinish = finish; } #endif /* This is the way Tim does it in DBD::Oracle to get around the tainted issue. */ if (SvGMAGICAL(ph_namesv)) /* eg if from tainted expression */ mg_get(ph_namesv); if (!SvNIOKp(ph_namesv)) { name = SvPV(ph_namesv, name_len); } if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) { sprintf(namebuf, ":p%d", (int) SvIV(ph_namesv)); name = namebuf; name_len = strlen(name); } if (SvTYPE(newvalue) > SVt_PVLV) /* hook for later array logic */ croak("Can't bind non-scalar value (currently)"); #if 0 if (SvTYPE(newvalue) == SVt_PVLV && is_inout) /* may allow later */ croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)"); #endif if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), "bind %s <== '%.200s' (attribs: %s)\n", name, SvPV(newvalue, lna), attribs ? SvPV(attribs, lna) : ""); phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0); if (phs_svp == NULL) croak("Can't bind unknown placeholder '%s'", name); phs = (phs_t*) SvPVX(*phs_svp); /* placeholder struct */ if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " parameter is output [%s]\n", is_inout ? "true" : "false" ); if (phs->sv == &PL_sv_undef) { /* first bind for this placeholder */ phs->sql_type = (sql_type) ? sql_type : SQL_CHAR; phs->ftype = map_sql_types(phs->sql_type); if (imp_sth->type == 1) { /* RPC call, must set up the datafmt struct */ if (phs->varname[0] == '@') { strcpy(phs->datafmt.name, phs->varname); phs->datafmt.namelen = strlen(phs->varname); } else phs->datafmt.namelen = 0; phs->datafmt.datatype = phs->ftype; phs->datafmt.status = phs->is_inout ? CS_RETURN : CS_INPUTVALUE; phs->datafmt.maxlength = 0; } phs->maxlen = maxlen; /* 0 if not inout */ /* phs->is_inout = is_inout; */ #if 0 if (is_inout) { phs->sv = SvREFCNT_inc(newvalue); /* point to live var */ ++imp_sth->has_inout_params; /* build array of phs's so we can deal with out vars fast */ if (!imp_sth->out_params_av) imp_sth->out_params_av = newAV(); av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp)); } #endif /* some types require the trailing null included in the length. */ phs->alen_incnull = 0; } #if 0 /* check later rebinds for any changes */ else if (is_inout || phs->is_inout) { croak("Can't rebind or change param %s in/out mode after first bind", phs->name); } #endif else if (maxlen && maxlen != phs->maxlen) { croak("Can't change param %s maxlen (%ld->%ld) after first bind", phs->name, phs->maxlen, maxlen); } if (!is_inout) { /* normal bind to take a (new) copy of current value */ if (phs->sv == &PL_sv_undef) /* (first time bind) */ phs->sv = newSV(0); sv_setsv(phs->sv, newvalue); phs->is_boundinout = 0; } else { phs->sv = SvREFCNT_inc(newvalue); /* Take a reference to the input variable */ phs->is_boundinout = 1; if (DBIc_DBISTATE(imp_sth)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_sth), " parameter is bound as inout\n"); } /* BLK binding done at execute time, in a loop */ if (imp_sth->type == 2) return 1; return 1; /* _dbd_rebind_ph(sth, imp_sth, phs, 0); */ } static CS_RETCODE fetch_data(imp_dbh_t *imp_dbh, CS_COMMAND *cmd) { dTHX; CS_RETCODE retcode; CS_INT num_cols; CS_INT i; CS_INT j; CS_INT row_count = 0; CS_INT rows_read; CS_INT disp_len; CS_DATAFMT *datafmt; ColData *coldata; char buff[1024]; /* ** Find out how many columns there are in this result set. */ if ((retcode = ct_res_info(cmd, CS_NUMDATA, &num_cols, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("fetch_data: ct_res_info() failed"); return retcode; } /* ** Make sure we have at least one column */ if (num_cols <= 0) { warn("fetch_data: ct_res_info() returned zero columns"); return CS_FAIL; } New(902, coldata, num_cols, ColData); New(902, datafmt, num_cols, CS_DATAFMT); for (i = 0; i < num_cols; i++) { if ((retcode = ct_describe(cmd, (i + 1), &datafmt[i])) != CS_SUCCEED) { warn("fetch_data: ct_describe() failed"); break; } datafmt[i].maxlength = display_dlen(&datafmt[i]) + 1; datafmt[i].datatype = CS_CHAR_TYPE; datafmt[i].format = CS_FMT_NULLTERM; New(902, coldata[i].value.c, datafmt[i].maxlength, char); if ((retcode = ct_bind(cmd, (i + 1), &datafmt[i], coldata[i].value.c, &coldata[i].valuelen, &coldata[i].indicator)) != CS_SUCCEED) { warn("fetch_data: ct_bind() failed"); break; } } if (retcode != CS_SUCCEED) { for (j = 0; j < i; j++) { Safefree(coldata[j].value.c); } Safefree(coldata); Safefree(datafmt); return retcode; } display_header(imp_dbh, num_cols, datafmt); while (((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read)) == CS_SUCCEED) || (retcode == CS_ROW_FAIL)) { row_count = row_count + rows_read; /* ** Check if we hit a recoverable error. */ if (retcode == CS_ROW_FAIL) { sprintf(buff, "Error on row %ld.\n", row_count); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); } /* ** We have a row. Loop through the columns displaying the ** column values. */ for (i = 0; i < num_cols; i++) { /* ** Display the column value */ sv_catpv(DBIc_ERRSTR(imp_dbh), coldata[i].value.c); /* ** If not last column, Print out spaces between this ** column and next one. */ if (i != num_cols - 1) { disp_len = display_dlen(&datafmt[i]); disp_len -= coldata[i].valuelen - 1; for (j = 0; j < disp_len; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } } } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); } /* ** Free allocated space. */ for (i = 0; i < num_cols; i++) { Safefree(coldata[i].value.c); } Safefree(coldata); Safefree(datafmt); /* ** We're done processing rows. Let's check the final return ** value of ct_fetch(). */ switch ((int) retcode) { case CS_END_DATA: retcode = CS_SUCCEED; break; case CS_FAIL: warn("fetch_data: ct_fetch() failed"); return retcode; break; default: /* unexpected return value! */ warn("fetch_data: ct_fetch() returned an expected retcode"); return retcode; break; } return retcode; } static int map_sql_types(int sql_type) { int ret; switch (sql_type) { case SQL_NUMERIC: case SQL_DECIMAL: ret = CS_NUMERIC_TYPE; break; case SQL_BIT: case SQL_INTEGER: case SQL_SMALLINT: ret = CS_INT_TYPE; break; case SQL_FLOAT: case SQL_REAL: case SQL_DOUBLE: ret = CS_FLOAT_TYPE; break; case SQL_BINARY: return CS_BINARY_TYPE; break; default: ret = CS_CHAR_TYPE; } return ret; } static int map_syb_types(int syb_type) { switch (syb_type) { case CS_CHAR_TYPE: return 1; case CS_BINARY_TYPE: return -2; /* case CS_LONGCHAR_TYPE: return SQL_CHAR; * XXX */ /* case CS_LONGBINARY_TYPE: return SQL_BINARY; * XXX */ case CS_TEXT_TYPE: return -1; /* XXX */ case CS_IMAGE_TYPE: return -4; /* XXX */ case CS_BIT_TYPE: return -7; case CS_TINYINT_TYPE: return -6; case CS_SMALLINT_TYPE: return 5; case CS_INT_TYPE: return 4; case CS_REAL_TYPE: return 7; case CS_FLOAT_TYPE: return 6; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: #endif case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: return 9; #if defined(CS_TIME_TYPE) case CS_TIME_TYPE: return 10; #endif case CS_MONEY_TYPE: case CS_MONEY4_TYPE: return 3; case CS_NUMERIC_TYPE: return 2; case CS_DECIMAL_TYPE: return 3; case CS_VARCHAR_TYPE: return 12; case CS_VARBINARY_TYPE: return -3; /* case CS_TIMESTAMP_TYPE: return -3; */ default: return SQL_CHAR; } } static char *my_strdup(char *string) { char *buff = safemalloc(strlen(string) + 1); strcpy(buff, string); return buff; } static void fetchKerbTicket(imp_dbh_t *imp_dbh) { dTHX; if (imp_dbh->kerbGetTicket) { dSP; SV *retval; int count; char *server = imp_dbh->server; if (!*server) { char *s = getenv("DSQUERY"); if (s && *s) { server = s; } else { server = "SYBASE"; } } ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv(server, 0))); PUTBACK; if ((count = perl_call_sv(imp_dbh->kerbGetTicket, G_SCALAR)) != 1) croak("A Kerberos Ticket handler can't return a LIST."); SPAGAIN; retval = POPs; PUTBACK; FREETMPS; LEAVE; if (SvPOK(retval)) { strncpy(imp_dbh->kerberosPrincipal, SvPVX(retval), 255); imp_dbh->kerberosPrincipal[31] = 0; } } } #if defined(NO_BLK) static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth) { return CS_SUCCEED; } #else static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth) { dTHX; CS_RETCODE ret; char table[256]; int i, num_cols; SV **svp; phs_t *phs; char name[32]; if (!getTableName(imp_sth->statement, table, 256)) { char str[512]; sprintf(str, "Can't get table name from '%.256s'", imp_sth->statement); syb_set_error(imp_dbh, -1, str); return CS_FAIL; } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_blk_init(): table=%s\n", table); } /* If AutoCommit is "officially" off here, then we need to make sure that Sybase thinks that it is *on*, otherwise the blk_init() call below will fail. */ if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) { toggle_autocommit(NULL, imp_dbh, 1); } ret = blk_alloc(imp_sth->connection ? imp_sth->connection : imp_dbh->connection, BLK_VERSION, &imp_sth->bcp_desc); if (ret != CS_SUCCEED) goto FAIL; ret = blk_props(imp_sth->bcp_desc, CS_SET, BLK_IDENTITY, (CS_VOID*) &imp_sth->bcpIdentityFlag, CS_UNUSED, NULL); if (ret != CS_SUCCEED) goto FAIL; ret = blk_init(imp_sth->bcp_desc, CS_BLK_IN, table, strlen(table)); if (ret != CS_SUCCEED) goto FAIL; num_cols = DBIc_NUM_PARAMS(imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_blk_init(): num_cols=%d, identityFlag=%d\n", num_cols, imp_sth->bcpIdentityFlag); } imp_sth->numCols = num_cols; /*Newz(902, imp_sth->datafmt, num_cols, CS_DATAFMT); */ Newz(902, imp_sth->coldata, num_cols, ColData); for (i = 1; i <= num_cols; ++i) { sprintf(name, ":p%d", i); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); memset(&phs->datafmt, 0, sizeof(CS_DATAFMT)); ret = blk_describe(imp_sth->bcp_desc, i, &phs->datafmt); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_blk_init: blk_describe()==%d col %d, type %d, status %d, length %d\n", ret, i, phs->datafmt.datatype, phs->datafmt.status, phs->datafmt.maxlength); if (ret != CS_SUCCEED) goto FAIL; } FAIL: ; if (ret != CS_SUCCEED) blkCleanUp(imp_sth, imp_dbh); else { imp_dbh->imp_sth = imp_sth; /* hack! */ /* Turn off autocommit for this handle, mainly to silence warnings from Sybase.xsi's commit() implementation */ imp_sth->bcpAutoCommit = DBIc_is(imp_dbh, DBIcf_AutoCommit); DBIc_set(imp_dbh, DBIcf_AutoCommit, 0); } return ret; } #endif #if defined(NO_BLK) static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh) { ; } #else static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh) { int i; for (i = 0; i < imp_sth->numCols; ++i) if (imp_sth->coldata[i].value.p && imp_sth->coldata[i].v_alloc) Safefree(imp_sth->coldata[i].value.p); if (imp_sth->coldata) Safefree(imp_sth->coldata); imp_sth->numCols = 0; imp_sth->coldata = NULL; imp_sth->datafmt = NULL; if (imp_sth->bcp_desc) { CS_INT ret = blk_drop(imp_sth->bcp_desc); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " blkCleanUp -> blk_drop(%d) = %d\n", imp_sth->bcp_desc, ret); imp_sth->bcp_desc = NULL; } } #endif static int getTableName(char *statement, char *table, int maxwidth) { char *ptr = safemalloc(strlen(statement) + 1); char *p; strcpy(ptr, statement); p = strtok(ptr, " "); if (!p || !*p || strncasecmp(p, "insert", 7)) goto FAIL; p = strtok(NULL, " ("); if (!p || !*p) goto FAIL; if (!strncasecmp(p, "into", 4)) p = strtok(NULL, " ("); if (!p || !*p) goto FAIL; strncpy(table, p, maxwidth); Safefree(ptr); return 1; FAIL: Safefree(ptr); return 0; } SV *syb_set_cslib_cb(SV *cb) { #if 0 /*!defined(USE_CSLIB_CB)*/ warn("Can't set a CS-Lib callback: DBD::Sybase was not built with -DUSE_CSLIB_CB"); return &PL_sv_undef; #else dTHX; SV *old = cslib_cb; if (cslib_cb == (SV*) NULL) cslib_cb = newSVsv(cb); else sv_setsv(cslib_cb, cb); return old ? old : &PL_sv_undef; #endif } /* WARNING - dbh passed in here is in some cases NULL */ static int toggle_autocommit(SV *dbh, imp_dbh_t *imp_dbh, int flag) { CS_BOOL value; CS_RETCODE ret; int current = DBIc_is(imp_dbh, DBIcf_AutoCommit); if (!imp_dbh->init_done) { imp_dbh->init_done = 1; if (DBIc_DBISTATE(imp_dbh)->debug >= 5) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " toggle_autocommit: init_done not set, no action\n"); return TRUE; } if (DBIc_DBISTATE(imp_dbh)->debug >= 5) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " toggle_autocommit: current = %s, new = %s\n", current ? "on" : "off", flag ? "on" : "off"); if (flag) { if (!current) { /* Going from OFF to ON - so force a COMMIT on any open transaction */ syb_db_commit(dbh, imp_dbh); } if (!imp_dbh->doRealTran) { value = CS_FALSE; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); } } else { if (!imp_dbh->doRealTran) { value = CS_TRUE; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); } } if (!imp_dbh->doRealTran && ret != CS_SUCCEED) { warn("Setting of CS_OPT_CHAINXACTS failed."); return FALSE; } return TRUE; } DBD-Sybase-1.14/CHANGES0100644000076500007650000005262211642076500014524 0ustar mpepplermpeppler$Id: CHANGES,v 1.88 2011/10/02 15:03:17 mpeppler Exp $ Release 1.14 Fix bad size handling for unicode data. Remove default charset setting to utf8 (this had been done in 1.11 as part of improved utf8 handling, but has negative side-effects. If unicode handling is needed then set "charset=utf8" as part of the connection string. Enforce the fact that utf8/unicode handling only works with OpenClient 15.x or later. Release 1.13 Fix for incorrect UTF8 handling when retrieving UNICODE data (Jean-Pierre Rupp). Release 1.12 Bug/Typo/Compatibility fixes with various versions of OpenClient. Experimental: Handle in/out parameters (Merijn Broeren) Release 1.11 Remove reliance on PERL_POLLUTE. Add better support for utf8 (Dave Rolsky) Release 1.10 Handle 15.x datatypes correctly. Add LONGMS date format symbol to handle microseconds for bigdatetime. Add support for CS_LONGCHAR_TYPE (Mark Aufflick) Document syb_isdead(). Handle 64bit builds with FreeTDS (Ian Grant/Hans Kristian Rosbach) Add foreign_key_info & statistics_info (Jim Radford) Change behavior of large fixed precision numeric types (money, bigint) to be converted to a string internally and returned as such to the caller (behavior similar to numeric/decimal). This can be reverted to the old behavior by defining SYB_NATIVE_NUM. Release 1.09 Behavior change: A new connection level attribute (syb_disconnect_in_child) has been added to allow automatical handling of InactiveDestroy across forks. By default in 1.09 a connection will NOT get closed if the process ID of the process that is exiting is not the same as the PID of the process that created the connection. Detect ASE error 5702 (The server is terminating this process) as a fatal error for the connection. Bug Fixes 645 - Spurious COMMIT calls sent to the dataserver during the login/connect calls. 628 - Increase size of Kerberos Principal string buffer 627 - Spurious sigset_t declaration. Release 1.08 Detect missing libblk.a library, and disable the BLK api calls if necessary. Added code to force dlopen() to use RTLD_GLOBAL. Corrected ct_option() functionality detection. Fixed incorrect handling of bind_params() (Thanks to Tim Bunce). Added serverType DSN parameter. Added tds_keepalive DSN parameter. Fixed incorrect handling of multiple result sets with DBI 1.53 and later. Re-wrote $dbh->ping() in C, it's now four times faster. Allow automated build without prompts. Improved nsql(). Added corrected handling of DATE and TIME values (ASE 12.5.2 and later). Added handling of UNSIGNED INT and BIGINT (ASE 15 and later). Added PERL_NO_GET_CONTEXT #define. Bug Fixes 624 - Empty strings incorrectly passed as NULL. 616 - Spurious error message when the login request times out. 614 - Documentation improvement for syb_xxx methods. 610 - Segfault when using signals with the threaded libraries and perl >= 5.8. Release 1.07 Changed the t/xblk.t test to lookup the charset used by the server and specify this in the connect() string. This should avoid failures when the client and server uses charsets of different sizes (utf8 vs. iso_1, for example). Better error reporting when the connection data is incorrect for the test scripts. Modified $dbh->ping() slightly. Bug Fixes 604 - Add missing mode parameter to mkdir in t/xblob.t 606 - Memory leak in the BLK API. Release 1.06 Fix off-by-one error for ISO date format. Clear error/warning when connecting to a Replication Server. Fix AutoCommit "off" behavior when CHAINED mode is turned off. Fix $dbh->begin_work() behavior. Note: This version fails 4 tests in t/xblk.t when building against the 15.0 Beta OCS libraries. Bug Fixes 582 - ISO date formatting off by one for months. 591 - NUM_OF_PARAMS isn't handled properly 593 - Connection can become unusable due a bug in get_server_version(). 597 - Prepared stored procs with placeholders return corrupted recordset on second fetch. 599 - The call to "prepare" also executes the statement. 600 - $sth->finish sometimes fails to properly clean up the handle. Release 1.05 BEHAVIOR CHANGE - $dbh->{LongReadLen} must now be called before $dbh->prepare(). Previously you could call this after the $dbh->prepare() but before the $sth->execute(). Install private statement handle methods for TEXT/IMAGE handling to avoid $h->func() calls, and update documentation. Implement experimental BLK API via prepare/execute loop. Change default "AutoCommit" off mode from explicit transactions to using the "chained" mode if it is available. Add $sth->syb_describe() call, taken from Sybase::CTlib's ct_describe(). Add ISO8601 date/time format for output. Fix $sth->finish() behavior when syb_flush_finish is turned on. Changed do { } while($sth->{syb_more_results}); idiom to use redo instead. Better/more consistent handling of multiple sth on a single dbh, and new test file. Bugs Fixed: 580 - Binding binary/varbinary values to placeholders sometimes fails. 575 - Fails three tests under Tru-64. 577 - perl Makefile.PL fails if umask is 0. 578 - Better warning for calling $dbh->{LongReadLen} if $dbh is busy. 572 - Minor documentation update for bind_param(). Release 1.04 Bugs Fixed: 566 - $sth->{NAME} fails right after prepare(). Release 1.03 Added linking of threaded Sybase libs if perl is built with threading turned on. Added CLONE() method. Minor changes to dbdimp.c to be thread-safe. Added t/thread.t test script. Changes to Makefile.PL to make configuration easier. Add support for Kerberos-based network login. Handle new library names (libsybct vs. libct). Make sure that cached statement handle attributes (NAME_lc, etc) are cleared when multiple result sets are processed. Add host and port connection properties, to allow connections to ASE servers that are not defined in the interfaces file (requires OCS 12.5.1) Add ability to dynamically increase the maximum number of connections (thanks to Ed Avis). Add ability to ignore stored proc return status in nsql() (thanks to Merijn Broeren) Fix Makefile.PL umask() issue on Win32 (thanks to Darin Delegal). Bugs Fixed: 541 - $sth->{NAME} fails right after prepare(). 551 - Tests fail when using perl 5.6.1. 556 - Add support for user-supplied SSL certificate file. 557 - type_info_all broken with ASE 11.0.x 562 - syb_flush_finish doesn't work during the connect() phase. 563 - Memory leak when syb_binary_images is set. Release 1.02 Added syb_server_version attribute. This is filled in at connect() time with the numeric version number (11.0.3.3, 12.5.1, etc) of the server that you are connected to. Bugs Fixed: 520 - t/exec.t fails on Win32. 533 - logic error in deadlock retry in nsql(). 532 - t/xblob.t test provides false positive for win32. 534 - Placeholder prepare() fails with ASE 11.0.x Release 1.01 Automatically finish() statement handles if they are re-executed before all the rows have been fetched. Added support for new tables() syntax, thanks to Stephen Wilcoxon. Added support for DATE and TIME datatypes (available in the ASE 12.5.1 release, currently undergoing beta testing). Allow user to specify a database to use for the tests instead of using "tempdb" (useful if user does not have SA privileges). Bugs Fixed: 517 - getpwnam() isn't portable. 493 - Second execute on a prepared handle fails. 487 - Add connection information to error messages. 407 - Second+ statement does not use db from "use database". Release 1.00 Added data_sources(). Allow "SQL_BINARY" placeholder parameters to be passed either as a hex string (with or without leading 0x), or as raw binary data. Bugs Fixed: 477 - segfault when servermsg_cb is called with a null connection 480 - Makefile.PL searches system dirs before PERL5LIB dirs when looking for DBI installation. 485 - Incorrect handling of large varbinary columns on fetches. 489 - (same as 497, see below). 492 - Can't compile on Win2k. 494 - Do not try to use the ocs.cfg file if it exists. 495 - Incorrect handling of parameters when using placeholders & stored procs. 497 - implicit type conversions with prepared statements often fail 503 - Binary placeholders with stored procedures. 506 - Default scriptName/hostname connect() params. 508 - DBD::Sybase doesn't build under Win2k. Release 0.95 Support for building DBD::Sybase in 64 bit mode with the 64 bit version of OpenClient on Solaris, HP-UX, AIX, etc. (note that perl itself must also be built in 64 bit mode for this to work!) Added column_info() method. Added G_EVAL flag to syb_err_handler calls. Improved syb_err_handler handling (thanks to Matthew Persico) Fixed memory leak when opening additional connections for multiple statement handles on a single database handle (thanks to Stefan Harbeck) Applied minor patch by Alex Fridman to get to build on WinNT. Force a ct_cancel() if, due to syb_do_proc_status, we force a failure on a request that could have more results pending (Blaise Lepeuple) Added syb_cancel_request_on_error attribute (see bug 471). Warning - the default value for this attribute changes the behavior of $sth->execute() when there is a failure that is detected in multi-statement requests. Added syb_bind_empty_string_as_null attribute (see bug 446) to allow user configurable empty string binding semantics (convert to single space [default] or to NULL). Bugs Fixed: 431 - fetchrow_hashref() has incorrect keys when retrieving multiple result sets. 437 - imp_sth->numRows in st_next_result not always set. 444 - Incorrect example for ct_get_data(). ct_get_data() SEGV if passed a non-reference for $image. 394 - $sth->{CursorName} fails hard. 449 - ct_get_data() limited to 32k 450 - Fix incorrect NULLABLE handling. 452 - Incorrect $sth->finish() handling in syb_flush_finish mode (thanks to Steve Willer). 443 - $sth->fetch produces error if called after $sth->execute on statement that doesn't return any rows. 411 - statement handle attributes do not change between result sets. 430 - $dbh->prepare can return undef without triggering RaiseError. 436 - Problems with make test generating errors creating Makefile.aperl. 441 - amadmin who,sqm fails while in a transaction. 446 - Empty string converts to a space (fixed by making this configurable). 448 - define strncasecmp as strnicmp for Win32 systems. 454 - syb_err_handler won't catch connect-time error. 456 - ping still fails if connection is dead. 461 - Memory leak if NOT using placeholders in selects and calling execute() multiple times. 464 - Binding an empty string for a date field causes "1/1/1900" to be inserted (instead of NULL). 469 - nsql error handling bug. 447 - syb_db_disconnect(): ct_con_drop() failed. 471 - Certain class of errors isn't detected by DBD::Sybase. Documentation changes to explain why ... WHERE (product_code = ? OR (? IS NULL AND product_code IS NULL)) doesn't work with Sybase. Release 0.94 Added optional SQL buffer argument to syb_err_handler. Interactive setting of user/server/pwd entries in PWD for "make test". Add syb_failed_db_fatal and syb_no_child_con attributes. Bugs Fixed: 408 - Add the YYYYMMDD format to _date_fmt(). 414 - Binding '' is interpreted as NULL. 415 - Fix buffer overlow in syb_db_login(). 418 - Fix incorrect handing of CS_CANCELED return code in st_next_result(). 421 - ActiveState patches. Release 0.93 Added password encryption option to connect() request (contributed by Tin Martone) Added initial nsql(). Added ct_get_data(), ct_send_data() and friends func(). Added ?-style placeholder support for exec proc statements. Changed getExtraLibs() in Makefile.PL to *not* link with -linsck or -ltli (this avoids problems if the $SYBASE/config/libtcl.cfg file has been set to load the threaded version of these libraries.) Added support for primary_key_info(). (release 0.92 was never publicly released for various reasons) Bugs Fixed: 366 ping() fails if connection has been marked dead 364 t/fail.t bug. Release 0.91 Removed artificial 1024 byte limit on char/varchar datatypes in result sets. Bug Fixes: 213: BLOBs are returned in HEX, not binary. Release 0.90 Release number sequence change: I'm dropping the "alpha" qualifier and I expect to release 1.00 fairly soon. Small Makefile.PL fix for Sybase 12.0 installation directory changes. Applied patch from Tim Ayers to allow 0x type formatting for binary data fetches (similar to what Sybase::CTlib and Sybase::DBlib allow). Fixed some t/ scripts to not fail when run against MS-SQL. Corrected the handling of timeout events in the client callback. Bug Fixes: 349: CS_NUMERIC bindings for ?-style placeholders fails for large values. 345: Dynamic statement ids get re-used. 351: prepared statements with placeholders cause handle to become unusable if *first* execute fails. 352: ping() doesn't work right in Apache::DBI (thanks to Kiriakos Georgiou) 353: syb_quoted_identifier doesn't work. 354: Calling fetch() after prepare() but no execute() fails with internal DBI error. This should also fix bug # 278 and 288. 297: type_info() returns incorrect or no data. 344: timeout doesn't work correctly. Release 0.23 Bug Fixes: 331: ? marks in comments are parsed as placeholders. 343: Errors in stored procs cause data rows from proc to be thrown away. 255: $dbh->execute does not fail it executing proc without permissions. Release 0.22 Bug Fixes: 271: execute() does not restart a transaction after a rollback or commit when running multiple execute() calls for the same statement handle. 294: SEGV on executing a prepared statement with undef values. 295: SEGV due to printf w/ null pointer 299: Missing dTHR in syb_st_prepare(). Release 0.21 Added constant() function, so that if DBD::Sybase is use'd you can access some CS_xxx_RESULT constants. Added $sth->func('syb_output_params') to allow for easier retrieval of stored proc OUTPUT parameters. Added syb_do_proc_status database attribute to allow $sth->execute to handle stored procedure return status directly, and to fail if the stored proc has a non-0 return status. This should also fix bug 255. Errors with severity 10 or below are not stored in $DBI::err anymore. Use $dbh->{syb_err_handler} to get at those warning messages. Added t/fail.t test script to better test failure modes. Setting AutoCommit on a $dbh with active statement handles is now a fatal error. Bug Fixes: 255: Memory leak for prepared statements that are not executed. 264: make test fails when building DBD::Sybase against OpenClient 10.x. 266: make test fails when building DBD::Sybase with perl 5.004_04 or earlier. 268: $sth->execute(x,y,z) (ie executing a prepare'd statment that has ?-style placeholders) does not return undef if a constraint violation occurs on the insert/update/delete. Release 0.20 Fix code to allow prepare, execute, execute, execute... on statements that don't include ?-style placeholders. Fix LENGTH/PRECISION/SCALE $sth attributes to be closer to the DBI spec. Fix core dump problem when binding undef values and having trace >= 2. Add syb_quoted_identifier connection/database handle attribute. Add syb_oc_version read-only database handle attribute, returns the Sybase library version that this binary is currently using. Added the syb_rowcount $dbh attribute. Added $sth->cancel(). Call the syb_err_handler (if one is defined) for client-side errors. Release 0.19 Setting chained/non-chained mode was still broken. syb_flush_finish mode didn't quite work right either. Added more verbose traces. Release 0.18 Add $h->{syb_chained_txn} attribute to switch between CHAINED transactions and explicit named transactions for AutoCommit=0 mode. The default is for syb_chained_txn to be off (ie 0.13 behaviour). Fixed typo in syb_db_commit() to actually commit instead of doing a rollback. Added an autocommit.t test (which still needs some work). Disable opening new connection for secondary $sth handles off of a single $dbh handle when AutoCommit == 0. Release 0.17 Fix AutoCommit = 0 problems introduced with 0.15 for MS-SQL or older Sybase server (ie TDS 4.x protocol connections). Add syb_dynamic_supported $dbh attribute to check whether the connection supports ?-style placeholders. Release 0.16 Added code to define PL_xxx symbols for pre 5.005 perls. New syb_flush_finish attribute (contributed by Steve Miller). Patch to Makefile.PL for VMS systems. Better library detection code in Makefile.PL. Release 0.15 Added an error handler callback which can intercept error messages and provide ad-hoc handling of error situations. In AutoCommit == 0 mode, use CS_OPT_CHAINXACTS mode on the server instead of issuing explicit transactions. $dbh->LongReadLen and LongTruncOK now work. First cut at the type_info() and type_info_all() methods. perl Makefile.PL now attempts to discover the libraries directly based on what it finds in $SYBASE/lib. Release 0.14 Added a 'timeout' connection attribute (contributed by Tom May) to handle timeout errors during normal processing. SQL PRINT statements are now handled by a warn() call (instead a printf() call) so that they can be caught by a __WARN__ handler. Make sure $dbh->do() returns immediately when an error is encountered. Include dbd-sybase.pod (Tim Bunce's Driver Summary for DBD::Sybase). Release 0.13 Bug fix release - binding undef (NULL) variables when using ? style placeholders didn't work. Incorrect login didn't get flagged properly (this bug was introduced in 0.11.) Added database attribute to the connect() call. Release 0.12 Bug fix release - recent versions of DBI make an array that DBD::Sybase uses read-only, causing errors when multiple result sets are retrieved where the second result set is wider (has more columns) than the first one. Release 0.11 Adds support for multiple $sth for a single $dbh (this is done by openeing a new connection in prepare() if the previously prepared statement is still active. Add support for date formatting via $dbh->func($fmt, '_date_fmt'). Added two new connect attributes: scriptName and hostname. Setting these can help identify processes in the Sybase sysprocesses table. Release 0.10 Fixes stupid Makefile.PL bug. Fixes incorrect freeing of memory when mixing prepare() statements with ? placeholders and prepare() statements without them. Release 0.09 Features: Added $sth->{syb_result_type} which returns the numerical value of the current result set. The values are defined in $SYBASE/include/cspublic.h. Made $sth->{TYPE} compatible with generic DBI values, and added $sth->{syb_types} to get the native Sybase types. Added $dbh->tables and $dbh->table_info. Finally got rid of the "Use of uninitialized value" message in connect() (thanks to Tom May for this) Fixed at least some of the memory leaks (thanks to Bryan Mawhinney) Added Sybase specific do() sub that will handle multiple result sets. Added $dbh->{syb_show_sql} and $dbh->{syb_show_eed} to add more control to error reporting. Implemented $dbh->ping() method (first cut - may need improvement!) Bug Fixes: 244: fetch gets infinite loop on sproc error 246: extended error messages go to STDOUT. Release 0.08 Features: Added ? placeholder processing. This is done by calling ct_dynamic() and friends if the statement being executed includes ? type placeholders. Bug Fixes: 210: print statements are lost 231: error messages are lost 238: reformat error messages 241: remove the necessity for users to call $sth->finish Release 0.07 Bug fixes: 204: One form of DBI->connect() fails when specifying the server name. 211: $dbh->do("use database") fails with RaiseError is true. 230: fetch() does not return correct results for certain stored procs situations. Release 0.06 Added ability to specify interfaces file in the connect() call. Added eg/dbschema.pl (ported from Sybase::DBlib). Fixed incorrect handling of AutoCommit and PrintError attributes to connect(). Bugs fixed: 203: Executing sp_helprotect fails. Release 0.05 Added explicit assignement of LDDLFLAGS and LDFLAGS in Makefile.PL to make sure that -L$SYBASE/lib comes first in the list of -L flags. Added documentation. Added ability to specify character set, language, packet size in the connect() call. Small Win32 portability patch to Makefile.PL from Matt Herbert. Bugs fixed: 198: connect failure does not return undef 199: DBD::Sybase interaction with Apache::DBI 0.74 Release 0.04 Fixed counting of active statement handles. Add implicit rollback of open transactions on disconnect. Add implicit commit when changing AutoCommit from off to on. Release 0.03 First ALPHA release of native DBD::Sybase implementation. Release 0.02 Some fixes to the emulation layer. Release 0.01 Proof of concept release - built as an emulation layer on top of Sybase::CTlib (part of sybperl 2.x). DBD-Sybase-1.14/META.yml0100644000076500007650000000045011642076573015004 0ustar mpepplermpeppler# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: DBD-Sybase version: 1.14 version_from: Sybase.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 DBD-Sybase-1.14/dbdimp.h0100644000076500007650000001116011555234074015136 0ustar mpepplermpeppler/* $Id: dbdimp.h,v 1.43 2011/04/25 08:59:17 mpeppler Exp $ Copyright (c) 1997-2011 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Based on DBD::Oracle dbdimp.h, Copyright (c) 1994,1995 Tim Bunce */ typedef struct imp_fbh_st imp_fbh_t; /* ** Maximum character buffer for displaying a column */ #define MAX_CHAR_BUF 1024 typedef struct _col_data { CS_SMALLINT indicator; CS_INT type; CS_INT realType; CS_INT realLength; union { CS_CHAR *c; CS_INT i; #if defined(CS_UINT_TYPE) CS_UINT ui; CS_BIGINT bi; CS_UBIGINT ubi; #endif CS_FLOAT f; CS_DATETIME dt; #if defined(CS_DATE_TYPE) CS_DATE d; CS_TIME t; #endif CS_MONEY mn; CS_NUMERIC num; CS_VOID *p; } value; int v_alloc; CS_INT valuelen; CS_VOID *ptr; } ColData; struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ }; #define MAX_SQL_SIZE 255 /* Define dbh implementor data structure */ struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ CS_CONNECTION *connection; CS_LOCALE *locale; CS_IODESC iodesc; char tranName[32]; int inTransaction; int doRealTran; int chainedSupported; int quotedIdentifier; int useBin0x; int binaryImage; int dateFmt; /* 0 for Sybase native, 1 for ISO8601 */ int optSupported; /* 0 if the server doesn't support ct_options() */ int lasterr; int lastsev; char uid[32]; char pwd[32]; char server[64]; char charset[64]; char packetSize[64]; char language[64]; char ifile[255]; char loginTimeout[64]; char timeout[64]; char scriptName[255]; char hostname[255]; char database[36]; char curr_db[36]; char tdsLevel[30]; char encryptPassword[10]; char kerberosPrincipal[256]; char host[64]; /* for use with CS_SERVERADDR */ char port[20]; /* for use with CS_SERVERADDR */ char maxConnect[25]; char sslCAFile[255]; char blkLogin[16]; char tds_keepalive[16]; char serverType[32]; char serverVersion[15]; char serverVersionString[255]; int isDead; SV *err_handler; SV *row_cb; SV *kerbGetTicket; int enable_utf8; int showEed; int showSql; int flushFinish; int rowcount; int doProcStatus; int deadlockRetry; int deadlockSleep; int deadlockVerbose; int nsqlNoStatus; int disconnectInChild; /* if set, then OK to disconnect in child process (even if pid different from pid that created the connection), subject to the setting of InactiveDestroy */ int noChildCon; /* Don't create child connections for simultaneous statement handles */ int failedDbUseFatal; int bindEmptyStringNull; int alwaysForceFailure; /* PR/471 */ int inUse; /* Set when the primary statement handle (the one that uses the connection referred to here) is in use. */ int pid; /* Set when the connection is opened, used checked in the DESTROY() call */ int init_done; char *sql; struct imp_sth_st *imp_sth; /* needed for BCP handling */ }; typedef struct phs_st { int ftype; int sql_type; SV *sv; int sv_type; bool is_inout; bool is_boundinout; IV maxlen; char *sv_buf; CS_DATAFMT datafmt; char varname[34]; int alen_incnull; /* 0 or 1 if alen should include null */ char name[1]; /* struct is malloc'd bigger as needed */ } phs_t; /* struct to store pointer to output parameter and returned length */ typedef struct boundparams_st { phs_t *phs; int len; } boundparams_t; /* Define sth implementor data structure */ struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ CS_CONNECTION *connection; /* set if this is a sub-connection */ CS_COMMAND *cmd; ColData *coldata; CS_DATAFMT *datafmt; int numCols; CS_INT lastResType; CS_INT numRows; int moreResults; int doProcStatus; int lastProcStatus; int noBindBlob; int retryCount; int exec_done; /* Input Details */ char dyn_id[50]; /* The id for this ct_dynamic() call */ int dyn_execed; /* true if ct_dynamic(CS_EXECUTE) has been called */ int type; /* 0 = normal, 1 => rpc */ char proc[150]; /* used for rpc calls */ char *statement; /* sql (see sth_scan) */ HV *all_params_hv; /* all params, keyed by name */ AV *out_params_av; /* quick access to inout params */ int syb_pad_empty; /* convert ""->" " when binding */ /* Select Column Output Details */ int done_desc; /* have we described this sth yet ? */ /* BCP functionality */ int bcpFlag; int bcpIdentityFlag; int bcpIdentityCol; CS_BLKDESC *bcp_desc; int bcpRows; /* incremented for each successful call to blk_rowxfer, set to -1 when blk_done(CS_BLK_CANCEL) has been called. */ int bcpAutoCommit; /* (In/)Out Parameter Details */ int has_inout_params; }; #define IMP_STH_EXECUTING 0x0001 DBD-Sybase-1.14/PWD.factory0100644000076500007650000000013007776360245015556 0ustar mpepplermpeppler# $Id: PWD.factory,v 1.1 2004/01/05 22:09:41 mpeppler Exp $ DB= SRV=SYBASE UID=sa PWD= DBD-Sybase-1.14/dbivport.h0100644000076500007650000000374010571606237015536 0ustar mpepplermpeppler/* dbivport.h Provides macros that enable greater portability between DBI versions. This file should be *copied* and included in driver distributions and #included into the source, after #include DBIXS.h New driver releases should include an updated copy of dbivport.h from the most recent DBI release. */ #ifndef DBI_VPORT_H #define DBI_VPORT_H #ifndef DBIh_SET_ERR_CHAR /* Emulate DBIh_SET_ERR_CHAR Only uses the err_i, errstr and state parameters. */ #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ sv_setiv(DBIc_ERR(imp_xxh), err_i); \ (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) #endif #ifndef DBIcf_Executed #define DBIcf_Executed 0x080000 #endif #ifndef DBIc_TRACE_LEVEL_MASK #define DBIc_TRACE_LEVEL_MASK 0x0000000F #define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) #define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) #define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) /* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) */ #define DBIc_TRACE_MATCHES(s1, s2) \ ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level */ #define DBIc_TRACE(imp, flags, flaglevel, level) \ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ || (level && DBIc_TRACE_LEVEL(imp) >= level) ) #endif #endif /* !DBI_VPORT_H */ DBD-Sybase-1.14/README.vms0100644000076500007650000000257506720553475015233 0ustar mpepplermpeppler$Id: README.vms,v 1.1 1999/05/19 15:22:37 mpeppler Exp $ From: "Craig A. Berry" To: Michael Peppler , dbi-users@fugue.com, vmsperl@perl.org Subject: DBD::Sybase 0.15 makefile.pl patch for VMS Date: Tue, 18 May 1999 17:39:59 -0500 Two minor fixes to makefile.pl were necessary. The first one avoids a double colon in the filename for MAN3PODS. The second moves the call to unixify up earlier where it needs to be. The patch at the end of this message accomplishes both. I did my build using DEC C V5.2-003 on OpenVMS Alpha V7.1 with perl 5.005_03, DBI 1.08. There is a bug in the VMS portion of Liblist.pm that messes up the order of the libraries when creating the linker options file. You can either edit sybase.opt by hand to restore the original order or apply the patch available at the following location: for 5.005_02: for 5.005_03: and a fix for File::Spec:VMS is necessary to get the test suite to even begin to work: Oh, and if you want Dynaloader to find it (pretty important), rename sybase.exe to libsybase.exe after you do the install. DBD-Sybase-1.14/CONFIG0100644000076500007650000000310207642152537014420 0ustar mpepplermpeppler# $Id: CONFIG,v 1.9 2003/03/31 23:55:11 mpeppler Exp $ # Configuration file for DBD::Sybase. # # The Makefile.PL file attempts to set reasonable defaults for the # variables in this file. # # Where is the Sybase directory on your system (include files & # libraries are expected to be found at SYBASE/include & SYBASE/lib # If not set, uses the SYBASE environment variable. SYBASE=$ENV{SYBASE}||'/opt/sybase' # Additional libraries. # Some systems require -lnsl or -lBSD. # Solaris 2.x needs -ltli # SGI IRIX needs -linsck (and may need need -ltli) # DEC OSF/1 needs -ldnet_stub and may need -lsdna and -linsck or -ltli # SunOS 4.x needs -linsck # HP-UX 10.x needs -linsck # AIX 3.2.5 needs -linsck # Linux needs -linsck # See the Sybase OpenClient Supplement for your OS/Hardware # combination. # If not set, will attempt to determine which libraries are needed by scanning the # $SYBASE/lib directory. EXTRA_LIBS= # DBI_INCLUDE # DBD::Sybase needs access to some C include files that are provided # by the DBI module. These are normally found in $Config{sitearchexp}/auto/DBI # but if they are in some other place on your system then you can specify # that directory here: # DBI_INCLUDE=/usr/local/lib/perl5/site_perl/sun4-solaris/ # BUILD_TYPE # Set this to 64 if you are building in 64 bit mode on a platform # that supports the 64bit OpenClient libraries (libct64.a, etc). # BUILD_TYPE=64 # LINKTYPE # If you wish to link DBD::Sybase statically # into perl uncomment the line below and run the make normally. Then, # when you run 'make test' a new perl binary will be built. #LINKTYPE=static DBD-Sybase-1.14/dbd-sybase.pod0100644000076500007650000005502407642152537016263 0ustar mpepplermpeppler=head1 DBD::Sybase - Driver and Database Characteristics =begin docbook =end docbook =head2 Driver Name, Version, Author and Contact Details This driver summary is for DBD::Sybase version 0.90. The driver author is Michael Peppler and he can be contacted via the dbi-users mailing list, or at mpeppler@peppler.org =head2 Supported Database Versions and Options The DBD::Sybase module supports Sybase 10.x, 11.x and 12.x, and offers limited support for accessing Microsoft MS-SQL 6.x and 7.x (as SP2) server. Assuming that OpenClient 10.x or 11.x is available DBD::Sybase can be used to connect to Sybase 4.x servers. In addition DBD::Sybase can be used in combination with the FreeTDS reimplementation of OpenClient to connect to MS-SQL or Sybase servers from platforms where Sybase OpenClient is not available. See http://www.freetds.org for details. =head2 Connect Syntax The DSN for DBD::Sybase is of the general form "dbi:Sybase:attr=value;attr=value". The following attributes are supported: =over 8 =item server Specify the Sybase server to connect to. =item database Specify the database within the server that should be made the default database (via "use $database"). =item charset Specify the client character set to use. Useful if the client's default character set is different from the server. Using this will enable automatic character conversion from one character set to the other. =item packetSize Set the network packetSize. Setting a larger packet size can increase the network throughput. See the Sybase documentation on how to use this as it may require changing the server configuration values. =item hostname Set the hostname that will be stored in the sysprocesses table for this process. =item loginTimeout Specify the number of seconds that DBI->connect() will wait for a response from the Sybase server. The default is 60 seconds. (This was added in the 0.14 release.) =item timeout Specify the number of seconds that DBD::Sybase will wait for a server response. If no response is received within that timeframe the command fails with a timeout error and the connection is marked dead. The default is to not timeout. Setting a timeout of 0 is the same as no timeout. (This was added in the 0.14 release.) =item interfaces Specify the location of an alternate I file: =item scriptName Specify the name for this connection that will be displayed in sp_who (ie in the sysprocesses table in the I column). =item hostname Specify the hostname that will be displayed by sp_who (and will be stored in the hostname column of sysprocesses).. =item tdsLevel Specify the TDS protocol level to use when connecting to the server. Valid values are CS_TDS_40, CS_TDS_42, CS_TDS_46, CS_TDS_495 and CS_TDS_50. In general this is automatically negotiated between the client and the server, but in certain cases this may need to be forced to a lower level by the client. $dbh->DBI->connect("dbi:Sybase:tdsLevel=CS_TDS_42", $user, $password); B: Setting the tdsLevel below CS_TDS_495 will disable a number of features, ?-style placeholders and CHAINED non-AutoCommit mode, in particular. =item encryptPassword Specify the use of the client password encryption supported by CT-Lib. Specify a value of 1 to use encrypted passwords. $dbh->DBI->connect("dbi:Sybase:encryptPassword=1", $user, $password); =back =head2 Numeric Data Handling The driver supports INTEGER, SMALLINT, TINYINT, MONEY, SMALLMONEY, FLOAT, REAL, DOUBLE, NUMERIC(p,s) and DECIMAL(p,s). All but the NUMERIC/DECIMAL datatypes are hardware specific, but INTEGER is always a 32bit int, SMALLINT is 16bit, TINYINT is 8bit. Precision for numeric/decimal is from 1 to 38, and scale is from 0 to 38. Numeric/decimal values are returned as perl strings by default, even if the scale is 0 and the precision is small enough to fit in an integer value. All other numbers are returned in native format. =head2 String Data Handling DBD::Sybase supports CHAR/VARCHAR/BINARY/VARBINARY, limited to 255 characters in length up to version 12.0x. As of 12.5 these datatypes can be up to 16K in size - but supporting the larger sizes requires that Open Client 12.5 or later be used. Note that the CHAR type is fixed length (blank padded). Sybase automatically converts CHAR and VARCHAR data between the character set of the server (see the syscharset system table) and the character set of the client, defined by the locale setting of the client. The BINARY and VARBINARY types are not converted. UTF-8 is supported. See the OpenClient International Developer's Guide in the Sybase OpenClient manuals for more on character set issues. Strings can be concatenated using the C<+> SQL operator. =head2 Date Data Handling Sybase supports the DATETIME and SMALLDATETIME values. A DATETIME can have a value from Jan 1 1753 to Dec 31, 9999 with a 300th of a second resolution. A SMALLDATETIME has a range of Jan 1 1900 to Jun 6 2079 with a 1 minute resolution. The current date on the server is obtained with the GETDATE() SQL function. The Sybase date format depends on the locale settings for the client. The default date format is based on the 'C' locale: Feb 16 1999 12:07PM In this same locale Sybase understands several input formats in addition to the one above: 2/16/1998 12:07PM 1998/02/16 12:07 1998-02-16 12:07 19980216 12:07 If the time portion is omitted it is set to 00:00. If the date portion is omitted it is set to Jan 1 1900. If the century is omitted it is assumed to be 1900 if the year is <50 and 2000 if the year >= 50. You can use the special _date_fmt() private method (accessed via $dbh->func()) to change the date input and output format. The formats are based on Sybase's standard conversion routines. The following subset of available formats has been implemented: LONG - Nov 15 1998 11:30:11:496AM SHORT - Nov 15 1998 11:30AM DMY4_YYYY - 15 Nov 1998 MDY1_YYYY - 11/15/1998 DMY1_YYYY - 15/11/1998 HMS - 11:30:11 Use the CONVERT() SQL function to convert date and time values from other formats. For example: UPDATE a_table SET date_field = CONVERT(datetime_field, '1999-02-21', 105) CONVERT() is a generic conversion function that can convert to/from most datatypes. See the CONVERT() function in Chapter 2 of the Sybase Reference Manual. Arithmetic on date time types is done on dates via the DATEADD(), DATEPART(), DATEDIFF() Transact SQL functions. For example: SELECT DATEDIFF(ss, date1, date2) returns the difference in seconds between date1 and date2. Sybase does not understand time zones at all, except that the GETDATE() SQL function returns the date in the time zone that the server is running in (via localtime). The following SQL expression can be used to convert an integer "seconds since 1-jan-1970" value ('unix time') to the corresponding database date time: DATEADD(ss, unixtime_field, 'Jan 1 1970') Note however that the server does not understand time zones, and will therefore give the 'server I unixtime' and not the correct value for the GMT time zone. If you know that the server runs in the same timezone as the client then you can use use Time::Local; $time_to_database = timegm(localtime($unixtime)); to convert the unixtime value before sending it to Sybase. To do the reverse, converting from a database date time value to 'unix time', you can use: DATEDIFF(ss, 'Jan 1 1970', datetime_field) The same GMT vs localtime caveat applies in this case. If you know that the server runs in the same timezone as the client you can convert the returned value to the correct GMT based value with this perl expression: use Time::Local; $time = timelocal(gmtime($time_from_database)); =head2 LONG/BLOB Data Handling Sybase supports an IMAGE and a TEXT type for LONG/BLOB data. Each type can hold up to 2GB of binary data, including nul characters. The main difference between an IMAGE and a TEXT column lies in how the client libraries treat the data on input and output. TEXT data is entered and returned "as is". IMAGE data is returned as a long hex string, and should be entered in the same way. The default size limit for TEXT/IMAGE data is 32Kb, but this can be changed by setting the LongReadLen attribute. Bind parameters can I be used to insert TEXT or IMAGE data to Sybase. =head2 Other Data Handling issues Sybase does not differentiate between CHAR and VARCHAR or BINARY and VARBINARY on returned data, so you will never get a TYPE value of SQL_VARCHAR or SQL_VARBINARY when querying the $h->{TYPE} attribute for a result set. Sybase does not automatically convert numbers to strings or strings to numbers. You need to explicitly call the C SQL function. However, placeholders don't need special handling because DBD::Sybase knows what type each placeholder needs to be. =head2 Transactions, Isolation and Locking DBD::Sybase supports transactions. The default transaction isolation level is 'Read Commited'. Sybase supports READ COMMITED, READ UNCOMMITED and SERIALIZABLE isolation levels. The level be changed per-connection or per-statement by executing a "SET TRANSACTION_ISOLATION LEVEL x", where x is 0 for READ UNCOMMITED, 1 for READ COMMITED, and 3 for SERIALIZABLE. By default a READ query will aquire a shared lock on each page that it reads. This will allow any other process to read from the table, but will block any process trying to obtain an exclusive lock (for update). The shared lock is only maintained for the time the server needs to actually read the page, not for the entire length of the SELECT operation. Sybase 11.9.2 and later include optional row-level locking ("datarows" locking) which can be set on a table by table basis. See the Sybase manuals for details. There is an explicit LOCK TABLE statement (from 11.9.2 onwards) but you should not normally need to use it. Appending "WITH HOLDLOCK" to a SELECT statement can be used to force an exclusive lock to be aquired on a table. It is usually called within a transaction. In general this call is not needed. The correct way to do a multi-table update with Sybase is to wrap the entire operation in a transaction. This will ensure that locks will be aquired in the correct order, and that no intervening action from another process will modify any rows that your operation is currently modifying. =head2 No-Table Expression Select Syntax To select a constant expression (one that doesn't involve data from a database table or view) you can select it without naming a table: SELECT getdate() =head2 Table Join Syntax Outer joins are supported using the =* (right outer join) and *= (left outer join) operators: SELECT customer_name, order_date FROM customers, orders WHERE customers.cust_id =* orders.cust_id For all rows in the customers table that have no matching rows in the orders table, Sybase returns NULL for any select list expressions containing columns from the orders table. ASE 12.0 and later supports the ANSI syntax for left/right outer joins. =head2 Table and Column Names The names of Sybase identifiers, such as tables and columns, cannot exceed 30 characters in length. The first character must be an alphabetic character (as defined by the current server character set) or _ (underscore). Subsequent characters can be alpha, and may include currency symbols, @, # and _. Identifiers can't include embedded spaces or the %, !, ^, * or . symbols. In addition, identifiers must not be on the "reserved word" list (see the Sybase documentation for a complete list). Table names or column names I be quoted if the B option is turned on. This allows the user to get around the reserved word limitation. When this option is set, character strings enclosed in double quotes are treated as identifiers, and strings enclosed in single quotes are treated as literal strings. By default identifiers are case-sensitive. This can be turned off by changing the default sort order for the B. National characters can be used in identifier names without quoting. =head2 Case sensitivity of like operator The Sybase LIKE operator is case sensitive. The UPPER function can be used to force a case insensitive match, e.g., UPPER(name) LIKE 'TOM%' (although that does prevent Sybase from making use of any index on the name column to speed up the query). =head2 Row ID Sybase does not support a pseudo 'row id' column. =head2 Automatic Key or Sequence Generation Sybase supports an IDENTITY feature for automatic key generation. Declaring a table with an IDENTITY column will generate a new value for each insert. The values are monotnonically increasing, but are not guaranteed to be sequential. To fetch the value generated and used by the last insert, you can SELECT @@IDENTITY Sybase does not support sequence generators, although ad-hoc stored procedures to generate sequence numbers are quite easy to write. See http://techinfo.sybase.com/css/techinfo.nsf/DocID/ID=860 for a complete explanation of the various possibilities. =head2 Automatic Row Numbering and Row Count Limiting Sybase does not offer a pseudocolumn that sequentially numbers the rows fetched by a select statement. However, using SET ROWCOUNT xxx will limit the number of rows returned in a SELECT statement I the number of rows affected by a DELETE, INSERT or UPDATE statement. =head2 Parameter binding Parameter binding is directly suported by Sybase. However, there are two downsides that one should be aware of: Firstly, Sybase creates an internal stored procedure for each prepare() call that includes ? style parameters. These stored procedures live in the tempdb database, and are only destroyed when the connection is closed. It is quite possible to run out of tempdb space if a lot of prepare() calls with placeholders are being made in a script. Secondly, because all the temporary stored procedures are created in tempdb this causes a potential hot-spot due to the locking of system tables in tempdb. This hot-spot is a problem in Sybase 11.5.1 and earlier, but has been lifted in 11.9.2 and later releases. The :1 placeholder style is not supported and the TYPE attribute to bind_param is currently ignored, so unsupported values don't generate a warning. However, trying to bind a TEXT or IMAGE datatype will fail. =head2 Stored procedures Sybase stored procedures are written in Transact-SQL, Sybase's procedural extension to SQL. Stored procedures are called exactly the same way as regular SQL, and can return the same types of results (ie a SELECT in the stored procedure can be retrieved with $sth->fetch). If the stored procedure returns data via OUTPUT parameters, then these must be declared first: $sth = $dbh->prepare(qq[ declare \@name varchar(50) exec getName 1234, \@name output ]); Stored procedures can't be called with bind (?) parameters - so this would be illegal: $sth = $dbh->prepare("exec my_proc ?"); $sth->execute('foo'); so use $sth = $dbh->prepare("exec my_proc 'foo'"); $sth->execute; instead. Because Sybase stored procedures almost always return more than one result set you should always make sure to use a loop until the B is 0: do { while($data = $sth->fetch) { ... } } while($sth->{syb_more_results}); =head2 Table Metadata DBD::Sybase supports the table_info method. The syscolumns table has one row per column per table. See the definitions of the Sybase system tables for details. However, the easiest method is to use the sp_help stored procedure. The easiest way to get detailed information about the indexes of a table is to use the sp_helpindex (or sp_helpkey) stored procedure. =head2 Driver-specific attributes and methods DBD::Sybase has the following driver specific database handle attributes: =over 8 =item syb_show_sql If set then the current statement is included in the string returned by $dbh->errstr. =item syb_show_eed If set, then extended error information is included in the string returned by $dbh->errstr. Extended error information include the index causing a duplicate insert to fail, for example. =item syb_err_handler This attribute is used to set an ad-hoc error handler callback (ie a perl subroutine) that gets called before the normal error handler does it's job. If this subroutine returns 0 then the error is ignored. This is useful for handling PRINT statements in Transact-SQL, for handling messages from the Backup Server, showplan output, dbcc output, etc. The subroutine is called with 7 parameters: the Sybase error number, the severity, the state, the line number in the SQL batch, the server name (if available), the stored procedure name (if available), and the message text. Example: %showplan_msgs = map { $_ => 1} (3612 .. 3615, 6201 .. 6225); sub err_handler { my($err, $sev, $state, $line, $server, $proc, $msg) = @_; if($showplan_msgs{$err}) { # it's a showplan message print SHOWPLAN "$err - $msg\n"; return 0; # This is not an error } return 1; } $dbh = DBI->connect('dbi:Sybase:server=troll', 'sa', ''); $dbh->{syb_err_handler} = \&err_handler; $dbh->do("set showplan on"); open(SHOWPLAN, ">>/var/tmp/showplan.log") || die "Can't open showplan log: $!"; $dbh->do("exec someproc"); # get the showplan trace for this proc. $dbh->disconnect; =item syb_flush_finish If $dbh->{syb_flush_finish} is set then $dbh->finish will drain any results remaining for the current command by actually fetching them. The default behaviour is to issue a ct_cancel(CS_CANCEL_ALL), but this I to cause connections to hang or to fail in certain cases (although I've never witnessed this myself.) =item syb_dynamic_supported This is a read-only attribute that returns TRUE if the dataserver you are connected to supports ?-style placeholders. Typically placeholders are not supported when using DBD::Sybase to connect to a MS-SQL server. =item syb_chained_txn If set then we use CHAINED transactions when AutoCommit is off. Otherwise we issue an explicit BEGIN TRAN as needed. The default is off. This attribute should usually be used only during the connect() call: $dbh = DBI->connect('dbi:Sybase:', $user, $pwd, {syb_chained_txn => 1}); Using it at any other time with B turned B will B on the current handle. =item syb_use_bin_0x If set, BINARY and VARBINARY values are prefixed with '0x' in the result. Default is off. =item syb_binary_images If set, IMAGE data is returned in raw binary format. Otherwise the data is converted to a long hex string. The default is off. =item syb_quoted_identifier (bool) If set, then identifiers that would normally clash with Sybase reserved words can be quoted using C<"identifier">. In this case strings must be quoted with the single quote. Default is for this attribute to be B. =item syb_rowcount (int) Setting this attribute to non-0 will limit the number of rows returned by a I statements. I've decided to handle this by returning an empty row at the end of each result set, and by setting a special Sybase attribute in $sth which you can check to see if there is more data to be fetched. The attribute is B which you should check to see if you need to re-start the C loop. To make sure all results are fetched, the basic C loop can be written like this: { while($d = $sth->fetch) { ... do something with the data } redo if $sth->{syb_more_results}; } You can get the type of the current result set with $sth->{syb_result_type}. This returns a numerical value, as defined in $SYBASE/$SYBASE_OCS/include/cspublic.h: #define CS_ROW_RESULT (CS_INT)4040 #define CS_CURSOR_RESULT (CS_INT)4041 #define CS_PARAM_RESULT (CS_INT)4042 #define CS_STATUS_RESULT (CS_INT)4043 #define CS_MSG_RESULT (CS_INT)4044 #define CS_COMPUTE_RESULT (CS_INT)4045 In particular, the return status of a stored procedure is returned as CS_STATUS_RESULT (4043), and is normally the last result set that is returned in a stored proc execution, but see the B attribute for an alternative way of handling this result type. See B elsewhere in this document for more information. If you add a use DBD::Sybase; to your script then you can use the symbolic values (CS_xxx_RESULT) instead of the numeric values in your programs, which should make them easier to read. See also the C<$sth->syb_output_params> call to handle stored procedures that B return B parameters. =head1 $sth->execute() failure mode behavior DBD::Sybase has the ability to handle multi-statement SQL commands in a single batch. For example, you could insert several rows in a single batch like this: $sth = $dbh->prepare(" insert foo(one, two, three) values(1, 2, 3) insert foo(one, two, three) values(4, 5, 6) insert foo(one, two, three) values(10, 11, 12) insert foo(one, two, three) values(11, 12, 13) "); $sth->execute; If any one of the above inserts fails for any reason then $sth->execute will return C, B the inserts that didn't fail will still be in the database, unless C is off. It's also possible to write a statement like this: $sth = $dbh->prepare(" insert foo(one, two, three) values(1, 2, 3) select * from bar insert foo(one, two, three) values(10, 11, 12) "); $sth->execute; If the second C is the one that fails, then $sth->execute will B return C. The error will get flagged after the rows from C have been fetched. I know that this is not as intuitive as it could be, but I am constrained by the Sybase API here. As an aside, I know that the example above doesn't really make sense, but I need to illustrate this particular sequence... You can also see the t/fail.t test script which shows this particular behavior. =head1 Sybase Specific Attributes There are a number of handle attributes that are specific to this driver. These attributes all start with B so as to not clash with any normal DBI attributes. =head2 Database Handle Attributes The following Sybase specific attributes can be set at the Database handle level: =over 4 =item syb_show_sql (bool) If set then the current statement is included in the string returned by $dbh->errstr. =item syb_show_eed (bool) If set, then extended error information is included in the string returned by $dbh->errstr. Extended error information include the index causing a duplicate insert to fail, for example. =item syb_err_handler (subroutine ref) This attribute is used to set an ad-hoc error handler callback (ie a perl subroutine) that gets called before the normal error handler does it's job. If this subroutine returns 0 then the error is ignored. This is useful for handling PRINT statements in Transact-SQL, for handling messages from the Backup Server, showplan output, dbcc output, etc. The subroutine is called with nine parameters: o the Sybase error number o the severity o the state o the line number in the SQL batch o the server name (if available) o the stored procedure name (if available) o the message text o the current SQL command buffer o either of the strings "client" (for Client Library errors) or "server" (for server errors, such as SQL syntax errors, etc), allowing you to identify the error type. As a contrived example, here is a port of the distinct error and message handlers from the Sybase documentation: Example: sub err_handler { my($err, $sev, $state, $line, $server, $proc, $msg, $sql, $err_type) = @_; my @msg = (); if($err_type eq 'server') { push @msg, ('', 'Server message', sprintf('Message number: %ld, Severity %ld, State %ld, Line %ld', $err,$sev,$state,$line), (defined($server) ? "Server '$server' " : '') . (defined($proc) ? "Procedure '$proc'" : ''), "Message String:$msg"); } else { push @msg, ('', 'Open Client Message:', sprintf('Message number: SEVERITY = (%ld) NUMBER = (%ld)', $sev, $err), "Message String: $msg"); } print STDERR join("\n",@msg); return 0; ## CS_SUCCEED } In a simpler and more focused example, this error handler traps showplan messages: %showplan_msgs = map { $_ => 1} (3612 .. 3615, 6201 .. 6299, 10201 .. 10299); sub err_handler { my($err, $sev, $state, $line, $server, $proc, $msg, $sql, $err_type) = @_; if($showplan_msgs{$err}) { # it's a showplan message print SHOWPLAN "$err - $msg\n"; return 0; # This is not an error } return 1; } and this is how you would use it: $dbh = DBI->connect('dbi:Sybase:server=troll', 'sa', ''); $dbh->{syb_err_handler} = \&err_handler; $dbh->do("set showplan on"); open(SHOWPLAN, ">>/var/tmp/showplan.log") || die "Can't open showplan log: $!"; $dbh->do("exec someproc"); # get the showplan trace for this proc. $dbh->disconnect; B - if you set the error handler in the DBI->connect() call like this $dbh = DBI->connect('dbi:Sybase:server=troll', 'sa', '', { syb_err_handler => \&err_handler }); then the err_handler() routine will get called if there is an error during the connect itself. This is B behavior in DBD::Sybase 0.95. =item syb_flush_finish (bool) If $dbh->{syb_flush_finish} is set then $dbh->finish will drain any results remaining for the current command by actually fetching them. The default behaviour is to issue a ct_cancel(CS_CANCEL_ALL), but this I to cause connections to hang or to fail in certain cases (although I've never witnessed this myself.) =item syb_dynamic_supported (bool) This is a read-only attribute that returns TRUE if the dataserver you are connected to supports ?-style placeholders. Typically placeholders are not supported when using DBD::Sybase to connect to a MS-SQL server. =item syb_chained_txn (bool) If set then we use CHAINED transactions when AutoCommit is off. Otherwise we issue an explicit BEGIN TRAN as needed. The default is on if it is supported by the server. This attribute should usually be used only during the connect() call: $dbh = DBI->connect('dbi:Sybase:', $user, $pwd, {syb_chained_txn => 1}); Using it at any other time with B turned B will B on the current handle. =item syb_quoted_identifier (bool) If set, then identifiers that would normally clash with Sybase reserved words can be quoted using C<"identifier">. In this case strings must be quoted with the single quote. This attribute can only be set if the database handle is idle (no active statement handle.) Default is for this attribute to be B. =item syb_rowcount (int) Setting this attribute to non-0 will limit the number of rows returned by a I