DBI-1.652/0000755000031300001440000000000015240046615011365 5ustar00merijnusersDBI-1.652/t/0000755000031300001440000000000015240046615011630 5ustar00merijnusersDBI-1.652/t/49dbd_file.t0000644000031300001440000002000615206013200013702 0ustar00merijnusers#!perl -w $|=1; use strict; use Cwd; use File::Path; use File::Spec; use Test::More; my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; my $tbl; BEGIN { $tbl = "db_". $$ . "_" }; #END { $tbl and unlink glob "${tbl}*" } use_ok ("DBI"); use_ok ("DBD::File"); do "./t/lib.pl"; my $dir = test_dir (); my $rowidx = 0; my @rows = ( [ "Hello World" ], [ "Hello DBI Developers" ], ); my $dbh; # Check if we can connect at all ok ($dbh = DBI->connect ("dbi:File:"), "Connect clean"); is (ref $dbh, "DBI::db", "Can connect to DBD::File driver"); my $f_versions = $dbh->func ("f_versions"); note $f_versions; ok ($f_versions, "f_versions"); # Check if all the basic DBI attributes are accepted ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { RaiseError => 1, PrintError => 1, AutoCommit => 1, ChopBlanks => 1, ShowErrorStatement => 1, FetchHashKeyName => "NAME_lc", }), "Connect with DBI attributes"); # Check if all the f_ attributes are accepted, in two ways ok ($dbh = DBI->connect ("dbi:File:f_ext=.txt;f_dir=.;f_encoding=cp1252;f_schema=test"), "Connect with driver attributes in DSN"); my $encoding = "iso-8859-1"; # now use dir to prove file existence ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { f_ext => ".txt", f_dir => $dir, f_schema => undef, f_encoding => $encoding, f_lock => 0, RaiseError => 0, PrintError => 0, }), "Connect with driver attributes in hash"); my $sth; ok ($sth = $dbh->prepare ("select * from t_sbdgf_53442Gz"), "Prepare select from non-existing file"); { my @msg; eval { local $SIG{__DIE__} = sub { push @msg, @_ }; $sth->execute; }; like ("@msg", qr{Cannot open .*t_sbdgf_}, "Cannot open non-existing file"); eval { note $dbh->f_get_meta ("t_sbdgf_53442Gz", "f_fqfn"); }; } SKIP: { my $fh; my $tbl2 = $tbl . "2"; my $tbl2_file1 = File::Spec->catfile ($dir, "$tbl2.txt"); open $fh, ">", $tbl2_file1 or skip; print $fh "You cannot read this anyway ..."; close $fh; my $tbl2_file2 = File::Spec->catfile ($dir, "$tbl2"); open $fh, ">", $tbl2_file2 or skip; print $fh "Neither that"; close $fh; ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (first file)"); ok (! -f $tbl2_file1, "$tbl2_file1 removed"); ok ( -f $tbl2_file2, "$tbl2_file2 exists"); ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (second file)"); ok (! -f $tbl2_file2, "$tbl2_file2 removed"); } my @tfhl; # Now test some basic SQL statements my $tbl_file = File::Spec->catfile (Cwd::abs_path ($dir), "$tbl.txt"); ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or diag $dbh->errstr; ok (-f $tbl_file, "Test table exists"); is ($dbh->f_get_meta ($tbl, "f_fqfn"), $tbl_file, "get single table meta data"); is_deeply ($dbh->f_get_meta ([$tbl, "t_sbdgf_53442Gz"], [qw(f_dir f_ext)]), { $tbl => { f_dir => $dir, f_ext => ".txt", }, t_sbdgf_53442Gz => { f_dir => $dir, f_ext => ".txt", }, }, "get multiple meta data"); # Expected: ("unix", "perlio", "encoding(iso-8859-1)") # use Data::Peek; DDumper [ @tfh ]; my @layer = grep { $_ eq "encoding($encoding)" } @tfhl; is (scalar @layer, 1, "encoding shows in layer"); my @tables = sort $dbh->func ("list_tables"); is_deeply (\@tables, [sort "000_just_testing", $tbl], "Listing tables gives test table"); ok ($sth = $dbh->table_info (), "table_info"); @tables = sort { $a->[2] cmp $b->[2] } @{$sth->fetchall_arrayref}; is_deeply (\@tables, [ map { [ undef, undef, $_, 'TABLE', 'FILE' ] } sort "000_just_testing", $tbl ], "table_info gives test table"); SKIP: { $using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 6; ok ($dbh->f_set_meta ($tbl, "f_dir", $dir), "set single meta datum"); is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set single meta datum"); ok ($dbh->f_set_meta ($tbl, { f_dir => $dir }), "set multiple meta data"); is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set multiple meta attributes"); ok($dbh->f_new_meta("t_bsgdf_3544G2z", { f_ext => undef, f_dir => $dir, }), "initialize new table (meta) with settings"); my $t_bsgdf_file = File::Spec->catfile (Cwd::abs_path ($dir), "t_bsgdf_3544G2z"); is($t_bsgdf_file, $dbh->f_get_meta ("t_bsgdf_3544G2z", "f_fqfn"), "verify create meta from scratch"); } ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl"); $rowidx = 0; SKIP: { $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; ok ($sth->execute, "execute on $tbl"); $dbh->errstr and diag $dbh->errstr; } my $uctbl = uc ($tbl); ok ($sth = $dbh->prepare ("select * from $uctbl"), "Prepare select * from $uctbl"); $rowidx = 0; SKIP: { $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; ok ($sth->execute, "execute on $uctbl"); $dbh->errstr and diag $dbh->errstr; } # ==================== ReadOnly tests ============================= ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { f_ext => ".txt", f_dir => $dir, f_schema => undef, f_encoding => $encoding, f_lock => 0, sql_meta => { $tbl => { col_names => [qw(txt)], } }, RaiseError => 0, PrintError => 0, ReadOnly => 1, }), "ReadOnly connect with driver attributes in hash"); ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl"); $rowidx = 0; SKIP: { $using_dbd_gofer and skip "method intrusion didn't work with proxying", 3; ok ($sth->execute, "execute on $tbl"); like ($_, qr{^[0-9]+$}, "TYPE is numeric") for @{$sth->{TYPE}}; like ($_, qr{^[A-Z]\w+$}, "TYPE_NAME is set") for @{$sth->{TYPE_NAME}}; $dbh->errstr and diag $dbh->errstr; } ok ($sth = $dbh->prepare ("insert into $tbl (txt) values (?)"), "prepare 'insert into $tbl'"); is ($sth->execute ("Perl rules"), undef, "insert failed intentionally"); ok ($sth = $dbh->prepare ("delete from $tbl"), "prepare 'delete from $tbl'"); is ($sth->execute (), undef, "delete failed intentionally"); is ($dbh->do ("drop table $tbl"), undef, "table drop failed intentionally"); is (-f $tbl_file, 1, "Test table not removed"); # ==================== ReadWrite again tests ====================== ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { f_ext => ".txt", f_dir => $dir, f_schema => undef, f_encoding => $encoding, f_lock => 0, RaiseError => 0, PrintError => 0, }), "ReadWrite for drop connect with driver attributes in hash"); # XXX add a truncate test ok ($dbh->do ("drop table $tbl"), "table drop"); is (-s $tbl_file, undef, "Test table removed"); # -s => size test # ==================== Nonexisting top-dir ======================== my %drh = DBI->installed_drivers; my $qer = qr{\bNo such directory}; foreach my $tld ("./non-existing", "nonexisting_folder", "/Fr-dle/hurd0k/ok$$") { is (DBI->connect ("dbi:File:", undef, undef, { f_dir => $tld, RaiseError => 0, PrintError => 0, }), undef, "Should not be able to open a DB to $tld"); like ($DBI::errstr, $qer, "Error message"); $drh{File}->set_err (undef, ""); is ($DBI::errstr, undef, "Cleared error"); my $dbh; eval { $dbh = DBI->connect ("dbi:File:", undef, undef, { f_dir => $tld, RaiseError => 1, PrintError => 0, })}; is ($dbh, undef, "connect () should die on $tld with RaiseError"); like ($@, $qer, "croak message"); like ($DBI::errstr, $qer, "Error message"); } done_testing (); sub DBD::File::Table::fetch_row ($$) { my ($self, $data) = @_; my $meta = $self->{meta}; if ($rowidx >= scalar @rows) { $self->{row} = undef; } else { $self->{row} = $rows[$rowidx++]; } return $self->{row}; } # fetch_row sub DBD::File::Table::push_names ($$$) { my ($self, $data, $row_aryref) = @_; my $meta = $self->{meta}; @tfhl = PerlIO::get_layers ($meta->{fh}); @{$meta->{col_names}} = @{$row_aryref}; } # push_names DBI-1.652/t/04mods.t0000644000031300001440000000350712127465144013133 0ustar00merijnusers#!perl -w $|=1; use strict; use Test::More tests => 12; ## ---------------------------------------------------------------------------- ## 04mods.t - ... ## ---------------------------------------------------------------------------- # Note: # the modules tested here are all marked as new and not guaranteed, so this if # they change, these will fail. ## ---------------------------------------------------------------------------- BEGIN { use_ok( 'DBI' ); # load these first, since the other two load them # and we want to catch the error first use_ok( 'DBI::Const::GetInfo::ANSI' ); use_ok( 'DBI::Const::GetInfo::ODBC' ); use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) ); use_ok( 'DBI::Const::GetInfoReturn', qw(%GetInfoReturnTypes %GetInfoReturnValues) ); } ## test GetInfoType cmp_ok(scalar(keys(%GetInfoType)), '>', 1, '... we have at least one key in the GetInfoType hash'); is_deeply( \%GetInfoType, { %DBI::Const::GetInfo::ANSI::InfoTypes, %DBI::Const::GetInfo::ODBC::InfoTypes }, '... the GetInfoType hash is constructed from the ANSI and ODBC hashes' ); ## test GetInfoReturnTypes cmp_ok(scalar(keys(%GetInfoReturnTypes)), '>', 1, '... we have at least one key in the GetInfoReturnType hash'); is_deeply( \%GetInfoReturnTypes, { %DBI::Const::GetInfo::ANSI::ReturnTypes, %DBI::Const::GetInfo::ODBC::ReturnTypes }, '... the GetInfoReturnType hash is constructed from the ANSI and ODBC hashes' ); ## test GetInfoReturnValues cmp_ok(scalar(keys(%GetInfoReturnValues)), '>', 1, '... we have at least one key in the GetInfoReturnValues hash'); # ... testing GetInfoReturnValues any further would be difficult ## test the two methods found in DBI::Const::GetInfoReturn can_ok('DBI::Const::GetInfoReturn', 'Format'); can_ok('DBI::Const::GetInfoReturn', 'Explain'); 1; DBI-1.652/t/85gofer.t0000644000031300001440000002247614742423677013324 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # vim:sw=4:ts=8 $|=1; use strict; use warnings; use Cwd; use Config; use Data::Dumper; use Test::More 0.84; use Getopt::Long; use DBI qw(dbi_time); if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity plan skip_all => "transport+policy tests skipped with non-gofer DBI_AUTOPROXY" if $ap !~ /^dbi:Gofer/i; plan skip_all => "transport+policy tests skipped with non-pedantic policy in DBI_AUTOPROXY" if $ap !~ /policy=pedantic\b/i; } do "./t/lib.pl"; # 0=SQL::Statement if avail, 1=DBI::SQL::Nano # next line forces use of Nano rather than default behaviour # $ENV{DBI_SQL_NANO}=1; # This is done in zvn_50dbm.t GetOptions( 'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)), 'dbm=s' => \my $opt_dbm, 'v|verbose!' => \my $opt_verbose, 't|transport=s' => \my $opt_transport, 'p|policy=s' => \my $opt_policy, ) or exit 1; # so users can try others from the command line if (!$opt_dbm) { # pick first available, starting with SDBM_File for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) { if (eval { no warnings; require "$_.pm" }) { $opt_dbm = ($_); last; } } plan skip_all => 'No DBM modules available' if !$opt_dbm; } my @remote_dsns = DBI->data_sources( "dbi:DBM:", { dbm_type => $opt_dbm, f_lock => 0, f_dir => test_dir() } ); my $remote_dsn = $remote_dsns[0]; ( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i; # Long timeout for slow/overloaded systems (incl virtual machines with low priority) my $timeout = 240; if ($ENV{DBI_AUTOPROXY}) { # this means we have DBD::Gofer => DBD::Gofer => DBD::DBM! # rather than disable it we let it run because we're twisted # and because it helps find more bugs (though debugging can be painful) warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n" unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t } # ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; my %durations; my $getcwd = getcwd(); my $username = eval { getpwuid($>) } || ''; # fails on windows my $can_ssh = ($username && $username eq 'timbo' && -d '.svn' && system("sh -c 'echo > /dev/tcp/localhost/22' 2>/dev/null")==0 ); my $perl = "$^X -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note two spaces) my %trials = ( null => {}, pipeone => { perl=>$perl, timeout=>$timeout }, stream => { perl=>$perl, timeout=>$timeout }, stream_ssh => ($can_ssh) ? { perl=>$perl, timeout=>$timeout, url => "ssh:$username\@localhost" } : undef, #http => { url => "http://localhost:8001/gofer" }, ); # too dependent on local config to make a standard test delete $trials{http} unless $username eq 'timbo' && -d '.svn'; my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials); note("Transports: @transports"); my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush); note("Policies: @policies"); note("Count: $opt_count"); for my $trial (@transports) { (my $transport = $trial) =~ s/_.*//; my $trans_attr = $trials{$trial} or next; # XXX temporary restrictions, hopefully if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) { # stream needs Fcntl macro F_GETFL for non-blocking # and pipe seems to hang on some windows systems next if $transport eq 'stream' or $transport eq 'pipeone'; } for my $policy_name (@policies) { eval { run_tests($transport, $trans_attr, $policy_name) }; ($@) ? fail("$trial: $@") : pass(); } } # to get baseline for comparisons if doing performance testing run_tests('no', {}, 'pedantic') if $opt_count; while ( my ($activity, $stats_hash) = each %durations ) { note(""); $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+pedantic"}; for my $perf_tag (reverse sort keys %$stats_hash) { my $dur = $stats_hash->{$perf_tag} || 0.0000001; note sprintf " %6s %-16s: %.6fsec (%5d/sec)", $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur; my $baseline_dur = $stats_hash->{'~baseline~'}; note sprintf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000 unless $perf_tag eq '~baseline~'; note ""; } } sub run_tests { my ($transport, $trans_attr, $policy_name) = @_; my $policy = get_policy($policy_name); my $skip_gofer_checks = ($transport eq 'no'); my $test_run_tag = "Testing $transport transport with $policy_name policy"; note "============="; note "$test_run_tag"; my $driver_dsn = "transport=$transport;policy=$policy_name"; $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys %$trans_attr if %$trans_attr; my $dsn = "dbi:Gofer:$driver_dsn;dsn=$remote_dsn"; $dsn = $remote_dsn if $transport eq 'no'; note " $dsn"; my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError => 0, ShowErrorStatement => 1 } ); die "$test_run_tag aborted: $DBI::errstr\n" unless $dbh; # no point continuing ok $dbh, sprintf "should connect to %s", $dsn; is $dbh->{Name}, ($policy->skip_connect_check) ? $driver_dsn : $remote_driver_dsn; END { unlink glob "fruit.???" } ok $dbh->do("DROP TABLE IF EXISTS fruit"); ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))"); die "$test_run_tag aborted ($DBI::errstr)\n" if $DBI::err; my $sth = do { local $dbh->{RaiseError} = 0; $dbh->prepare("complete non-sql gibberish"); }; ($policy->skip_prepare_check) ? isa_ok $sth, 'DBI::st' : is $sth, undef, 'should detect prepare failure'; ok my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)"); ok $ins_sth->execute(1, 'oranges'); ok $ins_sth->execute(2, 'oranges'); my $rowset; ok $rowset = $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit ORDER BY dKey"); is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]); ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'"); ok $dbh->{go_response}->executed_flag_set, 'go_response executed flag should be true' unless $skip_gofer_checks && pass(); ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit"); ok $sth->execute; ok $rowset = $sth->fetchall_hashref('dKey'); is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2, dVal=>'apples' } }); if ($opt_count and $transport ne 'pipeone') { note "performance check - $opt_count selects and inserts"; my $start = dbi_time(); $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit") for (1000..1000+$opt_count); $durations{select}{"$transport+$policy_name"} = dbi_time() - $start; # some rows in to get a (*very* rough) idea of overheads $start = dbi_time(); $ins_sth->execute($_, 'speed') for (1000..1000+$opt_count); $durations{insert}{"$transport+$policy_name"} = dbi_time() - $start; } note "Testing go_request_count and caching of simple values"; my $go_request_count = $dbh->{go_request_count}; ok $go_request_count unless $skip_gofer_checks && pass(); ok $dbh->do("DROP TABLE fruit"); is ++$go_request_count, $dbh->{go_request_count} unless $skip_gofer_checks && pass(); # tests go_request_count, caching, and skip_default_methods policy my $use_remote = ($policy->skip_default_methods) ? 0 : 1; $use_remote = 1; # XXX since DBI::DBD::SqlEngine::db implements own data_sources this is always done remotely note sprintf "use_remote=%s (policy=%s, transport=%s) %s", $use_remote, $policy_name, $transport, DBI::neat($dbh->{dbi_default_methods})||''; SKIP: { skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3 if $ENV{DBI_AUTOPROXY} or $skip_gofer_checks; $dbh->data_sources({ foo_bar => $go_request_count }); is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; $dbh->data_sources({ foo_bar => $go_request_count }); # should use cache is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; @_=$dbh->data_sources({ foo_bar => $go_request_count }); # no cached yet due to wantarray is $dbh->{go_request_count}, $go_request_count + 2*$use_remote; } SKIP: { skip "caching of metadata methods returning sth not yet implemented", 2; note "Testing go_request_count and caching of sth"; $go_request_count = $dbh->{go_request_count}; my $sth_ti1 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); is $go_request_count + 1, $dbh->{go_request_count}; my $sth_ti2 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); # should use cache is $go_request_count + 1, $dbh->{go_request_count}; } ok $dbh->disconnect; } sub get_policy { my ($policy_class) = @_; $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class =~ /::/; _load_class($policy_class) or die $@; return $policy_class->new(); } sub _load_class { # return true or false+$@ my $class = shift; (my $pm = $class) =~ s{::}{/}g; $pm .= ".pm"; return 1 if eval { require $pm }; delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough undef; # error in $@ } done_testing; 1; DBI-1.652/t/31methcache.t0000644000031300001440000000632415230132401014073 0ustar00merijnusers#!perl -w # # check that the inner-method lookup cache works # (or rather, check that it doesn't cache things when it shouldn't) my $use_threads_err; BEGIN { eval "use threads;"; $use_threads_err = $@; } # Must be first use Config qw(%Config); my $has_threads = $Config{useithreads}; die $use_threads_err if $has_threads && $use_threads_err; use Test::More; use strict; $|=1; $^W=1; $has_threads or diag("No threads available in this perl"); use_ok( 'DBI' ); sub new_handle { my $dbh = DBI->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 1, }); my $sth = $dbh->prepare("foo", # data for DBD::Sponge to return via fetch { rows => [ [ "row0" ], [ "row1" ], [ "row2" ], [ "row3" ], [ "row4" ], [ "row5" ], [ "row6" ], ], } ); return ($dbh, $sth); } sub Foo::local1 { [ "local1" ] }; sub Foo::local2 { [ "local2" ] }; my $fetch_hook; { package Bar; our @ISA = qw(DBD::_::st); sub fetch { &$fetch_hook }; } sub run_tests { my ($desc, $dbh, $sth) = @_; my $row = $sth->fetch; is($row->[0], "row0", "$desc row0"); { # replace CV slot no warnings 'redefine'; local *DBD::Sponge::st::fetch = sub { [ "local0" ] }; $row = $sth->fetch; is($row->[0], "local0", "$desc local0"); } $row = $sth->fetch; is($row->[0], "row1", "$desc row1"); { # replace GP local *DBD::Sponge::st::fetch = *Foo::local1; $row = $sth->fetch; is($row->[0], "local1", "$desc local1"); } $row = $sth->fetch; is($row->[0], "row2", "$desc row2"); { # replace GV local $DBD::Sponge::st::{fetch} = *Foo::local2; $row = $sth->fetch; is($row->[0], "local2", "$desc local2"); } $row = $sth->fetch; is($row->[0], "row3", "$desc row3"); { # @ISA = NoSuchPackage local $DBD::Sponge::st::{fetch}; local @DBD::Sponge::st::ISA = qw(NoSuchPackage); eval { local $SIG{__WARN__} = sub {}; $row = $sth->fetch }; like($@, qr/Can't locate DBI object method/, "$desc locate DBI object"); } $row = $sth->fetch; is($row->[0], "row4", "$desc row4"); { # @ISA = Bar $fetch_hook = \&DBD::Sponge::st::fetch; local $DBD::Sponge::st::{fetch}; local @DBD::Sponge::st::ISA = qw(Bar); $row = $sth->fetch; is($row->[0], "row5", "$desc row5"); $fetch_hook = sub { [ "local3" ] }; $row = $sth->fetch; is($row->[0], "local3", "$desc local3"); } $row = $sth->fetch; is($row->[0], "row6", "$desc row6"); } run_tests("plain", new_handle()); if ($has_threads) { # only enable this when handles are allowed to be shared across threads #{ # my @h = new_handle(); # threads->new(sub { run_tests("threads", @h) })->join; #} threads->new(sub { run_tests("threads-h", new_handle()) })->join; # using weaken attaches magic to the CV; see whether this interferes # with the cache magic } use Scalar::Util qw(weaken); my $fetch_ref = \&DBI::st::fetch; weaken $fetch_ref; run_tests("magic", new_handle()); if ($has_threads) { # only enable this when handles are allowed to be shared across threads #{ # my @h = new_handle(); # threads->new(sub { run_tests("threads", @h) })->join; #} threads->new(sub { run_tests("magic threads-h", new_handle()) })->join; } done_testing; 1; DBI-1.652/t/91_store_warning.t0000644000031300001440000000253714742423677015233 0ustar00merijnusers# Test if a warning can be recorded in the STORE method # which it couldn't in DBI 1.628 # see https://rt.cpan.org/Ticket/Display.html?id=89015 # This is all started from the fact that the SQLite ODBC Driver cannot set the # ReadOnly attribute (which is mapped to ODBC SQL_ACCESS_MODE) - it # legitimately returns SQL_SUCCESS_WITH_INFO option value changed. # It was decided that this should record a warning but when it was added to DBD::ODBC # DBI did not show the warning - keep_err? # Tim's comment on #dbi was: # the dispatcher has logic to notice if ErrCount went up during a call and disables keep_err in that case. # I think something similar might be needed for err. E.g., "if it's defined now but wasn't defined before" then # act appropriately. use strict; use warnings; use Test::More; use DBI; my $warning; $SIG{__WARN__} = sub { $warning = $_[0] }; my $dbh = DBI->connect('dbi:NullP:', '', '', {PrintWarn => 1}); is $warning, undef, 'initially not set'; $dbh->set_err("0", "warning plain"); like $warning, qr/^DBD::\w+::db set_err warning: warning plain/, "Warning recorded by store"; $dbh->set_err(undef, undef); undef $warning; $dbh->set_err("0", "warning \N{U+263A} smiley face"); like $warning, qr/^DBD::\w+::db set_err warning: warning \x{263A} smiley face/, "Warning recorded by store" or warn DBI::data_string_desc($warning); done_testing; DBI-1.652/t/02dbidrv.t0000755000031300001440000001721514742423677013457 0ustar00merijnusers#!perl -w # vim:sw=4:ts=8:et $|=1; use strict; use Test::More tests => 54; ## ---------------------------------------------------------------------------- ## 02dbidrv.t - ... ## ---------------------------------------------------------------------------- # This test creates a Test Driver (DBD::Test) and then exercises it. # NOTE: # There are a number of tests as well that are embedded within the actual # driver code as well ## ---------------------------------------------------------------------------- ## load DBI BEGIN { use_ok('DBI'); } ## DBI::_new_drh had an internal limit on a driver class name and crashed. SKIP: { Test::More::skip "running DBI::PurePerl", 1 if $DBI::PurePerl; eval { DBI::_new_drh('DBD::Test::OverLong' . 'x' x 300, { Name => 'Test', Version => 'Test', _NO_DESTRUCT_WARN => 1}, 42); }; like($@, qr/unknown _mem package/, 'Overlong DBD class name is processed'); } ## ---------------------------------------------------------------------------- ## create a Test Driver (DBD::Test) ## main Test Driver Package { package DBD::Test; use strict; use warnings; my $drh = undef; sub driver { return $drh if $drh; Test::More::pass('... DBD::Test->driver called to getnew Driver handle'); my($class, $attr) = @_; $class = "${class}::dr"; ($drh) = DBI::_new_drh($class, { Name => 'Test', Version => '$Revision: 11.11 $', }, 77 # 'implementors data' ); Test::More::ok($drh, "... new Driver handle ($drh) created successfully"); Test::More::isa_ok($drh, 'DBI::dr'); return $drh; } } ## Test Driver { package DBD::Test::dr; use strict; use warnings; $DBD::Test::dr::imp_data_size = 0; Test::More::cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo'); sub DESTROY { undef } sub data_sources { my ($h) = @_; Test::More::ok($h, '... Driver object passed to data_sources'); Test::More::isa_ok($h, 'DBI::dr'); Test::More::ok(!tied $h, '... Driver object is not tied'); return ("dbi:Test:foo", "dbi:Test:bar"); } } ## Test db package { package DBD::Test::db; use strict; $DBD::Test::db::imp_data_size = 0; Test::More::cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo'); sub do { my $h = shift; Test::More::ok($h, '... Database object passed to do'); Test::More::isa_ok($h, 'DBI::db'); Test::More::ok(!tied $h, '... Database object is not tied'); my $drh_i = $h->{Driver}; Test::More::ok($drh_i, '... got Driver object from Database object with Driver attribute'); Test::More::isa_ok($drh_i, "DBI::dr"); Test::More::ok(!tied %{$drh_i}, '... Driver object is not tied'); my $drh_o = $h->FETCH('Driver'); Test::More::ok($drh_o, '... got Driver object from Database object by FETCH-ing Driver attribute'); Test::More::isa_ok($drh_o, "DBI::dr"); SKIP: { Test::More::skip "running DBI::PurePerl", 1 if $DBI::PurePerl; Test::More::ok(tied %{$drh_o}, '... Driver object is not tied'); } # return this to make our test pass return 1; } sub data_sources { my ($dbh, $attr) = @_; my @ds = $dbh->SUPER::data_sources($attr); Test::More::is_deeply(( \@ds, [ 'dbi:Test:foo', 'dbi:Test:bar' ] ), '... checking fetched datasources from Driver' ); push @ds, "dbi:Test:baz"; return @ds; } sub disconnect { shift->STORE(Active => 0); } } ## ---------------------------------------------------------------------------- ## test the Driver (DBD::Test) $INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver() # Note that install_driver should *not* normally be called directly. # This test does so only because it's a test of install_driver! my $drh = DBI->install_driver('Test'); ok($drh, '... got a Test Driver object back from DBI->install_driver'); isa_ok($drh, 'DBI::dr'); cmp_ok(DBI::_get_imp_data($drh), '==', 77, '... checking the DBI::_get_imp_data function'); my @ds1 = DBI->data_sources("Test"); is_deeply(( [ @ds1 ], [ 'dbi:Test:foo', 'dbi:Test:bar' ] ), '... got correct datasources from DBI->data_sources("Test")' ); SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids'); } # create scope to test $dbh DESTROY behaviour do { my $dbh = $drh->connect; ok($dbh, '... got a database handle from calling $drh->connect'); isa_ok($dbh, 'DBI::db'); SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 1, '... this Driver does not yet have any Kids'); } my @ds2 = $dbh->data_sources(); is_deeply(( [ @ds2 ], [ 'dbi:Test:foo', 'dbi:Test:bar', 'dbi:Test:baz' ] ), '... got correct datasources from $dbh->data_sources()' ); ok($dbh->do('dummy'), '... this will trigger more driver internal tests above in DBD::Test::db'); $dbh->disconnect; $drh->set_err("41", "foo 41 drh"); cmp_ok($drh->err, '==', 41, '... checking Driver handle err set with set_err method'); $dbh->set_err("42", "foo 42 dbh"); cmp_ok($dbh->err, '==', 42, '... checking Database handle err set with set_err method'); cmp_ok($drh->err, '==', 41, '... checking Database handle err set with Driver handle set_err method'); }; SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids') or $drh->dump_handle("bad Kids",3); } # copied up to drh from dbh when dbh was DESTROYd cmp_ok($drh->err, '==', 42, '... $dbh->DESTROY should set $drh->err to 42'); $drh->set_err("99", "foo"); cmp_ok($DBI::err, '==', 99, '... checking $DBI::err set with Driver handle set_err method'); is($DBI::errstr, "foo 42 dbh [err was 42 now 99]\nfoo", '... checking $DBI::errstr'); $drh->default_user("",""); # just to reset err etc $drh->set_err(1, "errmsg", "00000"); is($DBI::state, "", '... checking $DBI::state'); $drh->set_err(1, "test error 1"); is($DBI::state, 'S1000', '... checking $DBI::state'); $drh->set_err(2, "test error 2", "IM999"); is($DBI::state, 'IM999', '... checking $DBI::state'); SKIP: { skip "using DBI::PurePerl", 1 if $DBI::PurePerl; eval { $DBI::rows = 1 }; like($@, qr/Can't modify/, '... trying to assign to $DBI::rows should throw an excpetion'); #' } is($drh->{FetchHashKeyName}, 'NAME', '... FetchHashKeyName is NAME'); $drh->{FetchHashKeyName} = 'NAME_lc'; is($drh->{FetchHashKeyName}, 'NAME_lc', '... FetchHashKeyName is now changed to NAME_lc'); ok(!$drh->disconnect_all, '... calling $drh->disconnect_all (not implemented but will fail silently)'); ok defined $drh->dbixs_revision, 'has dbixs_revision'; ok($drh->dbixs_revision =~ m/^\d+$/, 'has integer dbixs_revision'); SKIP: { skip "using DBI::PurePerl", 5 if $DBI::PurePerl; my $can = $drh->can('FETCH'); ok($can, '... $drh can FETCH'); is(ref($can), "CODE", '... and it returned a proper CODE ref'); my $name = $can->($drh, "Name"); ok($name, '... used FETCH returned from can to fetch the Name attribute'); is($name, "Test", '... the Name attribute is equal to Test'); ok(!$drh->can('disconnect_all'), '... '); } 1; DBI-1.652/t/30subclass.t0000644000031300001440000001010414742423677014010 0ustar00merijnusers#!perl -w use strict; $|=1; $^W=1; my $calls = 0; my %my_methods; # ================================================= # Example code for sub classing the DBI. # # Note that the extra ::db and ::st classes must be set up # as sub classes of the corresponding DBI classes. # # This whole mechanism is new and experimental - it may change! package MyDBI; our @ISA = qw(DBI); # the MyDBI::dr::connect method is NOT called! # you can either override MyDBI::connect() # or use MyDBI::db::connected() package MyDBI::db; our @ISA = qw(DBI::db); sub prepare { my($dbh, @args) = @_; ++$my_methods{prepare}; ++$calls; my $sth = $dbh->SUPER::prepare(@args); return $sth; } package MyDBI::st; our @ISA = qw(DBI::st); sub fetch { my($sth, @args) = @_; ++$my_methods{fetch}; ++$calls; # this is just to trigger (re)STORE on exit to test that the STORE # doesn't clear any erro condition local $sth->{Taint} = 0; my $row = $sth->SUPER::fetch(@args); if ($row) { # modify fetched data as an example $row->[1] = lc($row->[1]); # also demonstrate calling set_err() return $sth->set_err(1,"Don't be so negative",undef,"fetch") if $row->[0] < 0; # ... and providing alternate results # (although typically would trap and hide and error from SUPER::fetch) return $sth->set_err(2,"Don't exaggerate",undef, undef, [ 42,"zz",0 ]) if $row->[0] > 42; } return $row; } # ================================================= package main; use Test::More tests => 43; BEGIN { use_ok( 'DBI' ); } my $tmp; #DBI->trace(2); my $dbh = MyDBI->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 1, CompatMode => 1, # just for clone test }); isa_ok($dbh, 'MyDBI::db'); is($dbh->{CompatMode}, 1); undef $dbh; $dbh = DBI->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 1, RootClass => "MyDBI", CompatMode => 1, # just for clone test dbi_foo => 1, # just to help debugging clone etc }); isa_ok( $dbh, 'MyDBI::db'); is($dbh->{CompatMode}, 1); #$dbh->trace(5); my $sth = $dbh->prepare("foo", # data for DBD::Sponge to return via fetch { rows => [ [ 40, "AAA", 9 ], [ 41, "BB", 8 ], [ -1, "C", 7 ], [ 49, "DD", 6 ] ], } ); is($calls, 1); isa_ok($sth, 'MyDBI::st'); my $row = $sth->fetch; is($calls, 2); is($row->[1], "aaa"); $row = $sth->fetch; is($calls, 3); is($row->[1], "bb"); is($DBI::err, undef); $row = eval { $sth->fetch }; my $eval_err = $@; is(!defined $row, 1); is(substr($eval_err,0,50), "DBD::Sponge::st fetch failed: Don't be so negative"); #$sth->trace(5); #$sth->{PrintError} = 1; $sth->{RaiseError} = 0; $row = eval { $sth->fetch }; isa_ok($row, 'ARRAY'); is($row->[0], 42); is($DBI::err, 2); like($DBI::errstr, qr/Don't exaggerate/); is($@ =~ /Don't be so negative/, $@); my $dbh2 = $dbh->clone; isa_ok( $dbh2, 'MyDBI::db', "Clone A" ); is($dbh2 != $dbh, 1); is($dbh2->{CompatMode}, 1); my $dbh3 = $dbh->clone({}); isa_ok( $dbh3, 'MyDBI::db', 'Clone B' ); is($dbh3 != $dbh, 1); is($dbh3 != $dbh2, 1); isa_ok( $dbh3, 'MyDBI::db'); is($dbh3->{CompatMode}, 1); my $dbh2c = $dbh2->clone; isa_ok( $dbh2c, 'MyDBI::db', "Clone of clone A" ); is($dbh2c != $dbh2, 1); is($dbh2c->{CompatMode}, 1); my $dbh3c = $dbh3->clone({ CompatMode => 0 }); isa_ok( $dbh3c, 'MyDBI::db', 'Clone of clone B' ); is((grep { $dbh3c == $_ } $dbh, $dbh2, $dbh3), 0); isa_ok( $dbh3c, 'MyDBI::db'); ok(!$dbh3c->{CompatMode}); $tmp = $dbh->sponge_test_installed_method('foo','bar'); isa_ok( $tmp, "ARRAY", "installed method" ); is_deeply( $tmp, [qw( foo bar )] ); $tmp = eval { $dbh->sponge_test_installed_method() }; is(!$tmp, 1); is($dbh->err, 42); is($dbh->errstr, "not enough parameters"); $dbh = eval { DBI->connect("dbi:Sponge:foo","","", { RootClass => 'nonesuch1', PrintError => 0, RaiseError => 0, }); }; ok( !defined($dbh), "Failed connect #1" ); is(substr($@,0,25), "Can't locate nonesuch1.pm"); $dbh = eval { nonesuch2->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 0, }); }; ok( !defined($dbh), "Failed connect #2" ); is(substr($@,0,36), q{Can't locate object method "connect"}); print "@{[ %my_methods ]}\n"; 1; DBI-1.652/t/03handle.t0000644000031300001440000003520114742423677013431 0ustar00merijnusers#!perl -w $|=1; use strict; use Test::More tests => 137; ## ---------------------------------------------------------------------------- ## 03handle.t - tests handles ## ---------------------------------------------------------------------------- # This set of tests exercises the different handles; Driver, Database and # Statement in various ways, in particular in their interactions with one # another ## ---------------------------------------------------------------------------- BEGIN { use_ok( 'DBI' ); } # installed drivers should start empty my %drivers = DBI->installed_drivers(); is(scalar keys %drivers, 0); ## ---------------------------------------------------------------------------- # get the Driver handle my $driver = "ExampleP"; my $drh = DBI->install_driver($driver); isa_ok( $drh, 'DBI::dr' ); SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids'); } # now the driver should be registered %drivers = DBI->installed_drivers(); is(scalar keys %drivers, 1); ok(exists $drivers{ExampleP}); ok($drivers{ExampleP}->isa('DBI::dr')); my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; ## ---------------------------------------------------------------------------- # do database handle tests inside do BLOCK to capture scope do { my $dbh = DBI->connect("dbi:$driver:", '', ''); isa_ok($dbh, 'DBI::db'); my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer SKIP: { skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid'); cmp_ok($drh->{ActiveKids}, '==', 1, '... our Driver has one ActiveKid'); } my $sql = "select name from ?"; my $sth1 = $dbh->prepare_cached($sql); isa_ok($sth1, 'DBI::st'); ok($sth1->execute("."), '... execute ran successfully'); my $ck = $dbh->{CachedKids}; is(ref($ck), "HASH", '... we got the CachedKids hash'); cmp_ok(scalar(keys(%{$ck})), '==', 1, '... there is one CachedKid'); ok(eq_set( [ values %{$ck} ], [ $sth1 ] ), '... our statement handle should be in the CachedKids'); ok($sth1->{Active}, '... our first statement is Active'); { my $warn = 0; # use this to check that we are warned local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/i }; my $sth2 = $dbh->prepare_cached($sql); isa_ok($sth2, 'DBI::st'); is($sth1, $sth2, '... prepare_cached returned the same statement handle'); cmp_ok($warn,'==', 1, '... we got warned about our first statement handle being still active'); ok(!$sth1->{Active}, '... our first statement is no longer Active since we re-prepared it'); my $sth3 = $dbh->prepare_cached($sql, { foo => 1 }); isa_ok($sth3, 'DBI::st'); isnt($sth1, $sth3, '... prepare_cached returned a different statement handle now'); cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); ok(eq_set( [ values %{$ck} ], [ $sth1, $sth3 ] ), '... both statement handles should be in the CachedKids'); ok($sth1->execute("."), '... executing first statement handle again'); ok($sth1->{Active}, '... first statement handle is now active again'); my $sth4 = $dbh->prepare_cached($sql, undef, 3); isa_ok($sth4, 'DBI::st'); isnt($sth1, $sth4, '... our fourth statement handle is not the same as our first'); ok($sth1->{Active}, '... first statement handle is still active'); cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); ok(eq_set( [ values %{$ck} ], [ $sth2, $sth4 ] ), '... second and fourth statement handles should be in the CachedKids'); $sth1->finish; ok(!$sth1->{Active}, '... first statement handle is no longer active'); ok($sth4->execute("."), '... fourth statement handle executed properly'); ok($sth4->{Active}, '... fourth statement handle is Active'); my $sth5 = $dbh->prepare_cached($sql, undef, 1); isa_ok($sth5, 'DBI::st'); cmp_ok($warn, '==', 1, '... we still only got one warning'); is($sth4, $sth5, '... fourth statement handle and fifth one match'); ok(!$sth4->{Active}, '... fourth statement handle is not Active'); ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be its the same as fifth)'); cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); ok(eq_set( [ values %{$ck} ], [ $sth2, $sth5 ] ), '... second and fourth/fifth statement handles should be in the CachedKids'); } SKIP: { skip "swap_inner_handle() not supported under DBI::PurePerl", 23 if $DBI::PurePerl; my $sth6 = $dbh->prepare($sql); $sth6->execute("."); my $sth1_driver_name = $sth1->{Database}{Driver}{Name}; ok( $sth6->{Active}, '... sixth statement handle is active'); ok(!$sth1->{Active}, '... first statement handle is not active'); ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); ok(!$sth6->{Active}, '... sixth statement handle is now not active'); ok( $sth1->{Active}, '... first statement handle is now active again'); ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); ok( $sth6->{Active}, '... sixth statement handle is active'); ok(!$sth1->{Active}, '... first statement handle is not active'); ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); ok(!$sth6->{Active}, '... sixth statement handle is now not active'); ok( $sth1->{Active}, '... first statement handle is now active again'); $sth1->{PrintError} = 0; ok(!$sth1->swap_inner_handle($dbh), '... can not swap a sth with a dbh'); cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle between sth and dbh"); ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); ok( $sth6->{Active}, '... sixth statement handle is active'); ok(!$sth1->{Active}, '... first statement handle is not active'); $sth6->finish; ok(my $dbh_nullp = DBI->connect("dbi:NullP:", undef, undef, { go_bypass => 1 })); ok(my $sth7 = $dbh_nullp->prepare("")); $sth1->{PrintError} = 0; ok(!$sth1->swap_inner_handle($sth7), "... can't swap_inner_handle with handle from different parent"); cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle with handle from different parent"); cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', $sth1_driver_name ); ok( $sth1->swap_inner_handle($sth7,1), "... can swap to different parent if forced"); cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "NullP" ); $dbh_nullp->disconnect; } ok( $dbh->ping, 'ping should be true before disconnect'); $dbh->disconnect; $dbh->{PrintError} = 0; # silence 'not connected' warning ok( !$dbh->ping, 'ping should be false after disconnect'); SKIP: { skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid after disconnect'); cmp_ok($drh->{ActiveKids}, '==', 0, '... our Driver has no ActiveKids after disconnect'); } }; if ($using_dbd_gofer) { $drh->{CachedKids} = {}; } # make sure our driver has no more kids after this test # NOTE: # this also assures us that the next test has an empty slate as well SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 0, "... our $drh->{Name} driver should have 0 Kids after dbh was destoryed"); } ## ---------------------------------------------------------------------------- # handle reference leak tests # NOTE: # this test checks for reference leaks by testing the Kids attribute # which is not supported by DBI::PurePerl, so we just do not run this # for DBI::PurePerl all together. Even though some of the tests would # pass, it does not make sense because in the end, what is actually # being tested for will give a false positive sub work { my (%args) = @_; my $dbh = DBI->connect("dbi:$driver:", '', ''); isa_ok( $dbh, 'DBI::db' ); cmp_ok($drh->{Kids}, '==', 1, '... the Driver should have 1 Kid(s) now'); if ( $args{Driver} ) { isa_ok( $dbh->{Driver}, 'DBI::dr' ); } else { pass( "not testing Driver here" ); } my $sth = $dbh->prepare_cached("select name from ?"); isa_ok( $sth, 'DBI::st' ); if ( $args{Database} ) { isa_ok( $sth->{Database}, 'DBI::db' ); } else { pass( "not testing Database here" ); } $dbh->disconnect; # both handles should be freed here } SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 25 if $DBI::PurePerl; skip "drh Kids not testable under DBD::Gofer", 25 if $using_dbd_gofer; foreach my $args ( {}, { Driver => 1 }, { Database => 1 }, { Driver => 1, Database => 1 }, ) { work( %{$args} ); cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids'); } # make sure we have no kids when we end this cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids at the end of this test'); } ## ---------------------------------------------------------------------------- # handle take_imp_data test SKIP: { skip "take_imp_data test not supported under DBD::Gofer", 19 if $using_dbd_gofer; my $dbh = DBI->connect("dbi:$driver:", '', ''); isa_ok($dbh, "DBI::db"); my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here') unless $DBI::PurePerl && pass(); $dbh->prepare("select name from ?"); # destroyed at once my $sth2 = $dbh->prepare("select name from ?"); # inactive my $sth3 = $dbh->prepare("select name from ?"); # active: $sth3->execute("."); is $sth3->{Active}, 1; is $dbh->{ActiveKids}, 1 unless $DBI::PurePerl && pass(); my $ChildHandles = $dbh->{ChildHandles}; skip "take_imp_data test needs weakrefs", 15 if not $ChildHandles; ok $ChildHandles, 'we need weakrefs for take_imp_data to work safely with child handles'; is @$ChildHandles, 3, 'should have 3 entries (implementation detail)'; is grep({ defined } @$ChildHandles), 2, 'should have 2 defined handles'; my $imp_data = $dbh->take_imp_data; ok($imp_data, '... we got some imp_data to test'); # generally length($imp_data) = 112 for 32bit, 116 for 64 bit # (as of DBI 1.37) but it can differ on some platforms # depending on structure packing by the compiler # so we just test that it's something reasonable: cmp_ok(length($imp_data), '>=', 80, '... test that our imp_data is greater than or equal to 80, this is reasonable'); cmp_ok($drh->{Kids}, '==', 0, '... our Driver should have 0 Kid(s) after calling take_imp_data'); is ref $sth3, 'DBI::zombie', 'sth should be reblessed'; eval { $sth3->finish }; like $@, qr/Can't locate object method/; { my @warn; local $SIG{__WARN__} = sub { push @warn, $_[0] if $_[0] =~ /after take_imp_data/; print "warn: @_\n"; }; my $drh = $dbh->{Driver}; ok(!defined $drh, '... our Driver should be undefined'); my $trace_level = $dbh->{TraceLevel}; ok(!defined $trace_level, '... our TraceLevel should be undefined'); ok(!defined $dbh->disconnect, '... disconnect should return undef'); ok(!defined $dbh->quote(42), '... quote should return undefined'); cmp_ok(scalar @warn, '==', 4, '... we should have gotten 4 warnings'); } my $dbh2 = DBI->connect("dbi:$driver:", '', '', { dbi_imp_data => $imp_data }); isa_ok($dbh2, "DBI::db"); # need a way to test dbi_imp_data has been used cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) again') unless $DBI::PurePerl && pass(); } # we need this SKIP block on its own since we are testing the # destruction of objects within the scope of the above SKIP # block SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh->{Kids}, '==', 0, '... our Driver has no Kids after this test'); } ## ---------------------------------------------------------------------------- # NullP statement handle attributes without execute my $driver2 = "NullP"; my $drh2 = DBI->install_driver($driver); isa_ok( $drh2, 'DBI::dr' ); SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids before this test'); } do { my $dbh = DBI->connect("dbi:$driver2:", '', ''); isa_ok($dbh, "DBI::db"); my $sth = $dbh->prepare("foo bar"); isa_ok($sth, "DBI::st"); cmp_ok($sth->{NUM_OF_PARAMS}, '==', 0, '... NUM_OF_PARAMS is 0'); is($sth->{NUM_OF_FIELDS}, undef, '... NUM_OF_FIELDS should be undef'); is($sth->{Statement}, "foo bar", '... Statement is "foo bar"'); ok(!defined $sth->{NAME}, '... NAME is undefined'); ok(!defined $sth->{TYPE}, '... TYPE is undefined'); ok(!defined $sth->{SCALE}, '... SCALE is undefined'); ok(!defined $sth->{PRECISION}, '... PRECISION is undefined'); ok(!defined $sth->{NULLABLE}, '... NULLABLE is undefined'); ok(!defined $sth->{RowsInCache}, '... RowsInCache is undefined'); ok(!defined $sth->{ParamValues}, '... ParamValues is undefined'); # derived NAME attributes ok(!defined $sth->{NAME_uc}, '... NAME_uc is undefined'); ok(!defined $sth->{NAME_lc}, '... NAME_lc is undefined'); ok(!defined $sth->{NAME_hash}, '... NAME_hash is undefined'); ok(!defined $sth->{NAME_uc_hash}, '... NAME_uc_hash is undefined'); ok(!defined $sth->{NAME_lc_hash}, '... NAME_lc_hash is undefined'); my $dbh_ref = ref($dbh); my $sth_ref = ref($sth); ok($dbh_ref->can("prepare"), '... $dbh can call "prepare"'); ok(!$dbh_ref->can("nonesuch"), '... $dbh cannot call "nonesuch"'); ok($sth_ref->can("execute"), '... $sth can call "execute"'); # what is this test for?? # I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't: # Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot to load "DBI::db"?) eval { ref($dbh)->nonesuch; }; $dbh->disconnect; }; SKIP: { skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids after this test'); } ## ---------------------------------------------------------------------------- 1; DBI-1.652/t/41prof_dump.t0000644000031300001440000000550315230133021014143 0ustar00merijnusers#!perl -wl # Using -l to ensure ProfileDumper is isolated from changes to $/ and $\ and such $|=1; use strict; # # test script for DBI::ProfileDumper # use DBI; use Config; use Test::More; BEGIN { plan skip_all => 'profiling not supported for DBI::PurePerl' if $DBI::PurePerl; # clock instability on xen systems is a reasonably common cause of failure # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html # so we'll skip automated testing on those systems plan skip_all => "skipping profile tests on xen (due to clock instability)" if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 and $ENV{AUTOMATED_TESTING}; } BEGIN { use_ok( 'DBI' ); use_ok( 'DBI::ProfileDumper' ); } my $prof_file = "dbi$$.prof"; my $prof_backup = $prof_file . ".prev"; END { 1 while unlink $prof_file; 1 while unlink $prof_backup; } my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>"2/DBI::ProfileDumper/File:$prof_file" }); isa_ok( $dbh, 'DBI::db' ); isa_ok( $dbh->{Profile}, "DBI::ProfileDumper" ); isa_ok( $dbh->{Profile}{Data}, 'HASH' ); isa_ok( $dbh->{Profile}{Path}, 'ARRAY' ); # do a little work my $sql = "select mode,size,name from ?"; my $sth = $dbh->prepare($sql); isa_ok( $sth, 'DBI::st' ); $sth->execute("."); # check that flush_to_disk doesn't change Path if Path is undef (it # did before 1.49) { local $dbh->{Profile}->{Path} = undef; $sth->{Profile}->flush_to_disk(); is($dbh->{Profile}->{Path}, undef); } $sth->{Profile}->flush_to_disk(); while ( my $hash = $sth->fetchrow_hashref ) {} # force output undef $sth; $dbh->disconnect; undef $dbh; # wrote the profile to disk? ok( -s $prof_file, 'Profile is on disk and nonzero size' ); # XXX We're breaking encapsulation here open(PROF, $prof_file) or die $!; my @prof = ; close PROF; print @prof; # has a header? like( $prof[0], '/^DBI::ProfileDumper\s+([\d.]+)/', 'Found a version number' ); # version matches VERSION? (DBI::ProfileDumper uses $self->VERSION so # it's a stringified version object that looks like N.N.N) $prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/; is( $1, DBI::ProfileDumper->VERSION, "Version numbers match in $prof[0]" ); like( $prof[1], qr{^Path\s+=\s+\[\s+\]}, 'Found the Path'); ok( $prof[2] =~ m{^Program\s+=\s+(\S+)}, 'Found the Program'); # check that expected key is there like(join('', @prof), qr/\+\s+1\s+\Q$sql\E/m); # unlink($prof_file); # now done by 'make clean' # should be able to load DBI::ProfileDumper::Apache outside apache # this also naturally checks for syntax errors etc. SKIP: { skip "developer-only test", 1 unless (-d ".svn" || -d ".git") && -f "MANIFEST.SKIP"; skip "Apache module not installed", 1 unless eval { require Apache }; require_ok('DBI::ProfileDumper::Apache') } done_testing; 1; DBI-1.652/t/73cachedkids.t0000644000031300001440000000341614656646601014270 0ustar00merijnusersuse warnings; use strict; use Scalar::Util qw( weaken reftype refaddr blessed ); use DBI; use B (); use Tie::Hash (); use Test::More; my (%weak_dbhs, %weak_caches); # past this scope everything should be gone { ### get two identical connections my @dbhs = map { DBI->connect('dbi:ExampleP::memory:', undef, undef, { RaiseError => 1 }) } (1,2); ### get weakrefs on both handles %weak_dbhs = map { refdesc($_) => $_ } @dbhs; weaken $_ for values %weak_dbhs; ### tie the first one's cache if (1) { ok( tie( my %cache, 'Tie::StdHash'), refdesc($dbhs[0]) . ' cache tied' ); $dbhs[0]->{CachedKids} = \%cache; } ### prepare something on both $_->prepare_cached( 'SELECT name FROM .' ) for @dbhs; ### get weakrefs of both caches %weak_caches = map { sprintf( 'statement cache of %s (%s)', refdesc($_), refdesc($_->{CachedKids}) ) => $_->{CachedKids} } @dbhs; weaken $_ for values %weak_caches; ### check both caches have entries is (scalar keys %{$weak_caches{$_}}, 1, "One cached statement found in $_") for keys %weak_caches; ### check both caches have sane refcounts is ( refcount( $weak_caches{$_} ), 1, "Refcount of $_ correct") for keys %weak_caches; ### check both dbh have sane refcounts is ( refcount( $weak_dbhs{$_} ), 1, "Refcount of $_ correct") for keys %weak_dbhs; note "Exiting scope"; @dbhs=(); } # check both $dbh weakrefs are gone is ($weak_dbhs{$_}, undef, "$_ garbage collected") for keys %weak_dbhs; is ($weak_caches{$_}, undef, "$_ garbage collected") for keys %weak_caches; sub refdesc { sprintf '%s%s(0x%x)', ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ), reftype $_[0], refaddr($_[0]), ; } sub refcount { B::svref_2object($_[0])->REFCNT; } done_testing; DBI-1.652/t/19fhtrace.t0000644000031300001440000001470714742423677013631 0ustar00merijnusers#!perl -w # vim:sw=4:ts=8 use strict; use Test::More tests => 27; ## ---------------------------------------------------------------------------- ## 09trace.t ## ---------------------------------------------------------------------------- # ## ---------------------------------------------------------------------------- BEGIN { use_ok( 'DBI' ); } $|=1; our $fancylogfn = "fancylog$$.log"; our $trace_file = "dbitrace$$.log"; # Clean up when we're done. END { 1 while unlink $fancylogfn; 1 while unlink $trace_file; }; package PerlIO::via::TraceDBI; our $logline; sub OPEN { return 1; } sub PUSHED { my ($class,$mode,$fh) = @_; # When writing we buffer the data my $buf = ''; return bless \$buf,$class; } sub FILL { my ($obj,$fh) = @_; return $logline; } sub READLINE { my ($obj,$fh) = @_; return $logline; } sub WRITE { my ($obj,$buf,$fh) = @_; # print "\n*** WRITING $buf\n"; $logline = $buf; return length($buf); } sub FLUSH { my ($obj,$fh) = @_; return 0; } sub CLOSE { # print "\n*** CLOSING!!!\n"; $logline = "**** CERRADO! ***"; return -1; } 1; package PerlIO::via::MyFancyLogLayer; sub OPEN { my ($obj, $path, $mode, $fh) = @_; $$obj = $path; return 1; } sub PUSHED { my ($class,$mode,$fh) = @_; # When writing we buffer the data my $logger; return bless \$logger,$class; } sub WRITE { my ($obj,$buf,$fh) = @_; $$obj->log($buf); return length($buf); } sub FLUSH { my ($obj,$fh) = @_; return 0; } sub CLOSE { my $self = shift; $$self->close(); return 0; } 1; package MyFancyLogger; use Symbol qw(gensym); sub new { my $self = {}; my $fh = gensym(); open $fh, '>', $fancylogfn; $self->{_fh} = $fh; $self->{_buf} = ''; return bless $self, shift; } sub log { my $self = shift; my $fh = $self->{_fh}; $self->{_buf} .= shift; print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and $self->{_buf} = '' if $self->{_buf}=~tr/\n//; } sub close { my $self = shift; return unless exists $self->{_fh}; my $fh = $self->{_fh}; print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and $self->{_buf} = '' if $self->{_buf}; close $fh; delete $self->{_fh}; } 1; package main; ## ---------------------------------------------------------------------------- # Connect to the example driver. my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '', { PrintError => 0, RaiseError => 1, PrintWarn => 0, RaiseWarn => 1, }); isa_ok( $dbh, 'DBI::db' ); # Clean up when we're done. END { $dbh->disconnect if $dbh }; ## ---------------------------------------------------------------------------- # Check the database handle attributes. cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute'); 1 while unlink $trace_file; my $tracefd; ## ---------------------------------------------------------------------------- # First use regular filehandle open $tracefd, '>>', $trace_file; my $oldfd = select($tracefd); $| = 1; select $oldfd; ok(-f $trace_file, '... regular fh: trace file successfully created'); $dbh->trace(2, $tracefd); ok( 1, '... regular fh: filehandle successfully set'); # # read current size of file # my $filesz = (stat $tracefd)[7]; $dbh->trace_msg("First logline\n", 1); # # read new file size and verify its different # my $newfsz = (stat $tracefd)[7]; SKIP: { skip 'on VMS autoflush using select does not work', 1 if $^O eq 'VMS'; ok(($filesz != $newfsz), '... regular fh: trace_msg'); } $dbh->trace(undef, "STDOUT"); # close $trace_file ok(-f $trace_file, '... regular fh: file successfully changed'); $filesz = (stat $tracefd)[7]; $dbh->trace_msg("Next logline\n"); # # read new file size and verify its same # $newfsz = (stat $tracefd)[7]; ok(($filesz == $newfsz), '... regular fh: trace_msg after changing trace output'); #1 while unlink $trace_file; $dbh->trace(0); # disable trace { # Open trace to glob. started failing in perl-5.10 my $tf = "foo.log.$$"; 1 while unlink $tf; 1 while unlink "*main::FOO"; 1 while unlink "*main::STDERR"; is (-f $tf, undef, "Tracefile removed"); ok (open (FOO, ">", $tf), "Tracefile FOO opened"); ok (-f $tf, "Tracefile created"); DBI->trace (1, *FOO); is (-f "*main::FOO", undef, "Regression test"); DBI->trace_msg ("foo\n", 1); DBI->trace (0, *STDERR); close FOO; open my $fh, "<", $tf; is ((<$fh>)[-1], "foo\n", "Traced message"); close $fh; is (-f "*main::STDERR", undef, "Regression test"); 1 while unlink $tf; } ## ---------------------------------------------------------------------------- # Then use layered filehandle # open TRACEFD, '+>:via(TraceDBI)', 'layeredtrace.out'; print TRACEFD "*** Test our layer\n"; my $result = ; is $result, "*** Test our layer\n", "... layered fh: file is layered: $result\n"; $dbh->trace(1, \*TRACEFD); ok( 1, '... layered fh: filehandle successfully set'); $dbh->trace_msg("Layered logline\n", 1); $result = ; is $result, "Layered logline\n", "... layered fh: trace_msg: $result\n"; $dbh->trace(1, "STDOUT"); # close $trace_file $result = ; is $result, "Layered logline\n", "... layered fh: close doesn't close: $result\n"; $dbh->trace_msg("Next logline\n", 1); $result = ; is $result, "Layered logline\n", "... layered fh: trace_msg after change trace output: $result\n"; ## ---------------------------------------------------------------------------- # Then use scalar filehandle # my $tracestr; open TRACEFD, '+>:scalar', \$tracestr; print TRACEFD "*** Test our layer\n"; ok 1, "... scalar trace: file is layered: $tracestr\n"; $dbh->trace(1, \*TRACEFD); ok 1, '... scalar trace: filehandle successfully set'; $dbh->trace_msg("Layered logline\n", 1); ok 1, "... scalar trace: $tracestr\n"; $dbh->trace(1, "STDOUT"); # close $trace_file ok 1, "... scalar trace: close doesn't close: $tracestr\n"; $dbh->trace_msg("Next logline\n", 1); ok 1, "... scalar trace: after change trace output: $tracestr\n"; ## ---------------------------------------------------------------------------- # Then use fancy logger # open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new(); $dbh->trace('SQL', $fh); $dbh->trace_msg("Layered logline\n", 1); ok 1, "... logger: trace_msg\n"; $dbh->trace(1, "STDOUT"); # close $trace_file ok 1, "... logger: close doesn't close\n"; $dbh->trace_msg("Next logline\n", 1); ok 1, "... logger: trace_msg after change trace output\n"; close $fh; 1; # end DBI-1.652/t/90sql_type_cast.t0000644000031300001440000001332215230133211015025 0ustar00merijnusers# $Id$ # Test DBI::sql_type_cast use strict; #use warnings; this script generate warnings deliberately as part of the test use Test::More; use DBI qw(:sql_types :utils); use Config; # https://metacpan.org/release/MLEHMANN/Canary-Stability-2013/source/Stability.pm#L146 # 5.022 is the last supported perl for JSON::XS. my $jx = $] >= 5.022000 ? 0 : eval {require JSON::XS;}; my $dp = eval {require Data::Peek;}; my $pp = $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning # NOTE: would have liked to use DBI::neat to test the cast value is what # we expect but unfortunately neat uses SvNIOK(sv) so anything that looks # like a number is printed as a number without quotes even if it has # a pv. use constant INVALID_TYPE => -2; use constant SV_IS_UNDEF => -1; use constant NO_CAST_STRICT => 0; use constant NO_CAST_NO_STRICT => 1; use constant CAST_OK => 2; my @tests = ( ['undef', undef, SQL_INTEGER, SV_IS_UNDEF, -1, q{[null]}], ['invalid sql type', "99", 123456789, 0, INVALID_TYPE, q{["99"]}], ['non numeric cast to int', "aa", SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["aa"]}], ['non numeric cast to int (strict)', "aa", SQL_INTEGER, DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}], ['small int cast to int', "99", SQL_INTEGER, 0, CAST_OK, q{["99"]}], ['2 byte max signed int cast to int', "32767", SQL_INTEGER, 0, CAST_OK, q{["32767"]}], ['2 byte max unsigned int cast to int', "65535", SQL_INTEGER, 0, CAST_OK, q{["65535"]}], ['4 byte max signed int cast to int', "2147483647", SQL_INTEGER, 0, CAST_OK, q{["2147483647"]}], ['4 byte max unsigned int cast to int', "4294967295", SQL_INTEGER, 0, CAST_OK, q{["4294967295"]}], ['small int cast to int (discard)', "99", SQL_INTEGER, DBIstcf_DISCARD_STRING, CAST_OK, q{[99]}], ['non numeric cast to numeric', "aa", SQL_NUMERIC, 0, NO_CAST_NO_STRICT, q{["aa"]}], ['non numeric cast to numeric (strict)', "aa", SQL_NUMERIC, DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}], ); unless ($pp) { # some tests cannot be performed with PurePerl as numbers don't # overflow in the same way as XS. push @tests, ( ['very large int cast to int', "99999999999999999999", SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["99999999999999999999"]}], ['very large int cast to int (strict)', "99999999999999999999", SQL_INTEGER, DBIstcf_STRICT, NO_CAST_STRICT, q{["99999999999999999999"]}], ['float cast to int', "99.99", SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["99.99"]}], ['float cast to int (strict)', "99.99", SQL_INTEGER, DBIstcf_STRICT, NO_CAST_STRICT, q{["99.99"]}], ['float cast to double', "99.99", SQL_DOUBLE, 0, CAST_OK, q{["99.99"]}] ); if ($Config{ivsize} == 4) { push @tests, ['4 byte max unsigned int cast to int (ivsize=4)', "4294967296", SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["4294967296"]}]; } elsif ($Config{ivsize} >= 8) { push @tests, ['4 byte max unsigned int cast to int (ivsize>8)', "4294967296", SQL_INTEGER, 0, CAST_OK, q{["4294967296"]}]; } } push @tests, ( ['non numeric cast to double', "aabb", SQL_DOUBLE, 0, NO_CAST_NO_STRICT, q{["aabb"]}], ['non numeric cast to double (strict)', "aabb", SQL_DOUBLE, DBIstcf_STRICT, NO_CAST_STRICT, q{["aabb"]}] ); foreach my $test(@tests) { my $val = $test->[1]; #diag(join(",", map {neat($_)} Data::Peek::DDual($val))); my $result; { no warnings; # lexical but also affects XS sub local $^W = 0; # needed for PurePerl tests $result = sql_type_cast($val, $test->[2], $test->[3]); } is($result, $test->[4], "result, $test->[0]"); if ($jx) { SKIP: { skip 'DiscardString not supported in PurePerl', 1 if $pp && ($test->[3] & DBIstcf_DISCARD_STRING); my $json = JSON::XS->new->encode([$val]); #diag(neat($val), ",", $json); # This test is about quotation of the value, not about the # style/formatting of JSON. Strip all leading/trailing # whitespace that is not part of the test, treating '[99]' # identical to ' [ 99 ] ' or '[99 ]' $json =~ s{^\s*\[\s*(.*?)\s*\]\s*$}{[$1]}; is($json, $test->[5], "json $test->[0]"); }; } if ($dp) { my ($pv, $iv, $nv, $rv, $hm); ($pv, $iv, $nv, $rv, $hm) = Data::Peek::DDual($val); if ($test->[3] & DBIstcf_DISCARD_STRING) { #diag("D::P ",neat($pv), ",", neat($iv), ",", neat($nv), # ",", neat($rv)); SKIP: { skip 'DiscardString not supported in PurePerl', 1 if $pp; ok(!defined($pv), "dp: discard works, $test->[0]"); }; } if ($test->[2] == SQL_DOUBLE) { #diag("D::P ", neat($pv), ",", neat($iv), ",", neat($nv), # ",", neat($rv)); if ($test->[4] == CAST_OK) { ok(defined($nv), "dp: nv defined $test->[0]"); } else { ok(!defined($nv) || !$nv, "dp: nv not defined $test->[0]"); } } } } done_testing; 1; DBI-1.652/t/09trace.t0000644000031300001440000000665214742423677013312 0ustar00merijnusers#!perl -w # vim:sw=4:ts=8 use strict; use Test::More tests => 99; ## ---------------------------------------------------------------------------- ## 09trace.t ## ---------------------------------------------------------------------------- # ## ---------------------------------------------------------------------------- BEGIN { $ENV{DBI_TRACE} = 0; # for PurePerl - ensure DBI_TRACE is in the env use_ok( 'DBI' ); } $|=1; my $trace_file = "dbitrace$$.log"; 1 while unlink $trace_file; warn "Can't unlink existing $trace_file: $!" if -e $trace_file; my $orig_trace_level = DBI->trace; DBI->trace(3, $trace_file); # enable trace before first driver load my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef); die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh; isa_ok($dbh, 'DBI::db'); $dbh->dump_handle("dump_handle test, write to log file", 2); DBI->trace(0, undef); # turn off and restore to STDERR SKIP: { skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i); ok( -s $trace_file, "trace file size = " . -s $trace_file); } DBI->trace($orig_trace_level); # no way to restore previous outfile XXX # Clean up when we're done. END { $dbh->disconnect if $dbh; 1 while unlink $trace_file; }; ## ---------------------------------------------------------------------------- # Check the database handle attributes. cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute'); 1 while unlink $trace_file; $dbh->trace(0, $trace_file); ok( -f $trace_file, '... trace file successfully created'); my @names = qw( SQL CON ENC DBD TXN foo bar baz boo bop ); my %flag; my $all_flags = 0; foreach my $name (@names) { print "parse_trace_flag $name\n"; ok( my $flag1 = $dbh->parse_trace_flag($name) ); ok( my $flag2 = $dbh->parse_trace_flags($name) ); is( $flag1, $flag2 ); $dbh->{TraceLevel} = $flag1; is( $dbh->{TraceLevel}, $flag1 ); $dbh->{TraceLevel} = 0; is( $dbh->{TraceLevel}, 0 ); $dbh->trace($flag1); is $dbh->trace, $flag1; is $dbh->{TraceLevel}, $flag1; $dbh->{TraceLevel} = $name; # set by name $dbh->{TraceLevel} = undef; # check no change on undef is( $dbh->{TraceLevel}, $flag1 ); $flag{$name} = $flag1; $all_flags |= $flag1 if defined $flag1; # reduce noise if there's a bug } print "parse_trace_flag @names\n"; ok(eq_set([ keys %flag ], [ @names ]), '...'); $dbh->{TraceLevel} = 0; $dbh->{TraceLevel} = join "|", @names; is($dbh->{TraceLevel}, $all_flags, '...'); { print "inherit\n"; my $sth = $dbh->prepare("select ctime, name from foo"); isa_ok( $sth, 'DBI::st' ); is( $sth->{TraceLevel}, $all_flags ); } $dbh->{TraceLevel} = 0; ok !$dbh->{TraceLevel}; $dbh->{TraceLevel} = 'ALL'; ok $dbh->{TraceLevel}; { print "test unknown parse_trace_flag\n"; my $warn = 0; local $SIG{__WARN__} = sub { if ($_[0] =~ /unknown/i) { ++$warn; print "caught warn: ",@_ }else{ warn @_ } }; is $dbh->parse_trace_flag("nonesuch"), undef; is $warn, 0; is $dbh->parse_trace_flags("nonesuch"), 0; is $warn, 1; is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL"); is $warn, 2; } $dbh->dump_handle("dump_handle test, write to log file", 2); $dbh->trace(0); ok !$dbh->{TraceLevel}; $dbh->trace(undef, "STDERR"); # close $trace_file ok( -s $trace_file ); 1; # end DBI-1.652/t/35thrclone.t0000644000031300001440000000402715230132752014003 0ustar00merijnusers#!perl -w $|=1; # --- Test DBI support for threads created after the DBI was loaded BEGIN { eval "use threads;" } # Must be first my $use_threads_err = $@; use strict; use Config qw(%Config); use Test::More; BEGIN { if (!$Config{useithreads}) { plan skip_all => "this $^O perl $] not supported for DBI iThreads"; } die $use_threads_err if $use_threads_err; # need threads } my $threads = 4; { package threads_sub; use base qw(threads); } use_ok('DBI'); $DBI::PurePerl = $DBI::PurePerl; # just to silence used only once warning $DBI::neat_maxlen = 12345; cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was successful'); my @connect_args = ("dbi:ExampleP:", '', ''); my $dbh_parent = DBI->connect_cached(@connect_args); isa_ok( $dbh_parent, 'DBI::db' ); # this our function for the threads to run sub testing { cmp_ok($DBI::neat_maxlen, '==', 12345, '... DBI::neat_maxlen still holding its value'); my $dbh = DBI->connect_cached(@connect_args); isa_ok( $dbh, 'DBI::db' ); isnt($dbh, $dbh_parent, '... new $dbh is not the same instance as $dbh_parent'); cmp_ok($dbh->{Driver}->{Kids}, '==', 1, '... the Driver has one Kid') unless $DBI::PurePerl && ok(1); # RT #77137: a thread created from a thread was crashing the # interpreter my $subthread = threads->new(sub {}); # provide a little insurance against thread scheduling issues (hopefully) # http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4369660.html eval { select undef, undef, undef, 0.2 }; $subthread->join(); } # load up the threads my @thr; push @thr, threads_sub->create( \&testing ) or die "thread->create failed ($!)" foreach (1..$threads); # join all the threads foreach my $thread (@thr) { # provide a little insurance against thread scheduling issues (hopefully) # http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4369660.html eval { select undef, undef, undef, 0.2 }; $thread->join; } pass('... all tests have passed'); done_testing; 1; DBI-1.652/t/48dbi_dbd_sqlengine.t0000644000031300001440000000540214742423677015623 0ustar00merijnusers#!perl -w $|=1; use strict; use Cwd; use File::Path; use File::Spec; use Test::More; my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; my $tbl; BEGIN { $tbl = "db_". $$ . "_" }; #END { $tbl and unlink glob "${tbl}*" } use_ok ("DBI"); use_ok ("DBI::DBD::SqlEngine"); use_ok ("DBD::File"); my $sql_statement = DBI::DBD::SqlEngine::Statement->isa('SQL::Statement'); my $dbh = DBI->connect( "DBI:File:", undef, undef, { PrintError => 0, RaiseError => 0, } ); # Can't use DBI::DBD::SqlEngine direct for my $sql ( split "\n", <<"" ) CREATE TABLE foo (id INT, foo TEXT) CREATE TABLE bar (id INT, baz TEXT) INSERT INTO foo VALUES (1, 'Hello world') INSERT INTO bar VALUES (1, 'Bugfixes welcome') INSERT bar VALUES (2, 'Bug reports, too') SELECT foo FROM foo where ID=1 UPDATE bar SET id=5 WHERE baz='Bugfixes welcome' DELETE FROM foo DELETE FROM bar WHERE baz='Bugfixes welcome' { my $sth; $sql =~ s/^\s+//; eval { $sth = $dbh->prepare( $sql ); }; ok( $sth, "prepare '$sql'" ); } for my $line ( split "\n", <<"" ) Junk -- Junk CREATE foo (id INT, foo TEXT) -- missing table INSERT INTO bar (1, 'Bugfixes welcome') -- missing "VALUES" UPDATE bar id=5 WHERE baz="Bugfixes welcome" -- missing "SET" DELETE * FROM foo -- waste between "DELETE" and "FROM" { my $sth; $line =~ s/^\s+//; my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ ); eval { $sth = $dbh->prepare( $sql ); }; ok( !$sth, "$test: prepare '$sql'" ); } SKIP: { # some SQL::Statement / SQL::Parser related tests skip( "Not running with SQL::Statement", 3 ) unless ($sql_statement); for my $line ( split "\n", <<"" ) Junk -- Junk CREATE TABLE bar (id INT, baz CHARACTER VARYING(255)) -- invalid column type { my $sth; $line =~ s/^\s+//; my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ ); eval { $sth = $dbh->prepare( $sql ); }; ok( !$sth, "$test: prepare '$sql'" ); } my $dbh2 = DBI->connect( "DBI:File:", undef, undef, { sql_dialect => "ANSI" } ); my $sth; eval { $sth = $dbh2->prepare( "CREATE TABLE foo (id INTEGER PRIMARY KEY, phrase CHARACTER VARYING(40) UNIQUE)" ); }; ok( $sth, "prepared statement using ANSI dialect" ); skip( "Gofer proxy prevents fetching embedded SQL::Parser object", 1 ); my $sql_parser = $dbh2->FETCH("sql_parser_object"); cmp_ok( $sql_parser->dialect(), "eq", "ANSI", "SQL::Parser has 'ANSI' as dialect" ); } SKIP: { skip( 'not running with DBIx::ContextualFetch', 2 ) unless eval { require DBIx::ContextualFetch; 1; }; my $dbh; ok ($dbh = DBI->connect('dbi:File:','','', {RootClass => 'DBIx::ContextualFetch'})); is ref $dbh, 'DBIx::ContextualFetch::db', 'root class is DBIx::ContextualFetch'; } done_testing (); DBI-1.652/t/07kids.t0000644000031300001440000000704215230132652013115 0ustar00merijnusers#!perl -w $|=1; use strict; use Test::More; use DBI 1.50; # also tests Exporter::require_version BEGIN { plan skip_all => '$h->{Kids} attribute not supported for DBI::PurePerl' if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning } ## ---------------------------------------------------------------------------- ## 07kids.t ## ---------------------------------------------------------------------------- # This test check the Kids and the ActiveKids attributes and how they act # in various situations. # # Check the database handle's kids: # - upon creation of handle # - upon creation of statement handle # - after execute of statement handle # - after finish of statement handle # - after destruction of statement handle # Check the driver handle's kids: # - after creation of database handle # - after disconnection of database handle # - after destruction of database handle ## ---------------------------------------------------------------------------- # Connect to the example driver and create a database handle my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '', { PrintError => 1, RaiseError => 0 }); # check our database handle to make sure its good isa_ok($dbh, 'DBI::db'); # check that it has no Kids or ActiveKids yet cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) at start'); cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) at start'); # create a scope for our $sth to live and die in do { # create a statement handle my $sth = $dbh->prepare('select uid from ./'); # verify that it is a correct statement handle isa_ok($sth, "DBI::st"); # check our Kids and ActiveKids after prepare cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $dbh->prepare'); cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $dbh->prepare'); $sth->execute(); # check our Kids and ActiveKids after execute cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->execute'); cmp_ok($dbh->{ActiveKids}, '==', 1, '... database handle has 1 ActiveKid(s) after $sth->execute'); $sth->finish(); # check our Kids and Activekids after finish cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->finish'); cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth->finish'); }; # now check it after the statement handle has been destroyed cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) after $sth is destroyed'); cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth is destroyed'); # get the database handles driver Driver my $drh = $dbh->{Driver}; # check that is it a correct driver handle isa_ok($drh, "DBI::dr"); # check the driver's Kids and ActiveKids cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s)'); cmp_ok( $drh->{ActiveKids}, '==', 1, '... driver handle has 1 ActiveKid(s)'); $dbh->disconnect; # check the driver's Kids and ActiveKids after $dbh->disconnect cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s) after $dbh->disconnect'); cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after $dbh->disconnect'); undef $dbh; ok(!defined($dbh), '... lets be sure that $dbh is not undefined'); # check the driver's Kids and ActiveKids after undef $dbh cmp_ok( $drh->{Kids}, '==', 0, '... driver handle has 0 Kid(s) after undef $dbh'); cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after undef $dbh'); done_testing; DBI-1.652/t/82sponge.t0000644000031300001440000000557315206024306013467 0ustar00merijnusers#! /usr/bin/env perl # vim: noet ts=2 sw=2: use strict; use warnings; use Test::More tests => 17; use Storable qw(dclone); use DBI qw(:sql_types); # our reference table: # # A0 B1 C2 # ------- --------- ------- # foo NULL bazooka # foolery bar NULL # NULL barrowman baz # # Historically, DBD::Sponge defaulted an sth's PRECISION to the length # of its column names, meaning that some DBI shells could truncate row # display. For example, formatting a row ('fo', NULL, 'ba') from our # reference table above. our @NAMES = ( 'A0', 'B1', 'C2' ); our @ROWS = (['foo', undef, 'bazooka'], ['foolery', 'bar', undef ], [undef, 'barrowman', 'baz' ]); my $dbh = DBI->connect("dbi:Sponge:", '', ''); ok($dbh, "connect(dbi:Sponge:) succeeds"); my $sth = $dbh->prepare("simple, correct sponge", { rows => dclone( \@ROWS ), NAME => [ @NAMES ], }); ok($sth, "prepare() of 3x3 result succeeded"); is_deeply($sth->{NAME}, ['A0', 'B1', 'C2'], "column NAMEs as expected"); is_deeply($sth->{TYPE}, [SQL_VARCHAR, SQL_VARCHAR, SQL_VARCHAR], "column TYPEs default to SQL_VARCHAR"); # # Old versions of DBD-Sponge defaulted PRECISION (data "length") to # length of the field _names_ rather than the length of the _data_. # is_deeply($sth->{PRECISION}, [7, 9, 7], "column PRECISION matches lengths of longest field data"); is_deeply($sth->fetch(), $ROWS[0], "first row fetch as expected"); is_deeply($sth->fetch(), $ROWS[1], "second row fetch as expected"); is_deeply($sth->fetch(), $ROWS[2], "third row fetch as expected"); ok(!defined($sth->fetch()), "fourth fetch returns undef"); # Test that DBD-Sponge preserves bogus user-supplied attributes but # ignores them when returning rows $sth = $dbh->prepare('user-supplied silly TYPE and PRECISION', { rows => dclone( \@ROWS ), NAME => [qw( first_col second_col third_col )], TYPE => [SQL_INTEGER, SQL_DATETIME, SQL_CHAR], PRECISION => [1, 100_000, 0], }); ok($sth, "prepare() 3x3 result with TYPE and PRECISION succeeded"); is_deeply($sth->{NAME}, ['first_col','second_col','third_col'], "column NAMEs again as expected"); is_deeply($sth->{TYPE}, [SQL_INTEGER, SQL_DATETIME, SQL_CHAR], "column TYPEs not overwritten"); is_deeply($sth->{PRECISION}, [1, 100_000, 0], "column PRECISION not overwritten"); is_deeply($sth->fetch(), $ROWS[0], "first row fetch as expected, despite bogus attributes"); is_deeply($sth->fetch(), $ROWS[1], "second row fetch as expected, despite bogus attributes"); is_deeply($sth->fetch(), $ROWS[2], "third row fetch as expected, despite bogus attributes"); ok(!defined($sth->fetch()), "fourth fetch returns undef, despite bogus attributes"); DBI-1.652/t/60preparse.t0000755000031300001440000001230215236611305014004 0ustar00merijnusers#!perl -w use DBI qw(:preparse_flags); $|=1; use Test::More; BEGIN { if ($DBI::PurePerl) { plan skip_all => 'preparse not supported for DBI::PurePerl'; } } my $dbh = DBI->connect("dbi:ExampleP:", "", "", { PrintError => 0, }); isa_ok( $dbh, 'DBI::db' ); sub pp { my $dbh = shift; my $rv = $dbh->preparse(@_); return $rv; } # --------------------------------------------------------------------- # # DBIpp_cm_cs /* C style */ # DBIpp_cm_hs /* # */ # DBIpp_cm_dd /* -- */ # DBIpp_cm_br /* {} */ # DBIpp_cm_dw /* '-- ' dash dash whitespace */ # DBIpp_cm_XX /* any of the above */ # DBIpp_ph_qm /* ? */ # DBIpp_ph_cn /* :1 */ # DBIpp_ph_cs /* :name */ # DBIpp_ph_sp /* %s (as return only, not accept) */ # DBIpp_ph_XX /* any of the above */ # DBIpp_st_qq /* '' char escape */ # DBIpp_st_bs /* \ char escape */ # DBIpp_st_XX /* any of the above */ # ===================================================================== # # pp (h input return accept expected) # # ===================================================================== # ## Comments: is( pp($dbh, "a#b\nc", DBIpp_cm_cs, DBIpp_cm_hs), "a/*b*/\nc" ); is( pp($dbh, "a#b\nc", DBIpp_cm_dw, DBIpp_cm_hs), "a-- b\nc" ); is( pp($dbh, "a/*b*/c", DBIpp_cm_hs, DBIpp_cm_cs), "a#b\nc" ); is( pp($dbh, "a{b}c", DBIpp_cm_cs, DBIpp_cm_br), "a/*b*/c" ); is( pp($dbh, "a--b\nc", DBIpp_cm_br, DBIpp_cm_dd), "a{b}\nc" ); is( pp($dbh, "a-- b\n/*c*/d", DBIpp_cm_br, DBIpp_cm_cs|DBIpp_cm_dw), "a{ b}\n{c}d" ); is( pp($dbh, "a/*b*/c#d\ne--f\nh-- i\nj{k}", 0, DBIpp_cm_XX), "a c\ne\nh\nj " ); ## Placeholders: is( pp($dbh, "a = :1", DBIpp_ph_qm, DBIpp_ph_cn), "a = ?" ); is( pp($dbh, "a = :1", DBIpp_ph_sp, DBIpp_ph_cn), "a = %s" ); is( pp($dbh, "a = ?" , DBIpp_ph_cn, DBIpp_ph_qm), "a = :p1" ); is( pp($dbh, "a = ?" , DBIpp_ph_sp, DBIpp_ph_qm), "a = %s" ); is( pp($dbh, "a = :name", DBIpp_ph_qm, DBIpp_ph_cs), "a = ?" ); is( pp($dbh, "a = :name", DBIpp_ph_sp, DBIpp_ph_cs), "a = %s" ); is( pp($dbh, "a = ? b = ? c = ?", DBIpp_ph_cn, DBIpp_ph_XX), "a = :p1 b = :p2 c = :p3" ); ## Placeholders inside comments (should be ignored where comments style is accepted): is( pp( $dbh, "a = ? /*b = :1*/ c = ?", DBIpp_cm_dw|DBIpp_ph_cn, DBIpp_cm_cs|DBIpp_ph_qm), "a = :p1 -- b = :1\n c = :p2" ); ## Placeholders inside single and double quotes (should be ignored): is( pp( $dbh, "a = ? 'b = :1' c = ?", DBIpp_ph_cn, DBIpp_ph_XX), "a = :p1 'b = :1' c = :p2" ); is( pp( $dbh, 'a = ? "b = :1" c = ?', DBIpp_ph_cn, DBIpp_ph_XX), 'a = :p1 "b = :1" c = :p2' ); ## Comments inside single and double quotes (should be ignored): is( pp( $dbh, "a = ? '{b = :1}' c = ?", DBIpp_cm_cs|DBIpp_ph_cn, DBIpp_cm_XX|DBIpp_ph_qm), "a = :p1 '{b = :1}' c = :p2" ); is( pp( $dbh, 'a = ? "/*b = :1*/" c = ?', DBIpp_cm_dw|DBIpp_ph_cn, DBIpp_cm_XX|DBIpp_ph_qm), 'a = :p1 "/*b = :1*/" c = :p2' ); ## Single and double quoted strings starting inside comments (should be ignored): is( pp( $dbh, 'a = ? /*"b = :1 */ c = ?', DBIpp_cm_br|DBIpp_ph_cn, DBIpp_cm_XX|DBIpp_ph_qm), 'a = :p1 {"b = :1 } c = :p2' ); ## Check error conditions are trapped: is( pp($dbh, "a = :value and b = :1", DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef ); ok( $DBI::err ); is( $DBI::errstr, "preparse found mixed placeholder styles (:1 / :name)" ); is( pp($dbh, "a = :1 and b = :3", DBIpp_ph_qm, DBIpp_ph_cn), undef ); ok( $DBI::err ); is( $DBI::errstr, "preparse found placeholder :3 out of sequence, expected :2" ); is( pp($dbh, "foo ' comment", 0, 0), "foo ' comment" ); ok( $DBI::err ); is( $DBI::errstr, "preparse found unterminated single-quoted string" ); is( pp($dbh, 'foo " comment', 0, 0), 'foo " comment' ); ok( $DBI::err ); is( $DBI::errstr, "preparse found unterminated double-quoted string" ); is( pp($dbh, 'foo /* comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo /* comment' ); ok( $DBI::err ); is( $DBI::errstr, "preparse found unterminated bracketed C-style comment" ); is( pp($dbh, 'foo { comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo { comment' ); ok( $DBI::err ); is( $DBI::errstr, "preparse found unterminated bracketed {...} comment" ); # --------------------------------------------------------------------- # is( pp($dbh, 'a = :99999', DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef, 'out of sequence'); ok( $DBI::err ); is( $DBI::errstr, "preparse found placeholder :99999 out of sequence, expected :1"); is( pp($dbh, 'a = :100000', DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef, 'exceeds limit'); ok( $DBI::err ); is( $DBI::errstr, "preparse found :p100000 which is outside the allowed range."); is( pp($dbh, 'a = :2147483648', DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef, 'exceeds limit'); ok( $DBI::err ); is( $DBI::errstr, "preparse found :p-2147483648 which is outside the allowed range."); is( pp($dbh, 'a = :12345678987654321', DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef, 'exceeds limit'); ok( $DBI::err ); like( $DBI::errstr, qr{^preparse found :p\d+ which is outside the allowed range.$}); $dbh->disconnect; done_testing; 1; DBI-1.652/t/43prof_env.t0000644000031300001440000000216612127465144014012 0ustar00merijnusers#!perl -w $|=1; use strict; # # test script for using DBI_PROFILE env var to enable DBI::Profile # and testing non-ref assignments to $h->{Profile} # BEGIN { $ENV{DBI_PROFILE} = 6 } # prior to use DBI use DBI; use DBI::Profile; use Config; use Data::Dumper; BEGIN { if ($DBI::PurePerl) { print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n"; exit 0; } } use Test::More tests => 11; DBI->trace(0, "STDOUT"); my $dbh1 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); is(ref $dbh1->{Profile}, "DBI::Profile"); is(ref $dbh1->{Profile}{Data}, 'HASH'); is(ref $dbh1->{Profile}{Path}, 'ARRAY'); my $dbh2 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); is(ref $dbh2->{Profile}, "DBI::Profile"); is(ref $dbh2->{Profile}{Data}, 'HASH'); is(ref $dbh2->{Profile}{Path}, 'ARRAY'); is $dbh1->{Profile}, $dbh2->{Profile}, '$h->{Profile} should be shared'; $dbh1->do("set dummy=1"); $dbh1->do("set dummy=2"); my $profile = $dbh1->{Profile}; my $p_data = $profile->{Data}; is keys %$p_data, 3; # '', $sql1, $sql2 ok $p_data->{''}; ok $p_data->{"set dummy=1"}; ok $p_data->{"set dummy=2"}; __END__ DBI-1.652/t/20meta.t0000644000031300001440000000142612127465144013113 0ustar00merijnusers#!perl -w use strict; use Test::More tests => 8; $|=1; $^W=1; BEGIN { use_ok( 'DBI', ':sql_types' ) } BEGIN { use_ok( 'DBI::DBD::Metadata' ) } # just to check for syntax errors etc my $dbh = DBI->connect("dbi:ExampleP:.","","", { FetchHashKeyName => 'NAME_lc' }) or die "Unable to connect to ExampleP driver: $DBI::errstr"; isa_ok($dbh, 'DBI::db'); #$dbh->trace(3); #use Data::Dumper; #print Dumper($dbh->type_info_all); #print Dumper($dbh->type_info); #print Dumper($dbh->type_info(DBI::SQL_INTEGER)); my @ti = $dbh->type_info; ok(@ti>0); is($dbh->type_info(SQL_INTEGER)->{DATA_TYPE}, SQL_INTEGER); is($dbh->type_info(SQL_INTEGER)->{TYPE_NAME}, 'INTEGER'); is($dbh->type_info(SQL_VARCHAR)->{DATA_TYPE}, SQL_VARCHAR); is($dbh->type_info(SQL_VARCHAR)->{TYPE_NAME}, 'VARCHAR'); 1; DBI-1.652/t/08keeperr.t0000644000031300001440000002662414742423677013651 0ustar00merijnusers#!perl -w use strict; use Test::More; ## ---------------------------------------------------------------------------- ## 08keeperr.t ## ---------------------------------------------------------------------------- # ## ---------------------------------------------------------------------------- BEGIN { use_ok('DBI'); } $|=1; $^W=1; ## ---------------------------------------------------------------------------- # subclass DBI # DBI subclass package My::DBI; use base 'DBI'; # Database handle subclass package My::DBI::db; use base 'DBI::db'; # Statement handle subclass package My::DBI::st; use base 'DBI::st'; sub execute { my $sth = shift; # we localize an attribute here to check that the corresponding STORE # at scope exit doesn't clear any recorded error local $sth->{Warn} = 0; my $rv = $sth->SUPER::execute(@_); return $rv; } ## ---------------------------------------------------------------------------- # subclass the subclass of DBI package Test; use strict; use base 'My::DBI'; use DBI; my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 1 }); sub test_select { my $dbh = shift; eval { $dbh->selectrow_arrayref('select * from foo') }; $dbh->disconnect; return $@; } my $err1 = test_select( My::DBI->connect(@con_info) ); Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error'); my $err2 = test_select( DBI->connect(@con_info) ); Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error'); package main; my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; # test ping does not destroy the errstr sub ping_keeps_err { my $dbh = DBI->connect('DBI:ExampleP:', undef, undef, { PrintError => 0 }); $dbh->set_err(42, "ERROR 42"); is $dbh->err, 42; is $dbh->errstr, "ERROR 42"; ok $dbh->ping, "ping returns true"; is $dbh->err, 42, "err unchanged after ping"; is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; $dbh->disconnect; $dbh->set_err(42, "ERROR 42"); is $dbh->err, 42, "err unchanged after ping"; is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; ok !$dbh->ping, "ping returns false"; # it's reasonable for ping() to set err/errstr if it fails # so here we just test that there is an error ok $dbh->err, "err true after failed ping"; ok $dbh->errstr, "errstr true after failed ping"; # for a driver which doesn't have its own ping $dbh = DBI->connect('DBI:Sponge:', undef, undef, { PrintError => 0 }); $dbh->STORE(Active => 1); $dbh->set_err(42, "ERROR 42"); is $dbh->err, 42; is $dbh->errstr, "ERROR 42"; ok $dbh->ping, "ping returns true: ".$dbh->ping; is $dbh->err, 42, "err unchanged after ping"; is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; $dbh->disconnect; $dbh->STORE(Active => 0); $dbh->set_err(42, "ERROR 42"); is $dbh->err, 42, "err unchanged after ping"; is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; ok !$dbh->ping, "ping returns false"; # it's reasonable for ping() to set err/errstr if it fails # so here we just test that there is an error ok $dbh->err, "err true after failed ping"; ok $dbh->errstr, "errstr true after failed ping"; } ## ---------------------------------------------------------------------------- print "Test HandleSetErr\n"; my $dbh = DBI->connect(@con_info); isa_ok($dbh, "DBI::db"); $dbh->{RaiseError} = 1; $dbh->{PrintError} = 1; $dbh->{RaiseWarn} = 0; $dbh->{PrintWarn} = 1; # warning handler my %warn; my @handlewarn; sub reset_warn_counts { %warn = ( failed => 0, warning => 0 ); @handlewarn = (0,0,0); } reset_warn_counts(); $SIG{__WARN__} = sub { my $msg = shift; if ($msg =~ /^DBD::\w+::\S+\s+(\S+)\s+(\w+)/) { ++$warn{$2}; $msg =~ s/\n/\\n/g; print "warn: '$msg'\n"; return; } warn $msg; }; # HandleSetErr handler $dbh->{HandleSetErr} = sub { my ($h, $err, $errstr, $state) = @_; return 0 unless defined $err; ++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls return 1 if $state && $state eq "return"; # for tests ($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123") if $state && $state eq "override"; # for tests return 0 if $err; # be transparent for errors local $^W; print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n"; return 0; }; # start our tests ok(!defined $DBI::err, '... $DBI::err is not defined'); # ---- $dbh->set_err("", "(got info)"); ok(defined $DBI::err, '... $DBI::err is defined'); # true is($DBI::err, "", '... $DBI::err is an empty string'); is($DBI::errstr, "(got info)", '... $DBI::errstr is as we expected'); is($dbh->errstr, "(got info)", '... $dbh->errstr matches $DBI::errstr'); cmp_ok($warn{failed}, '==', 0, '... $warn{failed} is 0'); cmp_ok($warn{warning}, '==', 0, '... $warn{warning} is 0'); is_deeply(\@handlewarn, [ 1, 0, 0 ], '... the @handlewarn array is (1, 0, 0)'); # ---- $dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn ok(defined $DBI::err, '... $DBI::err is defined'); is($DBI::err, "0", '... $DBI::err is "0"'); is($DBI::errstr, "(got info)\n(got warn)", '... $DBI::errstr is as we expected'); is($dbh->errstr, "(got info)\n(got warn)", '... $dbh->errstr matches $DBI::errstr'); is($DBI::state, "AA001", '... $DBI::state is AA001'); cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1'); is_deeply(\@handlewarn, [ 1, 1, 0 ], '... the @handlewarn array is (1, 1, 0)'); # ---- $dbh->set_err("", "(got more info)"); # triggers PrintWarn ok(defined $DBI::err, '... $DBI::err is defined'); is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's still a warn is($dbh->err, "0", '... $dbh->err is "0"'); is($DBI::state, "AA001", '... $DBI::state is AA001'); is($DBI::errstr, "(got info)\n(got warn)\n(got more info)", '... $DBI::errstr is as we expected'); is($dbh->errstr, "(got info)\n(got warn)\n(got more info)", '... $dbh->errstr matches $DBI::errstr'); cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); is_deeply(\@handlewarn, [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)'); # ---- $dbh->{RaiseError} = 0; $dbh->{PrintError} = 1; $dbh->{RaiseWarn} = 1; # ---- $dbh->set_err("42", "(got error)", "AA002"); ok(defined $DBI::err, '... $DBI::err is defined'); cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)", '... $dbh->errstr is as we expected'); is($DBI::state, "AA002", '... $DBI::state is AA002'); is_deeply(\@handlewarn, [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)'); # ---- $dbh->set_err("", "(got info)"); ok(defined $DBI::err, '... $DBI::err is defined'); cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)", '... $dbh->errstr is as we expected'); is_deeply(\@handlewarn, [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)'); # ---- $dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err ok(defined $DBI::err, '... $DBI::err is defined'); cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn)", '... $dbh->errstr is as we expected'); is_deeply(\@handlewarn, [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)'); # ---- $dbh->set_err("4200", "(got new error)", "AA003"); ok(defined $DBI::err, '... $DBI::err is defined'); cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200'); cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now AA003]\n(got new error)", '... $dbh->errstr is as we expected'); is_deeply(\@handlewarn, [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)'); # ---- $dbh->set_err(undef, "foo", "bar"); # clear error ok(!defined $dbh->errstr, '... $dbh->errstr is defined'); ok(!defined $dbh->err, '... $dbh->err is defined'); is($dbh->state, "", '... $dbh->state is an empty string'); # ---- reset_warn_counts(); # ---- my @ret; @ret = $dbh->set_err(1, "foo"); # PrintError cmp_ok(scalar(@ret), '==', 1, '... only returned one value'); ok(!defined $ret[0], '... the first value is undefined'); ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); # PrintError ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); # PrintError ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); # PrintError is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn", '... $dbh->errstr is as we expected'); is($warn{failed}, 4, '... $warn{failed} is 4'); is_deeply(\@handlewarn, [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)'); # ---- $dbh->set_err(undef, undef, undef); # clear error @ret = $dbh->set_err(1, "foo", "AA123", "method"); cmp_ok(scalar @ret, '==', 1, '... only returned one value'); ok(!defined $ret[0], '... the first value is undefined'); @ret = $dbh->set_err(1, "foo", "AA123", "method", "42"); cmp_ok(scalar @ret, '==', 1, '... only returned one value'); is($ret[0], "42", '... the first value is "42"'); @ret = $dbh->set_err(1, "foo", "return"); cmp_ok(scalar @ret, '==', 0, '... returned no values'); # ---- $dbh->set_err(undef, undef, undef); # clear error @ret = $dbh->set_err("", "info", "override"); cmp_ok(scalar @ret, '==', 1, '... only returned one value'); ok(!defined $ret[0], '... the first value is undefined'); cmp_ok($dbh->err, '==', 99, '... $dbh->err is 99'); is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected'); is($dbh->state, "OV123", '... $dbh->state is as we expected'); $dbh->disconnect; # --- ping_keeps_err(); # --- reset_warn_counts(); SKIP: { # we could test this with gofer is we used a different keep_err method other than STORE # to trigger the set_err calls skip 'set_err keep_error skipped for Gofer', 2 if $using_dbd_gofer; $dbh->{examplep_set_err} = ""; # set information state cmp_ok($warn{warning}, '==', 0, 'no extra warning generated for set_err("") in STORE'); $dbh->{RaiseWarn} = 0; $dbh->{examplep_set_err} = "0"; # set warning state cmp_ok($warn{warning}, '==', 1, 'warning generated for set_err("0") in STORE'); } # --- # ---- done_testing(); 1; # end DBI-1.652/t/54_dbd_mem.t0000644000031300001440000000207614742423677013736 0ustar00merijnusers#!perl -w $|=1; use strict; use Cwd; use File::Path; use File::Spec; use Test::More; my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; $using_dbd_gofer and plan skip_all => "modifying meta data doesn't work with Gofer-AutoProxy"; my $tbl; BEGIN { $tbl = "db_". $$ . "_" }; #END { $tbl and unlink glob "${tbl}*" } use_ok ("DBI"); use_ok ("DBD::Mem"); my $dbh = DBI->connect( "DBI:Mem:", undef, undef, { PrintError => 0, RaiseError => 0, } ); # Can't use DBI::DBD::SqlEngine direct for my $sql ( split "\n", <<"" ) CREATE TABLE foo (id INT, foo TEXT) CREATE TABLE bar (id INT, baz TEXT) INSERT INTO foo VALUES (1, 'Hello world') INSERT INTO bar VALUES (1, 'Bugfixes welcome') INSERT bar VALUES (2, 'Bug reports, too') SELECT foo FROM foo where ID=1 UPDATE bar SET id=5 WHERE baz='Bugfixes welcome' DELETE FROM foo DELETE FROM bar WHERE baz='Bugfixes welcome' { my $done; $sql =~ s/^\s+//; eval { $done = $dbh->do( $sql ); }; ok( $done, "executed '$sql'" ) or diag $dbh->errstr; } done_testing (); DBI-1.652/t/51dbm_file.t0000644000031300001440000001620415206022252013720 0ustar00merijnusers#!perl -w $| = 1; use strict; use warnings; use Cwd (); use File::Copy (); use File::Path; use File::Spec (); use Test::More; my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY} || "") =~ m/^dbi:Gofer.*transport=/i; use DBI; do "./t/lib.pl"; { # test issue reported in RT#99508 my @msg; my $dbh = eval { local $SIG{__WARN__} = sub { push @msg => @_ }; local $SIG{__DIE__} = sub { push @msg => @_ }; DBI->connect ("dbi:DBM:f_dir=./hopefully-doesnt-existst;sql_identifier_case=1;RaiseError=1"); }; is ($dbh, undef, "Connect failed"); like ("@msg", qr{.*hopefully-doesnt-existst.*}, "Cannot open from non-existing directory with attributes in DSN"); @msg = (); $dbh = eval { local $SIG{__WARN__} = sub { push @msg => @_ }; local $SIG{__DIE__} = sub { push @msg => @_ }; DBI->connect ("dbi:DBM:", , undef, undef, { f_dir => "./hopefully-doesnt-existst", sql_identifier_case => 1, RaiseError => 1, }); }; is ($dbh, undef, "Connect failed"); like ("@msg", qr{.*hopefully-doesnt-existst}, "Cannot open from non-existing directory with attributes in HASH"); } my $dir = test_dir (); my $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, sql_identifier_case => 1, # SQL_IC_UPPER }); ok ($dbh, "Connect with driver attributes in hash"); ok ($dbh->do ("drop table if exists FRED"), "drop table"); my $dirfext = $^O eq "VMS" ? ".sdbm_dir" : ".dir"; $dbh->do ("create table fred (a integer, b integer)"); ok (-f File::Spec->catfile ($dir, "FRED$dirfext"), "FRED$dirfext exists"); rmtree $dir; mkpath $dir; if ($using_dbd_gofer) { # can't modify attributes when connect through a Gofer instance $dbh->disconnect (); $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER }); } else { $dbh->dbm_clear_meta ("fred"); # otherwise the col_names are still known! $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER } $dbh->do ("create table FRED (a integer, b integer)"); ok (-f File::Spec->catfile ($dir, "fred$dirfext"), "fred$dirfext exists"); my $tblfext; unless ($using_dbd_gofer) { $tblfext = $dbh->{dbm_tables}{fred}{f_ext} || ""; $tblfext =~ s{/r$}{}; ok (-f File::Spec->catfile ($dir, "fred$tblfext"), "fred$tblfext exists"); } ok ($dbh->do ("insert into fRED (a, b) values (1, 2)"), "insert into mixed case table"); # but change fRED to FRED and it works. ok ($dbh->do ("insert into FRED (a, b) values (2, 1)"), "insert into uppercase table"); unless ($using_dbd_gofer) { my $fn_tbl2 = $dbh->{dbm_tables}{fred}{f_fqfn}; $fn_tbl2 =~ s/fred(\.[^.]*)?$/freddy$1/; my @dbfiles = grep { -f $_ } ( $dbh->{dbm_tables}{fred}{f_fqfn}, $dbh->{dbm_tables}{fred}{f_fqln}, $dbh->{dbm_tables}{fred}{f_fqbn} . ".dir" ); foreach my $fn (@dbfiles) { my $tgt_fn = $fn; $tgt_fn =~ s/fred(\.[^.]*)?$/freddy$1/; File::Copy::copy ($fn, $tgt_fn); } $dbh->{dbm_tables}{krueger}{file} = $fn_tbl2; my $r = $dbh->selectall_arrayref ("select * from Krueger"); ok (@$r == 2, "rows found via cloned mixed case table"); ok ($dbh->do ("drop table if exists KRUeGEr"), "drop table"); } my $r = $dbh->selectall_arrayref ("select * from Fred"); ok (@$r == 2, "rows found via mixed case table"); SKIP: { DBD::DBM::Statement->isa ("SQL::Statement") or skip ("quoted identifiers aren't supported by DBI::SQL::Nano", 1); my $abs_tbl = File::Spec->catfile ($dir, "fred"); # work around SQL::Statement bug DBD::DBM::Statement->isa ("SQL::Statement") and SQL::Statement->VERSION () lt "1.32" and $abs_tbl =~ s{\\}{/}g; $r = $dbh->selectall_arrayref (sprintf 'select * from "%s"', $abs_tbl); ok (@$r == 2, "rows found via select via fully qualified path"); } if ($using_dbd_gofer) { ok ($dbh->do ("drop table if exists FRED"), "drop table"); ok (!-f File::Spec->catfile ($dir, "fred$dirfext"), "fred$dirfext removed"); } else { my $tbl_info = {file => "fred$tblfext"}; ok ($dbh->disconnect (), "disconnect"); $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER dbm_tables => {fred => $tbl_info}, }); my @tbl; @tbl = $dbh->tables (undef, undef, undef, undef); is (scalar @tbl, 1, "Found 1 tables"); $r = $dbh->selectall_arrayref ("select * from Fred"); ok (@$r == 2, "rows found after reconnect using 'dbm_tables'"); my $deep_dir = File::Spec->catdir ($dir, "deep"); mkpath $deep_dir; $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $deep_dir, sql_identifier_case => 2, # SQL_IC_LOWER }); ok ($dbh->do ("create table wilma (a integer, b char (10))"), "Create wilma"); ok ($dbh->do ("insert into wilma values (1, 'Barney')"), "insert Barney"); ok ($dbh->disconnect (), "disconnect"); $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER }); # Make sure wilma is not found without f_dir_search @tbl = $dbh->tables (undef, undef, undef, undef); is (scalar @tbl, 1, "Found 1 table"); ok ($dbh->disconnect (), "disconnect"); $dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, f_dir_search => [ $deep_dir ], sql_identifier_case => 2, # SQL_IC_LOWER }); @tbl = $dbh->tables (undef, undef, undef, undef); is (scalar @tbl, 2, "Found 2 tables"); # f_dir should always appear before f_dir_search like ($tbl[0], qr{(?:^|\.)fred$}i, "Fred first"); like ($tbl[1], qr{(?:^|\.)wilma$}i, "Fred second"); my ($n, $sth); ok ($sth = $dbh->prepare ("select * from fred"), "select from fred"); ok ($sth->execute, "execute fred"); $n = 0; $n++ while $sth->fetch; is ($n, 2, "2 entry in fred"); ok ($sth = $dbh->prepare ("select * from wilma"), "select from wilma"); ok ($sth->execute, "execute wilma"); $n = 0; $n++ while $sth->fetch; is ($n, 1, "1 entry in wilma"); ok ($dbh->do (q/drop table if exists FRED/), "drop table fred"); ok (!-f File::Spec->catfile ($dir, "fred$dirfext"), "fred$dirfext removed"); ok (!-f File::Spec->catfile ($dir, "fred$tblfext"), "fred$tblfext removed"); ok ($dbh->do (q/drop table if exists wilma/), "drop table wilma"); ok (!-f File::Spec->catfile ($deep_dir, "wilma$dirfext"), "wilma$dirfext removed"); ok (!-f File::Spec->catfile ($deep_dir, "wilma$tblfext"), "wilma$tblfext removed"); } unless ($using_dbd_gofer) { ok ($dbh = DBI->connect ("dbi:DBM:", undef, undef, { f_dir => $dir, f_dir_search => [ "t" ], }), "New dbh for CVE"); $dbh->{dbm_tables}{fred}{file} = File::Spec->catdir (Cwd::abs_path ( File::Spec->catdir ($dir, "..")), "fred"); my @msg; eval { local $SIG{__DIE__} = sub { push @msg => @_ }; local $dbh->{PrintError} = 0; $dbh->do ("create table fred (a integer, b integer)"); }; like ("@msg", qr{is unsafe and not allowed}, "unsafe is caught"); } done_testing (); DBI-1.652/t/12quote.t0000644000031300001440000000322214742423677013331 0ustar00merijnusers#!perl -w use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB use strict; use Test::More tests => 10; use DBI qw(:sql_types); use Config; use Cwd; $^W = 1; $| = 1; my $dbh = DBI->connect('dbi:ExampleP:', '', ''); sub check_quote { # checking quote is($dbh->quote("quote's"), "'quote''s'", '... quoting strings with embedded single quotes'); is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as SQL_VARCHAR'); is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as SQL_INTEGER'); is($dbh->quote(undef), "NULL", '... quoting undef as NULL'); } check_quote(); sub check_quote_identifier { is($dbh->quote_identifier('foo'), '"foo"', '... properly quotes foo as "foo"'); is($dbh->quote_identifier('f"o'), '"f""o"', '... properly quotes f"o as "f""o"'); is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '... properly quotes foo, bar as "foo"."bar"'); is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '... properly quotes undef, undef, bar as "bar"'); is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '... properly quotes foo, undef, bar as "foo"."bar"'); SKIP: { skip "Can't test alternate quote_identifier logic with DBI_AUTOPROXY", 1 if $ENV{DBI_AUTOPROXY}; my $qi = $dbh->{dbi_quote_identifier_cache} || die "test out of date with dbi internals?"; $qi->[1] = '@'; # SQL_CATALOG_NAME_SEPARATOR $qi->[2] = 2; # SQL_CATALOG_LOCATION is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now quotes it as "bar"@"foo" after flushing cache'); } } check_quote_identifier(); 1; DBI-1.652/t/lib.pl0000644000031300001440000000150014656646601012742 0ustar00merijnusers#!/usr/bin/perl # lib.pl is the file where database specific things should live, # wherever possible. For example, you define certain constants # here and the like. use strict; use File::Basename; use File::Path; use File::Spec; my $test_dir; END { defined( $test_dir ) and rmtree $test_dir } sub test_dir { unless( defined( $test_dir ) ) { $test_dir = File::Spec->rel2abs( File::Spec->curdir () ); $test_dir = File::Spec->catdir ( $test_dir, "test_output_" . $$ ); $test_dir = VMS::Filespec::unixify($test_dir) if $^O eq 'VMS'; rmtree $test_dir if -d $test_dir; mkpath $test_dir; # There must be at least one directory in the test directory, # and nothing guarantees that dot or dot-dot directories will exist. mkpath ( File::Spec->catdir( $test_dir, '000_just_testing' ) ); } return $test_dir; } 1; DBI-1.652/t/01basics.t0000755000031300001440000003357014742423677013452 0ustar00merijnusers#!perl -w use strict; use Test::More tests => 130; use File::Spec; use Config; $|=1; ## ---------------------------------------------------------------------------- ## 01basic.t - test of some basic DBI functions ## ---------------------------------------------------------------------------- # Mostly this script takes care of testing the items exported by the 3 # tags below (in this order): # - :sql_types # - :squl_cursor_types # - :util # It also then handles some other class methods and functions of DBI, such # as the following: # - $DBI::dbi_debug & its relation to DBI->trace # - DBI->internal # and then tests on that return value: # - $i->debug # - $i->{DebugDispatch} # - $i->{Warn} # - $i->{Attribution} # - $i->{Version} # - $i->{private_test1} # - $i->{cachedKids} # - $i->{Kids} # - $i->{ActiveKids} # - $i->{Active} # - and finally that it will not autovivify # - DBI->available_drivers # - DBI->installed_versions (only for developers) ## ---------------------------------------------------------------------------- ## load DBI and export some symbols BEGIN { diag "--- Perl $] on $Config{archname}"; use_ok('DBI', qw( :sql_types :sql_cursor_types :utils )); } ## ---------------------------------------------------------------------------- ## testing the :sql_types exports cmp_ok(SQL_GUID , '==', -11, '... testing sql_type'); cmp_ok(SQL_WLONGVARCHAR , '==', -10, '... testing sql_type'); cmp_ok(SQL_WVARCHAR , '==', -9, '... testing sql_type'); cmp_ok(SQL_WCHAR , '==', -8, '... testing sql_type'); cmp_ok(SQL_BIT , '==', -7, '... testing sql_type'); cmp_ok(SQL_TINYINT , '==', -6, '... testing sql_type'); cmp_ok(SQL_BIGINT , '==', -5, '... testing sql_type'); cmp_ok(SQL_LONGVARBINARY , '==', -4, '... testing sql_type'); cmp_ok(SQL_VARBINARY , '==', -3, '... testing sql_type'); cmp_ok(SQL_BINARY , '==', -2, '... testing sql_type'); cmp_ok(SQL_LONGVARCHAR , '==', -1, '... testing sql_type'); cmp_ok(SQL_UNKNOWN_TYPE , '==', 0, '... testing sql_type'); cmp_ok(SQL_ALL_TYPES , '==', 0, '... testing sql_type'); cmp_ok(SQL_CHAR , '==', 1, '... testing sql_type'); cmp_ok(SQL_NUMERIC , '==', 2, '... testing sql_type'); cmp_ok(SQL_DECIMAL , '==', 3, '... testing sql_type'); cmp_ok(SQL_INTEGER , '==', 4, '... testing sql_type'); cmp_ok(SQL_SMALLINT , '==', 5, '... testing sql_type'); cmp_ok(SQL_FLOAT , '==', 6, '... testing sql_type'); cmp_ok(SQL_REAL , '==', 7, '... testing sql_type'); cmp_ok(SQL_DOUBLE , '==', 8, '... testing sql_type'); cmp_ok(SQL_DATETIME , '==', 9, '... testing sql_type'); cmp_ok(SQL_DATE , '==', 9, '... testing sql_type'); cmp_ok(SQL_INTERVAL , '==', 10, '... testing sql_type'); cmp_ok(SQL_TIME , '==', 10, '... testing sql_type'); cmp_ok(SQL_TIMESTAMP , '==', 11, '... testing sql_type'); cmp_ok(SQL_VARCHAR , '==', 12, '... testing sql_type'); cmp_ok(SQL_BOOLEAN , '==', 16, '... testing sql_type'); cmp_ok(SQL_UDT , '==', 17, '... testing sql_type'); cmp_ok(SQL_UDT_LOCATOR , '==', 18, '... testing sql_type'); cmp_ok(SQL_ROW , '==', 19, '... testing sql_type'); cmp_ok(SQL_REF , '==', 20, '... testing sql_type'); cmp_ok(SQL_BLOB , '==', 30, '... testing sql_type'); cmp_ok(SQL_BLOB_LOCATOR , '==', 31, '... testing sql_type'); cmp_ok(SQL_CLOB , '==', 40, '... testing sql_type'); cmp_ok(SQL_CLOB_LOCATOR , '==', 41, '... testing sql_type'); cmp_ok(SQL_ARRAY , '==', 50, '... testing sql_type'); cmp_ok(SQL_ARRAY_LOCATOR , '==', 51, '... testing sql_type'); cmp_ok(SQL_MULTISET , '==', 55, '... testing sql_type'); cmp_ok(SQL_MULTISET_LOCATOR , '==', 56, '... testing sql_type'); cmp_ok(SQL_TYPE_DATE , '==', 91, '... testing sql_type'); cmp_ok(SQL_TYPE_TIME , '==', 92, '... testing sql_type'); cmp_ok(SQL_TYPE_TIMESTAMP , '==', 93, '... testing sql_type'); cmp_ok(SQL_TYPE_TIME_WITH_TIMEZONE , '==', 94, '... testing sql_type'); cmp_ok(SQL_TYPE_TIMESTAMP_WITH_TIMEZONE , '==', 95, '... testing sql_type'); cmp_ok(SQL_INTERVAL_YEAR , '==', 101, '... testing sql_type'); cmp_ok(SQL_INTERVAL_MONTH , '==', 102, '... testing sql_type'); cmp_ok(SQL_INTERVAL_DAY , '==', 103, '... testing sql_type'); cmp_ok(SQL_INTERVAL_HOUR , '==', 104, '... testing sql_type'); cmp_ok(SQL_INTERVAL_MINUTE , '==', 105, '... testing sql_type'); cmp_ok(SQL_INTERVAL_SECOND , '==', 106, '... testing sql_type'); cmp_ok(SQL_INTERVAL_YEAR_TO_MONTH , '==', 107, '... testing sql_type'); cmp_ok(SQL_INTERVAL_DAY_TO_HOUR , '==', 108, '... testing sql_type'); cmp_ok(SQL_INTERVAL_DAY_TO_MINUTE , '==', 109, '... testing sql_type'); cmp_ok(SQL_INTERVAL_DAY_TO_SECOND , '==', 110, '... testing sql_type'); cmp_ok(SQL_INTERVAL_HOUR_TO_MINUTE , '==', 111, '... testing sql_type'); cmp_ok(SQL_INTERVAL_HOUR_TO_SECOND , '==', 112, '... testing sql_type'); cmp_ok(SQL_INTERVAL_MINUTE_TO_SECOND , '==', 113, '... testing sql_type'); ## ---------------------------------------------------------------------------- ## testing the :sql_cursor_types exports cmp_ok(SQL_CURSOR_FORWARD_ONLY, '==', 0, '... testing sql_cursor_types'); cmp_ok(SQL_CURSOR_KEYSET_DRIVEN, '==', 1, '... testing sql_cursor_types'); cmp_ok(SQL_CURSOR_DYNAMIC, '==', 2, '... testing sql_cursor_types'); cmp_ok(SQL_CURSOR_STATIC, '==', 3, '... testing sql_cursor_types'); cmp_ok(SQL_CURSOR_TYPE_DEFAULT, '==', 0, '... testing sql_cursor_types'); ## ---------------------------------------------------------------------------- ## test the :util exports ## testing looks_like_number my @is_num = looks_like_number(undef, "", "foo", 1, ".", 2, "2"); ok(!defined $is_num[0], '... looks_like_number : undef -> undef'); ok(!defined $is_num[1], '... looks_like_number : "" -> undef (eg "don\'t know")'); ok( defined $is_num[2], '... looks_like_number : "foo" -> defined false'); ok( !$is_num[2], '... looks_like_number : "foo" -> defined false'); ok( $is_num[3], '... looks_like_number : 1 -> true'); ok( !$is_num[4], '... looks_like_number : "." -> false'); ok( $is_num[5], '... looks_like_number : 1 -> true'); ok( $is_num[6], '... looks_like_number : 1 -> true'); ## testing neat cmp_ok($DBI::neat_maxlen, '==', 1000, "... $DBI::neat_maxlen initial state is 400"); is(neat(1 + 1), "2", '... neat : 1 + 1 -> "2"'); is(neat("2"), "'2'", '... neat : 2 -> "\'2\'"'); is(neat(undef), "undef", '... neat : undef -> "undef"'); ## testing neat_list is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "|"), "2|'2'|undef|'foo...'", '... test array argument w/separator and maxlen'); is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out separator or maxlen'); ## ---------------------------------------------------------------------------- ## testing DBI functions ## test DBI->internal my $switch = DBI->internal; isa_ok($switch, 'DBI::dr'); ## checking attributes of $switch # NOTE: # check too see if this covers all the attributes or not # TO DO: # these three can be improved $switch->debug(0); pass('... test debug'); $switch->{DebugDispatch} = 0; # handled by Switch pass('... test DebugDispatch'); $switch->{Warn} = 1; # handled by DBI core pass('... test Warn'); like($switch->{'Attribution'}, qr/DBI.*? by Tim Bunce/, '... this should say Tim Bunce'); # is this being presumptious? is($switch->{'Version'}, $DBI::VERSION, '... the version should match DBI version'); cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and return 1'); cmp_ok($switch->{private_test1}, '==', 1, '... this should equal 1'); is($switch->{CachedKids}, undef, '... CachedKids should be undef initially'); my $cache = {}; $switch->{CachedKids} = $cache; is($switch->{CachedKids}, $cache, '... CachedKids should be our ref'); cmp_ok($switch->{Kids}, '==', 0, '... this should be zero'); cmp_ok($switch->{ActiveKids}, '==', 0, '... this should be zero'); ok($switch->{Active}, '... Active flag is true'); # test attribute warnings { my $warn = ""; local $SIG{__WARN__} = sub { $warn .= "@_" }; $switch->{FooBarUnknown} = 1; like($warn, qr/Can't set.*FooBarUnknown/, '... we should get a warning here'); $warn = ""; $_ = $switch->{BarFooUnknown}; like($warn, qr/Can't get.*BarFooUnknown/, '... we should get a warning here'); $warn = ""; my $dummy = $switch->{$_} for qw(private_foo dbd_foo dbi_foo); # special cases cmp_ok($warn, 'eq', "", '... we should get no warnings here'); } # is this here for a reason? Are we testing anything? $switch->trace_msg("Test \$h->trace_msg text.\n", 1); DBI->trace_msg("Test DBI->trace_msg text.\n", 1); ## testing DBI->available_drivers my @drivers = DBI->available_drivers(); cmp_ok(scalar(@drivers), '>', 0, '... we at least have one driver installed'); # NOTE: # we lowercase the interpolated @drivers array # so that our reg-exp will match on VMS & Win32 like(lc("@drivers"), qr/examplep/, '... we should at least have ExampleP installed'); # call available_drivers in scalar context my $num_drivers = DBI->available_drivers; cmp_ok($num_drivers, '>', 0, '... we should at least have one driver'); ## testing DBI::hash cmp_ok(DBI::hash("foo1" ), '==', -1077531989, '... should be -1077531989'); cmp_ok(DBI::hash("foo1",0), '==', -1077531989, '... should be -1077531989'); cmp_ok(DBI::hash("foo2",0), '==', -1077531990, '... should be -1077531990'); SKIP: { skip("Math::BigInt < 1.56",2) if $DBI::PurePerl && !eval { require Math::BigInt; require_version Math::BigInt 1.56 }; skip("Math::BigInt $Math::BigInt::VERSION broken",2) if $DBI::PurePerl && $Math::BigInt::VERSION =~ /^1\.8[45]/; my $bigint_vers = $Math::BigInt::VERSION || ""; if (!$DBI::PurePerl) { cmp_ok(DBI::hash("foo1",1), '==', -1263462440); cmp_ok(DBI::hash("foo2",1), '==', -1263462437); } else { # for PurePerl we use Math::BigInt but that's often caused test failures that # aren't DBI's fault. So we just warn (via a skip) if it's not working right. skip("Seems like your Math::BigInt $Math::BigInt::VERSION has a bug",2) unless (DBI::hash("foo1X",1) == -1263462440) && (DBI::hash("foo2",1) == -1263462437); ok(1, "Math::BigInt $Math::BigInt::VERSION worked okay"); ok(1); } } is(data_string_desc(""), "UTF8 off, ASCII, 0 characters 0 bytes"); is(data_string_desc(42), "UTF8 off, ASCII, 2 characters 2 bytes"); is(data_string_desc("foo"), "UTF8 off, ASCII, 3 characters 3 bytes"); is(data_string_desc(undef), "UTF8 off, undef"); is(data_string_desc("bar\x{263a}"), "UTF8 on, non-ASCII, 4 characters 6 bytes"); is(data_string_desc("\xEA"), "UTF8 off, non-ASCII, 1 characters 1 bytes"); is(data_string_diff( "", ""), ""); is(data_string_diff( "",undef), "String b is undef, string a has 0 characters"); is(data_string_diff(undef,undef), ""); is(data_string_diff("aaa","aaa"), ""); is(data_string_diff("aaa","aba"), "Strings differ at index 1: a[1]=a, b[1]=b"); is(data_string_diff("aba","aaa"), "Strings differ at index 1: a[1]=b, b[1]=a"); is(data_string_diff("aa" ,"aaa"), "String a truncated after 2 characters"); is(data_string_diff("aaa","aa" ), "String b truncated after 2 characters"); is(data_diff( "", ""), ""); is(data_diff(undef,undef), ""); is(data_diff("aaa","aaa"), ""); is(data_diff( "",undef), join "","a: UTF8 off, ASCII, 0 characters 0 bytes\n", "b: UTF8 off, undef\n", "String b is undef, string a has 0 characters\n"); is(data_diff("aaa","aba"), join "","a: UTF8 off, ASCII, 3 characters 3 bytes\n", "b: UTF8 off, ASCII, 3 characters 3 bytes\n", "Strings differ at index 1: a[1]=a, b[1]=b\n"); is(data_diff(pack("C",0xEA), pack("U",0xEA)), join "", "a: UTF8 off, non-ASCII, 1 characters 1 bytes\n", "b: UTF8 on, non-ASCII, 1 characters 2 bytes\n", "Strings contain the same sequence of characters\n"); is(data_diff(pack("C",0xEA), pack("U",0xEA), 1), ""); # no logical difference ## ---------------------------------------------------------------------------- # restrict this test to just developers SKIP: { skip 'developer tests', 4 unless -d ".svn" || -d ".git"; if ($^O eq "MSWin32" && eval { require Win32API::File }) { Win32API::File::SetErrorMode(Win32API::File::SEM_FAILCRITICALERRORS()); } print "Test DBI->installed_versions (for @drivers)\n"; print "(If one of those drivers, or the configuration for it, is bad\n"; print "then these tests can kill or freeze the process here. That's not the DBI's fault.)\n"; $SIG{ALRM} = sub { die "Test aborted because a driver (one of: @drivers) hung while loading" ." (almost certainly NOT a DBI problem)"; }; alarm(20); ## ---------------------------------------------------------------------------- ## test installed_versions # scalar context my $installed_versions = DBI->installed_versions; is(ref($installed_versions), 'HASH', '... we got a hash of installed versions'); cmp_ok(scalar(keys(%{$installed_versions})), '>=', 1, '... make sure we have at least one'); # list context my @installed_drivers = DBI->installed_versions; cmp_ok(scalar(@installed_drivers), '>=', 1, '... make sure we got at least one'); like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBD::Sponge'); } ## testing dbi_debug cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug's initial state is 0"); SKIP: { my $null = File::Spec->devnull(); skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null); DBI->trace(15,$null); cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15"); DBI->trace(0, undef); cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug is 0"); } 1; DBI-1.652/t/40profile.t0000644000031300001440000004255715230133000013616 0ustar00merijnusers#!perl -w $|=1; # # test script for DBI::Profile # use strict; use Config; use DBI::Profile; use DBI qw(dbi_time); use Data::Dumper; use File::Spec; use Storable qw(dclone); use Test::More; BEGIN { plan skip_all => "profiling not supported for DBI::PurePerl" if $DBI::PurePerl; # clock instability on xen systems is a reasonably common cause of failure # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html # so we'll skip automated testing on those systems plan skip_all => "skipping profile tests on xen (due to clock instability)" if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 and $ENV{AUTOMATED_TESTING}; } $Data::Dumper::Indent = 1; $Data::Dumper::Terse = 1; # log file to store profile results my $LOG_FILE = "test_output_profile$$.log"; my $orig_dbi_debug = $DBI::dbi_debug; DBI->trace($DBI::dbi_debug, $LOG_FILE); END { return if $orig_dbi_debug; 1 while unlink $LOG_FILE; } print "Test enabling the profile\n"; # make sure profiling starts disabled my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); ok($dbh, 'connect'); ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE}, 'Profile and DBI_PROFILE not set'); # can turn it on after the fact using a path number $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); $dbh->{Profile} = "4"; is_deeply sanitize_tree($dbh->{Profile}), bless { 'Path' => [ '!MethodName' ], } => 'DBI::Profile'; # using a package name $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); $dbh->{Profile} = "/DBI::Profile"; is_deeply sanitize_tree($dbh->{Profile}), bless { 'Path' => [ ], } => 'DBI::Profile'; # using a combined path and name $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); $dbh->{Profile} = "20/DBI::Profile"; is_deeply sanitize_tree($dbh->{Profile}), bless { 'Path' => [ '!MethodName', '!Caller2' ], } => 'DBI::Profile'; my $t_file = __FILE__; $dbh->do("set foo=1"); my $line = __LINE__; my $expected_caller = "40profile.t line $line"; $expected_caller .= " via ${1}40profile.t line 4" if $0 =~ /(zv\w+_)/; print Dumper($dbh->{Profile}); is_deeply sanitize_tree($dbh->{Profile}), bless { 'Path' => [ '!MethodName', '!Caller2' ], 'Data' => { 'do' => { $expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ] } } } => 'DBI::Profile' or warn Dumper $dbh->{Profile}; # can turn it on at connect $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 }); is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ]; cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 1, 'on at connect, 1 key'); cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1, 'on at connect, 1 key'); # at least STORE ok(ref $dbh->{Profile}{Data}{""}{STORE}, 'STORE is ref'); print "dbi_profile\n"; # Try to avoid rounding problem on double precision systems # $got->[5] = '1150962858.01596498' # $expected->[5] = '1150962858.015965' # by treating as a string (because is_deeply stringifies) my $t1 = DBI::dbi_time() . ""; my $dummy_statement = "Hi mom"; my $dummy_methname = "my_method_name"; my $leaf = dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1); print Dumper($dbh->{Profile}); cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2, 'avoid rounding, 1 key'); cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1, 'avoid rounding, 1 dummy statement'); is(ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY', 'dummy method name is array'); ok $leaf, "should return ref to leaf node"; is ref $leaf, 'ARRAY', "should return ref to leaf node"; my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}; is $leaf, $mine, "should return ref to correct leaf node"; print "@$mine\n"; is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ]; my $t2 = DBI::dbi_time() . ""; dbi_profile($dbh, $dummy_statement, $dummy_methname, $t2, $t2 + 2); print "@$mine\n"; is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ]; print "Test collected profile data\n"; $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 }); # do a (hopefully) measurable amount of work my $sql = "select mode,size,name from ?"; my $sth = $dbh->prepare($sql); for my $loop (1..50) { # enough work for low-res timers or v.fast cpus $sth->execute("."); while ( my $hash = $sth->fetchrow_hashref ) {} } $dbh->do("set foo=1"); print Dumper($dbh->{Profile}); # check that the proper key was set in Data my $data = $dbh->{Profile}{Data}{$sql}; ok($data, 'profile data'); is(ref $data, 'ARRAY', 'ARRAY ref'); ok(@$data == 7, '7 elements'); ok((grep { defined($_) } @$data) == 7, 'all 7 defined'); ok((grep { DBI::looks_like_number($_) } @$data) == 7, 'all 7 numeric'); my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data; ok($count > 3, 'count is 3'); ok($total > $first, ' total > first'); ok($total > $longest, 'total > longest') or warn "total $total > longest $longest: failed\n"; ok($longest > 0, 'longest > 0') or warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable ok($longest > $shortest, 'longest > shortest'); ok($time1 >= $^T, 'time1 later than start time'); ok($time2 >= $^T, 'time2 later than start time'); ok($time1 <= $time2, 'time1 <= time2'); my $next = int(dbi_time()) + 1; ok($next > $time1, 'next > time1') or warn "next $next > first $time1: failed\n"; ok($next > $time2, 'next > time2') or warn "next $next > last $time2: failed\n"; if ($shortest < 0) { my $sys = "$Config{archname} $Config{osvers}"; # ie sparc-linux 2.4.20-2.3sparcsmp warn < -0.008; } my $tmp = sanitize_tree($dbh->{Profile}); $tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count is_deeply $tmp, (bless { 'Path' => [ '!Statement' ], 'Data' => { '' => [ 6, 0, 0, 0, 0, 0, 0 ], $sql => [ -1, 0, 0, 0, 0, 0, 0 ], 'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ], } } => 'DBI::Profile'), 'profile'; print "Test profile format\n"; my $output = $dbh->{Profile}->format(); print "Profile Output\n$output"; # check that output was produced in the expected format ok(length $output, 'non zero length'); ok($output =~ /^DBI::Profile:/, 'DBI::Profile'); ok($output =~ /\((\d+) calls\)/, 'some calls'); ok($1 >= $count, 'calls >= count'); # ----------------------------------------------------------------------------------- # try statement and method name and reference-to-scalar path my $by_reference = 'foo'; $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', { RaiseError => 1, Profile => { Path => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ] } }); $sql = "select name from ."; $sth = $dbh->prepare($sql); $sth->execute(); $sth->fetchrow_hashref; $by_reference = 'bar'; $sth->finish; undef $sth; # DESTROY $tmp = sanitize_tree($dbh->{Profile}); ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored'; $tmp->{Data}{usrnam}{""}{foo} = {}; # make test insentitive to number of local files #warn Dumper($tmp); is_deeply $tmp, bless { 'Path' => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ], 'Data' => { '' => { # because Profile was enabled by DBI just before Username was set '' => { 'foo' => { 'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ], } } }, 'usrnam' => { '' => { 'foo' => { }, }, 'select name from .' => { 'foo' => { 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ], 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ], }, 'bar' => { 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ], 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ], }, }, }, }, } => 'DBI::Profile'; $tmp = [ $dbh->{Profile}->as_node_path_list() ]; is @$tmp, 8, 'should have 8 nodes'; sanitize_profile_data_nodes($_->[0]) for @$tmp; #warn Dumper($dbh->{Profile}->{Data}); is_deeply $tmp, [ [ [ 3, 0, 0, 0, 0, 0, 0 ], '', '', 'foo', 'STORE' ], [ [ 2, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'STORE' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'connected' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'DESTROY' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'finish' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'execute' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'fetchrow_hashref' ], [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'prepare' ] ]; print "testing '!File', '!Caller' and their variants in Path\n"; $dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ]; $dbh->{Profile}->{Data} = undef; my $file = (File::Spec->splitpath(__FILE__))[2]; # '40profile.t' my ($line1, $line2); sub a_sub { $sth = $dbh->prepare("select name from ."); $line2 = __LINE__; } a_sub(); $line1 = __LINE__; $tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data}); #warn Dumper($tmp); is_deeply $tmp, { "$file" => { "$file via $file" => { "$file line $line2" => { "$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ] } } } }; print "testing '!Time' and variants in Path\n"; undef $sth; my $factor = 1_000_000; $dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ]; $dbh->{Profile}->{Data} = undef; # give up a timeslice in the hope that the following few lines # run in well under a second even of slow/overloaded systems $t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts $t2 = int($t1/$factor)*$factor; $sth = $dbh->prepare("select name from ."); $tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data}); # if actual "!Time" recorded is 'close enough' then we'll pass # the test - it's not worth failing just because a system is slow $t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 5); is_deeply $tmp, { $t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }} }, "!Time and !Time~$factor should work" or warn Dumper([$t1, $t2, $tmp]); print "testing &norm_std_n3 in Path\n"; $dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic is_deeply $dbh->{Profile}{Path}, [ \&DBI::ProfileSubs::norm_std_n3 ]; $dbh->{Profile}->{Data} = undef; $sql = qq{insert into foo20060726 (a,b) values (42,"foo")}; dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002); $tmp = $dbh->{Profile}{Data}; #warn Dumper($tmp); is_deeply $tmp, { 'insert into foo (a,b) values (,"")' => [ 1, '2', '2', '2', '2', '100000000', '100000000' ] }, '&norm_std_n3 should normalize statement'; # ----------------------------------------------------------------------------------- print "testing code ref in Path\n"; sub run_test1 { my ($profile) = @_; $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', { RaiseError => 1, Profile => $profile, }); $sql = "select name from ."; $sth = $dbh->prepare($sql); $sth->execute(); $sth->fetchrow_hashref; $sth->finish; undef $sth; # DESTROY my $data = sanitize_profile_data_nodes($dbh->{Profile}{Data}, 1); return ($data, $dbh) if wantarray; return $data; } $tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] }); is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 11, 0,0,0,0,0,0 ] } } }; $tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] }); is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 11, 0,0,0,0,0,0 ] } } }; $tmp = run_test1( { Path => [ 'foo', sub { \undef } ] }); is_deeply $tmp, { 'foo' => undef }, 'should be vetoed'; # check what code ref sees in $_ $tmp = run_test1( { Path => [ sub { $_ } ] }); is_deeply $tmp, { '' => [ 6, 0, 0, 0, 0, 0, 0 ], 'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ] }, '$_ should contain statement'; # check what code ref sees in @_ $tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if $method =~ /^[A-Z]+$/; return (ref $h, $method) } ] }); is_deeply $tmp, { 'DBI::db' => { 'connected' => [ 1, 0, 0, 0, 0, 0, 0 ], 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ], }, 'DBI::st' => { 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ], 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ], }, }, 'should have @_ as keys'; # check we can filter by method $tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/; return $_[1] } ] }); #warn Dumper($tmp); is_deeply $tmp, { 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], }, 'should be able to filter by method'; DBI->trace(0, "STDOUT"); # close current log to flush it ok(-s $LOG_FILE, 'output should go to log file'); # ----------------------------------------------------------------------------------- print "testing as_text\n"; # check %N$ indices $dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ] } }; my $as_text = $dbh->{Profile}->as_text({ path => [ 'top' ], separator => ':', format => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d ]', }); is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text'); # test sortsub $dbh->{Profile}->{Data} = { A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] }, B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] }, }; $as_text = $dbh->{Profile}->as_text({ separator => ':', format => '%1$s %10$d ', sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary } }); is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub'); # general test, including defaults ($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] }); $as_text = $dbh->{Profile}->as_text(); $as_text =~ s/\.00+/.0/g; #warn "[$as_text]"; is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > STORE > baz: 0.0s / 5 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > connected > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > execute > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > fetchrow_hashref > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > finish > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) foo > prepare > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) }, 'as_text general'; # ----------------------------------------------------------------------------------- print "dbi_profile_merge_nodes\n"; my $total_time = dbi_profile_merge_nodes( my $totals=[], [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ], [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ], ); $_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00", 'merged nodes'); is($total_time, 0.93, 'merged time'); $total_time = dbi_profile_merge_nodes( $totals=[], { foo => [ 10, 1.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ], bar => [ 17, 1.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ], } ); $_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00", 'merged time foo/bar'); is($total_time, 2.93, 'merged nodes foo/bar time'); subtest "CVE-2026-14380" => sub { plan tests => 3; { my $marker = sprintf('dbi-test-payload-%1.6f-%u-%u-%u', $], time, $$, 1); local $ENV{DBI_PROFILE} = payload_for($marker); my $dbh = eval { DBI->connect("dbi:Sponge:", "", "", { RaiseError => 0 }) }; ok !( -e "/tmp/$marker" ), "ENV DBI_PROFILE payload"; unlink "/tmp/$marker" if -e "/tmp/$marker"; } { my $marker = sprintf('dbi-test-payload-%1.6f-%u-%u-%u', $], time, $$, 2); my $dbh = DBI->connect("dbi:Sponge:", "", "", { RaiseError => 0 }); eval { $dbh->{Profile} = payload_for($marker); }; ok !( -e "/tmp/$marker" ), "Set Profile payload"; unlink "/tmp/$marker" if -e "/tmp/$marker"; } { my $marker = sprintf('dbi-test-payload-%1.6f-%u-%u-%u', $], time, $$, 3); my $payload = payload_for($marker); my $dsn = "dbi:Sponge(Profile=>$payload):"; my $dbh = eval { DBI->connect($dsn, "", "", { RaiseError => 0 }) }; ok !( -e "/tmp/$marker" ), "DSN payload"; unlink "/tmp/$marker" if -e "/tmp/$marker"; } }; done_testing; exit 0; sub payload_for { my ($marker) = @_; # Single-quoted q{...} so \x2f is literal backslash-x-2-f for split; # the inner qq(...) re-interprets \x2f = / at eval-time. return qq{2/system(qq(touch \\x2ftmp\\x2f$marker))}; } sub sanitize_tree { my $data = shift; my $skip_clone = shift; return $data unless ref $data; $data = dclone($data) unless $skip_clone; sanitize_profile_data_nodes($data->{Data}) if $data->{Data}; return $data; } sub sanitize_profile_data_nodes { my $node = shift; if (ref $node eq 'HASH') { sanitize_profile_data_nodes($_) for values %$node; } elsif (ref $node eq 'ARRAY') { if (@$node == 7 and DBI::looks_like_number($node->[0])) { # sanitize the profile data node to simplify tests $_ = 0 for @{$node}[1..@$node-1]; # not 0 } } return $node; } DBI-1.652/t/05concathash.t0000644000031300001440000001250715225122735014303 0ustar00merijnusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl CatHash.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use strict; use Benchmark qw(:all); use Scalar::Util qw(looks_like_number); no warnings 'uninitialized'; use Test::More tests => 41; BEGIN { use_ok('DBI') }; # null and undefs -- segfaults?; is (DBI::_concat_hash_sorted(undef, "=", ":", 0, undef), undef); is (DBI::_concat_hash_sorted({ }, "=", ":", 0, undef), ""); eval { DBI::_concat_hash_sorted([], "=", ":", 0, undef) }; like ($@ || "", qr/is not a hash reference/); is (DBI::_concat_hash_sorted({ }, undef, ":", 0, undef), ""); is (DBI::_concat_hash_sorted({ }, "=", undef, 0, undef), ""); is (DBI::_concat_hash_sorted({ }, "=", ":", undef, undef),""); # simple cases is (DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=", ", ", undef, undef), "1='a', 2='b'"); # nul byte in key sep and pair sep # (nul byte in hash not supported) is DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=\000=", ":\000:", undef, undef), "1=\000='a':\000:2=\000='b'", 'should work with nul bytes in kv_sep and pair_sep'; is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 1, undef), "1='a.a':2='b'", 'should work with nul bytes in hash value (neat)'; is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 0, undef), "1='a\000a':2='b'", 'should work with nul bytes in hash value (not neat)'; # Simple stress tests # limit stress when performing automated testing # eg http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4374116.html my $stress = $ENV{AUTOMATED_TESTING} ? 1_000 : 10_000; ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "="x$stress, ":", 1, undef)); ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "=", ":"x$stress, 1, undef)); ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "="x$stress, ":", 1, undef)); ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "=", ":"x$stress, 1, undef), 'test'); ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..100)}, "="x$stress, ":"x$stress, 1, undef), 'test'); my $simple_hash = { bob=>"there", jack=>12, fred=>"there", norman=>"there", # sam =>undef }; my $simple_numeric = { 1=>"there", 2=>"there", 16 => 'yo', 07 => "buddy", 49 => undef, }; my $simple_mixed = { bob=>"there", jack=>12, fred=>"there", sam =>undef, 1=>"there", 32=>"there", 16 => 'yo', 07 => "buddy", 49 => undef, }; my $simple_float = { 1.12 =>"there", 3.1415926 =>"there", 32=>"there", 1.6 => 'yo', 0.78 => "buddy", 49 => undef, }; #eval { # DBI::_concat_hash_sorted($simple_hash, "=",,":",1,12); #}; ok(1," Unknown sort order"); #like ($@, qr/Unknown sort order/, "Unknown sort order"); ## Loopify and Add Neat my %neats = ( "Neat"=>0, "Not Neat"=> 1 ); my %sort_types = ( guess=>undef, numeric => 1, lexical=> 0 ); my %hashes = ( Numeric=>$simple_numeric, "Simple Hash" => $simple_hash, "Mixed Hash" => $simple_mixed, "Float Hash" => $simple_float ); for my $sort_type (keys %sort_types){ for my $neat (keys %neats) { for my $hash (keys %hashes) { test_concat_hash($hash, $neat, $sort_type); } } } sub test_concat_hash { my ($hash, $neat, $sort_type) = @_; my @args = ($hashes{$hash}, "=", ":",$neats{$neat}, $sort_types{$sort_type}); is ( DBI::_concat_hash_sorted(@args), _concat_hash_sorted(@args), "$hash - $neat $sort_type" ); } if (0) { eval { cmpthese(200_000, { Perl => sub {_concat_hash_sorted($simple_hash, "=", ":",0,undef); }, C=> sub {DBI::_concat_hash_sorted($simple_hash, "=", ":",0,1);} }); print "\n"; cmpthese(200_000, { NotNeat => sub {DBI::_concat_hash_sorted( $simple_hash, "=", ":",1,undef); }, Neat => sub {DBI::_concat_hash_sorted( $simple_hash, "=", ":",0,undef); } }); }; } #CatHash::_concat_hash_values({ }, ":-",,"::",1,1); sub _concat_hash_sorted { my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; # $num_sort: 0=lexical, 1=numeric, undef=try to guess return undef unless defined $hash_ref; die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); my $string = ''; for my $key (@$keys) { $string .= $pair_separator if length $string > 0; my $value = $hash_ref->{$key}; if ($use_neat) { $value = DBI::neat($value, 0); } else { $value = (defined $value) ? "'$value'" : 'undef'; } $string .= $key . $kv_separator . $value; } return $string; } sub _get_sorted_hash_keys { my ($hash_ref, $sort_type) = @_; if (not defined $sort_type) { my $sort_guess = 1; $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess for keys %$hash_ref; $sort_type = $sort_guess; } my @keys = keys %$hash_ref; no warnings 'numeric'; my @sorted = ($sort_type) ? sort { $a <=> $b or $a cmp $b } @keys : sort @keys; #warn "$sort_type = @sorted\n"; return \@sorted; } 1; DBI-1.652/t/14utf8.t0000644000031300001440000000312715230132727013052 0ustar00merijnusers#!perl -w # vim:ts=8:sw=4 $|=1; use Test::More; use DBI; eval { require Storable; import Storable qw(dclone); require Encode; import Encode qw(_utf8_on _utf8_off is_utf8); }; plan skip_all => "Unable to load required module ($@)" unless defined &_utf8_on; my $dbh = DBI->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 1, }); my $source_rows = [ # data for DBD::Sponge to return via fetch [ 41, "AAA", 9 ], [ 42, "BB", undef ], [ 43, undef, 7 ], [ 44, "DDD", 6 ], ]; my($sth, $col0, $col1, $col2, $rows); # set utf8 on one of the columns so we can check it carries through into the # keys of fetchrow_hashref my @col_names = qw(Col1 Col2 Col3); _utf8_on($col_names[1]); ok is_utf8($col_names[1]); ok !is_utf8($col_names[0]); $sth = $dbh->prepare("foo", { rows => dclone($source_rows), NAME => \@col_names, }); ok($sth->bind_columns(\($col0, $col1, $col2)) ); ok($sth->execute(), $DBI::errstr); ok $sth->fetch; cmp_ok $col1, 'eq', "AAA"; ok !is_utf8($col1); # force utf8 flag on _utf8_on($col1); ok is_utf8($col1); ok $sth->fetch; cmp_ok $col1, 'eq', "BB"; # XXX sadly this test doesn't detect the problem when using DBD::Sponge # because DBD::Sponge uses $sth->_set_fbav (correctly) and that uses # sv_setsv which doesn't have the utf8 persistence that sv_setpv does. ok !is_utf8($col1); # utf8 flag should have been reset ok $sth->fetch; ok !defined $col1; # null ok !is_utf8($col1); # utf8 flag should have been reset ok my $hash = $sth->fetchrow_hashref; ok 1 == grep { is_utf8($_) } keys %$hash; $sth->finish; done_testing; # end DBI-1.652/t/15array.t0000644000031300001440000001714714742423677013330 0ustar00merijnusers#!perl -w $|=1; use strict; use Test::More tests => 55; ## ---------------------------------------------------------------------------- ## 15array.t ## ---------------------------------------------------------------------------- # ## ---------------------------------------------------------------------------- BEGIN { use_ok('DBI'); } # create a database handle my $dbh = DBI->connect("dbi:Sponge:dummy", '', '', { RaiseError => 1, ShowErrorStatement => 1, AutoCommit => 1 }); # check that our db handle is good isa_ok($dbh, "DBI::db"); my $rv; my $rows = []; my $tuple_status = []; my $dumped; my $sth = $dbh->prepare("insert", { rows => $rows, # where to 'insert' (push) the rows NUM_OF_PARAMS => 4, execute_hook => sub { # DBD::Sponge hook to make certain data trigger an error for that row local $^W; return $_[0]->set_err(1,"errmsg") if grep { $_ and $_ eq "B" } @_; return 1; } }); isa_ok($sth, "DBI::st"); cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); # ----------------------------------------------- ok(! eval { local $sth->{PrintError} = 0; $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [ 1, 2, 3 ], # array of integers 42, # scalar 42 treated as array of 42's undef, # scalar undef treated as array of undef's [ qw(A B C) ], # array of strings ) }, '... execute_array should return false' ); ok $@, 'execute_array failure with RaiseError should have died'; like $sth->errstr, '/executing 3 generated 1 errors/'; cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows'); cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); ok(eq_array( $rows, [ [1, 42, undef, 'A'], [3, 42, undef, 'C'] ] ), '... our rows are as expected'); ok(eq_array( $tuple_status, [1, [1, 'errmsg', 'S1000'], 1] ), '... our tuple_status is as expected'); # ----------------------------------------------- # --- change one param and re-execute @$rows = (); ok( $sth->bind_param_array(4, [ qw(a b c) ]), '... bind_param_array should return true'); ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }), '... execute_array should return true'); cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows'); cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); ok(eq_array( $rows, [ [1, 42, undef, 'a'], [2, 42, undef, 'b'], [3, 42, undef, 'c'] ] ), '... our rows are as expected'); ok(eq_array( $tuple_status, [1, 1, 1] ), '... our tuple_status is as expected'); # ----------------------------------------------- # --- call execute_array in array context to get executed AND affected @$rows = (); my ($executed, $affected) = $sth->execute_array({ ArrayTupleStatus => $tuple_status }); ok($executed, '... execute_array should return true'); cmp_ok($executed, '==', 3, '... we should have executed 3 rows'); cmp_ok($affected, '==', 3, '... we should have affected 3 rows'); # ----------------------------------------------- # --- with no values for bind params, should execute zero times @$rows = (); $rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [], [], [], []); ok($rv, '... execute_array should return true'); ok(!($rv+0), '... execute_array should return 0 (but true)'); cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status'); # ----------------------------------------------- # --- with only scalar values for bind params, should execute just once @$rows = (); $rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, 6, 7, 8); cmp_ok($rv, '==', 1, '... execute_array should return 1'); cmp_ok(scalar @{$rows}, '==', 1, '... we should have 1 rows'); ok(eq_array( $rows, [ [5,6,7,8] ]), '... our rows are as expected'); cmp_ok(scalar @{$tuple_status}, '==', 1,'... we should have 1 tuple_status'); ok(eq_array( $tuple_status, [1]), '... our tuple_status is as expected'); # ----------------------------------------------- # --- with mix of scalar values and arrays only arrays control tuples @$rows = (); $rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, [], 7, 8); cmp_ok($rv, '==', 0, '... execute_array should return 0'); cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status'); # ----------------------------------------------- # --- catch 'undefined value' bug with zero bind values @$rows = (); my $sth_other = $dbh->prepare("insert", { rows => $rows, # where to 'insert' (push) the rows NUM_OF_PARAMS => 1, }); isa_ok($sth_other, "DBI::st"); $rv = $sth_other->execute_array( {}, [] ); ok($rv, '... execute_array should return true'); ok(!($rv+0), '... execute_array should return 0 (but true)'); # no ArrayTupleStatus cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); # ----------------------------------------------- # --- ArrayTupleFetch code-ref tests --- my $index = 0; my $fetchrow = sub { # generate 5 rows of two integer values return if $index >= 2; $index +=1; # There doesn't seem any reliable way to force $index to be # treated as a string (and so dumped as such). We just have to # make the test case allow either 1 or '1'. return [ $index, 'a','b','c' ]; }; @$rows = (); ok( $sth->execute_array({ ArrayTupleFetch => $fetchrow, ArrayTupleStatus => $tuple_status }), '... execute_array should return true'); cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows'); cmp_ok(scalar @{$tuple_status}, '==', 2, '... we should have 2 tuple_status'); ok(eq_array( $rows, [ [1, 'a', 'b', 'c'], [2, 'a', 'b', 'c'] ] ), '... rows should match' ); ok(eq_array( $tuple_status, [1, 1] ), '... tuple_status should match' ); # ----------------------------------------------- # --- ArrayTupleFetch sth tests --- my $fetch_sth = $dbh->prepare("foo", { rows => [ map { [ $_,'x','y','z' ] } 7..9 ], NUM_OF_FIELDS => 4 }); isa_ok($fetch_sth, "DBI::st"); $fetch_sth->execute(); @$rows = (); ok( $sth->execute_array({ ArrayTupleFetch => $fetch_sth, ArrayTupleStatus => $tuple_status, }), '... execute_array should return true'); cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows'); cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); ok(eq_array( $rows, [ [7, 'x', 'y', 'z'], [8, 'x', 'y', 'z'], [9, 'x', 'y', 'z'] ] ), '... rows should match' ); ok(eq_array( $tuple_status, [1, 1, 1] ), '... tuple status should match' ); # ----------------------------------------------- # --- error detection tests --- $sth->{RaiseError} = 0; $sth->{PrintError} = 0; ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]), '... execute_array should return undef'); is($sth->errstr, '2 bind values supplied but 4 expected', '... errstr is as expected'); ok(!defined $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), '... execute_array should return undef'); is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref', '... errstr is as expected'); ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4), '... execute_array should return undef'); is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a HASH', '... errstr is as expected'); ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array should return undef'); is( $sth->errstr, "Can't use named placeholder ':foo' for non-driver supported bind_param_array", '... errstr is as expected'); $dbh->disconnect; 1; DBI-1.652/t/86gofer_fail.t0000644000031300001440000001334714742423677014315 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # vim:sw=4:ts=8 $|=1; use strict; use warnings; use DBI; use Data::Dumper; use Test::More; sub between_ok; # here we test the DBI_GOFER_RANDOM mechanism # and how gofer deals with failures plan skip_all => "requires Callbacks which are not supported with PurePerl" if $DBI::PurePerl; if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity plan skip_all => "Gofer DBI_AUTOPROXY" if $ap =~ /^dbi:Gofer/i; # this means we have DBD::Gofer => DBD::Gofer => DBD::whatever # rather than disable it we let it run because we're twisted # and because it helps find more bugs (though debugging can be painful) warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n" unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t } plan 'no_plan'; my $tmp; my $dbh; my $fails; # we'll use the null transport for simplicity and speed # and the rush policy to limit the number of interactions with the gofer executor # silence the "DBI_GOFER_RANDOM..." warnings my @warns; $SIG{__WARN__} = sub { ("@_" =~ /^DBI_GOFER_RANDOM/) ? push(@warns, @_) : warn @_; }; # --- 100% failure rate ($fails, $dbh) = trial_impact("fail=100%,do", 10, "", sub { $_->do("set foo=1") }); is $fails, 100, 'should fail 100% of the time'; ok $@, '$@ should be set'; like $@, '/fake error from do method induced by DBI_GOFER_RANDOM/'; ok $dbh->errstr, 'errstr should be set'; like $dbh->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain DBI_GOFER_RANDOM'; ok !$dbh->{go_response}->executed_flag_set, 'go_response executed flag should be false'; # XXX randomness can't be predicted, so it's just possible these will fail srand(42); # try to limit occasional failures (effect will vary by platform etc) sub trial_impact { my ($spec, $count, $dsn_attr, $code, $verbose) = @_; local $ENV{DBI_GOFER_RANDOM} = $spec; my $dbh = dbi_connect("policy=rush;$dsn_attr"); local $_ = $dbh; my $fail_percent = percentage_exceptions(200, $code, $verbose); return $fail_percent unless wantarray; return ($fail_percent, $dbh); } # --- 50% failure rate, with no retries $fails = trial_impact("fail=50%,do", 200, "retry_limit=0", sub { $_->do("set foo=1") }); print "target approx 50% random failures, got $fails%\n"; between_ok $fails, 10, 90, "should fail about 50% of the time, but at least between 10% and 90%"; # --- 50% failure rate, with many retries (should yield low failure rate) $fails = trial_impact("fail=50%,prepare", 200, "retry_limit=5", sub { $_->prepare("set foo=1") }); print "target less than 20% effective random failures (ideally 0), got $fails%\n"; cmp_ok $fails, '<', 20, 'should fail < 20%'; # --- 10% failure rate, with many retries (should yield zero failure rate) $fails = trial_impact("fail=10,do", 200, "retry_limit=10", sub { $_->do("set foo=1") }); cmp_ok $fails, '<', 1, 'should fail < 1%'; # --- 50% failure rate, test is_idempotent $ENV{DBI_GOFER_RANDOM} = "fail=50%,do"; # 50% # test go_retry_hook and that ReadOnly => 1 retries a non-idempotent statement ok my $dbh_50r1ro = dbi_connect("policy=rush;retry_limit=1", { go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 }, ReadOnly => 1, } ); between_ok percentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }), 10, 40, 'should fail ~25% (ie 50% with one retry)'; between_ok $dbh_50r1ro->{go_transport}->meta->{request_retry_count}, 20, 80, 'transport request_retry_count should be around 50'; # test as above but with ReadOnly => 0 ok my $dbh_50r1rw = dbi_connect("policy=rush;retry_limit=1", { go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 }, ReadOnly => 0, } ); between_ok percentage_exceptions(100, sub { $dbh_50r1rw->do("set foo=1") }), 20, 80, 'should fail ~50%, ie no retries'; ok !$dbh_50r1rw->{go_transport}->meta->{request_retry_count}, 'transport request_retry_count should be zero or undef'; # --- check random is random and non-random is non-random my %fail_percents; for (1..5) { $fails = trial_impact("fail=50%,do", 10, "", sub { $_->do("set foo=1") }); ++$fail_percents{$fails}; } cmp_ok scalar keys %fail_percents, '>=', 2, 'positive percentage should fail randomly'; %fail_percents = (); for (1..5) { $fails = trial_impact("fail=-50%,do", 10, "", sub { $_->do("set foo=1") }); ++$fail_percents{$fails}; } is scalar keys %fail_percents, 1, 'negative percentage should fail non-randomly'; # --- print "Testing random delay\n"; $ENV{DBI_GOFER_RANDOM} = "delay0.1=51%,do"; # odd percentage to force warn()s @warns = (); ok $dbh = dbi_connect("policy=rush;retry_limit=0"); is percentage_exceptions(20, sub { $dbh->do("set foo=1") }), 0, "should not fail for DBI_GOFER_RANDOM='$ENV{DBI_GOFER_RANDOM}'"; my $delays = grep { m/delaying execution/ } @warns; between_ok $delays, 1, 19, 'should be delayed around 5 times'; exit 0; # --- subs --- # sub between_ok { my ($got, $min, $max, $label) = @_; local $Test::Builder::Level = 2; cmp_ok $got, '>=', $min, "$label (got $got)"; cmp_ok $got, '<=', $max, "$label (got $got)"; } sub dbi_connect { my ($gdsn, $attr) = @_; return DBI->connect("dbi:Gofer:transport=null;$gdsn;dsn=dbi:ExampleP:", 0, 0, { RaiseError => 1, PrintError => 0, ($attr) ? %$attr : () }); } sub percentage_exceptions { my ($count, $sub, $verbose) = @_; my $i = $count; my $exceptions = 0; while ($i--) { eval { $sub->() }; warn sprintf("percentage_exceptions $i: %s\n", $@|| $DBI::errstr || '') if $verbose; if ($@) { die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM/; ++$exceptions; } } warn sprintf "percentage_exceptions %f/%f*100 = %f\n", $exceptions, $count, $exceptions/$count*100 if $verbose; return $exceptions/$count*100; } DBI-1.652/t/80proxy.t0000644000031300001440000003254014742423677013367 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # vim:sw=4:ts=8 use strict; use warnings; use DBI; use Config; require VMS::Filespec if $^O eq 'VMS'; require Cwd; my $haveFileSpec = eval { require File::Spec }; my $failed_tests = 0; $| = 1; $^W = 1; # $\ = "\n"; # XXX Triggers bug, check this later (JW, 1998-12-28) # Can we load the modules? If not, exit the test immediately: # Reason is most probable a missing prerequisite. # # Is syslog available (required for the server)? eval { local $SIG{__WARN__} = sub { $@ = shift }; require Storable; require DBD::Proxy; require DBI::ProxyServer; require RPC::PlServer; require Net::Daemon::Test; }; if ($@) { if ($@ =~ /^Can't locate (\S+)/) { print "1..0 # Skipped: modules required for proxy are probably not installed (e.g., $1)\n"; exit 0; } die $@; } if ($DBI::PurePerl) { # XXX temporary I hope print "1..0 # Skipped: DBD::Proxy currently has a problem under DBI::PurePerl\n"; exit 0; } { my $numTest = 0; sub _old_Test($;$) { my $result = shift; my $str = shift || ''; printf("%sok %d%s\n", ($result ? "" : "not "), ++$numTest, $str); $result; } sub Test ($;$) { my($ok, $msg) = @_; $msg = ($msg) ? " ($msg)" : ""; my $line = (caller)[2]; ++$numTest; ($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n"; warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok; ++$failed_tests unless $ok; return $ok; } } # Create an empty config file to make sure that settings aren't # overloaded by /etc/dbiproxy.conf my $config_file = "./dbiproxytst.conf"; unlink $config_file; (open(FILE, ">$config_file") and (print FILE "{}\n") and close(FILE)) or die "Failed to create config file $config_file: $!"; my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0; my $dbitracelog = "dbiproxy.dbilog"; my ($handle, $port, @child_args); my $numTests = 136; if (@ARGV) { $port = $ARGV[0]; } else { unlink $dbitracelog; unlink "dbiproxy.log"; unlink "dbiproxy.truss"; # Uncommentand adjust this to isolate pure-perl client from server settings: # local $ENV{DBI_PUREPERL} = 0; # If desperate uncomment this and add '-d' after $^X below: # local $ENV{PERLDB_OPTS} = "AutoTrace NonStop=1 LineInfo=dbiproxy.dbg"; # pass our @INC to children (e.g., so -Mblib passes through) $ENV{PERL5LIB} = join($Config{path_sep}, @INC); # server DBI trace level always at least 1 my $dbitracelevel = DBI->trace(0) || 1; @child_args = ( #'truss', '-o', 'dbiproxy.truss', $^X, 'dbiproxy', '--test', # --test must be first command line arg "--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg '--configfile', $config_file, ($dbitracelevel >= 2 ? ('--debug') : ()), '--mode=single', '--logfile=STDERR', '--timeout=90' ); warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0); ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args); } my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:"; print "Making a first connection and closing it immediately.\n"; Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) }) or print "Connect error: " . $DBI::errstr . "\n"; print "Making a second connection.\n"; my $dbh; Test($dbh = eval { DBI->connect($dsn, '', '', { 'PrintError' => 0 }) }) or print "Connect error: " . $DBI::errstr . "\n"; print "example_driver_path=$dbh->{example_driver_path}\n"; Test($dbh->{example_driver_path}); print "Setting AutoCommit\n"; $@ = "old-error"; # should be preserved across DBI calls Test($dbh->{AutoCommit} = 1); Test($dbh->{AutoCommit}); Test($@ eq "old-error", "\$@ now '$@'"); #$dbh->trace(2); eval { local $dbh->{ AutoCommit } = 1; # This breaks die! die "BANG!!!\n"; }; Test($@ eq "BANG!!!\n", "\$@ value lost"); print "begin_work...\n"; Test($dbh->{AutoCommit}); Test(!$dbh->{BegunWork}); Test($dbh->begin_work); Test(!$dbh->{AutoCommit}); Test($dbh->{BegunWork}); $dbh->commit; Test(!$dbh->{BegunWork}); Test($dbh->{AutoCommit}); Test($dbh->begin_work({})); $dbh->rollback; Test($dbh->{AutoCommit}); Test(!$dbh->{BegunWork}); print "Doing a ping.\n"; $_ = $dbh->ping; Test($_); Test($_ eq '2'); # ping was DBD::ExampleP's ping print "Ensure CompatMode enabled.\n"; Test($dbh->{CompatMode}); print "Trying local quote.\n"; $dbh->{'proxy_quote'} = 'local'; Test($dbh->quote("quote's") eq "'quote''s'"); Test($dbh->quote(undef) eq "NULL"); print "Trying remote quote.\n"; $dbh->{'proxy_quote'} = 'remote'; Test($dbh->quote("quote's") eq "'quote''s'"); Test($dbh->quote(undef) eq "NULL"); # XXX the $optional param is undocumented and may be removed soon Test($dbh->quote_identifier('foo') eq '"foo"', $dbh->quote_identifier('foo')); Test($dbh->quote_identifier('f"o') eq '"f""o"', $dbh->quote_identifier('f"o')); Test($dbh->quote_identifier('foo','bar') eq '"foo"."bar"'); Test($dbh->quote_identifier('foo',undef,'bar') eq '"foo"."bar"'); Test($dbh->quote_identifier(undef,undef,'bar') eq '"bar"'); print "Trying commit with invalid number of parameters.\n"; eval { $dbh->commit('dummy') }; Test($@ =~ m/^DBI commit: invalid number of arguments:/) unless $DBI::PurePerl && Test(1); print "Trying select with unknown field name.\n"; my $cursor_e = $dbh->prepare("select unknown_field_name from ?"); Test(defined $cursor_e); Test(!$cursor_e->execute('a')); Test($DBI::err); Test($DBI::err == $dbh->err); Test($DBI::errstr =~ m/unknown_field_name/, $DBI::errstr); Test($DBI::errstr eq $dbh->errstr); Test($dbh->errstr eq $dbh->func('errstr')); my $dir = Cwd::cwd(); # a dir always readable on all platforms $dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; print "Trying a real select.\n"; my $csr_a = $dbh->prepare("select mode,name from ?"); Test(ref $csr_a); Test($csr_a->execute($dir)) or print "Execute failed: ", $csr_a->errstr(), "\n"; print "Repeating the select with second handle.\n"; my $csr_b = $dbh->prepare("select mode,name from ?"); Test(ref $csr_b); Test($csr_b->execute($dir)); Test($csr_a != $csr_b); Test($csr_a->{NUM_OF_FIELDS} == 2); if ($DBI::PurePerl) { $csr_a->trace(2); use Data::Dumper; warn Dumper($csr_a->{Database}); } Test($csr_a->{Database}->{Driver}->{Name} eq 'Proxy', "Name=$csr_a->{Database}->{Driver}->{Name}"); $csr_a->trace(0), die if $DBI::PurePerl; my($col0, $col1); my(@row_a, @row_b); #$csr_a->trace(2); print "Trying bind_columns.\n"; Test($csr_a->bind_columns(undef, \($col0, $col1)) ); Test($csr_a->execute($dir)); @row_a = $csr_a->fetchrow_array; Test(@row_a); Test($row_a[0] eq $col0); Test($row_a[1] eq $col1); print "Trying bind_param.\n"; Test($csr_b->bind_param(1, $dir)); Test($csr_b->execute()); @row_b = @{ $csr_b->fetchrow_arrayref }; Test(@row_b); Test("@row_a" eq "@row_b"); @row_b = $csr_b->fetchrow_array; Test("@row_a" ne "@row_b") or printf("Expected something different from '%s', got '%s'\n", "@row_a", "@row_b"); print "Trying fetchrow_hashref.\n"; Test($csr_b->execute()); my $row_b = $csr_b->fetchrow_hashref; Test($row_b); print "row_a: @{[ @row_a ]}\n"; print "row_b: @{[ %$row_b ]}\n"; Test($row_b->{mode} == $row_a[0]); Test($row_b->{name} eq $row_a[1]); print "Trying fetchrow_hashref with FetchHashKeyName.\n"; do { #local $dbh->{TraceLevel} = 9; local $dbh->{FetchHashKeyName} = 'NAME_uc'; Test($dbh->{FetchHashKeyName} eq 'NAME_uc'); my $csr_c = $dbh->prepare("select mode,name from ?"); Test($csr_c->execute($dir), $DBI::errstr); $row_b = $csr_c->fetchrow_hashref; Test($row_b); print "row_b: @{[ %$row_b ]}\n"; Test($row_b->{MODE} eq $row_a[0]); }; print "Trying finish.\n"; Test($csr_a->finish); #Test($csr_b->finish); Test(1); print "Forcing destructor.\n"; $csr_a = undef; # force destruction of this cursor now Test(1); print "Trying fetchall_arrayref.\n"; Test($csr_b->execute()); my $r = $csr_b->fetchall_arrayref; Test($r); Test(@$r); Test($r->[0]->[0] == $row_a[0]); Test($r->[0]->[1] eq $row_a[1]); Test($csr_b->finish); print "Retrying unknown field name.\n"; my $csr_c; $csr_c = $dbh->prepare("select unknown_field_name1 from ?"); Test($csr_c); Test(!$csr_c->execute($dir)); Test($DBI::errstr =~ m/Unknown field names: unknown_field_name1/) or printf("Wrong error string: %s", $DBI::errstr); print "Trying RaiseError.\n"; $dbh->{RaiseError} = 1; Test($dbh->{RaiseError}); Test($csr_c = $dbh->prepare("select unknown_field_name2 from ?")); Test(!eval { $csr_c->execute(); 1 }); #print "$@\n"; Test($@ =~ m/Unknown field names: unknown_field_name2/); $dbh->{RaiseError} = 0; Test(!$dbh->{RaiseError}); print "Trying warnings.\n"; { my @warn; local($SIG{__WARN__}) = sub { push @warn, @_ }; $dbh->{PrintError} = 1; Test($dbh->{PrintError}); Test(($csr_c = $dbh->prepare("select unknown_field_name3 from ?"))); Test(!$csr_c->execute()); Test("@warn" =~ m/Unknown field names: unknown_field_name3/); $dbh->{PrintError} = 0; Test(!$dbh->{PrintError}); } $csr_c->finish(); print "Trying type_info_all.\n"; my $array = $dbh->type_info_all(); Test($array and ref($array) eq 'ARRAY') or printf("Expected ARRAY, got %s, error %s\n", DBI::neat($array), $dbh->errstr()); Test($array->[0] and ref($array->[0]) eq 'HASH'); my $ok = 1; for (my $i = 1; $i < @{$array}; $i++) { print "$array->[$i]\n"; $ok = 0 unless ($array->[$i] and ref($array->[$i]) eq 'ARRAY'); print "$ok\n"; } Test($ok); # Test the table_info method # First generate a list of all subdirectories $dir = $haveFileSpec ? File::Spec->curdir() : "."; Test(opendir(DIR, $dir)); my(%dirs, %unexpected, %missing); while (defined(my $file = readdir(DIR))) { $dirs{$file} = 1 if -d $file; } closedir(DIR); my $sth = $dbh->table_info(undef, undef, undef, undef); Test($sth) or warn "table_info failed: ", $dbh->errstr(), "\n"; %missing = %dirs; %unexpected = (); while (my $ref = $sth->fetchrow_hashref()) { print "table_info: Found table $ref->{'TABLE_NAME'}\n"; if (exists($missing{$ref->{'TABLE_NAME'}})) { delete $missing{$ref->{'TABLE_NAME'}}; } else { $unexpected{$ref->{'TABLE_NAME'}} = 1; } } Test(!$sth->errstr()) or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; Test(keys %unexpected == 0) or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; Test(keys %missing == 0) or print "Missing directories: ", join(",", keys %missing), "\n"; # Test the tables method %missing = %dirs; %unexpected = (); print "Expecting directories ", join(",", keys %dirs), "\n"; foreach my $table ($dbh->tables()) { print "tables: Found table $table\n"; if (exists($missing{$table})) { delete $missing{$table}; } else { $unexpected{$table} = 1; } } Test(!$sth->errstr()) or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; Test(keys %unexpected == 0) or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; Test(keys %missing == 0) or print "Missing directories: ", join(",", keys %missing), "\n"; # Test large recordsets for (my $i = 0; $i <= 300; $i += 100) { print "Testing the fake directories ($i).\n"; Test($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i")); Test($csr_a->execute(), $DBI::errstr); my $ary = $csr_a->fetchall_arrayref; Test(!$DBI::errstr, $DBI::errstr); Test(@$ary == $i, "expected $i got ".@$ary); if ($i) { my @n1 = map { $_->[0] } @$ary; my @n2 = reverse map { "file$_" } 1..$i; Test("@n1" eq "@n2"); } else { Test(1); } } # Test the RowCacheSize attribute Test($csr_a = $dbh->prepare("SELECT * FROM ?")); Test($dbh->{'RowCacheSize'} == 20); Test($csr_a->{'RowCacheSize'} == 20); Test($csr_a->execute('long_list_50')); Test($csr_a->fetchrow_arrayref()); Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 19); Test($csr_a->finish()); Test($dbh->{'RowCacheSize'} = 30); Test($dbh->{'RowCacheSize'} == 30); Test($csr_a->{'RowCacheSize'} == 30); Test($csr_a->execute('long_list_50')); Test($csr_a->fetchrow_arrayref()); Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 29) or print("Expected 29 records in cache, got " . @{$csr_a->{'proxy_data'}} . "\n"); Test($csr_a->finish()); Test($csr_a->{'RowCacheSize'} = 10); Test($dbh->{'RowCacheSize'} == 30); Test($csr_a->{'RowCacheSize'} == 10); Test($csr_a->execute('long_list_50')); Test($csr_a->fetchrow_arrayref()); Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 9) or print("Expected 9 records in cache, got " . @{$csr_a->{'proxy_data'}} . "\n"); Test($csr_a->finish()); $dbh->disconnect; # Test $dbh->func() # print "Testing \$dbh->func().\n"; # my %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables(); # $ok = 1; # foreach my $t ($dbh->func('lib', 'examplep_tables')) { # defined(delete $tables{$t}) or print "Unexpected table: $t\n"; # } # Test(%tables == 0); if ($failed_tests) { warn "Proxy: @child_args\n"; for my $class (qw(Net::Daemon RPC::PlServer Storable)) { (my $pm = $class) =~ s/::/\//g; $pm .= ".pm"; my $version = eval { $class->VERSION } || '?'; warn sprintf "Using %-13s %-6s %s\n", $class, $version, $INC{$pm}; } warn join(", ", map { "$_=$ENV{$_}" } grep { /^LC_|LANG/ } keys %ENV)."\n"; warn "More info can be found in $dbitracelog\n"; #system("cat $dbitracelog"); } END { local $?; $handle->Terminate() if $handle; undef $handle; unlink $config_file if $config_file; if (!$failed_tests) { unlink 'dbiproxy.log'; unlink $dbitracelog if $dbitracelog; } }; 1; DBI-1.652/t/72childhandles.t0000644000031300001440000000717415230133104014606 0ustar00merijnusers#!perl -w $|=1; use strict; # # test script for the ChildHandles attribute # use DBI; use Test::More; my $HAS_WEAKEN = eval { require Scalar::Util; # this will croak() if this Scalar::Util doesn't have a working weaken(). Scalar::Util::weaken( my $test = [] ); # same test as in DBI.pm 1; }; if (!$HAS_WEAKEN) { chomp $@; print "1..0 # Skipped: Scalar::Util::weaken not available ($@)\n"; exit 0; } my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; my $drh; { # make 10 connections my @dbh; for (1 .. 10) { my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); push @dbh, $dbh; } # get the driver handle $drh = $dbh[0]->{Driver}; ok $drh; # get the kids, should be the same list of connections my $db_handles = $drh->{ChildHandles}; is ref $db_handles, 'ARRAY'; is scalar @$db_handles, scalar @dbh; # make sure all the handles are there my $found = 0; foreach my $h (@dbh) { ++$found if grep { $h == $_ } @$db_handles; } is $found, scalar @dbh; } # now all the out-of-scope DB handles should be gone { my $handles = $drh->{ChildHandles}; my @db_handles = grep { defined } @$handles; is scalar @db_handles, 0, "All handles should be undef now"; } my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); my $empty = $dbh->{ChildHandles}; is_deeply $empty, [], "ChildHandles should be an array-ref if wekref is available"; # test child handles for statement handles { my @sth; my $sth_count = 20; for (1 .. $sth_count) { my $sth = $dbh->prepare('SELECT name FROM t'); push @sth, $sth; } my $handles = $dbh->{ChildHandles}; is scalar @$handles, scalar @sth; # test a recursive walk like the one in the docs my @lines; sub show_child_handles { my ($h, $level) = @_; $level ||= 0; push(@lines, sprintf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h); show_child_handles($_, $level + 1) for (grep { defined } @{$h->{ChildHandles}}); } my $drh = $dbh->{Driver}; show_child_handles($drh, 0); print @lines[0..4]; is scalar @lines, $sth_count + 2; like $lines[0], qr/^drh/; like $lines[1], qr/^dbh/; like $lines[2], qr/^sth/; } my $handles = $dbh->{ChildHandles}; my @live = grep { defined $_ } @$handles; is scalar @live, 0, "handles should be gone now"; # test visit_child_handles { my $info; my $visitor = sub { my ($h, $info) = @_; my $type = $h->{Type}; ++$info->{ $type }{ ($type eq 'st') ? $h->{Statement} : $h->{Name} }; return $info; }; DBI->visit_handles($visitor, $info = {}); is_deeply $info, { 'dr' => { 'ExampleP' => 1, ($using_dbd_gofer) ? (Gofer => 1) : () }, 'db' => { '' => 1 }, }; my $sth1 = $dbh->prepare('SELECT name FROM t'); my $sth2 = $dbh->prepare('SELECT name FROM t'); DBI->visit_handles($visitor, $info = {}); is_deeply $info, { 'dr' => { 'ExampleP' => 1, ($using_dbd_gofer) ? (Gofer => 1) : () }, 'db' => { '' => 1 }, 'st' => { 'SELECT name FROM t' => 2 } }; } # test that the childhandle array does not grow uncontrollably SKIP: { skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer; for (1 .. 1000) { my $sth = $dbh->prepare('SELECT name FROM t'); } my $handles = $dbh->{ChildHandles}; cmp_ok scalar @$handles, '<', 1000; my @live = grep { defined } @$handles; is scalar @live, 0; } done_testing; 1; DBI-1.652/t/11fetch.t0000644000031300001440000000563515230132673013260 0ustar00merijnusers#!perl -w # vim:ts=8:sw=4 $|=1; use strict; use Test::More; use DBI; use Storable qw(dclone); use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; my $dbh = DBI->connect("dbi:Sponge:foo","","", { PrintError => 0, RaiseError => 1, }); my $source_rows = [ # data for DBD::Sponge to return via fetch [ 41, "AAA", 9 ], [ 41, "BBB", 9 ], [ 42, "BBB", undef ], [ 43, "ccc", 7 ], [ 44, "DDD", 6 ], ]; sub go { my $source = shift || $source_rows; my $sth = $dbh->prepare("foo", { rows => dclone($source), NAME => [ qw(C1 C2 C3) ], }); ok($sth->execute(), $DBI::errstr); return $sth; } my($sth, $col0, $col1, $col2, $rows); # --- fetchrow_arrayref # --- fetchrow_array # etc etc # --- fetchall_hashref my @fetchall_hashref_results = ( # single keys C1 => { 41 => { C1 => 41, C2 => 'BBB', C3 => 9 }, 42 => { C1 => 42, C2 => 'BBB', C3 => undef }, 43 => { C1 => 43, C2 => 'ccc', C3 => 7 }, 44 => { C1 => 44, C2 => 'DDD', C3 => 6 } }, C2 => { AAA => { C1 => 41, C2 => 'AAA', C3 => 9 }, BBB => { C1 => 42, C2 => 'BBB', C3 => undef }, DDD => { C1 => 44, C2 => 'DDD', C3 => 6 }, ccc => { C1 => 43, C2 => 'ccc', C3 => 7 } }, [ 'C2' ] => { # single key within arrayref AAA => { C1 => 41, C2 => 'AAA', C3 => 9 }, BBB => { C1 => 42, C2 => 'BBB', C3 => undef }, DDD => { C1 => 44, C2 => 'DDD', C3 => 6 }, ccc => { C1 => 43, C2 => 'ccc', C3 => 7 } }, ); push @fetchall_hashref_results, ( # multiple keys [ 'C1', 'C2' ] => { '41' => { AAA => { C1 => '41', C2 => 'AAA', C3 => 9 }, BBB => { C1 => '41', C2 => 'BBB', C3 => 9 } }, '42' => { BBB => { C1 => '42', C2 => 'BBB', C3 => undef } }, '43' => { ccc => { C1 => '43', C2 => 'ccc', C3 => 7 } }, '44' => { DDD => { C1 => '44', C2 => 'DDD', C3 => 6 } } }, ); my %dump; while (my $keyfield = shift @fetchall_hashref_results) { my $expected = shift @fetchall_hashref_results; my $k = (ref $keyfield) ? "[@$keyfield]" : $keyfield; print "# fetchall_hashref($k)\n"; ok($sth = go()); my $result = $sth->fetchall_hashref($keyfield); ok($result); is_deeply($result, $expected); # $dump{$k} = dclone $result; # just for adding tests } warn Dumper \%dump if %dump; # test assignment to NUM_OF_FIELDS automatically alters the row buffer $sth = go(); my $row = $sth->fetchrow_arrayref; is scalar @$row, 3; is $sth->{NUM_OF_FIELDS}, 3; is scalar @{ $sth->_get_fbav }, 3; $sth->{NUM_OF_FIELDS} = 4; is $sth->{NUM_OF_FIELDS}, 4; is scalar @{ $sth->_get_fbav }, 4; $sth->{NUM_OF_FIELDS} = 2; is $sth->{NUM_OF_FIELDS}, 2; is scalar @{ $sth->_get_fbav }, 2; $sth->finish; if (0) { my @perf = map { [ int($_/100), $_, $_ ] } 0..10000; require Benchmark; Benchmark::timethis(10, sub { go(\@perf)->fetchall_hashref([ 'C1','C2','C3' ]) }); } done_testing; 1; # end DBI-1.652/t/87gofer_cache.t0000644000031300001440000000600514656646601014435 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # vim:sw=4:ts=8 $|=1; use strict; use warnings; use DBI; use Data::Dumper; use Test::More; use DBI::Util::CacheMemory; plan skip_all => "Gofer DBI_AUTOPROXY" if (($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer/i); plan 'no_plan'; my $dsn = "dbi:Gofer:transport=null;policy=classic;dsn=dbi:ExampleP:"; my @cache_classes = qw(DBI::Util::CacheMemory); push @cache_classes, "Cache::Memory" if eval { require Cache::Memory }; push @cache_classes, "1"; # test alias for DBI::Util::CacheMemory for my $cache_class (@cache_classes) { my $cache_obj = ($cache_class eq "1") ? $cache_class : $cache_class->new(); run_tests($cache_obj); } sub run_tests { my $cache_obj = shift; my $tmp; print "\n --- using $cache_obj for $dsn\n"; my $dbh = DBI->connect($dsn, undef, undef, { go_cache => $cache_obj, RaiseError => 1, PrintError => 0, ShowErrorStatement => 1, } ); ok my $go_transport = $dbh->{go_transport}; ok my $go_cache = $go_transport->go_cache; # setup $go_cache->clear; is $go_cache->count, 0, 'cache should be empty after clear'; $go_transport->transmit_count(0); is $go_transport->transmit_count, 0, 'transmit_count should be 0'; $go_transport->cache_hit(0); $go_transport->cache_miss(0); $go_transport->cache_store(0); # request 1 ok my $rows1 = $dbh->selectall_arrayref("select name from ?", {}, "."); cmp_ok $go_cache->count, '>', 0, 'cache should not be empty after select'; my $expected = ($ENV{DBI_AUTOPROXY}) ? 2 : 1; is $go_transport->cache_hit, 0; is $go_transport->cache_miss, $expected; is $go_transport->cache_store, $expected; is $go_transport->transmit_count, $expected, "should make $expected round trip"; $go_transport->transmit_count(0); is $go_transport->transmit_count, 0, 'transmit_count should be 0'; # request 2 ok my $rows2 = $dbh->selectall_arrayref("select name from ?", {}, "."); is_deeply $rows2, $rows1; is $go_transport->transmit_count, 0, 'should make 0 round trip'; is $go_transport->cache_hit, $expected, 'cache_hit'; is $go_transport->cache_miss, $expected, 'cache_miss'; is $go_transport->cache_store, $expected, 'cache_store'; } print "test per-sth go_cache\n"; my $dbh = DBI->connect($dsn, undef, undef, { go_cache => 1, RaiseError => 1, PrintError => 0, ShowErrorStatement => 1, } ); ok my $go_transport = $dbh->{go_transport}; ok my $dbh_cache = $go_transport->go_cache; $dbh_cache->clear; # discard ping from connect my $cache2 = DBI::Util::CacheMemory->new( namespace => "foo2" ); ok $cache2; ok $cache2 != $dbh_cache; my $sth1 = $dbh->prepare("select name from ?"); is $sth1->go_cache, $dbh_cache; is $dbh_cache->size, 0; ok $dbh->selectall_arrayref($sth1, undef, "."); ok $dbh_cache->size; my $sth2 = $dbh->prepare("select * from ?", { go_cache => $cache2 }); is $sth2->go_cache, $cache2; is $cache2->size, 0; ok $dbh->selectall_arrayref($sth2, undef, "."); ok $cache2->size; cmp_ok $cache2->size, '>', $dbh_cache->size; 1; DBI-1.652/t/50dbm_simple.t0000755000031300001440000002445515240024143014302 0ustar00merijnusers#!perl -w $|=1; use strict; use warnings; require DBD::DBM; use File::Path; use File::Spec; use Test::More; use Cwd; use Config qw(%Config); use Storable qw(dclone); my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; use DBI; my ( @mldbm_types, @dbm_types ); BEGIN { # 0=SQL::Statement if avail, 1=DBI::SQL::Nano # next line forces use of Nano rather than default behaviour # $ENV{DBI_SQL_NANO}=1; # This is done in zv*n*_50dbm_simple.t push @mldbm_types, ''; if (eval { require 'MLDBM.pm'; }) { push @mldbm_types, qw(Data::Dumper Storable); # both in CORE push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' }; push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; }; push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; } # Potential DBM modules in preference order (SDBM_File first) # skip NDBM and ODBM as they don't support EXISTS my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File); my @use_dbms = @ARGV; if( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) { @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS}; } if (lc "@use_dbms" eq "all") { # test with as many of the major DBM types as are available @dbm_types = grep { eval { no warnings; require "$_.pm" } } @dbms; } elsif (@use_dbms) { @dbm_types = @use_dbms; } else { # we only test SDBM_File by default to avoid tripping up # on any broken DBM's that may be installed in odd places. # It's only DBD::DBM we're trying to test here. # (However, if SDBM_File is not available, then use another.) for my $dbm (@dbms) { if (eval { no warnings; require "$dbm.pm" }) { @dbm_types = ($dbm); last; } } } if( eval { require List::MoreUtils; } ) { List::MoreUtils->import("part"); } else { # XXX from PP part of List::MoreUtils eval <<'EOP'; sub part(&@) { my ($code, @list) = @_; my @parts; push @{ $parts[$code->($_)] }, $_ for @list; return @parts; } EOP } } my $dbi_sql_nano = not DBD::DBM::Statement->isa('SQL::Statement'); do "./t/lib.pl"; my $dir = test_dir (); my %tests_statement_results = ( 2 => [ "DROP TABLE IF EXISTS fruit", -1, "CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))", '0E0', "INSERT INTO fruit VALUES (1,'oranges' )", 1, "INSERT INTO fruit VALUES (2,'to_change' )", 1, "INSERT INTO fruit VALUES (3, NULL )", 1, "INSERT INTO fruit VALUES (4,'to delete' )", 1, "INSERT INTO fruit VALUES (?,?); #5,via placeholders", 1, "INSERT INTO fruit VALUES (6,'to delete' )", 1, "INSERT INTO fruit VALUES (7,'to_delete' )", 1, "DELETE FROM fruit WHERE dVal='to delete'", 2, "UPDATE fruit SET dVal='apples' WHERE dKey=2", 1, "DELETE FROM fruit WHERE dKey=7", 1, "SELECT * FROM fruit ORDER BY dKey DESC", [ [ 5, 'via placeholders' ], [ 3, '' ], [ 2, 'apples' ], [ 1, 'oranges' ], ], "SELECT * FROM fruit WHERE dVal >= 'oranges' ORDER BY dKey", [ [ 1, 'oranges' ], [ 5, 'via placeholders' ], ], "SELECT * FROM fruit WHERE dVal <= 'oranges' ORDER BY dVal", [ [ 3, '' ], [ 2, 'apples' ], [ 1, 'oranges' ], ], "SELECT * FROM fruit WHERE dVal IS NULL", [ [ 3, '' ], ], "DELETE FROM fruit", 4, $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM fruit", [ [ 0 ] ] ), "DROP TABLE fruit", -1, ], 3 => [ "DROP TABLE IF EXISTS multi_fruit", -1, "CREATE TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT)", '0E0', "INSERT INTO multi_fruit VALUES (1,'oranges' , 11 )", 1, "INSERT INTO multi_fruit VALUES (2,'to_change', 0 )", 1, "INSERT INTO multi_fruit VALUES (3, NULL , 13 )", 1, "INSERT INTO multi_fruit VALUES (4,'to_delete', 14 )", 1, "INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15", 1, "INSERT INTO multi_fruit VALUES (6,'to_delete', 16 )", 1, "INSERT INTO multi_fruit VALUES (7,'to delete', 17 )", 1, "INSERT INTO multi_fruit VALUES (8,'to remove', 18 )", 1, "UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2", 1, "DELETE FROM multi_fruit WHERE dVal='to_delete'", 2, "DELETE FROM multi_fruit WHERE qux=17", 1, "DELETE FROM multi_fruit WHERE dKey=8", 1, "SELECT * FROM multi_fruit ORDER BY dKey DESC", [ [ 5, 'via placeholders', 15 ], [ 3, undef, 13 ], [ 2, 'apples', 12 ], [ 1, 'oranges', 11 ], ], "DELETE FROM multi_fruit", 4, $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM multi_fruit", [ [ 0 ] ] ), "DROP TABLE multi_fruit", -1, ], ); print "Using DBM modules: @dbm_types\n"; print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types; my %test_statements; my %expected_results; for my $columns ( 2 .. 3 ) { my $i = 0; my @tests = part { $i++ % 2 } @{ $tests_statement_results{$columns} }; @{ $test_statements{$columns} } = @{$tests[0]}; @{ $expected_results{$columns} } = @{$tests[1]}; } unless (@dbm_types) { plan skip_all => "No DBM modules available"; } for my $mldbm ( @mldbm_types ) { my $columns = ($mldbm) ? 3 : 2; for my $dbm_type ( @dbm_types ) { print "\n--- Using $dbm_type ($mldbm) ---\n"; eval { do_test( $dbm_type, $mldbm, $columns) } or warn $@; } } done_testing(); sub do_test { my ($dtype, $mldbm, $columns) = @_; #diag ("Starting test: " . $starting_test_no); # The DBI can't test locking here, sadly, because of the risk it'll hang # on systems with broken NFS locking daemons. # (This test script doesn't test that locking actually works anyway.) # use f_lockfile in next release - use it here as test case only my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;f_lockfile=.lck"; if ($using_dbd_gofer) { $dsn .= ";f_dir=$dir"; } my $dbh = DBI->connect( $dsn ); my $dbm_versions; if ($DBI::VERSION >= 1.37 # needed for install_method && !$ENV{DBI_AUTOPROXY} # can't transparently proxy driver-private methods ) { $dbm_versions = $dbh->dbm_versions; } else { $dbm_versions = $dbh->func('dbm_versions'); } note $dbm_versions; ok($dbm_versions, 'dbm_versions'); isa_ok($dbh, 'DBI::db'); # test if it correctly accepts valid $dbh attributes SKIP: { skip "Can't set attributes after connect using DBD::Gofer", 2 if $using_dbd_gofer; eval {$dbh->{f_dir}=$dir}; ok(!$@); eval {$dbh->{dbm_mldbm}=$mldbm}; ok(!$@); } # test if it correctly rejects invalid $dbh attributes # eval { local $SIG{__WARN__} = sub { } if $using_dbd_gofer; local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; $dbh->{dbm_bad_name}=1; }; ok($@); my @queries = @{$test_statements{$columns}}; my @results = @{$expected_results{$columns}}; SKIP: for my $idx ( 0 .. $#queries ) { my $sql = $queries[$idx]; $sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name $sql =~ s/;$//; #diag($sql); # XXX FIX INSERT with NULL VALUE WHEN COLUMN NOT NULLABLE $dtype eq 'BerkeleyDB' and !$mldbm and 0 == index($sql, 'INSERT') and $sql =~ s/NULL/''/; $sql =~ s/\s*;\s*(?:#(.*))//; my $comment = $1; my $sth = $dbh->prepare($sql); ok($sth, "prepare $sql") or diag($dbh->errstr || 'unknown error'); my @bind; if($sth->{NUM_OF_PARAMS}) { @bind = split /,/, $comment; } # if execute errors we will handle it, not PrintError: $sth->{PrintError} = 0; my $n = $sth->execute(@bind); ok($n, 'execute') or diag($sth->errstr || 'unknown error'); next if (!defined($n)); is( $n, $results[$idx], $sql ) unless( 'ARRAY' eq ref $results[$idx] ); TODO: { local $TODO = "AUTOPROXY drivers might throw away sth->rows()" if($ENV{DBI_AUTOPROXY}); is( $n, $sth->rows, '$sth->execute(' . $sql . ') == $sth->rows' ) if( $sql =~ m/^(?:UPDATE|DELETE)/ ); } next unless $sql =~ /SELECT/; my $results=''; my $allrows = $sth->fetchall_arrayref(); my $expected_rows = $results[$idx]; is( $sth->rows, scalar( @{$expected_rows} ), $sql ); is_deeply( $allrows, $expected_rows, 'SELECT results' ); } my $sth = $dbh->table_info(); ok ($sth, "prepare table_info (without tables)"); my @tables = $sth->fetchall_arrayref; is_deeply( \@tables, [ [] ], "No tables delivered by table_info" ); # TODO these tests should be run using the database connection parameters do_update_test( $dbh, $dtype ) unless $using_dbd_gofer; $dbh->disconnect; return 1; } sub do_update_test { my ( $dbh, $dtype ) = @_; for my $mode ( 0 .. 2 ) { note "dbm_updatable_key = $mode"; $dbh->{dbm_updatable_key} = $mode; my $tests = [ "DROP TABLE IF EXISTS brassica", -1, "CREATE TABLE brassica (dKey INT, dVal VARCHAR(10))", '0E0', "INSERT INTO brassica VALUES (1,'neep')", 1, "INSERT INTO brassica VALUES (2,'kale')", 1, "UPDATE brassica SET dKey=1 WHERE dKey=2", \$mode, # depends on mode "DROP TABLE brassica", -1, ]; my $i = 0; my ( $queries, $expected ) = part { $i++ % 2 } @{$tests}; my $idx = 0; for my $sql ( @{$queries} ) { $sql =~ s/\S*brassica/${dtype}_brassica/; # include dbm type in table name my $sth = $dbh->prepare($sql); ok( $sth, "prepare $sql" ) or diag( $dbh->errstr || 'unknown error' ); my $expect = $expected->[$idx]; if ( ref($expect) ) { $sth->{PrintError} = 0; my $n = $sth->execute(); if ( $mode == 2 ) { ok( !$n, 'execute failed' ); like $sth->errstr, qr/^Row with PK '1' already exists/, 'execpted error'; } else { # TODO: trap warnings to test when $mode == 1 is( $n, 1, 'execute' ) or diag( $sth->errstr || 'unknown error' ); } } else { my $n = $sth->execute(); is( $n, $expect, 'execute' ) or diag( $sth->errstr || 'unknown error' ); } $idx++; } } } 1; DBI-1.652/t/16destroy.t0000644000031300001440000001003314742423677013667 0ustar00merijnusers#!perl -w use strict; use Test::More tests => 20; # use explicit plan to avoid race hazard BEGIN{ use_ok( 'DBI' ) } my $expect_active; ## main Test Driver Package { package DBD::Test; use strict; use warnings; my $drh = undef; sub driver { return $drh if $drh; my ($class, $attr) = @_; $class = "${class}::dr"; ($drh) = DBI::_new_drh($class, { Name => 'Test', Version => '1.0', }, 77 ); return $drh; } sub CLONE { undef $drh } } ## Test Driver { package DBD::Test::dr; use warnings; use Test::More; sub connect { # normally overridden, but a handy default my($drh, $dbname, $user, $auth, $attrs)= @_; my ($outer, $dbh) = DBI::_new_dbh($drh); $dbh->STORE(Active => 1); $dbh->STORE(AutoCommit => 1); $dbh->STORE( $_ => $attrs->{$_}) for keys %$attrs; return $outer; } $DBD::Test::dr::imp_data_size = 0; cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo'); } ## Test db package { package DBD::Test::db; use strict; use warnings; use Test::More; $DBD::Test::db::imp_data_size = 0; cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo'); sub STORE { my ($dbh, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle if ($attrib eq 'AutoCommit') { # convert AutoCommit values to magic ones to let DBI # know that the driver has 'handled' the AutoCommit attribute $value = ($value) ? -901 : -900; } return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; return $dbh->SUPER::STORE($attrib, $value); } sub DESTROY { if ($expect_active < 0) { # inside child my $self = shift; exit ($self->FETCH('Active') || 0) unless $^O eq 'MSWin32'; # On Win32, the forked child is actually a thread. So don't exit, # and report failure directly. fail 'Child should be inactive on DESTROY' if $self->FETCH('Active'); } else { return $expect_active ? ok( shift->FETCH('Active'), 'Should be active in DESTROY') : ok( !shift->FETCH('Active'), 'Should not be active in DESTROY'); } } } my $dsn = 'dbi:ExampleP:dummy'; $INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver() ok my $drh = DBI->install_driver('Test'), 'Install test driver'; NOSETTING: { # Try defaults. ok my $dbh = $drh->connect, 'Connect to test driver'; ok $dbh->{Active}, 'Should start active'; $expect_active = 1; } IAD: { # Try InactiveDestroy. ok my $dbh = $drh->connect($dsn, '', '', { InactiveDestroy => 1 }), 'Create with ActiveDestroy'; ok $dbh->{InactiveDestroy}, 'InactiveDestroy should be set'; ok $dbh->{Active}, 'Should start active'; $expect_active = 0; } AIAD: { # Try AutoInactiveDestroy. ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }), 'Create with AutoInactiveDestroy'; ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set'; ok $dbh->{Active}, 'Should start active'; $expect_active = 1; } FORK: { # Try AutoInactiveDestroy and fork. ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }), 'Create with AutoInactiveDestroy again'; ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set'; ok $dbh->{Active}, 'Should start active'; my $pid = eval { fork() }; if (not defined $pid) { chomp $@; my $msg = "AutoInactiveDestroy destroy test skipped"; diag "$msg because $@\n"; pass $msg; # in lieu of the child status test } elsif ($pid) { # parent. $expect_active = 1; wait; ok $? == 0, 'Child should be inactive on DESTROY'; } else { # child. $expect_active = -1; } } DBI-1.652/t/42prof_data.t0000644000031300001440000001036715230133036014122 0ustar00merijnusers#!perl -w $|=1; use strict; use DBI; use Config; use Test::More; use Data::Dumper; BEGIN { plan skip_all => 'profiling not supported for DBI::PurePerl' if $DBI::PurePerl; # clock instability on xen systems is a reasonably common cause of failure # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html # so we'll skip automated testing on those systems plan skip_all => "skipping profile tests on xen (due to clock instability)" if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 and $ENV{AUTOMATED_TESTING}; } BEGIN { use_ok( 'DBI::ProfileDumper' ); use_ok( 'DBI::ProfileData' ); } my $sql = "select mode,size,name from ?"; my $prof_file = "dbi$$.prof"; my $prof_backup = $prof_file . ".prev"; END { 1 while unlink $prof_file; 1 while unlink $prof_backup; } my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); isa_ok( $dbh, 'DBI::db', 'Created connection' ); require DBI::Profile; DBI::Profile->import(qw(dbi_time)); # do enough work to avoid 0's on systems that are very fast or have low res timers my $t1 = dbi_time(); foreach (1..20) { $dbh->do("set dummy=$_"); my $sth = $dbh->prepare($sql); for my $loop (1..90) { $sth->execute("."); $sth->fetchrow_hashref; $sth->finish; } $sth->{Profile}->flush_to_disk(); } $dbh->disconnect; undef $dbh; my $t2 = dbi_time(); note sprintf "DBI work done in %fs (%f - %f)", $t2-$t1, $t2, $t1; # wrote the profile to disk? ok(-s $prof_file, "Profile written to disk, non-zero size" ); # load up my $prof = DBI::ProfileData->new( File => $prof_file, Filter => sub { my ($path_ref, $data_ref) = @_; $path_ref->[0] =~ s/set dummy=\d/set dummy=N/; }, ); isa_ok( $prof, 'DBI::ProfileData' ); cmp_ok( $prof->count, '>=', 3, 'At least 3 profile data items' ); # try a few sorts my $nodes = $prof->nodes; $prof->sort(field => "longest"); my $longest = $nodes->[0][4]; ok($longest); $prof->sort(field => "longest", reverse => 1); cmp_ok( $nodes->[0][4], '<', $longest ); $prof->sort(field => "count"); my $most = $nodes->[0]; ok($most); $prof->sort(field => "count", reverse => 1); cmp_ok( $nodes->[0][0], '<', $most->[0] ); # remove the top count and make sure it's gone my $clone = $prof->clone(); isa_ok( $clone, 'DBI::ProfileData' ); $clone->sort(field => "count"); ok($clone->exclude(key1 => $most->[7])); # compare keys of the new first element and the old one to make sure # exclude works ok($clone->nodes()->[0][7] ne $most->[7] && $clone->nodes()->[0][8] ne $most->[8]); # there can only be one $clone = $prof->clone(); isa_ok( $clone, 'DBI::ProfileData' ); ok($clone->match(key1 => $clone->nodes->[0][7])); ok($clone->match(key2 => $clone->nodes->[0][8])); ok($clone->count == 1); # take a look through Data my $Data = $prof->Data; print "SQL: $_\n" for keys %$Data; ok(exists($Data->{$sql}), "Data for '$sql' should exist") or print Dumper($Data); ok(exists($Data->{$sql}{execute}), "Data for '$sql'->{execute} should exist"); # did the Filter convert set dummy=1 (etc) into set dummy=N? ok(exists($Data->{"set dummy=N"})); # test escaping of \n and \r in keys $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); isa_ok( $dbh, 'DBI::db', 'Created connection' ); my $sql2 = 'select size from . where name = "LITERAL: \r\n"'; my $sql3 = "select size from . where name = \"EXPANDED: \r\n\""; # do a little work foreach (1,2,3) { my $sth2 = $dbh->prepare($sql2); isa_ok( $sth2, 'DBI::st' ); $sth2->execute(); $sth2->fetchrow_hashref; $sth2->finish; my $sth3 = $dbh->prepare($sql3); isa_ok( $sth3, 'DBI::st' ); $sth3->execute(); $sth3->fetchrow_hashref; $sth3->finish; } $dbh->disconnect; undef $dbh; # load dbi.prof $prof = DBI::ProfileData->new( File => $prof_file, DeleteFiles => 1 ); isa_ok( $prof, 'DBI::ProfileData' ); ok(not(-e $prof_file), "file should be deleted when DeleteFiles set" ); # make sure the keys didn't get garbled $Data = $prof->Data; ok(exists $Data->{$sql2}, "Data for '$sql2' should exist") or print Dumper($Data); ok(exists $Data->{$sql3}, "Data for '$sql3' should exist") or print Dumper($Data); done_testing; 1; DBI-1.652/t/52dbm_complex.t0000644000031300001440000003440414742423677014477 0ustar00merijnusers#!perl -w $| = 1; use strict; use warnings; require DBD::DBM; use File::Path; use File::Spec; use Test::More; use Cwd; use Config qw(%Config); use Storable qw(dclone); my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; use DBI; my ( @mldbm_types, @dbm_types ); BEGIN { # 0=SQL::Statement if avail, 1=DBI::SQL::Nano # next line forces use of Nano rather than default behaviour # $ENV{DBI_SQL_NANO}=1; # This is done in zv*n*_50dbm_simple.t if ( eval { require 'MLDBM.pm'; } ) { push @mldbm_types, qw(Data::Dumper Storable); # both in CORE push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' }; push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; }; push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; } # Potential DBM modules in preference order (SDBM_File first) # skip NDBM and ODBM as they don't support EXISTS my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File); my @use_dbms = @ARGV; if ( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) { @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS}; } if ( lc "@use_dbms" eq "all" ) { # test with as many of the major DBM types as are available @dbm_types = grep { eval { no warnings; require "$_.pm" } } @dbms; } elsif (@use_dbms) { @dbm_types = @use_dbms; } else { # we only test SDBM_File by default to avoid tripping up # on any broken DBM's that may be installed in odd places. # It's only DBD::DBM we're trying to test here. # (However, if SDBM_File is not available, then use another.) for my $dbm (@dbms) { if ( eval { no warnings; require "$dbm.pm" } ) { @dbm_types = ($dbm); last; } } } if ( eval { require List::MoreUtils; } ) { List::MoreUtils->import("part"); } else { # XXX from PP part of List::MoreUtils eval <<'EOP'; sub part(&@) { my ($code, @list) = @_; my @parts; push @{ $parts[$code->($_)] }, $_ for @list; return @parts; } EOP } } my $haveSS = DBD::DBM::Statement->isa('SQL::Statement'); plan skip_all => "DBI::SQL::Nano is being used" unless ( $haveSS ); plan skip_all => "Not running with MLDBM" unless ( @mldbm_types ); do "./t/lib.pl"; my $dir = test_dir (); my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, } ); my $suffix; my $tbl_meta; sub break_at_warn { note "break here"; } $SIG{__WARN__} = \&break_at_warn; $SIG{__DIE__} = \&break_at_warn; sub load_tables { my ( $dbmtype, $dbmmldbm ) = @_; my $last_suffix; if ($using_dbd_gofer) { $dbh->disconnect(); $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => $dir, dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm } ); } else { $last_suffix = $suffix; $dbh->{dbm_type} = $dbmtype; $dbh->{dbm_mldbm} = $dbmmldbm; } (my $serializer = $dbmmldbm ) =~ s/::/_/g; $suffix = join( "_", $$, $dbmtype, $serializer ); if ($last_suffix) { for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s)) { my $readsql = sprintf "SELECT * FROM $table", $last_suffix; my $impsql = sprintf "CREATE TABLE $table AS IMPORT (?)", $suffix; my ($readsth); ok( $readsth = $dbh->prepare($readsql), "prepare: $readsql" ); ok( $readsth->execute(), "execute: $readsql" ); ok( $dbh->do( $impsql, {}, $readsth ), $impsql ) or warn $dbh->errstr(); } } else { for my $sql ( split( "\n", join( '', <<'EOD' ) ) ) CREATE TABLE APPL_%s (id INT, applname CHAR, appluniq CHAR, version CHAR, appl_type CHAR) CREATE TABLE PREC_%s (id INT, appl_id INT, node_id INT, precedence INT) CREATE TABLE NODE_%s (id INT, nodename CHAR, os CHAR, version CHAR) CREATE TABLE LANDSCAPE_%s (id INT, landscapename CHAR) CREATE TABLE CONTACT_%s (id INT, surname CHAR, familyname CHAR, phone CHAR, userid CHAR, mailaddr CHAR) CREATE TABLE NM_LANDSCAPE_%s (id INT, ls_id INT, obj_id INT, obj_type INT) CREATE TABLE APPL_CONTACT_%s (id INT, contact_id INT, appl_id INT, contact_type CHAR) INSERT INTO APPL_%s VALUES ( 1, 'ZQF', 'ZFQLIN', '10.2.0.4', 'Oracle DB') INSERT INTO APPL_%s VALUES ( 2, 'YRA', 'YRA-UX', '10.2.0.2', 'Oracle DB') INSERT INTO APPL_%s VALUES ( 3, 'PRN1', 'PRN1-4.B2', '1.1.22', 'CUPS' ) INSERT INTO APPL_%s VALUES ( 4, 'PRN2', 'PRN2-4.B2', '1.1.22', 'CUPS' ) INSERT INTO APPL_%s VALUES ( 5, 'PRN1', 'PRN1-4.B1', '1.1.22', 'CUPS' ) INSERT INTO APPL_%s VALUES ( 7, 'PRN2', 'PRN2-4.B1', '1.1.22', 'CUPS' ) INSERT INTO APPL_%s VALUES ( 8, 'sql-stmt', 'SQL::Statement', '1.21', 'Project Web-Site') INSERT INTO APPL_%s VALUES ( 9, 'cpan.org', 'http://www.cpan.org/', '1.0', 'Web-Site') INSERT INTO APPL_%s VALUES (10, 'httpd', 'cpan-apache', '2.2.13', 'Web-Server') INSERT INTO APPL_%s VALUES (11, 'cpan-mods', 'cpan-mods', '8.4.1', 'PostgreSQL DB') INSERT INTO APPL_%s VALUES (12, 'cpan-authors', 'cpan-authors', '8.4.1', 'PostgreSQL DB') INSERT INTO NODE_%s VALUES ( 1, 'ernie', 'RHEL', '5.2') INSERT INTO NODE_%s VALUES ( 2, 'bert', 'RHEL', '5.2') INSERT INTO NODE_%s VALUES ( 3, 'statler', 'FreeBSD', '7.2') INSERT INTO NODE_%s VALUES ( 4, 'waldorf', 'FreeBSD', '7.2') INSERT INTO NODE_%s VALUES ( 5, 'piggy', 'NetBSD', '5.0.2') INSERT INTO NODE_%s VALUES ( 6, 'kermit', 'NetBSD', '5.0.2') INSERT INTO NODE_%s VALUES ( 7, 'samson', 'NetBSD', '5.0.2') INSERT INTO NODE_%s VALUES ( 8, 'tiffy', 'NetBSD', '5.0.2') INSERT INTO NODE_%s VALUES ( 9, 'rowlf', 'Debian Lenny', '5.0') INSERT INTO NODE_%s VALUES (10, 'fozzy', 'Debian Lenny', '5.0') INSERT INTO PREC_%s VALUES ( 1, 1, 1, 1) INSERT INTO PREC_%s VALUES ( 2, 1, 2, 2) INSERT INTO PREC_%s VALUES ( 3, 2, 2, 1) INSERT INTO PREC_%s VALUES ( 4, 2, 1, 2) INSERT INTO PREC_%s VALUES ( 5, 3, 5, 1) INSERT INTO PREC_%s VALUES ( 6, 3, 7, 2) INSERT INTO PREC_%s VALUES ( 7, 4, 6, 1) INSERT INTO PREC_%s VALUES ( 8, 4, 8, 2) INSERT INTO PREC_%s VALUES ( 9, 5, 7, 1) INSERT INTO PREC_%s VALUES (10, 5, 5, 2) INSERT INTO PREC_%s VALUES (11, 6, 8, 1) INSERT INTO PREC_%s VALUES (12, 7, 6, 2) INSERT INTO PREC_%s VALUES (13, 10, 9, 1) INSERT INTO PREC_%s VALUES (14, 10, 10, 1) INSERT INTO PREC_%s VALUES (15, 8, 9, 1) INSERT INTO PREC_%s VALUES (16, 8, 10, 1) INSERT INTO PREC_%s VALUES (17, 9, 9, 1) INSERT INTO PREC_%s VALUES (18, 9, 10, 1) INSERT INTO PREC_%s VALUES (19, 11, 3, 1) INSERT INTO PREC_%s VALUES (20, 11, 4, 2) INSERT INTO PREC_%s VALUES (21, 12, 4, 1) INSERT INTO PREC_%s VALUES (22, 12, 3, 2) INSERT INTO LANDSCAPE_%s VALUES (1, 'Logistic') INSERT INTO LANDSCAPE_%s VALUES (2, 'Infrastructure') INSERT INTO LANDSCAPE_%s VALUES (3, 'CPAN') INSERT INTO CONTACT_%s VALUES ( 1, 'Hans Peter', 'Mueller', '12345', 'HPMUE', 'hp-mueller@here.com') INSERT INTO CONTACT_%s VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', 'k-inge@here.com') INSERT INTO CONTACT_%s VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', 'lola.ngyuen@customer.com') INSERT INTO CONTACT_%s VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', 'helge.brunft@external-dc.at') -- TYPE: 1: APPL 2: NODE 3: CONTACT INSERT INTO NM_LANDSCAPE_%s VALUES ( 1, 1, 1, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 2, 1, 2, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 3, 3, 3, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 4, 3, 4, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 5, 2, 5, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 6, 2, 6, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 7, 2, 7, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 8, 2, 8, 2) INSERT INTO NM_LANDSCAPE_%s VALUES ( 9, 3, 9, 2) INSERT INTO NM_LANDSCAPE_%s VALUES (10, 3,10, 2) INSERT INTO NM_LANDSCAPE_%s VALUES (11, 1, 1, 1) INSERT INTO NM_LANDSCAPE_%s VALUES (12, 2, 2, 1) INSERT INTO NM_LANDSCAPE_%s VALUES (13, 2, 2, 3) INSERT INTO NM_LANDSCAPE_%s VALUES (14, 3, 1, 3) INSERT INTO APPL_CONTACT_%s VALUES (1, 3, 1, 'OWNER') INSERT INTO APPL_CONTACT_%s VALUES (2, 3, 2, 'OWNER') INSERT INTO APPL_CONTACT_%s VALUES (3, 4, 3, 'ADMIN') INSERT INTO APPL_CONTACT_%s VALUES (4, 4, 4, 'ADMIN') INSERT INTO APPL_CONTACT_%s VALUES (5, 4, 5, 'ADMIN') INSERT INTO APPL_CONTACT_%s VALUES (6, 4, 6, 'ADMIN') EOD { chomp $sql; $sql =~ s/^\s+//; $sql =~ s/--.*$//; $sql =~ s/\s+$//; next if ( '' eq $sql ); $sql = sprintf $sql, $suffix; ok( $dbh->do($sql), $sql ); } } for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s)) { my $tbl_name = lc sprintf($table, $suffix); $tbl_meta->{$tbl_name} = { dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm }; } unless ($using_dbd_gofer) { my $tbl_known_meta = $dbh->dbm_get_meta( "+", [ qw(dbm_type dbm_mldbm) ] ); is_deeply( $tbl_known_meta, $tbl_meta, "Know meta" ); } } sub do_tests { my ( $dbmtype, $serializer ) = @_; note "Running do_tests for $dbmtype + $serializer"; load_tables( $dbmtype, $serializer ); my %joins; my $sql; $sql = join( " ", q{SELECT applname, appluniq, version, nodename }, sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s }, ($suffix) x 3 ), sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ), ); $joins{$sql} = [ 'ZQF~ZFQLIN~10.2.0.4~ernie', 'ZQF~ZFQLIN~10.2.0.4~bert', 'YRA~YRA-UX~10.2.0.2~bert', 'YRA~YRA-UX~10.2.0.2~ernie', 'cpan-mods~cpan-mods~8.4.1~statler', 'cpan-mods~cpan-mods~8.4.1~waldorf', 'cpan-authors~cpan-authors~8.4.1~waldorf', 'cpan-authors~cpan-authors~8.4.1~statler', ]; $sql = join( " ", q{SELECT applname, appluniq, version, landscapename, nodename}, sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, LANDSCAPE_%s, NM_LANDSCAPE_%s}, ($suffix) x 5 ), sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), sprintf( q{PREC_%s.node_id=NODE_%s.id AND NM_LANDSCAPE_%s.obj_id=APPL_%s.id AND}, ($suffix) x 4 ), sprintf( q{NM_LANDSCAPE_%s.obj_type=1 AND NM_LANDSCAPE_%s.ls_id=LANDSCAPE_%s.id}, ($suffix) x 3 ), ); $joins{$sql} = [ 'ZQF~ZFQLIN~10.2.0.4~Logistic~ernie', 'ZQF~ZFQLIN~10.2.0.4~Logistic~bert', 'YRA~YRA-UX~10.2.0.2~Infrastructure~bert', 'YRA~YRA-UX~10.2.0.2~Infrastructure~ernie', ]; $sql = join( " ", q{SELECT applname, appluniq, version, surname, familyname, phone, nodename}, sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ), sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id AND}, ($suffix) x 4 ), sprintf( q{APPL_CONTACT_%s.contact_id=CONTACT_%s.id AND PREC_%s.PRECEDENCE=1}, ($suffix) x 3 ), ); $joins{$sql} = [ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit', 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson', ]; $sql = join( " ", q{SELECT DISTINCT applname, appluniq, version, surname, familyname, phone, nodename}, sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ), sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id}, ($suffix) x 4 ), sprintf( q{AND APPL_CONTACT_%s.contact_id=CONTACT_%s.id}, ($suffix) x 2 ), ); $joins{$sql} = [ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson', 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~samson', 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit', 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~tiffy', ]; $sql = join( " ", q{SELECT CONCAT('[% NOW %]') AS "timestamp", applname, appluniq, version, nodename}, sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s}, ($suffix) x 3 ), sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ), ); $joins{$sql} = [ '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~ernie', '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~bert', '[% NOW %]~YRA~YRA-UX~10.2.0.2~bert', '[% NOW %]~YRA~YRA-UX~10.2.0.2~ernie', '[% NOW %]~cpan-mods~cpan-mods~8.4.1~statler', '[% NOW %]~cpan-mods~cpan-mods~8.4.1~waldorf', '[% NOW %]~cpan-authors~cpan-authors~8.4.1~waldorf', '[% NOW %]~cpan-authors~cpan-authors~8.4.1~statler', ]; while ( my ( $sql, $result ) = each(%joins) ) { my $sth = $dbh->prepare($sql); eval { $sth->execute() }; warn $@ if $@; my @res; while ( my $row = $sth->fetchrow_arrayref() ) { push( @res, join( '~', @{$row} ) ); } is( join( '^', sort @res ), join( '^', sort @{$result} ), $sql ); } } foreach my $dbmtype (@dbm_types) { foreach my $serializer (@mldbm_types) { do_tests( $dbmtype, $serializer ); } } done_testing(); DBI-1.652/t/65transact.t0000644000031300001440000000117615230133071014004 0ustar00merijnusers#!perl -w $|=1; use strict; use DBI; use Test::More; plan skip_all => 'Transactions not supported by DBD::Gofer' if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:Gofer/i; my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef) or die "Unable to connect to ExampleP driver: $DBI::errstr"; print "begin_work...\n"; ok($dbh->{AutoCommit}); ok(!$dbh->{BegunWork}); ok($dbh->begin_work); ok(!$dbh->{AutoCommit}); ok($dbh->{BegunWork}); $dbh->commit; ok($dbh->{AutoCommit}); ok(!$dbh->{BegunWork}); ok($dbh->begin_work({})); $dbh->rollback; ok($dbh->{AutoCommit}); ok(!$dbh->{BegunWork}); done_testing; 1; DBI-1.652/t/17handle_error.t0000644000031300001440000001024014656646601014641 0ustar00merijnusers#!perl -w use strict; use warnings; use DBI; use Test::More; my $skip_error; my $skip_warn; my $handled_errstr; sub error_sub { my ($errstr, $dbh, $ret) = @_; $handled_errstr = $errstr; $handled_errstr =~ s/.* set_err (?:failed|warning): //; return $ret unless ($skip_error and $errstr =~ / set_err failed: /) or ($skip_warn and $errstr =~ / set_err warning:/); $dbh->set_err(undef, undef); return 1; } my $dbh = DBI->connect('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 0, PrintWarn => 0, RaiseWarn => 0, HandleError => \&error_sub }); sub clear_err { $dbh->set_err(undef, undef); $handled_errstr = undef; } ### ok eval { $dbh->set_err('', 'string 1'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 1'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(0, 'string 2'); 1 } or diag($@); is $dbh->err, 0; is $dbh->errstr, 'string 2'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(1, 'string 3'); 1 } or diag($@); is $dbh->err, 1; is $dbh->errstr, 'string 3'; is $handled_errstr, 'string 3'; clear_err; ### $dbh->{RaiseError} = 1; ok eval { $dbh->set_err('', 'string 4'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 4'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(0, 'string 5'); 1 } or diag($@); is $dbh->err, 0; is $dbh->errstr, 'string 5'; is $handled_errstr, undef; clear_err; ok !eval { $dbh->set_err(1, 'string 6'); 1 }; is $dbh->err, 1; is $dbh->errstr, 'string 6'; is $handled_errstr, 'string 6'; clear_err; $dbh->{RaiseError} = 0; ### $dbh->{RaiseWarn} = 1; ok eval { $dbh->set_err('', 'string 7'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 7'; is $handled_errstr, undef; clear_err; ok !eval { $dbh->set_err(0, 'string 8'); 1 }; is $dbh->err, 0; is $dbh->errstr, 'string 8'; is $handled_errstr, 'string 8'; clear_err; ok eval { $dbh->set_err(1, 'string 9'); 1 } or diag($@); is $dbh->err, 1; is $dbh->errstr, 'string 9'; is $handled_errstr, 'string 9'; clear_err; $dbh->{RaiseWarn} = 0; ### $dbh->{RaiseError} = 1; $dbh->{RaiseWarn} = 1; ok eval { $dbh->set_err('', 'string 10'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 10'; is $handled_errstr, undef; clear_err; ok !eval { $dbh->set_err(0, 'string 11'); 1 }; is $dbh->err, 0; is $dbh->errstr, 'string 11'; is $handled_errstr, 'string 11'; clear_err; ok !eval { $dbh->set_err(1, 'string 12'); 1 }; is $dbh->err, 1; is $dbh->errstr, 'string 12'; is $handled_errstr, 'string 12'; clear_err; $dbh->{RaiseError} = 0; $dbh->{RaiseWarn} = 0; ### $dbh->{RaiseError} = 1; $skip_error = 1; ok eval { $dbh->set_err('', 'string 13'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 13'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(0, 'string 14'); 1 } or diag($@); is $dbh->err, 0; is $dbh->errstr, 'string 14'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(1, 'string 15'); 1 } or diag($@); is $dbh->err, undef; is $dbh->errstr, undef; is $handled_errstr, 'string 15'; clear_err; $dbh->{RaiseError} = 0; $skip_error = 0; ### $dbh->{RaiseWarn} = 1; $skip_warn = 1; ok eval { $dbh->set_err('', 'string 16'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 16'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(0, 'string 17'); 1 } or diag($@); is $dbh->err, undef; is $dbh->errstr, undef; is $handled_errstr, 'string 17'; clear_err; ok eval { $dbh->set_err(1, 'string 18'); 1 } or diag($@); is $dbh->err, 1; is $dbh->errstr, 'string 18'; is $handled_errstr, 'string 18'; clear_err; $dbh->{RaiseWarn} = 0; $skip_error = 0; ### $dbh->{RaiseError} = 1; $dbh->{RaiseWarn} = 1; $skip_error = 1; $skip_warn = 1; ok eval { $dbh->set_err('', 'string 19'); 1 } or diag($@); is $dbh->err, ''; is $dbh->errstr, 'string 19'; is $handled_errstr, undef; clear_err; ok eval { $dbh->set_err(0, 'string 20'); 1 } or diag($@); is $dbh->err, undef; is $dbh->errstr, undef; is $handled_errstr, 'string 20'; clear_err; ok eval { $dbh->set_err(1, 'string 21'); 1 } or diag($@); is $dbh->err, undef; is $dbh->errstr, undef; is $handled_errstr, 'string 21'; clear_err; $dbh->{RaiseError} = 0; $dbh->{RaiseWarn} = 0; $skip_error = 0; ### done_testing; DBI-1.652/t/53sqlengine_adv.t0000644000031300001440000000245714742423677015031 0ustar00merijnusers#!perl -w $| = 1; use strict; use warnings; require DBD::DBM; use File::Path; use File::Spec; use Test::More; use Cwd; use Config qw(%Config); use Storable qw(dclone); my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; plan skip_all => "Modifying driver state won't compute running behind Gofer" if($using_dbd_gofer); use DBI; # <[Sno]> what I could do is create a new test case where inserting into a DBD::DBM and after that clone the meta into a DBD::File $dbh # <[Sno]> would that help to get a better picture? do "./t/lib.pl"; my $dir = test_dir(); my $dbm_dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER } ); $dbm_dbh->do(q/create table FRED (a integer, b integer)/); $dbm_dbh->do(q/insert into fRED (a,b) values(1,2)/); $dbm_dbh->do(q/insert into FRED (a,b) values(2,1)/); my $f_dbh = DBI->connect( 'dbi:File:', undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER } ); my $dbm_fred_meta = $dbm_dbh->f_get_meta("fred", [qw(dbm_type)]); $f_dbh->f_new_meta( "fred", {sql_table_class => "DBD::DBM::Table"} ); my $r = $f_dbh->selectall_arrayref(q/select * from Fred/); ok( @$r == 2, 'rows found via mixed case table' ); done_testing(); DBI-1.652/t/13taint.t0000644000031300001440000000571015231610072013275 0ustar00merijnusers#!perl -wT use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB use DBI qw(:sql_types); use Config; use Cwd; use strict; $^W = 1; $| = 1; require VMS::Filespec if $^O eq 'VMS'; use Test::More; # Check Taint attribute works. This requires this test to be run # manually with the -T flag: "perl -T -Mblib t/examp.t" sub is_tainted { my $foo; return ! eval { ($foo=join('',@_)), kill 0; 1; }; } sub mk_tainted { my $string = shift; return substr($string.$^X, 0, length($string)); } plan skip_all => "Taint attributes not supported with DBI::PurePerl" if $DBI::PurePerl; plan skip_all => "Taint attribute tests require taint mode (perl -T)" unless is_tainted($^X); plan skip_all => "Taint attribute tests not functional with DBI_AUTOPROXY" if $ENV{DBI_AUTOPROXY}; # get a dir always readable on all platforms my $dir = getcwd() || cwd(); $dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; $dir =~ m/(.*)/; $dir = $1 || die; # untaint $dir my ($r, $dbh); $dbh = DBI->connect('dbi:ExampleP:', '', '', { PrintError=>0, RaiseError=>1, Taint => 1 }); my $std_sql = "select mode,size,name from ?"; my $csr_a = $dbh->prepare($std_sql); ok(ref $csr_a); ok($dbh->{'Taint'}); ok($dbh->{'TaintIn'} == 1); ok($dbh->{'TaintOut'} == 1); $dbh->{'TaintOut'} = 0; ok($dbh->{'Taint'} == 0); ok($dbh->{'TaintIn'} == 1); ok($dbh->{'TaintOut'} == 0); $dbh->{'Taint'} = 0; ok($dbh->{'Taint'} == 0); ok($dbh->{'TaintIn'} == 0); ok($dbh->{'TaintOut'} == 0); $dbh->{'TaintIn'} = 1; ok($dbh->{'Taint'} == 0); ok($dbh->{'TaintIn'} == 1); ok($dbh->{'TaintOut'} == 0); $dbh->{'TaintOut'} = 1; ok($dbh->{'Taint'} == 1); ok($dbh->{'TaintIn'} == 1); ok($dbh->{'TaintOut'} == 1); $dbh->{'Taint'} = 0; my $st; eval { $st = $dbh->prepare($std_sql); }; ok(ref $st); ok($st->{'Taint'} == 0); ok($st->execute( $dir ), 'should execute ok'); my @row = $st->fetchrow_array; ok(@row); ok(!is_tainted($row[0])); ok(!is_tainted($row[1])); ok(!is_tainted($row[2])); print "TaintIn\n"; $st->{'TaintIn'} = 1; @row = $st->fetchrow_array; ok(@row); ok(!is_tainted($row[0])); ok(!is_tainted($row[1])); ok(!is_tainted($row[2])); print "TaintOut\n"; $st->{'TaintOut'} = 1; @row = $st->fetchrow_array; ok(@row); ok(is_tainted($row[0])); ok(is_tainted($row[1])); ok(is_tainted($row[2])); $st->finish; my $tainted_sql = mk_tainted($std_sql); my $tainted_dot = mk_tainted('.'); $dbh->{'Taint'} = $csr_a->{'Taint'} = 1; eval { $dbh->prepare($tainted_sql); 1; }; ok($@ =~ /Insecure dependency/, $@); eval { $csr_a->execute($tainted_dot); 1; }; ok($@ =~ /Insecure dependency/, $@); eval { $dbh->func($tainted_dot, 'M' x 180); 1; }; ok($@ =~ /Insecure dependency.*parameter 1/s, 'long func method name is safely included in taint rejection'); undef $@; $dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0; eval { $dbh->prepare($tainted_sql); 1; }; ok(!$@, $@); eval { $csr_a->execute($tainted_dot); 1; }; ok(!$@, $@); $csr_a->{Taint} = 0; ok($csr_a->{Taint} == 0); $csr_a->finish; $dbh->disconnect; done_testing; 1; DBI-1.652/t/06attrs.t0000644000031300001440000003704715225122747013337 0ustar00merijnusers#!perl -w use strict; use Storable qw(dclone); use Test::More; ## ---------------------------------------------------------------------------- ## 06attrs.t - ... ## ---------------------------------------------------------------------------- # This test checks the parameters and the values associated with them for # the three different handles (Driver, Database, Statement) ## ---------------------------------------------------------------------------- BEGIN { use_ok( 'DBI' ) } $|=1; my $using_autoproxy = ($ENV{DBI_AUTOPROXY}); my $dsn = 'dbi:ExampleP:dummy'; # Connect to the example driver. my $dbh = DBI->connect($dsn, '', '', { PrintError => 0, RaiseError => 1, }); isa_ok( $dbh, 'DBI::db' ); # Clean up when we're done. END { $dbh->disconnect if $dbh }; ## ---------------------------------------------------------------------------- # Check the database handle attributes. # bit flag attr ok( $dbh->{Warn}, '... checking Warn attribute for dbh'); ok( $dbh->{Active}, '... checking Active attribute for dbh'); ok( $dbh->{AutoCommit}, '... checking AutoCommit attribute for dbh'); ok(!$dbh->{CompatMode}, '... checking CompatMode attribute for dbh'); ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestroy attribute for dbh'); ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for dbh'); ok(!$dbh->{PrintError}, '... checking PrintError attribute for dbh'); ok( $dbh->{PrintWarn}, '... checking PrintWarn attribute for dbh'); # true because of perl -w above ok( $dbh->{RaiseError}, '... checking RaiseError attribute for dbh'); ok(!$dbh->{RaiseWarn}, '... checking RaiseWarn attribute for dbh'); ok(!$dbh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for dbh'); ok(!$dbh->{ChopBlanks}, '... checking ChopBlanks attribute for dbh'); ok(!$dbh->{LongTruncOk}, '... checking LongTrunkOk attribute for dbh'); ok(!$dbh->{TaintIn}, '... checking TaintIn attribute for dbh'); ok(!$dbh->{TaintOut}, '... checking TaintOut attribute for dbh'); ok(!$dbh->{Taint}, '... checking Taint attribute for dbh'); ok(!$dbh->{Executed}, '... checking Executed attribute for dbh'); # other attr cmp_ok($dbh->{ErrCount}, '==', 0, '... checking ErrCount attribute for dbh'); SKIP: { skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl; cmp_ok($dbh->{Kids}, '==', 0, '... checking Kids attribute for dbh');; cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for dbh');; } is($dbh->{CachedKids}, undef, '... checking CachedKids attribute for dbh'); ok(!defined $dbh->{HandleError}, '... checking HandleError attribute for dbh'); ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh'); ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh'); ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for dbh'); ok(!defined $dbh->{ReadOnly}, '... checking ReadOnly attribute for dbh'); is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for dbh'); is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh') # fails for Multiplex unless $using_autoproxy && ok(1); cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for dbh'); cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for dbh'); is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCount)) ], [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many'; is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value'; is delete $dbh->{examplep_private_dbh_attrib}, 42, 'delete on non-private attribute acts like fetch'; is $dbh->{examplep_private_dbh_attrib}, 42, 'value unchanged after delete'; $dbh->{private_foo} = 42; is $dbh->{private_foo}, 42, 'should see private_foo dbh attribute value'; is delete $dbh->{private_foo}, 42, 'delete should return private_foo dbh attribute value'; is $dbh->{private_foo}, undef, 'value of private_foo after delete should be undef'; # Raise an error. eval { $dbh->do('select foo from foo') }; like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching exception'); ok(defined $dbh->err, '... $dbh->err is undefined'); like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking $dbh->errstr'); is($dbh->state, 'S1000', '... checking $dbh->state'); ok($dbh->{Executed}, '... checking Executed attribute for dbh'); # even though it failed $dbh->{Executed} = 0; # reset(able) cmp_ok($dbh->{Executed}, '==', 0, '... checking Executed attribute for dbh (after reset)'); cmp_ok($dbh->{ErrCount}, '==', 1, '... checking ErrCount attribute for dbh (after error was generated)'); ## ---------------------------------------------------------------------------- # Test the driver handle attributes. my $drh = $dbh->{Driver}; isa_ok( $drh, 'DBI::dr' ); ok($dbh->err, '... checking $dbh->err'); cmp_ok($drh->{ErrCount}, '==', 0, '... checking ErrCount attribute for drh'); ok( $drh->{Warn}, '... checking Warn attribute for drh'); ok( $drh->{Active}, '... checking Active attribute for drh'); ok( $drh->{AutoCommit}, '... checking AutoCommit attribute for drh'); ok(!$drh->{CompatMode}, '... checking CompatMode attribute for drh'); ok(!$drh->{InactiveDestroy}, '... checking InactiveDestroy attribute for drh'); ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for drh'); ok(!$drh->{PrintError}, '... checking PrintError attribute for drh'); ok( $drh->{PrintWarn}, '... checking PrintWarn attribute for drh'); # true because of perl -w above ok(!$drh->{RaiseError}, '... checking RaiseError attribute for drh'); ok(!$dbh->{RaiseWarn}, '... checking RaiseWarn attribute for dbh'); ok(!$drh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for drh'); ok(!$drh->{ChopBlanks}, '... checking ChopBlanks attribute for drh'); ok(!$drh->{LongTruncOk}, '... checking LongTrunkOk attribute for drh'); ok(!$drh->{TaintIn}, '... checking TaintIn attribute for drh'); ok(!$drh->{TaintOut}, '... checking TaintOut attribute for drh'); ok(!$drh->{Taint}, '... checking Taint attribute for drh'); SKIP: { skip "Executed attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; ok($drh->{Executed}, '... checking Executed attribute for drh') # due to the do() above } SKIP: { skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if ($DBI::PurePerl or $dbh->{mx_handle_list}); cmp_ok($drh->{Kids}, '==', 1, '... checking Kids attribute for drh'); cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for drh'); } is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh'); ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh'); ok(!defined $drh->{Profile}, '... checking Profile attribute for drh'); ok(!defined $drh->{ReadOnly}, '... checking ReadOnly attribute for drh'); cmp_ok($drh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for drh'); cmp_ok($drh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for drh'); is($drh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for drh'); is($drh->{Name}, 'ExampleP', '... checking Name attribute for drh') unless $using_autoproxy && ok(1); ## ---------------------------------------------------------------------------- # Test the statement handle attributes. # Create a statement handle. my $sth = $dbh->prepare("select ctime, name from ?"); isa_ok($sth, "DBI::st"); ok(!$sth->{Executed}, '... checking Executed attribute for sth'); ok(!$dbh->{Executed}, '... checking Executed attribute for dbh'); cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth'); # Trigger an exception. eval { $sth->execute("foo") }; # we don't check actual opendir error msg because of locale differences like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '... checking exception'); # Test all of the statement handle attributes. like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr'); is($sth->state, 'S1000', '... checking $sth->state'); ok($sth->{Executed}, '... checking Executed attribute for sth'); # even though it failed ok($dbh->{Executed}, '... checking Exceuted attribute for dbh'); # due to $sth->prepare, even though it failed cmp_ok($sth->{ErrCount}, '==', 1, '... checking ErrCount attribute for sth'); $sth->{ErrCount} = 0; cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after reset)'); # booleans ok( $sth->{Warn}, '... checking Warn attribute for sth'); ok(!$sth->{Active}, '... checking Active attribute for sth'); ok(!$sth->{CompatMode}, '... checking CompatMode attribute for sth'); ok(!$sth->{InactiveDestroy}, '... checking InactiveDestroy attribute for sth'); ok(!$sth->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for sth'); ok(!$sth->{PrintError}, '... checking PrintError attribute for sth'); ok( $sth->{PrintWarn}, '... checking PrintWarn attribute for sth'); ok( $sth->{RaiseError}, '... checking RaiseError attribute for sth'); ok(!$dbh->{RaiseWarn}, '... checking RaiseWarn attribute for dbh'); ok(!$sth->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for sth'); ok(!$sth->{ChopBlanks}, '... checking ChopBlanks attribute for sth'); ok(!$sth->{LongTruncOk}, '... checking LongTrunkOk attribute for sth'); ok(!$sth->{TaintIn}, '... checking TaintIn attribute for sth'); ok(!$sth->{TaintOut}, '... checking TaintOut attribute for sth'); ok(!$sth->{Taint}, '... checking Taint attribute for sth'); # common attr SKIP: { skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl; cmp_ok($sth->{Kids}, '==', 0, '... checking Kids attribute for sth'); cmp_ok($sth->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for sth'); } ok(!defined $sth->{CachedKids}, '... checking CachedKids attribute for sth'); ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth'); ok(!defined $sth->{Profile}, '... checking Profile attribute for sth'); ok(!defined $sth->{ReadOnly}, '... checking ReadOnly attribute for sth'); cmp_ok($sth->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for sth'); cmp_ok($sth->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for sth'); is($sth->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for sth'); # sth specific attr ok(!defined $sth->{CursorName}, '... checking CursorName attribute for sth'); cmp_ok($sth->{NUM_OF_FIELDS}, '==', 2, '... checking NUM_OF_FIELDS attribute for sth'); cmp_ok($sth->{NUM_OF_PARAMS}, '==', 1, '... checking NUM_OF_PARAMS attribute for sth'); my $name = $sth->{NAME}; is(ref($name), 'ARRAY', '... checking type of NAME attribute for sth'); cmp_ok(scalar(@{$name}), '==', 2, '... checking number of elements returned'); is_deeply($name, ['ctime', 'name' ], '... checking values returned'); my $name_lc = $sth->{NAME_lc}; is(ref($name_lc), 'ARRAY', '... checking type of NAME_lc attribute for sth'); cmp_ok(scalar(@{$name_lc}), '==', 2, '... checking number of elements returned'); is_deeply($name_lc, ['ctime', 'name' ], '... checking values returned'); my $name_uc = $sth->{NAME_uc}; is(ref($name_uc), 'ARRAY', '... checking type of NAME_uc attribute for sth'); cmp_ok(scalar(@{$name_uc}), '==', 2, '... checking number of elements returned'); is_deeply($name_uc, ['CTIME', 'NAME' ], '... checking values returned'); my $nhash = $sth->{NAME_hash}; is(ref($nhash), 'HASH', '... checking type of NAME_hash attribute for sth'); cmp_ok(scalar(keys(%{$nhash})), '==', 2, '... checking number of keys returned'); cmp_ok($nhash->{ctime}, '==', 0, '... checking values returned'); cmp_ok($nhash->{name}, '==', 1, '... checking values returned'); my $nhash_lc = $sth->{NAME_lc_hash}; is(ref($nhash_lc), 'HASH', '... checking type of NAME_lc_hash attribute for sth'); cmp_ok(scalar(keys(%{$nhash_lc})), '==', 2, '... checking number of keys returned'); cmp_ok($nhash_lc->{ctime}, '==', 0, '... checking values returned'); cmp_ok($nhash_lc->{name}, '==', 1, '... checking values returned'); my $nhash_uc = $sth->{NAME_uc_hash}; is(ref($nhash_uc), 'HASH', '... checking type of NAME_uc_hash attribute for sth'); cmp_ok(scalar(keys(%{$nhash_uc})), '==', 2, '... checking number of keys returned'); cmp_ok($nhash_uc->{CTIME}, '==', 0, '... checking values returned'); cmp_ok($nhash_uc->{NAME}, '==', 1, '... checking values returned'); if ( ! $using_autoproxy and # Older Storable does not work properly with tied handles # Instead of hard-depending on newer Storable, just skip this # particular test outright eval { Storable->VERSION("2.16") } ) { # set ability to set sth attributes that are usually set internally for $a (qw(NAME NAME_lc NAME_uc NAME_hash NAME_lc_hash NAME_uc_hash)) { my $v = $sth->{$a}; ok(eval { $sth->{$a} = dclone($sth->{$a}) }, "Can set sth $a"); is_deeply($sth->{$a}, $v, "Can get set sth $a"); } } my $type = $sth->{TYPE}; is(ref($type), 'ARRAY', '... checking type of TYPE attribute for sth'); cmp_ok(scalar(@{$type}), '==', 2, '... checking number of elements returned'); is_deeply($type, [ 4, 12 ], '... checking values returned'); my $null = $sth->{NULLABLE}; is(ref($null), 'ARRAY', '... checking type of NULLABLE attribute for sth'); cmp_ok(scalar(@{$null}), '==', 2, '... checking number of elements returned'); is_deeply($null, [ 0, 0 ], '... checking values returned'); # Should these work? They don't. my $prec = $sth->{PRECISION}; is(ref($prec), 'ARRAY', '... checking type of PRECISION attribute for sth'); cmp_ok(scalar(@{$prec}), '==', 2, '... checking number of elements returned'); is_deeply($prec, [ 10, 1024 ], '... checking values returned'); my $scale = $sth->{SCALE}; is(ref($scale), 'ARRAY', '... checking type of SCALE attribute for sth'); cmp_ok(scalar(@{$scale}), '==', 2, '... checking number of elements returned'); is_deeply($scale, [ 0, 0 ], '... checking values returned'); my $params = $sth->{ParamValues}; is(ref($params), 'HASH', '... checking type of ParamValues attribute for sth'); is($params->{1}, 'foo', '... checking values returned'); is($sth->{Statement}, "select ctime, name from ?", '... checking Statement attribute for sth'); ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute for sth'); is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth attribute value'; # $h->{TraceLevel} tests are in t/09trace.t note "Checking inheritance\n"; SKIP: { skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if $ENV{DBI_AUTOPROXY}; sub check_inherited { my ($drh, $attr, $value, $skip_sth) = @_; local $drh->{$attr} = $value; local $drh->{PrintError} = 1; my $dbh = $drh->connect("dummy"); is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from drh"; unless ($skip_sth) { my $sth = $dbh->prepare("select name from ."); is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited from dbh"; } } check_inherited($drh, "ReadOnly", 1, 0); } done_testing(); 1; # end DBI-1.652/t/10examp.t0000644000031300001440000004770215231610560013276 0ustar00merijnusers#!perl -w use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB use DBI qw(:sql_types); use Config; use Cwd; use strict; use Data::Dumper; $^W = 1; $| = 1; require File::Basename; require File::Spec; require VMS::Filespec if $^O eq 'VMS'; use Test::More; do { # provide some protection against growth in size of '.' during the test # which was probable cause of this failure # http://www.nntp.perl.org/group/perl.cpan.testers/2009/09/msg5297317.html my $tmpfile = "deleteme_$$"; open my $fh, ">$tmpfile"; close $fh; unlink $tmpfile; }; # "globals" my ($r, $dbh); ok !eval { $dbh = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1, AutoCommit => 1 }); }, 'connect should fail'; like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an exception here'); ok(!$dbh, '... $dbh2 should not be defined'); { my ($error, $tdbh); eval { $tdbh = DBI->connect('dbi:ExampleP:', '', []); } or do { $error= $@ || "Zombie Error"; }; like($error,qr/Usage:/,"connect with unblessed ref password should fail"); ok(!defined($tdbh), '... $dbh should not be defined'); } { package Test::Secret; use overload '""' => sub { return "" }; } { my ($error,$tdbh); eval { $tdbh = DBI->connect('dbi:ExampleP:', '', bless [], "Test::Secret"); } or do { $error= $@ || "Zombie Error"; }; ok(!$error,"connect with blessed ref password should not fail"); ok(defined($tdbh), '... $dbh should be defined'); } $dbh = DBI->connect('dbi:ExampleP:', '', ''); sub check_connect_cached { # connect_cached # ------------------------------------------ # This test checks that connect_cached works # and how it then relates to the CachedKids # attribute for the driver. ok my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); ok my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so they are the same'); ok my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo => 1 }); isnt($dbh_cached_3, $dbh_cached_2, '... this handle was created with different parameters, so it is not the same'); # check that cached_connect applies attributes to handles returned from the cache # (The specific case of Executed is relevant to DBD::Gofer retry-on-error logic) ok $dbh_cached_1->do("select * from ."); # set Executed flag ok $dbh_cached_1->{Executed}, 'Executed should be true'; ok my $dbh_cached_4 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); is $dbh_cached_4, $dbh_cached_1, 'should return same handle'; ok !$dbh_cached_4->{Executed}, 'Executed should be false because reset by connect attributes'; my $drh = $dbh->{Driver}; isa_ok($drh, "DBI::dr"); my @cached_kids = values %{$drh->{CachedKids}}; ok(eq_set(\@cached_kids, [ $dbh_cached_1, $dbh_cached_3 ]), '... these are our cached kids'); $drh->{CachedKids} = {}; cmp_ok(scalar(keys %{$drh->{CachedKids}}), '==', 0, '... we have emptied out cache'); } check_connect_cached(); $dbh->{AutoCommit} = 1; $dbh->{PrintError} = 0; ok($dbh->{AutoCommit} == 1); cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0'); is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME'); # test access to driver-private attributes like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the example driver_path'); print "others\n"; eval { $dbh->commit('dummy') }; ok($@ =~ m/DBI commit: invalid number of arguments:/, $@) unless $DBI::PurePerl && ok(1); #my $long_usage_method = 'examplep_' . ('U' x 260); #DBD::ExampleP::db->install_method( # $long_usage_method, { U => [ 1, 1, '' ] }, #); #eval { $dbh->$long_usage_method('dummy') }; #like($@, qr/invalid number of arguments.*Usage:/s, 'long usage diagnostic is safe'); ok($dbh->ping, "ping should return true"); # --- errors my $cursor_e = $dbh->prepare("select unknown_field_name from ?"); is($cursor_e, undef, "prepare should fail"); ok($dbh->err, "sth->err should be true"); ok($DBI::err, "DBI::err should be true"); cmp_ok($DBI::err, 'eq', $dbh->err , "\$DBI::err should match \$dbh->err"); like($DBI::errstr, qr/Unknown field names: unknown_field_name/, "\$DBI::errstr should contain error string"); cmp_ok($DBI::errstr, 'eq', $dbh->errstr, "\$DBI::errstr should match \$dbh->errstr"); # --- func ok($dbh->errstr eq $dbh->func('errstr')); my $std_sql = "select mode,size,name from ?"; my $csr_a = $dbh->prepare($std_sql); ok(ref $csr_a); ok($csr_a->{NUM_OF_FIELDS} == 3); SKIP: { skip "inner/outer handles not fully supported for DBI::PurePerl", 3 if $DBI::PurePerl; ok(tied %{ $csr_a->{Database} }); # ie is 'outer' handle ok($csr_a->{Database} eq $dbh, "$csr_a->{Database} ne $dbh") unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex tests ok(tied %{ $csr_a->{Database}->{Driver} }); # ie is 'outer' handle } my $driver_name = $csr_a->{Database}->{Driver}->{Name}; ok($driver_name eq 'ExampleP') unless $ENV{DBI_AUTOPROXY} && ok(1); # --- FetchHashKeyName $dbh->{FetchHashKeyName} = 'NAME_uc'; my $csr_b = $dbh->prepare($std_sql); $csr_b->execute('.'); ok(ref $csr_b); ok($csr_a != $csr_b); ok("@{$csr_b->{NAME_lc}}" eq "mode size name"); # before NAME ok("@{$csr_b->{NAME_uc}}" eq "MODE SIZE NAME"); ok("@{$csr_b->{NAME}}" eq "mode size name"); ok("@{$csr_b->{ $csr_b->{FetchHashKeyName} }}" eq "MODE SIZE NAME"); ok("@{[sort keys %{$csr_b->{NAME_lc_hash}}]}" eq "mode name size"); ok("@{[sort values %{$csr_b->{NAME_lc_hash}}]}" eq "0 1 2"); ok("@{[sort keys %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE"); ok("@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2"); do "./t/lib.pl"; # get a dir always readable on all platforms #my $dir = getcwd() || cwd(); #$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; # untaint $dir #$dir =~ m/(.*)/; $dir = $1 || die; my $dir = test_dir (); # --- my($col0, $col1, $col2, $col3, $rows); my(@row_a, @row_b); ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) ); ok($csr_a->execute( $dir ), $DBI::errstr); @row_a = $csr_a->fetchrow_array; ok(@row_a); # check bind_columns is($row_a[0], $col0); is($row_a[1], $col1); is($row_a[2], $col2); ok( ! $csr_a->bind_columns(undef, \($col0, $col1)) ); like $csr_a->errstr, '/bind_columns called with 2 values but 3 are needed/', 'errstr should contain error message'; ok( ! $csr_a->bind_columns(undef, \($col0, $col1, $col2, $col3)) ); like $csr_a->errstr, '/bind_columns called with 4 values but 3 are needed/', 'errstr should contain error message'; ok( $csr_a->bind_col(2, undef, { foo => 42 }) ); ok ! eval { $csr_a->bind_col(0, undef) }; like $@, '/bind_col: column 0 is not a valid column \(1..3\)/', 'errstr should contain error message'; ok ! eval { $csr_a->bind_col(4, undef) }; like $@, '/bind_col: column 4 is not a valid column \(1..3\)/', 'errstr should contain error message'; ok($csr_b->bind_param(1, $dir)); ok($csr_b->execute()); @row_b = @{ $csr_b->fetchrow_arrayref }; ok(@row_b); ok("@row_a" eq "@row_b"); @row_b = $csr_b->fetchrow_array; ok("@row_a" ne "@row_b"); ok($csr_a->finish); ok($csr_b->finish); $csr_a = undef; # force destruction of this cursor now ok(1); print "fetchrow_hashref('NAME_uc')\n"; ok($csr_b->execute()); my $row_b = $csr_b->fetchrow_hashref('NAME_uc'); ok($row_b); ok($row_b->{MODE} == $row_a[0]); ok($row_b->{SIZE} == $row_a[1]); ok($row_b->{NAME} eq $row_a[2]); print "fetchrow_hashref('ParamValues')\n"; ok($csr_b->execute()); ok(!defined eval { $csr_b->fetchrow_hashref('ParamValues') } ); # PurePerl croaks print "FetchHashKeyName\n"; ok($csr_b->execute()); $row_b = $csr_b->fetchrow_hashref(); ok($row_b); ok(keys(%$row_b) == 3); ok($row_b->{MODE} == $row_a[0]); ok($row_b->{SIZE} == $row_a[1]); ok($row_b->{NAME} eq $row_a[2]); print "fetchall_arrayref\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref; ok($r); ok(@$r); ok($r->[0]->[0] == $row_a[0]); ok($r->[0]->[1] == $row_a[1]); ok($r->[0]->[2] eq $row_a[2]); print "fetchall_arrayref array slice\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref([2,1]); ok($r && @$r); ok($r->[0]->[1] == $row_a[1]); ok($r->[0]->[0] eq $row_a[2]); print "fetchall_arrayref hash slice\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref({ SizE=>1, nAMe=>1}); ok($r && @$r); ok($r->[0]->{SizE} == $row_a[1]); ok($r->[0]->{nAMe} eq $row_a[2]); ok ! $csr_b->fetchall_arrayref({ NoneSuch=>1 }); like $DBI::errstr, qr/Invalid column name/; print "fetchall_arrayref renaming hash slice\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref(\{ 1 => "Koko", 2 => "Nimi"}); ok($r && @$r); ok($r->[0]->{Koko} == $row_a[1]); ok($r->[0]->{Nimi} eq $row_a[2]); ok ! eval { $csr_b->fetchall_arrayref(\{ 9999 => "Koko" }) }; like $@, qr/\Qis not a valid column/; print "fetchall_arrayref empty renaming hash slice\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref(\{}); ok($r && @$r); ok(keys %{$r->[0]} == 0); ok($csr_b->execute()); ok(!$csr_b->fetchall_arrayref(\[])); like $DBI::errstr, qr/\Qfetchall_arrayref(REF) invalid/; print "fetchall_arrayref hash\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref({}); ok($r); ok(keys %{$r->[0]} == 3); ok("@{$r->[0]}{qw(MODE SIZE NAME)}" eq "@row_a", "'@{$r->[0]}{qw(MODE SIZE NAME)}' ne '@row_a'"); print "rows()\n"; # assumes previous fetch fetched all rows $rows = $csr_b->rows; ok($rows > 0, "row count $rows"); ok($rows == @$r, "$rows vs ".@$r); ok($rows == $DBI::rows, "$rows vs $DBI::rows"); print "fetchall_arrayref array slice and max rows\n"; ok($csr_b->execute()); $r = $csr_b->fetchall_arrayref([0], 1); ok($r); is_deeply($r, [[$row_a[0]]]); $r = $csr_b->fetchall_arrayref([], 1); is @$r, 1, 'should fetch one row'; $r = $csr_b->fetchall_arrayref([], 99999); ok @$r, 'should fetch all the remaining rows'; $r = $csr_b->fetchall_arrayref([], 99999); is $r, undef, 'should return undef as there are no more rows'; # --- print "selectrow_array\n"; @row_b = $dbh->selectrow_array($std_sql, undef, $dir); ok(@row_b == 3); ok("@row_b" eq "@row_a"); print "selectrow_hashref\n"; $r = $dbh->selectrow_hashref($std_sql, undef, $dir); ok(keys %$r == 3); ok($r->{MODE} eq $row_a[0]); ok($r->{SIZE} eq $row_a[1]); ok($r->{NAME} eq $row_a[2]); print "selectall_arrayref\n"; $r = $dbh->selectall_arrayref($std_sql, undef, $dir); ok($r); ok(@{$r->[0]} == 3); ok("@{$r->[0]}" eq "@row_a"); ok(@$r == $rows); print "selectall_arrayref Slice array slice\n"; $r = $dbh->selectall_arrayref($std_sql, { Slice => [ 2, 0 ] }, $dir); ok($r); ok(@{$r->[0]} == 2); ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"}); ok(@$r == $rows); print "selectall_arrayref Columns array slice\n"; $r = $dbh->selectall_arrayref($std_sql, { Columns => [ 3, 1 ] }, $dir); ok($r); ok(@{$r->[0]} == 2); ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"}); ok(@$r == $rows); print "selectall_arrayref hash slice\n"; $r = $dbh->selectall_arrayref($std_sql, { Columns => { MoDe=>1, NamE=>1 } }, $dir); ok($r); ok(keys %{$r->[0]} == 2); ok(exists $r->[0]{MoDe}); ok(exists $r->[0]{NamE}); ok($r->[0]{MoDe} eq $row_a[0]); ok($r->[0]{NamE} eq $row_a[2]); ok(@$r == $rows); print "selectall_array\n"; $r = [ $dbh->selectall_array($std_sql, undef, $dir) ]; ok($r); ok(@{$r->[0]} == 3); ok("@{$r->[0]}" eq "@row_a"); ok(@$r == $rows); print "selectall_hashref\n"; $r = $dbh->selectall_hashref($std_sql, 'NAME', undef, $dir); ok($r, "selectall_hashref result"); is(ref $r, 'HASH', "selectall_hashref HASH: ".ref $r); is(scalar keys %$r, $rows); is($r->{ $row_a[2] }{SIZE}, $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]}); print "selectall_hashref by column number\n"; $r = $dbh->selectall_hashref($std_sql, 3, undef, $dir); ok($r); ok($r->{ $row_a[2] }{SIZE} eq $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]}); print "selectcol_arrayref\n"; $r = $dbh->selectcol_arrayref($std_sql, undef, $dir); ok($r); ok(@$r == $rows); ok($r->[0] eq $row_b[0]); print "selectcol_arrayref column slice\n"; $r = $dbh->selectcol_arrayref($std_sql, { Columns => [3,2] }, $dir); ok($r); # warn Dumper([\@row_b, $r]); ok(@$r == $rows * 2); ok($r->[0] eq $row_b[2]); ok($r->[1] eq $row_b[1]); # --- print "others...\n"; my $csr_c; $csr_c = $dbh->prepare("select unknown_field_name1 from ?"); ok(!defined $csr_c); ok($DBI::errstr =~ m/Unknown field names: unknown_field_name1/); print "RaiseError & PrintError & ShowErrorStatement\n"; $dbh->{RaiseError} = 1; ok($dbh->{RaiseError}); $dbh->{ShowErrorStatement} = 1; ok($dbh->{ShowErrorStatement}); my $error_sql = "select unknown_field_name2 from ?"; ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); #print "$@\n"; like $@, qr/\Q$error_sql/; # ShowErrorStatement like $@, qr/Unknown field names: unknown_field_name2/; # check attributes are inherited my $se_sth1 = $dbh->prepare("select mode from ?"); ok($se_sth1->{RaiseError}); ok($se_sth1->{ShowErrorStatement}); # check ShowErrorStatement ParamValues are included and sorted $se_sth1->bind_param($_, "val$_") for (1..11); ok( !eval { $se_sth1->execute } ); like $@, qr/\[for Statement "select mode from \?" with ParamValues: 1='val1', 2='val2', 3='val3', 4='val4', 5='val5', 6='val6', 7='val7', 8='val8', 9='val9', 10='val10', 11='val11'\]/; # this test relies on the fact that ShowErrorStatement is set above TODO: { local $TODO = "rt66127 not fixed yet"; eval { local $se_sth1->{PrintError} = 0; $se_sth1->execute(1,2); }; unlike($@, qr/ParamValues:/, 'error string does not contain ParamValues'); is($se_sth1->{ParamValues}, undef, 'ParamValues is empty') or diag(Dumper($se_sth1->{ParamValues})); }; # check that $dbh->{Statement} tracks last _executed_ sth $se_sth1 = $dbh->prepare("select mode from ?"); ok($se_sth1->{Statement} eq "select mode from ?"); ok($dbh->{Statement} eq "select mode from ?") or print "got: $dbh->{Statement}\n"; my $se_sth2 = $dbh->prepare("select name from ?"); ok($se_sth2->{Statement} eq "select name from ?"); ok($dbh->{Statement} eq "select name from ?"); $se_sth1->execute('.'); ok($dbh->{Statement} eq "select mode from ?"); # show error param values ok(! eval { $se_sth1->execute('first','second') }); # too many params ok($@ =~ /\b1='first'/, $@); ok($@ =~ /\b2='second'/, $@); $se_sth1->finish; $se_sth2->finish; $dbh->{RaiseError} = 0; ok(!$dbh->{RaiseError}); $dbh->{ShowErrorStatement} = 0; ok(!$dbh->{ShowErrorStatement}); { my @warn; local($SIG{__WARN__}) = sub { push @warn, @_ }; $dbh->{PrintError} = 1; ok($dbh->{PrintError}); ok(! $dbh->selectall_arrayref("select unknown_field_name3 from ?")); ok("@warn" =~ m/Unknown field names: unknown_field_name3/); $dbh->{PrintError} = 0; ok(!$dbh->{PrintError}); } print "HandleError\n"; my $HandleErrorReturn; my $HandleError = sub { my $msg = sprintf "HandleError: %s [h=%s, rv=%s, #=%d]", $_[0],$_[1],(defined($_[2])?$_[2]:'undef'),scalar(@_); die $msg if $HandleErrorReturn < 0; print "$msg\n"; $_[2] = 42 if $HandleErrorReturn == 2; return $HandleErrorReturn; }; $dbh->{HandleError} = $HandleError; ok($dbh->{HandleError}); ok($dbh->{HandleError} == $HandleError); $dbh->{RaiseError} = 1; $dbh->{PrintError} = 0; $error_sql = "select unknown_field_name2 from ?"; print "HandleError -> die\n"; $HandleErrorReturn = -1; ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); ok($@ =~ m/^HandleError:/, $@); print "HandleError -> 0 -> RaiseError\n"; $HandleErrorReturn = 0; ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); ok($@ =~ m/^DBD::(ExampleP|Multiplex|Gofer)::db prepare failed:/, $@); print "HandleError -> 1 -> return (original)undef\n"; $HandleErrorReturn = 1; $r = eval { $csr_c = $dbh->prepare($error_sql); }; ok(!$@, $@); ok(!defined($r), $r); print "HandleError -> 2 -> return (modified)42\n"; $HandleErrorReturn = 2; $r = eval { $csr_c = $dbh->prepare($error_sql); }; ok(!$@, $@); ok($r==42) unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex $dbh->{HandleError} = undef; ok(!$dbh->{HandleError}); { # dump_results; my $sth = $dbh->prepare($std_sql); isa_ok($sth, "DBI::st"); if (length(File::Spec->updir)) { ok($sth->execute(File::Spec->updir)); } else { ok($sth->execute('../')); } my $dump_file = "dumpcsr.tst.$$"; SKIP: { skip "# dump_results test skipped: unable to open $dump_file: $!\n", 4 unless open(DUMP_RESULTS, ">$dump_file"); ok($sth->dump_results("10", "\n", ",\t", \*DUMP_RESULTS)); close(DUMP_RESULTS) or warn "close $dump_file: $!"; ok(-s $dump_file > 0); is( unlink( $dump_file ), 1, "Remove $dump_file" ); ok( !-e $dump_file, "Actually gone" ); } } note "table_info\n"; # First generate a list of all subdirectories $dir = File::Basename::dirname( $INC{"DBI.pm"} ); my $dh; ok(opendir($dh, $dir)); my(%dirs, %unexpected, %missing); while (defined(my $file = readdir($dh))) { $dirs{$file} = 1 if -d File::Spec->catdir($dir,$file); } note( "Local $dir subdirs: @{[ keys %dirs ]}" ); closedir($dh); my $sth = $dbh->table_info($dir, undef, "%", "TABLE"); ok($sth); %unexpected = %dirs; %missing = (); while (my $ref = $sth->fetchrow_hashref()) { if (exists($unexpected{$ref->{'TABLE_NAME'}})) { delete $unexpected{$ref->{'TABLE_NAME'}}; } else { $missing{$ref->{'TABLE_NAME'}} = 1; } } ok(keys %unexpected == 0) or diag "Unexpected directories: ", join(",", keys %unexpected), "\n"; ok(keys %missing == 0) or diag "Missing directories: ", join(",", keys %missing), "\n"; note "tables\n"; my @tables_expected = ( q{"schema"."table"}, q{"sch-ema"."table"}, q{"schema"."ta-ble"}, q{"sch ema"."table"}, q{"schema"."ta ble"}, ); my @tables = $dbh->tables(undef, undef, "%", "VIEW"); ok(@tables == @tables_expected, "Table count mismatch".@tables_expected." vs ".@tables); ok($tables[$_] eq $tables_expected[$_], "$tables[$_] ne $tables_expected[$_]") foreach (0..$#tables_expected); for (my $i = 0; $i < 300; $i += 100) { note "Testing the fake directories ($i).\n"; ok($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i")); ok($csr_a->execute(), $DBI::errstr); my $ary = $csr_a->fetchall_arrayref; ok(@$ary == $i, @$ary." rows instead of $i"); if ($i) { my @n1 = map { $_->[0] } @$ary; my @n2 = reverse map { "file$_" } 1..$i; ok("@n1" eq "@n2", "'@n1' ne '@n2'"); } else { ok(1); } } SKIP: { skip "test not tested with Multiplex", 1 if $dbh->{mx_handle_list}; note "Testing \$dbh->func().\n"; my %tables; %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables(); my @func_tables = $dbh->func('lib', 'examplep_tables'); foreach my $t (@func_tables) { defined(delete $tables{$t}) or print "Unexpected table: $t\n"; } is(keys(%tables), 0); } { # some tests on special cases for the older tables call # uses DBD::NullP and relies on 2 facts about DBD::NullP: # 1) it has a get_info for for 29 - the quote chr # 2) it has a table_info which returns some types and catalogs my $dbhnp = DBI->connect('dbi:NullP:test'); # this special case should just return a list of table types my @types = $dbhnp->tables('','','','%'); ok(scalar(@types), 'we got some table types'); my $defined = grep {defined($_)} @types; is($defined, scalar(@types), 'all table types are defined'); SKIP: { skip "some table types were not defined", 1 if ($defined != scalar(@types)); my $found_sep = grep {$_ =~ '\.'} @types; is($found_sep, 0, 'no name separators in table types') or diag(Dumper(\@types)); }; # this special case should just return a list of catalogs my @catalogs = $dbhnp->tables('%', '', ''); ok(scalar(@catalogs), 'we got some catalogs'); SKIP: { skip "no catalogs found", 1 if !scalar(@catalogs); my $found_sep = grep {$_ =~ '\.'} @catalogs; is($found_sep, 0, 'no name separators in catalogs') or diag(Dumper(\@catalogs)); }; $dbhnp->disconnect; } $dbh->disconnect; ok(!$dbh->{Active}); ok(!$dbh->ping, "ping should return false after disconnect"); done_testing; 1; DBI-1.652/t/70callbacks.t0000644000031300001440000002266714742423677014135 0ustar00merijnusers#!perl -w # vim:ts=8:sw=4 use strict; use Test::More; use DBI; BEGIN { plan skip_all => '$h->{Callbacks} attribute not supported for DBI::PurePerl' if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning } $| = 1; my $dsn = "dbi:ExampleP:drv_foo=drv_bar"; my %called; ok my $dbh = DBI->connect($dsn, '', ''), "Create dbh"; is $dbh->{Callbacks}, undef, "Callbacks initially undef"; ok $dbh->{Callbacks} = my $cb = { }; is ref $dbh->{Callbacks}, 'HASH', "Callbacks can be set to a hash ref"; is $dbh->{Callbacks}, $cb, "Callbacks set to same hash ref"; $dbh->{Callbacks} = undef; is $dbh->{Callbacks}, undef, "Callbacks set to undef again"; ok $dbh->{Callbacks} = { ping => sub { my $m = $_; is $m, 'ping', '$m holds method name'; is $_, 'ping', '$_ holds method name (not stolen)'; is @_, 1, '@_ holds 1 values'; is ref $_[0], 'DBI::db', 'first is $dbh'; ok tied(%{$_[0]}), '$dbh is tied (outer) handle' or DBI::dump_handle($_[0], 'tied?', 10); $called{$_}++; return; }, quote_identifier => sub { is @_, 4, '@_ holds 4 values'; my $dbh = shift; is ref $dbh, 'DBI::db', 'first is $dbh'; is $_[0], 'foo'; is $_[1], 'bar'; is $_[2], undef; $_[2] = { baz => 1 }; $called{$_}++; return (1,2,3); # return something - which is not allowed }, disconnect => sub { # test die from within a callback die "You can't disconnect that easily!\n"; }, "*" => sub { $called{$_}++; return; } }; is keys %{ $dbh->{Callbacks} }, 4; is ref $dbh->{Callbacks}->{ping}, 'CODE'; $_ = 42; ok $dbh->ping; is $called{ping}, 1; is $_, 42, '$_ not altered by callback'; ok $dbh->ping; is $called{ping}, 2; ok $dbh->type_info_all; is $called{type_info_all}, 1, 'fallback callback'; my $attr; eval { $dbh->quote_identifier('foo','bar', $attr) }; is $called{quote_identifier}, 1; ok $@, 'quote_identifier callback caused fatal error'; is ref $attr, 'HASH', 'param modified by callback - not recommended!'; ok !eval { $dbh->disconnect }; ok $@, "You can't disconnect that easily!\n"; $dbh->{Callbacks} = undef; ok $dbh->ping; is $called{ping}, 2; # no change # --- test skipping dispatch and fallback callbacks $dbh->{Callbacks} = { ping => sub { undef $_; # tell dispatch to not call the method return "42 bells"; }, data_sources => sub { my ($h, $values_to_return) = @_; undef $_; # tell dispatch to not call the method my @ret = 11..10+($values_to_return||0); return @ret; }, commit => sub { # test using set_err within a callback my $h = shift; undef $_; # tell dispatch to not call the method return $h->set_err(42, "faked commit failure"); }, }; # these tests are slightly convoluted because messing with the stack is bad for # your mental health my $rv = $dbh->ping; is $rv, "42 bells"; my @rv = $dbh->ping; is scalar @rv, 1, 'should return a single value in list context'; is "@rv", "42 bells"; # test returning lists with different number of args to test # the stack handling in the dispatch code is join(":", $dbh->data_sources()), ""; is join(":", $dbh->data_sources(0)), ""; is join(":", $dbh->data_sources(1)), "11"; is join(":", $dbh->data_sources(2)), "11:12"; { local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; is eval { $dbh->commit }, undef, 'intercepted commit should return undef'; like $@, '/DBD::\w+::db commit failed: faked commit failure/'; is $DBI::err, 42; is $DBI::errstr, "faked commit failure"; } # --- test connect_cached.* =for comment XXX The big problem here is that conceptually the Callbacks attribute is applied to the $dbh _during_ the $drh->connect() call, so you can't set a callback on "connect" on the $dbh because connect isn't called on the dbh, but on the $drh. So a "connect" callback would have to be defined on the $drh, but that's cumbersome for the user and then it would apply to all future connects using that driver. The best thing to do is probably to special-case "connect", "connect_cached" and (the already special-case) "connect_cached.reused". =cut my $driver_dsn = (DBI->parse_dsn($dsn))[4] or die 'panic'; my @args = ( $dsn, 'u', 'p', { Callbacks => { "connect_cached.new" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.new $h is tied (outer) handle' if $dbh; # $dbh is typically undef or a dead/disconnected $dbh like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{new}++; return; }, "connect_cached.reused" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.reused $h is tied (outer) handle'; like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{cached}++; return; }, "connect_cached.connected" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.connected $h is tied (outer) handle'; like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{connected}++; return; }, } } ); %called = (); ok $dbh = DBI->connect(@args), "Create handle with callbacks"; is keys %called, 0, 'no callback for plain connect'; ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; is $called{new}, 1, "connect_cached.new called"; is $called{cached}, undef, "connect_cached.reused not yet called"; is $called{connected}, 1, "connect_cached.connected called"; ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; is $called{cached}, 1, "connect_cached.reused called"; is $called{new}, 1, "connect_cached.new not called again"; is $called{connected}, 1, "connect_cached.connected not called called"; # --- test ChildCallbacks. %called = (); $args[-1] = { Callbacks => my $dbh_callbacks = { ping => sub { $called{ping}++; return; }, ChildCallbacks => my $sth_callbacks = { execute => sub { $called{execute}++; return; }, fetch => sub { $called{fetch}++; return; }, } } }; ok $dbh = DBI->connect(@args), "Create handle with ChildCallbacks"; ok $dbh->ping, 'Ping'; is $called{ping}, 1, 'Ping callback should have been called'; ok my $sth = $dbh->prepare('SELECT name from t'), 'Prepare a statement handle (child)'; ok $sth->{Callbacks}, 'child should have Callbacks'; is $sth->{Callbacks}, $sth_callbacks, "child Callbacks should be ChildCallbacks of parent" or diag "(dbh Callbacks is $dbh_callbacks)"; ok $sth->execute, 'Execute'; is $called{execute}, 1, 'Execute callback should have been called'; ok $sth->fetch, 'Fetch'; is $called{fetch}, 1, 'Fetch callback should have been called'; # stress test for stack reallocation and mark handling -- RT#86744 my $stress_count = 3000; my $place_holders = join(',', ('?') x $stress_count); my @params = ('t') x $stress_count; my $stress_dbh = DBI->connect( 'DBI:NullP:test'); my $stress_sth = $stress_dbh->prepare("select 1"); $stress_sth->{Callbacks}{execute} = sub { return; }; $stress_sth->execute(@params); { package LeakDetect; our $count = 0; sub new { my $class = shift; $count++; return bless {}, $class; } sub DESTROY { $count--; } } # ensure running a callback does not leak extant $_ $dbh = DBI->connect('DBI:NullP:test'); $dbh->{Callbacks}{ping} = sub {}; # with plain assignment to $_ $_ = LeakDetect->new; if ($] >= 5.008002) { is $LeakDetect::count, 1, "[plain] live object count is 1 after new()"; my $obj = $_; $dbh->ping; is $_, $obj, '[plain] $_ still holds an object reference after the callback'; } $_ = undef; is $_, undef, '[plain] $_ is undef at the end'; is $LeakDetect::count, 0, "[plain] live object count is 0 after all object references are gone"; # with localized $_ if ($] >= 5.008002) { local $_ = LeakDetect->new; is $LeakDetect::count, 1, "[local] live object count is 1 after new()"; my $obj = $_; $dbh->ping; is $_, $obj, '[local] $_ still holds an object reference after the callback'; } is $_, undef, '[local] $_ is undef at the end'; is $LeakDetect::count, 0, "[local] live object count is 0 after all object references are gone"; # with implicit localization of $_ for (LeakDetect->new) { is $LeakDetect::count, 1, "[foreach] live object count is 1 after new()"; my $obj = $_; $] >= 5.008002 or next; $dbh->ping; is $_, $obj, '[foreach] $_ still holds an object reference after the callback'; } is $_, undef, '[foreach] $_ is undef at the end'; is $LeakDetect::count, 0, "[foreach] live object count is 0 after all object references are gone"; done_testing(); __END__ A generic 'transparent' callback looks like this: (this assumes only scalar context will be used) sub { my $h = shift; return if our $avoid_deep_recursion->{"$h $_"}++; my $this = $h->$_(@_); undef $_; # tell DBI not to call original method return $this; # tell DBI to return this instead }; XXX should add a test for this XXX even better would be to run chunks of the test suite with that as a '*' callback. In theory everything should pass (except this test file, naturally).. DBI-1.652/lib/0000755000031300001440000000000015240046615012133 5ustar00merijnusersDBI-1.652/lib/DBD/0000755000031300001440000000000015240046615012524 5ustar00merijnusersDBI-1.652/lib/DBD/ExampleP.pm0000644000031300001440000003021714656646601014613 0ustar00merijnusers{ package DBD::ExampleP; use strict; use warnings; use Symbol; use DBI qw(:sql_types); require File::Spec; our (@EXPORT,$VERSION,@statnames,%statnames,@stattypes,%stattypes, @statprec,%statprec,$drh,); @EXPORT = qw(); # Do NOT @EXPORT anything. $VERSION = "12.014311"; # $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $ # # Copyright (c) 1994,1997,1998 Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. @statnames = qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks name); @statnames{@statnames} = (0 .. @statnames-1); @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); @stattypes{@statnames} = @stattypes; @statprec = ((10) x (@statnames-1), 1024); @statprec{@statnames} = @statprec; die unless @statnames == @stattypes; die unless @statprec == @stattypes; $drh = undef; # holds driver handle once initialised #$gensym = "SYM000"; # used by st::execute() for filehandles sub driver{ return $drh if $drh; my($class, $attr) = @_; $class .= "::dr"; ($drh) = DBI::_new_drh($class, { 'Name' => 'ExampleP', 'Version' => $VERSION, 'Attribution' => 'DBD Example Perl stub by Tim Bunce', }, ['example implementors private data '.__PACKAGE__]); $drh; } sub CLONE { undef $drh; } } { package DBD::ExampleP::dr; # ====== DRIVER ====== $imp_data_size = 0; use strict; sub connect { # normally overridden, but a handy default my($drh, $dbname, $user, $auth)= @_; my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dbname, examplep_private_dbh_attrib => 42, # an example, for testing }); $dbh->{examplep_get_info} = { 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR 41 => '.', # SQL_CATALOG_NAME_SEPARATOR 114 => 1, # SQL_CATALOG_LOCATION }; #$dbh->{Name} = $dbname; $dbh->STORE('Active', 1); return $outer; } sub data_sources { return ("dbi:ExampleP:dir=."); # possibly usefully meaningless } } { package DBD::ExampleP::db; # ====== DATABASE ====== $imp_data_size = 0; use strict; sub prepare { my($dbh, $statement)= @_; my @fields; my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; if (defined $fields and defined $dir) { @fields = ($fields eq '*') ? keys %DBD::ExampleP::statnames : split(/\s*,\s*/, $fields); } else { return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") unless $statement =~ m/^\s*set\s+/; # the SET syntax is just a hack so the ExampleP driver can # be used to test non-select statements. # Now we have DBI::DBM etc., ExampleP should be deprecated } my ($outer, $sth) = DBI::_new_sth($dbh, { 'Statement' => $statement, examplep_private_sth_attrib => 24, # an example, for testing }, ['example implementors private data '.__PACKAGE__]); my @bad = map { defined $DBD::ExampleP::statnames{$_} ? () : $_ } @fields; return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") if @bad; $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); if (@fields) { $outer->STORE('NAME' => \@fields); $outer->STORE('NULLABLE' => [ (0) x @fields ]); $outer->STORE('SCALE' => [ (0) x @fields ]); } $outer; } sub table_info { my $dbh = shift; my ($catalog, $schema, $table, $type) = @_; my @types = split(/["']*,["']/, $type || 'TABLE'); my %types = map { $_=>$_ } @types; # Return a list of all subdirectories my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; my $dir = $catalog || File::Spec->curdir(); my @list; if ($types{VIEW}) { # for use by test harness push @list, [ undef, "schema", "table", 'VIEW', undef ]; push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; } if ($types{TABLE}) { no strict 'refs'; opendir($dh, $dir) or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); while (defined(my $item = readdir($dh))) { if ($^O eq 'VMS') { # if on VMS then avoid warnings from catdir if you use a file # (not a dir) as the item below next if $item !~ /\.dir$/oi; } my $file = File::Spec->catdir($dir,$item); next unless -d $file; my($dev, $ino, $mode, $nlink, $uid) = lstat($file); my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; } close($dh); } # We would like to simply do a DBI->connect() here. However, # this is wrong if we are in a subclass like DBI::ProxyServer. $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') or return $dbh->set_err($DBI::err, "Failed to connect to DBI::Sponge: $DBI::errstr"); my $attr = { 'rows' => \@list, 'NUM_OF_FIELDS' => 5, 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS'], 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], 'NULLABLE' => [1, 1, 1, 1, 1] }; my $sdbh = $dbh->{'dbd_sponge_dbh'}; my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); $sth; } sub type_info_all { my ($dbh) = @_; my $ti = [ { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE=> 9, FIXED_PREC_SCALE=> 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, }, [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], ]; return $ti; } sub ping { (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t } sub disconnect { shift->STORE(Active => 0); return 1; } sub get_info { my ($dbh, $info_type) = @_; return $dbh->{examplep_get_info}->{$info_type}; } sub FETCH { my ($dbh, $attrib) = @_; # In reality this would interrogate the database engine to # either return dynamic values that cannot be precomputed # or fetch and cache attribute values too expensive to prefetch. # else pass up to DBI to handle return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; return $dbh->SUPER::FETCH($attrib); } sub STORE { my ($dbh, $attrib, $value) = @_; # store only known attributes else pass up to DBI to handle if ($attrib eq 'examplep_set_err') { # a fake attribute to enable a test case where STORE issues a warning $dbh->set_err($value, $value); return; } if ($attrib eq 'AutoCommit') { # convert AutoCommit values to magic ones to let DBI # know that the driver has 'handled' the AutoCommit attribute $value = ($value) ? -901 : -900; } return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; return $dbh->SUPER::STORE($attrib, $value); } sub DESTROY { my $dbh = shift; $dbh->disconnect if $dbh->FETCH('Active'); undef } # This is an example to demonstrate the use of driver-specific # methods via $dbh->func(). # Use it as follows: # my @tables = $dbh->func($re, 'examplep_tables'); # # Returns all the tables that match the regular expression $re. sub examplep_tables { my $dbh = shift; my $re = shift; grep { $_ =~ /$re/ } $dbh->tables(); } sub parse_trace_flag { my ($h, $name) = @_; return 0x01000000 if $name eq 'foo'; return 0x02000000 if $name eq 'bar'; return 0x04000000 if $name eq 'baz'; return 0x08000000 if $name eq 'boo'; return 0x10000000 if $name eq 'bop'; return $h->SUPER::parse_trace_flag($name); } sub private_attribute_info { return { example_driver_path => undef }; } } { package DBD::ExampleP::st; # ====== STATEMENT ====== $imp_data_size = 0; use strict; no strict 'refs'; # cause problems with filehandles sub bind_param { my($sth, $param, $value, $attribs) = @_; $sth->{'dbd_param'}->[$param-1] = $value; return 1; } sub execute { my($sth, @dir) = @_; my $dir; if (@dir) { $sth->bind_param($_, $dir[$_-1]) or return foreach (1..@dir); } my $dbd_param = $sth->{'dbd_param'} || []; return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") unless @$dbd_param == $sth->{NUM_OF_PARAMS}; return 0 unless $sth->{NUM_OF_FIELDS}; # not a select $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; return $sth->set_err(2, "No bind parameter supplied") unless defined $dir; $sth->finish; # # If the users asks for directory "long_list_4532", then we fake a # directory with files "file4351", "file4350", ..., "file0". # This is a special case used for testing, especially DBD::Proxy. # if ($dir =~ /^long_list_(\d+)$/) { $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode $sth->{dbd_datahandle} = undef; } else { $sth->{dbd_dir} = $dir; my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; opendir($sym, $dir) or return $sth->set_err(2, "opendir($dir): $!"); $sth->{dbd_datahandle} = $sym; } $sth->STORE(Active => 1); return 1; } sub fetch { my $sth = shift; my $dir = $sth->{dbd_dir}; my %s; if (ref $dir) { # special fake-data test mode my $num = $dir->[0]--; unless ($num > 0) { $sth->finish(); return; } my $time = time; @s{@DBD::ExampleP::statnames} = ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, $time, $time, $time, 512, 2, "file$num") } else { # normal mode my $dh = $sth->{dbd_datahandle} or return $sth->set_err($DBI::stderr, "fetch without successful execute"); my $f = readdir($dh); unless ($f) { $sth->finish; return; } # untaint $f so that we can use this for DBI taint tests ($f) = ($f =~ m/^(.*)$/); my $file = File::Spec->catfile($dir, $f); # put in all the data fields @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); } # return just what fields the query asks for my @new = @s{ @{$sth->{NAME}} }; return $sth->_set_fbav(\@new); } *fetchrow_arrayref = \&fetch; sub finish { my $sth = shift; closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; $sth->{dbd_datahandle} = undef; $sth->{dbd_dir} = undef; $sth->SUPER::finish(); return 1; } sub FETCH { my ($sth, $attrib) = @_; # In reality this would interrogate the database engine to # either return dynamic values that cannot be precomputed # or fetch and cache attribute values too expensive to prefetch. if ($attrib eq 'TYPE'){ return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; } elsif ($attrib eq 'PRECISION'){ return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; } elsif ($attrib eq 'ParamValues') { my $dbd_param = $sth->{dbd_param} || []; my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; return \%pv; } # else pass up to DBI to handle return $sth->SUPER::FETCH($attrib); } sub STORE { my ($sth, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle return $sth->{$attrib} = $value if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; return $sth->SUPER::STORE($attrib, $value); } *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; } 1; # vim: sw=4:ts=8 DBI-1.652/lib/DBD/File.pm0000644000031300001440000012201315225415545013745 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # # DBD::File - A base class for implementing DBI drivers that # act on plain files # # This module is currently maintained by # # H.Merijn Brand & Jens Rehsack # # The original author is Jochen Wiedmann. # # Copyright (C) 2009-2026 by H.Merijn Brand & Jens Rehsack # Copyright (C) 2004 by Jeff Zucker # Copyright (C) 1998 by Jochen Wiedmann # # All rights reserved. # # You may distribute this module under the terms of either the GNU # General Public License or the Artistic License, as specified in # the Perl README file. require 5.012; use strict; use warnings; use DBI (); package DBD::File; use strict; use warnings; use base qw( DBI::DBD::SqlEngine ); use Carp; our $VERSION = "0.45"; our $drh = undef; # holds driver handle(s) once initialized sub driver ($;$) { my ($class, $attr) = @_; # Drivers typically use a singleton object for the $drh # We use a hash here to have one singleton per subclass. # (Otherwise DBD::CSV and DBD::DBM, for example, would # share the same driver object which would cause problems.) # An alternative would be to not cache the $drh here at all # and require that subclasses do that. Subclasses should do # their own caching, so caching here just provides extra safety. $drh->{$class} and return $drh->{$class}; $attr ||= {}; { no strict "refs"; unless ($attr->{Attribution}) { $class eq "DBD::File" and $attr->{Attribution} = "$class by Jeff Zucker"; $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} || "oops the author of $class forgot to define this"; } $attr->{Version} ||= ${$class . "::VERSION"}; $attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://; } $drh->{$class} = $class->SUPER::driver ($attr); # XXX inject DBD::XXX::Statement unless exists return $drh->{$class}; } # driver sub CLONE { undef $drh; } # CLONE # ====== DRIVER ================================================================ package DBD::File::dr; use strict; use warnings; use Carp; our @ISA = qw( DBI::DBD::SqlEngine::dr ); our $imp_data_size = 0; sub dsn_quote { my $str = shift; ref $str and return ""; defined $str or return ""; $str =~ s/([;:\\])/\\$1/g; return $str; } # dsn_quote # XXX rewrite using TableConfig ... sub default_table_source { "DBD::File::TableSource::FileSystem" } sub connect { my ($drh, $dbname, $user, $auth, $attr) = @_; # We do not (yet) care about conflicting attributes here # my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" }); # will test here that both test and text should exist # # Parsing on our own similar to parse_dsn to find attributes in 'dbname' parameter. if ($dbname) { my $attr_hash = { map { (m/^\s* (\S+) \s*(?: =>? | , )\s* (\S*) \s*$/x) } split m/;/ => $dbname }; if (defined $attr_hash->{f_dir}) { my $f_dir = $attr_hash->{f_dir}; # DSN escapes the : in Windows' path, which is not accepted by -d # D\\:\\\\Test\\\\DBI-01\\\\test_output_12345 # -> D:\\\\Test\\\\DBI-01\\\\test_output_12345 $^O eq "MSWin32" and $f_dir =~ s{^([a-zA-Z])\\+:}{$1:}; unless (-d $f_dir) { my $msg = "No such directory '$attr_hash->{f_dir}"; $drh->set_err (2, $msg); $attr_hash->{RaiseError} and croak $msg; return; } } } if ($attr and defined $attr->{f_dir}) { my $f_dir = $attr->{f_dir}; $^O eq "MSWin32" and $f_dir =~ s{^([a-zA-Z])\\+:}{$1:}; unless (-d $f_dir) { my $msg = "No such directory '$attr->{f_dir}"; $drh->set_err (2, $msg); return; } } return $drh->SUPER::connect ($dbname, $user, $auth, $attr); } # connect sub disconnect_all { } # disconnect_all sub DESTROY { undef; } # DESTROY # ====== DATABASE ============================================================== package DBD::File::db; use strict; use warnings; use Carp; require File::Spec; require Cwd; use Scalar::Util qw( refaddr ); # in CORE since 5.7.3 our @ISA = qw( DBI::DBD::SqlEngine::db ); our $imp_data_size = 0; sub data_sources { my ($dbh, $attr, @other) = @_; ref ($attr) eq "HASH" or $attr = {}; exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir}; exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search}; return $dbh->SUPER::data_sources ($attr, @other); } # data_source sub set_versions { my $dbh = shift; $dbh->{f_version} = $DBD::File::VERSION; return $dbh->SUPER::set_versions (); } # set_versions sub init_valid_attributes { my $dbh = shift; $dbh->{f_valid_attrs} = { f_version => 1, # DBD::File version f_dir => 1, # base directory f_dir_search => 1, # extended search directories f_ext => 1, # file extension f_schema => 1, # schema name f_lock => 1, # Table locking mode f_lockfile => 1, # Table lockfile extension f_encoding => 1, # Encoding of the file f_valid_attrs => 1, # File valid attributes f_readonly_attrs => 1, # File readonly attributes }; $dbh->{f_readonly_attrs} = { f_version => 1, # DBD::File version f_valid_attrs => 1, # File valid attributes f_readonly_attrs => 1, # File readonly attributes }; return $dbh->SUPER::init_valid_attributes (); } # init_valid_attributes sub init_default_attributes { my ($dbh, $phase) = @_; # must be done first, because setting flags implicitly calls $dbdname::db->STORE $dbh->SUPER::init_default_attributes ($phase); # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and # don't call twice unless (defined $phase) { # we have an "old" driver here $phase = defined $dbh->{sql_init_phase}; $phase and $phase = $dbh->{sql_init_phase}; } if (0 == $phase) { # f_ext should not be initialized # f_map is deprecated (but might return) $dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ()); push @{$dbh->{sql_init_order}{90}}, "f_meta"; # complete derived attributes, if required (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix ($drv_class); if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) { my $attr = $dbh->{$drv_prefix . "meta"}; defined $dbh->{f_valid_attrs}{f_meta} and $dbh->{f_valid_attrs}{f_meta} = 1; $dbh->{f_meta} = $dbh->{$attr}; } } return $dbh; } # init_default_attributes sub validate_FETCH_attr { my ($dbh, $attrib) = @_; $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta"; return $dbh->SUPER::validate_FETCH_attr ($attrib); } # validate_FETCH_attr sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; if ($attrib eq "f_dir" && defined $value) { -d $value or return $dbh->set_err ($DBI::stderr, "No such directory '$value'"); File::Spec->file_name_is_absolute ($value) or $value = Cwd::abs_path ($value); } if ($attrib eq "f_ext") { $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or carp "'$value' doesn't look like a valid file extension attribute\n"; } $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta"; return $dbh->SUPER::validate_STORE_attr ($attrib, $value); } # validate_STORE_attr sub get_f_versions { my ($dbh, $table) = @_; my $class = $dbh->{ImplementorClass}; $class =~ s/::db$/::Table/; my $dver; my $dtype = "IO::File"; eval { $dver = IO::File->VERSION (); # when we're still alive here, everything went ok - no need to check for $@ $dtype .= " ($dver)"; }; my $f_encoding; if ($table) { my $meta; $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); $meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding}; } # if ($table) $f_encoding ||= $dbh->{f_encoding}; $f_encoding and $dtype .= " + " . $f_encoding . " encoding"; return sprintf "%s using %s", $dbh->{f_version}, $dtype; } # get_f_versions # ====== STATEMENT ============================================================= package DBD::File::st; use strict; use warnings; our @ISA = qw( DBI::DBD::SqlEngine::st ); our $imp_data_size = 0; my %supported_attrs = ( TYPE => 1, PRECISION => 1, NULLABLE => 1, ); sub FETCH { my ($sth, $attr) = @_; if ($supported_attrs{$attr}) { my $stmt = $sth->{sql_stmt}; if (exists $sth->{ImplementorClass} && exists $sth->{sql_stmt} && $sth->{sql_stmt}->isa ("SQL::Statement")) { # fill overall_defs unless we know unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) { my $types = $sth->{Database}{Types}; unless ($types) { # Fetch types only once per database if (my $t = $sth->{Database}->type_info_all ()) { foreach my $i (1 .. $#$t) { $types->{uc $t->[$i][0]} = $t->[$i][1]; $types->{$t->[$i][1]} ||= uc $t->[$i][0]; } } # sane defaults for ([ 0, "" ], [ 1, "CHAR" ], [ 4, "INTEGER" ], [ 12, "VARCHAR" ], ) { $types->{$_->[0]} ||= $_->[1]; $types->{$_->[1]} ||= $_->[0]; } $sth->{Database}{Types} = $types; } my $all_meta = $sth->{Database}->func ("*", "table_defs", "get_sql_engine_meta"); foreach my $tbl (keys %$all_meta) { my $meta = $all_meta->{$tbl}; exists $meta->{table_defs} && ref $meta->{table_defs} or next; foreach (keys %{$meta->{table_defs}{columns}}) { my $field_info = $meta->{table_defs}{columns}{$_}; if (defined $field_info->{data_type} && $field_info->{data_type} !~ m/^[0-9]+$/) { $field_info->{type_name} = uc $field_info->{data_type}; $field_info->{data_type} = $types->{$field_info->{type_name}} || 0; } $field_info->{type_name} ||= $types->{$field_info->{data_type}} || "CHAR"; $sth->{f_overall_defs}{$_} = $field_info; } } } my @colnames = $sth->sql_get_colnames (); $attr eq "TYPE" and return [ map { $sth->{f_overall_defs}{$_}{data_type} || 12 } @colnames ]; $attr eq "TYPE_NAME" and return [ map { $sth->{f_overall_defs}{$_}{type_name} || "VARCHAR" } @colnames ]; $attr eq "PRECISION" and return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 } @colnames ]; $attr eq "NULLABLE" and return [ map { ( grep { $_ eq "NOT NULL" } @{ $sth->{f_overall_defs}{$_}{constraints} || [] }) ? 0 : 1 } @colnames ]; } } return $sth->SUPER::FETCH ($attr); } # FETCH # ====== TableSource =========================================================== package DBD::File::TableSource::FileSystem; use strict; use warnings; use IO::Dir; our @ISA = "DBI::DBD::SqlEngine::TableSource"; sub data_sources { my ($class, $drh, $attr) = @_; my $dir = $attr && exists $attr->{f_dir} ? $attr->{f_dir} : File::Spec->curdir (); defined $dir or return; # Stream-based databases do not have f_dir unless (-d $dir && -r $dir && -x $dir) { $drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir"); return; } my %attrs; $attr and %attrs = %$attr; delete $attrs{f_dir}; my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote"); my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs; my @dir = ($dir); $attr->{f_dir_search} && ref $attr->{f_dir_search} eq "ARRAY" and push @dir, grep { -d $_ } @{$attr->{f_dir_search}}; my @dsns; foreach $dir (@dir) { my $dirh = IO::Dir->new ($dir); unless (defined $dirh) { $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); return; } my ($file, %names, $driver); $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File"; while (defined ($file = $dirh->read ())) { my $d = File::Spec->catdir ($dir, $file); # allow current dir ... it can be a data_source too $file ne File::Spec->updir () && -d $d and push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : ""); } } return @dsns; } # data_sources sub avail_tables { my ($self, $dbh) = @_; my $dir = $dbh->{f_dir}; defined $dir or return; # Stream based db's cannot be queried for tables my %seen; my @tables; my @dir = ($dir); $dbh->{f_dir_search} && ref $dbh->{f_dir_search} eq "ARRAY" and push @dir, grep { -d $_ } @{$dbh->{f_dir_search}}; foreach $dir (@dir) { my $dirh = IO::Dir->new ($dir); unless (defined $dirh) { $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); return; } my $class = $dbh->FETCH ("ImplementorClass"); $class =~ s/::db$/::Table/; my ($file, %names); my $schema = exists $dbh->{f_schema} ? defined $dbh->{f_schema} && $dbh->{f_schema} ne "" ? $dbh->{f_schema} : undef : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent while (defined ($file = $dirh->read ())) { my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX # $tbl && $meta && -f $meta->{f_fqfn} or next; $seen{$schema // "\0"}{$dir}{$tbl}++ or push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ]; } $dirh->close () or $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!"); } return @tables; } # avail_tables # ====== DataSource ============================================================ package DBD::File::DataSource::Stream; use strict; use warnings; use Carp; our @ISA = "DBI::DBD::SqlEngine::DataSource"; # We may have a working flock () built-in but that doesn't mean that locking # will work on NFS (flock () may hang hard) my $locking = eval { my $fh; my $nulldevice = File::Spec->devnull (); open $fh, ">", $nulldevice or croak "Can't open $nulldevice: $!"; flock $fh, 0; close $fh; 1; }; sub complete_table_name { my ($self, $meta, $file, $respect_case) = @_; my $tbl = $file; if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER $tbl = uc $tbl; } elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER $tbl = lc $tbl; } $meta->{f_fqfn} = undef; $meta->{f_fqbn} = undef; $meta->{f_fqln} = undef; $meta->{table_name} = $tbl; return $tbl; } # complete_table_name sub apply_encoding { my ($self, $meta, $fn) = @_; $fn //= "file handle " . fileno ($meta->{fh}); if (my $enc = $meta->{f_encoding}) { binmode $meta->{fh}, ":encoding($enc)" or croak "Failed to set encoding layer '$enc' on $fn: $!"; } else { binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!"; } } # apply_encoding sub open_data { my ($self, $meta, $attrs, $flags) = @_; $flags->{dropMode} and croak "Can't drop a table in stream"; my $fn = "file handle " . fileno ($meta->{f_file}); if ($flags->{createMode} || $flags->{lockMode}) { $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; } else { $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or croak "Cannot open $fn for reading: $! (" . ($!+0) . ")"; } if ($meta->{fh}) { $self->apply_encoding ($meta, $fn); } # have $meta->{$fh} if ($self->can_flock && $meta->{fh}) { my $lm = defined $flags->{f_lock} && $flags->{f_lock} =~ m/^[012]$/ ? $flags->{f_lock} : $flags->{lockMode} ? 2 : 1; if ($lm == 2) { flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; } elsif ($lm == 1) { flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!"; } # $lm = 0 is forced no locking at all } } # open_data sub can_flock { $locking } package DBD::File::DataSource::File; use strict; use warnings; our @ISA = "DBD::File::DataSource::Stream"; use Carp; require List::Util; my $fn_any_ext_regex = qr/\.[^.]*/; sub complete_table_name { my ($self, $meta, $file, $respect_case, $file_is_table) = @_; $file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir # XXX now called without proving f_fqfn first ... my ($ext, $req) = ("", 0); if ($meta->{f_ext}) { ($ext, my $opt) = split m{/}, $meta->{f_ext}; if ($ext && $opt) { $opt =~ m/r/i and $req = 1; } } # (my $tbl = $file) =~ s/\Q$ext\E$//i; my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir); if ($file_is_table and defined $meta->{f_file}) { $tbl = $file; ($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex); $file = $basename . $fn_ext; $user_spec_file = 1; } else { ($basename, $dir, undef) = File::Basename::fileparse ($file, qr{\Q$ext\E}); # $dir is returned with trailing (back)slash. We just need to check # if it is ".", "./", or ".\" or "[]" (VMS) if ($dir =~ m{^(?:[.][/\\]?|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") { foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) { my $f = File::Spec->catdir ($d, $file); -f $f or next; $searchdir = Cwd::abs_path ($d); $dir = ""; last; } } $file = $tbl = $basename; $user_spec_file = 0; } if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER $basename = uc $basename; $tbl = uc $tbl; } elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER $basename = lc $basename; $tbl = lc $tbl; } unless (defined $searchdir) { $searchdir = File::Spec->file_name_is_absolute ($dir) ? ($dir =~ s{/$}{}, $dir) : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir)); } -d $searchdir or croak "-d $searchdir: $!"; # If the file location is outside the current folder, # its absolute path should be in ($f_dir, @f_dir_search) # Note this triggers only when *used*, not at definition time # $dbh->{csv_tables}{foo}{file} = "/out/side/scope/foo.csv"; # OK # $dbh->do ("create table foo (c char)"); # FAIL my @bases = map { Cwd::abs_path ($_) } $meta->{f_dir}, @{$meta->{f_dir_search} || []}; if ($searchdir) { my $sd = Cwd::abs_path ($searchdir); unless (List::Util::first { $_ eq $sd } @bases) { croak "Using data files in $searchdir is unsafe and not allowed.\nUse f_dir or f_dir_search.\n"; } } $searchdir eq $meta->{f_dir} and $dir = ""; unless ($user_spec_file) { $file_is_table and $file = "$basename$ext"; # Fully Qualified File Name my $cmpsub; if ($respect_case) { $cmpsub = sub { my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); $^O eq "VMS" && $sfx eq "." and $sfx = ""; # no extension turns up as a dot $fn eq $basename and return (lc $sfx eq lc $ext or !$req && !$sfx); return 0; } } else { $cmpsub = sub { my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); $^O eq "VMS" && $sfx eq "." and $sfx = ""; # no extension turns up as a dot lc $fn eq lc $basename and return (lc $sfx eq lc $ext or !$req && !$sfx); return 0; } } my @f; { my $dh = IO::Dir->new ($searchdir) or croak "Can't open '$searchdir': $!"; @f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } $dh->read (); $dh->close () or croak "Can't close '$searchdir': $!"; } @f > 0 && @f <= 2 and $file = $f[0]; !$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED ($tbl = $file) =~ s/\Q$ext\E$//i; my $tmpfn = $file; if ($ext && $req) { # File extension required $tmpfn =~ s/\Q$ext\E$//i or return; } } my $fqfn = File::Spec->catfile ($searchdir, $file); my $fqbn = File::Spec->catfile ($searchdir, $basename); $meta->{f_fqfn} = $fqfn; $meta->{f_fqbn} = $fqbn; defined $meta->{f_lockfile} && $meta->{f_lockfile} and $meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile}; $dir && !$user_spec_file and $tbl = File::Spec->catfile ($dir, $tbl); if (-l $fqfn) { my $real = Cwd::abs_path ($fqfn); unless (List::Util::any { $real =~ m{^\Q$_\E} } @bases) { croak "Data file $fqfn is a outside of f_dir f_and f_dir_search\n"; } } $meta->{table_name} = $tbl; return $tbl; } # complete_table_name sub open_data { my ($self, $meta, $attrs, $flags) = @_; defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename given"; my ($fh, $fn); unless ($meta->{f_dontopen}) { $fn = $meta->{f_fqfn}; if ($flags->{createMode}) { -f $meta->{f_fqfn} and croak "Cannot create table $attrs->{table}: Already exists"; $fh = IO::File->new ($fn, "a+") or croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; } else { unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { croak "Cannot open $fn: $! (" . ($!+0) . ")"; } } $meta->{fh} = $fh; if ($fh) { $fh->seek (0, 0) or croak "Error while seeking back: $!"; $self->apply_encoding ($meta); } } if ($meta->{f_fqln}) { $fn = $meta->{f_fqln}; if ($flags->{createMode}) { -f $fn and croak "Cannot create table lock at '$fn' for $attrs->{table}: Already exists"; $fh = IO::File->new ($fn, "a+") or croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; } else { unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { croak "Cannot open $fn: $! (" . ($!+0) . ")"; } } $meta->{lockfh} = $fh; } if ($self->can_flock && $fh) { my $lm = defined $flags->{f_lock} && $flags->{f_lock} =~ m/^[012]$/ ? $flags->{f_lock} : $flags->{lockMode} ? 2 : 1; if ($lm == 2) { flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; } elsif ($lm == 1) { flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!"; } # $lm = 0 is forced no locking at all } } # open_data # ====== SQL::STATEMENT ======================================================== package DBD::File::Statement; use strict; use warnings; our @ISA = qw( DBI::DBD::SqlEngine::Statement ); # ====== SQL::TABLE ============================================================ package DBD::File::Table; use strict; use warnings; use Carp; require IO::File; require File::Basename; require File::Spec; require Cwd; require Scalar::Util; our @ISA = qw( DBI::DBD::SqlEngine::Table ); # ====== UTILITIES ============================================================ if (eval { require Params::Util; }) { Params::Util->import ("_HANDLE"); } else { # taken but modified from Params::Util ... *_HANDLE = sub { # It has to be defined, of course defined $_[0] or return; # Normal globs are considered to be file handles ref $_[0] eq "GLOB" and return $_[0]; # Check for a normal tied filehandle # Side Note: 5.5.4's tied () and can () doesn't like getting undef tied ($_[0]) and tied ($_[0])->can ("TIEHANDLE") and return $_[0]; # There are no other non-object handles that we support Scalar::Util::blessed ($_[0]) or return; # Check for a common base classes for conventional IO::Handle object $_[0]->isa ("IO::Handle") and return $_[0]; # Check for tied file handles using Tie::Handle $_[0]->isa ("Tie::Handle") and return $_[0]; # IO::Scalar is not a proper seekable, but it is valid is a # regular file handle $_[0]->isa ("IO::Scalar") and return $_[0]; # Yet another special case for IO::String, which refuses (for now # anyway) to become a subclass of IO::Handle. $_[0]->isa ("IO::String") and return $_[0]; # This is not any sort of object we know about return; }; } # ====== FLYWEIGHT SUPPORT ===================================================== # Flyweight support for table_info # The functions file2table, init_table_meta, default_table_meta and # get_table_meta are using $self arguments for polymorphism only. The # must not rely on an instantiated DBD::File::Table sub file2table { my ($self, $meta, $file, $file_is_table, $respect_case) = @_; return $meta->{sql_data_source}->complete_table_name ($meta, $file, $respect_case, $file_is_table); } # file2table sub bootstrap_table_meta { my ($self, $dbh, $meta, $table, @other) = @_; $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other); exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir}; exists $meta->{f_dir_search} or $meta->{f_dir_search} = $dbh->{f_dir_search}; defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext}; defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding}; exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock}; exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile}; defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema}; defined $meta->{f_open_file_needed} or $meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file"); defined ($meta->{sql_data_source}) or $meta->{sql_data_source} = _HANDLE ($meta->{f_file}) ? "DBD::File::DataSource::Stream" : "DBD::File::DataSource::File"; } # bootstrap_table_meta sub get_table_meta ($$$$;$) { my ($self, $dbh, $table, $file_is_table, $respect_case) = @_; my $meta = $self->SUPER::get_table_meta ($dbh, $table, $respect_case, $file_is_table); $table = $meta->{table_name}; return unless $table; return ($table, $meta); } # get_table_meta my %reset_on_modify = ( f_file => [ "f_fqfn", "sql_data_source" ], f_dir => "f_fqfn", f_dir_search => [], f_ext => "f_fqfn", f_lockfile => "f_fqfn", # forces new file2table call ); __PACKAGE__->register_reset_on_modify (\%reset_on_modify); my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile ); __PACKAGE__->register_compat_map (\%compat_map); # ====== DBD::File <= 0.40 compat stuff ======================================== # compat to 0.38 .. 0.40 API sub open_file { my ($className, $meta, $attrs, $flags) = @_; return $className->SUPER::open_data ($meta, $attrs, $flags); } # open_file sub open_data { my ($className, $meta, $attrs, $flags) = @_; # compat to 0.38 .. 0.40 API $meta->{f_open_file_needed} ? $className->open_file ($meta, $attrs, $flags) : $className->SUPER::open_data ($meta, $attrs, $flags); return; } # open_data # ====== SQL::Eval API ========================================================= sub drop ($) { my ($self, $data) = @_; my $meta = $self->{meta}; # We have to close the file before unlinking it: Some OS'es will # refuse the unlink otherwise. $meta->{fh} and $meta->{fh}->close (); $meta->{lockfh} and $meta->{lockfh}->close (); undef $meta->{fh}; undef $meta->{lockfh}; $meta->{f_fqfn} and unlink $meta->{f_fqfn}; # XXX ==> sql_data_source $meta->{f_fqln} and unlink $meta->{f_fqln}; # XXX ==> sql_data_source delete $data->{Database}{sql_meta}{$self->{table}}; return 1; } # drop sub seek ($$$$) { my ($self, $data, $pos, $whence) = @_; my $meta = $self->{meta}; if ($whence == 0 && $pos == 0) { $pos = $meta->{first_row_pos} // 0; } elsif ($whence != 2 || $pos != 0) { croak "Illegal seek position: pos = $pos, whence = $whence"; } $meta->{fh}->seek ($pos, $whence) or croak "Error while seeking in " . $meta->{f_fqfn} . ": $!"; } # seek sub truncate ($$) { my ($self, $data) = @_; my $meta = $self->{meta}; $meta->{fh}->truncate ($meta->{fh}->tell ()) or croak "Error while truncating " . $meta->{f_fqfn} . ": $!"; return 1; } # truncate sub DESTROY { my $self = shift; my $meta = $self->{meta}; $meta->{fh} and $meta->{fh}->close (); $meta->{lockfh} and $meta->{lockfh}->close (); undef $meta->{fh}; undef $meta->{lockfh}; $self->SUPER::DESTROY(); } # DESTROY 1; __END__ =head1 NAME DBD::File - Base class for writing file based DBI drivers =head1 SYNOPSIS This module is a base class for writing other Ls. It is not intended to function as a DBD itself (though it is possible). If you want to access flat files, use L, or L (both of which are subclasses of DBD::File). =head1 DESCRIPTION The DBD::File module is not a true L driver, but an abstract base class for deriving concrete DBI drivers from it. The implication is, that these drivers work with plain files, for example CSV files or INI files. The module is based on the L module, a simple SQL engine. See L for details on DBI, L for details on SQL::Statement and L, L or L for example drivers. =head2 Metadata The following attributes are handled by DBI itself and not by DBD::File, thus they all work as expected: Active ActiveKids CachedKids CompatMode (Not used) InactiveDestroy AutoInactiveDestroy Kids PrintError RaiseError Warn (Not used) =head3 The following DBI attributes are handled by DBD::File: =head4 AutoCommit Always on. =head4 ChopBlanks Works. =head4 NUM_OF_FIELDS Valid after C<< $sth->execute >>. =head4 NUM_OF_PARAMS Valid after C<< $sth->prepare >>. =head4 NAME Valid after C<< $sth->execute >>; undef for Non-Select statements. =head4 NULLABLE Not really working, always returns an array ref of ones, except the affected table has been created in this session. Valid after C<< $sth->execute >>; undef for non-select statements. =head3 Unsupported DBI attributes and methods =over 2 =item bind_param_inout =item CursorName =item LongReadLen =item LongTruncOk =back =head3 DBD::File specific attributes In addition to the DBI attributes, you can use the following dbh attributes: =head4 f_dir This attribute is used for setting the directory where the files are opened and it defaults to the current directory (F<.>). Usually you set it on the dbh but it may be overridden per table (see L). When the value for C is a relative path, it is converted into the appropriate absolute path name (based on the current working directory) when the dbh attribute is set. f_dir => "/data/foo/csv", If C is set to a non-existing location, the connection will fail. See CVE-2014-10401 for reasoning. Because of this, folders to use cannot be created after the connection, but must exist before the connection is initiated. See L. =head4 f_dir_search This optional attribute can be set to pass a list of folders to also find existing tables. It will B be used to create new files. f_dir_search => [ "/data/bar/csv", "/dump/blargh/data" ], =head4 f_ext This attribute is used for setting the file extension. The format is: extension{/flag} where the /flag is optional and the extension is case-insensitive. C allows you to specify an extension which: f_ext => ".csv/r", =over =item * makes DBD::File prefer F over F. =item * makes the table name the filename minus the extension. =back DBI:CSV:f_dir=data;f_ext=.csv In the above example and when C contains both F and F
, DBD::File will open F and the table will be named "table". If F does not exist but F
does that file is opened and the table is also called "table". If C is not specified and F exists it will be opened and the table will be called "table.csv" which is probably not what you want. NOTE: even though extensions are case-insensitive, table names are not. DBI:CSV:f_dir=data;f_ext=.csv/r The C flag means the file extension is required and any filename that does not match the extension is ignored. Usually you set it on the dbh but it may be overridden per table (see L). =head4 f_schema This will set the schema name and defaults to the owner of the directory in which the table file resides. You can set C to C. my $dbh = DBI->connect ("dbi:CSV:", "", "", { f_schema => undef, f_dir => "data", f_ext => ".csv/r", }) or die $DBI::errstr; By setting the schema you affect the results from the tables call: my @tables = $dbh->tables (); # no f_schema "merijn".foo "merijn".bar # f_schema => "dbi" "dbi".foo "dbi".bar # f_schema => undef foo bar Defining C to the empty string is equal to setting it to C so the DSN can be C<"dbi:CSV:f_schema=;f_dir=.">. =head4 f_lock The C attribute is used to set the locking mode on the opened table files. Note that not all platforms support locking. By default, tables are opened with a shared lock for reading, and with an exclusive lock for writing. The supported modes are: 0: No locking at all. 1: Shared locks will be used. 2: Exclusive locks will be used. But see L below. =head4 f_lockfile If you wish to use a lockfile extension other than C<.lck>, simply specify the C attribute: $dbh = DBI->connect ("dbi:DBM:f_lockfile=.foo"); $dbh->{f_lockfile} = ".foo"; $dbh->{dbm_tables}{qux}{f_lockfile} = ".foo"; If you wish to disable locking, set the C to C<0>. $dbh = DBI->connect ("dbi:DBM:f_lockfile=0"); $dbh->{f_lockfile} = 0; $dbh->{dbm_tables}{qux}{f_lockfile} = 0; =head4 f_encoding With this attribute, you can set the encoding in which the file is opened. This is implemented using C<< binmode $fh, ":encoding()" >>. =head4 f_meta Private data area aliasing L which contains information about the tables this module handles. Table meta data might not be available until the table has been accessed for the first time e.g., by issuing a select on it however it is possible to pre-initialize attributes for each table you use. DBD::File recognizes the (public) attributes C, C, C, C, C, C, C, in addition to the attributes L already supports. Be very careful when modifying attributes you do not know, the consequence might be a destroyed or corrupted table. C is an attribute applicable to table meta data only and you will not find a corresponding attribute in the dbh. Whilst it may be reasonable to have several tables with the same column names, it is not for the same file name. If you need access to the same file using different table names, use C as the SQL engine and the C keyword: SELECT * FROM tbl AS t1, tbl AS t2 WHERE t1.id = t2.id C can be an absolute path name or a relative path name but if it is relative, it is interpreted as being relative to the C attribute of the table meta data. When C is set DBD::File will use C as specified and will not attempt to work out an alternative for C using the C
and C attribute. While C is a private and readonly attribute (which means, you cannot modify it's values), derived drivers might provide restricted write access through another attribute. Well known accessors are C for L, C for L and C for L. =head3 New opportunities for attributes from DBI::DBD::SqlEngine =head4 sql_table_source C<< $dbh->{sql_table_source} >> can be set to I (and is the default setting of DBD::File). This provides usual behaviour of previous DBD::File releases on @ary = DBI->data_sources ($driver); @ary = DBI->data_sources ($driver, \%attr); @ary = $dbh->data_sources (); @ary = $dbh->data_sources (\%attr); @names = $dbh->tables ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr); $dbh->func ("list_tables"); =head4 sql_data_source C<< $dbh->{sql_data_source} >> can be set to either I, which is default and provides the well known behavior of DBD::File releases prior to 0.41, or I, which reuses already opened file-handle for operations. =head3 Internally private attributes to deal with SQL backends Do not modify any of these private attributes unless you understand the implications of doing so. The behavior of DBD::File and derived DBDs might be unpredictable when one or more of those attributes are modified. =head4 sql_nano_version Contains the version of loaded DBI::SQL::Nano. =head4 sql_statement_version Contains the version of loaded SQL::Statement. =head4 sql_handler Contains either the text 'SQL::Statement' or 'DBI::SQL::Nano'. =head4 sql_ram_tables Contains optionally temporary tables. =head4 sql_flags Contains optional flags to instantiate the SQL::Parser parsing engine when SQL::Statement is used as SQL engine. See L for valid flags. =head2 Driver private methods =head3 Default DBI methods =head4 data_sources The C method returns a list of subdirectories of the current directory in the form "dbi:CSV:f_dir=$dirname". If you want to read the subdirectories of another directory, use my ($drh) = DBI->install_driver ("CSV"); my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data"); =head3 Additional methods The following methods are only available via their documented name when DBD::File is used directly. Because this is only reasonable for testing purposes, the real names must be used instead. Those names can be computed by replacing the C in the method name with the driver prefix. =head4 f_versions Signature: sub f_versions (;$) { my ($table_name) = @_; $table_name ||= "."; ... } Returns the versions of the driver, including the DBI version, the Perl version, DBI::PurePerl version (if DBI::PurePerl is active) and the version of the SQL engine in use. my $dbh = DBI->connect ("dbi:File:"); my $f_versions = $dbh->func ("f_versions"); print "$f_versions\n"; __END__ # DBD::File 0.41 using IO::File (1.16) # DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.406 # DBI 1.623 # OS darwin (12.2.1) # Perl 5.017006 (darwin-thread-multi-ld-2level) Called in list context, f_versions will return an array containing each line as single entry. Some drivers might use the optional (table name) argument and modify version information related to the table (e.g. DBD::DBM provides storage backend information for the requested table, when it has a table name). =head1 KNOWN BUGS AND LIMITATIONS =over 4 =item * This module uses flock () internally but flock is not available on all platforms. On MacOS and Windows 95 there is no locking at all (perhaps not so important on MacOS and Windows 95, as there is only a single user). =item * The module stores details about the handled tables in a private area of the driver handle (C<$drh>). This data area is not shared between different driver instances, so several C<< DBI->connect () >> calls will cause different table instances and private data areas. This data area is filled for the first time when a table is accessed, either via an SQL statement or via C and is not destroyed until the table is dropped or the driver handle is released. Manual destruction is possible via L. The following attributes are preserved in the data area and will evaluated instead of driver globals: =over 8 =item f_ext =item f_dir =item f_dir_search =item f_lock =item f_lockfile =item f_encoding =item f_schema =item col_names =item sql_identifier_case =back The following attributes are preserved in the data area only and cannot be set globally. =over 8 =item f_file =back The following attributes are preserved in the data area only and are computed when initializing the data area: =over 8 =item f_fqfn =item f_fqbn =item f_fqln =item table_name =back For DBD::CSV tables this means, once opened "foo.csv" as table named "foo", another table named "foo" accessing the file "foo.txt" cannot be opened. Accessing "foo" will always access the file "foo.csv" in memorized C, locking C via memorized C. You can use L or the C attribute for a specific table to work around this. =item * When used with SQL::Statement and temporary tables e.g., CREATE TEMP TABLE ... the table data processing bypasses DBD::File::Table. No file system calls will be made and there are no clashes with existing (file based) tables with the same name. Temporary tables are chosen over file tables, but they will not covered by C. =back =head1 AUTHOR This module is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > The original author is Jochen Wiedmann. =head1 COPYRIGHT AND LICENSE Copyright (C) 2009-2026 by H.Merijn Brand & Jens Rehsack Copyright (C) 2004-2009 by Jeff Zucker Copyright (C) 1998-2004 by Jochen Wiedmann All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L, L, L, L, L, L, and L =cut DBI-1.652/lib/DBD/Gofer/0000755000031300001440000000000015240046615013566 5ustar00merijnusersDBI-1.652/lib/DBD/Gofer/Transport/0000755000031300001440000000000015240046615015562 5ustar00merijnusersDBI-1.652/lib/DBD/Gofer/Transport/null.pm0000644000031300001440000000532212153147453017076 0ustar00merijnuserspackage DBD::Gofer::Transport::null; # $Id: null.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use base qw(DBD::Gofer::Transport::Base); use DBI::Gofer::Execute; our $VERSION = "0.010088"; __PACKAGE__->mk_accessors(qw( pending_response transmit_count )); my $executor = DBI::Gofer::Execute->new(); sub transmit_request_by_transport { my ($self, $request) = @_; $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests my $frozen_request = $self->freeze_request($request); # ... # the request is magically transported over to ... ourselves # ... my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) ); # put response 'on the shelf' ready for receive_response() $self->pending_response( $response ); return undef; } sub receive_response_by_transport { my $self = shift; my $response = $self->pending_response; my $frozen_response = $self->freeze_response($response, undef, 1); # ... # the response is magically transported back to ... ourselves # ... return $self->thaw_response($frozen_response); } 1; __END__ =head1 NAME DBD::Gofer::Transport::null - DBD::Gofer client transport for testing =head1 SYNOPSIS my $original_dsn = "..." DBI->connect("dbi:Gofer:transport=null;dsn=$original_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY="dbi:Gofer:transport=null" =head1 DESCRIPTION Connect via DBD::Gofer but execute the requests within the same process. This is a quick and simple way to test applications for compatibility with the (few) restrictions that DBD::Gofer imposes. It also provides a simple, portable way for the DBI test suite to be used to test DBD::Gofer on all platforms with no setup. Also, by measuring the difference in performance between normal connections and connections via C the basic cost of using DBD::Gofer can be measured. Furthermore, the additional cost of more advanced transports can be isolated by comparing their performance with the null transport. The C script in the DBI distribution includes a comparative benchmark. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut DBI-1.652/lib/DBD/Gofer/Transport/stream.pm0000644000031300001440000002201215225414620017406 0ustar00merijnuserspackage DBD::Gofer::Transport::stream; # $Id: stream.pm 14598 2010-12-21 22:53:25Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; use base qw(DBD::Gofer::Transport::pipeone); our $VERSION = "0.014599"; __PACKAGE__->mk_accessors(qw( go_persist )); my $persist_all = 5; my %persist; sub _connection_key { my ($self) = @_; return join "~", $self->go_url||"", @{ $self->go_perl || [] }; } sub _connection_get { my ($self) = @_; my $persist = $self->go_persist; # = 0 can force non-caching $persist //= $persist_all; my $key = ($persist) ? $self->_connection_key : ''; if ($persist{$key} && $self->_connection_check($persist{$key})) { $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1; return $persist{$key}; } my $connection = $self->_make_connection; if ($key) { %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses $persist{$key} = $connection; } return $connection; } sub _connection_check { my ($self, $connection) = @_; $connection ||= $self->connection_info; my $pid = $connection->{pid}; my $ok = (kill 0, $pid); $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace; return $ok; } sub _connection_kill { my ($self) = @_; my $connection = $self->connection_info; my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)}; $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace; # closing the write file handle should be enough, generally close $wfh; # in future we may want to be more aggressive #close $rfh; close $efh; kill 15, $pid # but deleting from the persist cache... delete $persist{ $self->_connection_key }; # ... and removing the connection_info should suffice $self->connection_info( undef ); return; } sub _make_connection { my ($self) = @_; my $go_perl = $self->go_perl; my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)]; #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c"; if (my $url = $self->go_url) { die "Only 'ssh:user\@host' style url supported by this transport" unless $url =~ s/^ssh://; my $ssh = $url; my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile); my $setup = $setup_env.q{; exec "$@"}; # don't use $^X on remote system by default as it's possibly wrong $cmd->[0] = 'perl' if "@$go_perl" eq $^X; # -x not only 'Disables X11 forwarding' but also makes connections *much* faster unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup; } $self->trace_msg("new connection: @$cmd\n",0) if $self->trace; # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's # sent as soon as it starts that we can wait for to report success - and soak up # and report useful warnings etc from ssh before we get it? Increases latency though. my $connection = $self->start_pipe_command($cmd); return $connection; } sub transmit_request_by_transport { my ($self, $request) = @_; my $trace = $self->trace; my $connection = $self->connection_info || do { my $con = $self->_connection_get; $self->connection_info( $con ); $con; }; my $encoded_request = unpack("H*", $self->freeze_request($request)); $encoded_request .= "\015\012"; my $wfh = $connection->{wfh}; $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0) if $trace >= 4; # send frozen request local $\; $wfh->print($encoded_request) # autoflush enabled or do { my $err = $!; # XXX could/should make new connection and retry $self->_connection_kill; die "Error sending request: $err"; }; $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4; return undef; # indicate no response yet (so caller calls receive_response_by_transport) } sub receive_response_by_transport { my $self = shift; my $trace = $self->trace; $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4; my $connection = $self->connection_info || die; my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)}; my $errno = 0; my $encoded_response; my $stderr_msg; $self->read_response_from_fh( { $efh => { error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 }, eof => sub { warn "eof reading efh" if $trace >= 4; 1 }, read => sub { $stderr_msg .= $_; 0 }, }, $rfh => { error => sub { warn "error reading response: $!"; $errno||=$!; 1 }, eof => sub { warn "eof reading rfh" if $trace >= 4; 1 }, read => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 }, }, }); # if we got no output on stdout at all then the command has # probably exited, possibly with an error to stderr. # Turn this situation into a reasonably useful DBI error. if (not $encoded_response) { my @msg; push @msg, "error while reading response: $errno" if $errno; if ($stderr_msg) { chomp $stderr_msg; push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s", $self->cmd_as_string, $pid, ((kill 0, $pid) ? "" : ", exited"), $stderr_msg; } die join(", ", "No response received", @msg)."\n"; } $self->trace_msg("Response received: $encoded_response\n",0) if $trace >= 4; $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0) if $stderr_msg && $trace; my $frozen_response = pack("H*", $encoded_response); # XXX need to be able to detect and deal with corruption my $response = $self->thaw_response($frozen_response); if ($stderr_msg) { # add stderr messages as warnings (for PrintWarn) $response->add_err(0, $stderr_msg, undef, $trace) # but ignore warning from old version of blib unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; } return $response; } sub transport_timedout { my $self = shift; $self->_connection_kill; return $self->SUPER::transport_timedout(@_); } 1; __END__ =head1 NAME DBD::Gofer::Transport::stream - DBD::Gofer transport for stdio streaming =head1 SYNOPSIS DBI->connect('dbi:Gofer:transport=stream;url=ssh:username@host.example.com;dsn=dbi:...',...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY='dbi:Gofer:transport=stream;url=ssh:username@host.example.com' =head1 DESCRIPTION Without the C parameter it launches a subprocess as perl -MDBI::Gofer::Transport::stream -e run_stdio_hex and feeds requests into it and reads responses from it. But that's not very useful. With a C parameter it uses ssh to launch the subprocess on a remote system. That's much more useful! It gives you secure remote access to DBI databases on any system you can login to. Using ssh also gives you optional compression and many other features (see the ssh manual for how to configure that and many other options via ~/.ssh/config file). The actual command invoked is something like: ssh -xq ssh:username@host.example.com bash -c $setup $run where $run is the command shown above, and $command is . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile 2>/dev/null; exec "$@" which is trying (in a limited and fairly unportable way) to setup the environment (PATH, PERL5LIB etc) as it would be if you had logged in to that system. The "C" used in the command will default to the value of $^X when not using ssh. On most systems that's the full path to the perl that's currently executing. =head1 PERSISTENCE Currently gofer stream connections persist (remain connected) after all database handles have been disconnected. This makes later connections in the same process very fast. Currently up to 5 different gofer stream connections (based on url) can persist. If more than 5 are in the cache when a new connection is made then the cache is cleared before adding the new connection. Simple but effective. =head1 TO DO Document go_perl attribute Automatically reconnect (within reason) if there's a transport error. Decide on default for persistent connection - on or off? limits? ttl? =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut DBI-1.652/lib/DBD/Gofer/Transport/Base.pm0000644000031300001440000003070215225414662017000 0ustar00merijnuserspackage DBD::Gofer::Transport::Base; # $Id: Base.pm 14120 2010-06-07 19:52:19Z H.Merijn $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use base qw(DBI::Gofer::Transport::Base); our $VERSION = "0.014121"; __PACKAGE__->mk_accessors(qw( trace go_dsn go_url go_policy go_timeout go_retry_hook go_retry_limit go_cache cache_hit cache_miss cache_store )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($class, $args) = @_; $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; #warn "args @{[ %$args ]}\n"; return $class->SUPER::new($args); } sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } sub new_response { my $self = shift; return DBI::Gofer::Response->new(@_); } sub transmit_request { my ($self, $request) = @_; my $trace = $self->trace; my $response; my ($go_cache, $request_cache_key); if ($go_cache = $self->{go_cache}) { $request_cache_key = $request->{meta}{request_cache_key} = $self->get_cache_key_for_request($request); if ($request_cache_key) { my $frozen_response = eval { $go_cache->get($request_cache_key) }; if ($frozen_response) { $self->_dump("cached response found for ".ref($request), $request) if $trace; $response = $self->thaw_response($frozen_response); $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") if $trace; ++$self->{cache_hit}; return $response; } warn $@ if $@; ++$self->{cache_miss}; $self->trace_msg("transmit_request cache miss\n") if $trace; } } my $to = $self->go_timeout; my $transmit_sub = sub { $self->trace_msg("transmit_request\n") if $trace; local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { local $SIG{PIPE} = sub { my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; die "Unable to send request: Broken pipe$extra\n"; }; alarm($to) if $to; $self->transmit_request_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("transmit_request", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; $response = $self->_transmit_request_with_retries($request, $transmit_sub); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key; } $self->trace_msg("transmit_request is returning a response itself\n") if $trace && $response; return $response unless wantarray; return ($response, $transmit_sub); } sub _transmit_request_with_retries { my ($self, $request, $transmit_sub) = @_; my $response; do { $response = $transmit_sub->(); } while ( $response && $self->response_needs_retransmit($request, $response) ); return $response; } sub receive_response { my ($self, $request, $retransmit_sub) = @_; my $to = $self->go_timeout; my $receive_sub = sub { $self->trace_msg("receive_response\n"); local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { alarm($to) if $to; $self->receive_response_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("receive_response", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; my $response; do { $response = $receive_sub->(); if ($self->response_needs_retransmit($request, $response)) { $response = $self->_transmit_request_with_retries($request, $retransmit_sub); $response ||= $receive_sub->(); } } while ( $self->response_needs_retransmit($request, $response) ); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; my $request_cache_key = $request->{meta}{request_cache_key}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key && $self->{go_cache}; } return $response; } sub response_retry_preference { my ($self, $request, $response) = @_; # give the user a chance to express a preference (or undef for default) if (my $go_retry_hook = $self->go_retry_hook) { my $retry = $go_retry_hook->($request, $response, $self); $self->trace_msg(sprintf "go_retry_hook returned %s\n", $retry // 'undef'); return $retry if defined $retry; } # This is the main decision point. We don't retry requests that got # as far as executing because the error is probably from the database # (not transport) so retrying is unlikely to help. But note that any # severe transport error occurring after execute is likely to return # a new response object that doesn't have the execute flag set. Beware! return 0 if $response->executed_flag_set; return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set return undef; # we couldn't make up our mind } sub response_needs_retransmit { my ($self, $request, $response) = @_; my $err = $response->err or return 0; # nothing went wrong my $retry = $self->response_retry_preference($request, $response); if (!$retry) { # false or undef $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); return 0; } # we'd like to retry but have we retried too much already? my $retry_limit = $self->go_retry_limit; if (!$retry_limit) { $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); return 0; } my $request_meta = $request->meta; my $retry_count = $request_meta->{retry_count} || 0; if ($retry_count >= $retry_limit) { $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); # XXX should be possible to disable altering the err $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); return 0; } # will retry now, do the admin ++$retry_count; $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); # hook so response_retry_preference can defer some code execution # until we've checked retry_count and retry_limit. if (ref $retry eq 'CODE') { $retry->($retry_count, $retry_limit) and warn "should return false"; # protect future use } ++$request_meta->{retry_count}; # update count for this request object ++$self->meta->{request_retry_count}; # update cumulative transport stats return 1; } sub transport_timedout { my ($self, $method, $timeout) = @_; $timeout ||= $self->go_timeout; return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); } # return undef if we don't want to cache this request # subclasses may use more specialized rules sub get_cache_key_for_request { my ($self, $request) = @_; # we only want to cache idempotent requests # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set return undef if not $request->is_idempotent; # XXX would be nice to avoid the extra freeze here my $key = $self->freeze_request($request, undef, 1); #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; return $key; } sub _store_response_in_cache { my ($self, $frozen_response, $request_cache_key) = @_; my $go_cache = $self->{go_cache} or return; # new() ensures that enabling go_cache also enables keep_meta_frozen warn "No meta frozen in response" if !$frozen_response; warn "No request_cache_key" if !$request_cache_key; if ($frozen_response && $request_cache_key) { $self->trace_msg("receive_response added response to cache $go_cache\n"); eval { $go_cache->set($request_cache_key, $frozen_response) }; warn $@ if $@; ++$self->{cache_store}; } } 1; __END__ =head1 NAME DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports =head1 SYNOPSIS my $remote_dsn = "..." DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...' which will force I DBI connections to be made via that Gofer server. =head1 DESCRIPTION This is the base class for all DBD::Gofer client transports. =head1 ATTRIBUTES Gofer transport attributes can be specified either in the attributes parameter of the connect() method call, or in the DSN string. When used in the DSN string, attribute names don't have the C prefix. =head2 go_dsn The full DBI DSN that the Gofer server should connect to on your behalf. When used in the DSN it must be the last element in the DSN string. =head2 go_timeout A time limit for sending a request and receiving a response. Some drivers may implement sending and receiving as separate steps, in which case (currently) the timeout applies to each separately. If a request needs to be resent then the timeout is restarted for each sending of a request and receiving of a response. =head2 go_retry_limit The maximum number of times an request may be retried. The default is 2. =head2 go_retry_hook This subroutine reference is called, if defined, for each response received where $response->err is true. The subroutine is pass three parameters: the request object, the response object, and the transport object. If it returns an undefined value then the default retry behaviour is used. See L below. If it returns a defined but false value then the request is not resent. If it returns true value then the request is resent, so long as the number of retries does not exceed C. =head1 RETRY ON ERROR The default retry on error behaviour is: - Retry if the error was due to DBI_GOFER_RANDOM. See L. - Retry if $request->is_idempotent returns true. See L. A retry won't be allowed if the number of previous retries has reached C. =head1 TRACING Tracing of gofer requests and responses can be enabled by setting the C environment variable. A value of 1 gives a reasonably compact summary of each request and response. A value of 2 or more gives a detailed, and voluminous, dump. The trace is written using DBI->trace_msg() and so is written to the default DBI trace output, which is usually STDERR. =head1 METHODS I =head2 response_retry_preference $retry = $transport->response_retry_preference($request, $response); The response_retry_preference is called by DBD::Gofer when considering if a request should be retried after an error. Returns true (would like to retry), false (must not retry), undef (no preference). If a true value is returned in the form of a CODE ref then, if DBD::Gofer does decide to retry the request, it calls the code ref passing $retry_count, $retry_limit. Can be used for logging and/or to implement exponential back-off behaviour. Currently the called code must return using C to allow for future extensions. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L, L, L, L. and some example transports: L L L =cut DBI-1.652/lib/DBD/Gofer/Transport/corostream.pm0000644000031300001440000000643412127465144020310 0ustar00merijnuserspackage DBD::Gofer::Transport::corostream; use strict; use warnings; use Carp; use Coro::Select; # a slow but coro-aware replacement for CORE::select (global effect!) use Coro; use Coro::Handle; use base qw(DBD::Gofer::Transport::stream); # XXX ensure DBI_PUREPERL for parent doesn't pass to child sub start_pipe_command { local $ENV{DBI_PUREPERL} = $ENV{DBI_PUREPERL_COROCHILD}; # typically undef my $connection = shift->SUPER::start_pipe_command(@_); return $connection; } 1; __END__ =head1 NAME DBD::Gofer::Transport::corostream - Async DBD::Gofer stream transport using Coro and AnyEvent =head1 SYNOPSIS DBI_AUTOPROXY="dbi:Gofer:transport=corostream" perl some-perl-script-using-dbi.pl or $dsn = ...; # the DSN for the driver and database you want to use $dbh = DBI->connect("dbi:Gofer:transport=corostream;dsn=$dsn", ...); =head1 DESCRIPTION The I from using L is that it enables the use of existing DBI frameworks like L. =head1 KNOWN ISSUES AND LIMITATIONS - Uses Coro::Select so alters CORE::select globally Parent class probably needs refactoring to enable a more encapsulated approach. - Doesn't prevent multiple concurrent requests Probably just needs a per-connection semaphore - Coro has many caveats. Caveat emptor. =head1 STATUS THIS IS CURRENTLY JUST A PROOF-OF-CONCEPT IMPLEMENTATION FOR EXPERIMENTATION. Please note that I have no plans to develop this code further myself. I'd very much welcome contributions. Interested? Let me know! =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2010, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =head1 APPENDIX Example code: #!perl use strict; use warnings; use Time::HiRes qw(time); BEGIN { $ENV{PERL_ANYEVENT_STRICT} = 1; $ENV{PERL_ANYEVENT_VERBOSE} = 1; } use AnyEvent; BEGIN { $ENV{DBI_TRACE} = 0; $ENV{DBI_GOFER_TRACE} = 0; $ENV{DBD_GOFER_TRACE} = 0; }; use DBI; $ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=corostream'; my $ticker = AnyEvent->timer( after => 0, interval => 0.1, cb => sub { warn sprintf "-tick- %.2f\n", time } ); warn "connecting...\n"; my $dbh = DBI->connect("dbi:NullP:"); warn "...connected\n"; for (1..3) { warn "entering DBI...\n"; $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver warn "...returned\n"; } warn "done."; Example output: $ perl corogofer.pl connecting... -tick- 1293631437.14 -tick- 1293631437.14 ...connected entering DBI... -tick- 1293631437.25 -tick- 1293631437.35 -tick- 1293631437.45 -tick- 1293631437.55 ...returned entering DBI... -tick- 1293631437.66 -tick- 1293631437.76 -tick- 1293631437.86 ...returned entering DBI... -tick- 1293631437.96 -tick- 1293631438.06 -tick- 1293631438.16 ...returned done. at corogofer.pl line 39. You can see that the timer callback is firing while the code 'waits' inside the do() method for the response from the database. Normally that would block. =cut DBI-1.652/lib/DBD/Gofer/Transport/pipeone.pm0000644000031300001440000001620314742423677017576 0ustar00merijnuserspackage DBD::Gofer::Transport::pipeone; # $Id: pipeone.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; use Fcntl; use IO::Select; use IPC::Open3 qw(open3); use Symbol qw(gensym); use base qw(DBD::Gofer::Transport::Base); our $VERSION = "0.010088"; __PACKAGE__->mk_accessors(qw( connection_info go_perl )); sub new { my ($self, $args) = @_; $args->{go_perl} ||= do { ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ]; }; if (not ref $args->{go_perl}) { # user can override the perl to be used, either with an array ref # containing the command name and args to use, or with a string # (ie via the DSN) in which case, to enable args to be passed, # we split on two or more consecutive spaces (otherwise the path # to perl couldn't contain a space itself). $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ]; } return $self->SUPER::new($args); } # nonblock($fh) puts filehandle into nonblocking mode sub nonblock { my $fh = shift; my $flags = fcntl($fh, F_GETFL, 0) or croak "Can't get flags for filehandle $fh: $!"; fcntl($fh, F_SETFL, $flags | O_NONBLOCK) or croak "Can't make filehandle $fh nonblocking: $!"; } sub start_pipe_command { my ($self, $cmd) = @_; $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY'; # if it's important that the subprocess uses the same # (versions of) modules as us then the caller should # set PERL5LIB itself. # limit various forms of insanity, for now local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead local $ENV{DBI_AUTOPROXY}; local $ENV{DBI_PROFILE}; my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); my $pid = open3($wfh, $rfh, $efh, @$cmd) or die "error starting @$cmd: $!\n"; if ($self->trace) { $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0); } nonblock($rfh); nonblock($efh); my $ios = IO::Select->new($rfh, $efh); return { cmd=>$cmd, pid=>$pid, wfh=>$wfh, rfh=>$rfh, efh=>$efh, ios=>$ios, }; } sub cmd_as_string { my $self = shift; # XXX meant to return a properly shell-escaped string suitable for system # but its only for debugging so that can wait my $connection_info = $self->connection_info; return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}}; } sub transmit_request_by_transport { my ($self, $request) = @_; my $frozen_request = $self->freeze_request($request); my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)]; my $info = $self->start_pipe_command($cmd); my $wfh = delete $info->{wfh}; # send frozen request local $\; print $wfh $frozen_request or warn "error writing to @$cmd: $!\n"; # indicate that there's no more close $wfh or die "error closing pipe to @$cmd: $!\n"; $self->connection_info( $info ); return; } sub read_response_from_fh { my ($self, $fh_actions) = @_; my $trace = $self->trace; my $info = $self->connection_info || die; my ($ios) = @{$info}{qw(ios)}; my $errors = 0; my $complete; die "No handles to read response from" unless $ios->count; while ($ios->count) { my @readable = $ios->can_read(); for my $fh (@readable) { local $_; my $actions = $fh_actions->{$fh} || die "panic: no action for $fh"; my $rv = sysread($fh, $_='', 1024*31); # to fit in 32KB slab unless ($rv) { # error (undef) or end of file (0) my $action; unless (defined $rv) { # was an error $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4; $action = $actions->{error} || $actions->{eof}; ++$errors; # XXX an error may be a permenent condition of the handle # if so we'll loop here - not good } else { $action = $actions->{eof}; $self->trace_msg("eof on handle $fh\n") if $trace >= 4; } if ($action->($fh)) { $self->trace_msg("removing $fh from handle set\n") if $trace >= 4; $ios->remove($fh); } next; } # action returns true if the response is now complete # (we finish all handles $actions->{read}->($fh) && ++$complete; } last if $complete; } return $errors; } sub receive_response_by_transport { my $self = shift; my $info = $self->connection_info || die; my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)}; my $frozen_response; my $stderr_msg; $self->read_response_from_fh( { $efh => { error => sub { warn "error reading response stderr: $!"; 1 }, eof => sub { warn "eof on stderr" if 0; 1 }, read => sub { $stderr_msg .= $_; 0 }, }, $rfh => { error => sub { warn "error reading response: $!"; 1 }, eof => sub { warn "eof on stdout" if 0; 1 }, read => sub { $frozen_response .= $_; 0 }, }, }); waitpid $info->{pid}, 0 or warn "waitpid: $!"; # XXX do something more useful? die ref($self)." command (@$cmd) failed: $stderr_msg" if not $frozen_response; # no output on stdout at all # XXX need to be able to detect and deal with corruption my $response = $self->thaw_response($frozen_response); if ($stderr_msg) { # add stderr messages as warnings (for PrintWarn) $response->add_err(0, $stderr_msg, undef, $self->trace) # but ignore warning from old version of blib unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; } return $response; } 1; __END__ =head1 NAME DBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing =head1 SYNOPSIS $original_dsn = "..."; DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone" =head1 DESCRIPTION Connect via DBD::Gofer and execute each request by starting executing a subprocess. This is, as you might imagine, spectacularly inefficient! It's only intended for testing. Specifically it demonstrates that the server side is completely stateless. It also provides a base class for the much more useful L transport. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut DBI-1.652/lib/DBD/Gofer/Policy/0000755000031300001440000000000015240046615015025 5ustar00merijnusersDBI-1.652/lib/DBD/Gofer/Policy/pedantic.pm0000644000031300001440000000263312153146731017156 0ustar00merijnuserspackage DBD::Gofer::Policy::pedantic; # $Id: pedantic.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); # the 'pedantic' policy is the same as the Base policy 1; =head1 NAME DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...) =head1 DESCRIPTION The C policy tries to be as transparent as possible. To do this it makes round-trips to the server for almost every DBI method call. This is the best policy to use when first testing existing code with Gofer. Once it's working well you should consider moving to the C policy or defining your own policy class. Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBD/Gofer/Policy/rush.pm0000644000031300001440000000504514742423677016365 0ustar00merijnuserspackage DBD::Gofer::Policy::rush; # $Id: rush.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); __PACKAGE__->create_policy_subs({ # always use connect_cached on server connect_method => 'connect_cached', # use same methods on server as is called on client # (because code not using placeholders would bloat the sth cache) prepare_method => '', # Skipping the connect check is fast, but it also skips # fetching the remote dbh attributes! # Make sure that your application doesn't need access to dbh attributes. skip_connect_check => 1, # most code doesn't rely on sth attributes being set after prepare skip_prepare_check => 1, # we're happy to use local method if that's the same as the remote skip_default_methods => 1, # ping is almost meaningless for DBD::Gofer and most transports anyway skip_ping => 1, # don't update dbh attributes at all # XXX actually we currently need dbh_attribute_update for skip_default_methods to work # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update dbh_attribute_update => 'none', # actually means 'first' currently #dbh_attribute_list => undef, # we'd like to set locally_* but can't because drivers differ # in a rush assume metadata doesn't change cache_tables => 1, cache_table_info => 1, cache_column_info => 1, cache_primary_key_info => 1, cache_foreign_key_info => 1, cache_statistics_info => 1, cache_get_info => 1, }); 1; =head1 NAME DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...) =head1 DESCRIPTION The C policy tries to make as few round-trips as possible. It's the opposite end of the policy spectrum to the C policy. Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBD/Gofer/Policy/classic.pm0000644000031300001440000000407214742423677017024 0ustar00merijnuserspackage DBD::Gofer::Policy::classic; # $Id: classic.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); __PACKAGE__->create_policy_subs({ # always use connect_cached on server connect_method => 'connect_cached', # use same methods on server as is called on client prepare_method => '', # don't skip the connect check since that also sets dbh attributes # although this makes connect more expensive, that's partly offset # by skip_ping=>1 below, which makes connect_cached very fast. skip_connect_check => 0, # most code doesn't rely on sth attributes being set after prepare skip_prepare_check => 1, # we're happy to use local method if that's the same as the remote skip_default_methods => 1, # ping is not important for DBD::Gofer and most transports skip_ping => 1, # only update dbh attributes on first contact with server dbh_attribute_update => 'first', # we'd like to set locally_* but can't because drivers differ # get_info results usually don't change cache_get_info => 1, }); 1; =head1 NAME DBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...) The C policy is the default DBD::Gofer policy, so need not be included in the DSN. =head1 DESCRIPTION Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBD/Gofer/Policy/Base.pm0000644000031300001440000001174014656646601016253 0ustar00merijnuserspackage DBD::Gofer::Policy::Base; # $Id: Base.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; our $VERSION = "0.010088"; our $AUTOLOAD; my %policy_defaults = ( # force connect method (unless overridden by go_connect_method=>'...' attribute) # if false: call same method on client as on server connect_method => 'connect', # force prepare method (unless overridden by go_prepare_method=>'...' attribute) # if false: call same method on client as on server prepare_method => 'prepare', skip_connect_check => 0, skip_default_methods => 0, skip_prepare_check => 0, skip_ping => 0, dbh_attribute_update => 'every', dbh_attribute_list => ['*'], locally_quote => 0, locally_quote_identifier => 0, cache_parse_trace_flags => 1, cache_parse_trace_flag => 1, cache_data_sources => 1, cache_type_info_all => 1, cache_tables => 0, cache_table_info => 0, cache_column_info => 0, cache_primary_key_info => 0, cache_foreign_key_info => 0, cache_statistics_info => 0, cache_get_info => 0, cache_func => 0, ); my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; __PACKAGE__->create_policy_subs(\%policy_defaults); sub create_policy_subs { my ($class, $policy_defaults) = @_; while ( my ($policy_name, $policy_default) = each %$policy_defaults) { my $policy_attr_name = "go_$policy_name"; my $sub = sub { # $policy->foo($attr, ...) #carp "$policy_name($_[1],...)"; # return the policy default value unless an attribute overrides it return (ref $_[1] && exists $_[1]->{$policy_attr_name}) ? $_[1]->{$policy_attr_name} : $policy_default; }; no strict 'refs'; *{$class . '::' . $policy_name} = $sub; } } sub AUTOLOAD { carp "Unknown policy name $AUTOLOAD used"; # only warn once no strict 'refs'; *$AUTOLOAD = sub { undef }; return undef; } sub new { my ($class, $args) = @_; my $policy = {}; bless $policy, $class; } sub DESTROY { }; 1; =head1 NAME DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...) =head1 DESCRIPTION DBD::Gofer can be configured via a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. The L class is the base class for all the policy classes and describes all the individual policy items. The Base policy is not used directly. You should use a policy class derived from it. =head1 POLICY CLASSES Three policy classes are supplied with DBD::Gofer: L is most 'transparent' but slowest because it makes more round-trips to the Gofer server. L is a reasonable compromise - it's the default policy. L is fastest, but may require code changes in your applications. Generally the default C policy is fine. When first testing an existing application with Gofer it is a good idea to start with the C policy first and then switch to C or a custom policy, for final testing. =head1 POLICY ITEMS These are temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. See the source code to this module for more details. =head1 POLICY CUSTOMIZATION XXX This area of DBD::Gofer is subject to change. There are three ways to customize policies: Policy classes are designed to influence the overall behaviour of DBD::Gofer with existing, unaltered programs, so they work in a reasonably optimal way without requiring code changes. You can implement new policy classes as subclasses of existing policies. In many cases individual policy items can be overridden on a case-by-case basis within your application code. You do this by passing a corresponding C<>> attribute into DBI methods by your application code. This lets you fine-tune the behaviour for special cases. The policy items are implemented as methods. In many cases the methods are passed parameters relating to the DBD::Gofer code being executed. This means the policy can implement dynamic behaviour that varies depending on the particular circumstances, such as the particular statement being executed. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBD/File/0000755000031300001440000000000015240046615013403 5ustar00merijnusersDBI-1.652/lib/DBD/File/HowTo.pod0000644000031300001440000001135615206260124015150 0ustar00merijnusers=head1 NAME DBD::File::HowTo - Guide to create DBD::File based driver =head1 SYNOPSIS perldoc DBD::File::HowTo perldoc DBI perldoc DBI::DBD perldoc DBD::File::Developers perldoc DBI::DBD::SqlEngine::Developers perldoc DBI::DBD::SqlEngine perldoc SQL::Eval perldoc DBI::DBD::SqlEngine::HowTo perldoc SQL::Statement::Embed perldoc DBD::File perldoc DBD::File::HowTo perldoc DBD::File::Developers =head1 DESCRIPTION This document provides a step-by-step guide, how to create a new C based DBD. It expects that you carefully read the L documentation and that you're familiar with L and had read and understood L. This document addresses experienced developers who are really sure that they need to invest time when writing a new DBI Driver. Writing a DBI Driver is neither a weekend project nor an easy job for hobby coders after work. Expect one or two man-month of time for the first start. Those who are still reading, should be able to sing the rules of L. Of course, DBD::File is a DBI::DBD::SqlEngine and you surely read L before continuing here. =head1 CREATING DRIVER CLASSES Do you have an entry in DBI's DBD registry? For this guide, a prefix of C is assumed. =head2 Sample Skeleton package DBD::Foo; use strict; use warnings; use base qw(DBD::File); use DBI (); our $VERSION = "0.001"; package DBD::Foo::dr; our @ISA = qw(DBD::File::dr); our $imp_data_size = 0; package DBD::Foo::db; our @ISA = qw(DBD::File::db); our $imp_data_size = 0; package DBD::Foo::st; our @ISA = qw(DBD::File::st); our $imp_data_size = 0; package DBD::Foo::Statement; our @ISA = qw(DBD::File::Statement); package DBD::Foo::Table; our @ISA = qw(DBD::File::Table); 1; Tiny, eh? And all you have now is a DBD named foo which will be able to deal with temporary tables, as long as you use L. In L environments, this DBD can do nothing. =head2 Start over Based on L, we're now having a driver which could do basic things. Of course, it should now derive from DBD::File instead of DBI::DBD::SqlEngine, shouldn't it? DBD::File extends DBI::DBD::SqlEngine to deal with any kind of files. In principle, the only extensions required are to the table class: package DBD::Foo::Table; sub bootstrap_table_meta { my ($self, $dbh, $meta, $table) = @_; # initialize all $meta attributes which might be relevant for # file2table return $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table); } sub init_table_meta { my ($self, $dbh, $meta, $table) = @_; # called after $meta contains the results from file2table # initialize all missing $meta attributes $self->SUPER::init_table_meta ($dbh, $meta, $table); } In case C doesn't open the files as the driver needs that, override it! sub open_file { my ($self, $meta, $attrs, $flags) = @_; # ensure that $meta->{f_dontopen} is set $self->SUPER::open_file ($meta, $attrs, $flags); # now do what ever needs to be done } Combined with the methods implemented using the L guide, the table is full working and you could try a start over. =head2 User comfort C since C<0.39> consolidates all persistent meta data of a table into a single structure stored in C<< $dbh->{f_meta} >>. With C version C<0.41> and C version C<0.05>, this consolidation moves to L. It's still the C<< $dbh->{$drv_prefix . "_meta"} >> attribute which cares, so what you learned at this place before, is still valid. sub init_valid_attributes { my $dbh = $_[0]; $dbh->SUPER::init_valid_attributes (); $dbh->{foo_valid_attrs} = { ... }; $dbh->{foo_readonly_attrs} = { ... }; $dbh->{foo_meta} = "foo_tables"; return $dbh; } See updates at L. =head2 Testing Now you should have your own DBD::File based driver. Was easy, wasn't it? But does it work well? Prove it by writing tests and remember to use dbd_edit_mm_attribs from L to ensure testing even rare cases. =head1 AUTHOR This guide is written by Jens Rehsack. DBD::File is written by Jochen Wiedmann and Jeff Zucker. The module DBD::File is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > =head1 COPYRIGHT AND LICENSE Copyright (C) 2010-2026 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut DBI-1.652/lib/DBD/File/Developers.pod0000644000031300001440000005013115225122612016212 0ustar00merijnusers=head1 NAME DBD::File::Developers - Developers documentation for DBD::File =head1 SYNOPSIS package DBD::myDriver; use base qw( DBD::File ); sub driver { ... my $drh = $proto->SUPER::driver ($attr); ... return $drh->{class}; } sub CLONE { ... } package DBD::myDriver::dr; @ISA = qw( DBD::File::dr ); sub data_sources { ... } ... package DBD::myDriver::db; @ISA = qw( DBD::File::db ); sub init_valid_attributes { ... } sub init_default_attributes { ... } sub set_versions { ... } sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } sub get_myd_versions { ... } package DBD::myDriver::st; @ISA = qw( DBD::File::st ); sub FETCH { ... } sub STORE { ... } package DBD::myDriver::Statement; @ISA = qw( DBD::File::Statement ); package DBD::myDriver::Table; @ISA = qw( DBD::File::Table ); my %reset_on_modify = ( myd_abc => "myd_foo", myd_mno => "myd_bar", ); __PACKAGE__->register_reset_on_modify (\%reset_on_modify); my %compat_map = ( abc => 'foo_abc', xyz => 'foo_xyz', ); __PACKAGE__->register_compat_map (\%compat_map); sub bootstrap_table_meta { ... } sub init_table_meta { ... } sub table_meta_attr_changed { ... } sub open_data { ... } sub fetch_row { ... } sub push_row { ... } sub push_names { ... } # optimize the SQL engine by add one or more of sub update_current_row { ... } # or sub update_specific_row { ... } # or sub update_one_row { ... } # or sub insert_new_row { ... } # or sub delete_current_row { ... } # or sub delete_one_row { ... } =head1 DESCRIPTION This document describes how DBD developers can write DBD::File based DBI drivers. It supplements L and L, which you should read first. =head1 CLASSES Each DBI driver must provide a package global C method and three DBI related classes: =over 4 =item DBD::File::dr Driver package, contains the methods DBI calls indirectly via DBI interface: DBI->connect ('DBI:DBM:', undef, undef, {}) # invokes package DBD::DBM::dr; @DBD::DBM::dr::ISA = qw( DBD::File::dr ); sub connect ($$;$$$) { ... } Similar for C<< data_sources >> and C<< disconnect_all >>. Pure Perl DBI drivers derived from DBD::File do not usually need to override any of the methods provided through the DBD::XXX::dr package however if you need additional initialization in the connect method you may need to. =item DBD::File::db Contains the methods which are called through DBI database handles (C<< $dbh >>). e.g., $sth = $dbh->prepare ("select * from foo"); # returns the f_encoding setting for table foo $dbh->csv_get_meta ("foo", "f_encoding"); DBD::File provides the typical methods required here. Developers who write DBI drivers based on DBD::File need to override the methods C<< set_versions >> and C<< init_valid_attributes >>. =item DBD::File::st Contains the methods to deal with prepared statement handles. e.g., $sth->execute () or die $sth->errstr; =back =head2 DBD::File This is the main package containing the routines to initialize DBD::File based DBI drivers. Primarily the C<< DBD::File::driver >> method is invoked, either directly from DBI when the driver is initialized or from the derived class. package DBD::DBM; use base qw( DBD::File ); sub driver { my ($class, $attr) = @_; ... my $drh = $class->SUPER::driver ($attr); ... return $drh; } It is not necessary to implement your own driver method as long as additional initialization (e.g. installing more private driver methods) is not required. You do not need to call C<< setup_driver >> as DBD::File takes care of it. =head2 DBD::File::dr The driver package contains the methods DBI calls indirectly via the DBI interface (see L). DBD::File based DBI drivers usually do not need to implement anything here, it is enough to do the basic initialization: package DBD:XXX::dr; @DBD::XXX::dr::ISA = qw (DBD::File::dr); $DBD::XXX::dr::imp_data_size = 0; $DBD::XXX::dr::data_sources_attr = undef; $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; =head2 DBD::File::db This package defines the database methods, which are called via the DBI database handle C<< $dbh >>. Methods provided by DBD::File: =over 4 =item ping Simply returns the content of the C<< Active >> attribute. Override when your driver needs more complicated actions here. =item prepare Prepares a new SQL statement to execute. Returns a statement handle, C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor recommended to override this method. =item FETCH Fetches an attribute of a DBI database object. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. The driver prefix is extracted from the attribute name and verified against C<< $dbh->{$drv_prefix . "valid_attrs"} >> (when it exists). If the requested attribute value is not listed as a valid attribute, this method croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ $drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the attribute value is returned. So it's not possible to modify C from outside of DBD::File::db or a derived class. =item STORE Stores a database private attribute. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. If the database handle has an attribute C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in that hash, this method croaks. If the database handle has an attribute C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there can be stored (once they are initialized). Trying to overwrite such an immutable attribute forces this method to croak. An example of a valid attributes list can be found in C<< DBD::File::db::init_valid_attributes >>. =item set_versions This method sets the attribute C with the version of DBD::File. This method is called at the begin of the C phase. When overriding this method, do not forget to invoke the superior one. =item init_valid_attributes This method is called after the database handle is instantiated as the first attribute initialization. C<< DBD::File::db::init_valid_attributes >> initializes the attributes C and C. When overriding this method, do not forget to invoke the superior one, preferably before doing anything else. Compatibility table attribute access must be initialized here to allow DBD::File to instantiate the map tie: # for DBD::CSV $dbh->{csv_meta} = "csv_tables"; # for DBD::DBM $dbh->{dbm_meta} = "dbm_tables"; # for DBD::AnyData $dbh->{ad_meta} = "ad_tables"; =item init_default_attributes This method is called after the database handle is instantiated to initialize the default attributes. C<< DBD::File::db::init_default_attributes >> initializes the attributes C, C, C, C. When the derived implementor class provides the attribute to validate attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} = {...}; >>), the attributes C, C, C and C are added (when available) to the list of valid and immutable attributes (where C is interpreted as the driver prefix). If C is set, an attribute with the name in C is initialized providing restricted read/write access to the meta data of the tables using C in the first (table) level and C for the meta attribute level. C uses C to initialize the second level tied hash on FETCH/STORE. The C class uses C to FETCH attribute values and C to STORE attribute values. This allows it to map meta attributes for compatibility reasons. =item get_single_table_meta =item get_file_meta Retrieve an attribute from a table's meta information. The method signature is C<< get_file_meta ($dbh, $table, $attr) >>. This method is called by the injected db handle method C<< ${drv_prefix}get_meta >>. While get_file_meta allows C<$table> or C<$attr> to be a list of tables or attributes to retrieve, get_single_table_meta allows only one table name and only one attribute name. A table name of C<'.'> (single dot) is interpreted as the default table and this will retrieve the appropriate attribute globally from the dbh. This has the same restrictions as C<< $dbh->{$attrib} >>. get_file_meta allows C<'+'> and C<'*'> as wildcards for table names and C<$table> being a regular expression matching against the table names (evaluated without the default table). The table name C<'*'> is I. The table name C<'+'> is I (/^[_A-Za-z0-9]+$/). The table meta information is retrieved using the get_table_meta and get_table_meta_attr methods of the table class of the implementation. =item set_single_table_meta =item set_file_meta Sets an attribute in a table's meta information. The method signature is C<< set_file_meta ($dbh, $table, $attr, $value) >>. This method is called by the injected db handle method C<< ${drv_prefix}set_meta >>. While set_file_meta allows C<$table> to be a list of tables and C<$attr> to be a hash of several attributes to set, set_single_table_meta allows only one table name and only one attribute name/value pair. The wildcard characters for the table name are the same as for get_file_meta. The table meta information is updated using the get_table_meta and set_table_meta_attr methods of the table class of the implementation. =item clear_file_meta Clears all meta information cached about a table. The method signature is C<< clear_file_meta ($dbh, $table) >>. This method is called by the injected db handle method C<< ${drv_prefix}clear_meta >>. =back =head2 DBD::File::st Contains the methods to deal with prepared statement handles: =over 4 =item FETCH Fetches statement handle attributes. Supported attributes (for full overview see L) are C, C, C and C in case that SQL::Statement is used as SQL execution engine and a statement is successful prepared. When SQL::Statement has additional information about a table, those information are returned. Otherwise, the same defaults as in L are used. This method usually requires extending in a derived implementation. See L or L for some example. =back =head2 DBD::File::TableSource::FileSystem Provides data sources and table information on database driver and database handle level. package DBD::File::TableSource::FileSystem; sub data_sources ($;$) { my ($class, $drh, $attrs) = @_; ... } sub avail_tables { my ($class, $drh) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources ($driver); @ary = DBI->data_sources ($driver, \%attr); @ary = $dbh->data_sources (); @ary = $dbh->data_sources (\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr); $dbh->func ("list_tables"); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default. =head2 DBD::File::DataSource::Stream package DBD::File::DataSource::Stream; @DBD::File::DataSource::Stream::ISA = 'DBI::DBD::SqlEngine::DataSource'; sub complete_table_name { my ($self, $meta, $file, $respect_case) = @_; ... } Clears all meta attributes identifying a file: C, C and C. The table name is set according to C<$respect_case> and C<< $meta->{sql_identifier_case} >> (SQL_IC_LOWER, SQL_IC_UPPER). package DBD::File::DataSource::Stream; sub apply_encoding { my ($self, $meta, $fn) = @_; ... } Applies the encoding from I (C<< $meta->{f_encoding} >>) to the file handled opened in C. package DBD::File::DataSource::Stream; sub open_data { my ($self, $meta, $attrs, $flags) = @_; ... } Opens (C) the file handle provided in C<< $meta->{f_file} >>. package DBD::File::DataSource::Stream; sub can_flock { ... } Returns whether C is available or not (avoids retesting in subclasses). =head2 DBD::File::DataSource::File package DBD::File::DataSource::File; sub complete_table_name ($$;$) { my ($self, $meta, $table, $respect_case) = @_; ... } The method C tries to map a filename to the associated table name. It is called with a partially filled meta structure for the resulting table containing at least the following attributes: C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>. If a file/table map can be found then this method sets the C<< f_fqfn >>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in the meta structure. If a map cannot be found the table name will be undef. package DBD::File::DataSource::File; sub open_data ($) { my ($self, $meta, $attrs, $flags) = @_; ... } Depending on the attributes set in the table's meta data, the following steps are performed. Unless C<< f_dontopen >> is set to a true value, C<< f_fqfn >> must contain the full qualified file name for the table to work on (file2table ensures this). The encoding in C<< f_encoding >> is applied if set and the file is opened. If C<> (full qualified lock name) is set, this file is opened, too. Depending on the value in C<< f_lock >>, the appropriate lock is set on the opened data file or lock file. =head2 DBD::File::Statement Derives from DBI::SQL::Nano::Statement to provide following method: =over 4 =item open_table Implements the open_table method required by L and L. All the work for opening the file(s) belonging to the table is handled and parametrized in DBD::File::Table. Unless you intend to add anything to the following implementation, an empty DBD::XXX::Statement package satisfies DBD::File. sub open_table ($$$$$) { my ($self, $data, $table, $createMode, $lockMode) = @_; my $class = ref $self; $class =~ s/::Statement/::Table/; my $flags = { createMode => $createMode, lockMode => $lockMode, }; $self->{command} eq "DROP" and $flags->{dropMode} = 1; return $class->new ($data, { table => $table }, $flags); } # open_table =back =head2 DBD::File::Table Derives from DBI::SQL::Nano::Table and provides physical file access for the table data which are stored in the files. =over 4 =item bootstrap_table_meta Initializes a table meta structure. Can be safely overridden in a derived class, as long as the C<< SUPER >> method is called at the end of the overridden method. It copies the following attributes from the database into the table meta data C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >> and C<< f_lockfile >> and makes them sticky to the table. This method should be called before you attempt to map between file name and table name to ensure the correct directory, extension etc. are used. =item init_table_meta Initializes more attributes of the table meta data - usually more expensive ones (e.g. those which require class instantiations) - when the file name and the table name could mapped. =item get_table_meta Returns the table meta data. If there are none for the required table, a new one is initialized. When it fails, nothing is returned. On success, the name of the table and the meta data structure is returned. =item get_table_meta_attr Returns a single attribute from the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item set_table_meta_attr Sets a single attribute in the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item table_meta_attr_changed Called when an attribute of the meta data is modified. If the modified attribute requires to reset a calculated attribute, the calculated attribute is reset (deleted from meta data structure) and the I flag is removed, too. The decision is made based on C<%register_reset_on_modify>. =item register_reset_on_modify Allows C to reset meta attributes when special attributes are modified. For DBD::File, modifying one of C, C, C or C will reset C. DBD::DBM extends the list for C and C to reset the value of C. If your DBD has calculated values in the meta data area, then call C: my %reset_on_modify = (xxx_foo => "xxx_bar"); __PACKAGE__->register_reset_on_modify (\%reset_on_modify); =item register_compat_map Allows C and C to update the attribute name to the current favored one: # from DBD::DBM my %compat_map = (dbm_ext => "f_ext"); __PACKAGE__->register_compat_map (\%compat_map); =item open_file Called to open the table's data file. Depending on the attributes set in the table's meta data, the following steps are performed. Unless C<< f_dontopen >> is set to a true value, C<< f_fqfn >> must contain the full qualified file name for the table to work on (file2table ensures this). The encoding in C<< f_encoding >> is applied if set and the file is opened. If C<> (full qualified lock name) is set, this file is opened, too. Depending on the value in C<< f_lock >>, the appropriate lock is set on the opened data file or lock file. After this is done, a derived class might add more steps in an overridden C<< open_file >> method. =item new Instantiates the table. This is done in 3 steps: 1. get the table meta data 2. open the data file 3. bless the table data structure using inherited constructor new It is not recommended to override the constructor of the table class. Find a reasonable place to add you extensions in one of the above four methods. =item drop Implements the abstract table method for the C<< DROP >> command. Discards table meta data after all files belonging to the table are closed and unlinked. Overriding this method might be reasonable in very rare cases. =item seek Implements the abstract table method used when accessing the table from the engine. C<< seek >> is called every time the engine uses dumb algorithms for iterating over the table content. =item truncate Implements the abstract table method used when dumb table algorithms for C<< UPDATE >> or C<< DELETE >> need to truncate the table storage after the last written row. =back You should consult the documentation of C<< SQL::Eval::Table >> (see L) to get more information about the abstract methods of the table's base class you have to override and a description of the table meta information expected by the SQL engines. =head1 AUTHOR The module DBD::File is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > The original author is Jochen Wiedmann. =head1 COPYRIGHT AND LICENSE Copyright (C) 2010-2026 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut DBI-1.652/lib/DBD/File/Roadmap.pod0000644000031300001440000001345215222214034015467 0ustar00merijnusers=head1 NAME DBD::File::Roadmap - Planned Enhancements for DBD::File and pure Perl DBD's Jens Rehsack - May 2010 =head1 SYNOPSIS This document gives a high level overview of the future of the DBD::File DBI driver and groundwork for pure Perl DBI drivers. The planned enhancements cover features, testing, performance, reliability, extensibility and more. =head1 CHANGES AND ENHANCEMENTS =head2 Features There are some features missing we would like to add, but there is no time plan: =over 4 =item LOCK TABLE The newly implemented internal common table meta storage area would allow us to implement LOCK TABLE support based on file system C support. =item Transaction support While DBD::AnyData recommends explicitly committing by importing and exporting tables, DBD::File might be enhanced in a future version to allow transparent transactions using the temporary tables of SQL::Statement as shadow (dirty) tables. Transaction support will heavily rely on lock table support. =item Data Dictionary Persistence SQL::Statement provides dictionary information when a "CREATE TABLE ..." statement is executed. This dictionary is preserved for some statement handle attribute fetches (as C or C). It is planned to extend DBD::File to support data dictionaries to work on the tables in it. It is not planned to support one table in different dictionaries, but you can have several dictionaries in one directory. =item SQL Engine selecting on connect Currently the SQL engine selected is chosen during the loading of the module L. Ideally end users should be able to select the engine used in C<< DBI->connect () >> with a special DBD::File attribute. =back Other points of view to the planned features (and more features for the SQL::Statement engine) are shown in L. =head2 Testing DBD::File and the dependent DBD::DBM requires a lot more automated tests covering API stability and compatibility with optional modules like SQL::Statement. =head2 Performance Several arguments for support of features like indexes on columns and cursors are made for DBD::CSV (which is a DBD::File based driver, too). Similar arguments could be made for DBD::DBM, DBD::AnyData, DBD::RAM or DBD::PO etc. To improve the performance of the underlying SQL engines, a clean re-implementation seems to be required. Currently both engines are prematurely optimized and therefore it is not trivial to provide further optimization without the risk of breaking existing features. Join the DBI developers IRC channel at L to participate or post to the DBI Developers Mailing List. =head2 Reliability DBD::File currently lacks the following points: =over 4 =item duplicate table names It is currently possible to access a table quoted with a relative path (a) and additionally using an absolute path (b). If (a) and (b) are the same file that is not recognized (except for flock protection handled by the Operating System) and two independent tables are handled. =item invalid table names The current implementation does not prevent someone choosing a directory name as a physical file name for the table to open. =back =head2 Extensibility I (Jens Rehsack) have some (partially for example only) DBD's in mind: =over 4 =item DBD::Sys Derive DBD::Sys from a common code base shared with DBD::File which handles all the emulation DBI needs (as getinfo, SQL engine handling, ...) =item DBD::Dir Provide a DBD::File derived to work with fixed table definitions through the file system to demonstrate how DBI / Pure Perl DBDs could handle databases with hierarchical structures. =item DBD::Join Provide a DBI driver which is able to manage multiple connections to other Databases (as DBD::Multiplex), but allow them to point to different data sources and allow joins between the tables of them: # Example # Let table 'lsof' being a table in DBD::Sys giving a list of open files using lsof utility # Let table 'dir' being a atable from DBD::Dir $sth = $dbh->prepare( "select * from dir,lsof where path='/documents' and dir.entry = lsof.filename" ) $sth->execute(); # gives all open files in '/documents' ... # Let table 'filesys' a DBD::Sys table of known file systems on current host # Let table 'applications' a table of your Configuration Management Database # where current applications (relocatable, with mountpoints for filesystems) # are stored $sth = dbh->prepare( "select * from applications,filesys where " . "application.mountpoint = filesys.mountpoint and ". "filesys.mounted is true" ); $sth->execute(); # gives all currently mounted applications on this host =back =head1 PRIORITIES Our priorities are focused on current issues. Initially many new test cases for DBD::File and DBD::DBM should be added to the DBI test suite. After that some additional documentation on how to use the DBD::File API will be provided. Any additional priorities will come later and can be modified by (paying) users. =head1 RESOURCES AND CONTRIBUTIONS See F for I. If your company has benefited from DBI, please consider if it could make a donation to The Perl Foundation "DBI Development" fund at L to secure future development. Alternatively, if your company would benefit from a specific new DBI feature, please consider sponsoring it's development through the options listed in the section "Commercial Support from the Author" on L. Using such targeted financing allows you to contribute to DBI development and rapidly get something specific and directly valuable to you in return. My company also offers annual support contracts for the DBI, which provide another way to support the DBI and get something specific in return. Contact me for details. Thank you. =cut DBI-1.652/lib/DBD/NullP.pm0000644000031300001440000001366614742423677014145 0ustar00merijnusersuse strict; use warnings; { package DBD::NullP; require DBI; require Carp; our @EXPORT = qw(); # Do NOT @EXPORT anything. our $VERSION = "12.014715"; # $Id: NullP.pm 14714 2011-02-22 17:27:07Z Tim $ # # Copyright (c) 1994-2007 Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. our $drh = undef; # holds driver handle once initialised sub driver{ return $drh if $drh; my($class, $attr) = @_; $class .= "::dr"; ($drh) = DBI::_new_drh($class, { 'Name' => 'NullP', 'Version' => $VERSION, 'Attribution' => 'DBD Example Null Perl stub by Tim Bunce', }, [ qw'example implementors private data']); $drh; } sub CLONE { undef $drh; } } { package DBD::NullP::dr; # ====== DRIVER ====== our $imp_data_size = 0; use strict; sub connect { # normally overridden, but a handy default my $dbh = shift->SUPER::connect(@_) or return; $dbh->STORE(Active => 1); $dbh; } sub DESTROY { undef } } { package DBD::NullP::db; # ====== DATABASE ====== our $imp_data_size = 0; use strict; use Carp qw(croak); # Added get_info to support tests in 10examp.t sub get_info { my ($dbh, $type) = @_; if ($type == 29) { # identifier quote return '"'; } return; } # Added table_info to support tests in 10examp.t sub table_info { my ($dbh, $catalog, $schema, $table, $type) = @_; my ($outer, $sth) = DBI::_new_sth($dbh, { 'Statement' => 'tables', }); if (defined($type) && $type eq '%' && # special case for tables('','','','%') grep {defined($_) && $_ eq ''} ($catalog, $schema, $table)) { $outer->{dbd_nullp_data} = [[undef, undef, undef, 'TABLE', undef], [undef, undef, undef, 'VIEW', undef], [undef, undef, undef, 'ALIAS', undef]]; } elsif (defined($catalog) && $catalog eq '%' && # special case for tables('%','','') grep {defined($_) && $_ eq ''} ($schema, $table)) { $outer->{dbd_nullp_data} = [['catalog1', undef, undef, undef, undef], ['catalog2', undef, undef, undef, undef]]; } else { $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table1', 'TABLE']]; $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table2', 'TABLE']]; $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table3', 'TABLE']]; } $outer->STORE(NUM_OF_FIELDS => 5); $sth->STORE(Active => 1); return $outer; } sub prepare { my ($dbh, $statement)= @_; my ($outer, $sth) = DBI::_new_sth($dbh, { 'Statement' => $statement, }); return $outer; } sub FETCH { my ($dbh, $attrib) = @_; # In reality this would interrogate the database engine to # either return dynamic values that cannot be precomputed # or fetch and cache attribute values too expensive to prefetch. return $dbh->SUPER::FETCH($attrib); } sub STORE { my ($dbh, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle if ($attrib eq 'AutoCommit') { Carp::croak("Can't disable AutoCommit") unless $value; # convert AutoCommit values to magic ones to let DBI # know that the driver has 'handled' the AutoCommit attribute $value = ($value) ? -901 : -900; } elsif ($attrib eq 'nullp_set_err') { # a fake attribute to produce a test case where STORE issues a warning $dbh->set_err($value, $value); } return $dbh->SUPER::STORE($attrib, $value); } sub ping { 1 } sub disconnect { shift->STORE(Active => 0); } } { package DBD::NullP::st; # ====== STATEMENT ====== our $imp_data_size = 0; use strict; sub bind_param { my ($sth, $param, $value, $attr) = @_; $sth->{ParamValues}{$param} = $value; $sth->{ParamAttr}{$param} = $attr if defined $attr; # attr is sticky if not explicitly set return 1; } sub execute { my $sth = shift; $sth->bind_param($_, $_[$_-1]) for (1..@_); if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) { $sth->STORE(NUM_OF_FIELDS => 1); $sth->{NAME} = [ "fieldname" ]; # just for the sake of returning something, we return the params my $params = $sth->{ParamValues} || {}; $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ]; $sth->STORE(Active => 1); } # force a sleep - handy for testing elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) { my $secs = $1; if (eval { require Time::HiRes; defined &Time::HiRes::sleep }) { Time::HiRes::sleep($secs); } else { sleep $secs; } } # force an error - handy for testing elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) { return $sth->set_err($1, $2); } # anything else is silently ignored, successfully 1; } sub fetchrow_arrayref { my $sth = shift; my $data = shift @{$sth->{dbd_nullp_data}}; if (!$data || !@$data) { $sth->finish; # no more data so finish return undef; } return $sth->_set_fbav($data); } *fetch = \&fetchrow_arrayref; # alias sub FETCH { my ($sth, $attrib) = @_; # would normally validate and only fetch known attributes # else pass up to DBI to handle return $sth->SUPER::FETCH($attrib); } sub STORE { my ($sth, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle return $sth->SUPER::STORE($attrib, $value); } } 1; DBI-1.652/lib/DBD/Gofer.pm0000644000031300001440000013771414742423677014156 0ustar00merijnusers{ package DBD::Gofer; use strict; use warnings; require DBI; require DBI::Gofer::Request; require DBI::Gofer::Response; require Carp; our $VERSION = "0.015327"; # $Id: Gofer.pm 15326 2012-06-06 16:32:38Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # attributes we'll allow local STORE our %xxh_local_store_attrib = map { $_=>1 } qw( Active CachedKids Callbacks DbTypeSubclass ErrCount Executed FetchHashKeyName HandleError HandleSetErr InactiveDestroy AutoInactiveDestroy PrintError PrintWarn Profile RaiseError RaiseWarn RootClass ShowErrorStatement Taint TaintIn TaintOut TraceLevel Warn dbi_quote_identifier_cache dbi_connect_closure dbi_go_execute_unique ); our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw( Username dbi_connect_method ); our $drh = undef; # holds driver handle once initialized our $methods_already_installed; sub driver{ return $drh if $drh; DBI->setup_driver('DBD::Gofer'); unless ($methods_already_installed++) { my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR DBD::Gofer::db->install_method('go_dbh_method', $opts); DBD::Gofer::st->install_method('go_sth_method', $opts); DBD::Gofer::st->install_method('go_clone_sth', $opts); DBD::Gofer::db->install_method('go_cache', $opts); DBD::Gofer::st->install_method('go_cache', $opts); } my($class, $attr) = @_; $class .= "::dr"; ($drh) = DBI::_new_drh($class, { 'Name' => 'Gofer', 'Version' => $VERSION, 'Attribution' => 'DBD Gofer by Tim Bunce', }); $drh; } sub CLONE { undef $drh; } sub go_cache { my $h = shift; $h->{go_cache} = shift if @_; # return handle's override go_cache, if it has one return $h->{go_cache} if defined $h->{go_cache}; # or else the transports default go_cache return $h->{go_transport}->{go_cache}; } sub set_err_from_response { # set error/warn/info and propagate warnings my $h = shift; my $response = shift; if (my $warnings = $response->warnings) { warn $_ for @$warnings; } my ($err, $errstr, $state) = $response->err_errstr_state; # Only set_err() if there's an error else leave the current values # (The current values will normally be set undef by the DBI dispatcher # except for methods marked KEEPERR such as ping.) $h->set_err($err, $errstr, $state) if defined $err; return undef; } sub install_methods_proxy { my ($installed_methods) = @_; while ( my ($full_method, $attr) = each %$installed_methods ) { # need to install both a DBI dispatch stub and a proxy stub # (the dispatch stub may be already here due to local driver use) DBI->_install_method($full_method, "", $attr||{}) unless defined &{$full_method}; # now install proxy stubs on the driver side $full_method =~ m/^DBI::(\w\w)::(\w+)$/ or die "Invalid method name '$full_method' for install_method"; my ($type, $method) = ($1, $2); my $driver_method = "DBD::Gofer::${type}::${method}"; next if defined &{$driver_method}; my $sub; if ($type eq 'db') { $sub = sub { return shift->go_dbh_method(undef, $method, @_) }; } else { $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; }; } no strict 'refs'; *$driver_method = $sub; } } } { package DBD::Gofer::dr; # ====== DRIVER ====== $imp_data_size = 0; use strict; sub connect_cached { my ($drh, $dsn, $user, $auth, $attr)= @_; $attr ||= {}; return $drh->SUPER::connect_cached($dsn, $user, $auth, { (%$attr), go_connect_method => $attr->{go_connect_method} || 'connect_cached', }); } sub connect { my($drh, $dsn, $user, $auth, $attr)= @_; my $orig_dsn = $dsn; # first remove dsn= and everything after it my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1) or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'"); if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t return DBI->connect($remote_dsn, $user, $auth, $attr); } my %go_attr; # extract any go_ attributes from the connect() attr arg for my $k (grep { /^go_/ } keys %$attr) { $go_attr{$k} = delete $attr->{$k}; } # then override those with any attributes embedded in our dsn (not remote_dsn) for my $kv (grep /=/, split /;/, $dsn, -1) { my ($k, $v) = split /=/, $kv, 2; $go_attr{ "go_$k" } = $v; } if (not ref $go_attr{go_policy}) { # if not a policy object already my $policy_class = $go_attr{go_policy} || 'classic'; $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class =~ /::/; _load_class($policy_class) or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@"); # replace policy name in %go_attr with policy object $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) } or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@"); } # policy object is left in $go_attr{go_policy} so transport can see it my $go_policy = $go_attr{go_policy}; if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already my $cache_class = $go_attr{go_cache}; $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1'; _load_class($cache_class) or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@"); $go_attr{go_cache} = eval { $cache_class->new() } or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning } # delete any other attributes that don't apply to transport my $go_connect_method = delete $go_attr{go_connect_method}; my $transport_class = delete $go_attr{go_transport} or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'"); $transport_class = "DBD::Gofer::Transport::$transport_class" unless $transport_class =~ /::/; _load_class($transport_class) or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@"); my $go_transport = eval { $transport_class->new(\%go_attr) } or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@"); my $request_class = "DBI::Gofer::Request"; my $go_request = eval { my $go_attr = { %$attr }; # XXX user/pass of fwd server vs db server ? also impact of autoproxy if ($user) { $go_attr->{Username} = $user; $go_attr->{Password} = $auth; } # delete any attributes we can't serialize (or don't want to) delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)}; # delete any attributes that should only apply to the client-side delete @{$go_attr}{qw(RootClass DbTypeSubclass)}; $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect'; $request_class->new({ dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ], }) } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@"); my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, { 'Name' => $dsn, 'USER' => $user, go_transport => $go_transport, go_request => $go_request, go_policy => $go_policy, }); # mark as inactive temporarily for STORE. Active not set until connected() called. $dbh->STORE(Active => 0); # should we ping to check the connection # and fetch dbh attributes my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh); if (not $skip_connect_check) { if (not $dbh->go_dbh_method(undef, 'ping')) { return undef if $dbh->err; # error already recorded, typically return $dbh->set_err($DBI::stderr, "ping failed"); } } return $dbh; } sub _load_class { # return true or false+$@ my $class = shift; (my $pm = $class) =~ s{::}{/}g; $pm .= ".pm"; return 1 if eval { require $pm }; delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough undef; # error in $@ } } { package DBD::Gofer::db; # ====== DATABASE ====== $imp_data_size = 0; use strict; use Carp qw(carp croak); my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib; sub connected { shift->STORE(Active => 1); } sub go_dbh_method { my $dbh = shift; my $meta = shift; # @_ now contains ($method_name, @args) my $request = $dbh->{go_request}; $request->init_request([ wantarray, @_ ], $dbh); ++$dbh->{go_request_count}; my $go_policy = $dbh->{go_policy}; my $dbh_attribute_update = $go_policy->dbh_attribute_update(); $request->dbh_attributes( $go_policy->dbh_attribute_list() ) if $dbh_attribute_update eq 'every' or $dbh->{go_request_count}==1; $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) if $meta->{go_last_insert_id_args}; my $transport = $dbh->{go_transport} or return $dbh->set_err($DBI::stderr, "Not connected (no transport)"); local $transport->{go_cache} = $dbh->{go_cache} if defined $dbh->{go_cache}; my ($response, $retransmit_sub) = $transport->transmit_request($request); $response ||= $transport->receive_response($request, $retransmit_sub); $dbh->{go_response} = $response or die "No response object returned by $transport"; die "response '$response' returned by $transport is not a response object" unless UNIVERSAL::isa($response,"DBI::Gofer::Response"); if (my $dbh_attributes = $response->dbh_attributes) { # XXX installed_methods piggybacks on dbh_attributes for now if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) { DBD::Gofer::install_methods_proxy($installed_methods) if $dbh->{go_request_count}==1; } # XXX we don't STORE here, we just stuff the value into the attribute cache $dbh->{$_} = $dbh_attributes->{$_} for keys %$dbh_attributes; } my $rv = $response->rv; if (my $resultset_list = $response->sth_resultsets) { # dbh method call returned one or more resultsets # (was probably a metadata method like table_info) # # setup an sth but don't execute/forward it my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 }); # set the sth response to our dbh response (tied %$sth)->{go_response} = $response; # setup the sth with the results in our response $sth->more_results; # and return that new sth as if it came from original request $rv = [ $sth ]; } elsif (!$rv) { # should only occur for major transport-level error #carp("no rv in response { @{[ %$response ]} }"); $rv = [ ]; } DBD::Gofer::set_err_from_response($dbh, $response); return (wantarray) ? @$rv : $rv->[0]; } # Methods that should be forwarded but can be cached for my $method (qw( tables table_info column_info primary_key_info foreign_key_info statistics_info data_sources type_info_all get_info parse_trace_flags parse_trace_flag func )) { my $policy_name = "cache_$method"; my $super_name = "SUPER::$method"; my $sub = sub { my $dbh = shift; my $rv; # if we know the remote side doesn't override the DBI's default method # then we might as well just call the DBI's default method on the client # (which may, in turn, call other methods that are forwarded, like get_info) if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); return $dbh->$super_name(@_); } my $cache; my $cache_key; if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) { $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0, join(",\t", map { # XXX basic but sufficient for now !ref($_) ? DBI::neat($_,1e6) : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001") : ref($_) eq 'HASH' ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") } : do { warn "unhandled argument type ($_)"; $_ } } @_); if ($rv = $cache->{$cache_key}) { $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4); my @cache_rv = @$rv; # if it's an sth we have to clone it $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st'); return (wantarray) ? @cache_rv : $cache_rv[0]; } } $rv = [ (wantarray) ? ($dbh->go_dbh_method(undef, $method, @_)) : scalar $dbh->go_dbh_method(undef, $method, @_) ]; if ($cache) { $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4); my @cache_rv = @$rv; # if it's an sth we have to clone it #$cache_rv[0] = $cache_rv[0]->go_clone_sth # if UNIVERSAL::isa($cache_rv[0],'DBI::st'); $cache->{$cache_key} = \@cache_rv unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done } return (wantarray) ? @$rv : $rv->[0]; }; no strict 'refs'; *$method = $sub; } # Methods that can use the DBI defaults for some situations/drivers for my $method (qw( quote quote_identifier )) { # XXX keep DBD::Gofer::Policy::Base in sync my $policy_name = "locally_$method"; my $super_name = "SUPER::$method"; my $sub = sub { my $dbh = shift; # if we know the remote side doesn't override the DBI's default method # then we might as well just call the DBI's default method on the client # (which may, in turn, call other methods that are forwarded, like get_info) if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); return $dbh->$super_name(@_); } # false: use remote gofer # 1: use local DBI default method # code ref: use the code ref my $locally = $dbh->{go_policy}->$policy_name($dbh, @_); if ($locally) { return $locally->($dbh, @_) if ref $locally eq 'CODE'; return $dbh->$super_name(@_); } return $dbh->go_dbh_method(undef, $method, @_); # propagate context }; no strict 'refs'; *$method = $sub; } # Methods that should always fail for my $method (qw( begin_work commit rollback )) { no strict 'refs'; *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") } } sub do { my ($dbh, $sql, $attr, @args) = @_; delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted" $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} }; return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args); } sub ping { my $dbh = shift; return $dbh->set_err('', "can't ping while not connected") # info unless $dbh->SUPER::FETCH('Active'); my $skip_ping = $dbh->{go_policy}->skip_ping(); return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_); } sub last_insert_id { my $dbh = shift; my $response = $dbh->{go_response} or return undef; return $response->last_insert_id; } sub FETCH { my ($dbh, $attrib) = @_; # FETCH is effectively already cached because the DBI checks the # attribute cache in the handle before calling FETCH # and this FETCH copies the value into the attribute cache # forward driver-private attributes (except ours) if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) { my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib); $dbh->{$attrib} = $value; # XXX forces caching by DBI return $dbh->{$attrib} = $value; } # else pass up to DBI to handle return $dbh->SUPER::FETCH($attrib); } sub STORE { my ($dbh, $attrib, $value) = @_; if ($attrib eq 'AutoCommit') { croak "Can't enable transactions when using DBD::Gofer" if !$value; return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900); } return $dbh->SUPER::STORE($attrib => $value) # we handle this attribute locally if $dbh_local_store_attrib{$attrib} # or it's a private_ (application) attribute or $attrib =~ /^private_/ # or not yet connected (ie being called by DBI->connect) or not $dbh->FETCH('Active'); return $dbh->SUPER::STORE($attrib => $value) if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib} && do { # values are the same my $crnt = $dbh->FETCH($attrib); no warnings; (defined($value) ^ defined($crnt)) ? 0 # definedness differs : $value eq $crnt; }; # dbh attributes are set at connect-time - see connect() carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn'); return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer"); } sub disconnect { my $dbh = shift; $dbh->{go_transport} = undef; $dbh->STORE(Active => 0); } sub prepare { my ($dbh, $statement, $attr)= @_; return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected") unless $dbh->FETCH('Active'); $attr = { %$attr } if $attr; # copy so we can edit my $policy = delete($attr->{go_policy}) || $dbh->{go_policy}; my $lii_args = delete $attr->{go_last_insert_id_args}; my $go_prepare = delete($attr->{go_prepare_method}) || $dbh->{go_prepare_method} || $policy->prepare_method($dbh, $statement, $attr) || 'prepare'; # e.g. for code not using placeholders my $go_cache = delete $attr->{go_cache}; # set to undef if there are no attributes left for the actual prepare call $attr = undef if $attr and not %$attr; my ($sth, $sth_inner) = DBI::_new_sth($dbh, { Statement => $statement, go_prepare_call => [ 0, $go_prepare, $statement, $attr ], # go_method_calls => [], # autovivs if needed go_request => $dbh->{go_request}, go_transport => $dbh->{go_transport}, go_policy => $policy, go_last_insert_id_args => $lii_args, go_cache => $go_cache, }); $sth->STORE(Active => 0); # XXX needed? It should be the default my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth); if (not $skip_prepare_check) { $sth->go_sth_method() or return undef; } return $sth; } sub prepare_cached { my ($dbh, $sql, $attr, $if_active)= @_; $attr ||= {}; return $dbh->SUPER::prepare_cached($sql, { %$attr, go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached', }, $if_active); } *go_cache = \&DBD::Gofer::go_cache; } { package DBD::Gofer::st; # ====== STATEMENT ====== $imp_data_size = 0; use strict; my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1); sub go_sth_method { my ($sth, $meta) = @_; if (my $ParamValues = $sth->{ParamValues}) { my $ParamAttr = $sth->{ParamAttr}; # XXX the sort here is a hack to work around a DBD::Sybase bug # but only works properly for params 1..9 # (reverse because of the unshift) my @params = reverse sort keys %$ParamValues; if (@params > 9 && ($sth->{Database}{go_dsn}||'') =~ /dbi:Sybase/) { # if more than 9 then we need to do a proper numeric sort # also warn to alert user of this issue warn "Sybase param binding order hack in use"; @params = sort { $b <=> $a } @params; } for my $p (@params) { # unshift to put binds before execute call unshift @{ $sth->{go_method_calls} }, [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ]; } } my $dbh = $sth->{Database} or die "panic"; ++$dbh->{go_request_count}; my $request = $sth->{go_request}; $request->init_request($sth->{go_prepare_call}, $sth); $request->sth_method_calls(delete $sth->{go_method_calls}) if $sth->{go_method_calls}; $request->sth_result_attr({}); # (currently) also indicates this is an sth request $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) if $meta->{go_last_insert_id_args}; my $go_policy = $sth->{go_policy}; my $dbh_attribute_update = $go_policy->dbh_attribute_update(); $request->dbh_attributes( $go_policy->dbh_attribute_list() ) if $dbh_attribute_update eq 'every' or $dbh->{go_request_count}==1; my $transport = $sth->{go_transport} or return $sth->set_err($DBI::stderr, "Not connected (no transport)"); local $transport->{go_cache} = $sth->{go_cache} if defined $sth->{go_cache}; my ($response, $retransmit_sub) = $transport->transmit_request($request); $response ||= $transport->receive_response($request, $retransmit_sub); $sth->{go_response} = $response or die "No response object returned by $transport"; $dbh->{go_response} = $response; # mainly for last_insert_id if (my $dbh_attributes = $response->dbh_attributes) { # XXX we don't STORE here, we just stuff the value into the attribute cache $dbh->{$_} = $dbh_attributes->{$_} for keys %$dbh_attributes; # record the values returned, so we know that we have fetched # values are which we have fetched (see dbh->FETCH method) $dbh->{go_dbh_attributes_fetched} = $dbh_attributes; } my $rv = $response->rv; # may be undef on error if ($response->sth_resultsets) { # setup first resultset - including sth attributes $sth->more_results; } else { $sth->STORE(Active => 0); $sth->{go_rows} = $rv; } # set error/warn/info (after more_results as that'll clear err) DBD::Gofer::set_err_from_response($sth, $response); return $rv; } sub bind_param { my ($sth, $param, $value, $attr) = @_; $sth->{ParamValues}{$param} = $value; $sth->{ParamAttr}{$param} = $attr if defined $attr; # attr is sticky if not explicitly set return 1; } sub execute { my $sth = shift; $sth->bind_param($_, $_[$_-1]) for (1..@_); push @{ $sth->{go_method_calls} }, [ 'execute' ]; my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args} }; return $sth->go_sth_method($meta); } sub more_results { my $sth = shift; $sth->finish; my $response = $sth->{go_response} or do { # e.g., we haven't sent a request yet (ie prepare then more_results) $sth->trace_msg(" No response object present", 3); return; }; my $resultset_list = $response->sth_resultsets or return $sth->set_err($DBI::stderr, "No sth_resultsets"); my $meta = shift @$resultset_list or return undef; # no more result sets #warn "more_results: ".Data::Dumper::Dumper($meta); # pull out the special non-attributes first my ($rowset, $err, $errstr, $state) = delete @{$meta}{qw(rowset err errstr state)}; # copy meta attributes into attribute cache my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS}; $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS); # XXX need to use STORE for some? $sth->{$_} = $meta->{$_} for keys %$meta; if (($NUM_OF_FIELDS||0) > 0) { $sth->{go_rows} = ($rowset) ? @$rowset : -1; $sth->{go_current_rowset} = $rowset; $sth->{go_current_rowset_err} = [ $err, $errstr, $state ] if defined $err; $sth->STORE(Active => 1) if $rowset; } return $sth; } sub go_clone_sth { my ($sth1) = @_; # clone an (un-fetched-from) sth - effectively undoes the initial more_results # not 100% so just for use in caching returned sth e.g. table_info my $sth2 = $sth1->{Database}->prepare($sth1->{Statement}, { go_skip_prepare_check => 1 }); $sth2->STORE($_, $sth1->{$_}) for qw(NUM_OF_FIELDS Active); my $sth2_inner = tied %$sth2; $sth2_inner->{$_} = $sth1->{$_} for qw(NUM_OF_PARAMS FetchHashKeyName); die "not fully implemented yet"; return $sth2; } sub fetchrow_arrayref { my ($sth) = @_; my $resultset = $sth->{go_current_rowset} || do { # should only happen if fetch called after execute failed my $rowset_err = $sth->{go_current_rowset_err} || [ 1, 'no result set (did execute fail)' ]; return $sth->set_err( @$rowset_err ); }; return $sth->_set_fbav(shift @$resultset) if @$resultset; $sth->finish; # no more data so finish return undef; } *fetch = \&fetchrow_arrayref; # alias sub fetchall_arrayref { my ($sth, $slice, $max_rows) = @_; my $resultset = $sth->{go_current_rowset} || do { # should only happen if fetch called after execute failed my $rowset_err = $sth->{go_current_rowset_err} || [ 1, 'no result set (did execute fail)' ]; return $sth->set_err( @$rowset_err ); }; my $mode = ref($slice) || 'ARRAY'; return $sth->SUPER::fetchall_arrayref($slice, $max_rows) if ref($slice) or defined $max_rows; $sth->finish; # no more data after this so finish return $resultset; } sub rows { return shift->{go_rows}; } sub STORE { my ($sth, $attrib, $value) = @_; return $sth->SUPER::STORE($attrib => $value) if $sth_local_store_attrib{$attrib} # handle locally # or it's a private_ (application) attribute or $attrib =~ /^private_/; # otherwise warn but do it anyway # this will probably need refining later my $msg = "Altering \$sth->{$attrib} won't affect proxied handle"; Carp::carp($msg) if $sth->FETCH('Warn'); # XXX could perhaps do # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ] # if not $sth->FETCH('Executed'); # but how to handle repeat executions? How to we know when an # attribute is being set to affect the current resultset or the # next execution? # Could just always use go_method_calls I guess. # do the store locally anyway, just in case $sth->SUPER::STORE($attrib => $value); return $sth->set_err($DBI::stderr, $msg); } # sub bind_param_array # we use DBI's default, which sets $sth->{ParamArrays}{$param} = $value # and calls bind_param($param, undef, $attr) if $attr. sub execute_array { my $sth = shift; my $attr = shift; $sth->bind_param_array($_, $_[$_-1]) for (1..@_); push @{ $sth->{go_method_calls} }, [ 'execute_array', $attr ]; return $sth->go_sth_method($attr); } *go_cache = \&DBD::Gofer::go_cache; } 1; __END__ =head1 NAME DBD::Gofer - A stateless-proxy driver for communicating with a remote DBI =head1 SYNOPSIS use DBI; $original_dsn = "dbi:..."; # your original DBI Data Source Name $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$original_dsn", $user, $passwd, \%attributes); ... use $dbh as if it was connected to $original_dsn ... The C part specifies the name of the module to use to transport the requests to the remote DBI. If $transport doesn't contain any double colons then it's prefixed with C. The C part I of the DSN because everything after C is assumed to be the DSN that the remote DBI should use. The C<...> represents attributes that influence the operation of the Gofer driver or transport. These are described below or in the documentation of the transport module being used. =encoding ISO8859-1 =head1 DESCRIPTION DBD::Gofer is a DBI database driver that forwards requests to another DBI driver, usually in a separate process, often on a separate machine. It tries to be as transparent as possible so it appears that you are using the remote driver directly. DBD::Gofer is very similar to DBD::Proxy. The major difference is that with DBD::Gofer no state is maintained on the remote end. That means every request contains all the information needed to create the required state. (So, for example, every request includes the DSN to connect to.) Each request can be sent to any available server. The server executes the request and returns a single response that includes all the data. This is very similar to the way http works as a stateless protocol for the web. Each request from your web browser can be handled by a different web server process. =head2 Use Cases This may seem like pointless overhead but there are situations where this is a very good thing. Let's consider a specific case. Imagine using DBD::Gofer with an http transport. Your application calls connect(), prepare("select * from table where foo=?"), bind_param(), and execute(). At this point DBD::Gofer builds a request containing all the information about the method calls. It then uses the httpd transport to send that request to an apache web server. This 'dbi execute' web server executes the request (using DBI::Gofer::Execute and related modules) and builds a response that contains all the rows of data, if the statement returned any, along with all the attributes that describe the results, such as $sth->{NAME}. This response is sent back to DBD::Gofer which unpacks it and presents it to the application as if it had executed the statement itself. =head2 Advantages Okay, but you still don't see the point? Well let's consider what we've gained: =head3 Connection Pooling and Throttling The 'dbi execute' web server leverages all the functionality of web infrastructure in terms of load balancing, high-availability, firewalls, access management, proxying, caching. At its most basic level you get a configurable pool of persistent database connections. =head3 Simple Scaling Got thousands of processes all trying to connect to the database? You can use DBD::Gofer to connect them to your smaller pool of 'dbi execute' web servers instead. =head3 Caching Client-side caching is as simple as adding "C" to the DSN. This feature alone can be worth using DBD::Gofer for. =head3 Fewer Network Round-trips DBD::Gofer sends as few requests as possible (dependent on the policy being used). =head3 Thin Clients / Unsupported Platforms You no longer need drivers for your database on every system. DBD::Gofer is pure perl. =head1 CONSTRAINTS There are some natural constraints imposed by the DBD::Gofer 'stateless' approach. But not many: =head2 You can't change database handle attributes after connect() You can't change database handle attributes after you've connected. Use the connect() call to specify all the attribute settings you want. This is because it's critical that when a request is complete the database handle is left in the same state it was when first connected. An exception is made for attributes with names starting "C": They can be set after connect() but the change is only applied locally. =head2 You can't change statement handle attributes after prepare() You can't change statement handle attributes after prepare. An exception is made for attributes with names starting "C": They can be set after prepare() but the change is only applied locally. =head2 You can't use transactions AutoCommit only. Transactions aren't supported. (In theory transactions could be supported when using a transport that maintains a connection, like C does. If you're interested in this please get in touch via dbi-dev@perl.org) =head2 You can't call driver-private sth methods But that's rarely needed anyway. =head1 GENERAL CAVEATS A few important things to keep in mind when using DBD::Gofer: =head2 Temporary tables, locks, and other per-connection persistent state You shouldn't expect any per-session state to persist between requests. This includes locks and temporary tables. Because the server-side may execute your requests via a different database connections, you can't rely on any per-connection persistent state, such as temporary tables, being available from one request to the next. This is an easy trap to fall into. A good way to check for this is to test your code with a Gofer policy package that sets the C policy to 'connect' to force a new connection for each request. The C policy does this. =head2 Driver-private Database Handle Attributes Some driver-private dbh attributes may not be available if the driver has not implemented the private_attribute_info() method (added in DBI 1.54). =head2 Driver-private Statement Handle Attributes Driver-private sth attributes can be set in the prepare() call. TODO Some driver-private sth attributes may not be available if the driver has not implemented the private_attribute_info() method (added in DBI 1.54). =head2 Multiple Resultsets Multiple resultsets are supported only if the driver supports the more_results() method (an exception is made for DBD::Sybase). =head2 Statement activity that also updates dbh attributes Some drivers may update one or more dbh attributes after performing activity on a child sth. For example, DBD::mysql provides $dbh->{mysql_insertid} in addition to $sth->{mysql_insertid}. Currently mysql_insertid is supported via a hack but a more general mechanism is needed for other drivers to use. =head2 Methods that report an error always return undef With DBD::Gofer, a method that sets an error always return an undef or empty list. That shouldn't be a problem in practice because the DBI doesn't define any methods that return meaningful values while also reporting an error. =head2 Subclassing only applies to client-side The RootClass and DbTypeSubclass attributes are not passed to the Gofer server. =head1 CAVEATS FOR SPECIFIC METHODS =head2 last_insert_id To enable use of last_insert_id you need to indicate to DBD::Gofer that you'd like to use it. You do that my adding a C attribute to the do() or prepare() method calls. For example: $dbh->do($sql, { go_last_insert_id_args => [...] }); or $sth = $dbh->prepare($sql, { go_last_insert_id_args => [...] }); The array reference should contains the args that you want passed to the last_insert_id() method. =head2 execute_for_fetch The array methods bind_param_array() and execute_array() are supported. When execute_array() is called the data is serialized and executed in a single round-trip to the Gofer server. This makes it very fast, but requires enough memory to store all the serialized data. The execute_for_fetch() method currently isn't optimised, it uses the DBI fallback behaviour of executing each tuple individually. (It could be implemented as a wrapper for execute_array() - patches welcome.) =head1 TRANSPORTS DBD::Gofer doesn't concern itself with transporting requests and responses to and fro. For that it uses special Gofer transport modules. Gofer transport modules usually come in pairs: one for the 'client' DBD::Gofer driver to use and one for the remote 'server' end. They have very similar names: DBD::Gofer::Transport:: DBI::Gofer::Transport:: Sometimes the transports on the DBD and DBI sides may have different names. For example DBD::Gofer::Transport::http is typically used with DBI::Gofer::Transport::mod_perl (DBD::Gofer::Transport::http and DBI::Gofer::Transport::mod_perl modules are part of the GoferTransport-http distribution). =head2 Bundled Transports Several transport modules are provided with DBD::Gofer: =head3 null The null transport is the simplest of them all. It doesn't actually transport the request anywhere. It just serializes (freezes) the request into a string, then thaws it back into a data structure before passing it to DBI::Gofer::Execute to execute. The same freeze and thaw is applied to the results. The null transport is the best way to test if your application will work with Gofer. Just set the DBI_AUTOPROXY environment variable to "C" (see L below) and run your application, or ideally its test suite, as usual. It doesn't take any parameters. =head3 pipeone The pipeone transport launches a subprocess for each request. It passes in the request and reads the response. The fact that a new subprocess is started for each request ensures that the server side is truly stateless. While this does make the transport I slow, it is useful as a way to test that your application doesn't depend on per-connection state, such as temporary tables, persisting between requests. It's also useful both as a proof of concept and as a base class for the stream driver. =head3 stream The stream driver also launches a subprocess and writes requests and reads responses, like the pipeone transport. In this case, however, the subprocess is expected to handle more that one request. (Though it will be automatically restarted if it exits.) This is the first transport that is truly useful because it can launch the subprocess on a remote machine using C. This means you can now use DBD::Gofer to easily access any databases that's accessible from any system you can login to. You also get all the benefits of ssh, including encryption and optional compression. See L below for an example. =head2 Other Transports Implementing a Gofer transport is I simple, and more transports are very welcome. Just take a look at any existing transports that are similar to your needs. =head3 http See the GoferTransport-http distribution on CPAN: http://search.cpan.org/dist/GoferTransport-http/ =head3 Gearman I know Ask Bjørn Hansen has implemented a transport for the C distributed job system, though it's not on CPAN at the time of writing this. =head1 CONNECTING Simply prefix your existing DSN with "C" where $transport is the name of the Gofer transport you want to use (see L). The C and C attributes must be specified and the C attributes must be last. Other attributes can be specified in the DSN to configure DBD::Gofer and/or the Gofer transport module being used. The main attributes after C, are C and C. These and other attributes are described below. =head2 Using DBI_AUTOPROXY The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment variable. In this case you don't include the C part. For example: export DBI_AUTOPROXY="dbi:Gofer:transport=null" or, for a more useful example, try: export DBI_AUTOPROXY="dbi:Gofer:transport=stream;url=ssh:user@example.com" =head2 Connection Attributes These attributes can be specified in the DSN. They can also be passed in the \%attr parameter of the DBI connect method by adding a "C" prefix to the name. =head3 transport Specifies the Gofer transport class to use. Required. See L above. If the value does not include C<::> then "C" is prefixed. The transport object can be accessed via $h->{go_transport}. =head3 dsn Specifies the DSN for the remote side to connect to. Required, and must be last. =head3 url Used to tell the transport where to connect to. The exact form of the value depends on the transport used. =head3 policy Specifies the policy to use. See L. If the value does not include C<::> then "C" is prefixed. The policy object can be accessed via $h->{go_policy}. =head3 timeout Specifies a timeout, in seconds, to use when waiting for responses from the server side. =head3 retry_limit Specifies the number of times a failed request will be retried. Default is 0. =head3 retry_hook Specifies a code reference to be called to decide if a failed request should be retried. The code reference is called like this: $transport = $h->{go_transport}; $retry = $transport->go_retry_hook->($request, $response, $transport); If it returns true then the request will be retried, up to the C. If it returns a false but defined value then the request will not be retried. If it returns undef then the default behaviour will be used, as if C had not been specified. The default behaviour is to retry requests where $request->is_idempotent is true, or the error message matches C. =head3 cache Specifies that client-side caching should be performed. The value is the name of a cache class to use. Any class implementing get($key) and set($key, $value) methods can be used. That includes a great many powerful caching classes on CPAN, including the Cache and Cache::Cache distributions. You can use "C" is a shortcut for "C". See L for a description of this simple fast default cache. The cache object can be accessed via $h->go_cache. For example: $dbh->go_cache->clear; # free up memory being used by the cache The cache keys are the frozen (serialized) requests, and the values are the frozen responses. The default behaviour is to only use the cache for requests where $request->is_idempotent is true (i.e., the dbh has the ReadOnly attribute set or the SQL statement is obviously a SELECT without a FOR UPDATE clause.) For even more control you can use the C attribute to pass in an instantiated cache object. Individual methods, including prepare(), can also specify alternative caches via the C attribute. For example, to specify no caching for a particular query, you could use $sth = $dbh->prepare( $sql, { go_cache => 0 } ); This can be used to implement different caching policies for different statements. It's interesting to note that DBD::Gofer can be used to add client-side caching to any (gofer compatible) application, with no code changes and no need for a gofer server. Just set the DBI_AUTOPROXY environment variable like this: DBI_AUTOPROXY='dbi:Gofer:transport=null;cache=1' =head1 CONFIGURING BEHAVIOUR POLICY DBD::Gofer supports a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. The L class is the base class for all the policy packages and describes all the available policies. Three policy packages are supplied with DBD::Gofer: L is most 'transparent' but slowest because it makes more round-trips to the Gofer server. L is a reasonable compromise - it's the default policy. L is fastest, but may require code changes in your applications. Generally the default C policy is fine. When first testing an existing application with Gofer it is a good idea to start with the C policy first and then switch to C or a custom policy, for final testing. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 ACKNOWLEDGEMENTS The development of DBD::Gofer and related modules was sponsored by Shopzilla.com (L), where I currently work. =head1 SEE ALSO L, L, L. L, L. L =head1 Caveats for specific drivers This section aims to record issues to be aware of when using Gofer with specific drivers. It usually only documents issues that are not natural consequences of the limitations of the Gofer approach - as documented above. =head1 TODO This is just a random brain dump... (There's more in the source of the Changes file, not the pod) Document policy mechanism Add mechanism for transports to list config params and for Gofer to apply any that match (and warn if any left over?) Driver-private sth attributes - set via prepare() - change DBI spec add hooks into transport base class for checking & updating a result set cache ie via a standard cache interface such as: http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm http://search.cpan.org/~bradfitz/Cache-Memcached/lib/Cache/Memcached.pm http://search.cpan.org/~dclinton/Cache-Cache/ http://search.cpan.org/~cleishman/Cache/ Also caching instructions could be passed through the httpd transport layer in such a way that appropriate http cache headers are added to the results so that web caches (squid etc) could be used to implement the caching. (MUST require the use of GET rather than POST requests.) Rework handling of installed_methods to not piggyback on dbh_attributes? Perhaps support transactions for transports where it's possible (ie null and stream)? Would make stream transport (ie ssh) more useful to more people. Make sth_result_attr more like dbh_attributes (using '*' etc) Add @val = FETCH_many(@names) to DBI in C and use in Gofer/Execute? Implement _new_sth in C. =cut DBI-1.652/lib/DBD/Mem.pm0000644000031300001440000002331415225415266013610 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # # DBD::Mem - A DBI driver for in-memory tables # # This module is currently maintained by # # Jens Rehsack # # Copyright (C) 2016,2017 by Jens Rehsack # # All rights reserved. # # You may distribute this module under the terms of either the GNU # General Public License or the Artistic License, as specified in # the Perl README file. require 5.012; use strict; ################# package DBD::Mem; ################# use base qw( DBI::DBD::SqlEngine ); our $drh; our $VERSION = '0.001'; our $ATTRIBUTION = 'DBD::Mem by Jens Rehsack'; # no need to have driver() unless you need private methods # sub driver ($;$) { my ( $class, $attr ) = @_; return $drh if ($drh); # do the real work in DBI::DBD::SqlEngine # $attr->{Attribution} = 'DBD::Mem by Jens Rehsack'; $drh = $class->SUPER::driver($attr); return $drh; } sub CLONE { undef $drh; } ##################### package DBD::Mem::dr; ##################### our $imp_data_size = 0; our @ISA = qw(DBI::DBD::SqlEngine::dr); # you could put some :dr private methods here # you may need to over-ride some DBI::DBD::SqlEngine::dr methods here # but you can probably get away with just letting it do the work # in most cases ##################### package DBD::Mem::db; ##################### our $imp_data_size = 0; our @ISA = qw(DBI::DBD::SqlEngine::db); use Carp qw/carp/; sub set_versions { my $this = $_[0]; $this->{mem_version} = $DBD::Mem::VERSION; return $this->SUPER::set_versions(); } sub init_valid_attributes { my $dbh = shift; # define valid private attributes # # attempts to set non-valid attrs in connect() or # with $dbh->{attr} will throw errors # # the attrs here *must* start with mem_ or foo_ # # see the STORE methods below for how to check these attrs # $dbh->{mem_valid_attrs} = { mem_version => 1, # verbose DBD::Mem version mem_valid_attrs => 1, # DBD::Mem::db valid attrs mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs mem_meta => 1, # DBD::Mem public access for f_meta mem_tables => 1, # DBD::Mem public access for f_meta }; $dbh->{mem_readonly_attrs} = { mem_version => 1, # verbose DBD::Mem version mem_valid_attrs => 1, # DBD::Mem::db valid attrs mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs mem_meta => 1, # DBD::Mem public access for f_meta }; $dbh->{mem_meta} = "mem_tables"; return $dbh->SUPER::init_valid_attributes(); } sub get_mem_versions { my ( $dbh, $table ) = @_; $table ||= ''; my $meta; my $class = $dbh->{ImplementorClass}; $class =~ s/::db$/::Table/; $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) ); return sprintf( "%s using %s", $dbh->{mem_version}, $AnyData2::VERSION ); } package DBD::Mem::st; use strict; use warnings; our $imp_data_size = 0; our @ISA = qw(DBI::DBD::SqlEngine::st); ############################ package DBD::Mem::Statement; ############################ our @ISA = qw(DBI::DBD::SqlEngine::Statement); sub open_table ($$$$$) { my ( $self, $data, $table, $createMode, $lockMode ) = @_; my $class = ref $self; $class =~ s/::Statement/::Table/; my $flags = { createMode => $createMode, lockMode => $lockMode, }; if( defined( $data->{Database}->{mem_table_data}->{$table} ) && $data->{Database}->{mem_table_data}->{$table}) { my $t = $data->{Database}->{mem_tables}->{$table}; $t->seek( $data, 0, 0 ); return $t; } return $self->SUPER::open_table($data, $table, $createMode, $lockMode); } # ====== DataSource ============================================================ package DBD::Mem::DataSource; use strict; use warnings; use Carp; our @ISA = "DBI::DBD::SqlEngine::DataSource"; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; $table; } sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; $meta->{data_tbl} //= []; } ######################## package DBD::Mem::Table; ######################## # shamelessly stolen from SQL::Statement::RAM use Carp qw/croak/; our @ISA = qw(DBI::DBD::SqlEngine::Table); use Carp qw(croak); sub new { #my ( $class, $tname, $col_names, $data_tbl ) = @_; my ( $class, $data, $attrs, $flags ) = @_; my $self = $class->SUPER::new($data, $attrs, $flags); my $meta = $self->{meta}; $self->{records} = $meta->{data_tbl}; $self->{index} = 0; $self; } sub bootstrap_table_meta { my ( $self, $dbh, $meta, $table ) = @_; $meta->{sql_data_source} //= "DBD::Mem::DataSource"; $meta; } sub fetch_row { my ( $self, $data ) = @_; return $self->{row} = ( $self->{records} and ( $self->{index} < scalar( @{ $self->{records} } ) ) ) ? [ @{ $self->{records}->[ $self->{index}++ ] } ] : undef; } sub push_row { my ( $self, $data, $fields ) = @_; my $currentRow = $self->{index}; $self->{index} = $currentRow + 1; $self->{records}->[$currentRow] = $fields; return 1; } sub truncate { my $self = shift; return splice @{ $self->{records} }, $self->{index}, 1; } sub push_names { my ( $self, $data, $names ) = @_; my $meta = $self->{meta}; $meta->{col_names} = $self->{col_names} = $names; $self->{org_col_names} = [ @{$names} ]; $self->{col_nums} = {}; $self->{col_nums}{ $names->[$_] } = $_ for ( 0 .. scalar @$names - 1 ); } sub drop ($) { my ($self, $data) = @_; delete $data->{Database}{sql_meta}{$self->{table}}; return 1; } # drop sub seek { my ( $self, $data, $pos, $whence ) = @_; return unless defined $self->{records}; my ($currentRow) = $self->{index}; if ( $whence == 0 ) { $currentRow = $pos; } elsif ( $whence == 1 ) { $currentRow += $pos; } elsif ( $whence == 2 ) { $currentRow = @{ $self->{records} } + $pos; } else { croak $self . "->seek: Illegal whence argument ($whence)"; } $currentRow < 0 and croak "Illegal row number: $currentRow"; $self->{index} = $currentRow; } 1; =head1 NAME DBD::Mem - a DBI driver for Mem & MLMem files =head1 SYNOPSIS use DBI; $dbh = DBI->connect('dbi:Mem:', undef, undef, {}); $dbh = DBI->connect('dbi:Mem:', undef, undef, {RaiseError => 1}); # or $dbh = DBI->connect('dbi:Mem:'); $dbh = DBI->connect('DBI:Mem(RaiseError=1):'); and other variations on connect() as shown in the L docs and . Use standard DBI prepare, execute, fetch, placeholders, etc. =head1 DESCRIPTION DBD::Mem is a database management system that works right out of the box. If you have a standard installation of Perl and DBI you can begin creating, accessing, and modifying simple database tables without any further modules. You can add other modules (e.g., SQL::Statement) for improved functionality. DBD::Mem doesn't store any data persistently - all data has the lifetime of the instantiated C<$dbh>. The main reason to use DBD::Mem is to use extended features of L where temporary tables are required. One can use DBD::Mem to simulate C or sub-queries. Bundling C with L will allow us further compatibility checks of L beyond the capabilities of L and L. This will ensure DBI provided basis for drivers like L or L are better prepared and tested for not-file based backends. =head2 Metadata There're no new meta data introduced by C. See L for full description. =head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS If you need help installing or using DBD::Mem, please write to the DBI users mailing list at L or to the comp.lang.perl.modules newsgroup on usenet. I cannot always answer every question quickly but there are many on the mailing list or in the newsgroup who can. DBD developers for DBD's which rely on DBI::DBD::SqlEngine or DBD::Mem or use one of them as an example are suggested to join the DBI developers mailing list at L and strongly encouraged to join our IRC channel at L. If you have suggestions, ideas for improvements, or bugs to report, please report a bug as described in DBI. Do not mail any of the authors directly, you might not get an answer. When reporting bugs, please send the output of C<< $dbh->mem_versions($table) >> for a table that exhibits the bug and as small a sample as you can make of the code that produces the bug. And of course, patches are welcome, too :-). If you need enhancements quickly, you can get commercial support as described at L or you can contact Jens Rehsack at rehsack@cpan.org for commercial support. =head1 AUTHOR AND COPYRIGHT This module is written by Jens Rehsack < rehsack AT cpan.org >. Copyright (c) 2016- by Jens Rehsack, all rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L for the Database interface of the Perl Programming Language. L and L for the available SQL engines. L where the implementation is shamelessly stolen from to allow DBI bundled Pure-Perl drivers increase the test coverage. L using C for an incredible fast in-memory database engine. =cut DBI-1.652/lib/DBD/Sponge.pm0000644000031300001440000002110415206024306014306 0ustar00merijnusersuse strict; use warnings; { package DBD::Sponge; require DBI; require Carp; our @EXPORT = qw(); # Do NOT @EXPORT anything. our $VERSION = "12.010003"; # $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $ # # Copyright (c) 1994-2003 Tim Bunce Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. our $drh = undef; # holds driver handle once initialised my $methods_already_installed; sub driver{ return $drh if $drh; DBD::Sponge::db->install_method("sponge_test_installed_method") unless $methods_already_installed++; my($class, $attr) = @_; $class .= "::dr"; ($drh) = DBI::_new_drh($class, { 'Name' => 'Sponge', 'Version' => $VERSION, 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", }); $drh; } sub CLONE { undef $drh; } } { package DBD::Sponge::dr; # ====== DRIVER ====== our $imp_data_size = 0; # we use default (dummy) connect method } { package DBD::Sponge::db; # ====== DATABASE ====== our $imp_data_size = 0; use strict; sub prepare { my($dbh, $statement, $attribs) = @_; my $rows = delete $attribs->{'rows'} or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare"); my ($outer, $sth) = DBI::_new_sth($dbh, { 'Statement' => $statement, 'rows' => $rows, (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } qw(execute_hook) ), }); if (my $behave_like = $attribs->{behave_like}) { $outer->{$_} = $behave_like->{$_} foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); } if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() $sth->{is_insert} = 1; my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); } else { #assume select # we need to set NUM_OF_FIELDS my $numFields; if ($attribs->{'NUM_OF_FIELDS'}) { $numFields = $attribs->{'NUM_OF_FIELDS'}; } elsif ($attribs->{'NAME'}) { $numFields = @{$attribs->{NAME}}; } elsif ($attribs->{'TYPE'}) { $numFields = @{$attribs->{TYPE}}; } elsif (my $firstrow = $rows->[0]) { $numFields = scalar @$firstrow; } else { return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); } $sth->STORE('NUM_OF_FIELDS' => $numFields); $sth->{NAME} = $attribs->{NAME} || [ map { "col$_" } 1..$numFields ]; $sth->{TYPE} = $attribs->{TYPE} || [ (DBI::SQL_VARCHAR()) x $numFields ]; $sth->{SCALE} = $attribs->{SCALE} || [ (0) x $numFields ]; $sth->{NULLABLE} = $attribs->{NULLABLE} || [ (2) x $numFields ]; # Allow user to specify precision, otherwise # FETCH will lazily compute if needed if ($attribs->{PRECISION}) { $sth->{PRECISION} = $attribs->{PRECISION}; } } $outer; } sub type_info_all { my ($dbh) = @_; my $ti = [ { TYPE_NAME => 0, DATA_TYPE => 1, PRECISION => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE=> 9, MONEY => 10, AUTO_INCREMENT => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, }, [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], ]; return $ti; } sub FETCH { my ($dbh, $attrib) = @_; # In reality this would interrogate the database engine to # either return dynamic values that cannot be precomputed # or fetch and cache attribute values too expensive to prefetch. return 1 if $attrib eq 'AutoCommit'; # else pass up to DBI to handle return $dbh->SUPER::FETCH($attrib); } sub STORE { my ($dbh, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle if ($attrib eq 'AutoCommit') { return 1 if $value; # is already set Carp::croak("Can't disable AutoCommit"); } return $dbh->SUPER::STORE($attrib, $value); } sub sponge_test_installed_method { my ($dbh, @args) = @_; return $dbh->set_err(42, "not enough parameters") unless @args >= 2; return \@args; } } { package DBD::Sponge::st; # ====== STATEMENT ====== our $imp_data_size = 0; use strict; sub execute { my $sth = shift; # hack to support ParamValues (when not using bind_param) $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; if (my $hook = $sth->{execute_hook}) { &$hook($sth, @_) or return; } if ($sth->{is_insert}) { my $row; $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") if @$row != $NUM_OF_PARAMS; { no warnings; $sth->trace_msg("inserting (@$row)\n"); } push @{ $sth->{rows} }, $row; } else { # mark select sth as Active $sth->STORE(Active => 1); } # else do nothing for select as data is already in $sth->{rows} return 1; } sub fetch { my ($sth) = @_; my $row = shift @{$sth->{'rows'}}; unless ($row) { $sth->STORE(Active => 0); return undef; } return $sth->_set_fbav($row); } *fetchrow_arrayref = \&fetch; sub FETCH { my ($sth, $attrib) = @_; # would normally validate and only fetch known attributes # else pass up to DBI to handle if ($attrib eq 'PRECISION') { # prepare() did _not_ specify PRECISION, so lazily compute it now return $sth->{PRECISION} = _max_col_lengths(@{$sth}{'NUM_OF_FIELDS', 'rows'}); } return $sth->SUPER::FETCH($attrib); } sub STORE { my ($sth, $attrib, $value) = @_; # would normally validate and only store known attributes # else pass up to DBI to handle return $sth->SUPER::STORE($attrib, $value); } sub _max_col_lengths { # compute our columns' PRECISION (data length) by looking for the # max lengths of each column's data, row by row my ($num_of_fields, $rows) = @_; my @precision = (0,) x $num_of_fields; my $n = $num_of_fields - 1; my $len; for my $row (@$rows) { for my $i (0 .. $n) { next unless defined($len = length($row->[$i])); $precision[$i] = $len if $len > $precision[$i]; } } return \@precision; } } 1; __END__ =pod =head1 NAME DBD::Sponge - Create a DBI statement handle from Perl data =head1 SYNOPSIS my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); my $sth = $sponge->prepare($statement, { rows => $data, NAME => $names, %attr } ); =head1 DESCRIPTION DBD::Sponge is useful for making a Perl data structure accessible through a standard DBI statement handle. This may be useful to DBD module authors who need to transform data in this way. =head1 METHODS =head2 connect() my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); Here's a sample syntax for creating a database handle for the Sponge driver. No username and password are needed. =head2 prepare() my $sth = $sponge->prepare($statement, { rows => $data, NAME => $names, %attr } ); =over 4 =item * The C<$statement> here is an arbitrary statement or name you want to provide as identity of your data. If you're using DBI::Profile it will appear in the profile data. Generally it's expected that you are preparing a statement handle as if a C
for gotchas and warnings about the use of flock(). =head1 BUGS AND LIMITATIONS This module uses hash interfaces of two column file databases. While none of supported SQL engines have support for indices, the following statements really do the same (even if they mean something completely different) for each dbm type which lacks C support: $sth->do( "insert into foo values (1, 'hello')" ); # this statement does ... $sth->do( "update foo set v='world' where k=1" ); # ... the same as this statement $sth->do( "insert into foo values (1, 'world')" ); This is considered to be a bug and might change in a future release. Known affected dbm types are C and C. We highly recommended you use a more modern dbm type such as C. =head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS If you need help installing or using DBD::DBM, please write to the DBI users mailing list at dbi-users@perl.org or to the comp.lang.perl.modules newsgroup on usenet. I cannot always answer every question quickly but there are many on the mailing list or in the newsgroup who can. DBD developers for DBD's which rely on DBD::File or DBD::DBM or use one of them as an example are suggested to join the DBI developers mailing list at dbi-dev@perl.org and strongly encouraged to join our IRC channel at L. If you have suggestions, ideas for improvements, or bugs to report, please report a bug as described in DBI. Do not mail any of the authors directly, you might not get an answer. When reporting bugs, please send the output of $dbh->dbm_versions($table) for a table that exhibits the bug and as small a sample as you can make of the code that produces the bug. And of course, patches are welcome, too :-). If you need enhancements quickly, you can get commercial support as described at L or you can contact Jens Rehsack at rehsack@cpan.org for commercial support in Germany. Please don't bother Jochen Wiedmann or Jeff Zucker for support - they handed over further maintenance to H.Merijn Brand and Jens Rehsack. =head1 ACKNOWLEDGEMENTS Many, many thanks to Tim Bunce for prodding me to write this, and for copious, wise, and patient suggestions all along the way. (Jeff Zucker) I send my thanks and acknowledgements to H.Merijn Brand for his initial refactoring of DBD::File and his strong and ongoing support of SQL::Statement. Without him, the current progress would never have been made. And I have to name Martin J. Evans for each laugh (and correction) of all those funny word creations I (as non-native speaker) made to the documentation. And - of course - I have to thank all those unnamed contributors and testers from the Perl community. (Jens Rehsack) =head1 AUTHOR AND COPYRIGHT This module is written by Jeff Zucker < jzucker AT cpan.org >, who also maintained it till 2007. After that, in 2010, Jens Rehsack & H.Merijn Brand took over maintenance. Copyright (c) 2004 by Jeff Zucker, all rights reserved. Copyright (c) 2010-2013 by Jens Rehsack & H.Merijn Brand, all rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L, L, L, L, L, L, L, L, L =cut DBI-1.652/lib/DBD/Proxy.pm0000644000031300001440000007056715225414740014223 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # # # DBD::Proxy - DBI Proxy driver # # # Copyright (c) 1997,1998 Jochen Wiedmann # # The DBD::Proxy module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. In particular permission # is granted to Tim Bunce for distributing this as a part of the DBI. # # # Author: Jochen Wiedmann # Am Eisteich 9 # 72555 Metzingen # Germany # # Email: joe@ispsoft.de # Phone: +49 7123 14881 # use strict; use warnings; use Carp; require DBI; DBI->require_version(1.0201); use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released { package DBD::Proxy::RPC::PlClient; our @ISA = qw(RPC::PlClient); sub Call { my $self = shift; if ($self->{debug}) { my ($rpcmeth, $obj, $method, @args) = @_; no warnings; # silence undefs Carp::carp("Server $rpcmeth $method(@args)"); } return $self->SUPER::Call(@_); } } package DBD::Proxy; our $VERSION = "0.2004"; our $drh = undef; # holds driver handle once initialised our %ATTR = ( # common to db & st, see also %ATTR in DBD::Proxy::db & ::st 'Warn' => 'local', 'Active' => 'local', 'Kids' => 'local', 'CachedKids' => 'local', 'PrintError' => 'local', 'RaiseError' => 'local', 'HandleError' => 'local', 'TraceLevel' => 'cached', 'CompatMode' => 'local', ); sub driver ($$) { if (!$drh) { my($class, $attr) = @_; $class .= "::dr"; $drh = DBI::_new_drh($class, { 'Name' => 'Proxy', 'Version' => $VERSION, 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', }); $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) } $drh; } sub CLONE { undef $drh; } sub proxy_set_err { my ($h,$errmsg) = @_; my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//) ? ($1, $2) : (1, ' ' x 5); return $h->set_err($err, $errmsg, $state); } package DBD::Proxy::dr; # ====== DRIVER ====== our $imp_data_size = 0; sub connect ($$;$$) { my($drh, $dsn, $user, $auth, $attr)= @_; my($dsnOrig) = $dsn; my %attr = %$attr; my ($var, $val); while (length($dsn)) { if ($dsn =~ /^dsn=(.*)/) { $attr{'dsn'} = $1; last; } if ($dsn =~ /^(.*?);(.*)/) { $var = $1; $dsn = $2; } else { $var = $dsn; $dsn = ''; } if ($var =~ /^(.*?)=(.*)/) { $var = $1; $val = $2; $attr{$var} = $val; } } my $err = ''; if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } if (!defined($attr{'port'})) { $err .= " Missing port."; } if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } # Create a cipher object, if requested my $cipherRef = undef; if ($attr{'cipher'}) { $cipherRef = eval { $attr{'cipher'}->new(pack('H*', $attr{'key'})) }; if ($@) { $err .= " Cannot create cipher object: $@."; } } my $userCipherRef = undef; if ($attr{'userkey'}) { my $cipher = $attr{'usercipher'} || $attr{'cipher'}; $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; if ($@) { $err .= " Cannot create usercipher object: $@."; } } return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef my %client_opts = ( 'peeraddr' => $attr{'hostname'}, 'peerport' => $attr{'port'}, 'socket_proto' => 'tcp', 'application' => $attr{dsn}, 'user' => $user || '', 'password' => $auth || '', 'version' => $DBD::Proxy::VERSION, 'cipher' => $cipherRef, 'debug' => $attr{debug} || 0, 'timeout' => $attr{timeout} || undef, 'logfile' => $attr{logfile} || undef ); # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after # stripping the prefix. while (my($var,$val) = each %attr) { if ($var =~ s/^proxy_rpc_//) { $client_opts{$var} = $val; } } # Create an RPC::PlClient object. my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) }; return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@") if $@; # Returns undef return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg") unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef $msg = RPC::PlClient::Object->new($1, $client, $msg); my $max_proto_ver; my ($server_ver_str) = eval { $client->Call('Version') }; if ( $@ ) { # Server denies call, assume legacy protocol. $max_proto_ver = 1; } else { # Parse proxy server version. my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/; $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1; } my $req_proto_ver; if ( exists $attr{proxy_lazy_prepare} ) { $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1; return DBD::Proxy::proxy_set_err($drh, "DBI::ProxyServer does not support synchronous statement preparation.") if $max_proto_ver < $req_proto_ver; } # Switch to user specific encryption mode, if desired if ($userCipherRef) { $client->{'cipher'} = $userCipherRef; } # create a 'blank' dbh my $this = DBI::_new_dbh($drh, { 'Name' => $dsnOrig, 'proxy_dbh' => $msg, 'proxy_client' => $client, 'RowCacheSize' => $attr{'RowCacheSize'} || 20, 'proxy_proto_ver' => $req_proto_ver || 1 }); foreach $var (keys %attr) { if ($var =~ /proxy_/) { $this->{$var} = $attr{$var}; } } $this->SUPER::STORE('Active' => 1); $this; } sub DESTROY { undef } package DBD::Proxy::db; # ====== DATABASE ====== our $imp_data_size = 0; # XXX probably many more methods need to be added here # in order to trigger our AUTOLOAD to redirect them to the server. # (Unless the sub is declared it's bypassed by perl method lookup.) # See notes in ToDo about method metadata # The question is whether to add all the methods in %DBI::DBI_methods # to the corresponding classes (::db, ::st etc) # Also need to consider methods that, if proxied, would change the server state # in a way that might not be visible on the client, ie begin_work -> AutoCommit. sub commit; sub rollback; sub ping; our $AUTOLOAD; # inherited: STORE / FETCH against this class. # local: STORE / FETCH against parent class. # cached: STORE to remote and local objects, FETCH from local. # remote: STORE / FETCH against remote object only (default). # # Note: Attribute names starting with 'proxy_' always treated as 'inherited'. # our %ATTR = ( # see also %ATTR in DBD::Proxy::st %DBD::Proxy::ATTR, RowCacheSize => 'inherited', #AutoCommit => 'cached', 'FetchHashKeyName' => 'cached', Statement => 'local', Driver => 'local', dbi_connect_closure => 'local', Username => 'local', ); sub AUTOLOAD { my $method = $AUTOLOAD; $method =~ s/(.*::(.*)):://; my $class = $1; my $type = $2; #warn "AUTOLOAD of $method (class=$class, type=$type)"; my %expand = ( 'method' => $method, 'class' => $class, 'type' => $type, 'call' => "$method(\@_)", # XXX was trying to be smart but was tripping up over the DBI's own # smartness. Disabled, but left here in case there are issues. # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')", ); my $method_code = q{ package ~class~; sub ~method~ { my $h = shift; local $@; my @result = wantarray ? eval { $h->{'proxy_~type~h'}->~call~ } : eval { scalar $h->{'proxy_~type~h'}->~call~ }; return DBD::Proxy::proxy_set_err($h, $@) if $@; return wantarray ? @result : $result[0]; } }; $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; local $SIG{__DIE__} = 'DEFAULT'; my $err = do { local $@; eval $method_code.2; $@ }; die $err if $err; goto &$AUTOLOAD; } sub DESTROY { my $dbh = shift; local $@ if $@; # protect $@ $dbh->disconnect if $dbh->SUPER::FETCH('Active'); } sub connected { } # client-side not server-side, RT#75868 sub disconnect ($) { my ($dbh) = @_; # Sadly the Proxy too-often disagrees with the backend database # on the subject of 'Active'. In the short term, I'd like the # Proxy to ease up and let me decide when it's proper to go over # the wire. This ultimately applies to finish() as well. #return unless $dbh->SUPER::FETCH('Active'); # Drop database connection at remote end my $rdbh = $dbh->{'proxy_dbh'}; if ( $rdbh ) { local $SIG{__DIE__} = 'DEFAULT'; local $@; eval { $rdbh->disconnect() } ; DBD::Proxy::proxy_set_err($dbh, $@) if $@; } # Close TCP connect to remote # XXX possibly best left till DESTROY? Add a config attribute to choose? #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module $dbh->{proxy_client}->{socket} = undef; # hack $dbh->SUPER::STORE('Active' => 0); 1; } sub STORE ($$$) { my($dbh, $attr, $val) = @_; my $type = $ATTR{$attr} || 'remote'; if ($attr eq 'TraceLevel') { warn("TraceLevel $val"); my $pc = $dbh->{proxy_client} || die; $pc->{logfile} ||= 1; # XXX hack $pc->{debug} = ($val && $val >= 4); $pc->Debug("$pc debug enabled") if $pc->{debug}; } if ($attr =~ /^proxy_/ || $type eq 'inherited') { $dbh->{$attr} = $val; return 1; } if ($type eq 'remote' || $type eq 'cached') { local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; return $result; } return $dbh->SUPER::STORE($attr => $val); } sub FETCH ($$) { my($dbh, $attr) = @_; # we only get here for cached attribute values if the handle is in CompatMode # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache. my $type = $ATTR{$attr} || 'remote'; if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { return $dbh->{$attr}; } return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; return DBD::Proxy::proxy_set_err($dbh, $@) if $@; return $result; } sub prepare ($$;$) { my($dbh, $stmt, $attr) = @_; my $sth = DBI::_new_sth($dbh, { 'Statement' => $stmt, 'proxy_attr' => $attr, 'proxy_cache_only' => 0, 'proxy_params' => [], } ); my $proto_ver = $dbh->{'proxy_proto_ver'}; if ( $proto_ver > 1 ) { $sth->{'proxy_attr_cache'} = {cache_filled => 0}; my $rdbh = $dbh->{'proxy_dbh'}; local $SIG{__DIE__} = 'DEFAULT'; local $@; my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); my $client = $dbh->{'proxy_client'}; $rsth = RPC::PlClient::Object->new($1, $client, $rsth); $sth->{'proxy_sth'} = $rsth; # If statement is a positioned update we do not want any readahead. $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i; # Since resources are used by prepared remote handle, mark us active. $sth->SUPER::STORE(Active => 1); } $sth; } sub quote { my $dbh = shift; my $proxy_quote = $dbh->{proxy_quote} || 'remote'; return $dbh->SUPER::quote(@_) if $proxy_quote eq 'local' && @_ == 1; # For the common case of only a single argument # (no $data_type) we could learn and cache the behaviour. # Or we could probe the driver with a few test cases. # Or we could add a way to ask the DBI::ProxyServer # if $dbh->can('quote') == \&DBI::_::db::quote. # Tim # # Sounds all *very* smart to me. I'd rather suggest to # implement some of the typical quote possibilities # and let the user set # $dbh->{'proxy_quote'} = 'backslash_escaped'; # for example. # Jochen local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; return DBD::Proxy::proxy_set_err($dbh, $@) if $@; return $result; } sub table_info { my $dbh = shift; my $rdbh = $dbh->{'proxy_dbh'}; #warn "table_info(@_)"; local $SIG{__DIE__} = 'DEFAULT'; local $@; my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; return DBD::Proxy::proxy_set_err($dbh, $@) if $@; my ($sth, $inner) = DBI::_new_sth($dbh, { 'Statement' => "SHOW TABLES", 'proxy_params' => [], 'proxy_data' => \@rows, 'proxy_attr_cache' => { 'NUM_OF_PARAMS' => 0, 'NUM_OF_FIELDS' => $numFields, 'NAME' => $names, 'TYPE' => $types, 'cache_filled' => 1 }, 'proxy_cache_only' => 1, }); $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); $inner->{NAME} = $names; $inner->{TYPE} = $types; $sth->SUPER::STORE('Active' => 1); # already execute()'d $sth->{'proxy_rows'} = @rows; return $sth; } sub tables { my $dbh = shift; #warn "tables(@_)"; return $dbh->SUPER::tables(@_); } sub type_info_all { my $dbh = shift; local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; return DBD::Proxy::proxy_set_err($dbh, $@) if $@; return $result; } package DBD::Proxy::st; # ====== STATEMENT ====== our $imp_data_size = 0; # inherited: STORE to current object. FETCH from current if exists, else call up # to the (proxy) database object. # local: STORE / FETCH against parent class. # cache_only: STORE noop (read-only). FETCH from private_* if exists, else call # remote and cache the result. # remote: STORE / FETCH against remote object only (default). # # Note: Attribute names starting with 'proxy_' always treated as 'inherited'. # our %ATTR = ( # see also %ATTR in DBD::Proxy::db %DBD::Proxy::ATTR, 'Database' => 'local', 'RowsInCache' => 'local', 'RowCacheSize' => 'inherited', 'NULLABLE' => 'cache_only', 'NAME' => 'cache_only', 'TYPE' => 'cache_only', 'PRECISION' => 'cache_only', 'SCALE' => 'cache_only', 'NUM_OF_FIELDS' => 'cache_only', 'NUM_OF_PARAMS' => 'cache_only' ); *AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; sub execute ($@) { my $sth = shift; my $params = @_ ? \@_ : $sth->{'proxy_params'}; # new execute, so delete any cached rows from previous execute undef $sth->{'proxy_data'}; undef $sth->{'proxy_rows'}; my $rsth = $sth->{proxy_sth}; my $dbh = $sth->FETCH('Database'); my $proto_ver = $dbh->{proxy_proto_ver}; my ($numRows, @outData); local $SIG{__DIE__} = 'DEFAULT'; local $@; if ( $proto_ver > 1 ) { ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; # Attributes passed back only on the first execute() of a statement. unless ($sth->{proxy_attr_cache}->{cache_filled}) { my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); $sth->{'proxy_attr_cache'} = { 'NUM_OF_FIELDS' => $numFields, 'NUM_OF_PARAMS' => $numParams, 'NAME' => $names, 'cache_filled' => 1 }; $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); } } else { if ($rsth) { ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; } else { my $rdbh = $dbh->{'proxy_dbh'}; # Legacy prepare is actually prepare + first execute on the server. ($rsth, @outData) = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, $params, $proto_ver) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); my $client = $dbh->{'proxy_client'}; $rsth = RPC::PlClient::Object->new($1, $client, $rsth); my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); $sth->{'proxy_sth'} = $rsth; $sth->{'proxy_attr_cache'} = { 'NUM_OF_FIELDS' => $numFields, 'NUM_OF_PARAMS' => $numParams, 'NAME' => $names }; $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); $numRows = shift @outData; } } # Always condition active flag. $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT $sth->{'proxy_rows'} = $numRows; # Any remaining items are output params. if (@outData) { foreach my $p (@$params) { if (ref($p->[0])) { my $ref = shift @outData; ${$p->[0]} = $$ref; } } } $sth->{'proxy_rows'} || '0E0'; } sub fetch ($) { my $sth = shift; my $data = $sth->{'proxy_data'}; $sth->{'proxy_rows'} //= 0; if(!$data || !@$data) { return undef unless $sth->SUPER::FETCH('Active'); my $rsth = $sth->{'proxy_sth'}; if (!$rsth) { die "Attempt to fetch row without execute"; } my $num_rows = $sth->FETCH('RowCacheSize') || 20; local $SIG{__DIE__} = 'DEFAULT'; local $@; my @rows = eval { $rsth->fetch($num_rows) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; unless (@rows == $num_rows) { undef $sth->{'proxy_data'}; # server side has already called finish $sth->SUPER::STORE(Active => 0); } return undef unless @rows; $sth->{'proxy_data'} = $data = [@rows]; } my $row = shift @$data; $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); $sth->{'proxy_rows'}++; return $sth->_set_fbav($row); } *fetchrow_arrayref = \&fetch; sub rows ($) { my $rows = shift->{'proxy_rows'}; return ($rows // -1); } sub finish ($) { my($sth) = @_; return 1 unless $sth->SUPER::FETCH('Active'); my $rsth = $sth->{'proxy_sth'}; $sth->SUPER::STORE('Active' => 0); return 0 unless $rsth; # Something's out of sync my $no_finish = exists($sth->{'proxy_no_finish'}) ? $sth->{'proxy_no_finish'} : $sth->FETCH('Database')->{'proxy_no_finish'}; unless ($no_finish) { local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $rsth->finish() }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; return $result; } 1; } sub STORE ($$$) { my($sth, $attr, $val) = @_; my $type = $ATTR{$attr} || 'remote'; if ($attr =~ /^proxy_/ || $type eq 'inherited') { $sth->{$attr} = $val; return 1; } if ($type eq 'cache_only') { return 0; } if ($type eq 'remote' || $type eq 'cached') { my $rsth = $sth->{'proxy_sth'} or return undef; local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $rsth->STORE($attr => $val) }; return DBD::Proxy::proxy_set_err($sth, $@) if ($@); return $result if $type eq 'remote'; # else fall through to cache locally } return $sth->SUPER::STORE($attr => $val); } sub FETCH ($$) { my($sth, $attr) = @_; if ($attr =~ /^proxy_/) { return $sth->{$attr}; } my $type = $ATTR{$attr} || 'remote'; if ($type eq 'inherited') { if (exists($sth->{$attr})) { return $sth->{$attr}; } return $sth->FETCH('Database')->{$attr}; } if ($type eq 'cache_only' && exists($sth->{'proxy_attr_cache'}->{$attr})) { return $sth->{'proxy_attr_cache'}->{$attr}; } if ($type ne 'local') { my $rsth = $sth->{'proxy_sth'} or return undef; local $SIG{__DIE__} = 'DEFAULT'; local $@; my $result = eval { $rsth->FETCH($attr) }; return DBD::Proxy::proxy_set_err($sth, $@) if $@; return $result; } elsif ($attr eq 'RowsInCache') { my $data = $sth->{'proxy_data'}; $data ? @$data : 0; } else { $sth->SUPER::FETCH($attr); } } sub bind_param ($$$@) { my $sth = shift; my $param = shift; $sth->{'proxy_params'}->[$param-1] = [@_]; } *bind_param_inout = \&bind_param; sub DESTROY { my $sth = shift; $sth->finish if $sth->SUPER::FETCH('Active'); } 1; __END__ =head1 NAME DBD::Proxy - A proxy driver for the DBI =head1 SYNOPSIS use DBI; $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", $user, $passwd); # See the DBI module documentation for full details =head1 DESCRIPTION DBD::Proxy is a Perl module for connecting to a database via a remote DBI driver. See L for an alternative with different trade-offs. This is of course not needed for DBI drivers which already support connecting to a remote database, but there are engines which don't offer network connectivity. Another application is offering database access through a firewall, as the driver offers query based restrictions. For example you can restrict queries to exactly those that are used in a given CGI application. Speaking of CGI, another application is (or rather, will be) to reduce the database connect/disconnect overhead from CGI scripts by using proxying the connect_cached method. The proxy server will hold the database connections open in a cache. The CGI script then trades the database connect/disconnect overhead for the DBD::Proxy connect/disconnect overhead which is typically much less. =head1 CONNECTING TO THE DATABASE Before connecting to a remote database, you must ensure, that a Proxy server is running on the remote machine. There's no default port, so you have to ask your system administrator for the port number. See L for details. Say, your Proxy server is running on machine "alpha", port 3334, and you'd like to connect to an ODBC database called "mydb" as user "joe" with password "hello". When using DBD::ODBC directly, you'd do a $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); With DBD::Proxy this becomes $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; $dbh = DBI->connect($dsn, "joe", "hello"); You see, this is mainly the same. The DBD::Proxy module will create a connection to the Proxy server on "alpha" which in turn will connect to the ODBC database. Refer to the L documentation on the C method for a way to automatically use DBD::Proxy without having to change your code. DBD::Proxy's DSN string has the format $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; In other words, it is a collection of key/value pairs. The following keys are recognized: =over 4 =item hostname =item port Hostname and port of the Proxy server; these keys must be present, no defaults. Example: hostname=alpha;port=3334 =item dsn The value of this attribute will be used as a dsn name by the Proxy server. Thus it must have the format C, in particular it will contain colons. The I value may contain semicolons, hence this key *must* be the last and it's value will be the complete remaining part of the dsn. Example: dsn=DBI:ODBC:mydb =item cipher =item key =item usercipher =item userkey By using these fields you can enable encryption. If you set, for example, cipher=$class;key=$key (note the semicolon) then DBD::Proxy will create a new cipher object by executing $cipherRef = $class->new(pack("H*", $key)); and pass this object to the RPC::PlClient module when creating a client. See L. Example: cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 The usercipher/userkey attributes allow you to use two phase encryption: The cipher/key encryption will be used in the login and authorisation phase. Once the client is authorised, he will change to usercipher/userkey encryption. Thus the cipher/key pair is a B based secret, typically less secure than the usercipher/userkey secret and readable by anyone. The usercipher/userkey secret is B private secret. Of course encryption requires an appropriately configured server. See L. =item debug Turn on debugging mode =item stderr This attribute will set the corresponding attribute of the RPC::PlClient object, thus logging will not use syslog(), but redirected to stderr. This is the default under Windows. stderr=1 =item logfile Similar to the stderr attribute, but output will be redirected to the given file. logfile=/dev/null =item RowCacheSize The DBD::Proxy driver supports this attribute (which is DBI standard, as of DBI 1.02). It's used to reduce network round-trips by fetching multiple rows in one go. The current default value is 20, but this may change. =item proxy_no_finish This attribute can be used to reduce network traffic: If the application is calling $sth->finish() then the proxy tells the server to finish the remote statement handle. Of course this slows down things quite a lot, but is perfectly good for reducing memory usage with persistent connections. However, if you set the I attribute to a TRUE value, either in the database handle or in the statement handle, then finish() calls will be suppressed. This is what you want, for example, in small and fast CGI applications. =item proxy_quote This attribute can be used to reduce network traffic: By default calls to $dbh->quote() are passed to the remote driver. Of course this slows down things quite a lot, but is the safest default behaviour. However, if you set the I attribute to the value 'C' either in the database handle or in the statement handle, and the call to quote has only one parameter, then the local default DBI quote method will be used (which will be faster but may be wrong). =back =head1 KNOWN ISSUES =head2 Unproxied method calls If a method isn't being proxied, try declaring a stub sub in the appropriate package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method). For example: sub DBD::Proxy::db::selectall_arrayref; That will enable selectall_arrayref to be proxied. Currently many methods aren't explicitly proxied and so you get the DBI's default methods executed on the client. Some of those methods, like selectall_arrayref, may then call other methods that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch which is proxied). So things may appear to work but operate more slowly than the could. This may all change in a later version. =head2 Complex handle attributes Sometimes handles are having complex attributes like hash refs or array refs and not simple strings or integers. For example, with DBD::CSV, you would like to write something like $dbh->{"csv_tables"}->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; The above example would advice the CSV driver to assume the file "passwd" to be in the format of the /etc/passwd file: Colons as separators and a line feed without carriage return as line terminator. Surprisingly this example doesn't work with the proxy driver. To understand the reasons, you should consider the following: The Perl compiler is executing the above example in two steps: =over =item 1 The first step is fetching the value of the key "csv_tables" in the handle $dbh. The value returned is complex, a hash ref. =item 2 The second step is storing some value (the right hand side of the assignment) as the key "passwd" in the hash ref from step 1. =back This becomes a little bit clearer, if we rewrite the above code: $tables = $dbh->{"csv_tables"}; $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; While the examples work fine without the proxy, the fail due to a subtle difference in step 1: By DBI magic, the hash ref $dbh->{'csv_tables'} is returned from the server to the client. The client creates a local copy. This local copy is the result of step 1. In other words, step 2 modifies a local copy of the hash ref, but not the server's hash ref. The workaround is storing the modified local copy back to the server: $tables = $dbh->{"csv_tables"}; $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; $dbh->{"csv_tables"} = $tables; =head1 SECURITY WARNING L used underneath is not secure due to serializing and deserializing data with L module. Use the proxy driver only in trusted environment. =head1 AUTHOR AND COPYRIGHT This module is Copyright (c) 1997, 1998 Jochen Wiedmann Am Eisteich 9 72555 Metzingen Germany Email: joe@ispsoft.de Phone: +49 7123 14887 The DBD::Proxy module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. In particular permission is granted to Tim Bunce for distributing this as a part of the DBI. =head1 SEE ALSO L, L, L =cut DBI-1.652/lib/DBI/0000755000031300001440000000000015240046615012531 5ustar00merijnusersDBI-1.652/lib/DBI/Gofer/0000755000031300001440000000000015240046615013573 5ustar00merijnusersDBI-1.652/lib/DBI/Gofer/Serializer/0000755000031300001440000000000015240046615015704 5ustar00merijnusersDBI-1.652/lib/DBI/Gofer/Serializer/DataDumper.pm0000644000031300001440000000243712153146731020276 0ustar00merijnuserspackage DBI::Gofer::Serializer::DataDumper; use strict; use warnings; our $VERSION = "0.009950"; # $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. =head1 NAME DBI::Gofer::Serializer::DataDumper - Gofer serialization using DataDumper =head1 SYNOPSIS $serializer = DBI::Gofer::Serializer::DataDumper->new(); $string = $serializer->serialize( $data ); =head1 DESCRIPTION Uses DataDumper to serialize. Deserialization is not supported. The output of this class is only meant for human consumption. See also L. =cut use Data::Dumper; use base qw(DBI::Gofer::Serializer::Base); sub serialize { my $self = shift; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 0; # enabling this disables xs local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Quotekeys = 0; local $Data::Dumper::Deparse = 0; local $Data::Dumper::Purity = 0; my $frozen = Data::Dumper::Dumper(shift); return $frozen unless wantarray; return ($frozen, $self->{deserializer_class}); } 1; DBI-1.652/lib/DBI/Gofer/Serializer/Storable.pm0000644000031300001440000000264114742423677020035 0ustar00merijnuserspackage DBI::Gofer::Serializer::Storable; use strict; use warnings; use base qw(DBI::Gofer::Serializer::Base); # $Id: Storable.pm 15585 2013-03-22 20:31:22Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. =head1 NAME DBI::Gofer::Serializer::Storable - Gofer serialization using Storable =head1 SYNOPSIS $serializer = DBI::Gofer::Serializer::Storable->new(); $string = $serializer->serialize( $data ); ($string, $deserializer_class) = $serializer->serialize( $data ); $data = $serializer->deserialize( $string ); =head1 DESCRIPTION Uses Storable::nfreeze() to serialize and Storable::thaw() to deserialize. The serialize() method sets local $Storable::forgive_me = 1; so it doesn't croak if it encounters any data types that can't be serialized, such as code refs. See also L. =cut use Storable qw(nfreeze thaw); our $VERSION = "0.015586"; use base qw(DBI::Gofer::Serializer::Base); sub serialize { my $self = shift; local $Storable::forgive_me = 1; # for CODE refs etc local $Storable::canonical = 1; # for go_cache my $frozen = nfreeze(shift); return $frozen unless wantarray; return ($frozen, $self->{deserializer_class}); } sub deserialize { my $self = shift; return thaw(shift); } 1; DBI-1.652/lib/DBI/Gofer/Serializer/Base.pm0000644000031300001440000000273512153146731017123 0ustar00merijnuserspackage DBI::Gofer::Serializer::Base; # $Id: Base.pm 9949 2007-09-18 09:38:15Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. =head1 NAME DBI::Gofer::Serializer::Base - base class for Gofer serialization =head1 SYNOPSIS $serializer = $serializer_class->new(); $string = $serializer->serialize( $data ); ($string, $deserializer_class) = $serializer->serialize( $data ); $data = $serializer->deserialize( $string ); =head1 DESCRIPTION DBI::Gofer::Serializer::* classes implement a very minimal subset of the L API. Gofer serializers are expected to be very fast and are not required to deal with anything other than non-blessed references to arrays and hashes, and plain scalars. =cut use strict; use warnings; use Carp qw(croak); our $VERSION = "0.009950"; sub new { my $class = shift; my $deserializer_class = $class->deserializer_class; return bless { deserializer_class => $deserializer_class } => $class; } sub deserializer_class { my $self = shift; my $class = ref($self) || $self; $class =~ s/^DBI::Gofer::Serializer:://; return $class; } sub serialize { my $self = shift; croak ref($self)." has not implemented the serialize method"; } sub deserialize { my $self = shift; croak ref($self)." has not implemented the deserialize method"; } 1; DBI-1.652/lib/DBI/Gofer/Transport/0000755000031300001440000000000015240046615015567 5ustar00merijnusersDBI-1.652/lib/DBI/Gofer/Transport/Base.pm0000644000031300001440000001163415225416121017000 0ustar00merijnuserspackage DBI::Gofer::Transport::Base; # $Id: Base.pm 12536 2009-02-24 22:37:09Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use DBI; use base qw(DBI::Util::_accessor); use DBI::Gofer::Serializer::Storable; use DBI::Gofer::Serializer::DataDumper; our $VERSION = "0.012537"; __PACKAGE__->mk_accessors(qw( trace keep_meta_frozen serializer_obj )); # see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] } sub new { my ($class, $args) = @_; $args->{trace} ||= $class->_init_trace; $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new(); my $self = bless {}, $class; $self->$_( $args->{$_} ) for keys %$args; $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace; return $self; } my $packet_header_text = "GoFER1:"; my $packet_header_regex = qr/^GoFER(\d+):/; sub _freeze_data { my ($self, $data, $serializer, $skip_trace) = @_; my $frozen = eval { $self->_dump("freezing $self->{trace} ".ref($data), $data) if !$skip_trace and $self->trace; local $data->{meta}; # don't include meta in serialization $serializer ||= $self->{serializer_obj}; my ($data, $deserializer_class) = $serializer->serialize($data); $packet_header_text . $data; }; if ($@) { chomp $@; die "Error freezing ".ref($data)." object: $@"; } # stash the frozen data into the data structure itself # to make life easy for the client caching code in DBD::Gofer::Transport::Base $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen; return $frozen; } # public aliases used by subclasses *freeze_request = \&_freeze_data; *freeze_response = \&_freeze_data; sub _thaw_data { my ($self, $frozen_data, $serializer, $skip_trace) = @_; my $data; eval { # check for and extract our gofer header and the info it contains (my $frozen = $frozen_data) =~ s/$packet_header_regex//o or die "does not have gofer header\n"; my ($t_version) = $1; $serializer ||= $self->{serializer_obj}; $data = $serializer->deserialize($frozen); die ref($serializer)."->deserialize didn't return a reference" unless ref $data; $data->{_transport}{version} = $t_version; $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen; }; if ($@) { chomp(my $err = $@); # remove extra noise from Storable $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{}; my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50); Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace; die $msg; } $self->_dump("thawing $self->{trace} ".ref($data), $data) if !$skip_trace and $self->trace; return $data; } # public aliases used by subclasses *thaw_request = \&_thaw_data; *thaw_response = \&_thaw_data; # this should probably live in the request and response classes # and the tace level passed in sub _dump { my ($self, $label, $data) = @_; # don't dump the binary local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen}; my $trace_level = $self->trace; my $summary; if ($trace_level >= 4) { require Data::Dumper; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 0; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Quotekeys = 0; local $Data::Dumper::Deparse = 0; local $Data::Dumper::Purity = 0; $summary = Data::Dumper::Dumper($data); } elsif ($trace_level >= 2) { $summary = eval { $data->summary_as_text } || $@ || "no summary available\n"; } else { $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n"; } $self->trace_msg("$label: $summary"); } sub trace_msg { my ($self, $msg, $min_level) = @_; $min_level //= 1; # transport trace level can override DBI's trace level $min_level = 0 if $self->trace >= $min_level; return DBI->trace_msg("gofer ".$msg, $min_level); } 1; =head1 NAME DBI::Gofer::Transport::Base - Base class for Gofer transports =head1 DESCRIPTION This is the base class for server-side Gofer transports. It's also the base class for the client-side base class L. This is an internal class. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Gofer/Transport/stream.pm0000644000031300001440000000375612153146731017433 0ustar00merijnuserspackage DBI::Gofer::Transport::stream; # $Id: stream.pm 12536 2009-02-24 22:37:09Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use DBI qw(dbi_time); use DBI::Gofer::Execute; use base qw(DBI::Gofer::Transport::pipeone Exporter); our $VERSION = "0.012537"; our @EXPORT = qw(run_stdio_hex); my $executor = DBI::Gofer::Execute->new(); sub run_stdio_hex { my $transport = DBI::Gofer::Transport::stream->new(); local $| = 1; DBI->trace_msg("$0 started (pid $$)\n"); local $\; # OUTPUT_RECORD_SEPARATOR local $/ = "\012"; # INPUT_RECORD_SEPARATOR while ( defined( my $encoded_request = ) ) { my $time_received = dbi_time(); $encoded_request =~ s/\015?\012$//; my $frozen_request = pack "H*", $encoded_request; my $request = $transport->thaw_request( $frozen_request ); my $response = $executor->execute_request( $request ); my $frozen_response = $transport->freeze_response($response); my $encoded_response = unpack "H*", $frozen_response; print $encoded_response, "\015\012"; # autoflushed due to $|=1 # there's no way to access the stats currently # so this just serves as a basic test and illustration of update_stats() $executor->update_stats($request, $response, $frozen_request, $frozen_response, $time_received, 1); } DBI->trace_msg("$0 ending (pid $$)\n"); } 1; __END__ =head1 NAME DBI::Gofer::Transport::stream - DBD::Gofer server-side transport for stream =head1 SYNOPSIS See L. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Gofer/Transport/pipeone.pm0000644000031300001440000000253614656646601017605 0ustar00merijnuserspackage DBI::Gofer::Transport::pipeone; # $Id: pipeone.pm 12536 2009-02-24 22:37:09Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use DBI::Gofer::Execute; use base qw(DBI::Gofer::Transport::Base Exporter); our $VERSION = "0.012537"; our @EXPORT = qw(run_one_stdio); my $executor = DBI::Gofer::Execute->new(); sub run_one_stdio { binmode STDIN; binmode STDOUT; my $transport = DBI::Gofer::Transport::pipeone->new(); my $frozen_request = do { local $/; }; my $response = $executor->execute_request( $transport->thaw_request($frozen_request) ); my $frozen_response = $transport->freeze_response($response); print $frozen_response; # no point calling $executor->update_stats(...) for pipeONE } 1; __END__ =head1 NAME DBI::Gofer::Transport::pipeone - DBD::Gofer server-side transport for pipeone =head1 SYNOPSIS See L. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Gofer/Response.pm0000644000031300001440000001414114656646601015743 0ustar00merijnuserspackage DBI::Gofer::Response; # $Id: Response.pm 11565 2008-07-22 20:17:33Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; use DBI qw(neat neat_list); use base qw(DBI::Util::_accessor Exporter); our $VERSION = "0.011566"; use constant GOf_RESPONSE_EXECUTED => 0x0001; our @EXPORT = qw(GOf_RESPONSE_EXECUTED); __PACKAGE__->mk_accessors(qw( version rv err errstr state flags last_insert_id dbh_attributes sth_resultsets warnings )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($self, $args) = @_; $args->{version} ||= $VERSION; chomp $args->{errstr} if $args->{errstr}; return $self->SUPER::new($args); } sub err_errstr_state { my $self = shift; return @{$self}{qw(err errstr state)}; } sub executed_flag_set { my $flags = shift->flags or return 0; return $flags & GOf_RESPONSE_EXECUTED; } sub add_err { my ($self, $err, $errstr, $state, $trace) = @_; # acts like the DBI's set_err method. # this code copied from DBI::PurePerl's set_err method. chomp $errstr if $errstr; $state ||= ''; carp ref($self)."->add_err($err, $errstr, $state)" if $trace and defined($err) || $errstr; my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state}); if ($r_errstr) { $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err if $r_err && $err && $r_err ne $err; $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state if $r_state and $r_state ne "S1000" && $state && $r_state ne $state; $r_errstr .= "\n$errstr" if $r_errstr ne $errstr; } else { $r_errstr = $errstr; } # assign if higher priority: err > "0" > "" > undef my $err_changed; if ($err # new error: so assign or !defined $r_err # no existing warn/info: so assign # new warn ("0" len 1) > info ("" len 0): so assign or defined $err && length($err) > length($r_err) ) { $r_err = $err; ++$err_changed; } $r_state = ($state eq "00000") ? "" : $state if $state && $err_changed; ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state); return undef; } sub summary_as_text { my $self = shift; my ($context) = @_; my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr)) if defined $err; $s[-1] .= sprintf(", flags=0x%x", $self->{flags}) if defined $self->{flags}; push @s, "last_insert_id=%s", $self->last_insert_id if defined $self->last_insert_id; if (my $dbh_attr = $self->dbh_attributes) { my @keys = sort keys %$dbh_attr; push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys) if @keys; } for my $rs (@{$self->sth_resultsets || []}) { my ($rowset, $err, $errstr, $state) = @{$rs}{qw(rowset err errstr state)}; my $summary = "rowset: "; my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; my $rows = $rowset ? @$rowset : 0; if ($rowset || $NUM_OF_FIELDS > 0) { $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS; } $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err; if ($rows) { my $NAME = $rs->{NAME}; # generate my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1; $summary .= sprintf " [%s]", join ", ", @colinfo; $summary .= ",..." if $rows > 1; # we can be a little more helpful for Sybase/MSSQL user $summary .= " syb_result_type=$rs->{syb_result_type}" if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040; } push @s, $summary; } for my $w (@{$self->warnings || []}) { chomp $w; push @s, "warning: $w"; } if ($context && %$context) { my @keys = sort keys %$context; push @s, join(", ", map { "$_=>".$context->{$_} } @keys); } return join("\n\t", @s). "\n"; } sub outline_as_text { # one-line version of summary_as_text my $self = shift; my ($context) = @_; my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); $s .= sprintf(", err=%s %s", $err, neat($errstr)) if defined $err; $s .= sprintf(", flags=0x%x", $self->{flags}) if $self->{flags}; if (my $sth_resultsets = $self->sth_resultsets) { $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets); my @rs; for my $rs (@{$self->sth_resultsets || []}) { my $summary = ""; my ($rowset, $err, $errstr) = @{$rs}{qw(rowset err errstr)}; my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; my $rows = $rowset ? @$rowset : 0; if ($rowset || $NUM_OF_FIELDS > 0) { $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS; } $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr) if defined $err; push @rs, $summary; } $s .= join "; ", map { "[$_]" } @rs; } return $s; } 1; =head1 NAME DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer =head1 DESCRIPTION This is an internal class. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Gofer/Execute.pm0000644000031300001440000007463514742425306015556 0ustar00merijnuserspackage DBI::Gofer::Execute; # $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; use DBI qw(dbi_time); use DBI::Gofer::Request; use DBI::Gofer::Response; use base qw(DBI::Util::_accessor); our $VERSION = "0.014283"; our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common}; our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods; our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr our $current_dbh; # the dbh we're using for this request # set trace for server-side gofer # Could use DBI_TRACE env var when it's an unrelated separate process # but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream) DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE}; # define valid configuration attributes (args to new()) # the values here indicate the basic type of values allowed my %configuration_attributes = ( gofer_execute_class => 1, default_connect_dsn => 1, forced_connect_dsn => 1, default_connect_attributes => {}, forced_connect_attributes => {}, track_recent => 1, check_request_sub => sub {}, check_response_sub => sub {}, forced_single_resultset => 1, max_cached_dbh_per_drh => 1, max_cached_sth_per_dbh => 1, forced_response_attributes => {}, forced_gofer_random => 1, stats => {}, ); __PACKAGE__->mk_accessors( keys %configuration_attributes ); sub new { my ($self, $args) = @_; $args->{default_connect_attributes} ||= {}; $args->{forced_connect_attributes} ||= {}; $args->{max_cached_sth_per_dbh} ||= 1000; $args->{stats} ||= {}; return $self->SUPER::new($args); } sub valid_configuration_attributes { my $self = shift; return { %configuration_attributes }; } my %extra_attr = ( # Only referenced if the driver doesn't support private_attribute_info method. # What driver-specific attributes should be returned for the driver being used? # keyed by $dbh->{Driver}{Name} # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others # which would reduce processing/traffic for non-select statements mysql => { dbh => [qw( mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id )], sth => [qw( mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid )], # XXX this dbh_after_sth stuff is a temporary, but important, hack. # should be done via hash instead of arrays where the hash value contains # flags that can indicate which attributes need to be handled in this way dbh_after_sth => [qw( mysql_insertid )], }, Pg => { dbh => [qw( pg_protocol pg_lib_version pg_server_version pg_db pg_host pg_port pg_default_port pg_options pg_pid )], sth => [qw( pg_size pg_type pg_oid_status pg_cmd_status )], }, Sybase => { dbh => [qw( syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string )], sth => [qw( syb_types syb_proc_status syb_result_type )], }, SQLite => { dbh => [qw( sqlite_version )], sth => [qw( )], }, ExampleP => { dbh => [qw( examplep_private_dbh_attrib )], sth => [qw( examplep_private_sth_attrib )], dbh_after_sth => [qw( examplep_insertid )], }, ); sub _connect { my ($self, $request) = @_; my $stats = $self->{stats}; # discard CachedKids from time to time if (++$stats->{_requests_served} % 1000 == 0 # XXX config? and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh} ) { my %drivers = DBI->installed_drivers(); while ( my ($driver, $drh) = each %drivers ) { next unless my $CK = $drh->{CachedKids}; next unless keys %$CK > $max_cached_dbh_per_drh; next if $driver eq 'Gofer'; # ie transport=null when testing DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver", scalar keys %$CK, $self->{max_cached_dbh_per_drh}); $_->{Active} && $_->disconnect for values %$CK; %$CK = (); } } # local $ENV{...} can leak, so only do it if required local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; $connect_method ||= 'connect_cached'; $stats->{method_calls_dbh}->{$connect_method}++; # delete attributes we don't want to affect the server-side # (Could just do this on client-side and trust the client. DoS?) delete @{$attr}{qw(Profile InactiveDestroy AutoInactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request"; my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; my $connect_attr = { # the configured default attributes, if any %{ $self->default_connect_attributes }, # pass username and password as attributes # then they can be overridden by forced_connect_attributes Username => $username, Password => $password, # the requested attributes %$attr, # force some attributes the way we'd like them PrintWarn => $local_log, PrintError => $local_log, # the configured default attributes, if any %{ $self->forced_connect_attributes }, # RaiseError must be enabled RaiseError => 1, # reset Executed flag (of the cached handle) so we can use it to tell # if errors happened before the main part of the request was executed Executed => 0, # ensure this connect_cached doesn't have the same args as the client # because that causes subtle issues if in the same process (ie transport=null) # include pid to avoid problems with forking (ie null transport in mod_perl) # include gofer-random to avoid random behaviour leaking to other handles dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), }; # XXX implement our own private connect_cached method? (with rate-limited ping) my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); $dbh->{ShowErrorStatement} = 1 if $local_log; # XXX should probably just be a Callbacks => arg to connect_cached # with a cache of pre-built callback hooks (memoized, without $self) if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) { $self->_install_rand_callbacks($dbh, $random); } my $CK = $dbh->{CachedKids}; if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) { %$CK = (); # clear all statement handles } #$dbh->trace(0); $current_dbh = $dbh; return $dbh; } sub reset_dbh { my ($self, $dbh) = @_; $dbh->set_err(undef, undef); # clear any error state } sub new_response_with_err { my ($self, $rv, $eval_error, $dbh) = @_; # this is the usual way to create a response for both success and failure # capture err+errstr etc and merge in $eval_error ($@) my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); if ($eval_error) { $err ||= $DBI::stderr || 1; # ensure err is true if ($errstr) { $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; chomp $errstr; $errstr .= "; $eval_error"; } else { $errstr = $eval_error; } } chomp $errstr if $errstr; my $flags; # (XXX if we ever add transaction support then we'll need to take extra # steps because the commit/rollback would reset Executed before we get here) $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed}; my $response = DBI::Gofer::Response->new({ rv => $rv, err => $err, errstr => $errstr, state => $state, flags => $flags, }); return $response; } sub execute_request { my ($self, $request) = @_; # should never throw an exception DBI->trace_msg("-----> execute_request\n"); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; warn @_ if $local_log; }; my $response = eval { if (my $check_request_sub = $self->check_request_sub) { $request = $check_request_sub->($request, $self) or die "check_request_sub failed"; } my $version = $request->version || 0; die ref($request)." version $version is not supported" if $version < 0.009116 or $version >= 1; ($request->is_sth_request) ? $self->execute_sth_request($request) : $self->execute_dbh_request($request); }; $response ||= $self->new_response_with_err(undef, $@, $current_dbh); if (my $check_response_sub = $self->check_response_sub) { # not protected with an eval so it can choose to throw an exception my $new = $check_response_sub->($response, $self, $request); $response = $new if ref $new; } undef $current_dbh; $response->warnings(\@warnings) if @warnings; DBI->trace_msg("<----- execute_request\n"); return $response; } sub execute_dbh_request { my ($self, $request) = @_; my $stats = $self->{stats}; my $dbh; my $rv_ref = eval { $dbh = $self->_connect($request); my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] my $wantarray = shift @$args; my $meth = shift @$args; $stats->{method_calls_dbh}->{$meth}++; my @rv = ($wantarray) ? $dbh->$meth(@$args) : scalar $dbh->$meth(@$args); \@rv; } || []; my $response = $self->new_response_with_err($rv_ref, $@, $dbh); return $response if not $dbh; # does this request also want any dbh attributes returned? if (my $dbh_attributes = $request->dbh_attributes) { $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) ); } if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) { $stats->{method_calls_dbh}->{last_insert_id}++; my $id = $dbh->last_insert_id( @$lid_args ); $response->last_insert_id( $id ); } if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) { # dbh_method_call was probably a metadata method like table_info # that returns a statement handle, so turn the $sth into resultset my $sth = $rv_ref->[0]; $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); $response->rv("(sth)"); # don't try to return actual sth } # we're finished with this dbh for this request $self->reset_dbh($dbh); return $response; } sub gather_dbh_attributes { my ($self, $dbh, $dbh_attributes) = @_; my @req_attr_names = @$dbh_attributes; if ($req_attr_names[0] eq '*') { # auto include std + private shift @req_attr_names; push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) }; } my %dbh_attr_values; @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names); # XXX piggyback installed_methods onto dbh_attributes for now $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods }; # XXX piggyback default_methods onto dbh_attributes for now $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh); return \%dbh_attr_values; } sub _std_response_attribute_names { my ($self, $h) = @_; $h = tied(%$h) || $h; # switch to inner handle # cache the private_attribute_info data for each handle # XXX might be better to cache it in the executor # as it's unlikely to change # or perhaps at least cache it in the dbh even for sth # as the sth are typically very short lived my ($dbh, $h_type, $driver_name, @attr_names); if ($dbh = $h->{Database}) { # is an sth # does the dbh already have the answer cached? return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth}; ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name}); push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE); } else { # is a dbh return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh}; ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h); # explicitly add these because drivers may have different defaults # add Name so the client gets the real Name of the connection push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name); } if (my $pai = $h->private_attribute_info) { push @attr_names, keys %$pai; } else { push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []}; } if (my $fra = $self->{forced_response_attributes}) { push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []} } $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n"); # cache into the dbh even for sth, as the dbh is usually longer lived return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names; } sub execute_sth_request { my ($self, $request) = @_; my $dbh; my $sth; my $last_insert_id; my $stats = $self->{stats}; my $rv = eval { $dbh = $self->_connect($request); my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] shift @$args; # discard wantarray my $meth = shift @$args; $stats->{method_calls_sth}->{$meth}++; $sth = $dbh->$meth(@$args); my $last = '(sth)'; # a true value (don't try to return actual sth) # execute methods on the sth, e.g., bind_param & execute if (my $calls = $request->sth_method_calls) { for my $meth_call (@$calls) { my $method = shift @$meth_call; $stats->{method_calls_sth}->{$method}++; $last = $sth->$method(@$meth_call); } } if (my $lid_args = $request->dbh_last_insert_id_args) { $stats->{method_calls_sth}->{last_insert_id}++; $last_insert_id = $dbh->last_insert_id( @$lid_args ); } $last; }; my $response = $self->new_response_with_err($rv, $@, $dbh); return $response if not $dbh; $response->last_insert_id( $last_insert_id ) if defined $last_insert_id; # even if the eval failed we still want to try to gather attribute values # (XXX would be nice to be able to support streaming of results. # which would reduce memory usage and latency for large results) if ($sth) { $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); $sth->finish; } # does this request also want any dbh attributes returned? my $dbh_attr_set; if (my $dbh_attributes = $request->dbh_attributes) { $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); } # XXX needs to be integrated with private_attribute_info() etc if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); } $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; $self->reset_dbh($dbh); return $response; } sub gather_sth_resultsets { my ($self, $sth, $request, $response) = @_; my $resultsets = eval { my $attr_names = $self->_std_response_attribute_names($sth); my $sth_attr = {}; $sth_attr->{$_} = 1 for @$attr_names; # let the client add/remove sth attributes if (my $sth_result_attr = $request->sth_result_attr) { $sth_attr->{$_} = $sth_result_attr->{$_} for keys %$sth_result_attr; } my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; my $row_count = 0; my $rs_list = []; while (1) { my $rs = $self->fetch_result_set($sth, \@sth_attr); push @$rs_list, $rs; if (my $rows = $rs->{rowset}) { $row_count += @$rows; } last if $self->{forced_single_resultset}; last if !($sth->more_results || $sth->{syb_more_results}); } my $stats = $self->{stats}; $stats->{rows_returned_total} += $row_count; $stats->{rows_returned_max} = $row_count if $row_count > ($stats->{rows_returned_max}||0); $rs_list; }; $response->add_err(1, $@) if $@; return $resultsets; } sub fetch_result_set { my ($self, $sth, $sth_attr) = @_; my %meta; eval { @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); # we assume @$sth_attr contains NUM_OF_FIELDS $meta{rowset} = $sth->fetchall_arrayref() if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT # the fetchall_arrayref may fail with a 'not executed' kind of error # because gather_sth_resultsets/fetch_result_set are called even if # execute() failed, or even if there was no execute() call at all. # The corresponding error goes into the resultset err, not the top-level # response err, so in most cases this resultset err is never noticed. }; if ($@) { chomp $@; $meta{err} = $DBI::err || 1; $meta{errstr} = $DBI::errstr || $@; $meta{state} = $DBI::state; } return \%meta; } sub _get_default_methods { my ($dbh) = @_; # returns a ref to a hash of dbh method names for methods which the driver # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. my $ImplementorClass = $dbh->{ImplementorClass} or die; my %default_methods; for my $method (@all_dbh_methods) { my $dbi_sub = $all_dbh_methods{$method} || 42; my $imp_sub = $ImplementorClass->can($method) || 42; next if $imp_sub != $dbi_sub; #warn("default $method\n"); $default_methods{$method} = 1; } return \%default_methods; } # XXX would be nice to make this a generic DBI module sub _install_rand_callbacks { my ($self, $dbh, $dbi_gofer_random) = @_; my $callbacks = $dbh->{Callbacks} || {}; my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; # return if we've already setup this handle with callbacks for these specs return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); my @specs = split /,/, $dbi_gofer_random; for my $spec (@specs) { if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { $fail_percent = $1; $spec_part{fail} = $spec; next; } if ($spec =~ m/^err=(-?\d+)$/) { $fail_err = $1; $spec_part{err} = $spec; next; } if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { $delay_duration = $1; $delay_percent = $2; $spec_part{delay} = $spec; next; } elsif ($spec !~ m/^(\w+|\*)$/) { warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; next; } my $method = $spec; if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; next; } unless (defined $fail_percent or defined $delay_percent) { warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceded by 'fail=N' and/or 'delayN=N'"; next; } push @spec_note, join(",", values(%spec_part), $method); $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); } warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" if @spec_note; $dbh->{Callbacks} = $callbacks; $dbh->{private_gofer_rand_fail_callbacks} = $callbacks; } my %_mk_rand_callback_seqn; sub _mk_rand_callback { my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; my ($fail_modrate, $delay_modrate); $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; # note that $method may be "*" but that's not recommended or documented or wise return sub { my ($h) = @_; my $seqn = ++$_mk_rand_callback_seqn{$method}; my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : ($delay_percent < 0) ? !($seqn % $delay_modrate): 0; my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; #no warnings 'uninitialized'; #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; if ($delay) { my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; # Note what's happening in a trace message. If the delay percent is an even # number then use warn() instead so it's sent back to the client. ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); select undef, undef, undef, $delay_duration; # allows floating point value } if ($fail) { undef $_; # tell DBI to not call the method # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr # as it's checked for in a few places, such as the gofer retry logic return $h->set_err($fail_err || $DBI::stderr, "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); } return; } } sub update_stats { my ($self, $request, $response, $frozen_request, $frozen_response, $time_received, $store_meta, $other_meta, ) = @_; # should always have a response object here carp("No response object provided") unless $request; my $stats = $self->{stats}; $stats->{frozen_request_max_bytes} = length($frozen_request) if $frozen_request && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); $stats->{frozen_response_max_bytes} = length($frozen_response) if $frozen_response && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); my $recent; if (my $track_recent = $self->{track_recent}) { $recent = { request => $frozen_request, response => $frozen_response, time_received => $time_received, duration => dbi_time()-$time_received, # for any other info ($store_meta) ? (meta => $store_meta) : (), }; $recent->{request_object} = $request if !$frozen_request && $request; $recent->{response_object} = $response if !$frozen_response; my @queues = ($stats->{recent_requests} ||= []); push @queues, ($stats->{recent_errors} ||= []) if !$response or $response->err; for my $queue (@queues) { push @$queue, $recent; shift @$queue if @$queue > $track_recent; } } return $recent; } 1; __END__ =head1 NAME DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses =head1 SYNOPSIS $executor = DBI::Gofer::Execute->new( { ...config... }); $response = $executor->execute_request( $request ); =head1 DESCRIPTION Accepts a DBI::Gofer::Request object, executes the requested DBI method calls, and returns a DBI::Gofer::Response object. Any error, including any internal 'fatal' errors are caught and converted into a DBI::Gofer::Response object. This module is usually invoked by a 'server-side' Gofer transport module. They usually have names in the "C" namespace. Examples include: L and L. =head1 CONFIGURATION =head2 check_request_sub If defined, it must be a reference to a subroutine that will 'check' the request. It is passed the request object and the executor as its only arguments. The subroutine can either return the original request object or die with a suitable error message (which will be turned into a Gofer response). It can also construct and return a new request that should be executed instead of the original request. =head2 check_response_sub If defined, it must be a reference to a subroutine that will 'check' the response. It is passed the response object, the executor, and the request object. The sub may alter the response object and return undef, or return a new response object. This mechanism can be used to, for example, terminate the service if specific database errors are seen. =head2 forced_connect_dsn If set, this DSN is always used instead of the one in the request. =head2 default_connect_dsn If set, this DSN is used if C is not set and the request does not contain a DSN itself. =head2 forced_connect_attributes A reference to a hash of connect() attributes. Individual attributes in C will take precedence over corresponding attributes in the request. =head2 default_connect_attributes A reference to a hash of connect() attributes. Individual attributes in the request take precedence over corresponding attributes in C. =head2 max_cached_dbh_per_drh If set, the loaded drivers will be checked to ensure they don't have more than this number of cached connections. There is no default value. This limit is not enforced for every request. =head2 max_cached_sth_per_dbh If set, all the cached statement handles will be cleared once the number of cached statement handles rises above this limit. The default is 1000. =head2 forced_single_resultset If true, then only the first result set will be fetched and returned in the response. =head2 forced_response_attributes A reference to a data structure that can specify extra attributes to be returned in responses. forced_response_attributes => { DriverName => { dbh => [ qw(dbh_attrib_name) ], sth => [ qw(sth_attrib_name) ], }, }, This can be useful in cases where the driver has not implemented the private_attribute_info() method and DBI::Gofer::Execute's own fallback list of private attributes doesn't include the driver or attributes you need. =head2 track_recent If set, specifies the number of recent requests and responses that should be kept by the update_stats() method for diagnostics. See L. Note that this setting can significantly increase memory use. Use with caution. =head2 forced_gofer_random Enable forced random failures and/or delays for testing. See L below. =head1 DRIVER-SPECIFIC ISSUES Gofer needs to know about any driver-private attributes that should have their values sent back to the client. If the driver doesn't support private_attribute_info() method, and very few do, then the module falls back to using some hard-coded details, if available, for the driver being used. Currently hard-coded details are available for the mysql, Pg, Sybase, and SQLite drivers. =head1 TESTING DBD::Gofer, DBD::Execute and related packages are well tested by executing the DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer. Because Gofer includes timeout and 'retry on error' mechanisms there is a need for some way to trigger delays and/or errors. This can be done via the C configuration item, or else the DBI_GOFER_RANDOM environment variable. =head2 DBI_GOFER_RANDOM The value of the C configuration item (or else the DBI_GOFER_RANDOM environment variable) is treated as a series of tokens separated by commas. The tokens can be one of three types: =over 4 =item fail=R% Set the current failure rate to R where R is a percentage. The value R can be floating point, e.g., C. Negative values for R have special meaning, see below. =item err=N Sets the current failure err value to N (instead of the DBI's default 'standard err value' of 2000000000). This is useful when you want to simulate a specific error. =item delayN=R% Set the current random delay rate to R where R is a percentage, and set the current delay duration to N seconds. The values of R and N can be floating point, e.g., C. Negative values for R have special meaning, see below. If R is an odd number (R % 2 == 1) then a message is logged via warn() which will be returned to, and echoed at, the client. =item methodname Applies the current fail, err, and delay values to the named method. If neither a fail nor delay have been set yet then a warning is generated. =back For example: $executor = DBI::Gofer::Execute->new( { forced_gofer_random => "fail=0.01%,do,delay60=1%,execute", }); will cause the do() method to fail for 0.01% of calls, and the execute() method to fail 0.01% of calls and be delayed by 60 seconds on 1% of calls. If the percentage value (C) is negative then instead of the failures being triggered randomly (via the rand() function) they are triggered via a sequence number. In other words "C" will mean every fifth call will fail. Each method has a distinct sequence number. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Gofer/Request.pm0000644000031300001440000001220214742423677015573 0ustar00merijnuserspackage DBI::Gofer::Request; # $Id: Request.pm 12536 2009-02-24 22:37:09Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use DBI qw(neat neat_list); use base qw(DBI::Util::_accessor); our $VERSION = "0.012537"; use constant GOf_REQUEST_IDEMPOTENT => 0x0001; use constant GOf_REQUEST_READONLY => 0x0002; our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY); __PACKAGE__->mk_accessors(qw( version flags dbh_connect_call dbh_method_call dbh_attributes dbh_last_insert_id_args sth_method_calls sth_result_attr )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($self, $args) = @_; $args->{version} ||= $VERSION; return $self->SUPER::new($args); } sub reset { my ($self, $flags) = @_; # remove everything except connect and version %$self = ( version => $self->{version}, dbh_connect_call => $self->{dbh_connect_call}, ); $self->{flags} = $flags if $flags; } sub init_request { my ($self, $method_and_args, $dbh) = @_; $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 ); $self->dbh_method_call($method_and_args); } sub is_sth_request { return shift->{sth_result_attr}; } sub statements { my $self = shift; my @statements; if (my $dbh_method_call = $self->dbh_method_call) { my $statement_method_regex = qr/^(?:do|prepare)$/; my (undef, $method, $arg1) = @$dbh_method_call; push @statements, $arg1 if $method && $method =~ $statement_method_regex; } return @statements; } sub is_idempotent { my $self = shift; if (my $flags = $self->flags) { return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY); } # else check if all statements are SELECT statement that don't include FOR UPDATE my @statements = $self->statements; # XXX this is very minimal for now, doesn't even allow comments before the select # (and can't ever work for "exec stored_procedure_name" kinds of statements) # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar") return 1 if @statements == grep { m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi } @statements; return 0; } sub summary_as_text { my $self = shift; my ($context) = @_; my @s = ''; if ($context && %$context) { my @keys = sort keys %$context; push @s, join(", ", map { "$_=>".$context->{$_} } @keys); } my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call }; $method ||= 'connect_cached'; $pass = '***' if defined $pass; my $tmp = ''; if ($attr) { $tmp = { %{$attr||{}} }; # copy so we can edit $tmp->{Password} = '***' if exists $tmp->{Password}; $tmp = "{ ".neat_list([ %$tmp ])." }"; } push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp; if (my $flags = $self->flags) { push @s, sprintf "flags: 0x%x", $flags; } if (my $dbh_attr = $self->dbh_attributes) { push @s, sprintf "dbh->FETCH: %s", @$dbh_attr if @$dbh_attr; } my ($wantarray, $meth, @args) = @{ $self->dbh_method_call }; my $args = neat_list(\@args); $args =~ s/\n+/ /g; push @s, sprintf "dbh->%s(%s)", $meth, $args; if (my $lii_args = $self->dbh_last_insert_id_args) { push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args); } for my $call (@{ $self->sth_method_calls || [] }) { my ($meth, @args) = @$call; ($args = neat_list(\@args)) =~ s/\n+/ /g; push @s, sprintf "sth->%s(%s)", $meth, $args; } if (my $sth_attr = $self->sth_result_attr) { push @s, sprintf "sth->FETCH: %s", %$sth_attr if %$sth_attr; } return join("\n\t", @s) . "\n"; } sub outline_as_text { # one-line version of summary_as_text my $self = shift; my @s = ''; my $neatlen = 80; if (my $flags = $self->flags) { push @s, sprintf "flags=0x%x", $flags; } my (undef, $meth, @args) = @{ $self->dbh_method_call }; push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); for my $call (@{ $self->sth_method_calls || [] }) { my ($meth, @args) = @$call; push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); } my ($method, $dsn) = @{ $self->dbh_connect_call }; push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines return $outline; } 1; =head1 NAME DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute =head1 DESCRIPTION This is an internal class. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut DBI-1.652/lib/DBI/Const/0000755000031300001440000000000015240046615013617 5ustar00merijnusersDBI-1.652/lib/DBI/Const/GetInfo/0000755000031300001440000000000015240046615015152 5ustar00merijnusersDBI-1.652/lib/DBI/Const/GetInfo/ANSI.pm0000644000031300001440000002261614656646601016264 0ustar00merijnusers# $Id: ANSI.pm 8696 2007-01-24 23:12:38Z Tim $ # # Copyright (c) 2002 Tim Bunce Ireland # # Constant data describing ANSI CLI info types and return values for the # SQLGetInfo() method of ODBC. # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; package DBI::Const::GetInfo::ANSI; our (%InfoTypes,%ReturnTypes,%ReturnValues,); =head1 NAME DBI::Const::GetInfo::ANSI - ISO/IEC SQL/CLI Constants for GetInfo =head1 SYNOPSIS The API for this module is private and subject to change. =head1 DESCRIPTION Information requested by GetInfo(). See: A.1 C header file SQLCLI.H, Page 316, 317. The API for this module is private and subject to change. =head1 REFERENCES ISO/IEC FCD 9075-3:200x Information technology - Database Languages - SQL - Part 3: Call-Level Interface (SQL/CLI) SC32 N00744 = WG3:VIE-005 = H2-2002-007 Date: 2002-01-15 =cut my $VERSION = "2.008697"; %InfoTypes = ( SQL_ALTER_TABLE => 86 , SQL_CATALOG_NAME => 10003 , SQL_COLLATING_SEQUENCE => 10004 , SQL_CURSOR_COMMIT_BEHAVIOR => 23 , SQL_CURSOR_SENSITIVITY => 10001 , SQL_DATA_SOURCE_NAME => 2 , SQL_DATA_SOURCE_READ_ONLY => 25 , SQL_DBMS_NAME => 17 , SQL_DBMS_VERSION => 18 , SQL_DEFAULT_TRANSACTION_ISOLATION => 26 , SQL_DESCRIBE_PARAMETER => 10002 , SQL_FETCH_DIRECTION => 8 , SQL_GETDATA_EXTENSIONS => 81 , SQL_IDENTIFIER_CASE => 28 , SQL_INTEGRITY => 73 , SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 , SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 , SQL_MAXIMUM_COLUMNS_IN_TABLE => 101 , SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 , SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 , SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 , SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 , SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 , SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 , SQL_MAXIMUM_STMT_OCTETS => 20000 , SQL_MAXIMUM_STMT_OCTETS_DATA => 20001 , SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 20002 , SQL_MAXIMUM_TABLES_IN_SELECT => 106 , SQL_MAXIMUM_TABLE_NAME_LENGTH => 35 , SQL_MAXIMUM_USER_NAME_LENGTH => 107 , SQL_NULL_COLLATION => 85 , SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 , SQL_OUTER_JOIN_CAPABILITIES => 115 , SQL_SCROLL_CONCURRENCY => 43 , SQL_SEARCH_PATTERN_ESCAPE => 14 , SQL_SERVER_NAME => 13 , SQL_SPECIAL_CHARACTERS => 94 , SQL_TRANSACTION_CAPABLE => 46 , SQL_TRANSACTION_ISOLATION_OPTION => 72 , SQL_USER_NAME => 47 ); =head2 %ReturnTypes See: Codes and data types for implementation information (Table 28), Page 85, 86. Mapped to ODBC datatype names. =cut %ReturnTypes = # maxlen ( SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # INTEGER , SQL_CATALOG_NAME => 'SQLCHAR' # CHARACTER (1) , SQL_COLLATING_SEQUENCE => 'SQLCHAR' # CHARACTER (254) , SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # SMALLINT , SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # INTEGER , SQL_DATA_SOURCE_NAME => 'SQLCHAR' # CHARACTER (128) , SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # CHARACTER (1) , SQL_DBMS_NAME => 'SQLCHAR' # CHARACTER (254) , SQL_DBMS_VERSION => 'SQLCHAR' # CHARACTER (254) , SQL_DEFAULT_TRANSACTION_ISOLATION => 'SQLUINTEGER' # INTEGER , SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # CHARACTER (1) , SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # INTEGER , SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # INTEGER , SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # SMALLINT , SQL_INTEGRITY => 'SQLCHAR' # CHARACTER (1) , SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_STMT_OCTETS => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_STMT_OCTETS_DATA => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_TABLE_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT , SQL_NULL_COLLATION => 'SQLUSMALLINT' # SMALLINT , SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # CHARACTER (1) , SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # INTEGER , SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # INTEGER , SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # CHARACTER (1) , SQL_SERVER_NAME => 'SQLCHAR' # CHARACTER (128) , SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # CHARACTER (254) , SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # SMALLINT , SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # INTEGER , SQL_USER_NAME => 'SQLCHAR' # CHARACTER (128) ); =head2 %ReturnValues See: A.1 C header file SQLCLI.H, Page 317, 318. =cut $ReturnValues{SQL_ALTER_TABLE} = { SQL_AT_ADD_COLUMN => 0x00000001 , SQL_AT_DROP_COLUMN => 0x00000002 , SQL_AT_ALTER_COLUMN => 0x00000004 , SQL_AT_ADD_CONSTRAINT => 0x00000008 , SQL_AT_DROP_CONSTRAINT => 0x00000010 }; $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = { SQL_CB_DELETE => 0 , SQL_CB_CLOSE => 1 , SQL_CB_PRESERVE => 2 }; $ReturnValues{SQL_FETCH_DIRECTION} = { SQL_FD_FETCH_NEXT => 0x00000001 , SQL_FD_FETCH_FIRST => 0x00000002 , SQL_FD_FETCH_LAST => 0x00000004 , SQL_FD_FETCH_PRIOR => 0x00000008 , SQL_FD_FETCH_ABSOLUTE => 0x00000010 , SQL_FD_FETCH_RELATIVE => 0x00000020 }; $ReturnValues{SQL_GETDATA_EXTENSIONS} = { SQL_GD_ANY_COLUMN => 0x00000001 , SQL_GD_ANY_ORDER => 0x00000002 }; $ReturnValues{SQL_IDENTIFIER_CASE} = { SQL_IC_UPPER => 1 , SQL_IC_LOWER => 2 , SQL_IC_SENSITIVE => 3 , SQL_IC_MIXED => 4 }; $ReturnValues{SQL_NULL_COLLATION} = { SQL_NC_HIGH => 1 , SQL_NC_LOW => 2 }; $ReturnValues{SQL_OUTER_JOIN_CAPABILITIES} = { SQL_OUTER_JOIN_LEFT => 0x00000001 , SQL_OUTER_JOIN_RIGHT => 0x00000002 , SQL_OUTER_JOIN_FULL => 0x00000004 , SQL_OUTER_JOIN_NESTED => 0x00000008 , SQL_OUTER_JOIN_NOT_ORDERED => 0x00000010 , SQL_OUTER_JOIN_INNER => 0x00000020 , SQL_OUTER_JOIN_ALL_COMPARISON_OPS => 0x00000040 }; $ReturnValues{SQL_SCROLL_CONCURRENCY} = { SQL_SCCO_READ_ONLY => 0x00000001 , SQL_SCCO_LOCK => 0x00000002 , SQL_SCCO_OPT_ROWVER => 0x00000004 , SQL_SCCO_OPT_VALUES => 0x00000008 }; $ReturnValues{SQL_TRANSACTION_ACCESS_MODE} = { SQL_TRANSACTION_READ_ONLY => 0x00000001 , SQL_TRANSACTION_READ_WRITE => 0x00000002 }; $ReturnValues{SQL_TRANSACTION_CAPABLE} = { SQL_TC_NONE => 0 , SQL_TC_DML => 1 , SQL_TC_ALL => 2 , SQL_TC_DDL_COMMIT => 3 , SQL_TC_DDL_IGNORE => 4 }; $ReturnValues{SQL_TRANSACTION_ISOLATION} = { SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 , SQL_TRANSACTION_READ_COMMITTED => 0x00000002 , SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 , SQL_TRANSACTION_SERIALIZABLE => 0x00000008 }; 1; =head1 TODO Corrections, e.g.: SQL_TRANSACTION_ISOLATION_OPTION vs. SQL_TRANSACTION_ISOLATION =cut DBI-1.652/lib/DBI/Const/GetInfo/ODBC.pm0000644000031300001440000020112714656646601016235 0ustar00merijnusers# $Id: ODBC.pm 11373 2008-06-02 19:01:33Z Tim $ # # Copyright (c) 2002 Tim Bunce Ireland # # Constant data describing Microsoft ODBC info types and return values # for the SQLGetInfo() method of ODBC. # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; package DBI::Const::GetInfo::ODBC; our (%InfoTypes,%ReturnTypes,%ReturnValues,); =head1 NAME DBI::Const::GetInfo::ODBC - ODBC Constants for GetInfo =head1 SYNOPSIS The API for this module is private and subject to change. =head1 DESCRIPTION Information requested by GetInfo(). The API for this module is private and subject to change. =head1 REFERENCES MDAC SDK 2.6 ODBC version number (0x0351) sql.h sqlext.h =cut my $VERSION = "2.011374"; %InfoTypes = ( SQL_ACCESSIBLE_PROCEDURES => 20 , SQL_ACCESSIBLE_TABLES => 19 , SQL_ACTIVE_CONNECTIONS => 0 , SQL_ACTIVE_ENVIRONMENTS => 116 , SQL_ACTIVE_STATEMENTS => 1 , SQL_AGGREGATE_FUNCTIONS => 169 , SQL_ALTER_DOMAIN => 117 , SQL_ALTER_TABLE => 86 , SQL_ASYNC_MODE => 10021 , SQL_BATCH_ROW_COUNT => 120 , SQL_BATCH_SUPPORT => 121 , SQL_BOOKMARK_PERSISTENCE => 82 , SQL_CATALOG_LOCATION => 114 # SQL_QUALIFIER_LOCATION , SQL_CATALOG_NAME => 10003 , SQL_CATALOG_NAME_SEPARATOR => 41 # SQL_QUALIFIER_NAME_SEPARATOR , SQL_CATALOG_TERM => 42 # SQL_QUALIFIER_TERM , SQL_CATALOG_USAGE => 92 # SQL_QUALIFIER_USAGE , SQL_COLLATION_SEQ => 10004 , SQL_COLUMN_ALIAS => 87 , SQL_CONCAT_NULL_BEHAVIOR => 22 , SQL_CONVERT_BIGINT => 53 , SQL_CONVERT_BINARY => 54 , SQL_CONVERT_BIT => 55 , SQL_CONVERT_CHAR => 56 , SQL_CONVERT_DATE => 57 , SQL_CONVERT_DECIMAL => 58 , SQL_CONVERT_DOUBLE => 59 , SQL_CONVERT_FLOAT => 60 , SQL_CONVERT_FUNCTIONS => 48 , SQL_CONVERT_GUID => 173 , SQL_CONVERT_INTEGER => 61 , SQL_CONVERT_INTERVAL_DAY_TIME => 123 , SQL_CONVERT_INTERVAL_YEAR_MONTH => 124 , SQL_CONVERT_LONGVARBINARY => 71 , SQL_CONVERT_LONGVARCHAR => 62 , SQL_CONVERT_NUMERIC => 63 , SQL_CONVERT_REAL => 64 , SQL_CONVERT_SMALLINT => 65 , SQL_CONVERT_TIME => 66 , SQL_CONVERT_TIMESTAMP => 67 , SQL_CONVERT_TINYINT => 68 , SQL_CONVERT_VARBINARY => 69 , SQL_CONVERT_VARCHAR => 70 , SQL_CONVERT_WCHAR => 122 , SQL_CONVERT_WLONGVARCHAR => 125 , SQL_CONVERT_WVARCHAR => 126 , SQL_CORRELATION_NAME => 74 , SQL_CREATE_ASSERTION => 127 , SQL_CREATE_CHARACTER_SET => 128 , SQL_CREATE_COLLATION => 129 , SQL_CREATE_DOMAIN => 130 , SQL_CREATE_SCHEMA => 131 , SQL_CREATE_TABLE => 132 , SQL_CREATE_TRANSLATION => 133 , SQL_CREATE_VIEW => 134 , SQL_CURSOR_COMMIT_BEHAVIOR => 23 , SQL_CURSOR_ROLLBACK_BEHAVIOR => 24 , SQL_CURSOR_SENSITIVITY => 10001 , SQL_DATA_SOURCE_NAME => 2 , SQL_DATA_SOURCE_READ_ONLY => 25 , SQL_DATABASE_NAME => 16 , SQL_DATETIME_LITERALS => 119 , SQL_DBMS_NAME => 17 , SQL_DBMS_VER => 18 , SQL_DDL_INDEX => 170 , SQL_DEFAULT_TXN_ISOLATION => 26 , SQL_DESCRIBE_PARAMETER => 10002 , SQL_DM_VER => 171 , SQL_DRIVER_HDBC => 3 , SQL_DRIVER_HDESC => 135 , SQL_DRIVER_HENV => 4 , SQL_DRIVER_HLIB => 76 , SQL_DRIVER_HSTMT => 5 , SQL_DRIVER_NAME => 6 , SQL_DRIVER_ODBC_VER => 77 , SQL_DRIVER_VER => 7 , SQL_DROP_ASSERTION => 136 , SQL_DROP_CHARACTER_SET => 137 , SQL_DROP_COLLATION => 138 , SQL_DROP_DOMAIN => 139 , SQL_DROP_SCHEMA => 140 , SQL_DROP_TABLE => 141 , SQL_DROP_TRANSLATION => 142 , SQL_DROP_VIEW => 143 , SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 144 , SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 145 , SQL_EXPRESSIONS_IN_ORDERBY => 27 , SQL_FETCH_DIRECTION => 8 , SQL_FILE_USAGE => 84 , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 146 , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 147 , SQL_GETDATA_EXTENSIONS => 81 , SQL_GROUP_BY => 88 , SQL_IDENTIFIER_CASE => 28 , SQL_IDENTIFIER_QUOTE_CHAR => 29 , SQL_INDEX_KEYWORDS => 148 # SQL_INFO_DRIVER_START => 1000 # SQL_INFO_FIRST => 0 # SQL_INFO_LAST => 114 # SQL_QUALIFIER_LOCATION , SQL_INFO_SCHEMA_VIEWS => 149 , SQL_INSERT_STATEMENT => 172 , SQL_INTEGRITY => 73 , SQL_KEYSET_CURSOR_ATTRIBUTES1 => 150 , SQL_KEYSET_CURSOR_ATTRIBUTES2 => 151 , SQL_KEYWORDS => 89 , SQL_LIKE_ESCAPE_CLAUSE => 113 , SQL_LOCK_TYPES => 78 , SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 # SQL_MAX_CATALOG_NAME_LEN , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 # SQL_MAX_COLUMNS_IN_GROUP_BY , SQL_MAXIMUM_COLUMNS_IN_INDEX => 98 # SQL_MAX_COLUMNS_IN_INDEX , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 # SQL_MAX_COLUMNS_IN_ORDER_BY , SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 # SQL_MAX_COLUMNS_IN_SELECT , SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 # SQL_MAX_COLUMN_NAME_LEN , SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 # SQL_MAX_CONCURRENT_ACTIVITIES , SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 # SQL_MAX_CURSOR_NAME_LEN , SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 # SQL_MAX_DRIVER_CONNECTIONS , SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 # SQL_MAX_IDENTIFIER_LEN , SQL_MAXIMUM_INDEX_SIZE => 102 # SQL_MAX_INDEX_SIZE , SQL_MAXIMUM_ROW_SIZE => 104 # SQL_MAX_ROW_SIZE , SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 # SQL_MAX_SCHEMA_NAME_LEN , SQL_MAXIMUM_STATEMENT_LENGTH => 105 # SQL_MAX_STATEMENT_LEN , SQL_MAXIMUM_TABLES_IN_SELECT => 106 # SQL_MAX_TABLES_IN_SELECT , SQL_MAXIMUM_USER_NAME_LENGTH => 107 # SQL_MAX_USER_NAME_LEN , SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 10022 , SQL_MAX_BINARY_LITERAL_LEN => 112 , SQL_MAX_CATALOG_NAME_LEN => 34 , SQL_MAX_CHAR_LITERAL_LEN => 108 , SQL_MAX_COLUMNS_IN_GROUP_BY => 97 , SQL_MAX_COLUMNS_IN_INDEX => 98 , SQL_MAX_COLUMNS_IN_ORDER_BY => 99 , SQL_MAX_COLUMNS_IN_SELECT => 100 , SQL_MAX_COLUMNS_IN_TABLE => 101 , SQL_MAX_COLUMN_NAME_LEN => 30 , SQL_MAX_CONCURRENT_ACTIVITIES => 1 , SQL_MAX_CURSOR_NAME_LEN => 31 , SQL_MAX_DRIVER_CONNECTIONS => 0 , SQL_MAX_IDENTIFIER_LEN => 10005 , SQL_MAX_INDEX_SIZE => 102 , SQL_MAX_OWNER_NAME_LEN => 32 , SQL_MAX_PROCEDURE_NAME_LEN => 33 , SQL_MAX_QUALIFIER_NAME_LEN => 34 , SQL_MAX_ROW_SIZE => 104 , SQL_MAX_ROW_SIZE_INCLUDES_LONG => 103 , SQL_MAX_SCHEMA_NAME_LEN => 32 , SQL_MAX_STATEMENT_LEN => 105 , SQL_MAX_TABLES_IN_SELECT => 106 , SQL_MAX_TABLE_NAME_LEN => 35 , SQL_MAX_USER_NAME_LEN => 107 , SQL_MULTIPLE_ACTIVE_TXN => 37 , SQL_MULT_RESULT_SETS => 36 , SQL_NEED_LONG_DATA_LEN => 111 , SQL_NON_NULLABLE_COLUMNS => 75 , SQL_NULL_COLLATION => 85 , SQL_NUMERIC_FUNCTIONS => 49 , SQL_ODBC_API_CONFORMANCE => 9 , SQL_ODBC_INTERFACE_CONFORMANCE => 152 , SQL_ODBC_SAG_CLI_CONFORMANCE => 12 , SQL_ODBC_SQL_CONFORMANCE => 15 , SQL_ODBC_SQL_OPT_IEF => 73 , SQL_ODBC_VER => 10 , SQL_OJ_CAPABILITIES => 115 , SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 , SQL_OUTER_JOINS => 38 , SQL_OUTER_JOIN_CAPABILITIES => 115 # SQL_OJ_CAPABILITIES , SQL_OWNER_TERM => 39 , SQL_OWNER_USAGE => 91 , SQL_PARAM_ARRAY_ROW_COUNTS => 153 , SQL_PARAM_ARRAY_SELECTS => 154 , SQL_POSITIONED_STATEMENTS => 80 , SQL_POS_OPERATIONS => 79 , SQL_PROCEDURES => 21 , SQL_PROCEDURE_TERM => 40 , SQL_QUALIFIER_LOCATION => 114 , SQL_QUALIFIER_NAME_SEPARATOR => 41 , SQL_QUALIFIER_TERM => 42 , SQL_QUALIFIER_USAGE => 92 , SQL_QUOTED_IDENTIFIER_CASE => 93 , SQL_ROW_UPDATES => 11 , SQL_SCHEMA_TERM => 39 # SQL_OWNER_TERM , SQL_SCHEMA_USAGE => 91 # SQL_OWNER_USAGE , SQL_SCROLL_CONCURRENCY => 43 , SQL_SCROLL_OPTIONS => 44 , SQL_SEARCH_PATTERN_ESCAPE => 14 , SQL_SERVER_NAME => 13 , SQL_SPECIAL_CHARACTERS => 94 , SQL_SQL92_DATETIME_FUNCTIONS => 155 , SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 156 , SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 157 , SQL_SQL92_GRANT => 158 , SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 159 , SQL_SQL92_PREDICATES => 160 , SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 161 , SQL_SQL92_REVOKE => 162 , SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 163 , SQL_SQL92_STRING_FUNCTIONS => 164 , SQL_SQL92_VALUE_EXPRESSIONS => 165 , SQL_SQL_CONFORMANCE => 118 , SQL_STANDARD_CLI_CONFORMANCE => 166 , SQL_STATIC_CURSOR_ATTRIBUTES1 => 167 , SQL_STATIC_CURSOR_ATTRIBUTES2 => 168 , SQL_STATIC_SENSITIVITY => 83 , SQL_STRING_FUNCTIONS => 50 , SQL_SUBQUERIES => 95 , SQL_SYSTEM_FUNCTIONS => 51 , SQL_TABLE_TERM => 45 , SQL_TIMEDATE_ADD_INTERVALS => 109 , SQL_TIMEDATE_DIFF_INTERVALS => 110 , SQL_TIMEDATE_FUNCTIONS => 52 , SQL_TRANSACTION_CAPABLE => 46 # SQL_TXN_CAPABLE , SQL_TRANSACTION_ISOLATION_OPTION => 72 # SQL_TXN_ISOLATION_OPTION , SQL_TXN_CAPABLE => 46 , SQL_TXN_ISOLATION_OPTION => 72 , SQL_UNION => 96 , SQL_UNION_STATEMENT => 96 # SQL_UNION , SQL_USER_NAME => 47 , SQL_XOPEN_CLI_YEAR => 10000 ); =head2 %ReturnTypes See: mk:@MSITStore:X:\dm\cli\mdac\sdk26\Docs\odbc.chm::/htm/odbcsqlgetinfo.htm => : alias => !!! : edited =cut %ReturnTypes = ( SQL_ACCESSIBLE_PROCEDURES => 'SQLCHAR' # 20 , SQL_ACCESSIBLE_TABLES => 'SQLCHAR' # 19 , SQL_ACTIVE_CONNECTIONS => 'SQLUSMALLINT' # 0 => , SQL_ACTIVE_ENVIRONMENTS => 'SQLUSMALLINT' # 116 , SQL_ACTIVE_STATEMENTS => 'SQLUSMALLINT' # 1 => , SQL_AGGREGATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 169 , SQL_ALTER_DOMAIN => 'SQLUINTEGER bitmask' # 117 , SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # 86 , SQL_ASYNC_MODE => 'SQLUINTEGER' # 10021 , SQL_BATCH_ROW_COUNT => 'SQLUINTEGER bitmask' # 120 , SQL_BATCH_SUPPORT => 'SQLUINTEGER bitmask' # 121 , SQL_BOOKMARK_PERSISTENCE => 'SQLUINTEGER bitmask' # 82 , SQL_CATALOG_LOCATION => 'SQLUSMALLINT' # 114 , SQL_CATALOG_NAME => 'SQLCHAR' # 10003 , SQL_CATALOG_NAME_SEPARATOR => 'SQLCHAR' # 41 , SQL_CATALOG_TERM => 'SQLCHAR' # 42 , SQL_CATALOG_USAGE => 'SQLUINTEGER bitmask' # 92 , SQL_COLLATION_SEQ => 'SQLCHAR' # 10004 , SQL_COLUMN_ALIAS => 'SQLCHAR' # 87 , SQL_CONCAT_NULL_BEHAVIOR => 'SQLUSMALLINT' # 22 , SQL_CONVERT_BIGINT => 'SQLUINTEGER bitmask' # 53 , SQL_CONVERT_BINARY => 'SQLUINTEGER bitmask' # 54 , SQL_CONVERT_BIT => 'SQLUINTEGER bitmask' # 55 , SQL_CONVERT_CHAR => 'SQLUINTEGER bitmask' # 56 , SQL_CONVERT_DATE => 'SQLUINTEGER bitmask' # 57 , SQL_CONVERT_DECIMAL => 'SQLUINTEGER bitmask' # 58 , SQL_CONVERT_DOUBLE => 'SQLUINTEGER bitmask' # 59 , SQL_CONVERT_FLOAT => 'SQLUINTEGER bitmask' # 60 , SQL_CONVERT_FUNCTIONS => 'SQLUINTEGER bitmask' # 48 , SQL_CONVERT_GUID => 'SQLUINTEGER bitmask' # 173 , SQL_CONVERT_INTEGER => 'SQLUINTEGER bitmask' # 61 , SQL_CONVERT_INTERVAL_DAY_TIME => 'SQLUINTEGER bitmask' # 123 , SQL_CONVERT_INTERVAL_YEAR_MONTH => 'SQLUINTEGER bitmask' # 124 , SQL_CONVERT_LONGVARBINARY => 'SQLUINTEGER bitmask' # 71 , SQL_CONVERT_LONGVARCHAR => 'SQLUINTEGER bitmask' # 62 , SQL_CONVERT_NUMERIC => 'SQLUINTEGER bitmask' # 63 , SQL_CONVERT_REAL => 'SQLUINTEGER bitmask' # 64 , SQL_CONVERT_SMALLINT => 'SQLUINTEGER bitmask' # 65 , SQL_CONVERT_TIME => 'SQLUINTEGER bitmask' # 66 , SQL_CONVERT_TIMESTAMP => 'SQLUINTEGER bitmask' # 67 , SQL_CONVERT_TINYINT => 'SQLUINTEGER bitmask' # 68 , SQL_CONVERT_VARBINARY => 'SQLUINTEGER bitmask' # 69 , SQL_CONVERT_VARCHAR => 'SQLUINTEGER bitmask' # 70 , SQL_CONVERT_WCHAR => 'SQLUINTEGER bitmask' # 122 => !!! , SQL_CONVERT_WLONGVARCHAR => 'SQLUINTEGER bitmask' # 125 => !!! , SQL_CONVERT_WVARCHAR => 'SQLUINTEGER bitmask' # 126 => !!! , SQL_CORRELATION_NAME => 'SQLUSMALLINT' # 74 , SQL_CREATE_ASSERTION => 'SQLUINTEGER bitmask' # 127 , SQL_CREATE_CHARACTER_SET => 'SQLUINTEGER bitmask' # 128 , SQL_CREATE_COLLATION => 'SQLUINTEGER bitmask' # 129 , SQL_CREATE_DOMAIN => 'SQLUINTEGER bitmask' # 130 , SQL_CREATE_SCHEMA => 'SQLUINTEGER bitmask' # 131 , SQL_CREATE_TABLE => 'SQLUINTEGER bitmask' # 132 , SQL_CREATE_TRANSLATION => 'SQLUINTEGER bitmask' # 133 , SQL_CREATE_VIEW => 'SQLUINTEGER bitmask' # 134 , SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # 23 , SQL_CURSOR_ROLLBACK_BEHAVIOR => 'SQLUSMALLINT' # 24 , SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # 10001 , SQL_DATA_SOURCE_NAME => 'SQLCHAR' # 2 , SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # 25 , SQL_DATABASE_NAME => 'SQLCHAR' # 16 , SQL_DATETIME_LITERALS => 'SQLUINTEGER bitmask' # 119 , SQL_DBMS_NAME => 'SQLCHAR' # 17 , SQL_DBMS_VER => 'SQLCHAR' # 18 , SQL_DDL_INDEX => 'SQLUINTEGER bitmask' # 170 , SQL_DEFAULT_TXN_ISOLATION => 'SQLUINTEGER' # 26 , SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # 10002 , SQL_DM_VER => 'SQLCHAR' # 171 , SQL_DRIVER_HDBC => 'SQLUINTEGER' # 3 , SQL_DRIVER_HDESC => 'SQLUINTEGER' # 135 , SQL_DRIVER_HENV => 'SQLUINTEGER' # 4 , SQL_DRIVER_HLIB => 'SQLUINTEGER' # 76 , SQL_DRIVER_HSTMT => 'SQLUINTEGER' # 5 , SQL_DRIVER_NAME => 'SQLCHAR' # 6 , SQL_DRIVER_ODBC_VER => 'SQLCHAR' # 77 , SQL_DRIVER_VER => 'SQLCHAR' # 7 , SQL_DROP_ASSERTION => 'SQLUINTEGER bitmask' # 136 , SQL_DROP_CHARACTER_SET => 'SQLUINTEGER bitmask' # 137 , SQL_DROP_COLLATION => 'SQLUINTEGER bitmask' # 138 , SQL_DROP_DOMAIN => 'SQLUINTEGER bitmask' # 139 , SQL_DROP_SCHEMA => 'SQLUINTEGER bitmask' # 140 , SQL_DROP_TABLE => 'SQLUINTEGER bitmask' # 141 , SQL_DROP_TRANSLATION => 'SQLUINTEGER bitmask' # 142 , SQL_DROP_VIEW => 'SQLUINTEGER bitmask' # 143 , SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 144 , SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 145 , SQL_EXPRESSIONS_IN_ORDERBY => 'SQLCHAR' # 27 , SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # 8 => !!! , SQL_FILE_USAGE => 'SQLUSMALLINT' # 84 , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 146 , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 147 , SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # 81 , SQL_GROUP_BY => 'SQLUSMALLINT' # 88 , SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # 28 , SQL_IDENTIFIER_QUOTE_CHAR => 'SQLCHAR' # 29 , SQL_INDEX_KEYWORDS => 'SQLUINTEGER bitmask' # 148 # SQL_INFO_DRIVER_START => '' # 1000 => # SQL_INFO_FIRST => 'SQLUSMALLINT' # 0 => # SQL_INFO_LAST => 'SQLUSMALLINT' # 114 => , SQL_INFO_SCHEMA_VIEWS => 'SQLUINTEGER bitmask' # 149 , SQL_INSERT_STATEMENT => 'SQLUINTEGER bitmask' # 172 , SQL_INTEGRITY => 'SQLCHAR' # 73 , SQL_KEYSET_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 150 , SQL_KEYSET_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 151 , SQL_KEYWORDS => 'SQLCHAR' # 89 , SQL_LIKE_ESCAPE_CLAUSE => 'SQLCHAR' # 113 , SQL_LOCK_TYPES => 'SQLUINTEGER bitmask' # 78 => !!! , SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # 34 => , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 => , SQL_MAXIMUM_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 => , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 => , SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 => , SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # 30 => , SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 => , SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # 31 => , SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 => , SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # 10005 => , SQL_MAXIMUM_INDEX_SIZE => 'SQLUINTEGER' # 102 => , SQL_MAXIMUM_ROW_SIZE => 'SQLUINTEGER' # 104 => , SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # 32 => , SQL_MAXIMUM_STATEMENT_LENGTH => 'SQLUINTEGER' # 105 => , SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 => , SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # 107 => , SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 'SQLUINTEGER' # 10022 , SQL_MAX_BINARY_LITERAL_LEN => 'SQLUINTEGER' # 112 , SQL_MAX_CATALOG_NAME_LEN => 'SQLUSMALLINT' # 34 , SQL_MAX_CHAR_LITERAL_LEN => 'SQLUINTEGER' # 108 , SQL_MAX_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 , SQL_MAX_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 , SQL_MAX_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 , SQL_MAX_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 , SQL_MAX_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # 101 , SQL_MAX_COLUMN_NAME_LEN => 'SQLUSMALLINT' # 30 , SQL_MAX_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 , SQL_MAX_CURSOR_NAME_LEN => 'SQLUSMALLINT' # 31 , SQL_MAX_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 , SQL_MAX_IDENTIFIER_LEN => 'SQLUSMALLINT' # 10005 , SQL_MAX_INDEX_SIZE => 'SQLUINTEGER' # 102 , SQL_MAX_OWNER_NAME_LEN => 'SQLUSMALLINT' # 32 => , SQL_MAX_PROCEDURE_NAME_LEN => 'SQLUSMALLINT' # 33 , SQL_MAX_QUALIFIER_NAME_LEN => 'SQLUSMALLINT' # 34 => , SQL_MAX_ROW_SIZE => 'SQLUINTEGER' # 104 , SQL_MAX_ROW_SIZE_INCLUDES_LONG => 'SQLCHAR' # 103 , SQL_MAX_SCHEMA_NAME_LEN => 'SQLUSMALLINT' # 32 , SQL_MAX_STATEMENT_LEN => 'SQLUINTEGER' # 105 , SQL_MAX_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 , SQL_MAX_TABLE_NAME_LEN => 'SQLUSMALLINT' # 35 , SQL_MAX_USER_NAME_LEN => 'SQLUSMALLINT' # 107 , SQL_MULTIPLE_ACTIVE_TXN => 'SQLCHAR' # 37 , SQL_MULT_RESULT_SETS => 'SQLCHAR' # 36 , SQL_NEED_LONG_DATA_LEN => 'SQLCHAR' # 111 , SQL_NON_NULLABLE_COLUMNS => 'SQLUSMALLINT' # 75 , SQL_NULL_COLLATION => 'SQLUSMALLINT' # 85 , SQL_NUMERIC_FUNCTIONS => 'SQLUINTEGER bitmask' # 49 , SQL_ODBC_API_CONFORMANCE => 'SQLUSMALLINT' # 9 => !!! , SQL_ODBC_INTERFACE_CONFORMANCE => 'SQLUINTEGER' # 152 , SQL_ODBC_SAG_CLI_CONFORMANCE => 'SQLUSMALLINT' # 12 => !!! , SQL_ODBC_SQL_CONFORMANCE => 'SQLUSMALLINT' # 15 => !!! , SQL_ODBC_SQL_OPT_IEF => 'SQLCHAR' # 73 => , SQL_ODBC_VER => 'SQLCHAR' # 10 , SQL_OJ_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 , SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # 90 , SQL_OUTER_JOINS => 'SQLCHAR' # 38 => !!! , SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 => , SQL_OWNER_TERM => 'SQLCHAR' # 39 => , SQL_OWNER_USAGE => 'SQLUINTEGER bitmask' # 91 => , SQL_PARAM_ARRAY_ROW_COUNTS => 'SQLUINTEGER' # 153 , SQL_PARAM_ARRAY_SELECTS => 'SQLUINTEGER' # 154 , SQL_POSITIONED_STATEMENTS => 'SQLUINTEGER bitmask' # 80 => !!! , SQL_POS_OPERATIONS => 'SQLINTEGER bitmask' # 79 , SQL_PROCEDURES => 'SQLCHAR' # 21 , SQL_PROCEDURE_TERM => 'SQLCHAR' # 40 , SQL_QUALIFIER_LOCATION => 'SQLUSMALLINT' # 114 => , SQL_QUALIFIER_NAME_SEPARATOR => 'SQLCHAR' # 41 => , SQL_QUALIFIER_TERM => 'SQLCHAR' # 42 => , SQL_QUALIFIER_USAGE => 'SQLUINTEGER bitmask' # 92 => , SQL_QUOTED_IDENTIFIER_CASE => 'SQLUSMALLINT' # 93 , SQL_ROW_UPDATES => 'SQLCHAR' # 11 , SQL_SCHEMA_TERM => 'SQLCHAR' # 39 , SQL_SCHEMA_USAGE => 'SQLUINTEGER bitmask' # 91 , SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # 43 => !!! , SQL_SCROLL_OPTIONS => 'SQLUINTEGER bitmask' # 44 , SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # 14 , SQL_SERVER_NAME => 'SQLCHAR' # 13 , SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # 94 , SQL_SQL92_DATETIME_FUNCTIONS => 'SQLUINTEGER bitmask' # 155 , SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 'SQLUINTEGER bitmask' # 156 , SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 'SQLUINTEGER bitmask' # 157 , SQL_SQL92_GRANT => 'SQLUINTEGER bitmask' # 158 , SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 'SQLUINTEGER bitmask' # 159 , SQL_SQL92_PREDICATES => 'SQLUINTEGER bitmask' # 160 , SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 'SQLUINTEGER bitmask' # 161 , SQL_SQL92_REVOKE => 'SQLUINTEGER bitmask' # 162 , SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 'SQLUINTEGER bitmask' # 163 , SQL_SQL92_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 164 , SQL_SQL92_VALUE_EXPRESSIONS => 'SQLUINTEGER bitmask' # 165 , SQL_SQL_CONFORMANCE => 'SQLUINTEGER' # 118 , SQL_STANDARD_CLI_CONFORMANCE => 'SQLUINTEGER bitmask' # 166 , SQL_STATIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 167 , SQL_STATIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 168 , SQL_STATIC_SENSITIVITY => 'SQLUINTEGER bitmask' # 83 => !!! , SQL_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 50 , SQL_SUBQUERIES => 'SQLUINTEGER bitmask' # 95 , SQL_SYSTEM_FUNCTIONS => 'SQLUINTEGER bitmask' # 51 , SQL_TABLE_TERM => 'SQLCHAR' # 45 , SQL_TIMEDATE_ADD_INTERVALS => 'SQLUINTEGER bitmask' # 109 , SQL_TIMEDATE_DIFF_INTERVALS => 'SQLUINTEGER bitmask' # 110 , SQL_TIMEDATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 52 , SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # 46 => , SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 => , SQL_TXN_CAPABLE => 'SQLUSMALLINT' # 46 , SQL_TXN_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 , SQL_UNION => 'SQLUINTEGER bitmask' # 96 , SQL_UNION_STATEMENT => 'SQLUINTEGER bitmask' # 96 => , SQL_USER_NAME => 'SQLCHAR' # 47 , SQL_XOPEN_CLI_YEAR => 'SQLCHAR' # 10000 ); =head2 %ReturnValues See: sql.h, sqlext.h Edited: SQL_TXN_ISOLATION_OPTION =cut $ReturnValues{SQL_AGGREGATE_FUNCTIONS} = { SQL_AF_AVG => 0x00000001 , SQL_AF_COUNT => 0x00000002 , SQL_AF_MAX => 0x00000004 , SQL_AF_MIN => 0x00000008 , SQL_AF_SUM => 0x00000010 , SQL_AF_DISTINCT => 0x00000020 , SQL_AF_ALL => 0x00000040 }; $ReturnValues{SQL_ALTER_DOMAIN} = { SQL_AD_CONSTRAINT_NAME_DEFINITION => 0x00000001 , SQL_AD_ADD_DOMAIN_CONSTRAINT => 0x00000002 , SQL_AD_DROP_DOMAIN_CONSTRAINT => 0x00000004 , SQL_AD_ADD_DOMAIN_DEFAULT => 0x00000008 , SQL_AD_DROP_DOMAIN_DEFAULT => 0x00000010 , SQL_AD_ADD_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 , SQL_AD_ADD_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 , SQL_AD_ADD_CONSTRAINT_DEFERRABLE => 0x00000080 , SQL_AD_ADD_CONSTRAINT_NON_DEFERRABLE => 0x00000100 }; $ReturnValues{SQL_ALTER_TABLE} = { SQL_AT_ADD_COLUMN => 0x00000001 , SQL_AT_DROP_COLUMN => 0x00000002 , SQL_AT_ADD_CONSTRAINT => 0x00000008 , SQL_AT_ADD_COLUMN_SINGLE => 0x00000020 , SQL_AT_ADD_COLUMN_DEFAULT => 0x00000040 , SQL_AT_ADD_COLUMN_COLLATION => 0x00000080 , SQL_AT_SET_COLUMN_DEFAULT => 0x00000100 , SQL_AT_DROP_COLUMN_DEFAULT => 0x00000200 , SQL_AT_DROP_COLUMN_CASCADE => 0x00000400 , SQL_AT_DROP_COLUMN_RESTRICT => 0x00000800 , SQL_AT_ADD_TABLE_CONSTRAINT => 0x00001000 , SQL_AT_DROP_TABLE_CONSTRAINT_CASCADE => 0x00002000 , SQL_AT_DROP_TABLE_CONSTRAINT_RESTRICT => 0x00004000 , SQL_AT_CONSTRAINT_NAME_DEFINITION => 0x00008000 , SQL_AT_CONSTRAINT_INITIALLY_DEFERRED => 0x00010000 , SQL_AT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00020000 , SQL_AT_CONSTRAINT_DEFERRABLE => 0x00040000 , SQL_AT_CONSTRAINT_NON_DEFERRABLE => 0x00080000 }; $ReturnValues{SQL_ASYNC_MODE} = { SQL_AM_NONE => 0 , SQL_AM_CONNECTION => 1 , SQL_AM_STATEMENT => 2 }; $ReturnValues{SQL_ATTR_MAX_ROWS} = { SQL_CA2_MAX_ROWS_SELECT => 0x00000080 , SQL_CA2_MAX_ROWS_INSERT => 0x00000100 , SQL_CA2_MAX_ROWS_DELETE => 0x00000200 , SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 , SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 # SQL_CA2_MAX_ROWS_AFFECTS_ALL => }; $ReturnValues{SQL_ATTR_SCROLL_CONCURRENCY} = { SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 , SQL_CA2_LOCK_CONCURRENCY => 0x00000002 , SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 , SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 , SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 , SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 , SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 }; $ReturnValues{SQL_BATCH_ROW_COUNT} = { SQL_BRC_PROCEDURES => 0x0000001 , SQL_BRC_EXPLICIT => 0x0000002 , SQL_BRC_ROLLED_UP => 0x0000004 }; $ReturnValues{SQL_BATCH_SUPPORT} = { SQL_BS_SELECT_EXPLICIT => 0x00000001 , SQL_BS_ROW_COUNT_EXPLICIT => 0x00000002 , SQL_BS_SELECT_PROC => 0x00000004 , SQL_BS_ROW_COUNT_PROC => 0x00000008 }; $ReturnValues{SQL_BOOKMARK_PERSISTENCE} = { SQL_BP_CLOSE => 0x00000001 , SQL_BP_DELETE => 0x00000002 , SQL_BP_DROP => 0x00000004 , SQL_BP_TRANSACTION => 0x00000008 , SQL_BP_UPDATE => 0x00000010 , SQL_BP_OTHER_HSTMT => 0x00000020 , SQL_BP_SCROLL => 0x00000040 }; $ReturnValues{SQL_CATALOG_LOCATION} = { SQL_CL_START => 0x0001 # SQL_QL_START , SQL_CL_END => 0x0002 # SQL_QL_END }; $ReturnValues{SQL_CATALOG_USAGE} = { SQL_CU_DML_STATEMENTS => 0x00000001 # SQL_QU_DML_STATEMENTS , SQL_CU_PROCEDURE_INVOCATION => 0x00000002 # SQL_QU_PROCEDURE_INVOCATION , SQL_CU_TABLE_DEFINITION => 0x00000004 # SQL_QU_TABLE_DEFINITION , SQL_CU_INDEX_DEFINITION => 0x00000008 # SQL_QU_INDEX_DEFINITION , SQL_CU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_QU_PRIVILEGE_DEFINITION }; $ReturnValues{SQL_CONCAT_NULL_BEHAVIOR} = { SQL_CB_NULL => 0x0000 , SQL_CB_NON_NULL => 0x0001 }; $ReturnValues{SQL_CONVERT_} = { SQL_CVT_CHAR => 0x00000001 , SQL_CVT_NUMERIC => 0x00000002 , SQL_CVT_DECIMAL => 0x00000004 , SQL_CVT_INTEGER => 0x00000008 , SQL_CVT_SMALLINT => 0x00000010 , SQL_CVT_FLOAT => 0x00000020 , SQL_CVT_REAL => 0x00000040 , SQL_CVT_DOUBLE => 0x00000080 , SQL_CVT_VARCHAR => 0x00000100 , SQL_CVT_LONGVARCHAR => 0x00000200 , SQL_CVT_BINARY => 0x00000400 , SQL_CVT_VARBINARY => 0x00000800 , SQL_CVT_BIT => 0x00001000 , SQL_CVT_TINYINT => 0x00002000 , SQL_CVT_BIGINT => 0x00004000 , SQL_CVT_DATE => 0x00008000 , SQL_CVT_TIME => 0x00010000 , SQL_CVT_TIMESTAMP => 0x00020000 , SQL_CVT_LONGVARBINARY => 0x00040000 , SQL_CVT_INTERVAL_YEAR_MONTH => 0x00080000 , SQL_CVT_INTERVAL_DAY_TIME => 0x00100000 , SQL_CVT_WCHAR => 0x00200000 , SQL_CVT_WLONGVARCHAR => 0x00400000 , SQL_CVT_WVARCHAR => 0x00800000 , SQL_CVT_GUID => 0x01000000 }; $ReturnValues{SQL_CONVERT_BIGINT } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_BINARY } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_BIT } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_CHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_DATE } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_DECIMAL } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_DOUBLE } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_FLOAT } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_GUID } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_INTEGER } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_INTERVAL_DAY_TIME } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_INTERVAL_YEAR_MONTH} = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_LONGVARBINARY } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_LONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_NUMERIC } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_REAL } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_SMALLINT } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_TIME } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_TIMESTAMP } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_TINYINT } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_VARBINARY } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_VARCHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_WCHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_WLONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_WVARCHAR } = $ReturnValues{SQL_CONVERT_}; $ReturnValues{SQL_CONVERT_FUNCTIONS} = { SQL_FN_CVT_CONVERT => 0x00000001 , SQL_FN_CVT_CAST => 0x00000002 }; $ReturnValues{SQL_CORRELATION_NAME} = { SQL_CN_NONE => 0x0000 , SQL_CN_DIFFERENT => 0x0001 , SQL_CN_ANY => 0x0002 }; $ReturnValues{SQL_CREATE_ASSERTION} = { SQL_CA_CREATE_ASSERTION => 0x00000001 , SQL_CA_CONSTRAINT_INITIALLY_DEFERRED => 0x00000010 , SQL_CA_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000020 , SQL_CA_CONSTRAINT_DEFERRABLE => 0x00000040 , SQL_CA_CONSTRAINT_NON_DEFERRABLE => 0x00000080 }; $ReturnValues{SQL_CREATE_CHARACTER_SET} = { SQL_CCS_CREATE_CHARACTER_SET => 0x00000001 , SQL_CCS_COLLATE_CLAUSE => 0x00000002 , SQL_CCS_LIMITED_COLLATION => 0x00000004 }; $ReturnValues{SQL_CREATE_COLLATION} = { SQL_CCOL_CREATE_COLLATION => 0x00000001 }; $ReturnValues{SQL_CREATE_DOMAIN} = { SQL_CDO_CREATE_DOMAIN => 0x00000001 , SQL_CDO_DEFAULT => 0x00000002 , SQL_CDO_CONSTRAINT => 0x00000004 , SQL_CDO_COLLATION => 0x00000008 , SQL_CDO_CONSTRAINT_NAME_DEFINITION => 0x00000010 , SQL_CDO_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 , SQL_CDO_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 , SQL_CDO_CONSTRAINT_DEFERRABLE => 0x00000080 , SQL_CDO_CONSTRAINT_NON_DEFERRABLE => 0x00000100 }; $ReturnValues{SQL_CREATE_SCHEMA} = { SQL_CS_CREATE_SCHEMA => 0x00000001 , SQL_CS_AUTHORIZATION => 0x00000002 , SQL_CS_DEFAULT_CHARACTER_SET => 0x00000004 }; $ReturnValues{SQL_CREATE_TABLE} = { SQL_CT_CREATE_TABLE => 0x00000001 , SQL_CT_COMMIT_PRESERVE => 0x00000002 , SQL_CT_COMMIT_DELETE => 0x00000004 , SQL_CT_GLOBAL_TEMPORARY => 0x00000008 , SQL_CT_LOCAL_TEMPORARY => 0x00000010 , SQL_CT_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 , SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 , SQL_CT_CONSTRAINT_DEFERRABLE => 0x00000080 , SQL_CT_CONSTRAINT_NON_DEFERRABLE => 0x00000100 , SQL_CT_COLUMN_CONSTRAINT => 0x00000200 , SQL_CT_COLUMN_DEFAULT => 0x00000400 , SQL_CT_COLUMN_COLLATION => 0x00000800 , SQL_CT_TABLE_CONSTRAINT => 0x00001000 , SQL_CT_CONSTRAINT_NAME_DEFINITION => 0x00002000 }; $ReturnValues{SQL_CREATE_TRANSLATION} = { SQL_CTR_CREATE_TRANSLATION => 0x00000001 }; $ReturnValues{SQL_CREATE_VIEW} = { SQL_CV_CREATE_VIEW => 0x00000001 , SQL_CV_CHECK_OPTION => 0x00000002 , SQL_CV_CASCADED => 0x00000004 , SQL_CV_LOCAL => 0x00000008 }; $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = { SQL_CB_DELETE => 0 , SQL_CB_CLOSE => 1 , SQL_CB_PRESERVE => 2 }; $ReturnValues{SQL_CURSOR_ROLLBACK_BEHAVIOR} = $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR}; $ReturnValues{SQL_CURSOR_SENSITIVITY} = { SQL_UNSPECIFIED => 0 , SQL_INSENSITIVE => 1 , SQL_SENSITIVE => 2 }; $ReturnValues{SQL_DATETIME_LITERALS} = { SQL_DL_SQL92_DATE => 0x00000001 , SQL_DL_SQL92_TIME => 0x00000002 , SQL_DL_SQL92_TIMESTAMP => 0x00000004 , SQL_DL_SQL92_INTERVAL_YEAR => 0x00000008 , SQL_DL_SQL92_INTERVAL_MONTH => 0x00000010 , SQL_DL_SQL92_INTERVAL_DAY => 0x00000020 , SQL_DL_SQL92_INTERVAL_HOUR => 0x00000040 , SQL_DL_SQL92_INTERVAL_MINUTE => 0x00000080 , SQL_DL_SQL92_INTERVAL_SECOND => 0x00000100 , SQL_DL_SQL92_INTERVAL_YEAR_TO_MONTH => 0x00000200 , SQL_DL_SQL92_INTERVAL_DAY_TO_HOUR => 0x00000400 , SQL_DL_SQL92_INTERVAL_DAY_TO_MINUTE => 0x00000800 , SQL_DL_SQL92_INTERVAL_DAY_TO_SECOND => 0x00001000 , SQL_DL_SQL92_INTERVAL_HOUR_TO_MINUTE => 0x00002000 , SQL_DL_SQL92_INTERVAL_HOUR_TO_SECOND => 0x00004000 , SQL_DL_SQL92_INTERVAL_MINUTE_TO_SECOND => 0x00008000 }; $ReturnValues{SQL_DDL_INDEX} = { SQL_DI_CREATE_INDEX => 0x00000001 , SQL_DI_DROP_INDEX => 0x00000002 }; $ReturnValues{SQL_DIAG_CURSOR_ROW_COUNT} = { SQL_CA2_CRC_EXACT => 0x00001000 , SQL_CA2_CRC_APPROXIMATE => 0x00002000 , SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 , SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 , SQL_CA2_SIMULATE_UNIQUE => 0x00010000 }; $ReturnValues{SQL_DROP_ASSERTION} = { SQL_DA_DROP_ASSERTION => 0x00000001 }; $ReturnValues{SQL_DROP_CHARACTER_SET} = { SQL_DCS_DROP_CHARACTER_SET => 0x00000001 }; $ReturnValues{SQL_DROP_COLLATION} = { SQL_DC_DROP_COLLATION => 0x00000001 }; $ReturnValues{SQL_DROP_DOMAIN} = { SQL_DD_DROP_DOMAIN => 0x00000001 , SQL_DD_RESTRICT => 0x00000002 , SQL_DD_CASCADE => 0x00000004 }; $ReturnValues{SQL_DROP_SCHEMA} = { SQL_DS_DROP_SCHEMA => 0x00000001 , SQL_DS_RESTRICT => 0x00000002 , SQL_DS_CASCADE => 0x00000004 }; $ReturnValues{SQL_DROP_TABLE} = { SQL_DT_DROP_TABLE => 0x00000001 , SQL_DT_RESTRICT => 0x00000002 , SQL_DT_CASCADE => 0x00000004 }; $ReturnValues{SQL_DROP_TRANSLATION} = { SQL_DTR_DROP_TRANSLATION => 0x00000001 }; $ReturnValues{SQL_DROP_VIEW} = { SQL_DV_DROP_VIEW => 0x00000001 , SQL_DV_RESTRICT => 0x00000002 , SQL_DV_CASCADE => 0x00000004 }; $ReturnValues{SQL_CURSOR_ATTRIBUTES1} = { SQL_CA1_NEXT => 0x00000001 , SQL_CA1_ABSOLUTE => 0x00000002 , SQL_CA1_RELATIVE => 0x00000004 , SQL_CA1_BOOKMARK => 0x00000008 , SQL_CA1_LOCK_NO_CHANGE => 0x00000040 , SQL_CA1_LOCK_EXCLUSIVE => 0x00000080 , SQL_CA1_LOCK_UNLOCK => 0x00000100 , SQL_CA1_POS_POSITION => 0x00000200 , SQL_CA1_POS_UPDATE => 0x00000400 , SQL_CA1_POS_DELETE => 0x00000800 , SQL_CA1_POS_REFRESH => 0x00001000 , SQL_CA1_POSITIONED_UPDATE => 0x00002000 , SQL_CA1_POSITIONED_DELETE => 0x00004000 , SQL_CA1_SELECT_FOR_UPDATE => 0x00008000 , SQL_CA1_BULK_ADD => 0x00010000 , SQL_CA1_BULK_UPDATE_BY_BOOKMARK => 0x00020000 , SQL_CA1_BULK_DELETE_BY_BOOKMARK => 0x00040000 , SQL_CA1_BULK_FETCH_BY_BOOKMARK => 0x00080000 }; $ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; $ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; $ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; $ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; $ReturnValues{SQL_CURSOR_ATTRIBUTES2} = { SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 , SQL_CA2_LOCK_CONCURRENCY => 0x00000002 , SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 , SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 , SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 , SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 , SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 , SQL_CA2_MAX_ROWS_SELECT => 0x00000080 , SQL_CA2_MAX_ROWS_INSERT => 0x00000100 , SQL_CA2_MAX_ROWS_DELETE => 0x00000200 , SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 , SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 , SQL_CA2_CRC_EXACT => 0x00001000 , SQL_CA2_CRC_APPROXIMATE => 0x00002000 , SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 , SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 , SQL_CA2_SIMULATE_UNIQUE => 0x00010000 }; $ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; $ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; $ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; $ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; $ReturnValues{SQL_FETCH_DIRECTION} = { SQL_FD_FETCH_NEXT => 0x00000001 , SQL_FD_FETCH_FIRST => 0x00000002 , SQL_FD_FETCH_LAST => 0x00000004 , SQL_FD_FETCH_PRIOR => 0x00000008 , SQL_FD_FETCH_ABSOLUTE => 0x00000010 , SQL_FD_FETCH_RELATIVE => 0x00000020 , SQL_FD_FETCH_RESUME => 0x00000040 , SQL_FD_FETCH_BOOKMARK => 0x00000080 }; $ReturnValues{SQL_FILE_USAGE} = { SQL_FILE_NOT_SUPPORTED => 0x0000 , SQL_FILE_TABLE => 0x0001 , SQL_FILE_QUALIFIER => 0x0002 , SQL_FILE_CATALOG => 0x0002 # SQL_FILE_QUALIFIER }; $ReturnValues{SQL_GETDATA_EXTENSIONS} = { SQL_GD_ANY_COLUMN => 0x00000001 , SQL_GD_ANY_ORDER => 0x00000002 , SQL_GD_BLOCK => 0x00000004 , SQL_GD_BOUND => 0x00000008 }; $ReturnValues{SQL_GROUP_BY} = { SQL_GB_NOT_SUPPORTED => 0x0000 , SQL_GB_GROUP_BY_EQUALS_SELECT => 0x0001 , SQL_GB_GROUP_BY_CONTAINS_SELECT => 0x0002 , SQL_GB_NO_RELATION => 0x0003 , SQL_GB_COLLATE => 0x0004 }; $ReturnValues{SQL_IDENTIFIER_CASE} = { SQL_IC_UPPER => 1 , SQL_IC_LOWER => 2 , SQL_IC_SENSITIVE => 3 , SQL_IC_MIXED => 4 }; $ReturnValues{SQL_INDEX_KEYWORDS} = { SQL_IK_NONE => 0x00000000 , SQL_IK_ASC => 0x00000001 , SQL_IK_DESC => 0x00000002 # SQL_IK_ALL => }; $ReturnValues{SQL_INFO_SCHEMA_VIEWS} = { SQL_ISV_ASSERTIONS => 0x00000001 , SQL_ISV_CHARACTER_SETS => 0x00000002 , SQL_ISV_CHECK_CONSTRAINTS => 0x00000004 , SQL_ISV_COLLATIONS => 0x00000008 , SQL_ISV_COLUMN_DOMAIN_USAGE => 0x00000010 , SQL_ISV_COLUMN_PRIVILEGES => 0x00000020 , SQL_ISV_COLUMNS => 0x00000040 , SQL_ISV_CONSTRAINT_COLUMN_USAGE => 0x00000080 , SQL_ISV_CONSTRAINT_TABLE_USAGE => 0x00000100 , SQL_ISV_DOMAIN_CONSTRAINTS => 0x00000200 , SQL_ISV_DOMAINS => 0x00000400 , SQL_ISV_KEY_COLUMN_USAGE => 0x00000800 , SQL_ISV_REFERENTIAL_CONSTRAINTS => 0x00001000 , SQL_ISV_SCHEMATA => 0x00002000 , SQL_ISV_SQL_LANGUAGES => 0x00004000 , SQL_ISV_TABLE_CONSTRAINTS => 0x00008000 , SQL_ISV_TABLE_PRIVILEGES => 0x00010000 , SQL_ISV_TABLES => 0x00020000 , SQL_ISV_TRANSLATIONS => 0x00040000 , SQL_ISV_USAGE_PRIVILEGES => 0x00080000 , SQL_ISV_VIEW_COLUMN_USAGE => 0x00100000 , SQL_ISV_VIEW_TABLE_USAGE => 0x00200000 , SQL_ISV_VIEWS => 0x00400000 }; $ReturnValues{SQL_INSERT_STATEMENT} = { SQL_IS_INSERT_LITERALS => 0x00000001 , SQL_IS_INSERT_SEARCHED => 0x00000002 , SQL_IS_SELECT_INTO => 0x00000004 }; $ReturnValues{SQL_LOCK_TYPES} = { SQL_LCK_NO_CHANGE => 0x00000001 , SQL_LCK_EXCLUSIVE => 0x00000002 , SQL_LCK_UNLOCK => 0x00000004 }; $ReturnValues{SQL_NON_NULLABLE_COLUMNS} = { SQL_NNC_NULL => 0x0000 , SQL_NNC_NON_NULL => 0x0001 }; $ReturnValues{SQL_NULL_COLLATION} = { SQL_NC_HIGH => 0 , SQL_NC_LOW => 1 , SQL_NC_START => 0x0002 , SQL_NC_END => 0x0004 }; $ReturnValues{SQL_NUMERIC_FUNCTIONS} = { SQL_FN_NUM_ABS => 0x00000001 , SQL_FN_NUM_ACOS => 0x00000002 , SQL_FN_NUM_ASIN => 0x00000004 , SQL_FN_NUM_ATAN => 0x00000008 , SQL_FN_NUM_ATAN2 => 0x00000010 , SQL_FN_NUM_CEILING => 0x00000020 , SQL_FN_NUM_COS => 0x00000040 , SQL_FN_NUM_COT => 0x00000080 , SQL_FN_NUM_EXP => 0x00000100 , SQL_FN_NUM_FLOOR => 0x00000200 , SQL_FN_NUM_LOG => 0x00000400 , SQL_FN_NUM_MOD => 0x00000800 , SQL_FN_NUM_SIGN => 0x00001000 , SQL_FN_NUM_SIN => 0x00002000 , SQL_FN_NUM_SQRT => 0x00004000 , SQL_FN_NUM_TAN => 0x00008000 , SQL_FN_NUM_PI => 0x00010000 , SQL_FN_NUM_RAND => 0x00020000 , SQL_FN_NUM_DEGREES => 0x00040000 , SQL_FN_NUM_LOG10 => 0x00080000 , SQL_FN_NUM_POWER => 0x00100000 , SQL_FN_NUM_RADIANS => 0x00200000 , SQL_FN_NUM_ROUND => 0x00400000 , SQL_FN_NUM_TRUNCATE => 0x00800000 }; $ReturnValues{SQL_ODBC_API_CONFORMANCE} = { SQL_OAC_NONE => 0x0000 , SQL_OAC_LEVEL1 => 0x0001 , SQL_OAC_LEVEL2 => 0x0002 }; $ReturnValues{SQL_ODBC_INTERFACE_CONFORMANCE} = { SQL_OIC_CORE => 1 , SQL_OIC_LEVEL1 => 2 , SQL_OIC_LEVEL2 => 3 }; $ReturnValues{SQL_ODBC_SAG_CLI_CONFORMANCE} = { SQL_OSCC_NOT_COMPLIANT => 0x0000 , SQL_OSCC_COMPLIANT => 0x0001 }; $ReturnValues{SQL_ODBC_SQL_CONFORMANCE} = { SQL_OSC_MINIMUM => 0x0000 , SQL_OSC_CORE => 0x0001 , SQL_OSC_EXTENDED => 0x0002 }; $ReturnValues{SQL_OJ_CAPABILITIES} = { SQL_OJ_LEFT => 0x00000001 , SQL_OJ_RIGHT => 0x00000002 , SQL_OJ_FULL => 0x00000004 , SQL_OJ_NESTED => 0x00000008 , SQL_OJ_NOT_ORDERED => 0x00000010 , SQL_OJ_INNER => 0x00000020 , SQL_OJ_ALL_COMPARISON_OPS => 0x00000040 }; $ReturnValues{SQL_OWNER_USAGE} = { SQL_OU_DML_STATEMENTS => 0x00000001 , SQL_OU_PROCEDURE_INVOCATION => 0x00000002 , SQL_OU_TABLE_DEFINITION => 0x00000004 , SQL_OU_INDEX_DEFINITION => 0x00000008 , SQL_OU_PRIVILEGE_DEFINITION => 0x00000010 }; $ReturnValues{SQL_PARAM_ARRAY_ROW_COUNTS} = { SQL_PARC_BATCH => 1 , SQL_PARC_NO_BATCH => 2 }; $ReturnValues{SQL_PARAM_ARRAY_SELECTS} = { SQL_PAS_BATCH => 1 , SQL_PAS_NO_BATCH => 2 , SQL_PAS_NO_SELECT => 3 }; $ReturnValues{SQL_POSITIONED_STATEMENTS} = { SQL_PS_POSITIONED_DELETE => 0x00000001 , SQL_PS_POSITIONED_UPDATE => 0x00000002 , SQL_PS_SELECT_FOR_UPDATE => 0x00000004 }; $ReturnValues{SQL_POS_OPERATIONS} = { SQL_POS_POSITION => 0x00000001 , SQL_POS_REFRESH => 0x00000002 , SQL_POS_UPDATE => 0x00000004 , SQL_POS_DELETE => 0x00000008 , SQL_POS_ADD => 0x00000010 }; $ReturnValues{SQL_QUALIFIER_LOCATION} = { SQL_QL_START => 0x0001 , SQL_QL_END => 0x0002 }; $ReturnValues{SQL_QUALIFIER_USAGE} = { SQL_QU_DML_STATEMENTS => 0x00000001 , SQL_QU_PROCEDURE_INVOCATION => 0x00000002 , SQL_QU_TABLE_DEFINITION => 0x00000004 , SQL_QU_INDEX_DEFINITION => 0x00000008 , SQL_QU_PRIVILEGE_DEFINITION => 0x00000010 }; $ReturnValues{SQL_QUOTED_IDENTIFIER_CASE} = $ReturnValues{SQL_IDENTIFIER_CASE}; $ReturnValues{SQL_SCHEMA_USAGE} = { SQL_SU_DML_STATEMENTS => 0x00000001 # SQL_OU_DML_STATEMENTS , SQL_SU_PROCEDURE_INVOCATION => 0x00000002 # SQL_OU_PROCEDURE_INVOCATION , SQL_SU_TABLE_DEFINITION => 0x00000004 # SQL_OU_TABLE_DEFINITION , SQL_SU_INDEX_DEFINITION => 0x00000008 # SQL_OU_INDEX_DEFINITION , SQL_SU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_OU_PRIVILEGE_DEFINITION }; $ReturnValues{SQL_SCROLL_CONCURRENCY} = { SQL_SCCO_READ_ONLY => 0x00000001 , SQL_SCCO_LOCK => 0x00000002 , SQL_SCCO_OPT_ROWVER => 0x00000004 , SQL_SCCO_OPT_VALUES => 0x00000008 }; $ReturnValues{SQL_SCROLL_OPTIONS} = { SQL_SO_FORWARD_ONLY => 0x00000001 , SQL_SO_KEYSET_DRIVEN => 0x00000002 , SQL_SO_DYNAMIC => 0x00000004 , SQL_SO_MIXED => 0x00000008 , SQL_SO_STATIC => 0x00000010 }; $ReturnValues{SQL_SQL92_DATETIME_FUNCTIONS} = { SQL_SDF_CURRENT_DATE => 0x00000001 , SQL_SDF_CURRENT_TIME => 0x00000002 , SQL_SDF_CURRENT_TIMESTAMP => 0x00000004 }; $ReturnValues{SQL_SQL92_FOREIGN_KEY_DELETE_RULE} = { SQL_SFKD_CASCADE => 0x00000001 , SQL_SFKD_NO_ACTION => 0x00000002 , SQL_SFKD_SET_DEFAULT => 0x00000004 , SQL_SFKD_SET_NULL => 0x00000008 }; $ReturnValues{SQL_SQL92_FOREIGN_KEY_UPDATE_RULE} = { SQL_SFKU_CASCADE => 0x00000001 , SQL_SFKU_NO_ACTION => 0x00000002 , SQL_SFKU_SET_DEFAULT => 0x00000004 , SQL_SFKU_SET_NULL => 0x00000008 }; $ReturnValues{SQL_SQL92_GRANT} = { SQL_SG_USAGE_ON_DOMAIN => 0x00000001 , SQL_SG_USAGE_ON_CHARACTER_SET => 0x00000002 , SQL_SG_USAGE_ON_COLLATION => 0x00000004 , SQL_SG_USAGE_ON_TRANSLATION => 0x00000008 , SQL_SG_WITH_GRANT_OPTION => 0x00000010 , SQL_SG_DELETE_TABLE => 0x00000020 , SQL_SG_INSERT_TABLE => 0x00000040 , SQL_SG_INSERT_COLUMN => 0x00000080 , SQL_SG_REFERENCES_TABLE => 0x00000100 , SQL_SG_REFERENCES_COLUMN => 0x00000200 , SQL_SG_SELECT_TABLE => 0x00000400 , SQL_SG_UPDATE_TABLE => 0x00000800 , SQL_SG_UPDATE_COLUMN => 0x00001000 }; $ReturnValues{SQL_SQL92_NUMERIC_VALUE_FUNCTIONS} = { SQL_SNVF_BIT_LENGTH => 0x00000001 , SQL_SNVF_CHAR_LENGTH => 0x00000002 , SQL_SNVF_CHARACTER_LENGTH => 0x00000004 , SQL_SNVF_EXTRACT => 0x00000008 , SQL_SNVF_OCTET_LENGTH => 0x00000010 , SQL_SNVF_POSITION => 0x00000020 }; $ReturnValues{SQL_SQL92_PREDICATES} = { SQL_SP_EXISTS => 0x00000001 , SQL_SP_ISNOTNULL => 0x00000002 , SQL_SP_ISNULL => 0x00000004 , SQL_SP_MATCH_FULL => 0x00000008 , SQL_SP_MATCH_PARTIAL => 0x00000010 , SQL_SP_MATCH_UNIQUE_FULL => 0x00000020 , SQL_SP_MATCH_UNIQUE_PARTIAL => 0x00000040 , SQL_SP_OVERLAPS => 0x00000080 , SQL_SP_UNIQUE => 0x00000100 , SQL_SP_LIKE => 0x00000200 , SQL_SP_IN => 0x00000400 , SQL_SP_BETWEEN => 0x00000800 , SQL_SP_COMPARISON => 0x00001000 , SQL_SP_QUANTIFIED_COMPARISON => 0x00002000 }; $ReturnValues{SQL_SQL92_RELATIONAL_JOIN_OPERATORS} = { SQL_SRJO_CORRESPONDING_CLAUSE => 0x00000001 , SQL_SRJO_CROSS_JOIN => 0x00000002 , SQL_SRJO_EXCEPT_JOIN => 0x00000004 , SQL_SRJO_FULL_OUTER_JOIN => 0x00000008 , SQL_SRJO_INNER_JOIN => 0x00000010 , SQL_SRJO_INTERSECT_JOIN => 0x00000020 , SQL_SRJO_LEFT_OUTER_JOIN => 0x00000040 , SQL_SRJO_NATURAL_JOIN => 0x00000080 , SQL_SRJO_RIGHT_OUTER_JOIN => 0x00000100 , SQL_SRJO_UNION_JOIN => 0x00000200 }; $ReturnValues{SQL_SQL92_REVOKE} = { SQL_SR_USAGE_ON_DOMAIN => 0x00000001 , SQL_SR_USAGE_ON_CHARACTER_SET => 0x00000002 , SQL_SR_USAGE_ON_COLLATION => 0x00000004 , SQL_SR_USAGE_ON_TRANSLATION => 0x00000008 , SQL_SR_GRANT_OPTION_FOR => 0x00000010 , SQL_SR_CASCADE => 0x00000020 , SQL_SR_RESTRICT => 0x00000040 , SQL_SR_DELETE_TABLE => 0x00000080 , SQL_SR_INSERT_TABLE => 0x00000100 , SQL_SR_INSERT_COLUMN => 0x00000200 , SQL_SR_REFERENCES_TABLE => 0x00000400 , SQL_SR_REFERENCES_COLUMN => 0x00000800 , SQL_SR_SELECT_TABLE => 0x00001000 , SQL_SR_UPDATE_TABLE => 0x00002000 , SQL_SR_UPDATE_COLUMN => 0x00004000 }; $ReturnValues{SQL_SQL92_ROW_VALUE_CONSTRUCTOR} = { SQL_SRVC_VALUE_EXPRESSION => 0x00000001 , SQL_SRVC_NULL => 0x00000002 , SQL_SRVC_DEFAULT => 0x00000004 , SQL_SRVC_ROW_SUBQUERY => 0x00000008 }; $ReturnValues{SQL_SQL92_STRING_FUNCTIONS} = { SQL_SSF_CONVERT => 0x00000001 , SQL_SSF_LOWER => 0x00000002 , SQL_SSF_UPPER => 0x00000004 , SQL_SSF_SUBSTRING => 0x00000008 , SQL_SSF_TRANSLATE => 0x00000010 , SQL_SSF_TRIM_BOTH => 0x00000020 , SQL_SSF_TRIM_LEADING => 0x00000040 , SQL_SSF_TRIM_TRAILING => 0x00000080 }; $ReturnValues{SQL_SQL92_VALUE_EXPRESSIONS} = { SQL_SVE_CASE => 0x00000001 , SQL_SVE_CAST => 0x00000002 , SQL_SVE_COALESCE => 0x00000004 , SQL_SVE_NULLIF => 0x00000008 }; $ReturnValues{SQL_SQL_CONFORMANCE} = { SQL_SC_SQL92_ENTRY => 0x00000001 , SQL_SC_FIPS127_2_TRANSITIONAL => 0x00000002 , SQL_SC_SQL92_INTERMEDIATE => 0x00000004 , SQL_SC_SQL92_FULL => 0x00000008 }; $ReturnValues{SQL_STANDARD_CLI_CONFORMANCE} = { SQL_SCC_XOPEN_CLI_VERSION1 => 0x00000001 , SQL_SCC_ISO92_CLI => 0x00000002 }; $ReturnValues{SQL_STATIC_SENSITIVITY} = { SQL_SS_ADDITIONS => 0x00000001 , SQL_SS_DELETIONS => 0x00000002 , SQL_SS_UPDATES => 0x00000004 }; $ReturnValues{SQL_STRING_FUNCTIONS} = { SQL_FN_STR_CONCAT => 0x00000001 , SQL_FN_STR_INSERT => 0x00000002 , SQL_FN_STR_LEFT => 0x00000004 , SQL_FN_STR_LTRIM => 0x00000008 , SQL_FN_STR_LENGTH => 0x00000010 , SQL_FN_STR_LOCATE => 0x00000020 , SQL_FN_STR_LCASE => 0x00000040 , SQL_FN_STR_REPEAT => 0x00000080 , SQL_FN_STR_REPLACE => 0x00000100 , SQL_FN_STR_RIGHT => 0x00000200 , SQL_FN_STR_RTRIM => 0x00000400 , SQL_FN_STR_SUBSTRING => 0x00000800 , SQL_FN_STR_UCASE => 0x00001000 , SQL_FN_STR_ASCII => 0x00002000 , SQL_FN_STR_CHAR => 0x00004000 , SQL_FN_STR_DIFFERENCE => 0x00008000 , SQL_FN_STR_LOCATE_2 => 0x00010000 , SQL_FN_STR_SOUNDEX => 0x00020000 , SQL_FN_STR_SPACE => 0x00040000 , SQL_FN_STR_BIT_LENGTH => 0x00080000 , SQL_FN_STR_CHAR_LENGTH => 0x00100000 , SQL_FN_STR_CHARACTER_LENGTH => 0x00200000 , SQL_FN_STR_OCTET_LENGTH => 0x00400000 , SQL_FN_STR_POSITION => 0x00800000 }; $ReturnValues{SQL_SUBQUERIES} = { SQL_SQ_COMPARISON => 0x00000001 , SQL_SQ_EXISTS => 0x00000002 , SQL_SQ_IN => 0x00000004 , SQL_SQ_QUANTIFIED => 0x00000008 , SQL_SQ_CORRELATED_SUBQUERIES => 0x00000010 }; $ReturnValues{SQL_SYSTEM_FUNCTIONS} = { SQL_FN_SYS_USERNAME => 0x00000001 , SQL_FN_SYS_DBNAME => 0x00000002 , SQL_FN_SYS_IFNULL => 0x00000004 }; $ReturnValues{SQL_TIMEDATE_ADD_INTERVALS} = { SQL_FN_TSI_FRAC_SECOND => 0x00000001 , SQL_FN_TSI_SECOND => 0x00000002 , SQL_FN_TSI_MINUTE => 0x00000004 , SQL_FN_TSI_HOUR => 0x00000008 , SQL_FN_TSI_DAY => 0x00000010 , SQL_FN_TSI_WEEK => 0x00000020 , SQL_FN_TSI_MONTH => 0x00000040 , SQL_FN_TSI_QUARTER => 0x00000080 , SQL_FN_TSI_YEAR => 0x00000100 }; $ReturnValues{SQL_TIMEDATE_FUNCTIONS} = { SQL_FN_TD_NOW => 0x00000001 , SQL_FN_TD_CURDATE => 0x00000002 , SQL_FN_TD_DAYOFMONTH => 0x00000004 , SQL_FN_TD_DAYOFWEEK => 0x00000008 , SQL_FN_TD_DAYOFYEAR => 0x00000010 , SQL_FN_TD_MONTH => 0x00000020 , SQL_FN_TD_QUARTER => 0x00000040 , SQL_FN_TD_WEEK => 0x00000080 , SQL_FN_TD_YEAR => 0x00000100 , SQL_FN_TD_CURTIME => 0x00000200 , SQL_FN_TD_HOUR => 0x00000400 , SQL_FN_TD_MINUTE => 0x00000800 , SQL_FN_TD_SECOND => 0x00001000 , SQL_FN_TD_TIMESTAMPADD => 0x00002000 , SQL_FN_TD_TIMESTAMPDIFF => 0x00004000 , SQL_FN_TD_DAYNAME => 0x00008000 , SQL_FN_TD_MONTHNAME => 0x00010000 , SQL_FN_TD_CURRENT_DATE => 0x00020000 , SQL_FN_TD_CURRENT_TIME => 0x00040000 , SQL_FN_TD_CURRENT_TIMESTAMP => 0x00080000 , SQL_FN_TD_EXTRACT => 0x00100000 }; $ReturnValues{SQL_TXN_CAPABLE} = { SQL_TC_NONE => 0 , SQL_TC_DML => 1 , SQL_TC_ALL => 2 , SQL_TC_DDL_COMMIT => 3 , SQL_TC_DDL_IGNORE => 4 }; $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION} = { SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 # SQL_TXN_READ_UNCOMMITTED , SQL_TRANSACTION_READ_COMMITTED => 0x00000002 # SQL_TXN_READ_COMMITTED , SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 # SQL_TXN_REPEATABLE_READ , SQL_TRANSACTION_SERIALIZABLE => 0x00000008 # SQL_TXN_SERIALIZABLE }; $ReturnValues{SQL_DEFAULT_TRANSACTION_ISOLATION} = $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION}; $ReturnValues{SQL_TXN_ISOLATION_OPTION} = { SQL_TXN_READ_UNCOMMITTED => 0x00000001 , SQL_TXN_READ_COMMITTED => 0x00000002 , SQL_TXN_REPEATABLE_READ => 0x00000004 , SQL_TXN_SERIALIZABLE => 0x00000008 }; $ReturnValues{SQL_DEFAULT_TXN_ISOLATION} = $ReturnValues{SQL_TXN_ISOLATION_OPTION}; $ReturnValues{SQL_TXN_VERSIONING} = { SQL_TXN_VERSIONING => 0x00000010 }; $ReturnValues{SQL_UNION} = { SQL_U_UNION => 0x00000001 , SQL_U_UNION_ALL => 0x00000002 }; $ReturnValues{SQL_UNION_STATEMENT} = { SQL_US_UNION => 0x00000001 # SQL_U_UNION , SQL_US_UNION_ALL => 0x00000002 # SQL_U_UNION_ALL }; 1; =head1 TODO Corrections? SQL_NULL_COLLATION: ODBC vs ANSI Unique values for $ReturnValues{...}?, e.g. SQL_FILE_USAGE =cut DBI-1.652/lib/DBI/Const/GetInfoReturn.pm0000644000031300001440000000457114660570432016723 0ustar00merijnusers# $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z Tim $ # # Copyright (c) 2002 Tim Bunce Ireland # # Constant data describing return values from the DBI getinfo function. # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. package DBI::Const::GetInfoReturn; use strict; use warnings; use Exporter (); our @ISA = qw(Exporter); our @EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues); my $VERSION = "2.008697"; =head1 NAME DBI::Const::GetInfoReturn - Data and functions for describing GetInfo results =head1 SYNOPSIS The interface to this module is undocumented and liable to change. =head1 DESCRIPTION Data and functions for describing GetInfo results =cut use DBI::Const::GetInfoType; use DBI::Const::GetInfo::ANSI (); use DBI::Const::GetInfo::ODBC (); our %GetInfoReturnTypes = ( %DBI::Const::GetInfo::ANSI::ReturnTypes , %DBI::Const::GetInfo::ODBC::ReturnTypes ); our %GetInfoReturnValues = (); { my $A = \%DBI::Const::GetInfo::ANSI::ReturnValues; my $O = \%DBI::Const::GetInfo::ODBC::ReturnValues; while ( my ($k, $v) = each %$A ) { my %h = ( exists $O->{$k} ) ? ( %$v, %{$O->{$k}} ) : %$v; $GetInfoReturnValues{$k} = \%h; } while ( my ($k, $v) = each %$O ) { next if exists $A->{$k}; my %h = %$v; $GetInfoReturnValues{$k} = \%h; } } # ----------------------------------------------------------------------------- sub Format { my $InfoType = shift; my $Value = shift; return '' unless defined $Value; my $ReturnType = $GetInfoReturnTypes{$InfoType}; return sprintf '0x%08X', $Value if $ReturnType eq 'SQLUINTEGER bitmask'; return sprintf '0x%08X', $Value if $ReturnType eq 'SQLINTEGER bitmask'; # return '"' . $Value . '"' if $ReturnType eq 'SQLCHAR'; return $Value; } sub Explain { my $InfoType = shift; my $Value = shift; return '' unless defined $Value; return '' unless exists $GetInfoReturnValues{$InfoType}; $Value = int $Value; my $ReturnType = $GetInfoReturnTypes{$InfoType}; my %h = reverse %{$GetInfoReturnValues{$InfoType}}; if ( $ReturnType eq 'SQLUINTEGER bitmask'|| $ReturnType eq 'SQLINTEGER bitmask') { my @a = (); for my $k ( sort { $a <=> $b } keys %h ) { push @a, $h{$k} if $Value & $k; } return wantarray ? @a : join(' ', @a ); } else { return $h{$Value} ||'?'; } } 1; DBI-1.652/lib/DBI/Const/GetInfoType.pm0000644000031300001440000000222114660570432016353 0ustar00merijnusers# $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z Tim $ # # Copyright (c) 2002 Tim Bunce Ireland # # Constant data describing info type codes for the DBI getinfo function. # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. package DBI::Const::GetInfoType; use strict; use warnings; use Exporter (); our @ISA = qw(Exporter); our @EXPORT = qw(%GetInfoType); my $VERSION = "2.008697"; =head1 NAME DBI::Const::GetInfoType - Data describing GetInfo type codes =head1 SYNOPSIS use DBI::Const::GetInfoType; =head1 DESCRIPTION Imports a %GetInfoType hash which maps names for GetInfo Type Codes into their corresponding numeric values. For example: $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} ); The interface to this module is new and nothing beyond what is written here is guaranteed. =cut use DBI::Const::GetInfo::ANSI (); # liable to change use DBI::Const::GetInfo::ODBC (); # liable to change our %GetInfoType = ( %DBI::Const::GetInfo::ANSI::InfoTypes # liable to change , %DBI::Const::GetInfo::ODBC::InfoTypes # liable to change ); 1; DBI-1.652/lib/DBI/DBD/0000755000031300001440000000000015240046615013122 5ustar00merijnusersDBI-1.652/lib/DBI/DBD/SqlEngine/0000755000031300001440000000000015240046615015007 5ustar00merijnusersDBI-1.652/lib/DBI/DBD/SqlEngine/Developers.pod0000644000031300001440000006520415206260373017633 0ustar00merijnusers=head1 NAME DBI::DBD::SqlEngine::Developers - Developers documentation for DBI::DBD::SqlEngine =head1 SYNOPSIS package DBD::myDriver; use base qw(DBI::DBD::SqlEngine); sub driver { ... my $drh = $proto->SUPER::driver($attr); ... return $drh->{class}; } sub CLONE { ... } package DBD::myDriver::dr; @ISA = qw(DBI::DBD::SqlEngine::dr); sub data_sources { ... } ... package DBD::myDriver::db; @ISA = qw(DBI::DBD::SqlEngine::db); sub init_valid_attributes { ... } sub init_default_attributes { ... } sub set_versions { ... } sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } sub get_myd_versions { ... } sub get_avail_tables { ... } package DBD::myDriver::st; @ISA = qw(DBI::DBD::SqlEngine::st); sub FETCH { ... } sub STORE { ... } package DBD::myDriver::Statement; @ISA = qw(DBI::DBD::SqlEngine::Statement); sub open_table { ... } package DBD::myDriver::Table; @ISA = qw(DBI::DBD::SqlEngine::Table); my %reset_on_modify = ( myd_abc => "myd_foo", myd_mno => "myd_bar", ); __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); my %compat_map = ( abc => 'foo_abc', xyz => 'foo_xyz', ); __PACKAGE__->register_compat_map( \%compat_map ); sub bootstrap_table_meta { ... } sub init_table_meta { ... } sub table_meta_attr_changed { ... } sub open_data { ... } sub new { ... } sub fetch_row { ... } sub push_row { ... } sub push_names { ... } sub seek { ... } sub truncate { ... } sub drop { ... } # optimize the SQL engine by add one or more of sub update_current_row { ... } # or sub update_specific_row { ... } # or sub update_one_row { ... } # or sub insert_new_row { ... } # or sub delete_current_row { ... } # or sub delete_one_row { ... } =head1 DESCRIPTION This document describes the interface of DBI::DBD::SqlEngine for DBD developers who write DBI::DBD::SqlEngine based DBI drivers. It supplements L and L, which you should read first. =head1 CLASSES Each DBI driver must provide a package global C<< driver >> method and three DBI related classes: =over 4 =item DBI::DBD::SqlEngine::dr Driver package, contains the methods DBI calls indirectly via DBI interface: DBI->connect ('DBI:DBM:', undef, undef, {}) # invokes package DBD::DBM::dr; our @ISA = qw(DBI::DBD::SqlEngine::dr); sub connect ($$;$$$) { ... } Similar for C and C. Pure Perl DBI drivers derived from DBI::DBD::SqlEngine usually don't need to override any of the methods provided through the DBD::XXX::dr package. However if you need additional initialization not fitting in C and C of you're ::db class, the connect method might be the final place to be modified. =item DBI::DBD::SqlEngine::db Contains the methods which are called through DBI database handles (C<< $dbh >>). e.g., $sth = $dbh->prepare ("select * from foo"); # returns the f_encoding setting for table foo $dbh->csv_get_meta ("foo", "f_encoding"); DBI::DBD::SqlEngine provides the typical methods required here. Developers who write DBI drivers based on DBI::DBD::SqlEngine need to override the methods C<< set_versions >> and C<< init_valid_attributes >>. =item DBI::DBD::SqlEngine::TieMeta; Provides the tie-magic for C<< $dbh->{$drv_pfx . "_meta"} >>. Routes C through C<< $drv->set_sql_engine_meta() >> and C through C<< $drv->get_sql_engine_meta() >>. C is not supported, you have to execute a C statement, where applicable. =item DBI::DBD::SqlEngine::TieTables; Provides the tie-magic for tables in C<< $dbh->{$drv_pfx . "_meta"} >>. Routes C though C<< $tblClass->set_table_meta_attr() >> and C though C<< $tblClass->get_table_meta_attr() >>. C removes an attribute from the I retrieved by C<< $tblClass->get_table_meta() >>. =item DBI::DBD::SqlEngine::st Contains the methods to deal with prepared statement handles. e.g., $sth->execute () or die $sth->errstr; =item DBI::DBD::SqlEngine::TableSource; Base class for 3rd party table sources: $dbh->{sql_table_source} = "DBD::Foo::TableSource"; =item DBI::DBD::SqlEngine::DataSource; Base class for 3rd party data sources: $dbh->{sql_data_source} = "DBD::Foo::DataSource"; =item DBI::DBD::SqlEngine::Statement; Base class for derived drivers statement engine. Implements C. =item DBI::DBD::SqlEngine::Table; Contains tailoring between SQL engine's requirements and C magic for finding the right tables and storage. Builds bridges between C handling of C, table initialization for SQL engines and I's attribute management for derived drivers. =back =head2 DBI::DBD::SqlEngine This is the main package containing the routines to initialize DBI::DBD::SqlEngine based DBI drivers. Primarily the C<< DBI::DBD::SqlEngine::driver >> method is invoked, either directly from DBI when the driver is initialized or from the derived class. package DBD::DBM; use base qw( DBI::DBD::SqlEngine ); sub driver { my ( $class, $attr ) = @_; ... my $drh = $class->SUPER::driver( $attr ); ... return $drh; } It is not necessary to implement your own driver method as long as additional initialization (e.g. installing more private driver methods) is not required. You do not need to call C<< setup_driver >> as DBI::DBD::SqlEngine takes care of it. =head2 DBI::DBD::SqlEngine::dr The driver package contains the methods DBI calls indirectly via the DBI interface (see L). DBI::DBD::SqlEngine based DBI drivers usually do not need to implement anything here, it is enough to do the basic initialization: package DBD:XXX::dr; our @ISA = qw (DBI::DBD::SqlEngine::dr); our $imp_data_size = 0; our $data_sources_attr = undef; $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; =head3 Methods provided by C<< DBI::DBD::SqlEngine::dr >>: =over 4 =item connect Supervises the driver bootstrap when calling DBI->connect( "dbi:Foo", , , { ... } ); First it instantiates a new driver using C. After that, initial bootstrap of the newly instantiated driver is done by $dbh->func( 0, "init_default_attributes" ); The first argument (C<0>) signals that this is the very first call to C. Modern drivers understand that and do early stage setup here after calling package DBD::Foo::db; our @ISA = qw(DBI::DBD::SqlEngine::db); sub init_default_attributes { my ($dbh, $phase) = @_; $dbh->SUPER::init_default_attributes($phase); ...; # own setup code, maybe separated by phases } When the C<$phase> argument is passed down until C, C recognizes a I driver and initializes the attributes from I and I<$attr> arguments passed via C<< DBI->connect( $dsn, $user, $pass, \%attr ) >>. At the end of the attribute initialization after I, C invoked C again for I: $dbh->func( 1, "init_default_attributes" ); =item data_sources Returns a list of I's using the C method of the class specified in C<< $dbh->{sql_table_source} >> or via C<\%attr>: @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); =item disconnect_all C doesn't have an overall driver cache, so nothing happens here at all. =back =head2 DBI::DBD::SqlEngine::db This package defines the database methods, which are called via the DBI database handle C<< $dbh >>. =head3 Methods provided by C<< DBI::DBD::SqlEngine::db >>: =over 4 =item ping Simply returns the content of the C<< Active >> attribute. Override when your driver needs more complicated actions here. =item prepare Prepares a new SQL statement to execute. Returns a statement handle, C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor recommended to override this method. =item validate_FETCH_attr Called by C to allow inherited drivers do their own attribute name validation. Calling convention is similar to C and the return value is the approved attribute name. return $validated_attribute_name; In case of validation fails (e.g. accessing private attribute or similar), C is permitted to throw an exception. =item FETCH Fetches an attribute of a DBI database object. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. The driver prefix is extracted from the attribute name and verified against C<< $dbh->{ $drv_prefix . "valid_attrs" } >> (when it exists). If the requested attribute value is not listed as a valid attribute, this method croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ $drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the attribute value is returned. So it's not possible to modify C from outside of DBI::DBD::SqlEngine::db or a derived class. =item validate_STORE_attr Called by C to allow inherited drivers do their own attribute name validation. Calling convention is similar to C and the return value is the approved attribute name followed by the approved new value. return ($validated_attribute_name, $validated_attribute_value); In case of validation fails (e.g. accessing private attribute or similar), C is permitted to throw an exception (C throws an exception when someone tries to assign value other than C to C<< $dbh->{sql_identifier_case} >> or C<< $dbh->{sql_quoted_identifier_case} >>). =item STORE Stores a database private attribute. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. If the database handle has an attribute C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in that hash, this method croaks. If the database handle has an attribute C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there can be stored (once they are initialized). Trying to overwrite such an immutable attribute forces this method to croak. An example of a valid attributes list can be found in C<< DBI::DBD::SqlEngine::db::init_valid_attributes >>. =item set_versions This method sets the attributes C<< f_version >>, C<< sql_nano_version >>, C<< sql_statement_version >> and (if not prohibited by a restrictive C<< ${prefix}_valid_attrs >>) C<< ${prefix}_version >>. This method is called at the end of the C<< connect () >> phase. When overriding this method, do not forget to invoke the superior one. =item init_valid_attributes This method is called after the database handle is instantiated as the first attribute initialization. C<< DBI::DBD::SqlEngine::db::init_valid_attributes >> initializes the attributes C and C. When overriding this method, do not forget to invoke the superior one, preferably before doing anything else. =item init_default_attributes This method is called after the database handle is instantiated to initialize the default attributes. It expects one argument: C<$phase>. If C<$phase> is not given, C of C expects this is an old-fashioned driver which isn't capable of multi-phased initialization. C<< DBI::DBD::SqlEngine::db::init_default_attributes >> initializes the attributes C, C, C, C, C, C, C and C when L is available. It sets C to the given C<$phase>. When the derived implementor class provides the attribute to validate attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} = {...}; >>), the attributes C, C and C are added (when available) to the list of valid and immutable attributes (where C is interpreted as the driver prefix). =item get_versions This method is called by the code injected into the instantiated driver to provide the user callable driver method C<< ${prefix}versions >> (e.g. C<< dbm_versions >>, C<< csv_versions >>, ...). The DBI::DBD::SqlEngine implementation returns all version information known by DBI::DBD::SqlEngine (e.g. DBI version, Perl version, DBI::DBD::SqlEngine version and the SQL handler version). C takes the C<$dbh> as the first argument and optionally a second argument containing a table name. The second argument is not evaluated in C<< DBI::DBD::SqlEngine::db::get_versions >> itself - but might be in the future. If the derived implementor class provides a method named C, this is invoked and the return value of it is associated to the derived driver name: if (my $dgv = $dbh->{ImplementorClass}->can ("get_" . $drv_prefix . "versions") { (my $derived_driver = $dbh->{ImplementorClass}) =~ s/::db$//; $versions{$derived_driver} = &$dgv ($dbh, $table); } Override it to add more version information about your module, (e.g. some kind of parser version in case of DBD::CSV, ...), if one line is not enough room to provide all relevant information. =item sql_parser_object Returns a L instance, when C<< sql_handler >> is set to "SQL::Statement". The parser instance is stored in C<< sql_parser_object >>. It is not recommended to override this method. =item disconnect Disconnects from a database. All local table information is discarded and the C<< Active >> attribute is set to 0. =item type_info_all Returns information about all the types supported by DBI::DBD::SqlEngine. =item table_info Returns a statement handle which is prepared to deliver information about all known tables. =item list_tables Returns a list of all known table names. =item quote Quotes a string for use in SQL statements. =item commit Warns about a useless call (if warnings enabled) and returns. DBI::DBD::SqlEngine is typically a driver which commits every action instantly when executed. =item rollback Warns about a useless call (if warnings enabled) and returns. DBI::DBD::SqlEngine is typically a driver which commits every action instantly when executed. =back =head3 Attributes used by C<< DBI::DBD::SqlEngine::db >>: This section describes attributes which are important to developers of DBI Database Drivers derived from C. =over 4 =item sql_init_order This attribute contains a hash with priorities as key and an array containing the C<$dbh> attributes to be initialized during before/after other attributes. C initializes following attributes: $dbh->{sql_init_order} = { 0 => [qw( Profile RaiseError PrintError AutoCommit )], 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ] } The default priority of not listed attribute keys is C<50>. It is well known that a lot of attributes needed to be set before some table settings are initialized. For example, for L, when using my $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => "/path/to/dbm/databases", dbm_type => "BerkeleyDB", dbm_mldbm => "JSON", # use MLDBM::Serializer::JSON dbm_tables => { quick => { dbm_type => "GDBM_File", dbm_MLDBM => "FreezeThaw" } } }); This defines a known table C which uses the L backend and L as serializer instead of the overall default L and L. B all files containing the table data have to be searched in C<< $dbh->{f_dir} >>, which requires C<< $dbh->{f_dir} >> must be initialized before C<< $dbh->{sql_meta}->{quick} >> is initialized by C method of L to get C<< $dbh->{sql_meta}->{quick}->{f_dir} >> being initialized properly. =item sql_init_phase This attribute is only set during the initialization steps of the DBI Database Driver. It contains the value of the currently run initialization phase. Currently supported phases are I and I. This attribute is set in C and removed in C. =item sql_engine_in_gofer This value has a true value in case of this driver is operated via L. The impact of being operated via Gofer is a read-only driver (not read-only databases!), so you cannot modify any attributes later - neither any table settings. B you won't get an error in cases you modify table attributes, so please carefully watch C. =item sql_table_source Names a class which is responsible for delivering I and I (Database Driver related). I here refers to L, not C. See L for details. =item sql_data_source Name a class which is responsible for handling table resources open and completing table names requested via SQL statements. See L for details. =item sql_dialect Controls the dialect understood by SQL::Parser. Possible values (delivery state of SQL::Statement): * ANSI * CSV * AnyData Defaults to "CSV". Because an SQL::Parser is instantiated only once and SQL::Parser doesn't allow one to modify the dialect once instantiated, it's strongly recommended to set this flag before any statement is executed (best place is connect attribute hash). =back =head2 DBI::DBD::SqlEngine::st Contains the methods to deal with prepared statement handles: =over 4 =item bind_param Common routine to bind placeholders to a statement for execution. It is dangerous to override this method without detailed knowledge about the DBI::DBD::SqlEngine internal storage structure. =item execute Executes a previously prepared statement (with placeholders, if any). =item finish Finishes a statement handle, discards all buffered results. The prepared statement is not discarded so the statement can be executed again. =item fetch Fetches the next row from the result-set. This method may be rewritten in a later version and if it's overridden in a derived class, the derived implementation should not rely on the storage details. =item fetchrow_arrayref Alias for C<< fetch >>. =item FETCH Fetches statement handle attributes. Supported attributes (for full overview see L) are C, C, C and C. Each column is returned as C which might be wrong depending on the derived backend storage. If the statement handle has private attributes, they can be fetched using this method, too. B that statement attributes are not associated with any table used in this statement. This method usually requires extending in a derived implementation. See L or L for some example. =item STORE Allows storing of statement private attributes. No special handling is currently implemented here. =item rows Returns the number of rows affected by the last execute. This method might return C. =back =head2 DBI::DBD::SqlEngine::TableSource Provides data sources and table information on database driver and database handle level. package DBI::DBD::SqlEngine::TableSource; sub data_sources ($;$) { my ( $class, $drh, $attrs ) = @_; ... } sub avail_tables { my ( $class, $drh ) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); @ary = $dbh->data_sources(); @ary = $dbh->data_sources(\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); $dbh->func( "list_tables" ); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default. =head2 DBI::DBD::SqlEngine::DataSource Provides base functionality for dealing with tables. It is primarily designed for allowing transparent access to files on disk or already opened (file-)streams (e.g. for DBD::CSV). Derived classes shall be restricted to similar functionality, too (e.g. opening streams from an archive, transparently compress/uncompress log files before parsing them, package DBI::DBD::SqlEngine::DataSource; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; ... } The method C is called when first setting up the I for a table: "SELECT user.id, user.name, user.shell FROM user WHERE ..." results in opening the table C. First step of the table open process is completing the name. Let's imagine you're having a L handle with following settings: $dbh->{sql_identifier_case} = SQL_IC_LOWER; $dbh->{f_ext} = '.lst'; $dbh->{f_dir} = '/data/web/adrmgr'; Those settings will result in looking for files matching C<[Uu][Ss][Ee][Rr](\.lst)?$> in C. The scanning of the directory C and the pattern match check will be done in C by the C method. If you intend to provide other sources of data streams than files, in addition to provide an appropriate C method, a method to open the resource is required: package DBI::DBD::SqlEngine::DataSource; sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; ... } After the method C has been run successfully, the table's meta information are in a state which allows the table's data accessor methods will be able to fetch/store row information. Implementation details heavily depends on the table implementation, whereby the most famous is surely L. =head2 DBI::DBD::SqlEngine::Statement Derives from DBI::SQL::Nano::Statement for unified naming when deriving new drivers. No additional feature is provided from here. =head2 DBI::DBD::SqlEngine::Table Derives from DBI::SQL::Nano::Table for unified naming when deriving new drivers. You should consult the documentation of C<< SQL::Eval::Table >> (see L) to get more information about the abstract methods of the table's base class you have to override and a description of the table meta information expected by the SQL engines. =over 4 =item bootstrap_table_meta Initializes a table meta structure. Can be safely overridden in a derived class, as long as the C<< SUPER >> method is called at the end of the overridden method. It copies the following attributes from the database into the table meta data C<< $dbh->{ReadOnly} >> into C<< $meta->{readonly} >>, C and C and makes them sticky to the table. This method should be called before you attempt to map between file name and table name to ensure the correct directory, extension etc. are used. =item init_table_meta Initializes more attributes of the table meta data - usually more expensive ones (e.g. those which require class instantiations) - when the file name and the table name could mapped. =item get_table_meta Returns the table meta data. If there are none for the required table, a new one is initialized. When after bootstrapping a new I and L a mapping can be established between an existing I and the new bootstrapped one, the already existing is used and a mapping shortcut between the recent used table name and the already known table name is hold in C<< $dbh->{sql_meta_map} >>. When it fails, nothing is returned. On success, the name of the table and the meta data structure is returned. =item get_table_meta_attr Returns a single attribute from the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item set_table_meta_attr Sets a single attribute in the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item table_meta_attr_changed Called when an attribute of the meta data is modified. If the modified attribute requires to reset a calculated attribute, the calculated attribute is reset (deleted from meta data structure) and the I flag is removed, too. The decision is made based on C<%register_reset_on_modify>. =item register_reset_on_modify Allows C to reset meta attributes when special attributes are modified. For DBD::File, modifying one of C, C, C or C will reset C. DBD::DBM extends the list for C and C to reset the value of C. If your DBD has calculated values in the meta data area, then call C: my %reset_on_modify = ( "xxx_foo" => "xxx_bar" ); __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); =item register_compat_map Allows C and C to update the attribute name to the current favored one: # from DBD::DBM my %compat_map = ( "dbm_ext" => "f_ext" ); __PACKAGE__->register_compat_map( \%compat_map ); =item open_data Called to open the table's data storage. This is silently forwarded to C<< $meta->{sql_data_source}->open_data() >>. After this is done, a derived class might add more steps in an overridden C<< open_file >> method. =item new Instantiates the table. This is done in 3 steps: 1. get the table meta data 2. open the data file 3. bless the table data structure using inherited constructor new It is not recommended to override the constructor of the table class. Find a reasonable place to add you extensions in one of the above four methods. =back =head1 AUTHOR The module DBI::DBD::SqlEngine is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > =head1 COPYRIGHT AND LICENSE Copyright (C) 2010-2026 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut DBI-1.652/lib/DBI/DBD/SqlEngine/HowTo.pod0000644000031300001440000002463215225122661016561 0ustar00merijnusers=head1 NAME DBI::DBD::SqlEngine::HowTo - Guide to create DBI::DBD::SqlEngine based driver =head1 SYNOPSIS perldoc DBI::DBD::SqlEngine::HowTo perldoc DBI perldoc DBI::DBD perldoc DBI::DBD::SqlEngine::Developers perldoc SQL::Eval perldoc DBI::DBD::SqlEngine perldoc DBI::DBD::SqlEngine::HowTo perldoc SQL::Statement::Embed =head1 DESCRIPTION This document provides a step-by-step guide, how to create a new C based DBD. It expects that you carefully read the L documentation and that you're familiar with L and had read and understood L. This document addresses experienced developers who are really sure that they need to invest time when writing a new DBI Driver. Writing a DBI Driver is neither a weekend project nor an easy job for hobby coders after work. Expect one or two man-month of time for the first start. Those who are still reading, should be able to sing the rules of L. =head1 CREATING DRIVER CLASSES Do you have an entry in DBI's DBD registry? DBI::DBD::SqlEngine expect having a unique prefix for every driver class in inheritance chain. It's easy to get a prefix - just drop the DBI team a note (L). If you want for some reason hide your work, take a look at L how to wrap a private prefix method around existing C. For this guide, a prefix of C is assumed. =head2 Sample Skeleton package DBD::Foo; use strict; use warnings; use base qw(DBI::DBD::SqlEngine); use DBI (); our $VERSION = "0.001"; package DBD::Foo::dr; our @ISA = qw(DBI::DBD::SqlEngine::dr); our $imp_data_size = 0; package DBD::Foo::db; our @ISA = qw(DBI::DBD::SqlEngine::db); our $imp_data_size = 0; package DBD::Foo::st; our @ISA = qw(DBI::DBD::SqlEngine::st); our $imp_data_size = 0; package DBD::Foo::Statement; our @ISA = qw(DBI::DBD::SqlEngine::Statement); package DBD::Foo::Table; our @ISA = qw(DBI::DBD::SqlEngine::Table); 1; Tiny, eh? And all you have now is a DBD named foo which will is able to deal with temporary tables, as long as you use L. In L environments, this DBD can do nothing. =head2 Deal with own attributes Before we start doing usable stuff with our DBI driver, we need to think about what we want to do and how we want to do it. Do we need tunable knobs accessible by users? Do we need status information? All this is handled in attributes of the database handles (be careful when your DBD is running "behind" a L proxy). How come the attributes into the DBD and how are they fetchable by the user? Good question, but you should know because you've read the L documentation. C and C taking care for you - all they need to know is which attribute names are valid and mutable or immutable. Tell them by adding C to your db class: sub init_valid_attributes { my $dbh = $_[0]; $dbh->SUPER::init_valid_attributes (); $dbh->{foo_valid_attrs} = { foo_version => 1, # contains version of this driver foo_valid_attrs => 1, # contains the valid attributes of foo drivers foo_readonly_attrs => 1, # contains immutable attributes of foo drivers foo_bar => 1, # contains the bar attribute foo_baz => 1, # contains the baz attribute foo_manager => 1, # contains the manager of the driver instance foo_manager_type => 1, # contains the manager class of the driver instance }; $dbh->{foo_readonly_attrs} = { foo_version => 1, # ensure no-one modifies the driver version foo_valid_attrs => 1, # do not permit one to add more valid attributes ... foo_readonly_attrs => 1, # ... or make the immutable mutable foo_manager => 1, # manager is set internally only }; return $dbh; } Woooho - but now the user cannot assign new managers? This is intended, overwrite C to handle it! sub STORE ($$$) { my ( $dbh, $attrib, $value ) = @_; $dbh->SUPER::STORE( $attrib, $value ); # we're still alive, so no exception is thrown ... # by DBI::DBD::SqlEngine::db::STORE if ( $attrib eq "foo_manager_type" ) { $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); # ... probably correct some states based on the new # foo_manager_type - see DBD::Sys for an example } } But ... my driver runs without a manager until someone first assignes a C. Well, no - there're two places where you can initialize defaults: sub init_default_attributes { my ($dbh, $phase) = @_; $dbh->SUPER::init_default_attributes($phase); if( 0 == $phase ) { # init all attributes which have no knowledge about # user settings from DSN or the attribute hash $dbh->{foo_manager_type} = "DBD::Foo::Manager"; } elsif( 1 == $phase ) { # init phase with more knowledge from DSN or attribute # hash $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); } return $dbh; } So far we can prevent the users to use our database driver as data storage for anything and everything. We care only about the real important stuff for peace on earth and alike attributes. But in fact, the driver still can't do anything. It can do less than nothing - meanwhile it's not a stupid storage area anymore. =head2 User comfort C since C<0.05> consolidates all persistent meta data of a table into a single structure stored in C<< $dbh->{sql_meta} >>. While DBI::DBD::SqlEngine provides only readonly access to this structure, modifications are still allowed. Primarily DBI::DBD::SqlEngine provides access via the setters C, C, C, C, C and C. Those methods are easily accessible by the users via the C<< $dbh->func () >> interface provided by DBI. Well, many users don't feel comfortize when calling # don't require extension for tables cars $dbh->func ("cars", "f_ext", ".csv", "set_sql_engine_meta"); DBI::DBD::SqlEngine will inject a method into your driver to increase the user comfort to allow: # don't require extension for tables cars $dbh->foo_set_meta ("cars", "f_ext", ".csv"); Better, but here and there users likes to do: # don't require extension for tables cars $dbh->{foo_tables}->{cars}->{f_ext} = ".csv"; This interface is provided when derived DBD's define following in C (re-capture L): sub init_valid_attributes { my $dbh = $_[0]; $dbh->SUPER::init_valid_attributes (); $dbh->{foo_valid_attrs} = { foo_version => 1, # contains version of this driver foo_valid_attrs => 1, # contains the valid attributes of foo drivers foo_readonly_attrs => 1, # contains immutable attributes of foo drivers foo_bar => 1, # contains the bar attribute foo_baz => 1, # contains the baz attribute foo_manager => 1, # contains the manager of the driver instance foo_manager_type => 1, # contains the manager class of the driver instance foo_meta => 1, # contains the public interface to modify table meta attributes }; $dbh->{foo_readonly_attrs} = { foo_version => 1, # ensure no-one modifies the driver version foo_valid_attrs => 1, # do not permit one to add more valid attributes ... foo_readonly_attrs => 1, # ... or make the immutable mutable foo_manager => 1, # manager is set internally only foo_meta => 1, # ensure public interface to modify table meta attributes are immutable }; $dbh->{foo_meta} = "foo_tables"; return $dbh; } This provides a tied hash in C<< $dbh->{foo_tables} >> and a tied hash for each table's meta data in C<< $dbh->{foo_tables}->{$table_name} >>. Modifications on the table meta attributes are done using the table methods: sub get_table_meta_attr { ... } sub set_table_meta_attr { ... } Both methods can adjust the attribute name for compatibility reasons, e.g. when former versions of the DBD allowed different names to be used for the same flag: my %compat_map = ( abc => 'foo_abc', xyz => 'foo_xyz', ); __PACKAGE__->register_compat_map( \%compat_map ); If any user modification on a meta attribute needs reinitialization of the meta structure (in case of C these are the attributes C, C, C and C), inform DBI::DBD::SqlEngine by doing my %reset_on_modify = ( foo_xyz => "foo_bar", foo_abc => "foo_bar", ); __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); The next access to the table meta data will force DBI::DBD::SqlEngine to re-do the entire meta initialization process. Any further action which needs to be taken can handled in C: sub table_meta_attr_changed { my ($class, $meta, $attrib, $value) = @_; ... $class->SUPER::table_meta_attr_changed ($meta, $attrib, $value); } This is done before the new value is set in C<$meta>, so the attribute changed handler can act depending on the old value. =head2 Dealing with Tables Let's put some life into it - it's going to be time for it. This is a good point where a quick side step to L will help to shorten the next paragraph. The documentation in SQL::Statement::Embed regarding embedding in own DBD's works pretty fine with SQL::Statement and DBI::SQL::Nano. Second look should go to L to get a picture over the driver part of the table API. Usually there isn't much to do for an easy driver. =head2 Testing Now you should have your first own DBD. Was easy, wasn't it? But does it work well? Prove it by writing tests and remember to use dbd_edit_mm_attribs from L to ensure testing even rare cases. =head1 AUTHOR This guide is written by Jens Rehsack. DBI::DBD::SqlEngine is written by Jens Rehsack using code from DBD::File originally written by Jochen Wiedmann and Jeff Zucker. The module DBI::DBD::SqlEngine is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > =head1 COPYRIGHT AND LICENSE Copyright (C) 2010-2026 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut DBI-1.652/lib/DBI/DBD/Metadata.pm0000644000031300001440000003520115225415731015203 0ustar00merijnuserspackage DBI::DBD::Metadata; # $Id: Metadata.pm 14213 2010-06-30 19:29:18Z Martin $ # # Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann, # Steffen Goeldner and Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Exporter (); use Carp; use DBI; use DBI::Const::GetInfoType qw(%GetInfoType); our @ISA = qw(Exporter); our @EXPORT = qw(write_getinfo_pm write_typeinfo_pm); our $VERSION = "2.014214"; =head1 NAME DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods =head1 SYNOPSIS The idea is to extract metadata information from a good quality ODBC driver and use it to generate code and data to use in your own DBI driver for the same database. To generate code to support the get_info method: perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver To generate code to support the type_info method: perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver Where C is the connection to use to extract the data, and C is the name of the driver you want the code generated for (the driver name gets embedded into the output in numerous places). =head1 Generating a GetInfo package for a driver The C in the DBI::DBD::Metadata module generates a DBD::Driver::GetInfo package on standard output. This method generates a DBD::Driver::GetInfo package from the data source you specified in the parameter list or in the environment variable DBI_DSN. DBD::Driver::GetInfo should help a DBD author implement the DBI get_info() method. Because you are just creating this package, it is very unlikely that DBD::Driver already provides a good implementation for get_info(). Thus you will probably connect via DBD::ODBC. Once you are sure that it is producing reasonably sane data, you should typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and then hand edit the result. Do not forget to update your Makefile.PL and MANIFEST to include this as an extra PM file that should be installed. If you connect via DBD::ODBC, you should use version 0.38 or greater; Please take a critical look at the data returned! ODBC drivers vary dramatically in their quality. The generator assumes that most values are static and places these values directly in the %info hash. A few examples show the use of CODE references and the implementation via subroutines. It is very likely that you will have to write additional subroutines for values depending on the session state or server version, e.g. SQL_DBMS_VER. A possible implementation of DBD::Driver::db::get_info() may look like: sub get_info { my($dbh, $info_type) = @_; require DBD::Driver::GetInfo; my $v = $DBD::Driver::GetInfo::info{int($info_type)}; $v = $v->($dbh) if ref $v eq 'CODE'; return $v; } Please replace Driver (or "") with the name of your driver. Note that this stub function is generated for you by write_getinfo_pm function, but you must manually transfer the code to Driver.pm. =cut sub write_getinfo_pm { my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1}); $driver //= ""; print <(\$dbh) if ref \$v eq 'CODE'; return \$v; } # Transfer this to lib/DBD/${driver}/GetInfo.pm # The \%info hash was automatically generated by # DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. package DBD::${driver}::GetInfo; use strict; use DBD::${driver}; # Beware: not officially documented interfaces... # use DBI::Const::GetInfoType qw(\%GetInfoType); # use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues); my \$sql_driver = '${driver}'; my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION); PERL my $kw_map = 0; { # Informix CLI (ODBC) v3.81.0000 does not return a list of keywords. local $\ = "\n"; local $, = "\n"; my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS}); if ($kw) { print "\nmy \@Keywords = qw(\n"; print sort split /,/, $kw; print ");\n\n"; print "sub sql_keywords {\n"; print q% return join ',', @Keywords;%; print "\n}\n\n"; $kw_map = 1; } } print <<'PERL'; sub sql_data_source_name { my $dbh = shift; return "dbi:$sql_driver:" . $dbh->{Name}; } sub sql_user_name { my $dbh = shift; # CURRENT_USER is a non-standard attribute, probably undef # Username is a standard DBI attribute return $dbh->{CURRENT_USER} || $dbh->{Username}; } PERL print "\nour \%info = (\n"; foreach my $key (sort keys %GetInfoType) { my $num = $GetInfoType{$key}; my $val = eval { $dbh->get_info($num); }; if ($key eq 'SQL_DATA_SOURCE_NAME') { $val = '\&sql_data_source_name'; } elsif ($key eq 'SQL_KEYWORDS') { $val = ($kw_map) ? '\&sql_keywords' : 'undef'; } elsif ($key eq 'SQL_DRIVER_NAME') { $val = "\$INC{'DBD/$driver.pm'}"; } elsif ($key eq 'SQL_DRIVER_VER') { $val = '$sql_driver_ver'; } elsif ($key eq 'SQL_USER_NAME') { $val = '\&sql_user_name'; } elsif (not defined $val) { $val = 'undef'; } elsif ($val eq '') { $val = "''"; } elsif ($val =~ /\D/) { $val =~ s/\\/\\\\/g; $val =~ s/'/\\'/g; $val = "'$val'"; } printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key; } print ");\n\n1;\n\n__END__\n"; } =head1 Generating a TypeInfo package for a driver The C function in the DBI::DBD::Metadata module generates on standard output the data needed for a driver's type_info_all method. It also provides default implementations of the type_info_all method for inclusion in the driver's main implementation file. The driver parameter is the name of the driver for which the methods will be generated; for the sake of examples, this will be "Driver". Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn", where the odbc_dsn is a DSN for one of the driver's databases. The user and pass parameters are the other optional connection parameters that will be provided to the DBI connect method. Once you are sure that it is producing reasonably sane data, you should typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm, and then hand edit the result if necessary. Do not forget to update your Makefile.PL and MANIFEST to include this as an extra PM file that should be installed. Please take a critical look at the data returned! ODBC drivers vary dramatically in their quality. The generator assumes that all the values are static and places these values directly in the %info hash. A possible implementation of DBD::Driver::type_info_all() may look like: sub type_info_all { my ($dbh) = @_; require DBD::Driver::TypeInfo; return [ @$DBD::Driver::TypeInfo::type_info_all ]; } Please replace Driver (or "") with the name of your driver. Note that this stub function is generated for you by the write_typeinfo_pm function, but you must manually transfer the code to Driver.pm. =cut # These two are used by fmt_value... my %dbi_inv; my %sql_type_inv; #-DEBUGGING-# #sub print_hash #{ # my ($name, %hash) = @_; # print "Hash: $name\n"; # foreach my $key (keys %hash) # { # print "$key => $hash{$key}\n"; # } #} #-DEBUGGING-# sub inverse_hash { my (%hash) = @_; my (%inv); foreach my $key (keys %hash) { my $val = $hash{$key}; die "Double mapping for key value $val ($inv{$val}, $key)!" if (defined $inv{$val}); $inv{$val} = $key; } return %inv; } sub fmt_value { my ($num, $val) = @_; if (!defined $val) { $val = "undef"; } elsif ($val !~ m/^[-+]?\d+$/) { # All the numbers in type_info_all are integers! # Anything that isn't an integer is a string. # Ensure that no double quotes screw things up. $val =~ s/"/\\"/g if ($val =~ m/"/o); $val = qq{"$val"}; } elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/) { # All numeric... $val = $sql_type_inv{$val} if (defined $sql_type_inv{$val}); } return $val; } sub write_typeinfo_pm { my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1}); $driver //= ""; print < 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, ); #-DEBUG-# print_hash("dbi_map", %dbi_map); %dbi_inv = inverse_hash(%dbi_map); #-DEBUG-# print_hash("dbi_inv", %dbi_inv); my $maxlen = 0; foreach my $key (keys %dbi_map) { $maxlen = length($key) if length($key) > $maxlen; } # Print the name/value mapping entry in the type_info_all array; my $fmt = " \%-${maxlen}s => \%2d,\n"; my $numkey = 0; my $maxkey = 0; print " \$type_info_all = [\n {\n"; foreach my $i (sort { $a <=> $b } keys %dbi_inv) { printf($fmt, $dbi_inv{$i}, $i); $numkey++; $maxkey = $i; } print " },\n"; print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n" unless $numkey = $maxkey + 1; my $h = $dbh->type_info_all; my @tia = @$h; my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]}; shift @tia; # Remove the mapping reference. my $numtyp = $#tia; #-DEBUG-# print_hash("odbc_map", %odbc_map); # In theory, the key/number mapping sequence for %dbi_map # should be the same as the one from the ODBC driver. However, to # prevent the possibility of mismatches, and to deal with older # missing attributes or unexpected new ones, we chase back through # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc # to map our new key number to the old one. # Report if @dbi_to_odbc is not an identity mapping. my @dbi_to_odbc; foreach my $num (sort { $a <=> $b } keys %dbi_inv) { # Find the name in %dbi_inv that matches this index number. my $dbi_key = $dbi_inv{$num}; #-DEBUG-# print "dbi_key = $dbi_key\n"; #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n"; # Find the index in %odbc_map that has this key. $dbi_to_odbc[$num] = $odbc_map{$dbi_key}; } # Determine the length of the longest formatted value in each field my @len; for (my $i = 0; $i <= $numtyp; $i++) { my @odbc_val = @{$tia[$i]}; for (my $num = 0; $num <= $maxkey; $num++) { # Find the value of the entry in the @odbc_val array. my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; $val = fmt_value($num, $val); #-DEBUG-# print "val = $val\n"; $val = "$val,"; $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num]; } } # Generate format strings to left justify each string in maximum field width. my @fmt; for (my $i = 0; $i <= $maxkey; $i++) { $fmt[$i] = "%-$len[$i]s"; #-DEBUG-# print "fmt[$i] = $fmt[$i]\n"; } # Format the data from type_info_all for (my $i = 0; $i <= $numtyp; $i++) { my @odbc_val = @{$tia[$i]}; print " [ "; for (my $num = 0; $num <= $maxkey; $num++) { # Find the value of the entry in the @odbc_val array. my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; $val = fmt_value($num, $val); printf $fmt[$num], "$val,"; } print " ],\n"; } print " ];\n\n 1;\n}\n\n__END__\n"; } 1; __END__ =head1 AUTHORS Jonathan Leffler (previously ), Jochen Wiedmann , Steffen Goeldner , and Tim Bunce . =cut DBI-1.652/lib/DBI/DBD/SqlEngine.pm0000644000031300001440000017635615240024143015357 0ustar00merijnusers#!/usr/bin/perl # -*- perl -*- # # DBI::DBD::SqlEngine - A base class for implementing DBI drivers that # have not an own SQL engine # # This module is currently maintained by # # H.Merijn Brand & Jens Rehsack # # The original author is Jochen Wiedmann. # # Copyright (C) 2009-2026 by H.Merijn Brand & Jens Rehsack # Copyright (C) 2004 by Jeff Zucker # Copyright (C) 1998 by Jochen Wiedmann # # All rights reserved. # # You may distribute this module under the terms of either the GNU # General Public License or the Artistic License, as specified in # the Perl README file. require 5.012; use strict; use DBI (); require DBI::SQL::Nano; package DBI::DBD::SqlEngine; use strict; use Carp; our %methods_installed; our $VERSION = "0.06"; our $drh = undef; # holds driver handle(s) once initialized DBI->setup_driver("DBI::DBD::SqlEngine"); # only needed once but harmless to repeat my %accessors = ( versions => "get_driver_versions", new_meta => "new_sql_engine_meta", get_meta => "get_sql_engine_meta", set_meta => "set_sql_engine_meta", clear_meta => "clear_sql_engine_meta", ); sub driver ($;$) { my ( $class, $attr ) = @_; # Drivers typically use a singleton object for the $drh # We use a hash here to have one singleton per subclass. # (Otherwise DBD::CSV and DBD::DBM, for example, would # share the same driver object which would cause problems.) # An alternative would be to not cache the $drh here at all # and require that subclasses do that. Subclasses should do # their own caching, so caching here just provides extra safety. $drh->{$class} and return $drh->{$class}; $attr ||= {}; { no strict "refs"; unless ( $attr->{Attribution} ) { $class eq "DBI::DBD::SqlEngine" and $attr->{Attribution} = "$class by Jens Rehsack"; $attr->{Attribution} ||= ${ $class . "::ATTRIBUTION" } || "oops the author of $class forgot to define this"; } $attr->{Version} ||= ${ $class . "::VERSION" }; $attr->{Name} or ( $attr->{Name} = $class ) =~ s/^DBD\:\://; } $drh->{$class} = DBI::_new_drh( $class . "::dr", $attr ); $drh->{$class}->STORE( ShowErrorStatement => 1 ); my $prefix = DBI->driver_prefix($class); if ($prefix) { my $dbclass = $class . "::db"; while ( my ( $accessor, $funcname ) = each %accessors ) { my $method = $prefix . $accessor; $dbclass->can($method) and next; my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname; sub %s::%s { my $func = %s->can (q{%s}); goto &$func; } EOI eval $inject; $dbclass->install_method($method); } } else { warn "Using DBI::DBD::SqlEngine with unregistered driver $class.\n" . "Reading documentation how to prevent is strongly recommended.\n"; } # XXX inject DBD::XXX::Statement unless exists my $stclass = $class . "::st"; $stclass->install_method("sql_get_colnames") unless ( $methods_installed{__PACKAGE__}++ ); return $drh->{$class}; } # driver sub CLONE { undef $drh; } # CLONE # ====== DRIVER ================================================================ package DBI::DBD::SqlEngine::dr; use strict; use warnings; use Carp qw/carp/; our $imp_data_size = 0; sub connect ($$;$$$) { my ( $drh, $dbname, $user, $auth, $attr ) = @_; # create a 'blank' dbh my $dbh = DBI::_new_dbh( $drh, { Name => $dbname, USER => $user, CURRENT_USER => $user, } ); if ($dbh) { # must be done first, because setting flags implicitly calls $dbdname::db->STORE $dbh->func( 0, "init_default_attributes" ); my $two_phased_init; defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase}; my %second_phase_attrs; my @func_inits; # this must be done to allow DBI.pm reblessing got handle after successful connecting exists $attr->{RootClass} and $second_phase_attrs{RootClass} = delete $attr->{RootClass}; my ( $var, $val ); while ( length $dbname ) { if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s ) { $var = $1; } else { $var = $dbname; $dbname = ""; } if ( $var =~ m/^(.+?)=(.*)/s ) { $var = $1; ( $val = $2 ) =~ s/\\(.)/$1/g; exists $attr->{$var} and carp("$var is given in DSN *and* \$attr during DBI->connect()") if ($^W); exists $attr->{$var} or $attr->{$var} = $val; } elsif ( $var =~ m/^(.+?)=>(.*)/s ) { $var = $1; ( $val = $2 ) =~ s/\\(.)/$1/g; my $ref = eval $val; # $dbh->$var($ref); push( @func_inits, $var, $ref ); } } # The attributes need to be sorted in a specific way as the # assignment is through tied hashes and calls STORE on each # attribute. Some attributes require to be called prior to # others # e.g. f_dir *must* be done before xx_tables in DBD::File # The dbh attribute sql_init_order is a hash with the order # as key (low is first, 0 .. 100) and the attributes that # are set to that oreder as anon-list as value: # { 0 => [qw( AutoCommit PrintError RaiseError Profile ... )], # 10 => [ list of attr to be dealt with immediately after first ], # 50 => [ all fields that are unspecified or default sort order ], # 90 => [ all fields that are needed after other initialisation ], # } my %order = map { my $order = $_; map { ( $_ => $order ) } @{ $dbh->{sql_init_order}{$order} }; } sort { $a <=> $b } keys %{ $dbh->{sql_init_order} || {} }; my @ordered_attr = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $order{$_} // 50 ] } keys %$attr; # initialize given attributes ... lower weighted before higher weighted foreach my $a (@ordered_attr) { exists $attr->{$a} or next; $two_phased_init and eval { $dbh->{$a} = $attr->{$a}; delete $attr->{$a}; }; $@ and $second_phase_attrs{$a} = delete $attr->{$a}; $two_phased_init or $dbh->STORE( $a, delete $attr->{$a} ); } $two_phased_init and $dbh->func( 1, "init_default_attributes" ); %$attr = %second_phase_attrs; for ( my $i = 0; $i < scalar(@func_inits); $i += 2 ) { my $func = $func_inits[$i]; my $arg = $func_inits[ $i + 1 ]; $dbh->$func($arg); } $dbh->func("init_done"); $dbh->STORE( Active => 1 ); } return $dbh; } # connect sub data_sources ($;$) { my ( $drh, $attr ) = @_; my $tbl_src; $attr and defined $attr->{sql_table_source} and $attr->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') and $tbl_src = $attr->{sql_table_source}; !defined($tbl_src) and $drh->{ImplementorClass}->can('default_table_source') and $tbl_src = $drh->{ImplementorClass}->default_table_source(); defined($tbl_src) or return; $tbl_src->data_sources( $drh, $attr ); } # data_sources sub disconnect_all { } # disconnect_all sub DESTROY { undef; } # DESTROY # ====== DATABASE ============================================================== package DBI::DBD::SqlEngine::db; use strict; use warnings; use Carp; use Scalar::Util qw( refaddr ); if ( eval { require Clone; } ) { Clone->import("clone"); } else { require Storable; # in CORE since 5.7.3 *clone = \&Storable::dclone; } our $imp_data_size = 0; sub ping { ( $_[0]->FETCH("Active") ) ? 1 : 0; } # ping sub data_sources { my ( $dbh, $attr, @other ) = @_; my $drh = $dbh->{Driver}; # XXX proxy issues? ref($attr) eq 'HASH' or $attr = {}; $attr->{sql_table_source} //= $dbh->{sql_table_source}; return $drh->data_sources( $attr, @other ); } sub prepare ($$;@) { my ( $dbh, $statement, @attribs ) = @_; # create a 'blank' sth my $sth = DBI::_new_sth( $dbh, { Statement => $statement } ); if ($sth) { my $class = $sth->FETCH("ImplementorClass"); $class =~ s/::st$/::Statement/; my $stmt; # if using SQL::Statement version > 1 # cache the parser object if the DBD supports parser caching # SQL::Nano and older SQL::Statements don't support this if ( $class->isa("SQL::Statement") ) { my $parser = $dbh->{sql_parser_object}; $parser ||= eval { $dbh->func("sql_parser_object") }; if ($@) { $stmt = eval { $class->new($statement) }; } else { $stmt = eval { $class->new( $statement, $parser ) }; } } else { $stmt = eval { $class->new($statement) }; } if ( $@ || $stmt->{errstr} ) { $dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} ); undef $sth; } else { $sth->STORE( "sql_stmt", $stmt ); $sth->STORE( "sql_params", [] ); $sth->STORE( "NUM_OF_PARAMS", scalar( $stmt->params() ) ); my @colnames = $sth->sql_get_colnames(); $sth->STORE( "NUM_OF_FIELDS", scalar @colnames ); } } return $sth; } # prepare sub set_versions { my $dbh = $_[0]; $dbh->{sql_engine_version} = $DBI::DBD::SqlEngine::VERSION; for (qw( nano_version statement_version )) { defined $DBI::SQL::Nano::versions->{$_} or next; $dbh->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_}; } $dbh->{sql_handler} = $dbh->{sql_statement_version} ? "SQL::Statement" : "DBI::SQL::Nano"; return $dbh; } # set_versions sub init_valid_attributes { my $dbh = $_[0]; $dbh->{sql_valid_attrs} = { sql_engine_version => 1, # DBI::DBD::SqlEngine version sql_handler => 1, # Nano or S:S sql_nano_version => 1, # Nano version sql_statement_version => 1, # S:S version sql_flags => 1, # flags for SQL::Parser sql_dialect => 1, # dialect for SQL::Parser sql_quoted_identifier_case => 1, # case for quoted identifiers sql_identifier_case => 1, # case for non-quoted identifiers sql_parser_object => 1, # SQL::Parser instance sql_sponge_driver => 1, # Sponge driver for table_info () sql_valid_attrs => 1, # SQL valid attributes sql_readonly_attrs => 1, # SQL readonly attributes sql_init_phase => 1, # Only during initialization sql_meta => 1, # meta data for tables sql_meta_map => 1, # mapping table for identifier case sql_data_source => 1, # reasonable datasource class }; $dbh->{sql_readonly_attrs} = { sql_engine_version => 1, # DBI::DBD::SqlEngine version sql_handler => 1, # Nano or S:S sql_nano_version => 1, # Nano version sql_statement_version => 1, # S:S version sql_quoted_identifier_case => 1, # case for quoted identifiers sql_parser_object => 1, # SQL::Parser instance sql_sponge_driver => 1, # Sponge driver for table_info () sql_valid_attrs => 1, # SQL valid attributes sql_readonly_attrs => 1, # SQL readonly attributes }; return $dbh; } # init_valid_attributes sub init_default_attributes { my ( $dbh, $phase ) = @_; my $given_phase = $phase; unless ( defined($phase) ) { # we have an "old" driver here $phase = defined $dbh->{sql_init_phase}; $phase and $phase = $dbh->{sql_init_phase}; } if ( 0 == $phase ) { # must be done first, because setting flags implicitly calls $dbdname::db->STORE $dbh->func("init_valid_attributes"); $dbh->func("set_versions"); $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER $dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE $dbh->{sql_dialect} = "CSV"; $dbh->{sql_init_phase} = $given_phase; # complete derived attributes, if required ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix($drv_class); my $valid_attrs = $drv_prefix . "valid_attrs"; my $ro_attrs = $drv_prefix . "readonly_attrs"; # check whether we're running in a Gofer server or not (see # validate_FETCH_attr for details) $dbh->{sql_engine_in_gofer} = ( defined $INC{"DBD/Gofer.pm"} && ( caller(5) )[0] eq "DBI::Gofer::Execute" ); $dbh->{sql_meta} = {}; $dbh->{sql_meta_map} = {}; # choose new name because it contains other keys # init_default_attributes calls inherited routine before derived DBD's # init their default attributes, so we don't override something here # # defining an order of attribute initialization from connect time # specified ones with a magic baarier (see next statement) my $drv_pfx_meta = $drv_prefix . "meta"; $dbh->{sql_init_order} = { 0 => [qw( Profile RaiseError PrintError AutoCommit )], 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ], }; # ensuring Profile, RaiseError, PrintError, AutoCommit are initialized # first when initializing attributes from connect time specified # attributes # further, initializations to predefined tables are happens after any # unspecified attribute initialization (that default to order 50) my @comp_attrs = qw(valid_attrs version readonly_attrs); if ( exists $dbh->{$drv_pfx_meta} and !$dbh->{sql_engine_in_gofer} ) { my $attr = $dbh->{$drv_pfx_meta}; defined $attr and defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and $dbh->{$valid_attrs}{$attr} = 1; my %h; tie %h, "DBI::DBD::SqlEngine::TieTables", $dbh; $dbh->{$attr} = \%h; push @comp_attrs, "meta"; } foreach my $comp_attr (@comp_attrs) { my $attr = $drv_prefix . $comp_attr; defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and $dbh->{$valid_attrs}{$attr} = 1; defined $dbh->{$ro_attrs} and !defined $dbh->{$ro_attrs}{$attr} and $dbh->{$ro_attrs}{$attr} = 1; } } return $dbh; } # init_default_attributes sub init_done { defined $_[0]->{sql_init_phase} and delete $_[0]->{sql_init_phase}; delete $_[0]->{sql_valid_attrs}->{sql_init_phase}; return; } sub sql_parser_object { my $dbh = $_[0]; my $dialect = $dbh->{sql_dialect} || "CSV"; my $parser = { RaiseError => $dbh->FETCH("RaiseError"), PrintError => $dbh->FETCH("PrintError"), }; my $sql_flags = $dbh->FETCH("sql_flags") || {}; %$parser = ( %$parser, %$sql_flags ); $parser = SQL::Parser->new( $dialect, $parser ); $dbh->{sql_parser_object} = $parser; return $parser; } # sql_parser_object sub sql_sponge_driver { my $dbh = $_[0]; my $dbh2 = $dbh->{sql_sponge_driver}; unless ($dbh2) { $dbh2 = $dbh->{sql_sponge_driver} = DBI->connect("DBI:Sponge:"); unless ($dbh2) { $dbh->set_err( $DBI::stderr, $DBI::errstr ); return; } } } sub disconnect ($) { %{ $_[0]->{sql_meta} } = (); %{ $_[0]->{sql_meta_map} } = (); $_[0]->STORE( Active => 0 ); return 1; } # disconnect sub validate_FETCH_attr { my ( $dbh, $attrib ) = @_; # If running in a Gofer server, access to our tied compatibility hash # would force Gofer to serialize the tieing object including it's # private $dbh reference used to do the driver function calls. # This will result in nasty exceptions. So return a copy of the # sql_meta structure instead, which is the source of for the compatibility # tie-hash. It's not as good as liked, but the best we can do in this # situation. if ( $dbh->{sql_engine_in_gofer} ) { ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix($drv_class); exists $dbh->{ $drv_prefix . "meta" } && $attrib eq $dbh->{ $drv_prefix . "meta" } and $attrib = "sql_meta"; } return $attrib; } sub FETCH ($$) { my ( $dbh, $attrib ) = @_; $attrib eq "AutoCommit" and return 1; # Driver private attributes are lower cased if ( $attrib eq ( lc $attrib ) ) { # first let the implementation deliver an alias for the attribute to fetch # after it validates the legitimation of the fetch request $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return; my $attr_prefix; $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; unless ($attr_prefix) { ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; $attr_prefix = DBI->driver_prefix($drv_class); $attrib = $attr_prefix . $attrib; } my $valid_attrs = $attr_prefix . "valid_attrs"; my $ro_attrs = $attr_prefix . "readonly_attrs"; exists $dbh->{$valid_attrs} and ( $dbh->{$valid_attrs}{$attrib} or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); exists $dbh->{$ro_attrs} and $dbh->{$ro_attrs}{$attrib} and defined $dbh->{$attrib} and refaddr( $dbh->{$attrib} ) and return clone( $dbh->{$attrib} ); return $dbh->{$attrib}; } # else pass up to DBI to handle return $dbh->SUPER::FETCH($attrib); } # FETCH sub validate_STORE_attr { my ( $dbh, $attrib, $value ) = @_; if ( $attrib eq "sql_identifier_case" || $attrib eq "sql_quoted_identifier_case" and $value < 1 || $value > 4 ) { croak "attribute '$attrib' must have a value from 1 .. 4 (SQL_IC_UPPER .. SQL_IC_MIXED)"; # XXX correctly a remap of all entries in sql_meta/sql_meta_map is required here } ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix($drv_class); exists $dbh->{ $drv_prefix . "meta" } and $attrib eq $dbh->{ $drv_prefix . "meta" } and $attrib = "sql_meta"; return ( $attrib, $value ); } # the ::db::STORE method is what gets called when you set # a lower-cased database handle attribute such as $dbh->{somekey}=$someval; # # STORE should check to make sure that "somekey" is a valid attribute name # but only if it is really one of our attributes (starts with dbm_ or foo_) # You can also check for valid values for the attributes if needed # and/or perform other operations # sub STORE ($$$) { my ( $dbh, $attrib, $value ) = @_; if ( $attrib eq "AutoCommit" ) { $value and return 1; # is already set croak "Can't disable AutoCommit"; } if ( $attrib eq lc $attrib ) { # Driver private attributes are lower cased ( $attrib, $value ) = $dbh->func( $attrib, $value, "validate_STORE_attr" ); $attrib or return; my $attr_prefix; $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; unless ($attr_prefix) { ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; $attr_prefix = DBI->driver_prefix($drv_class); $attrib = $attr_prefix . $attrib; } my $valid_attrs = $attr_prefix . "valid_attrs"; my $ro_attrs = $attr_prefix . "readonly_attrs"; exists $dbh->{$valid_attrs} and ( $dbh->{$valid_attrs}{$attrib} or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); exists $dbh->{$ro_attrs} and $dbh->{$ro_attrs}{$attrib} and defined $dbh->{$attrib} and return $dbh->set_err( $DBI::stderr, "attribute '$attrib' is readonly and must not be modified" ); if ( $attrib eq "sql_meta" ) { while ( my ( $k, $v ) = each %$value ) { $dbh->{$attrib}{$k} = $v; } } else { $dbh->{$attrib} = $value; } return 1; } return $dbh->SUPER::STORE( $attrib, $value ); } # STORE sub get_driver_versions { my ( $dbh, $table ) = @_; my %vsn = ( OS => "$^O ($Config::Config{osvers})", Perl => "$] ($Config::Config{archname})", DBI => $DBI::VERSION, ); my %vmp; my $sql_engine_verinfo = join " ", $dbh->{sql_engine_version}, "using", $dbh->{sql_handler}, $dbh->{sql_handler} eq "SQL::Statement" ? $dbh->{sql_statement_version} : $dbh->{sql_nano_version}; my $indent = 0; my @deriveds = ( $dbh->{ImplementorClass} ); while (@deriveds) { my $derived = shift @deriveds; $derived eq "DBI::DBD::SqlEngine::db" and last; $derived->isa("DBI::DBD::SqlEngine::db") or next; #no strict 'refs'; eval "push \@deriveds, \@${derived}::ISA"; #use strict; ( my $drv_class = $derived ) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix($drv_class); my $ddgv = $dbh->{ImplementorClass}->can("get_${drv_prefix}versions"); my $drv_version = $ddgv ? &$ddgv( $dbh, $table ) : $dbh->{ $drv_prefix . "version" }; $drv_version ||= eval { $derived->VERSION() }; # XXX access $drv_class::VERSION via symbol table $vsn{$drv_class} = $drv_version; $indent and $vmp{$drv_class} = " " x $indent . $drv_class; $indent += 2; } $vsn{"DBI::DBD::SqlEngine"} = $sql_engine_verinfo; $indent and $vmp{"DBI::DBD::SqlEngine"} = " " x $indent . "DBI::DBD::SqlEngine"; $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION; $indent += 20; my @versions = map { sprintf "%-${indent}s %s", $vmp{$_} || $_, $vsn{$_} } sort { $a->isa($b) and return -1; $b->isa($a) and return 1; $a->isa("DBI::DBD::SqlEngine") and return -1; $b->isa("DBI::DBD::SqlEngine") and return 1; return $a cmp $b; } keys %vsn; return wantarray ? @versions : join "\n", @versions; } # get_versions sub get_single_table_meta { my ( $dbh, $table, $attr ) = @_; my $meta; $table eq "." and return $dbh->FETCH($attr); ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); $meta or croak "No such table '$table'"; # prevent creation of undef attributes return $class->get_table_meta_attr( $meta, $attr ); } # get_single_table_meta sub get_sql_engine_meta { my ( $dbh, $table, $attr ) = @_; my $gstm = $dbh->{ImplementorClass}->can("get_single_table_meta"); $table eq "*" and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; $table eq "+" and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; ref $table eq "Regexp" and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ]; ref $table || ref $attr or return $gstm->( $dbh, $table, $attr ); ref $table or $table = [$table]; ref $attr or $attr = [$attr]; "ARRAY" eq ref $table or return $dbh->set_err( $DBI::stderr, "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table ); "ARRAY" eq ref $attr or return $dbh->set_err( "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr ); my %results; foreach my $tname ( @{$table} ) { my %tattrs; foreach my $aname ( @{$attr} ) { $tattrs{$aname} = $gstm->( $dbh, $tname, $aname ); } $results{$tname} = \%tattrs; } return \%results; } # get_sql_engine_meta sub new_sql_engine_meta { my ( $dbh, $table, $values ) = @_; my $respect_case = 0; "HASH" eq ref $values or croak "Invalid argument for \$values - SCALAR or HASH expected but got " . ref $values; $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers $table =~ s/\"$//; unless ($respect_case) { defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; } $dbh->{sql_meta}{$table} = { %{$values} }; my $class; defined $values->{sql_table_class} and $class = $values->{sql_table_class}; defined $class or ( $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; # XXX we should never hit DBD::File::Table::get_table_meta here ... my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, $respect_case ); 1; } # new_sql_engine_meta sub set_single_table_meta { my ( $dbh, $table, $attr, $value ) = @_; my $meta; $table eq "." and return $dbh->STORE( $attr, $value ); ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); # 1 means: respect case $meta or croak "No such table '$table'"; $class->set_table_meta_attr( $meta, $attr, $value ); return $dbh; } # set_single_table_meta sub set_sql_engine_meta { my ( $dbh, $table, $attr, $value ) = @_; my $sstm = $dbh->{ImplementorClass}->can("set_single_table_meta"); $table eq "*" and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; $table eq "+" and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; ref($table) eq "Regexp" and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ]; ref $table || ref $attr or return $sstm->( $dbh, $table, $attr, $value ); ref $table or $table = [$table]; ref $attr or $attr = { $attr => $value }; "ARRAY" eq ref $table or croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table; "HASH" eq ref $attr or croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr; foreach my $tname ( @{$table} ) { while ( my ( $aname, $aval ) = each %$attr ) { $sstm->( $dbh, $tname, $aname, $aval ); } } return $dbh; } # set_file_meta sub clear_sql_engine_meta { my ( $dbh, $table ) = @_; ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); $meta and %{$meta} = (); return; } # clear_file_meta sub DESTROY ($) { my $dbh = shift; $dbh->SUPER::FETCH("Active") and $dbh->disconnect; undef $dbh->{sql_parser_object}; } # DESTROY sub type_info_all ($) { [ { TYPE_NAME => 0, DATA_TYPE => 1, PRECISION => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, MONEY => 10, AUTO_INCREMENT => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, }, [ "VARCHAR", DBI::SQL_VARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], [ "CHAR", DBI::SQL_CHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], [ "INTEGER", DBI::SQL_INTEGER(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], [ "REAL", DBI::SQL_REAL(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], [ "TEXT", DBI::SQL_LONGVARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], ]; } # type_info_all sub get_avail_tables { my $dbh = $_[0]; my @tables = (); if ( $dbh->{sql_handler} eq "SQL::Statement" and $dbh->{sql_ram_tables} ) { # XXX map +[ undef, undef, $_, "TABLE", "TEMP" ], keys %{...} foreach my $table ( keys %{ $dbh->{sql_ram_tables} } ) { push @tables, [ undef, undef, $table, "TABLE", "TEMP" ]; } } my $tbl_src; defined $dbh->{sql_table_source} and $dbh->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') and $tbl_src = $dbh->{sql_table_source}; !defined($tbl_src) and $dbh->{Driver}->{ImplementorClass}->can('default_table_source') and $tbl_src = $dbh->{Driver}->{ImplementorClass}->default_table_source(); defined($tbl_src) and push( @tables, $tbl_src->avail_tables($dbh) ); return @tables; } # get_avail_tables { my $names = [qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )]; sub table_info ($) { my $dbh = shift; my @tables = $dbh->func("get_avail_tables"); # Temporary kludge: DBD::Sponge dies if @tables is empty. :-( # this no longer seems to be true @tables or return; my $dbh2 = $dbh->func("sql_sponge_driver"); my $sth = $dbh2->prepare( "TABLE_INFO", { rows => \@tables, NAME => $names, } ); $sth or return $dbh->set_err( $DBI::stderr, $dbh2->errstr ); $sth->execute or return; return $sth; } # table_info } sub list_tables ($) { my $dbh = shift; my @table_list; my @tables = $dbh->func("get_avail_tables") or return; foreach my $ref (@tables) { # rt69260 and rt67223 - the same issue in 2 different queues push @table_list, $ref->[2]; } return @table_list; } # list_tables sub quote ($$;$) { my ( $self, $str, $type ) = @_; defined $str or return "NULL"; defined $type && ( $type == DBI::SQL_NUMERIC() || $type == DBI::SQL_DECIMAL() || $type == DBI::SQL_INTEGER() || $type == DBI::SQL_SMALLINT() || $type == DBI::SQL_FLOAT() || $type == DBI::SQL_REAL() || $type == DBI::SQL_DOUBLE() || $type == DBI::SQL_TINYINT() ) and return $str; $str =~ s/\\/\\\\/sg; $str =~ s/\0/\\0/sg; $str =~ s/\'/\\\'/sg; $str =~ s/\n/\\n/sg; $str =~ s/\r/\\r/sg; return "'$str'"; } # quote sub commit ($) { my $dbh = shift; $dbh->FETCH("Warn") and carp "Commit ineffective while AutoCommit is on", -1; return 1; } # commit sub rollback ($) { my $dbh = shift; $dbh->FETCH("Warn") and carp "Rollback ineffective while AutoCommit is on", -1; return 0; } # rollback # ====== Tie-Meta ============================================================== package DBI::DBD::SqlEngine::TieMeta; use Carp qw(croak); require Tie::Hash; our @ISA = qw(Tie::Hash); sub TIEHASH { my ( $class, $tblClass, $tblMeta ) = @_; my $self = bless( { tblClass => $tblClass, tblMeta => $tblMeta, }, $class ); return $self; } # new sub STORE { my ( $self, $meta_attr, $meta_val ) = @_; $self->{tblClass}->set_table_meta_attr( $self->{tblMeta}, $meta_attr, $meta_val ); return; } # STORE sub FETCH { my ( $self, $meta_attr ) = @_; return $self->{tblClass}->get_table_meta_attr( $self->{tblMeta}, $meta_attr ); } # FETCH sub FIRSTKEY { my $a = scalar keys %{ $_[0]->{tblMeta} }; each %{ $_[0]->{tblMeta} }; } # FIRSTKEY sub NEXTKEY { each %{ $_[0]->{tblMeta} }; } # NEXTKEY sub EXISTS { exists $_[0]->{tblMeta}{ $_[1] }; } # EXISTS sub DELETE { croak "Can't delete single attributes from table meta structure"; } # DELETE sub CLEAR { %{ $_[0]->{tblMeta} } = (); } # CLEAR sub SCALAR { scalar %{ $_[0]->{tblMeta} }; } # SCALAR # ====== Tie-Tables ============================================================ package DBI::DBD::SqlEngine::TieTables; use Carp qw(croak); require Tie::Hash; our @ISA = qw(Tie::Hash); sub TIEHASH { my ( $class, $dbh ) = @_; ( my $tbl_class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; my $self = bless( { dbh => $dbh, tblClass => $tbl_class, }, $class ); return $self; } # new sub STORE { my ( $self, $table, $tbl_meta ) = @_; "HASH" eq ref $tbl_meta or croak "Invalid data for storing as table meta data (must be hash)"; ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); $meta or croak "Invalid table name '$table'"; while ( my ( $meta_attr, $meta_val ) = each %$tbl_meta ) { $self->{tblClass}->set_table_meta_attr( $meta, $meta_attr, $meta_val ); } return; } # STORE sub FETCH { my ( $self, $table ) = @_; ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); $meta or croak "Invalid table name '$table'"; my %h; tie %h, "DBI::DBD::SqlEngine::TieMeta", $self->{tblClass}, $meta; return \%h; } # FETCH sub FIRSTKEY { my $a = scalar keys %{ $_[0]->{dbh}->{sql_meta} }; each %{ $_[0]->{dbh}->{sql_meta} }; } # FIRSTKEY sub NEXTKEY { each %{ $_[0]->{dbh}->{sql_meta} }; } # NEXTKEY sub EXISTS { exists $_[0]->{dbh}->{sql_meta}->{ $_[1] } or exists $_[0]->{dbh}->{sql_meta_map}->{ $_[1] }; } # EXISTS sub DELETE { my ( $self, $table ) = @_; ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); $meta or croak "Invalid table name '$table'"; delete $_[0]->{dbh}->{sql_meta}->{ $meta->{table_name} }; } # DELETE sub CLEAR { %{ $_[0]->{dbh}->{sql_meta} } = (); %{ $_[0]->{dbh}->{sql_meta_map} } = (); } # CLEAR sub SCALAR { scalar %{ $_[0]->{dbh}->{sql_meta} }; } # SCALAR # ====== STATEMENT ============================================================= package DBI::DBD::SqlEngine::st; use strict; use warnings; our $imp_data_size = 0; sub bind_param ($$$;$) { my ( $sth, $pNum, $val, $attr ) = @_; if ( $attr && defined $val ) { my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr; if ( $type == DBI::SQL_BIGINT() || $type == DBI::SQL_INTEGER() || $type == DBI::SQL_SMALLINT() || $type == DBI::SQL_TINYINT() ) { $val += 0; } elsif ( $type == DBI::SQL_DECIMAL() || $type == DBI::SQL_DOUBLE() || $type == DBI::SQL_FLOAT() || $type == DBI::SQL_NUMERIC() || $type == DBI::SQL_REAL() ) { $val += 0.; } else { $val = "$val"; } } $sth->{sql_params}[ $pNum - 1 ] = $val; return 1; } # bind_param sub execute { my $sth = shift; my $params = @_ ? ( $sth->{sql_params} = [@_] ) : $sth->{sql_params}; $sth->finish; my $stmt = $sth->{sql_stmt}; # must not proved when already executed - SQL::Statement modifies # received params unless ( $sth->{sql_params_checked}++ ) { # SQL::Statement and DBI::SQL::Nano will return the list of required params # when called in list context. Do not look into the several items, they're # implementation specific and may change without warning unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) ) { my $msg = "You passed $nparm parameters where $req_prm required"; return $sth->set_err( $DBI::stderr, $msg ); } } my @err; my $result; eval { local $SIG{__WARN__} = sub { push @err, @_ }; $result = $stmt->execute( $sth, $params ); }; unless ( defined $result ) { $sth->set_err( $DBI::stderr, $@ || $stmt->{errstr} || $err[0] ); return; } if ( $stmt->{NUM_OF_FIELDS} ) { # is a SELECT statement $sth->STORE( Active => 1 ); $sth->FETCH("NUM_OF_FIELDS") or $sth->STORE( "NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS} ); } return $result; } # execute sub finish { my $sth = $_[0]; $sth->SUPER::STORE( Active => 0 ); delete $sth->{sql_stmt}{data}; return 1; } # finish sub fetch ($) { my $sth = $_[0]; my $data = $sth->{sql_stmt}{data}; if ( !$data || ref $data ne "ARRAY" ) { $sth->set_err( $DBI::stderr, "Attempt to fetch row without a preceding execute () call or from a non-SELECT statement" ); return; } my $dav = shift @$data; unless ($dav) { $sth->finish; return; } if ( $sth->FETCH("ChopBlanks") ) # XXX: (TODO) Only chop on CHAR fields, { # not on VARCHAR or NUMERIC (see DBI docs) $_ && $_ =~ s/ +$// for @$dav; } return $sth->_set_fbav($dav); } # fetch no warnings 'once'; *fetchrow_arrayref = \&fetch; use warnings; sub sql_get_colnames { my $sth = $_[0]; # Being a bit dirty here, as neither SQL::Statement::Structure nor # DBI::SQL::Nano::Statement_ does not offer an interface to the # required data my @colnames; if ( $sth->{sql_stmt}->{NAME} and "ARRAY" eq ref( $sth->{sql_stmt}->{NAME} ) ) { @colnames = @{ $sth->{sql_stmt}->{NAME} }; } elsif ( $sth->{sql_stmt}->isa('SQL::Statement') ) { my $stmt = $sth->{sql_stmt} || {}; my @coldefs = @{ $stmt->{column_defs} || [] }; @colnames = map { $_->{name} || $_->{value} } @coldefs; } @colnames = $sth->{sql_stmt}->column_names() unless (@colnames); @colnames = () if ( grep { m/\*/ } @colnames ); return @colnames; } sub FETCH ($$) { my ( $sth, $attrib ) = @_; $attrib eq "NAME" and return [ $sth->sql_get_colnames() ]; $attrib eq "TYPE" and return [ ( DBI::SQL_VARCHAR() ) x scalar $sth->sql_get_colnames() ]; $attrib eq "TYPE_NAME" and return [ ("VARCHAR") x scalar $sth->sql_get_colnames() ]; $attrib eq "PRECISION" and return [ (0) x scalar $sth->sql_get_colnames() ]; $attrib eq "NULLABLE" and return [ (1) x scalar $sth->sql_get_colnames() ]; if ( $attrib eq lc $attrib ) { # Private driver attributes are lower cased return $sth->{$attrib}; } # else pass up to DBI to handle return $sth->SUPER::FETCH($attrib); } # FETCH sub STORE ($$$) { my ( $sth, $attrib, $value ) = @_; if ( $attrib eq lc $attrib ) # Private driver attributes are lower cased { $sth->{$attrib} = $value; return 1; } return $sth->SUPER::STORE( $attrib, $value ); } # STORE sub DESTROY ($) { my $sth = shift; $sth->SUPER::FETCH("Active") and $sth->finish; undef $sth->{sql_stmt}; undef $sth->{sql_params}; } # DESTROY sub rows ($) { return $_[0]->{sql_stmt}{NUM_OF_ROWS}; } # rows # ====== TableSource =========================================================== package DBI::DBD::SqlEngine::TableSource; use strict; use warnings; use Carp; sub data_sources ($;$) { my ( $class, $drh, $attrs ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement data_sources" ); } sub avail_tables { my ( $self, $dbh ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement avail_tables" ); } # ====== DataSource ============================================================ package DBI::DBD::SqlEngine::DataSource; use strict; use warnings; use Carp; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement complete_table_name" ); } sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement open_data" ); } # ====== SQL::STATEMENT ======================================================== package DBI::DBD::SqlEngine::Statement; use strict; use warnings; use Carp; our @ISA = qw(DBI::SQL::Nano::Statement); sub open_table ($$$$$) { my ( $self, $data, $table, $createMode, $lockMode ) = @_; my $class = ref $self; $class =~ s/::Statement/::Table/; my $flags = { createMode => $createMode, lockMode => $lockMode, }; $self->{command} eq "DROP" and $flags->{dropMode} = 1; my ( $tblnm, $table_meta ) = $class->get_table_meta( $data->{Database}, $table, 1 ) or croak "Cannot find appropriate meta for table '$table'"; defined $table_meta->{sql_table_class} and $class = $table_meta->{sql_table_class}; # because column name mapping is initialized in constructor ... # and therefore specific opening operations might be done before # reaching DBI::DBD::SqlEngine::Table->new(), we need to intercept # ReadOnly here my $write_op = $createMode || $lockMode || $flags->{dropMode}; if ($write_op) { $table_meta->{readonly} and croak "Table '$table' is marked readonly - " . $self->{command} . ( $lockMode ? " with locking" : "" ) . " command forbidden"; } return $class->new( $data, { table => $table }, $flags ); } # open_table # ====== SQL::TABLE ============================================================ package DBI::DBD::SqlEngine::Table; use strict; use warnings; use Carp; our @ISA = qw(DBI::SQL::Nano::Table); sub bootstrap_table_meta { my ( $self, $dbh, $meta, $table ) = @_; defined $dbh->{ReadOnly} and !defined( $meta->{readonly} ) and $meta->{readonly} = $dbh->{ReadOnly}; defined $meta->{sql_identifier_case} or $meta->{sql_identifier_case} = $dbh->{sql_identifier_case}; exists $meta->{sql_data_source} or $meta->{sql_data_source} = $dbh->{sql_data_source}; $meta; } sub init_table_meta { my ( $self, $dbh, $meta, $table ) = @_ if (0); return; } # init_table_meta sub get_table_meta ($$$;$) { my ( $self, $dbh, $table, $respect_case, @other ) = @_; unless ( defined $respect_case ) { $respect_case = 0; $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers $table =~ s/\"$//; } unless ($respect_case) { defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; } my $meta = {}; defined $dbh->{sql_meta}{$table} and $meta = $dbh->{sql_meta}{$table}; do_initialize: unless ( $meta->{initialized} ) { $self->bootstrap_table_meta( $dbh, $meta, $table, @other ); $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) or return; if ( defined $meta->{table_name} and $table ne $meta->{table_name} ) { $dbh->{sql_meta_map}{$table} = $meta->{table_name}; $table = $meta->{table_name}; } # now we know a bit more - let's check if user can't use consequent spelling # XXX add know issue about reset sql_identifier_case here ... if ( defined $dbh->{sql_meta}{$table} ) { $meta = delete $dbh->{sql_meta}{$table}; # avoid endless loop $meta->{initialized} or goto do_initialize; #or $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) #or return; } unless ( $dbh->{sql_meta}{$table}{initialized} ) { $self->init_table_meta( $dbh, $meta, $table ); $meta->{initialized} = 1; $dbh->{sql_meta}{$table} = $meta; } } return ( $table, $meta ); } # get_table_meta my %reset_on_modify = (); my %compat_map = (); sub register_reset_on_modify { my ( $proto, $extra_resets ) = @_; foreach my $cv ( keys %$extra_resets ) { #%reset_on_modify = ( %reset_on_modify, %$extra_resets ); push @{ $reset_on_modify{$cv} }, ref $extra_resets->{$cv} ? @{ $extra_resets->{$cv} } : ( $extra_resets->{$cv} ); } return; } # register_reset_on_modify sub register_compat_map { my ( $proto, $extra_compat_map ) = @_; %compat_map = ( %compat_map, %$extra_compat_map ); return; } # register_compat_map sub get_table_meta_attr { my ( $class, $meta, $attrib ) = @_; exists $compat_map{$attrib} and $attrib = $compat_map{$attrib}; exists $meta->{$attrib} and return $meta->{$attrib}; return; } # get_table_meta_attr sub set_table_meta_attr { my ( $class, $meta, $attrib, $value ) = @_; exists $compat_map{$attrib} and $attrib = $compat_map{$attrib}; $class->table_meta_attr_changed( $meta, $attrib, $value ); $meta->{$attrib} = $value; } # set_table_meta_attr sub table_meta_attr_changed { my ( $class, $meta, $attrib, $value ) = @_; defined $reset_on_modify{$attrib} and delete @$meta{ @{ $reset_on_modify{$attrib} } } and $meta->{initialized} = 0; } # table_meta_attr_changed sub open_data { my ( $self, $meta, $attrs, $flags ) = @_; $meta->{sql_data_source} or croak "Table " . $meta->{table_name} . " not completely initialized"; $meta->{sql_data_source}->open_data( $meta, $attrs, $flags ); return; } # open_data # ====== SQL::Eval API ========================================================= sub new { my ( $className, $data, $attrs, $flags ) = @_; my $dbh = $data->{Database}; my ( $tblnm, $meta ) = $className->get_table_meta( $dbh, $attrs->{table}, 1 ) or croak "Cannot find appropriate table '$attrs->{table}'"; $attrs->{table} = $tblnm; # Being a bit dirty here, as SQL::Statement::Structure does not offer # me an interface to the data I want $flags->{createMode} && $data->{sql_stmt}{table_defs} and $meta->{table_defs} = $data->{sql_stmt}{table_defs}; # open_file must be called before inherited new is invoked # because column name mapping is initialized in constructor ... $className->open_data( $meta, $attrs, $flags ); my $tbl = { %{$attrs}, meta => $meta, col_names => $meta->{col_names} || [], }; return $className->SUPER::new($tbl); } # new sub DESTROY { my $self = shift; my $meta = $self->{meta}; $self->{row} and undef $self->{row}; () } 1; =pod =head1 NAME DBI::DBD::SqlEngine - Base class for DBI drivers without their own SQL engine =head1 SYNOPSIS package DBD::myDriver; use base qw(DBI::DBD::SqlEngine); sub driver { ... my $drh = $proto->SUPER::driver ($attr); ... return $drh->{class}; } package DBD::myDriver::dr; our @ISA = qw(DBI::DBD::SqlEngine::dr); sub data_sources { ... } ... package DBD::myDriver::db; our @ISA = qw(DBI::DBD::SqlEngine::db); sub init_valid_attributes { ... } sub init_default_attributes { ... } sub set_versions { ... } sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } sub get_myd_versions { ... } sub get_avail_tables { ... } package DBD::myDriver::st; our @ISA = qw(DBI::DBD::SqlEngine::st); sub FETCH { ... } sub STORE { ... } package DBD::myDriver::Statement; our @ISA = qw(DBI::DBD::SqlEngine::Statement); sub open_table { ... } package DBD::myDriver::Table; our @ISA = qw(DBI::DBD::SqlEngine::Table); sub new { ... } =head1 DESCRIPTION DBI::DBD::SqlEngine abstracts the usage of SQL engines from the DBD. DBD authors can concentrate on the data retrieval they want to provide. It is strongly recommended that you read L and L, because many of the DBD::File API is provided by DBI::DBD::SqlEngine. Currently the API of DBI::DBD::SqlEngine is experimental and will likely change in the near future to provide the table meta data basics like DBD::File. DBI::DBD::SqlEngine expects that any driver in inheritance chain has a L. =head2 Metadata The following attributes are handled by DBI itself and not by DBI::DBD::SqlEngine, thus they all work as expected: Active ActiveKids CachedKids CompatMode (Not used) InactiveDestroy AutoInactiveDestroy Kids PrintError RaiseError Warn (Not used) =head3 The following DBI attributes are handled by DBI::DBD::SqlEngine: =head4 AutoCommit Always on. =head4 ChopBlanks Works. =head4 NUM_OF_FIELDS Valid after C<< $sth->execute >>. =head4 NUM_OF_PARAMS Valid after C<< $sth->prepare >>. =head4 NAME Valid after C<< $sth->execute >>; probably undef for Non-Select statements. =head4 NULLABLE Not really working, always returns an array ref of ones, as DBD::CSV does not verify input data. Valid after C<< $sth->execute >>; undef for non-select statements. =head3 The following DBI attributes and methods are not supported: =over 4 =item bind_param_inout =item CursorName =item LongReadLen =item LongTruncOk =back =head3 DBI::DBD::SqlEngine specific attributes In addition to the DBI attributes, you can use the following dbh attributes: =head4 sql_engine_version Contains the module version of this driver (B) =head4 sql_nano_version Contains the module version of DBI::SQL::Nano (B) =head4 sql_statement_version Contains the module version of SQL::Statement, if available (B) =head4 sql_handler Contains the SQL Statement engine, either DBI::SQL::Nano or SQL::Statement (B). =head4 sql_parser_object Contains an instantiated instance of SQL::Parser (B). This is filled when used first time (only when used with SQL::Statement). =head4 sql_sponge_driver Contains an internally used DBD::Sponge handle (B). =head4 sql_valid_attrs Contains the list of valid attributes for each DBI::DBD::SqlEngine based driver (B). =head4 sql_readonly_attrs Contains the list of those attributes which are readonly (B). =head4 sql_identifier_case Contains how DBI::DBD::SqlEngine deals with non-quoted SQL identifiers: * SQL_IC_UPPER (1) means all identifiers are internally converted into upper-cased pendants * SQL_IC_LOWER (2) means all identifiers are internally converted into lower-cased pendants * SQL_IC_MIXED (4) means all identifiers are taken as they are These conversions happen if (and only if) no existing identifier matches. Once existing identifier is used as known. The SQL statement execution classes doesn't have to care, so don't expect C affects column names in statements like SELECT * FROM foo =head4 sql_quoted_identifier_case Contains how DBI::DBD::SqlEngine deals with quoted SQL identifiers (B). It's fixated to SQL_IC_SENSITIVE (3), which is interpreted as SQL_IC_MIXED. =head4 sql_flags Contains additional flags to instantiate an SQL::Parser. Because an SQL::Parser is instantiated only once, it's recommended to set this flag before any statement is executed. =head4 sql_dialect Controls the dialect understood by SQL::Parser. Possible values (delivery state of SQL::Statement): * ANSI * CSV * AnyData Defaults to "CSV". Because an SQL::Parser is instantiated only once and SQL::Parser doesn't allow one to modify the dialect once instantiated, it's strongly recommended to set this flag before any statement is executed (best place is connect attribute hash). =head4 sql_engine_in_gofer This value has a true value in case of this driver is operated via L. The impact of being operated via Gofer is a read-only driver (not read-only databases!), so you cannot modify any attributes later - neither any table settings. B you won't get an error in cases you modify table attributes, so please carefully watch C. =head4 sql_meta Private data area which contains information about the tables this module handles. Table meta data might not be available until the table has been accessed for the first time e.g., by issuing a select on it however it is possible to pre-initialize attributes for each table you use. DBI::DBD::SqlEngine recognizes the (public) attributes C, C, C, C and C. Be very careful when modifying attributes you do not know, the consequence might be a destroyed or corrupted table. While C is a private and readonly attribute (which means, you cannot modify it's values), derived drivers might provide restricted write access through another attribute. Well known accessors are C for L, C for L and C for L. =head4 sql_table_source Controls the class which will be used for fetching available tables. See L for details. =head4 sql_data_source Contains the class name to be used for opening tables. See L for details. =head2 Driver private methods =head3 Default DBI methods =head4 data_sources The C method returns a list of subdirectories of the current directory in the form "dbi:CSV:f_dir=$dirname". If you want to read the subdirectories of another directory, use my ($drh) = DBI->install_driver ("CSV"); my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data"); =head4 list_tables This method returns a list of file names inside $dbh->{f_dir}. Example: my ($dbh) = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data"); my (@list) = $dbh->func ("list_tables"); Note that the list includes all files contained in the directory, even those that have non-valid table names, from the view of SQL. =head3 Additional methods The following methods are only available via their documented name when DBI::DBD::SQlEngine is used directly. Because this is only reasonable for testing purposes, the real names must be used instead. Those names can be computed by replacing the C in the method name with the driver prefix. =head4 sql_versions Signature: sub sql_versions (;$) { my ($table_name) = @_; $table_name ||= "."; ... } Returns the versions of the driver, including the DBI version, the Perl version, DBI::PurePerl version (if DBI::PurePerl is active) and the version of the SQL engine in use. my $dbh = DBI->connect ("dbi:File:"); my $sql_versions = $dbh->func( "sql_versions" ); print "$sql_versions\n"; __END__ # DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.402 # DBI 1.623 # OS netbsd (6.99.12) # Perl 5.016002 (x86_64-netbsd-thread-multi) Called in list context, sql_versions will return an array containing each line as single entry. Some drivers might use the optional (table name) argument and modify version information related to the table (e.g. DBD::DBM provides storage backend information for the requested table, when it has a table name). =head4 sql_get_meta Signature: sub sql_get_meta ($$) { my ($table_name, $attrib) = @_; ... } Returns the value of a meta attribute set for a specific table, if any. See L for the possible attributes. A table name of C<"."> (single dot) is interpreted as the default table. This will retrieve the appropriate attribute globally from the dbh. This has the same restrictions as C<< $dbh->{$attrib} >>. =head4 sql_set_meta Signature: sub sql_set_meta ($$$) { my ($table_name, $attrib, $value) = @_; ... } Sets the value of a meta attribute set for a specific table. See L for the possible attributes. A table name of C<"."> (single dot) is interpreted as the default table which will set the specified attribute globally for the dbh. This has the same restrictions as C<< $dbh->{$attrib} = $value >>. =head4 sql_clear_meta Signature: sub sql_clear_meta ($) { my ($table_name) = @_; ... } Clears the table specific meta information in the private storage of the dbh. =head2 Extensibility =head3 DBI::DBD::SqlEngine::TableSource Provides data sources and table information on database driver and database handle level. package DBI::DBD::SqlEngine::TableSource; sub data_sources ($;$) { my ($class, $drh, $attrs) = @_; ... } sub avail_tables { my ( $class, $drh ) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources ($driver); @ary = DBI->data_sources ($driver, \%attr); @ary = $dbh->data_sources (); @ary = $dbh->data_sources (\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr); $dbh->func ("list_tables"); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default, e.g. @ary = DBI->data_sources ("dbi:CSV:", { f_dir => "/your/csv/tables", # note: this class doesn't comes with DBI sql_table_source => "DBD::File::Archive::Tar::TableSource", # scan tarballs instead of directories }); When you're going to implement such a DBD::File::Archive::Tar::TableSource class, remember to add correct attributes (including C and C) to the returned DSN's. =head3 DBI::DBD::SqlEngine::DataSource Provides base functionality for dealing with tables. It is primarily designed for allowing transparent access to files on disk or already opened (file-)streams (e.g. for DBD::CSV). Derived classes shall be restricted to similar functionality, too (e.g. opening streams from an archive, transparently compress/uncompress log files before parsing them, package DBI::DBD::SqlEngine::DataSource; sub complete_table_name ($$;$) { my ($self, $meta, $table, $respect_case) = @_; ... } The method C is called when first setting up the I for a table: "SELECT user.id, user.name, user.shell FROM user WHERE ..." results in opening the table C. First step of the table open process is completing the name. Let's imagine you're having a L handle with following settings: $dbh->{sql_identifier_case} = SQL_IC_LOWER; $dbh->{f_ext} = '.lst'; $dbh->{f_dir} = '/data/web/adrmgr'; Those settings will result in looking for files matching C<[Uu][Ss][Ee][Rr](\.lst)?$> in C. The scanning of the directory C and the pattern match check will be done in C by the C method. If you intend to provide other sources of data streams than files, in addition to provide an appropriate C method, a method to open the resource is required: package DBI::DBD::SqlEngine::DataSource; sub open_data ($) { my ($self, $meta, $attrs, $flags) = @_; ... } After the method C has been run successfully, the table's meta information are in a state which allows the table's data accessor methods will be able to fetch/store row information. Implementation details heavily depends on the table implementation, whereby the most famous is surely L. =head1 SQL ENGINES DBI::DBD::SqlEngine currently supports two SQL engines: L and L. DBI::SQL::Nano supports a I limited subset of SQL statements, but it might be faster for some very simple tasks. SQL::Statement in contrast supports a much larger subset of ANSI SQL. To use SQL::Statement, you need at least version 1.401 of SQL::Statement and the environment variable C must not be set to a true value. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc DBI::DBD::SqlEngine You can also look for information at: =over 4 =item * RT: CPAN's request tracker L L =item * CPAN Ratings L =item * Search CPAN L =back =head2 Where can I go for more help? For questions about installation or usage, please ask on the dbi-dev@perl.org mailing list. If you have a bug report, patch or suggestion, please open a new report ticket on CPAN, if there is not already one for the issue you want to report. Of course, you can mail any of the module maintainers, but it is less likely to be missed if it is reported on RT. Report tickets should contain a detailed description of the bug or enhancement request you want to report and at least an easy way to verify/reproduce the issue and any supplied fix. Patches are always welcome, too. =head1 ACKNOWLEDGEMENTS Thanks to Tim Bunce, Martin Evans and H.Merijn Brand for their continued support while developing DBD::File, DBD::DBM and DBD::AnyData. Their support, hints and feedback helped to design and implement this module. =head1 AUTHOR This module is currently maintained by H.Merijn Brand < hmbrand at cpan.org > and Jens Rehsack < rehsack at googlemail.com > The original authors are Jochen Wiedmann and Jeff Zucker. =head1 COPYRIGHT AND LICENSE Copyright (C) 2009-2026 by H.Merijn Brand & Jens Rehsack Copyright (C) 2004-2009 by Jeff Zucker Copyright (C) 1998-2004 by Jochen Wiedmann All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L, L, L and L. =cut DBI-1.652/lib/DBI/DBD.pm0000644000031300001440000036702515225403520013470 0ustar00merijnuserspackage DBI::DBD; # vim:ts=8:sw=4 use strict; use warnings; # set $VERSION early so we don't confuse PAUSE/CPAN etc # don't use Revision here because that's not in svn:keywords so that the # examples that use it below won't be messed up our $VERSION = "12.015129"; # $Id: DBD.pm 15128 2012-02-04 20:51:39Z Tim $ # # Copyright (c) 1997-2006 Jonathan Leffler, Jochen Wiedmann, Steffen # Goeldner and Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. =head1 NAME DBI::DBD - Perl DBI Database Driver Writer's Guide =head1 SYNOPSIS perldoc DBI::DBD =head2 Version and volatility This document is I a minimal draft which is in need of further work. Please read the B documentation first and fully. Then look at the implementation of some high-profile and regularly maintained drivers like DBD::Oracle, DBD::ODBC, DBD::Pg etc. (Those are in no particular order.) Then reread the B specification and the code of those drivers again as you're reading this. It'll help. Where this document and the driver code differ it's likely that the driver code is more correct, especially if multiple drivers do the same thing. This document is a patchwork of contributions from various authors. More contributions (preferably as patches) are very welcome. =head1 DESCRIPTION This document is primarily intended to help people writing new database drivers for the Perl Database Interface (Perl DBI). It may also help others interested in discovering why the internals of a B driver are written the way they are. This is a guide. Few (if any) of the statements in it are completely authoritative under all possible circumstances. This means you will need to use judgement in applying the guidelines in this document. If in I doubt at all, please do contact the I mailing list (details given below) where Tim Bunce and other driver authors can help. =head1 CREATING A NEW DRIVER The first rule for creating a new database driver for the Perl DBI is very simple: B There is usually a driver already available for the database you want to use, almost regardless of which database you choose. Very often, the database will provide an ODBC driver interface, so you can often use B to access the database. This is typically less convenient on a Unix box than on a Microsoft Windows box, but there are numerous options for ODBC driver managers on Unix too, and very often the ODBC driver is provided by the database supplier. Before deciding that you need to write a driver, do your homework to ensure that you are not wasting your energies. [As of December 2002, the consensus is that if you need an ODBC driver manager on Unix, then the unixODBC driver (available from L) is the way to go.] The second rule for creating a new database driver for the Perl DBI is also very simple: B Nevertheless, there are occasions when it is necessary to write a new driver, often to use a proprietary language or API to access the database more swiftly, or more comprehensively, than an ODBC driver can. Then you should read this document very carefully, but with a suitably sceptical eye. If there is something in here that does not make any sense, question it. You might be right that the information is bogus, but don't come to that conclusion too quickly. =head2 URLs and mailing lists The primary web-site for locating B software and information is http://dbi.perl.org/ There are two main and one auxiliary mailing lists for people working with B. The primary lists are I for general users of B and B drivers, and I mainly for B driver writers (don't join the I list unless you have a good reason). The auxiliary list is I for announcing new releases of B or B drivers. You can join these lists by accessing the web-site L. The lists are closed so you cannot send email to any of the lists unless you join the list first. You should also consider monitoring the I newsgroups, especially I. =head2 The Cheetah book The definitive book on Perl DBI is the Cheetah book, so called because of the picture on the cover. Its proper title is 'I' by Alligator Descartes and Tim Bunce, published by O'Reilly Associates, February 2000, ISBN 1-56592-699-4. Buy it now if you have not already done so, and read it. =head2 Locating drivers Before writing a new driver, it is in your interests to find out whether there already is a driver for your database. If there is such a driver, it would be much easier to make use of it than to write your own! The primary web-site for locating Perl software is L. You should look under the various modules listings for the software you are after. For example: http://search.cpan.org/modlist/Database_Interfaces Follow the B and B links at the top to see those subsets. See the B docs for information on B web sites and mailing lists. =head2 Registering a new driver Before going through any official registration process, you will need to establish that there is no driver already in the works. You'll do that by asking the B mailing lists whether there is such a driver available, or whether anybody is working on one. When you get the go ahead, you will need to establish the name of the driver and a prefix for the driver. Typically, the name is based on the name of the database software it uses, and the prefix is a contraction of that. Hence, B has the name I and the prefix 'I'. The prefix must be lowercase and contain no underscores other than the one at the end. This information will be recorded in the B module. Apart from documentation purposes, registration is a prerequisite for L. If you are writing a driver which will not be distributed on CPAN, then you should choose a prefix beginning with 'I', to avoid potential prefix collisions with drivers registered in the future. Thus, if you wrote a non-CPAN distributed driver called B, the prefix might be 'I'. This document assumes you are writing a driver called B, and that the prefix 'I' is assigned to the driver. =head2 Two styles of database driver There are two distinct styles of database driver that can be written to work with the Perl DBI. Your driver can be written in pure Perl, requiring no C compiler. When feasible, this is the best solution, but most databases are not written in such a way that this can be done. Some examples of pure Perl drivers are B and B. Alternatively, and most commonly, your driver will need to use some C code to gain access to the database. This will be classified as a C/XS driver. =head2 What code will you write? There are a number of files that need to be written for either a pure Perl driver or a C/XS driver. There are no extra files needed only by a pure Perl driver, but there are several extra files needed only by a C/XS driver. =head3 Files common to pure Perl and C/XS drivers Assuming that your driver is called B, these files are: =over 4 =item * F =item * F =item * F =item * F =item * F =item * F =item * F =item * F =back The first four files are mandatory. F is used to control how the driver is built and installed. The F file tells people who download the file about how to build the module and any prerequisite software that must be installed. The F file is used by the standard Perl module distribution mechanism. It lists all the source files that need to be distributed with your module. F is what is loaded by the B code; it contains the methods peculiar to your driver. Although the F file is not B you are advised to create one. Of particular importance are the I and I attributes which newer CPAN modules understand. You use these to tell the CPAN module (and CPANPLUS) that your build and configure mechanisms require DBI. The best reference for META.yml (at the time of writing) is L. You can find a reasonable example of a F in DBD::ODBC. The F file allows you to specify other Perl modules on which yours depends in a format that allows someone to type a simple command and ensure that all the pre-requisites are in place as well as building your driver. The F file contains (an updated version of) the information that was included - or that would have been included - in the appendices of the Cheetah book as a summary of the abilities of your driver and the associated database. The files in the F subdirectory are unit tests for your driver. You should write your tests as stringently as possible, while taking into account the diversity of installations that you can encounter: =over 4 =item * Your tests should not casually modify operational databases. =item * You should never damage existing tables in a database. =item * You should code your tests to use a constrained name space within the database. For example, the tables (and all other named objects) that are created could all begin with 'I'. =item * At the end of a test run, there should be no testing objects left behind in the database. =item * If you create any databases, you should remove them. =item * If your database supports temporary tables that are automatically removed at the end of a session, then exploit them as often as possible. =item * Try to make your tests independent of each other. If you have a test F that depends upon the successful running of F, people cannot run the single test case F. Further, running F twice in a row is likely to fail (at least, if F modifies the database at all) because the database at the start of the second run is not what you saw at the start of the first run. =item * Document in your F file what you do, and what privileges people need to do it. =item * You can, and probably should, sequence your tests by including a test number before an abbreviated version of the test name; the tests are run in the order in which the names are expanded by shell-style globbing. =item * It is in your interests to ensure that your tests work as widely as possible. =back Many drivers also install sub-modules B for any of a variety of different reasons, such as to support the metadata methods (see the discussion of L below). Such sub-modules are conventionally stored in the directory F. The module itself would usually be in a file F. All such sub-modules should themselves be version stamped (see the discussions far below). =head3 Extra files needed by C/XS drivers The software for a C/XS driver will typically contain at least four extra files that are not relevant to a pure Perl driver. =over 4 =item * F =item * F =item * F =item * F =back The F file is used to generate C code that Perl can call to gain access to the C functions you write that will, in turn, call down onto your database software. The F header is a stylized header that ensures you can access the necessary Perl and B macros, types, and function declarations. The F is used to specify which functions have been implemented by your driver. The F file is where you write the C code that does the real work of translating between Perl-ish data types and what the database expects to use and return. There are some (mainly small, but very important) differences between the contents of F and F for pure Perl and C/XS drivers, so those files are described both in the section on creating a pure Perl driver and in the section on creating a C/XS driver. Obviously, you can add extra source code files to the list. =head2 Requirements on a driver and driver writer To be remotely useful, your driver must be implemented in a format that allows it to be distributed via CPAN, the Comprehensive Perl Archive Network (L and L). Of course, it is easier if you do not have to meet this criterion, but you will not be able to ask for much help if you do not do so, and no-one is likely to want to install your module if they have to learn a new installation mechanism. =head1 CREATING A PURE PERL DRIVER Writing a pure Perl driver is surprisingly simple. However, there are some problems you should be aware of. The best option is of course picking up an existing driver and carefully modifying one method after the other. Also look carefully at B and B. As an example we take a look at the B driver, a driver for accessing plain files as tables, which is part of the B package. The minimal set of files we have to implement are F, F, F and F. =head2 Pure Perl version of Makefile.PL You typically start with writing F, a Makefile generator. The contents of this file are described in detail in the L man pages. It is definitely a good idea if you start reading them. At least you should know about the variables I, I, I, I, I, I, I, I, I, I, I, I, I, I, I, I from the L man page: these are used in almost any F. Additionally read the section on I and the descriptions of the I, I and I targets: They will definitely be useful for you. Of special importance for B drivers is the I method from the L man page. For Emacs users, I recommend the I method, which removes Emacs backup files (file names which end with a tilde '~') from lists of files. Now an example, I use the word C wherever you should insert your driver's name: # -*- perl -*- use ExtUtils::MakeMaker; WriteMakefile( dbd_edit_mm_attribs( { 'NAME' => 'DBD::Driver', 'VERSION_FROM' => 'Driver.pm', 'INC' => '', 'dist' => { 'SUFFIX' => '.gz', 'COMPRESS' => 'gzip -9f' }, 'realclean' => { FILES => '*.xsi' }, 'PREREQ_PM' => '1.03', 'CONFIGURE' => sub { eval {require DBI::DBD;}; if ($@) { warn $@; exit 0; } my $dbi_arch_dir = dbd_dbi_arch_dir(); if (exists($opts{INC})) { return {INC => "$opts{INC} -I$dbi_arch_dir"}; } else { return {INC => "-I$dbi_arch_dir"}; } } }, { create_pp_tests => 1}) ); package MY; sub postamble { return main::dbd_postamble(@_); } sub libscan { my ($self, $path) = @_; ($path =~ m/\~$/) ? undef : $path; } Note the calls to C and C. The second hash reference in the call to C (containing C) is optional; you should not use it unless your driver is a pure Perl driver (that is, it does not use C and XS code). Therefore, the call to C is not relevant for C/XS drivers and may be omitted; simply use the (single) hash reference containing NAME etc as the only argument to C. Note that the C code will fail if you do not have a F sub-directory containing at least one test case. I tells MakeMaker that DBI (version 1.03 in this case) is required for this module. This will issue a warning that DBI 1.03 is missing if someone attempts to install your DBD without DBI 1.03. See I below for why this does not work reliably in stopping cpan testers failing your module if DBI is not installed. I is a subroutine called by MakeMaker during C. By putting the C in this section we can attempt to load DBI::DBD but if it is missing we exit with success. As we exit successfully without creating a Makefile when DBI::DBD is missing cpan testers will not report a failure. This may seem at odds with I but I does not cause C to fail (unless you also specify PREREQ_FATAL which is strongly discouraged by MakeMaker) so C would continue to call C and fail. All drivers must use C or risk running into problems. Note the specification of I; the named file (F) will be scanned for the first line that looks like an assignment to I<$VERSION>, and the subsequent text will be used to determine the version number. Note the commentary in L on the subject of correctly formatted version numbers. If your driver depends upon external software (it usually will), you will need to add code to ensure that your environment is workable before the call to C. If you need to check for the existence of an external library and perhaps modify I to include the paths to where the external library header files are located and you cannot find the library or header files make sure you output a message saying they cannot be found but C (success) B calling C or CPAN testers will fail your module if the external library is not found. A full-fledged I can be quite large (for example, the files for B and B are both over 1000 lines long, and the Informix one uses - and creates - auxiliary modules too). See also L and L. Consider using L in place of I. =head2 README The L file should describe what the driver is for, the pre-requisites for the build process, the actual build process, how to report errors, and who to report them to. Users will find ways of breaking the driver build and test process which you would never even have dreamed to be possible in your worst nightmares. Therefore, you need to write this document defensively, precisely and concisely. As always, use the F from one of the established drivers as a basis for your own; the version in B is worth a look as it has been quite successful in heading off problems. =over 4 =item * Note that users will have versions of Perl and B that are both older and newer than you expected, but this will seldom cause much trouble. When it does, it will be because you are using features of B that are not supported in the version they are using. =item * Note that users will have versions of the database software that are both older and newer than you expected. You will save yourself time in the long run if you can identify the range of versions which have been tested and warn about versions which are not known to be OK. =item * Note that many people trying to install your driver will not be experts in the database software. =item * Note that many people trying to install your driver will not be experts in C or Perl. =back =head2 MANIFEST The F will be used by the Makefile's dist target to build the distribution tar file that is uploaded to CPAN. It should list every file that you want to include in your distribution, one per line. =head2 lib/Bundle/DBD/Driver.pm The CPAN module provides an extremely powerful bundle mechanism that allows you to specify pre-requisites for your driver. The primary pre-requisite is B; you may want or need to add some more. With the bundle set up correctly, the user can type: perl -MCPAN -e 'install Bundle::DBD::Driver' and Perl will download, compile, test and install all the Perl modules needed to build your driver. The prerequisite modules are listed in the C section, with the official name of the module followed by a dash and an informal name or description. =over 4 =item * Listing B as the main pre-requisite simplifies life. =item * Don't forget to list your driver. =item * Note that unless the DBMS is itself a Perl module, you cannot list it as a pre-requisite in this file. =item * You should keep the version of the bundle the same as the version of your driver. =item * You should add configuration management, copyright, and licensing information at the top. =back A suitable skeleton for this file is shown below. package Bundle::DBD::Driver; $VERSION = '0.01'; 1; __END__ =head1 NAME Bundle::DBD::Driver - A bundle to install all DBD::Driver related modules =head1 SYNOPSIS C =head1 CONTENTS Bundle::DBI - Bundle for DBI by TIMB (Tim Bunce) DBD::Driver - DBD::Driver by YOU (Your Name) =head1 DESCRIPTION This bundle includes all the modules used by the Perl Database Interface (DBI) driver for Driver (DBD::Driver), assuming the use of DBI version 1.13 or later, created by Tim Bunce. If you've not previously used the CPAN module to install any bundles, you will be interrogated during its setup phase. But when you've done it once, it remembers what you told it. You could start by running: C =head1 SEE ALSO Bundle::DBI =head1 AUTHOR Your Name EFE =head1 THANKS This bundle was created by ripping off Bundle::libnet created by Graham Barr EFE, and radically simplified with some information from Jochen Wiedmann EFE. The template was then included in the DBI::DBD documentation by Jonathan Leffler EFE. =cut =head2 lib/DBD/Driver/Summary.pm There is no substitute for taking the summary file from a driver that was documented in the Perl book (such as B or B or B, to name but three), and adapting it to describe the facilities available via B when accessing the Driver database. =head2 Pure Perl version of Driver.pm The F file defines the Perl module B for your driver. It will define a package B along with some version information, some variable definitions, and a function C which will have a more or less standard structure. It will also define three sub-packages of B: =over 4 =item DBD::Driver::dr with methods C, C and C; =item DBD::Driver::db with methods such as C; =item DBD::Driver::st with methods such as C and C. =back The F file will also contain the documentation specific to B in the format used by perldoc. In a pure Perl driver, the F file is the core of the implementation. You will need to provide all the key methods needed by B. Now let's take a closer look at an excerpt of F as an example. We ignore things that are common to any module (even non-DBI modules) or really specific to the B package. =head3 The DBD::Driver package =head4 The header package DBD::File; use strict; our $VERSION = "1.23.00" # Version number of DBD::File This is where the version number of your driver is specified, and is where F looks for this information. Please ensure that any other modules added with your driver are also version stamped so that CPAN does not get confused. It is recommended that you use a two-part (1.23) or three-part (1.23.45) version number. Also consider the CPAN system, which gets confused and considers version 1.10 to precede version 1.9, so that using a raw CVS, RCS or SCCS version number is probably not appropriate (despite being very common). For Subversion you could use: our $VERSION = "12.012346"; (use lots of leading zeros on the second portion so if you move the code to a shared repository like svn.perl.org the much larger revision numbers won't cause a problem, at least not for a few years). For RCS or CVS you can use: our $VERSION = "11.22"; which pads out the fractional part with leading zeros so all is well (so long as you don't go past x.99) our $drh = undef; # holds driver handle once initialized This is where the driver handle will be stored, once created. Note that you may assume there is only one handle for your driver. =head4 The driver constructor The C method is the driver handle constructor. Note that the C method is in the B package, not in one of the sub-packages B, B, or B. sub driver { return $drh if $drh; # already created - return same one my ($class, $attr) = @_; $class .= "::dr"; DBD::Driver::db->install_method('drv_example_dbh_method'); DBD::Driver::st->install_method('drv_example_sth_method'); # not a 'my' since we use it above to prevent multiple drivers $drh = DBI::_new_drh($class, { 'Name' => 'File', 'Version' => $VERSION, 'Attribution' => 'DBD::File by Jochen Wiedmann', }) or return undef; return $drh; } This is a reasonable example of how B implements its handles. There are three kinds: B (typically stored in I<$drh>; from now on called I or I<$drh>), B (from now on called I or I<$dbh>) and B (from now on called I or I<$sth>). The prototype of C is $drh = DBI::_new_drh($class, $public_attrs, $private_attrs); with the following arguments: =over 4 =item I<$class> is typically the class for your driver, (for example, "DBD::File::dr"), passed as the first argument to the C method. =item I<$public_attrs> is a hash ref to attributes like I, I, and I. These are processed and used by B. You had better not make any assumptions about them nor should you add private attributes here. =item I<$private_attrs> This is another (optional) hash ref with your private attributes. B will store them and otherwise leave them alone. =back The C method and the C method both return C for failure (in which case you must look at I<$DBI::err> and I<$DBI::errstr> for the failure information, because you have no driver handle to use). =head4 Using install_method() to expose driver-private methods DBD::Foo::db->install_method($method_name, \%attr); Installs the driver-private method named by $method_name into the DBI method dispatcher so it can be called directly, avoiding the need to use the func() method. It is called as a static method on the driver class to which the method belongs. The method name must begin with the corresponding registered driver-private prefix. For example, for DBD::Oracle $method_name must being with 'C', and for DBD::AnyData it must begin with 'C'. The C<\%attr> attributes can be used to provide fine control over how the DBI dispatcher handles the dispatching of the method. However it's undocumented at the moment. See the IMA_* #define's in DBI.xs and the O=>0x000x values in the initialization of %DBI::DBI_methods in DBI.pm. (Volunteers to polish up and document the interface are very welcome to get in touch via dbi-dev@perl.org). Methods installed using install_method default to the standard error handling behaviour for DBI methods: clearing err and errstr before calling the method, and checking for errors to trigger RaiseError etc. on return. This differs from the default behaviour of func(). Note for driver authors: The DBD::Foo::xx->install_method call won't work until the class-hierarchy has been setup. Normally the DBI looks after that just after the driver is loaded. This means install_method() can't be called at the time the driver is loaded unless the class-hierarchy is set up first. The way to do that is to call the setup_driver() method: DBI->setup_driver('DBD::Foo'); before using install_method(). =head4 The CLONE special subroutine Also needed here, in the B package, is a C method that will be called by perl when an interpreter is cloned. All your C method needs to do, currently, is clear the cached I<$drh> so the new interpreter won't start using the cached I<$drh> from the old interpreter: sub CLONE { undef $drh; } See L for details. =head3 The DBD::Driver::dr package The next lines of code look as follows: package DBD::Driver::dr; # ====== DRIVER ====== $DBD::Driver::dr::imp_data_size = 0; Note that no I<@ISA> is needed here, or for the other B classes, because the B takes care of that for you when the driver is loaded. *FIX ME* Explain what the imp_data_size is, so that implementors aren't practicing cargo-cult programming. =head4 The database handle constructor The database handle constructor is the driver's (hence the changed namespace) C method: sub connect { my ($drh, $dr_dsn, $user, $auth, $attr) = @_; # Some database specific verifications, default settings # and the like can go here. This should only include # syntax checks or similar stuff where it's legal to # 'die' in case of errors. # For example, many database packages requires specific # environment variables to be set; this could be where you # validate that they are set, or default them if they are not set. my $driver_prefix = "drv_"; # the assigned prefix for this driver # Process attributes from the DSN; we assume ODBC syntax # here, that is, the DSN looks like var1=val1;...;varN=valN foreach my $var ( split /;/, $dr_dsn ) { my ($attr_name, $attr_value) = split '=', $var, 2; return $drh->set_err($DBI::stderr, "Can't parse DSN part '$var'") unless defined $attr_value; # add driver prefix to attribute name if it doesn't have it already $attr_name = $driver_prefix.$attr_name unless $attr_name =~ /^$driver_prefix/o; # Store attribute into %$attr, replacing any existing value. # The DBI will STORE() these into $dbh after we've connected $attr->{$attr_name} = $attr_value; } # Get the attributes we'll use to connect. # We use delete here because these no need to STORE them my $db = delete $attr->{drv_database} || delete $attr->{drv_db} or return $drh->set_err($DBI::stderr, "No database name given in DSN '$dr_dsn'"); my $host = delete $attr->{drv_host} || 'localhost'; my $port = delete $attr->{drv_port} || 123456; # Assume you can attach to your database via drv_connect: my $connection = drv_connect($db, $host, $port, $user, $auth) or return $drh->set_err($DBI::stderr, "Can't connect to $dr_dsn: ..."); # create a 'blank' dbh (call superclass constructor) my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dr_dsn }); $dbh->STORE('Active', 1 ); $dbh->{drv_connection} = $connection; return $outer; } This is mostly the same as in the I above. The arguments are described in L. The constructor C is called, returning a database handle. The constructor's prototype is: ($outer, $inner) = DBI::_new_dbh($drh, $public_attr, $private_attr); with similar arguments to those in the I, except that the I<$class> is replaced by I<$drh>. The I attribute is a standard B attribute (see L). In scalar context, only the outer handle is returned. Note the use of the C method for setting the I attributes. That's because within the driver code, the handle object you have is the 'inner' handle of a tied hash, not the outer handle that the users of your driver have. Because you have the inner handle, tie magic doesn't get invoked when you get or set values in the hash. This is often very handy for speed when you want to get or set simple non-special driver-specific attributes. However, some attribute values, such as those handled by the B like I, don't actually exist in the hash and must be read via C<$h-EFETCH($attrib)> and set via C<$h-ESTORE($attrib, $value)>. If in any doubt, use these methods. =head4 The data_sources() method The C method must populate and return a list of valid data sources, prefixed with the "I" incantation that allows them to be used in the first argument of the Cconnect()> method. An example of this might be scanning the F<$HOME/.odbcini> file on Unix for ODBC data sources (DSNs). As a trivial example, consider a fixed list of data sources: sub data_sources { my($drh, $attr) = @_; my(@list) = (); # You need more sophisticated code than this to set @list... push @list, "dbi:Driver:abc"; push @list, "dbi:Driver:def"; push @list, "dbi:Driver:ghi"; # End of code to set @list return @list; } =head4 The disconnect_all() method If you need to release any resources when the driver is unloaded, you can provide a disconnect_all method. =head4 Other driver handle methods If you need any other driver handle methods, they can follow here. =head4 Error handling It is quite likely that something fails in the connect method. With B for example, you might catch an error when setting the current directory to something not existent by using the (driver-specific) I attribute. To report an error, you use the C method: $h->set_err($err, $errmsg, $state); This will ensure that the error is recorded correctly and that I and I etc are handled correctly. Typically you'll always use the method instance, aka your method's first argument. As C always returns C your error handling code can usually be simplified to something like this: return $h->set_err($err, $errmsg, $state) if ...; =head3 The DBD::Driver::db package package DBD::Driver::db; # ====== DATABASE ====== $DBD::Driver::db::imp_data_size = 0; =head4 The statement handle constructor There's nothing much new in the statement handle constructor, which is the C method: sub prepare { my ($dbh, $statement, @attribs) = @_; # create a 'blank' sth my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement }); $sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//)); $sth->{drv_params} = []; return $outer; } This is still the same -- check the arguments and call the super class constructor C. Again, in scalar context, only the outer handle is returned. The I attribute should be cached as shown. Note the prefix I in the attribute names: it is required that all your private attributes use a lowercase prefix unique to your driver. As mentioned earlier in this document, the B contains a registry of known driver prefixes and may one day warn about unknown attributes that don't have a registered prefix. Note that we parse the statement here in order to set the attribute I. The technique illustrated is not very reliable; it can be confused by question marks appearing in quoted strings, delimited identifiers or in SQL comments that are part of the SQL statement. We could set I in the C method instead because the B specification explicitly allows a driver to defer this, but then the user could not call C. =head4 Transaction handling Pure Perl drivers will rarely support transactions. Thus your C and C methods will typically be quite simple: sub commit { my ($dbh) = @_; if ($dbh->FETCH('Warn')) { warn("Commit ineffective while AutoCommit is on"); } 0; } sub rollback { my ($dbh) = @_; if ($dbh->FETCH('Warn')) { warn("Rollback ineffective while AutoCommit is on"); } 0; } Or even simpler, just use the default methods provided by the B that do nothing except return C. The B's default C method can be used by inheritance. =head4 The STORE() and FETCH() methods These methods (that we have already used, see above) are called for you, whenever the user does a: $dbh->{$attr} = $val; or, respectively, $val = $dbh->{$attr}; See L for details on tied hash refs to understand why these methods are required. The B will handle most attributes for you, in particular attributes like I or I. All you have to do is handle your driver's private attributes and any attributes, like I and I, that the B can't handle for you. A good example might look like this: sub STORE { my ($dbh, $attr, $val) = @_; if ($attr eq 'AutoCommit') { # AutoCommit is currently the only standard attribute we have # to consider. if (!$val) { die "Can't disable AutoCommit"; } return 1; } if ($attr =~ m/^drv_/) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. # Ideally we should warn about unknown attributes. $dbh->{$attr} = $val; # Yes, we are allowed to do this, return 1; # but only for our private attributes } # Else pass up to DBI to handle for us $dbh->SUPER::STORE($attr, $val); } sub FETCH { my ($dbh, $attr) = @_; if ($attr eq 'AutoCommit') { return 1; } if ($attr =~ m/^drv_/) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. return $dbh->{$attr}; # Yes, we are allowed to do this, # but only for our private attributes } # Else pass up to DBI to handle $dbh->SUPER::FETCH($attr); } The B will actually store and fetch driver-specific attributes (with all lowercase names) without warning or error, so there's actually no need to implement driver-specific any code in your C and C methods unless you need extra logic/checks, beyond getting or setting the value. Unless your driver documentation indicates otherwise, the return value of the C method is unspecified and the caller shouldn't use that value. =head4 Other database handle methods As with the driver package, other database handle methods may follow here. In particular you should consider a (possibly empty) C method and possibly a C method if B's default isn't correct for you. You may also need the C and C methods, as described elsewhere in this document. Where reasonable use C<$h-ESUPER::foo()> to call the B's method in some or all cases and just wrap your custom behavior around that. If you want to use private trace flags you'll probably want to be able to set them by name. To do that you'll need to define a C method (note that's "parse_trace_flag", singular, not "parse_trace_flags", plural). sub parse_trace_flag { my ($h, $name) = @_; return 0x01000000 if $name eq 'foo'; return 0x02000000 if $name eq 'bar'; return 0x04000000 if $name eq 'baz'; return 0x08000000 if $name eq 'boo'; return 0x10000000 if $name eq 'bop'; return $h->SUPER::parse_trace_flag($name); } All private flag names must be lowercase, and all private flags must be in the top 8 of the 32 bits. =head3 The DBD::Driver::st package This package follows the same pattern the others do: package DBD::Driver::st; $DBD::Driver::st::imp_data_size = 0; =head4 The execute() and bind_param() methods This is perhaps the most difficult method because we have to consider parameter bindings here. In addition to that, there are a number of statement attributes which must be set for inherited B methods to function correctly (see L below). We present a simplified implementation by using the I attribute from above: sub bind_param { my ($sth, $pNum, $val, $attr) = @_; my $type = (ref $attr) ? $attr->{TYPE} : $attr; if ($type) { my $dbh = $sth->{Database}; $val = $dbh->quote($sth, $type); } my $params = $sth->{drv_params}; $params->[$pNum-1] = $val; 1; } sub execute { my ($sth, @bind_values) = @_; # start of by finishing any previous execution if still active $sth->finish if $sth->FETCH('Active'); my $params = (@bind_values) ? \@bind_values : $sth->{drv_params}; my $numParam = $sth->FETCH('NUM_OF_PARAMS'); return $sth->set_err($DBI::stderr, "Wrong number of parameters") if @$params != $numParam; my $statement = $sth->{'Statement'}; for (my $i = 0; $i < $numParam; $i++) { $statement =~ s/?/$params->[$i]/; # XXX doesn't deal with quoting etc! } # Do anything ... we assume that an array ref of rows is # created and store it: $sth->{'drv_data'} = $data; $sth->{'drv_rows'} = @$data; # number of rows $sth->STORE('NUM_OF_FIELDS') = $numFields; $sth->{Active} = 1; @$data || '0E0'; } There are a number of things you should note here. We initialize the I and I attributes here, because they are essential for C to work. We use attribute C<$sth-E{Statement}> which we created within C. The attribute C<$sth-E{Database}>, which is nothing else than the I, was automatically created by B. Finally, note that (as specified in the B specification) we return the string C<'0E0'> instead of the number 0, so that the result tests true but equal to zero. $sth->execute() or die $sth->errstr; =head4 The execute_array(), execute_for_fetch() and bind_param_array() methods In general, DBD's only need to implement C and C. DBI's default C will invoke the DBD's C as needed. The following sequence describes the interaction between DBI C and a DBD's C: =over =item 1 App calls C<$sth-Eexecute_array(\%attrs, @array_of_arrays)> =item 2 If C<@array_of_arrays> was specified, DBI processes C<@array_of_arrays> by calling DBD's C. Alternately, App may have directly called C =item 3 DBD validates and binds each array =item 4 DBI retrieves the validated param arrays from DBD's ParamArray attribute =item 5 DBI calls DBD's C, where C<&$fetch_tuple_sub> is a closure to iterate over the returned ParamArray values, and C<\@tuple_status> is an array to receive the disposition status of each tuple. =item 6 DBD iteratively calls C<&$fetch_tuple_sub> to retrieve parameter tuples to be added to its bulk database operation/request. =item 7 when DBD reaches the limit of tuples it can handle in a single database operation/request, or the C<&$fetch_tuple_sub> indicates no more tuples by returning undef, the DBD executes the bulk operation, and reports the disposition of each tuple in \@tuple_status. =item 8 DBD repeats steps 6 and 7 until all tuples are processed. =back E.g., here's the essence of L's execute_for_fetch: while (1) { my @tuple_batch; for (my $i = 0; $i < $batch_size; $i++) { push @tuple_batch, [ @{$fetch_tuple_sub->() || last} ]; } last unless @tuple_batch; my $res = ora_execute_array($sth, \@tuple_batch, scalar(@tuple_batch), $tuple_batch_status); push @$tuple_status, @$tuple_batch_status; } Note that DBI's default execute_array()/execute_for_fetch() implementation requires the use of positional (i.e., '?') placeholders. Drivers which B named placeholders must either emulate positional placeholders (e.g., see L), or must implement their own execute_array()/execute_for_fetch() methods to properly sequence bound parameter arrays. =head4 Fetching data Only one method needs to be written for fetching data, C. The other methods, C, C, etc, as well as the database handle's C methods are part of B, and call C as necessary. sub fetchrow_arrayref { my ($sth) = @_; my $data = $sth->{drv_data}; my $row = shift @$data; if (!$row) { $sth->STORE(Active => 0); # mark as no longer active return undef; } if ($sth->FETCH('ChopBlanks')) { map { $_ =~ s/\s+$//; } @$row; } return $sth->_set_fbav($row); } *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref Note the use of the method C<_set_fbav()> -- this is required so that C and C work. If an error occurs which leaves the I<$sth> in a state where remaining rows can't be fetched then I should be turned off before the method returns. The C method for this driver can be implemented like this: sub rows { shift->{drv_rows} } because it knows in advance how many rows it has fetched. Alternatively you could delete that method and so fallback to the B's own method which does the right thing based on the number of calls to C<_set_fbav()>. =head4 The more_results method If your driver doesn't support multiple result sets, then don't even implement this method. Otherwise, this method needs to get the statement handle ready to fetch results from the next result set, if there is one. Typically you'd start with: $sth->finish; then you should delete all the attributes from the attribute cache that may no longer be relevant for the new result set: delete $sth->{$_} for qw(NAME TYPE PRECISION SCALE ...); for drivers written in C use: 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); Don't forget to also delete, or update, any driver-private attributes that may not be correct for the next resultset. The NUM_OF_FIELDS attribute is a special case. It should be set using STORE: $sth->STORE(NUM_OF_FIELDS => 0); /* for DBI <= 1.53 */ $sth->STORE(NUM_OF_FIELDS => $new_value); for drivers written in C use this incantation: /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */ DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */ DBIc_STATE(imp_xxh)->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS",13)), 0, sv_2mortal(newSViv(mysql_num_fields(imp_sth->result))) ); For DBI versions prior to 1.54 you'll also need to explicitly adjust the number of elements in the row buffer array (C) to match the new result set. Fill any new values with newSV(0) not &sv_undef. Alternatively you could free DBIc_FIELDS_AV(imp_sth) and set it to null, but that would mean bind_columns() wouldn't work across result sets. =head4 Statement attributes The main difference between I and I attributes is, that you should implement a lot of attributes here that are required by the B, such as I, I, I, etc. See L for a complete list. Pay attention to attributes which are marked as read only, such as I. These attributes can only be set the first time a statement is executed. If a statement is prepared, then executed multiple times, warnings may be generated. You can protect against these warnings, and prevent the recalculation of attributes which might be expensive to calculate (such as the I and I attributes): my $storedNumParams = $sth->FETCH('NUM_OF_PARAMS'); if (!defined $storedNumParams or $storedNumFields < 0) { $sth->STORE('NUM_OF_PARAMS') = $numParams; # Set other useful attributes that only need to be set once # for a statement, like $sth->{NAME} and $sth->{TYPE} } One particularly important attribute to set correctly (mentioned in L is I. Many B methods, including C, depend on this attribute. Besides that the C and C methods are mainly the same as above for I's. =head4 Other statement methods A trivial C method to discard stored data, reset any attributes (such as I) and do C<$sth-ESUPER::finish()>. If you've defined a C method in B<::db> you'll also want it in B<::st>, so just alias it in: *parse_trace_flag = \&DBD::foo:db::parse_trace_flag; And perhaps some other methods that are not part of the B specification, in particular to make metadata available. Remember that they must have names that begin with your drivers registered prefix so they can be installed using C. If C is called on a statement handle that's still active (C<$sth-E{Active}> is true) then it should effectively call C. sub DESTROY { my $sth = shift; $sth->finish if $sth->FETCH('Active'); } =head2 Tests The test process should conform as closely as possibly to the Perl standard test harness. In particular, most (all) of the tests should be run in the F sub-directory, and should simply produce an C when run under C. For details on how this is done, see the Camel book and the section in Chapter 7, "The Standard Perl Library" on L. The tests may need to adapt to the type of database which is being used for testing, and to the privileges of the user testing the driver. For example, the B test code has to adapt in a number of places to the type of database to which it is connected as different Informix databases have different capabilities: some of the tests are for databases without transaction logs; others are for databases with a transaction log; some versions of the server have support for blobs, or stored procedures, or user-defined data types, and others do not. When a complete file of tests must be skipped, you can provide a reason in a pseudo-comment: if ($no_transactions_available) { print "1..0 # Skip: No transactions available\n"; exit 0; } Consider downloading the B code and look at the code in F which is used throughout the B tests in the F sub-directory. =head1 CREATING A C/XS DRIVER Please also see the section under L regarding the creation of the F. Creating a new C/XS driver from scratch will always be a daunting task. You can and should greatly simplify your task by taking a good reference driver implementation and modifying that to match the database product for which you are writing a driver. The de facto reference driver has been the one for B written by Tim Bunce, who is also the author of the B package. The B module is a good example of a driver implemented around a C-level API. Nowadays it it seems better to base on B, another driver maintained by Tim and Jeff Urlwin, because it offers a lot of metadata and seems to become the guideline for the future development. (Also as B digs deeper into the Oracle 8 OCI interface it'll get even more hairy than it is now.) The B driver is one driver implemented using embedded SQL instead of a function-based API. B may also be worth a look. =head2 C/XS version of Driver.pm A lot of the code in the F file is very similar to the code for pure Perl modules - see above. However, there are also some subtle (and not so subtle) differences, including: =over 8 =item * The variables I<$DBD::Driver::{dr|db|st}::imp_data_size> are not defined here, but in the XS code, because they declare the size of certain C structures. =item * Some methods are typically moved to the XS code, in particular C, C, C, C and the C and C methods. =item * Other methods are still part of F, but have callbacks to the XS code. =item * If the driver-specific parts of the I structure need to be formally initialized (which does not seem to be a common requirement), then you need to add a call to an appropriate XS function in the driver method of C, and you define the corresponding function in F, and you define the C code in F and the prototype in F. For example, B has such a requirement, and adds the following call after the call to C<_new_drh()> in F: DBD::Informix::dr::driver_init($drh); and the following code in F: # Initialize the DBD::Informix driver data structure void driver_init(drh) SV *drh CODE: ST(0) = dbd_ix_dr_driver_init(drh) ? &sv_yes : &sv_no; and the code in F declares: extern int dbd_ix_dr_driver_init(SV *drh); and the code in F (equivalent to F) defines: /* Formally initialize the DBD::Informix driver structure */ int dbd_ix_dr_driver(SV *drh) { D_imp_drh(drh); imp_drh->n_connections = 0; /* No active connections */ imp_drh->current_connection = 0; /* No current connection */ imp_drh->multipleconnections = (ESQLC_VERSION >= 600) ? True : False; dbd_ix_link_newhead(&imp_drh->head); /* Empty linked list of connections */ return 1; } B has a similar requirement but gets around it by checking whether the private data part of the driver handle is all zeroed out, rather than add extra functions. =back Now let's take a closer look at an excerpt from F (revised heavily to remove idiosyncrasies) as an example, ignoring things that were already discussed for pure Perl drivers. =head3 The connect method The connect method is the database handle constructor. You could write either of two versions of this method: either one which takes connection attributes (new code) and one which ignores them (old code only). If you ignore the connection attributes, then you omit all mention of the I<$auth> variable (which is a reference to a hash of attributes), and the XS system manages the differences for you. sub connect { my ($drh, $dbname, $user, $auth, $attr) = @_; # Some database specific verifications, default settings # and the like following here. This should only include # syntax checks or similar stuff where it's legal to # 'die' in case of errors. my $dbh = DBI::_new_dbh($drh, { 'Name' => $dbname, }) or return undef; # Call the driver-specific function _login in Driver.xs file which # calls the DBMS-specific function(s) to connect to the database, # and populate internal handle data. DBD::Driver::db::_login($dbh, $dbname, $user, $auth, $attr) or return undef; $dbh; } This is mostly the same as in the pure Perl case, the exception being the use of the private C<_login()> callback, which is the function that will really connect to the database. It is implemented in F (you should not implement it) and calls C or C from F. See below for details. If your driver has driver-specific attributes which may be passed in the connect method and hence end up in C<$attr> in C then it is best to delete any you process so DBI does not send them again via STORE after connect. You can do this in C like this: DBD_ATTRIB_DELETE(attr, "my_attribute_name", strlen("my_attribute_name")); However, prior to DBI subversion version 11605 (and fixed post 1.607) DBD_ATTRIB_DELETE segfaulted so if you cannot guarantee the DBI version will be post 1.607 you need to use: hv_delete((HV*)SvRV(attr), "my_attribute_name", strlen("my_attribute_name"), G_DISCARD); *FIX ME* Discuss removing attributes in Perl code. =head3 The disconnect_all method *FIX ME* T.B.S =head3 The data_sources method If your C method can be implemented in pure Perl, then do so because it is easier than doing it in XS code (see the section above for pure Perl drivers). If your C method must call onto compiled functions, then you will need to define I in your F file, which will trigger F (in B v1.33 or greater) to generate the XS code that calls your actual C function (see the discussion below for details) and you do not code anything in F to handle it. =head3 The prepare method The prepare method is the statement handle constructor, and most of it is not new. Like the C method, it now has a C callback: package DBD::Driver::db; # ====== DATABASE ====== use strict; sub prepare { my ($dbh, $statement, $attribs) = @_; # create a 'blank' sth my $sth = DBI::_new_sth($dbh, { 'Statement' => $statement, }) or return undef; # Call the driver-specific function _prepare in Driver.xs file # which calls the DBMS-specific function(s) to prepare a statement # and populate internal handle data. DBD::Driver::st::_prepare($sth, $statement, $attribs) or return undef; $sth; } =head3 The execute method *FIX ME* T.B.S =head3 The fetchrow_arrayref method *FIX ME* T.B.S =head3 Other methods? *FIX ME* T.B.S =head2 Driver.xs F should look something like this: #include "Driver.h" DBISTATE_DECLARE; INCLUDE: Driver.xsi MODULE = DBD::Driver PACKAGE = DBD::Driver::dr /* Non-standard drh XS methods following here, if any. */ /* If none (the usual case), omit the MODULE line above too. */ MODULE = DBD::Driver PACKAGE = DBD::Driver::db /* Non-standard dbh XS methods following here, if any. */ /* Currently this includes things like _list_tables from */ /* DBD::mSQL and DBD::mysql. */ MODULE = DBD::Driver PACKAGE = DBD::Driver::st /* Non-standard sth XS methods following here, if any. */ /* In particular this includes things like _list_fields from */ /* DBD::mSQL and DBD::mysql for accessing metadata. */ Note especially the include of F here: B inserts stub functions for almost all private methods here which will typically do much work for you. Wherever you really have to implement something, it will call a private function in F, and this is what you have to implement. You need to set up an extra routine if your driver needs to export constants of its own, analogous to the SQL types available when you say: use DBI qw(:sql_types); *FIX ME* T.B.S =head2 Driver.h F is very simple and the operational contents should look like this: #ifndef DRIVER_H_INCLUDED #define DRIVER_H_INCLUDED #define NEED_DBIXS_VERSION 93 /* 93 for DBI versions 1.00 to 1.51+ */ #define PERL_NO_GET_CONTEXT /* if used require DBI 1.51+ */ #include /* installed by the DBI module */ #include "dbdimp.h" #include "dbivport.h" /* see below */ #include /* installed by the DBI module */ #endif /* DRIVER_H_INCLUDED */ The F header defines most of the interesting information that the writer of a driver needs. The file F header provides prototype declarations for the C functions that you might decide to implement. Note that you should normally only define one of C, C or C unless you are intent on supporting really old versions of B (prior to B 1.06) as well as modern versions. The only standard, B-mandated functions that you need write are those specified in the F header. You might also add extra driver-specific functions in F. The F file should be I from the latest B release into your distribution each time you modify your driver. Its job is to allow you to enhance your code to work with the latest B API while still allowing your driver to be compiled and used with older versions of the B (for example, when the C macro was added to B 1.41, an emulation of it was added to F). This makes users happy and your life easier. Always read the notes in F to check for any limitations in the emulation that you should be aware of. With B v1.51 or better I recommend that the driver defines I before F is included. This can significantly improve efficiency when running under a thread enabled perl. (Remember that the standard perl in most Linux distributions is built with threads enabled. So is ActiveState perl for Windows, and perl built for Apache mod_perl2.) If you do this there are some things to keep in mind: =over 4 =item * If I is defined, then every function that calls the Perl API will need to start out with a C declaration. =item * You'll know which functions need this, because the C compiler will complain that the undeclared identifier C is used if I the perl you are using to develop and test your driver has threads enabled. =item * If you don't remember to test with a thread-enabled perl before making a release it's likely that you'll get failure reports from users who are. =item * For driver private functions it is possible to gain even more efficiency by replacing C with C prepended to the parameter list and then C prepended to the argument list where the function is called. =back See L for additional information about I. =head2 Implementation header dbdimp.h This header file has two jobs: First it defines data structures for your private part of the handles. Note that the DBI provides many common fields for you. For example the statement handle (imp_sth) already has a row_count field with an IV type that accessed via the DBIc_ROW_COUNT(imp_sth) macro. Using this is strongly recommended as it's built in to some DBI internals so the DBI can 'just work' in more cases and you'll have less driver-specific code to write. Study DBIXS.h to see what's included with each type of handle. Second it defines macros that rename the generic names like C to database specific names like C. This avoids name clashes and enables use of different drivers when you work with a statically linked perl. It also will have the important task of disabling XS methods that you don't want to implement. Finally, the macros will also be used to select alternate implementations of some functions. For example, the C function is not passed the attribute hash. Since B v1.06, if a C macro is defined (for a function with 6 arguments), it will be used instead with the attribute hash passed as the sixth argument. Since B post v1.607, if a C macro is defined (for a function like dbd_db_login6 but with scalar pointers for the dbname, username and password), it will be used instead. This will allow your login6 function to see if there are any Unicode characters in the dbname. Similarly defining dbd_db_do4_iv is preferred over dbd_db_do4, dbd_st_rows_iv over dbd_st_rows, and dbd_st_execute_iv over dbd_st_execute. The *_iv forms are declared to return the IV type instead of an int. People used to just pick Oracle's F and use the same names, structures and types. I strongly recommend against that. At first glance this saves time, but your implementation will be less readable. It was just hell when I had to separate B specific parts, Oracle specific parts, mSQL specific parts and mysql specific parts in B's I and I. (B was a port of B which was based on B.) [Seconded, based on the experience taking B apart, even though the version inherited in 1996 was only based on B.] This part of the driver is I. Rewrite it from scratch, so it will be clean and short: in other words, a better piece of code. (Of course keep an eye on other people's work.) struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ /* Insert your driver handle attributes here */ }; struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ /* Insert your database handle attributes here */ }; struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ /* Insert your statement handle attributes here */ }; /* Rename functions for avoiding name clashes; prototypes are */ /* in dbd_xsh.h */ #define dbd_init drv_dr_init #define dbd_db_login6_sv drv_db_login_sv #define dbd_db_do drv_db_do ... many more here ... These structures implement your private part of the handles. You I to use the name C and the first field I be of type I and I be called C. You should never access these fields directly, except by using the I macros below. =head2 Implementation source dbdimp.c Conventionally, F is the main implementation file (but B calls the file F). This section includes a short note on each function that is used in the F template and thus I to be implemented. Of course, you will probably also need to implement other support functions, which should usually be file static if they are placed in F. If they are placed in other files, you need to list those files in F (and F) to handle them correctly. It is wise to adhere to a namespace convention for your functions to avoid conflicts. For example, for a driver with prefix I, you might call externally visible functions I. You should also avoid non-constant global variables as much as possible to improve the support for threading. Since Perl requires support for function prototypes (ANSI or ISO or Standard C), you should write your code using function prototypes too. It is possible to use either the unmapped names such as C or the mapped names such as C in the F file. B uses the mapped names which makes it easier to identify where to look for linkage problems at runtime (which will report errors using the mapped names). Most other drivers, and in particular B, use the unmapped names in the source code which makes it a little easier to compare code between drivers and eases discussions on the I mailing list. The majority of the code fragments here will use the unmapped names. Ultimately, you should provide implementations for most of the functions listed in the F header. The exceptions are optional functions (such as C) and those functions with alternative signatures, such as C, C and I. Then you should only implement one of the alternatives, and generally the newer one of the alternatives. =head3 The dbd_init method #include "Driver.h" DBISTATE_DECLARE; void dbd_init(dbistate_t* dbistate) { DBISTATE_INIT; /* Initialize the DBI macros */ } The C function will be called when your driver is first loaded; the bootstrap command in C triggers this, and the call is generated in the I section of F. These statements are needed to allow your driver to use the B macros. They will include your private header file F in turn. Note that I requires the name of the argument to C to be called C. =head3 The dbd_drv_error method You need a function to record errors so B can access them properly. You can call it whatever you like, but we'll call it C here. The argument list depends on your database software; different systems provide different ways to get at error information. static void dbd_drv_error(SV *h, int rc, const char *what) { Note that I is a generic handle, may it be a driver handle, a database or a statement handle. D_imp_xxh(h); This macro will declare and initialize a variable I with a pointer to your private handle pointer. You may cast this to to I, I or I. To record the error correctly, equivalent to the C method, use one of the C or C macros, which were added in B 1.41: DBIh_SET_ERR_SV(h, imp_xxh, err, errstr, state, method); DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method); For C the I, I, I, and I parameters are C (use &sv_undef instead of NULL). For C the I, I, I, I parameters are C. The I parameter is an C that's used instead of I if I is C. The I parameter can be ignored. The C macro is usually the simplest to use when you just have an integer error code and an error message string: DBIh_SET_ERR_CHAR(h, imp_xxh, Nullch, rc, what, Nullch, Nullch); As you can see, any parameters that aren't relevant to you can be C. To make drivers compatible with B < 1.41 you should be using F as described in L above. The (obsolete) macros such as C should be removed from drivers. The names C and C, which were used in previous versions of this document, should be replaced with the C macro. The name C, which was also used in previous versions of this document, should be replaced by C. Your code should not call the C Cstdio.hE> I/O functions; you should use C as shown: if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar %s: %s\n", foo, neatsvpv(errstr,0)); That's the first time we see how tracing works within a B driver. Make use of this as often as you can, but don't output anything at a trace level less than 3. Levels 1 and 2 are reserved for the B. You can define up to 8 private trace flags using the top 8 bits of C, that is: C<0xFF000000>. See the C method elsewhere in this document. =head3 The dbd_dr_data_sources method This method is optional; the support for it was added in B v1.33. As noted in the discussion of F, if the data sources can be determined by pure Perl code, do it that way. If, as in B, the information is obtained by a C function call, then you need to define a function that matches the prototype: extern AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs); An outline implementation for B follows, assuming that the C function call shown will return up to 100 databases names, with the pointers to each name in the array dbsname and the name strings themselves being stores in dbsarea. AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attr) { int ndbs; int i; char *dbsname[100]; char dbsarea[10000]; AV *av = Nullav; if (sqgetdbs(&ndbs, dbsname, 100, dbsarea, sizeof(dbsarea)) == 0) { av = NewAV(); av_extend(av, (I32)ndbs); sv_2mortal((SV *)av); for (i = 0; i < ndbs; i++) av_store(av, i, newSVpvf("dbi:Informix:%s", dbsname[i])); } return(av); } The actual B implementation has a number of extra lines of code, logs function entry and exit, reports the error from C, and uses C<#define>'d constants for the array sizes. =head3 The dbd_db_login6 method int dbd_db_login6_sv(SV* dbh, imp_dbh_t* imp_dbh, SV* dbname, SV* user, SV* auth, SV *attr); or int dbd_db_login6(SV* dbh, imp_dbh_t* imp_dbh, char* dbname, char* user, char* auth, SV *attr); This function will really connect to the database. The argument I is the database handle. I is the pointer to the handles private data, as is I in C above. The arguments I, I, I and I correspond to the arguments of the driver handle's C method. You will quite often use database specific attributes here, that are specified in the DSN. I recommend you parse the DSN (using Perl) within the C method and pass the segments of the DSN via the attributes parameter through C<_login()> to C. Here's how you fetch them; as an example we use I attribute, which can be up to 12 characters long excluding null terminator: SV** svp; STRLEN len; char* hostname; if ( (svp = DBD_ATTRIB_GET_SVP(attr, "drv_hostname", 12)) && SvTRUE(*svp)) { hostname = SvPV(*svp, len); DBD_ATTRIB_DELETE(attr, "drv_hostname", 12); /* avoid later STORE */ } else { hostname = "localhost"; } If you handle any driver specific attributes in the dbd_db_login6 method you probably want to delete them from C (as above with DBD_ATTRIB_DELETE). If you don't delete your handled attributes DBI will call C for each attribute after the connect/login and this is at best redundant for attributes you have already processed. B hv_delete((HV*)SvRV(attr), key, key_len, G_DISCARD) Note that you can also obtain standard attributes such as I and I from the attributes parameter, using C for integer attributes. If, for example, your database does not support transactions but I is set off (requesting transaction support), then you can emulate a 'failure to connect'. Now you should really connect to the database. In general, if the connection fails, it is best to ensure that all allocated resources are released so that the handle does not need to be destroyed separately. If you are successful (and possibly even if you fail but you have allocated some resources), you should use the following macros: DBIc_IMPSET_on(imp_dbh); This indicates that the driver (implementor) has allocated resources in the I structure and that the implementors private C function should be called when the handle is destroyed. DBIc_ACTIVE_on(imp_dbh); This indicates that the handle has an active connection to the server and that the C function should be called before the handle is destroyed. Note that if you do need to fail, you should report errors via the I or I rather than via I or I because I will be destroyed by the failure, so errors recorded in that handle will not be visible to B, and hence not the user either. Note too, that the function is passed I and I, and there is a macro C which can recover the I from the I. However, there is no B macro to provide you with the I given either the I or the I or the I (and there's no way to recover the I given just the I). This suggests that, despite the above notes about C taking an C, it may be better to have two error routines, one taking I and one taking I instead. With care, you can factor most of the formatting code out so that these are small routines calling a common error formatter. See the code in B 1.05.00 for more information. The C function should return I for success, I otherwise. Drivers implemented long ago may define the five-argument function C instead of C. The missing argument is the attributes. There are ways to work around the missing attributes, but they are ungainly; it is much better to use the 6-argument form. Even later drivers will use C which provides the dbname, username and password as SVs. =head3 The dbd_db_commit and dbd_db_rollback methods int dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh); int dbd_db_rollback(SV* dbh, imp_dbh_t* imp_dbh); These are used for commit and rollback. They should return I for success, I for error. The arguments I and I are the same as for C above; I will omit describing them in what follows, as they appear always. These functions should return I for success, I otherwise. =head3 The dbd_db_disconnect method This is your private part of the C method. Any I with the I flag on must be disconnected. (Note that you have to set it in C above.) int dbd_db_disconnect(SV* dbh, imp_dbh_t* imp_dbh); The database handle will return I for success, I otherwise. In any case it should do a: DBIc_ACTIVE_off(imp_dbh); before returning so B knows that C was executed. Note that there's nothing to stop a I being I while it still have active children. If your database API reacts badly to trying to use an I in this situation then you'll need to add code like this to all I methods: if (!DBIc_ACTIVE(DBIc_PARENT_COM(imp_sth))) return 0; Alternatively, you can add code to your driver to keep explicit track of the statement handles that exist for each database handle and arrange to destroy those handles before disconnecting from the database. There is code to do this in B. Similar comments apply to the driver handle keeping track of all the database handles. Note that the code which destroys the subordinate handles should only release the associated database resources and mark the handles inactive; it does not attempt to free the actual handle structures. This function should return I for success, I otherwise, but it is not clear what anything can do about a failure. =head3 The dbd_db_discon_all method int dbd_discon_all (SV *drh, imp_drh_t *imp_drh); This function may be called at shutdown time. It should make best-efforts to disconnect all database handles - if possible. Some databases don't support that, in which case you can do nothing but return 'success'. This function should return I for success, I otherwise, but it is not clear what anything can do about a failure. =head3 The dbd_db_destroy method This is your private part of the database handle destructor. Any I with the I flag on must be destroyed, so that you can safely free resources. (Note that you have to set it in C above.) void dbd_db_destroy(SV* dbh, imp_dbh_t* imp_dbh) { DBIc_IMPSET_off(imp_dbh); } The B F code will have called C for you, if the handle is still 'active', before calling C. Before returning the function must switch I to off, so B knows that the destructor was called. A B handle doesn't keep references to its children. But children do keep references to their parents. So a database handle won't be C'd until all its children have been C'd. =head3 The dbd_db_STORE_attrib method This function handles $dbh->{$key} = $value; Its prototype is: int dbd_db_STORE_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv, SV* valuesv); You do not handle all attributes; on the contrary, you should not handle B attributes here: leave this to B. (There are two exceptions, I and I, which you should care about.) The return value is I if you have handled the attribute or I otherwise. If you are handling an attribute and something fails, you should call C, so B can raise exceptions, if desired. If C returns, however, you have a problem: the user will never know about the error, because he typically will not check C<$dbh-Eerrstr()>. I cannot recommend a general way of going on, if C returns, but there are examples where even the B specification expects that you C. (See the I method in L.) If you have to store attributes, you should either use your private data structure I, the handle hash (via C<(HV*)SvRV(dbh)>), or use the private I. The first is best for internal C values like integers or pointers and where speed is important within the driver. The handle hash is best for values the user may want to get/set via driver-specific attributes. The private I is an additional C attached to the handle. You could think of it as an unnamed handle attribute. It's not normally used. =head3 The dbd_db_FETCH_attrib method This is the counterpart of C, needed for: $value = $dbh->{$key}; Its prototype is: SV* dbd_db_FETCH_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv); Unlike all previous methods this returns an C with the value. Note that you should normally execute C, if you return a nonconstant value. (Constant values are C<&sv_undef>, C<&sv_no> and C<&sv_yes>.) Note, that B implements a caching algorithm for attribute values. If you think, that an attribute may be fetched, you store it in the I itself: if (cacheit) /* cache value for later DBI 'quick' fetch? */ hv_store((HV*)SvRV(dbh), key, kl, cachesv, 0); =head3 The dbd_st_prepare method This is the private part of the C method. Note that you B really execute the statement here. You may, however, preparse and validate the statement, or do similar things. int dbd_st_prepare(SV* sth, imp_sth_t* imp_sth, char* statement, SV* attribs); A typical, simple, possibility is to do nothing and rely on the perl C code that set the I attribute on the handle. This attribute can then be used by C. If the driver supports placeholders then the I attribute must be set correctly by C: DBIc_NUM_PARAMS(imp_sth) = ... If you can, you should also setup attributes like I, I, etc. here, but B doesn't require that - they can be deferred until execute() is called. However, if you do, document it. In any case you should set the I flag, as you did in C above: DBIc_IMPSET_on(imp_sth); =head3 The dbd_st_execute method This is where a statement will really be executed. int dbd_st_execute(SV* sth, imp_sth_t* imp_sth); C should return -2 for any error, -1 if the number of rows affected is unknown else it should be the number of affected (updated, inserted) rows. Note that you must be aware a statement may be executed repeatedly. Also, you should not expect that C will be called between two executions, so you might need code, like the following, near the start of the function: if (DBIc_ACTIVE(imp_sth)) dbd_st_finish(h, imp_sth); If your driver supports the binding of parameters (it should!), but the database doesn't, you must do it here. This can be done as follows: SV *svp; char* statement = DBD_ATTRIB_GET_PV(h, "Statement", 9, svp, ""); int numParam = DBIc_NUM_PARAMS(imp_sth); int i; for (i = 0; i < numParam; i++) { char* value = dbd_db_get_param(sth, imp_sth, i); /* It is your drivers task to implement dbd_db_get_param, */ /* it must be setup as a counterpart of dbd_bind_ph. */ /* Look for '?' and replace it with 'value'. Difficult */ /* task, note that you may have question marks inside */ /* quotes and comments the like ... :-( */ /* See DBD::mysql for an example. (Don't look too deep into */ /* the example, you will notice where I was lazy ...) */ } The next thing is to really execute the statement. Note that you must set the attributes I, I, etc when the statement is successfully executed if the driver has not already done so: they may be used even before a potential C. In particular you have to tell B the number of fields that the statement has, because it will be used by B internally. Thus the function will typically ends with: if (isSelectStatement) { DBIc_NUM_FIELDS(imp_sth) = numFields; DBIc_ACTIVE_on(imp_sth); } It is important that the I flag only be set for C statement is: prepare, execute, fetch, fetch, ... execute, fetch, fetch, ... execute, fetch, fetch, ... for example: $sth = $dbh->prepare("SELECT foo, bar FROM table WHERE baz=?"); $sth->execute( $baz ); while ( @row = $sth->fetchrow_array ) { print "@row\n"; } For queries that are not executed many times at once, it is often cleaner to use the higher level select wrappers: $row_hashref = $dbh->selectrow_hashref("SELECT foo, bar FROM table WHERE baz=?", undef, $baz); $arrayref_of_row_hashrefs = $dbh->selectall_arrayref( "SELECT foo, bar FROM table WHERE baz BETWEEN ? AND ?", { Slice => {} }, $baz_min, $baz_max); The typical method call sequence for a I-C statements (or with drivers that don't support placeholders): $rows_affected = $dbh->do("UPDATE your_table SET foo = foo + 1"); $rows_affected = $dbh->do("DELETE FROM table WHERE foo = ?", undef, $foo); To commit your changes to the database (when L is off): $dbh->commit; # or call $dbh->rollback; to undo changes Finally, when you have finished working with the data source, you should L from it: $dbh->disconnect; =head2 General Interface Rules & Caveats The DBI does not have a concept of a "current session". Every session has a handle object (i.e., a C<$dbh>) returned from the C method. That handle object is used to invoke database related methods. Most data is returned to the Perl script as strings. (Null values are returned as C.) This allows arbitrary precision numeric data to be handled without loss of accuracy. Beware that Perl may not preserve the same accuracy when the string is used as a number. Dates and times are returned as character strings in the current default format of the corresponding database engine. Time zone effects are database/driver dependent. Perl supports binary data in Perl strings, and the DBI will pass binary data to and from the driver without change. It is up to the driver implementors to decide how they wish to handle such binary data. Perl supports two kinds of strings: Unicode (utf8 internally) and non-Unicode (defaults to iso-8859-1 if forced to assume an encoding). Drivers should accept both kinds of strings and, if required, convert them to the character set of the database being used. Similarly, when fetching from the database character data that isn't iso-8859-1 the driver should convert it into utf8. Multiple SQL statements may not be combined in a single statement handle (C<$sth>), although some databases and drivers do support this (notably Sybase and SQL Server). Non-sequential record reads are not supported in this version of the DBI. In other words, records can only be fetched in the order that the database returned them, and once fetched they are forgotten. Positioned updates and deletes are not directly supported by the DBI. See the description of the C attribute for an alternative. Individual driver implementors are free to provide any private functions and/or handle attributes that they feel are useful. Private driver functions can be invoked using the DBI C method. Private driver attributes are accessed just like standard attributes. Many methods have an optional C<\%attr> parameter which can be used to pass information to the driver implementing the method. Except where specifically documented, the C<\%attr> parameter can only be used to pass driver specific hints. In general, you can ignore C<\%attr> parameters or pass it as C. =head2 Naming Conventions and Name Space The DBI package and all packages below it (C) are reserved for use by the DBI. Extensions and related modules use the C namespace (see L). Package names beginning with C are reserved for use by DBI database drivers. All environment variables used by the DBI or by individual DBDs begin with "C" or "C". The letter case used for attribute names is significant and plays an important part in the portability of DBI scripts. The case of the attribute name is used to signify who defined the meaning of that name and its values. Case of name Has a meaning defined by ------------ ------------------------ UPPER_CASE Standards, e.g., X/Open, ISO SQL92 etc (portable) MixedCase DBI API (portable), underscores are not used. lower_case Driver or database engine specific (non-portable) It is of the utmost importance that Driver developers only use lowercase attribute names when defining private attributes. Private attribute names must be prefixed with the driver name or suitable abbreviation (e.g., "C" for Oracle, "C" for Ingres, etc). =head2 SQL - A Query Language Most DBI drivers require applications to use a dialect of SQL (Structured Query Language) to interact with the database engine. The L section provides links to useful information about SQL. The DBI itself does not mandate or require any particular language to be used; it is language independent. In ODBC terms, the DBI is in "pass-thru" mode, although individual drivers might not be. The only requirement is that queries and other statements must be expressed as a single string of characters passed as the first argument to the L or L methods. For an interesting diversion on the I history of RDBMS and SQL, from the people who made it happen, see: http://www.mcjones.org/System_R/SQL_Reunion_95/sqlr95.html Follow the "Full Contents" then "Intergalactic dataspeak" links for the SQL history. =head2 Placeholders and Bind Values Some drivers support placeholders and bind values. I, also called parameter markers, are used to indicate values in a database statement that will be supplied later, before the prepared statement is executed. For example, an application might use the following to insert a row of data into the SALES table: INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?) or the following, to select the description for a product: SELECT description FROM products WHERE product_code = ? The C characters are the placeholders. The association of actual values with placeholders is known as I, and the values are referred to as I. Note that the C is not enclosed in quotation marks, even when the placeholder represents a string. Some drivers also allow placeholders like C<:>I and C<:>I (e.g., C<:1>, C<:2>, and so on) in addition to C, but their use is not portable. If the C<:>I form of placeholder is supported by the driver you're using, then you should be able to use either L or L to bind values. Check your driver documentation. Some drivers allow you to prevent the recognition of a placeholder by placing a single backslash character (C<\>) immediately before it. The driver will remove the backslash character and ignore the placeholder, passing it unchanged to the backend. If the driver supports this then L(9000) will return true. With most drivers, placeholders can't be used for any element of a statement that would prevent the database server from validating the statement and creating a query execution plan for it. For example: "SELECT name, age FROM ?" # wrong (will probably fail) "SELECT name, ? FROM people" # wrong (but may not 'fail') Also, placeholders can only represent single scalar values. For example, the following statement won't work as expected for more than one value: "SELECT name, age FROM people WHERE name IN (?)" # wrong "SELECT name, age FROM people WHERE name IN (?,?)" # two names When using placeholders with the SQL C qualifier, you must remember that the placeholder substitutes for the whole string. So you should use "C<... LIKE ? ...>" and include any wildcard characters in the value that you bind to the placeholder. B Undefined values, or C, are used to indicate NULL values. You can insert and update columns with a NULL value as you would a non-NULL value. These examples insert and update the column C with a NULL value: $sth = $dbh->prepare(qq{ INSERT INTO people (fullname, age) VALUES (?, ?) }); $sth->execute("Joe Bloggs", undef); $sth = $dbh->prepare(qq{ UPDATE people SET age = ? WHERE fullname = ? }); $sth->execute(undef, "Joe Bloggs"); However, care must be taken when trying to use NULL values in a C clause. Consider: SELECT fullname FROM people WHERE age = ? Binding an C (NULL) to the placeholder will I select rows which have a NULL C! At least for database engines that conform to the SQL standard. Refer to the SQL manual for your database engine or any SQL book for the reasons for this. To explicitly select NULLs you have to say "C". A common issue is to have a code fragment handle a value that could be either C or C (non-NULL or NULL) at runtime. A simple technique is to prepare the appropriate statement as needed, and substitute the placeholder for non-NULL cases: $sql_clause = defined $age? "age = ?" : "age IS NULL"; $sth = $dbh->prepare(qq{ SELECT fullname FROM people WHERE $sql_clause }); $sth->execute(defined $age ? $age : ()); The following technique illustrates qualifying a C clause with several columns, whose associated values (C or C) are in a hash %h: for my $col ("age", "phone", "email") { if (defined $h{$col}) { push @sql_qual, "$col = ?"; push @sql_bind, $h{$col}; } else { push @sql_qual, "$col IS NULL"; } } $sql_clause = join(" AND ", @sql_qual); $sth = $dbh->prepare(qq{ SELECT fullname FROM people WHERE $sql_clause }); $sth->execute(@sql_bind); The techniques above call prepare for the SQL statement with each call to execute. Because calls to prepare() can be expensive, performance can suffer when an application iterates many times over statements like the above. A better solution is a single C clause that supports both NULL and non-NULL comparisons. Its SQL statement would need to be prepared only once for all cases, thus improving performance. Several examples of C clauses that support this are presented below. But each example lacks portability, robustness, or simplicity. Whether an example is supported on your database engine depends on what SQL extensions it provides, and where it supports the C placeholder in a statement. 0) age = ? 1) NVL(age, xx) = NVL(?, xx) 2) ISNULL(age, xx) = ISNULL(?, xx) 3) DECODE(age, ?, 1, 0) = 1 4) age = ? OR (age IS NULL AND ? IS NULL) 5) age = ? OR (age IS NULL AND SP_ISNULL(?) = 1) 6) age = ? OR (age IS NULL AND ? = 1) Statements formed with the above C clauses require execute statements as follows. The arguments are required, whether their values are C or C. 0,1,2,3) $sth->execute($age); 4,5) $sth->execute($age, $age); 6) $sth->execute($age, defined($age) ? 0 : 1); Example 0 should not work (as mentioned earlier), but may work on a few database engines anyway (e.g. Sybase). Example 0 is part of examples 4, 5, and 6, so if example 0 works, these other examples may work, even if the engine does not properly support the right hand side of the C expression. Examples 1 and 2 are not robust: they require that you provide a valid column value xx (e.g. '~') which is not present in any row. That means you must have some notion of what data won't be stored in the column, and expect clients to adhere to that. Example 5 requires that you provide a stored procedure (SP_ISNULL in this example) that acts as a function: it checks whether a value is null, and returns 1 if it is, or 0 if not. Example 6, the least simple, is probably the most portable, i.e., it should work with most, if not all, database engines. Here is a table that indicates which examples above are known to work on various database engines: -----Examples------ 0 1 2 3 4 5 6 - - - - - - - Oracle 9 N Y N Y Y ? Y Informix IDS 9 N N N Y N Y Y MS SQL N N Y N Y ? Y Sybase Y N N N N N Y AnyData,DBM,CSV Y N N N Y Y* Y SQLite 3.3 N N N N Y N N MSAccess N N N N Y N Y * Works only because Example 0 works. DBI provides a sample perl script that will test the examples above on your database engine and tell you which ones work. It is located in the F subdirectory of the DBI source distribution, or here: L Please use the script to help us fill-in and maintain this table. B Without using placeholders, the insert statement shown previously would have to contain the literal values to be inserted and would have to be re-prepared and re-executed for each row. With placeholders, the insert statement only needs to be prepared once. The bind values for each row can be given to the C method each time it's called. By avoiding the need to re-prepare the statement for each row, the application typically runs many times faster. Here's an example: my $sth = $dbh->prepare(q{ INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?) }) or die $dbh->errstr; while (<>) { chomp; my ($product_code, $qty, $price) = split /,/; $sth->execute($product_code, $qty, $price) or die $dbh->errstr; } $dbh->commit or die $dbh->errstr; See L and L for more details. The C style quoting used in this example avoids clashing with quotes that may be used in the SQL statement. Use the double-quote like C operator if you want to interpolate variables into the string. See L for more details. See also the L method, which is used to associate Perl variables with the output columns of a C that may have more data to fetch. (Fetching all the data or calling C<$sth-Efinish> sets C off.) =head3 C Type: boolean The C attribute is true if the handle object has been "executed". Currently only the $dbh do() method and the $sth execute(), execute_array(), and execute_for_fetch() methods set the C attribute. When it's set on a handle it is also set on the parent handle at the same time. So calling execute() on a $sth also sets the C attribute on the parent $dbh. The C attribute for a database handle is cleared by the commit() and rollback() methods (even if they fail). The C attribute of a statement handle is not cleared by the DBI under any circumstances and so acts as a permanent record of whether the statement handle was ever used. The C attribute was added in DBI 1.41. =head3 C Type: integer, read-only For a driver handle, C is the number of currently existing database handles that were created from that driver handle. For a database handle, C is the number of currently existing statement handles that were created from that database handle. For a statement handle, the value is zero. =head3 C Type: integer, read-only Like C, but only counting those that are C (as above). =head3 C Type: hash ref For a database handle, C returns a reference to the cache (hash) of statement handles created by the L method. For a driver handle, returns a reference to the cache (hash) of database handles created by the L method. =head3 C Type: scalar, read-only The C attribute identifies the type of a DBI handle. Returns "dr" for driver handles, "db" for database handles and "st" for statement handles. =head3 C Type: array ref The ChildHandles attribute contains a reference to an array of all the handles created by this handle which are still accessible. The contents of the array are weak-refs and will become undef when the handle goes out of scope. (They're cleared out occasionally.) C returns undef if your perl version does not support weak references (check the L module). The referenced array returned should be treated as read-only. For example, to enumerate all driver handles, database handles and statement handles: sub show_child_handles { my ($h, $level) = @_; printf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h; show_child_handles($_, $level + 1) for (grep { defined } @{$h->{ChildHandles}}); } my %drivers = DBI->installed_drivers(); show_child_handles($_, 0) for (values %drivers); =head3 C Type: boolean, inherited The C attribute is used by emulation layers (such as Oraperl) to enable compatible behaviour in the underlying driver (e.g., DBD::Oracle) for this handle. Not normally set by application code. It also has the effect of disabling the 'quick FETCH' of attribute values from the handles attribute cache. So all attribute values are handled by the drivers own FETCH method. This makes them slightly slower but is useful for special-purpose drivers like DBD::Multiplex. =head3 C Type: boolean The default value, false, means a handle will be fully destroyed as normal when the last reference to it is removed, just as you'd expect. If set true then the handle will be treated by the DESTROY as if it was no longer Active, and so the I related effects of DESTROYing a handle will be skipped. Think of the name as meaning 'treat the handle as not-Active in the DESTROY method'. For a database handle, this attribute does not disable an I call to the disconnect method, only the implicit call from DESTROY that happens if the handle is still marked as C. This attribute is specifically designed for use in Unix applications that "fork" child processes. For some drivers, when the child process exits the destruction of inherited handles cause the corresponding handles in the parent process to cease working. Either the parent or the child process, but not both, should set C true on all their shared handles. Alternatively, and preferably, the L can be set in the parent on connect. To help tracing applications using fork the process id is shown in the trace log whenever a DBI or handle trace() method is called. The process id also shown for I method call if the DBI trace level (not handle trace level) is set high enough to show the trace from the DBI's method dispatcher, e.g. >= 9. =head3 C Type: boolean, inherited The L attribute, described above, needs to be explicitly set in the child process after a fork(), on every active database and statement handle. This is a problem if the code that performs the fork() is not under your control, perhaps in a third-party module. Use C to get around this situation. If set true, the DESTROY method will check the process id of the handle and, if different from the current process id, it will set the I attribute. It is strongly recommended that C is enabled on all new code (it's only not enabled by default to avoid backwards compatibility problems). This is the example it's designed to deal with: my $dbh = DBI->connect(...); some_code_that_forks(); # Perhaps without your knowledge # Child process dies, destroying the inherited dbh $dbh->do(...); # Breaks because parent $dbh is now broken The C attribute was added in DBI 1.614. =head3 C Type: boolean, inherited The C attribute controls the printing of warnings recorded by the driver. When set to a true value (the default) the DBI will check method calls to see if a warning condition has been set. If so, the DBI will effectively do a C where C<$class> is the driver class and C<$method> is the name of the method which failed. E.g., DBD::Oracle::db execute warning: ... warning text here ... If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}> handler or modules like CGI::Carp and CGI::ErrorWrap. See also L for how warnings are recorded and L for how to influence it. Fetching the full details of warnings can require an extra round-trip to the database server for some drivers. In which case the driver may opt to only fetch the full details of warnings if the C attribute is true. If C is false then these drivers should still indicate the fact that there were warnings by setting the warning string to, for example: "3 warnings". =head3 C Type: boolean, inherited The C attribute can be used to force errors to generate warnings (using C) in addition to returning error codes in the normal way. When set "on", any method which results in an error occurring will cause the DBI to effectively do a C where C<$class> is the driver class and C<$method> is the name of the method which failed. E.g., DBD::Oracle::db prepare failed: ... error text here ... By default, Cconnect> sets C "on". If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}> handler or modules like CGI::Carp and CGI::ErrorWrap. =head3 C Type: boolean, inherited The C attribute can be used to force warnings to raise exceptions rather then simply printing them. It is "off" by default. When set "on", any method which sets warning condition will cause the DBI to effectively do a C, where C<$class> is the driver class and C<$method> is the name of the method that sets warning condition. E.g., DBD::Oracle::db execute warning: ... warning text here ... If you turn C on then you'd normally turn C off. If C is also on, then the C is done first (naturally). This attribute was added in DBI 1.643. =head3 C Type: boolean, inherited The C attribute can be used to force errors to raise exceptions rather than simply return error codes in the normal way. It is "off" by default. When set "on", any method which results in an error will cause the DBI to effectively do a C, where C<$class> is the driver class and C<$method> is the name of the method that failed. E.g., DBD::Oracle::db prepare failed: ... error text here ... If you turn C on then you'd normally turn C off. If C is also on, then the C is done first (naturally). Typically C is used in conjunction with C, or a module like L or L, to catch the exception that's been thrown and handle it. For example: use Try::Tiny; try { ... $sth->execute(); ... } catch { # $sth->err and $DBI::err will be true if error was from DBI warn $_; # print the error (which Try::Tiny puts into $_) ... # do whatever you need to deal with the error }; In the catch block the $DBI::lasth variable can be useful for diagnosis and reporting if you can't be sure which handle triggered the error. For example, $DBI::lasth->{Type} and $DBI::lasth->{Statement}. See also L. If you want to temporarily turn C off (inside a library function that is likely to fail, for example), the recommended way is like this: { local $h->{RaiseError}; # localize and turn off for this block ... } The original value will automatically and reliably be restored by Perl, regardless of how the block is exited. The same logic applies to other attributes, including C. =head3 C Type: code ref, inherited The C attribute can be used to provide your own alternative behaviour in case of errors. If set to a reference to a subroutine then that subroutine is called when an error is detected (at the same point that C and C are handled). It is called also when C is enabled and a warning is detected. The subroutine is called with three parameters: the error message string that C, C or C would use, the DBI handle being used (dbh, sth or drh as appropriate) and the first value being returned by the method that failed (typically undef). If the subroutine returns a false value then the C, C and/or C attributes are checked and acted upon as normal. For example, to C with a full stack trace for any error: use Carp; $h->{HandleError} = sub { confess(shift) }; Or to turn errors into exceptions: use Exception; # or your own favourite exception module $h->{HandleError} = sub { Exception->new('DBI')->raise($_[0]) }; It is possible to 'stack' multiple HandleError handlers by using closures: sub your_subroutine { my $previous_handler = $h->{HandleError}; $h->{HandleError} = sub { return 1 if $previous_handler and &$previous_handler(@_); ... your code here ... }; } Using a C inside a subroutine to store the previous C value is important. See L and L for more information about I. It is possible for C to alter the error message that will be used by C, C and C if it returns false. It can do that by altering the value of $_[0]. This example appends a stack trace to all errors and, unlike the previous example using Carp::confess, this will work C as well as C: $h->{HandleError} = sub { $_[0]=Carp::longmess($_[0]); 0; }; It is also possible for C to hide an error, to a limited degree, by using L to reset $DBI::err and $DBI::errstr, and altering the return value of the failed method. For example: $h->{HandleError} = sub { return 0 unless $_[0] =~ /^\S+ fetchrow_arrayref failed:/; return 0 unless $_[1]->err == 1234; # the error to 'hide' $h->set_err(undef,undef); # turn off the error $_[2] = [ ... ]; # supply alternative return value return 1; }; This only works for methods which return a single value and is hard to make reliable (avoiding infinite loops, for example) and so isn't recommended for general use! If you find a I use for it then please let me know. =head3 C Type: code ref, inherited The C attribute can be used to intercept the setting of handle C, C, and C values. If set to a reference to a subroutine then that subroutine is called whenever set_err() is called, typically by the driver or a subclass. The subroutine is called with five arguments, the first five that were passed to set_err(): the handle, the C, C, and C values being set, and the method name. These can be altered by changing the values in the @_ array. The return value affects set_err() behaviour, see L for details. It is possible to 'stack' multiple HandleSetErr handlers by using closures. See L for an example. The C and C subroutines differ in subtle but significant ways. HandleError is only invoked at the point where the DBI is about to return to the application with C set true. It's not invoked by the failure of a method that's been called by another DBI method. HandleSetErr, on the other hand, is called whenever set_err() is called with a defined C value, even if false. So it's not just for errors, despite the name, but also warn and info states. The set_err() method, and thus HandleSetErr, may be called multiple times within a method and is usually invoked from deep within driver code. In theory a driver can use the return value from HandleSetErr via set_err() to decide whether to continue or not. If set_err() returns an empty list, indicating that the HandleSetErr code has 'handled' the 'error', the driver could then continue instead of failing (if that's a reasonable thing to do). This isn't excepted to be common and any such cases should be clearly marked in the driver documentation and discussed on the dbi-dev mailing list. The C attribute was added in DBI 1.41. =head3 C Type: unsigned integer The C attribute is incremented whenever the set_err() method records an error. It isn't incremented by warnings or information states. It is not reset by the DBI at any time. The C attribute was added in DBI 1.41. Older drivers may not have been updated to use set_err() to record errors and so this attribute may not be incremented when using them. =head3 C Type: boolean, inherited The C attribute can be used to cause the relevant Statement text to be appended to the error messages generated by the C, C, C and C attributes. Only applies to errors on statement handles plus the prepare(), do(), and the various C database handle methods. (The exact format of the appended text is subject to change.) If C<$h-E{ParamValues}> returns a hash reference of parameter (placeholder) values then those are formatted and appended to the end of the Statement text in the error message. =head3 C Type: integer, inherited The C attribute can be used as an alternative to the L method to set the DBI trace level and trace flags for a specific handle. See L for more details. The C attribute is especially useful combined with C to alter the trace settings for just a single block of code. =head3 C Type: string, inherited The C attribute is used to specify whether the fetchrow_hashref() method should perform case conversion on the field names used for the hash keys. For historical reasons it defaults to 'C' but it is recommended to set it to 'C' (convert to lower case) or 'C' (convert to upper case) according to your preference. It can only be set for driver and database handles. For statement handles the value is frozen when prepare() is called. =head3 C Type: boolean, inherited The C attribute can be used to control the trimming of trailing space characters from fixed width character (CHAR) fields. No other field types are affected, even where field values have trailing spaces. The default is false (although it is possible that the default may change). Applications that need specific behaviour should set the attribute as needed. Drivers are not required to support this attribute, but any driver which does not support it must arrange to return C as the attribute value. =head3 C Type: unsigned integer, inherited The C attribute may be used to control the maximum length of 'long' type fields (LONG, BLOB, CLOB, MEMO, etc.) which the driver will read from the database automatically when it fetches each row of data. The C attribute only relates to fetching and reading long values; it is not involved in inserting or updating them. A value of 0 means not to automatically fetch any long data. Drivers may return undef or an empty string for long fields when C is 0. The default is typically 0 (zero) or 80 bytes but may vary between drivers. Applications fetching long fields should set this value to slightly larger than the longest long field value to be fetched. Some databases return some long types encoded as pairs of hex digits. For these types, C relates to the underlying data length and not the doubled-up length of the encoded string. Changing the value of C for a statement handle after it has been C'd will typically have no effect, so it's common to set C on the C<$dbh> before calling C. For most drivers the value used here has a direct effect on the memory used by the statement handle while it's active, so don't be too generous. If you can't be sure what value to use you could execute an extra select statement to determine the longest value. For example: $dbh->{LongReadLen} = $dbh->selectrow_array(qq{ SELECT MAX(OCTET_LENGTH(long_column_name)) FROM table WHERE ... }); $sth = $dbh->prepare(qq{ SELECT long_column_name, ... FROM table WHERE ... }); You may need to take extra care if the table can be modified between the first select and the second being executed. You may also need to use a different function if OCTET_LENGTH() does not work for long types in your database. For example, for Sybase use DATALENGTH() and for Oracle use LENGTHB(). See also L for information on truncation of long types. =head3 C Type: boolean, inherited The C attribute may be used to control the effect of fetching a long field value which has been truncated (typically because it's longer than the value of the C attribute). By default, C is false and so fetching a long value that needs to be truncated will cause the fetch to fail. (Applications should always be sure to check for errors after a fetch loop in case an error, such as a divide by zero or long field truncation, caused the fetch to terminate prematurely.) If a fetch fails due to a long field truncation when C is false, many drivers will allow you to continue fetching further rows. See also L. =head3 C Type: boolean, inherited If the C attribute is set to a true value I Perl is running in taint mode (e.g., started with the C<-T> option), then all the arguments to most DBI method calls are checked for being tainted. I The attribute defaults to off, even if Perl is in taint mode. See L for more about taint mode. If Perl is not running in taint mode, this attribute has no effect. When fetching data that you trust you can turn off the TaintIn attribute, for that statement handle, for the duration of the fetch loop. The C attribute was added in DBI 1.31. =head3 C Type: boolean, inherited If the C attribute is set to a true value I Perl is running in taint mode (e.g., started with the C<-T> option), then most data fetched from the database is considered tainted. I The attribute defaults to off, even if Perl is in taint mode. See L for more about taint mode. If Perl is not running in taint mode, this attribute has no effect. When fetching data that you trust you can turn off the TaintOut attribute, for that statement handle, for the duration of the fetch loop. Currently only fetched data is tainted. It is possible that the results of other DBI method calls, and the value of fetched attributes, may also be tainted in future versions. That change may well break your applications unless you take great care now. If you use DBI Taint mode, please report your experience and any suggestions for changes. The C attribute was added in DBI 1.31. =head3 C Type: boolean, inherited The C attribute is a shortcut for L and L (it is also present for backwards compatibility). Setting this attribute sets both L and L, and retrieving it returns a true value if and only if L and L are both set to true values. =head3 C Type: inherited The C attribute enables the collection and reporting of method call timing statistics. See the L module documentation for I more detail. The C attribute was added in DBI 1.24. =head3 C Type: boolean, inherited An application can set the C attribute of a handle to a true value to indicate that it will not be attempting to make any changes using that handle or any children of it. Note that the exact definition of 'read only' is rather fuzzy. For more details see the documentation for the driver you're using. If the driver can make the handle truly read-only then it should (unless doing so would have unpleasant side effect, like changing the consistency level from per-statement to per-session). Otherwise the attribute is simply advisory. A driver can set the C attribute itself to indicate that the data it is connected to cannot be changed for some reason. If the driver cannot ensure the C attribute is adhered to it will record a warning. In this case reading the C attribute back after it is set true will return true even if the underlying driver cannot ensure this (so any application knows the application declared itself ReadOnly). Library modules and proxy drivers can use the attribute to influence their behavior. For example, the DBD::Gofer driver considers the C attribute when making a decision about whether to retry an operation that failed. The attribute should be set to 1 or 0 (or undef). Other values are reserved. =head3 C Type: hash ref The DBI callback mechanism lets you intercept, and optionally replace, any method call on a DBI handle. At the extreme, it lets you become a puppet master, deceiving the application in any way you want. The C attribute is a hash reference where the keys are DBI method names and the values are code references. For each key naming a method, the DBI will execute the associated code reference before executing the method. The arguments to the code reference will be the same as to the method, including the invocant (a database handle or statement handle). For example, say that to callback to some code on a call to C: $dbh->{Callbacks} = { prepare => sub { my ($dbh, $query, $attrs) = @_; print "Preparing q{$query}\n" }, }; The callback would then be executed when you called the C method: $dbh->prepare('SELECT 1'); And the output of course would be: Preparing q{SELECT 1} Because callbacks are executed I the methods they're associated with, you can modify the arguments before they're passed on to the method call. For example, to make sure that all calls to C are immediately prepared by L, add a callback that makes sure that the C attribute is always set: my $dbh = DBI->connect($dsn, $username, $auth, { Callbacks => { prepare => sub { $_[2] ||= {}; $_[2]->{pg_prepare_now} = 1; return; # must return nothing }, } }); Note that we are editing the contents of C<@_> directly. In this case we've created the attributes hash if it's not passed to the C call. You can also prevent the associated method from ever executing. While a callback executes, C<$_> holds the method name. (This allows multiple callbacks to share the same code reference and still know what method was called.) To prevent the method from executing, simply C. For example, if you wanted to disable calls to C, you could do this: $dbh->{Callbacks} = { ping => sub { # tell dispatch to not call the method: undef $_; # return this value instead: return "42 bells"; } }; As with other attributes, Callbacks can be specified on a handle or via the attributes to C. Callbacks can also be applied to a statement methods on a statement handle. For example: $sth->{Callbacks} = { execute => sub { print "Executing ", shift->{Statement}, "\n"; } }; The C attribute of a database handle isn't copied to any statement handles it creates. So setting callbacks for a statement handle requires you to set the C attribute on the statement handle yourself, as in the example above, or use the special C key described below. B In addition to DBI handle method names, the C hash reference supports four additional keys. The first is the C key. When a statement handle is created from a database handle the C key of the database handle's C attribute, if any, becomes the new C attribute of the statement handle. This allows you to define callbacks for all statement handles created from a database handle. For example, if you wanted to count how many times C was called in your application, you could write: my $exec_count = 0; my $dbh = DBI->connect( $dsn, $username, $auth, { Callbacks => { ChildCallbacks => { execute => sub { $exec_count++; return; } } } }); END { print "The execute method was called $exec_count times\n"; } The other three special keys are C, C, and C. These keys define callbacks that are called when C is called, but allow different behaviors depending on whether a new handle is created or a handle is returned. The callback is invoked with these arguments: C<$dbh, $dsn, $user, $auth, $attr>. For example, some applications uses C to connect with C enabled and then disable C temporarily for transactions. If C is called during a transaction, perhaps in a utility method, then it might select the same cached handle and then force C on, forcing a commit of the transaction. See the L documentation for one way to deal with that. Here we'll describe an alternative approach using a callback. Because the C and C callbacks are invoked before C has applied the connect attributes, you can use them to edit the attributes that will be applied. To prevent a cached handle from having its transactions committed before it's returned, you can eliminate the C attribute in a C callback, like so: my $cb = { 'connect_cached.reused' => sub { delete $_[4]->{AutoCommit} }, }; sub dbh { my $self = shift; DBI->connect_cached( $dsn, $username, $auth, { PrintError => 0, RaiseError => 1, AutoCommit => 1, Callbacks => $cb, }); } The upshot is that new database handles are created with C enabled, while cached database handles are left in whatever transaction state they happened to be in when retrieved from the cache. Note that we've also used a lexical for the callbacks hash reference. This is because C returns a new database handle if any of the attributes passed to is have changed. If we used an inline hash reference, C would return a new database handle every time. Which would rather defeat the purpose. A more common application for callbacks is setting connection state only when a new connection is made (by connect() or connect_cached()). Adding a callback to the connected method (when using C) or via C (when using connect_cached()>) makes this easy. The connected() method is a no-op by default (unless you subclass the DBI and change it). The DBI calls it to indicate that a new connection has been made and the connection attributes have all been set. You can give it a bit of added functionality by applying a callback to it. For example, to make sure that MySQL understands your application's ANSI-compliant SQL, set it up like so: my $dbh = DBI->connect($dsn, $username, $auth, { Callbacks => { connected => sub { shift->do(q{ SET SESSION sql_mode='ansi,strict_trans_tables,no_auto_value_on_zero'; }); return; }, } }); If you're using C, use the C callback, instead. This is because C is called for both new and reused database handles, but you want to execute a callback only the when a new database handle is returned. For example, to set the time zone on connection to a PostgreSQL database, try this: my $cb = { 'connect_cached.connected' => sub { shift->do('SET timezone = UTC'); } }; sub dbh { my $self = shift; DBI->connect_cached( $dsn, $username, $auth, { Callbacks => $cb }); } One significant limitation with callbacks is that there can only be one per method per handle. This means it's easy for one use of callbacks to interfere with, or typically simply overwrite, another use of callbacks. For this reason modules using callbacks should document the fact clearly so application authors can tell if use of callbacks by the module will clash with use of callbacks by the application. You might be able to work around this issue by taking a copy of the original callback and calling it within your own. For example: my $prev_cb = $h->{Callbacks}{method_name}; $h->{Callbacks}{method_name} = sub { if ($prev_cb) { my @result = $prev_cb->(@_); return @result if not $_; # $prev_cb vetoed call } ... your callback logic here ... }; =head3 C The DBI provides a way to store extra information in a DBI handle as "private" attributes. The DBI will allow you to store and retrieve any attribute which has a name starting with "C". It is I recommended that you use just I private attribute (e.g., use a hash ref) I give it a long and unambiguous name that includes the module or application name that the attribute relates to (e.g., "C"). Because of the way the Perl tie mechanism works you cannot reliably use the C<||=> operator directly to initialise the attribute, like this: my $foo = $dbh->{private_yourmodname_foo} ||= { ... }; # WRONG you should use a two step approach like this: my $foo = $dbh->{private_yourmodname_foo}; $foo ||= $dbh->{private_yourmodname_foo} = { ... }; This attribute is primarily of interest to people sub-classing DBI, or for applications to piggy-back extra information onto DBI handles. =head1 DBI DATABASE HANDLE OBJECTS This section covers the methods and attributes associated with database handles. =head2 Database Handle Methods The following methods are specified for DBI database handles: =head3 C $new_dbh = $dbh->clone(\%attr); The C method duplicates the $dbh connection by connecting with the same parameters ($dsn, $user, $password) as originally used. The attributes for the cloned connect are the same as those used for the I connect, with any other attributes in C<\%attr> merged over them. Effectively the same as doing: %attributes_used = ( %original_attributes, %attr ); If \%attr is not given then it defaults to a hash containing all the attributes in the attribute cache of $dbh excluding any non-code references, plus the main boolean attributes (RaiseError, PrintError, AutoCommit, etc.). I The clone method can be used even if the database handle is disconnected. The C method was added in DBI 1.33. =head3 C @ary = $dbh->data_sources(); @ary = $dbh->data_sources(\%attr); Returns a list of data sources (databases) available via the $dbh driver's data_sources() method, plus any extra data sources that the driver can discover via the connected $dbh. Typically the extra data sources are other databases managed by the same server process that the $dbh is connected to. Data sources are returned in a form suitable for passing to the L method (that is, they will include the "C" prefix). The data_sources() method, for a $dbh, was added in DBI 1.38. =head3 C $rows = $dbh->do($statement) or die $dbh->errstr; $rows = $dbh->do($statement, \%attr) or die $dbh->errstr; $rows = $dbh->do($statement, \%attr, @bind_values) or die ... Prepare and execute a single statement. Returns the number of rows affected or C on error. A return value of C<-1> means the number of rows is not known, not applicable, or not available. This method is typically most useful for I-C statements because it does not return a statement handle (so you can't fetch any data). The default C method is logically similar to: sub do { my($dbh, $statement, $attr, @bind_values) = @_; my $sth = $dbh->prepare($statement, $attr) or return undef; $sth->execute(@bind_values) or return undef; my $rows = $sth->rows; ($rows == 0) ? "0E0" : $rows; # always return true if no error } For example: my $rows_deleted = $dbh->do(q{ DELETE FROM table WHERE status = ? }, undef, 'DONE') or die $dbh->errstr; Using placeholders and C<@bind_values> with the C method can be useful because it avoids the need to correctly quote any variables in the C<$statement>. But if you'll be executing the statement many times then it's more efficient to C it once and call C many times instead. The C style quoting used in this example avoids clashing with quotes that may be used in the SQL statement. Use the double-quote-like C operator if you want to interpolate variables into the string. See L for more details. Note drivers are free to avoid the overhead of creating an DBI statement handle for do(), especially if there are no parameters. In this case error handlers, if invoked during do(), will be passed the database handle. =head3 C $rv = $dbh->last_insert_id(); $rv = $dbh->last_insert_id($catalog, $schema, $table, $field); $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr); Returns a value 'identifying' the row just inserted, if possible. Typically this would be a value assigned by the database server to a column with an I or I type. Returns undef if the driver does not support the method or can't determine the value. The $catalog, $schema, $table, and $field parameters may be required for some drivers (see below). If you don't know the parameter values and your driver does not need them, then use C for each. There are several caveats to be aware of with this method if you want to use it for portable applications: B<*> For some drivers the value may only be available immediately after the insert statement has executed (e.g., mysql, Informix). B<*> For some drivers the $catalog, $schema, $table, and $field parameters are required, for others they are ignored (e.g., mysql). B<*> Drivers may return an indeterminate value if no insert has been performed yet. B<*> For some drivers the value may only be available if placeholders have I been used (e.g., Sybase, MS SQL). In this case the value returned would be from the last non-placeholder insert statement. B<*> Some drivers may need driver-specific hints about how to get the value. For example, being told the name of the database 'sequence' object that holds the value. Any such hints are passed as driver-specific attributes in the \%attr parameter. B<*> If the underlying database offers nothing better, then some drivers may attempt to implement this method by executing "C statements. If a row cache is not implemented, then setting C is ignored and getting the value returns C. Some C values have special meaning, as follows: 0 - Automatically determine a reasonable cache size for each C. Note that large cache sizes may require a very large amount of memory (I). Also, a large cache will cause a longer delay not only for the first fetch, but also whenever the cache needs refilling. See also the L statement handle attribute. =head3 C Type: string Returns the username used to connect to the database. =head1 DBI STATEMENT HANDLE OBJECTS This section lists the methods and attributes associated with DBI statement handles. =head2 Statement Handle Methods The DBI defines the following methods for use on DBI statement handles: =head3 C $sth->bind_param($p_num, $bind_value) $sth->bind_param($p_num, $bind_value, \%attr) $sth->bind_param($p_num, $bind_value, $bind_type) The C method takes a copy of $bind_value and associates it (binds it) with a placeholder, identified by $p_num, embedded in the prepared statement. Placeholders are indicated with question mark character (C). For example: $dbh->{RaiseError} = 1; # save having to check each method call $sth = $dbh->prepare("SELECT name, age FROM people WHERE name LIKE ?"); $sth->bind_param(1, "John%"); # placeholders are numbered from 1 $sth->execute; DBI::dump_results($sth); See L for more information. B The C<\%attr> parameter can be used to hint at the data type the placeholder should have. This is rarely needed. Typically, the driver is only interested in knowing if the placeholder should be bound as a number or a string. $sth->bind_param(1, $value, { TYPE => SQL_INTEGER }); As a short-cut for the common case, the data type can be passed directly, in place of the C<\%attr> hash reference. This example is equivalent to the one above: $sth->bind_param(1, $value, SQL_INTEGER); The C value indicates the standard (non-driver-specific) type for this parameter. To specify the driver-specific type, the driver may support a driver-specific attribute, such as C<{ ora_type =E 97 }>. The SQL_INTEGER and other related constants can be imported using use DBI qw(:sql_types); See L for more information. The data type is 'sticky' in that bind values passed to execute() are bound with the data type specified by earlier bind_param() calls, if any. Portable applications should not rely on being able to change the data type after the first C call. Perl only has string and number scalar data types. All database types that aren't numbers are bound as strings and must be in a format the database will understand except where the bind_param() TYPE attribute specifies a type that implies a particular format. For example, given: $sth->bind_param(1, $value, SQL_DATETIME); the driver should expect $value to be in the ODBC standard SQL_DATETIME format, which is 'YYYY-MM-DD HH:MM:SS'. Similarly for SQL_DATE, SQL_TIME etc. As an alternative to specifying the data type in the C call, you can let the driver pass the value as the default type (C). You can then use an SQL function to convert the type within the statement. For example: INSERT INTO price(code, price) VALUES (?, CONVERT(MONEY,?)) The C function used here is just an example. The actual function and syntax will vary between different databases and is non-portable. See also L for more information. =head3 C $rc = $sth->bind_param_inout($p_num, \$bind_value, $max_len) or die $sth->errstr; $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, \%attr) or ... $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, $bind_type) or ... This method acts like L, but also enables values to be updated by the statement. The statement is typically a call to a stored procedure. The C<$bind_value> must be passed as a reference to the actual value to be used. Note that unlike L, the C<$bind_value> variable is not copied when C is called. Instead, the value in the variable is read at the time L is called. The additional C<$max_len> parameter specifies the minimum amount of memory to allocate to C<$bind_value> for the new value. If the value returned from the database is too big to fit, then the execution should fail. If unsure what value to use, pick a generous length, i.e., a length larger than the longest value that would ever be returned. The only cost of using a larger value than needed is wasted memory. Undefined values or C are used to indicate null values. See also L for more information. =head3 C $rc = $sth->bind_param_array($p_num, $array_ref_or_value) $rc = $sth->bind_param_array($p_num, $array_ref_or_value, \%attr) $rc = $sth->bind_param_array($p_num, $array_ref_or_value, $bind_type) The C method is used to bind an array of values to a placeholder embedded in the prepared statement which is to be executed with L. For example: $dbh->{RaiseError} = 1; # save having to check each method call $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name, dept) VALUES(?, ?, ?)"); $sth->bind_param_array(1, [ 'John', 'Mary', 'Tim' ]); $sth->bind_param_array(2, [ 'Booth', 'Todd', 'Robinson' ]); $sth->bind_param_array(3, "SALES"); # scalar will be reused for each row $sth->execute_array( { ArrayTupleStatus => \my @tuple_status } ); The C<%attr> ($bind_type) argument is the same as defined for L. Refer to L for general details on using placeholders. (Note that bind_param_array() can I be used to expand a placeholder into a list of values for a statement like "SELECT foo WHERE bar IN (?)". A placeholder can only ever represent one value per execution.) Scalar values, including C, may also be bound by C. In which case the same value will be used for each L call. Driver-specific implementations may behave differently, e.g., when binding to a stored procedure call, some databases may permit mixing scalars and arrays as arguments. The default implementation provided by DBI (for drivers that have not implemented array binding) is to iteratively call L for each parameter tuple provided in the bound arrays. Drivers may provide more optimized implementations using whatever bulk operation support the database API provides. The default driver behaviour should match the default DBI behaviour, but always consult your driver documentation as there may be driver specific issues to consider. Note that the default implementation currently only supports non-data returning statements (INSERT, UPDATE, but not SELECT). Also, C and L cannot be mixed in the same statement execution, and C must be used with L; using C will have no effect for L. The C method was added in DBI 1.22. =head3 C $rv = $sth->execute or die $sth->errstr; $rv = $sth->execute(@bind_values) or die $sth->errstr; Perform whatever processing is necessary to execute the prepared statement. An C is returned if an error occurs. A successful C always returns true regardless of the number of rows affected, even if it's zero (see below). It is always important to check the return status of C (and most other DBI methods) for errors if you're not using L. For a I-C statements, execute simply "starts" the query within the database engine. Use one of the fetch methods to retrieve the data after calling C. The C method does I return the number of rows that will be returned by the query (because most databases can't tell in advance), it simply returns a true value. You can tell if the statement was a C" will return only a single key from C. In these cases use column aliases or C. Note that it is the database server (and not the DBD implementation) which provides the I for fields containing functions like "C" or "C" and they may clash with existing column names (most databases don't care about duplicate column names in a result-set). If you want these to return as unique names that are the same across databases, use I, as in "C" depending on the syntax your database supports. Because of the extra work C and Perl have to perform, it is not as efficient as C or C. By default a reference to a new hash is returned for each row. It is likely that a future version of the DBI will support an attribute which will enable the same hash to be reused for each row. This will give a significant performance boost, but it won't be enabled by default because of the risk of breaking old code. =head3 C $tbl_ary_ref = $sth->fetchall_arrayref; $tbl_ary_ref = $sth->fetchall_arrayref( $slice ); $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); The C method can be used to fetch all the data to be returned from a prepared and executed statement handle. It returns a reference to an array that contains one reference per row. If called on an I statement handle, C returns undef. If there are no rows left to return from an I statement handle, C returns a reference to an empty array. If an error occurs, C returns the data fetched thus far, which may be none. You should check C<$sth-Eerr> afterwards (or use the C attribute) to discover if the data is complete or was truncated due to an error. If $slice is an array reference, C uses L to fetch each row as an array ref. If the $slice array is not empty then it is used as a slice to select individual columns by perl array index number (starting at 0, unlike column and parameter numbers which start at 1). With no parameters, or if $slice is undefined, C acts as if passed an empty array ref. For example, to fetch just the first column of every row: $tbl_ary_ref = $sth->fetchall_arrayref([0]); To fetch the second to last and last column of every row: $tbl_ary_ref = $sth->fetchall_arrayref([-2,-1]); Those two examples both return a reference to an array of array refs. If $slice is a hash reference, C fetches each row as a hash reference. If the $slice hash is empty then the keys in the hashes have whatever name lettercase is returned by default. (See L attribute.) If the $slice hash is I empty, then it is used as a slice to select individual columns by name. The values of the hash should be set to 1. The key names of the returned hashes match the letter case of the names in the parameter hash, regardless of the L attribute. For example, to fetch all fields of every row as a hash ref: $tbl_ary_ref = $sth->fetchall_arrayref({}); To fetch only the fields called "foo" and "bar" of every row as a hash ref (with keys named "foo" and "BAR", regardless of the original capitalization): $tbl_ary_ref = $sth->fetchall_arrayref({ foo=>1, BAR=>1 }); Those two examples both return a reference to an array of hash refs. If $slice is a I, that hash is used to select and rename columns. The keys are 0-based column index numbers and the values are the corresponding keys for the returned row hashes. For example, to fetch only the first and second columns of every row as a hash ref (with keys named "k" and "v" regardless of their original names): $tbl_ary_ref = $sth->fetchall_arrayref( \{ 0 => 'k', 1 => 'v' } ); If $max_rows is defined and greater than or equal to zero then it is used to limit the number of rows fetched before returning. fetchall_arrayref() can then be called again to fetch more rows. This is especially useful when you need the better performance of fetchall_arrayref() but don't have enough memory to fetch and return all the rows in one go. Here's an example (assumes RaiseError is enabled): my $rows = []; # cache for batches of rows while( my $row = ( shift(@$rows) || # get row from cache, or reload cache: shift(@{$rows=$sth->fetchall_arrayref(undef,10_000)||[]}) ) ) { ... } That I be the fastest way to fetch and process lots of rows using the DBI, but it depends on the relative cost of method calls vs memory allocation. A standard C loop with column binding is often faster because the cost of allocating memory for the batch of rows is greater than the saving by reducing method calls. It's possible that the DBI may provide a way to reuse the memory of a previous batch in future, which would then shift the balance back towards fetchall_arrayref(). =head3 C $hash_ref = $sth->fetchall_hashref($key_field); The C method can be used to fetch all the data to be returned from a prepared and executed statement handle. It returns a reference to a hash containing a key for each distinct value of the $key_field column that was fetched. For each key the corresponding value is a reference to a hash containing all the selected columns and their values, as returned by C. If there are no rows to return, C returns a reference to an empty hash. If an error occurs, C returns the data fetched thus far, which may be none. You should check C<$sth-Eerr> afterwards (or use the C attribute) to discover if the data is complete or was truncated due to an error. The $key_field parameter provides the name of the field that holds the value to be used for the key for the returned hash. For example: $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->prepare("SELECT FOO, BAR, ID, NAME, BAZ FROM TABLE"); $sth->execute; $hash_ref = $sth->fetchall_hashref('id'); print "Name for id 42 is $hash_ref->{42}->{name}\n"; The $key_field parameter can also be specified as an integer column number (counting from 1). If $key_field doesn't match any column in the statement, as a name first then as a number, then an error is returned. For queries returning more than one 'key' column, you can specify multiple column names by passing $key_field as a reference to an array containing one or more key column names (or index numbers). For example: $sth = $dbh->prepare("SELECT foo, bar, baz FROM table"); $sth->execute; $hash_ref = $sth->fetchall_hashref( [ qw(foo bar) ] ); print "For foo 42 and bar 38, baz is $hash_ref->{42}->{38}->{baz}\n"; The fetchall_hashref() method is normally used only where the key fields values for each row are unique. If multiple rows are returned with the same values for the key fields then later rows overwrite earlier ones. =head3 C ... not yet documented ... =head3 C $rc = $sth->finish; Indicate that no more data will be fetched from this statement handle before it is either executed again or destroyed. You almost certainly do I need to call this method. Adding calls to C after loop that fetches all rows is a common mistake, don't do it, it can mask genuine problems like uncaught fetch errors. When all the data has been fetched from a C C (for some specific operations like C and C), or after fetching all the rows of a C statements, it is generally not possible to know how many rows will be returned except by fetching them all. Some drivers will return the number of rows the application has fetched so far, but others may return -1 until all rows have been fetched. So use of the C method or C<$DBI::rows> with C is to execute a "SELECT COUNT(*) FROM ..." SQL statement with the same "..." as your query and then fetch the row count from that. =head3 C $rc = $sth->bind_col($column_number, \$var_to_bind); $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr ); $rc = $sth->bind_col($column_number, \$var_to_bind, $bind_type ); Binds a Perl variable and/or some attributes to an output column (field) of a C statement. The list of references should have the same number of elements as the number of columns in the C statements, then this attribute holds the number of un-fetched rows in the cache. If the driver doesn't, then it returns C. Note that some drivers pre-fetch rows on execute, whereas others wait till the first fetch. See also the L database handle attribute. =head1 FURTHER INFORMATION =head2 Catalog Methods An application can retrieve metadata information from the DBMS by issuing appropriate queries on the views of the Information Schema. Unfortunately, C views are seldom supported by the DBMS. Special methods (catalog methods) are available to return result sets for a small but important portion of that metadata: column_info foreign_key_info primary_key_info table_info statistics_info All catalog methods accept arguments in order to restrict the result sets. Passing C to an optional argument does not constrain the search for that argument. However, an empty string ('') is treated as a regular search criteria and will only match an empty value. B: SQL/CLI and ODBC differ in the handling of empty strings. An empty string will not restrict the result set in SQL/CLI. Most arguments in the catalog methods accept only I, e.g. the arguments of C. Such arguments are treated as a literal string, i.e. the case is significant and quote characters are taken literally. Some arguments in the catalog methods accept I (strings containing '_' and/or '%'), e.g. the C<$table> argument of C. Passing '%' is equivalent to leaving the argument C. B: The underscore ('_') is valid and often used in SQL identifiers. Passing such a value to a search pattern argument may return more rows than expected! To include pattern characters as literals, they must be preceded by an escape character which can be achieved with $esc = $dbh->get_info( 14 ); # SQL_SEARCH_PATTERN_ESCAPE $search_pattern =~ s/([_%])/$esc$1/g; The ODBC and SQL/CLI specifications define a way to change the default behaviour described above: All arguments (except I) are treated as I if the C attribute is set to C. I are very similar to I, i.e. their body (the string within the quotes) is interpreted literally. I are compared in UPPERCASE. The DBI (currently) does not support the C attribute, i.e. it behaves like an ODBC driver where C is set to C. =head2 Transactions Transactions are a fundamental part of any robust database system. They protect against errors and database corruption by ensuring that sets of related changes to the database take place in atomic (indivisible, all-or-nothing) units. This section applies to databases that support transactions and where C is off. See L for details of using C with various types of databases. The recommended way to implement robust transactions in Perl applications is to enable L and catch the error that's 'thrown' as an exception. For example, using L: use Try::Tiny; $dbh->{AutoCommit} = 0; # enable transactions, if possible $dbh->{RaiseError} = 1; try { foo(...) # do lots of work here bar(...) # including inserts baz(...) # and updates $dbh->commit; # commit the changes if we get this far } catch { warn "Transaction aborted because $_"; # Try::Tiny copies $@ into $_ # now rollback to undo the incomplete changes # but do it in an eval{} as it may also fail eval { $dbh->rollback }; # add other application on-error-clean-up code here }; If the C attribute is not set, then DBI calls would need to be manually checked for errors, typically like this: $h->method(@args) or die $h->errstr; With C set, the DBI will automatically C if any DBI method call on that handle (or a child handle) fails, so you don't have to test the return value of each method call. See L for more details. A major advantage of the C approach is that the transaction will be properly rolled back if I code (not just DBI calls) in the inner application dies for any reason. The major advantage of using the C<$h-E{RaiseError}> attribute is that all DBI calls will be checked automatically. Both techniques are strongly recommended. After calling C or C many drivers will not let you fetch from a previously active C statements. See L and L for other important information about transactions. =head2 Handling BLOB / LONG / Memo Fields Many databases support "blob" (binary large objects), "long", or similar datatypes for holding very long strings or large amounts of binary data in a single field. Some databases support variable length long values over 2,000,000,000 bytes in length. Since values of that size can't usually be held in memory, and because databases can't usually know in advance the length of the longest long that will be returned from a C