Win32::DBIODBC - Win32::ODBC emulation layer for the DBI
25 | 26 |use Win32::DBIODBC; # instead of use Win32::ODBCThis is a very basic very alpha quality Win32::ODBC emulation for the DBI. To use it just replace
33 | 34 |use Win32::ODBC;in your scripts with
37 | 38 |use Win32::DBIODBC;or, while experimenting, you can pre-load this module without changing your scripts by doing
41 | 42 |perl -MWin32::DBIODBC your_script_nameError handling is virtually non-existent.
47 | 48 |Tom Horen <tho@melexis.com>
51 | 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /lib/DBD/Gofer/Policy/pedantic.pm: -------------------------------------------------------------------------------- 1 | package DBD::Gofer::Policy::pedantic; 2 | 3 | # $Id: pedantic.pm 10087 2007-10-16 12:42:37Z Tim $ 4 | # 5 | # Copyright (c) 2007, Tim Bunce, Ireland 6 | # 7 | # You may distribute under the terms of either the GNU General Public 8 | # License or the Artistic License, as specified in the Perl README file. 9 | 10 | use strict; 11 | use warnings; 12 | 13 | our $VERSION = "0.010088"; 14 | 15 | use base qw(DBD::Gofer::Policy::Base); 16 | 17 | # the 'pedantic' policy is the same as the Base policy 18 | 19 | 1; 20 | 21 | =head1 NAME 22 | 23 | DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer 24 | 25 | =head1 SYNOPSIS 26 | 27 | $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...) 28 | 29 | =head1 DESCRIPTION 30 | 31 | The CDBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer
25 | 26 |$dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...)The classic policy is the default DBD::Gofer policy, so need not be included in the DSN.
Temporary docs: See the source code for list of policies and their defaults.
35 | 36 |In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
37 | 38 |Tim Bunce, http://www.tim.bunce.name
41 | 42 |Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
45 | 46 |This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic.
47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /Old/TASKS.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | TASKS - Want to help? These things need doing... 4 | 5 | =head2 Increase test coverage 6 | 7 | More tests need to be added to test the codes that not urrently being tested. 8 | 9 | It's pretty poor right now: 10 | 11 | http://pjcj.sytes.net/cover/latest/DBI-1.52/coverage.html 12 | 13 | Start with improving the subroutine coverage 14 | 15 | http://pjcj.sytes.net/cover/latest/DBI-1.52/blib-lib-DBI-pm--subroutine.html 16 | 17 | =head2 Test the proxy 18 | 19 | The current t/80proxy.t is isolated from the rest of the test suite so actually 20 | tests very little, and what it does test is duplicating other tests. 21 | 22 | Ideally the proxy should be tested in the same way as DBI::PurePerl. In other 23 | words, by creating wrappers test files for each test file that set 24 | $ENV{DBI_AUTOPROXY} and run the original test. They'll also need to start and 25 | stop a proxy server. 26 | 27 | =head2 Fixing bugs 28 | 29 | The official bug list is here: 30 | 31 | http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBI 32 | 33 | Naturally I'll offer direction and guidance on any you want to tackle. 34 | I've also got a few that could be entered into rt.cpan.org. 35 | 36 | =head2 Others 37 | 38 | General: 39 | 40 | Protect trace_msg from SIGPIPE? 41 | prepare(...,{ Err=>\my $isolated_err, ...}) 42 | Add trace module that just records the last N trace messages into an array 43 | and prepends them to any error message to provide context for the error. 44 | Document DBI_PROFILE_FLOCK and LockFile attrib in DBI::ProfileData and DBI::ProfileDumper 45 | 46 | Performance: 47 | 48 | Move _new_sth to DBI::db::_new_sth (leave alias) and implement in C 49 | Or call _new_child and move to DBI::common? 50 | 51 | Implement FETCH_many() in C 52 | 53 | Add high-res dbi_time for windows - via Time::HiRes glob replace dbi_time()? 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /Perl.xs: -------------------------------------------------------------------------------- 1 | /* This is a skeleton driver that only serves as a basic sanity check 2 | that the Driver.xst mechansim doesn't have compile-time errors in it. 3 | vim: ts=8:sw=4:expandtab 4 | */ 5 | 6 | #define PERL_NO_GET_CONTEXT 7 | #include "DBIXS.h" 8 | #include "dbd_xsh.h" 9 | 10 | #undef DBIh_SET_ERR_CHAR /* to syntax check emulation */ 11 | #include "dbivport.h" 12 | 13 | DBISTATE_DECLARE; 14 | 15 | 16 | struct imp_drh_st { 17 | dbih_drc_t com; /* MUST be first element in structure */ 18 | }; 19 | struct imp_dbh_st { 20 | dbih_dbc_t com; /* MUST be first element in structure */ 21 | }; 22 | struct imp_sth_st { 23 | dbih_stc_t com; /* MUST be first element in structure */ 24 | }; 25 | 26 | 27 | 28 | #define dbd_discon_all(drh, imp_drh) (drh=drh,imp_drh=imp_drh,1) 29 | #define dbd_dr_data_sources(drh, imp_drh, attr) (drh=drh,imp_drh=imp_drh,attr=attr,Nullav) 30 | #define dbd_db_do4_iv(dbh,imp_dbh,p3,p4) (dbh=dbh,imp_dbh=imp_dbh,(void*)p3,p4=p4,-2) 31 | #define dbd_db_last_insert_id(dbh, imp_dbh, p3,p4,p5,p6, attr) \ 32 | (dbh=dbh,imp_dbh=imp_dbh,p3=p3,p4=p4,p5=p5,p6=p6,attr=attr,&PL_sv_undef) 33 | #define dbd_take_imp_data(h, imp_xxh, p3) (h=h,imp_xxh=imp_xxh,&PL_sv_undef) 34 | #define dbd_st_execute_for_fetch(sth, imp_sth, p3, p4) \ 35 | (sth=sth,imp_sth=imp_sth,p3=p3,p4=p4,&PL_sv_undef) 36 | 37 | #define dbd_st_bind_col(sth, imp_sth, param, ref, sql_type, attribs) \ 38 | (sth=sth,imp_sth=imp_sth,param=param,ref=ref,sql_type=sql_type,attribs=attribs,1) 39 | 40 | int /* just to test syntax of macros etc */ 41 | dbd_st_rows(SV *h, imp_sth_t *imp_sth) 42 | { 43 | dTHX; 44 | PERL_UNUSED_VAR(h); 45 | DBIh_SET_ERR_CHAR(h, imp_sth, 0, 1, "err msg", "12345", Nullch); 46 | return -1; 47 | } 48 | 49 | 50 | MODULE = DBD::Perl PACKAGE = DBD::Perl 51 | 52 | INCLUDE: Perl.xsi 53 | 54 | # vim:sw=4:ts=8 55 | -------------------------------------------------------------------------------- /doc/DBD-Gofer-Policy-rush.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer
25 | 26 |$dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...)The rush policy tries to make as few round-trips as possible. It's the opposite end of the policy spectrum to the pedantic policy.
Temporary docs: See the source code for list of policies and their defaults.
35 | 36 |In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
37 | 38 |Tim Bunce, http://www.tim.bunce.name
41 | 42 |Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
45 | 46 |This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic.
47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /t/14utf8.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | # vim:ts=8:sw=4 3 | $|=1; 4 | 5 | use Test::More; 6 | use DBI; 7 | 8 | eval { 9 | require Storable; 10 | import Storable qw(dclone); 11 | require Encode; 12 | import Encode qw(_utf8_on _utf8_off is_utf8); 13 | }; 14 | 15 | plan skip_all => "Unable to load required module ($@)" 16 | unless defined &_utf8_on; 17 | 18 | plan tests => 16; 19 | 20 | $dbh = DBI->connect("dbi:Sponge:foo","","", { 21 | PrintError => 0, 22 | RaiseError => 1, 23 | }); 24 | 25 | my $source_rows = [ # data for DBD::Sponge to return via fetch 26 | [ 41, "AAA", 9 ], 27 | [ 42, "BB", undef ], 28 | [ 43, undef, 7 ], 29 | [ 44, "DDD", 6 ], 30 | ]; 31 | 32 | my($sth, $col0, $col1, $col2, $rows); 33 | 34 | # set utf8 on one of the columns so we can check it carries through into the 35 | # keys of fetchrow_hashref 36 | my @col_names = qw(Col1 Col2 Col3); 37 | _utf8_on($col_names[1]); 38 | ok is_utf8($col_names[1]); 39 | ok !is_utf8($col_names[0]); 40 | 41 | $sth = $dbh->prepare("foo", { 42 | rows => dclone($source_rows), 43 | NAME => \@col_names, 44 | }); 45 | 46 | ok($sth->bind_columns(\($col0, $col1, $col2)) ); 47 | ok($sth->execute(), $DBI::errstr); 48 | 49 | ok $sth->fetch; 50 | cmp_ok $col1, 'eq', "AAA"; 51 | ok !is_utf8($col1); 52 | 53 | # force utf8 flag on 54 | _utf8_on($col1); 55 | ok is_utf8($col1); 56 | 57 | ok $sth->fetch; 58 | cmp_ok $col1, 'eq', "BB"; 59 | # XXX sadly this test doesn't detect the problem when using DBD::Sponge 60 | # because DBD::Sponge uses $sth->_set_fbav (correctly) and that uses 61 | # sv_setsv which doesn't have the utf8 persistence that sv_setpv does. 62 | ok !is_utf8($col1); # utf8 flag should have been reset 63 | 64 | ok $sth->fetch; 65 | ok !defined $col1; # null 66 | ok !is_utf8($col1); # utf8 flag should have been reset 67 | 68 | ok my $hash = $sth->fetchrow_hashref; 69 | ok 1 == grep { is_utf8($_) } keys %$hash; 70 | 71 | $sth->finish; 72 | 73 | # end 74 | -------------------------------------------------------------------------------- /lib/DBI/Util/_accessor.pm: -------------------------------------------------------------------------------- 1 | package DBI::Util::_accessor; 2 | use strict; 3 | use warnings; 4 | use Carp; 5 | our $VERSION = "0.009479"; 6 | 7 | # inspired by Class::Accessor::Fast 8 | 9 | sub new { 10 | my($proto, $fields) = @_; 11 | my($class) = ref $proto || $proto; 12 | $fields ||= {}; 13 | 14 | my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields; 15 | carp "$class doesn't have accessors for fields: @dubious" if @dubious; 16 | 17 | # make a (shallow) copy of $fields. 18 | bless {%$fields}, $class; 19 | } 20 | 21 | sub mk_accessors { 22 | my($self, @fields) = @_; 23 | $self->mk_accessors_using('make_accessor', @fields); 24 | } 25 | 26 | sub mk_accessors_using { 27 | my($self, $maker, @fields) = @_; 28 | my $class = ref $self || $self; 29 | 30 | # So we don't have to do lots of lookups inside the loop. 31 | $maker = $self->can($maker) unless ref $maker; 32 | 33 | no strict 'refs'; 34 | foreach my $field (@fields) { 35 | my $accessor = $self->$maker($field); 36 | *{$class."\:\:$field"} = $accessor 37 | unless defined &{$class."\:\:$field"}; 38 | } 39 | #my $hash_ref = \%{$class."\:\:_accessors_hash}; 40 | #$hash_ref->{$_}++ for @fields; 41 | # XXX also copy down _accessors_hash of base class(es) 42 | # so one in this class is complete 43 | return; 44 | } 45 | 46 | sub make_accessor { 47 | my($class, $field) = @_; 48 | return sub { 49 | my $self = shift; 50 | return $self->{$field} unless @_; 51 | croak "Too many arguments to $field" if @_ > 1; 52 | return $self->{$field} = shift; 53 | }; 54 | } 55 | 56 | sub make_accessor_autoviv_hashref { 57 | my($class, $field) = @_; 58 | return sub { 59 | my $self = shift; 60 | return $self->{$field} ||= {} unless @_; 61 | croak "Too many arguments to $field" if @_ > 1; 62 | return $self->{$field} = shift; 63 | }; 64 | } 65 | 66 | 1; 67 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | BEFORE BUILDING, TESTING AND INSTALLING this you will need to: 2 | 3 | Build, test and install a recent version of Perl 5 4 | It is very important to test it and actually install it! 5 | (You can use "Configure -Dprefix=..." to build a private copy.) 6 | 7 | BUILDING 8 | 9 | perl Makefile.PL 10 | make 11 | make test 12 | make test TEST_VERBOSE=1 (if any of the t/* tests fail) 13 | make install (if the tests look okay) 14 | 15 | The perl you use to execute Makefile.PL should be the first one in your PATH. 16 | If you want to use some installed perl then modify your PATH to match. 17 | 18 | IF YOU HAVE PROBLEMS 19 | 20 | --- 21 | If you get an error like "gcc: command not found" or "cc: command not found" 22 | you need to either install a compiler, or you may be able to install a 23 | precompiled binary of DBI using a package manager (e.g., ppm for ActiveState, 24 | Synaptic for Ubuntu, port for FreeBSD etc) 25 | 26 | --- 27 | If you get compiler errors referring to Perl's own header files 28 | (.../CORE/...h) or the compiler complains about bad options etc then 29 | there is something wrong with your perl installation. If the compiler complains 30 | of missing files (.../perl.h: error: sys/types.h: No such file) then you may 31 | need to install extra packages for your operating system. 32 | 33 | Generally it's best to use a Perl that was built on the system you are trying 34 | to use and it's also important to use the same compiler that was used to build 35 | the Perl you are using. 36 | 37 | If you installed Perl using a binary distribution, such as ActiveState Perl, 38 | or if Perl came installed with the operating system you use, such as Debian or 39 | Ubuntu, then you may be able to install a precompiled binary of DBI using a 40 | package manager. Check the package manager for your distribution of Perl (e.g. 41 | ppm for ActiveState) or for your operating system (e.g Synaptic for Ubuntu). 42 | 43 | --- 44 | If you get compiler warnings like "value computed is not used" and 45 | "unused variable" you can ignore them. 46 | 47 | -------------------------------------------------------------------------------- /t-mock/DBI/Test/Case/DBI/attributes/Executed.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, { AutoCommit => 0}); 6 | my %SQLS = ( 7 | 'SELECT' => 'SELECT 1+1', 8 | 'INSERT' => undef 9 | ); 10 | 11 | { #Check that calling execute on a statementhandler sets Executed to true on both the sth and the parent dbh 12 | 13 | my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); 14 | isa_ok($dbh, 'DBI::db'); 15 | 16 | my $sth = $dbh->prepare($SQLS{INSERT}); 17 | 18 | isa_ok($sth, 'DBI::st'); 19 | 20 | ok($sth->execute(), 'execute'); 21 | 22 | ok($sth->{Executed}, '$sth->{Executed} is true after execute() call'); 23 | ok($sth->FETCH('Executed'), '$sth->FETCH(Executed) is true after execute() call'); 24 | 25 | ok($dbh->{Executed}, '$dbh->{Executed} is true after execute() call'); 26 | ok($dbh->FETCH('Executed'), '$dbh->FETCH(Executed) is true after execute() call'); 27 | } 28 | 29 | { #Check that the Executed flag is cleared on the database handle when a commit\rollback is issued 30 | 31 | foreach my $method ( qw(commit rollback) ){ 32 | my $dbh = DBI->connect( @DB_CREDS[0..2], { AutoCommit => 0} ); 33 | isa_ok($dbh, 'DBI::db'); 34 | 35 | my $sth = $dbh->prepare($SQLS{INSERT}); 36 | isa_ok($sth, 'DBI::st'); 37 | 38 | ok($sth->execute(), 'execute'); 39 | 40 | ok($sth->{Executed}, '$sth->{Executed} is true after execute() call'); 41 | ok($sth->FETCH('Executed'), '$sth->FETCH(Executed) is true after execute() call'); 42 | 43 | ok($dbh->{Executed}, '$dbh->{Executed} is true after execute() call'); 44 | ok($dbh->FETCH('Executed'), '$dbh->FETCH(Executed) is true after execute() call'); 45 | 46 | ok($dbh->$method(), $method); 47 | 48 | #The Executed flag of the dbh should now be cleared by the commit or rollback call 49 | ok(!$dbh->{Executed}, '$dbh->{Executed} is false after ' . $method . ' call'); 50 | ok(!$dbh->FETCH('Executed'), '!$dbh->FETCH(Executed) is false after ' . $method . ' call'); 51 | } 52 | } 53 | done_testing(); -------------------------------------------------------------------------------- /t/04mods.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | $|=1; 3 | 4 | use strict; 5 | 6 | use Test::More tests => 12; 7 | 8 | ## ---------------------------------------------------------------------------- 9 | ## 04mods.t - ... 10 | ## ---------------------------------------------------------------------------- 11 | # Note: 12 | # the modules tested here are all marked as new and not guaranteed, so this if 13 | # they change, these will fail. 14 | ## ---------------------------------------------------------------------------- 15 | 16 | BEGIN { 17 | use_ok( 'DBI' ); 18 | 19 | # load these first, since the other two load them 20 | # and we want to catch the error first 21 | use_ok( 'DBI::Const::GetInfo::ANSI' ); 22 | use_ok( 'DBI::Const::GetInfo::ODBC' ); 23 | 24 | use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) ); 25 | use_ok( 'DBI::Const::GetInfoReturn', qw(%GetInfoReturnTypes %GetInfoReturnValues) ); 26 | } 27 | 28 | ## test GetInfoType 29 | 30 | cmp_ok(scalar(keys(%GetInfoType)), '>', 1, '... we have at least one key in the GetInfoType hash'); 31 | 32 | is_deeply( 33 | \%GetInfoType, 34 | { %DBI::Const::GetInfo::ANSI::InfoTypes, %DBI::Const::GetInfo::ODBC::InfoTypes }, 35 | '... the GetInfoType hash is constructed from the ANSI and ODBC hashes' 36 | ); 37 | 38 | ## test GetInfoReturnTypes 39 | 40 | cmp_ok(scalar(keys(%GetInfoReturnTypes)), '>', 1, '... we have at least one key in the GetInfoReturnType hash'); 41 | 42 | is_deeply( 43 | \%GetInfoReturnTypes, 44 | { %DBI::Const::GetInfo::ANSI::ReturnTypes, %DBI::Const::GetInfo::ODBC::ReturnTypes }, 45 | '... the GetInfoReturnType hash is constructed from the ANSI and ODBC hashes' 46 | ); 47 | 48 | ## test GetInfoReturnValues 49 | 50 | cmp_ok(scalar(keys(%GetInfoReturnValues)), '>', 1, '... we have at least one key in the GetInfoReturnValues hash'); 51 | 52 | # ... testing GetInfoReturnValues any further would be difficult 53 | 54 | ## test the two methods found in DBI::Const::GetInfoReturn 55 | 56 | can_ok('DBI::Const::GetInfoReturn', 'Format'); 57 | can_ok('DBI::Const::GetInfoReturn', 'Explain'); 58 | 59 | 1; 60 | -------------------------------------------------------------------------------- /doc/DBD-Gofer-Policy-pedantic.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer
25 | 26 |$dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...)The pedantic 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 classic policy or defining your own policy class.
Temporary docs: See the source code for list of policies and their defaults.
37 | 38 |In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
39 | 40 |Tim Bunce, http://www.tim.bunce.name
43 | 44 |Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
47 | 48 |This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic.
49 | 50 | 51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /t/73cachedkids.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | use Scalar::Util qw( weaken reftype refaddr blessed ); 4 | 5 | use DBI; 6 | use B (); 7 | use Tie::Hash (); 8 | use Test::More; 9 | 10 | my (%weak_dbhs, %weak_caches); 11 | 12 | # past this scope everything should be gone 13 | { 14 | 15 | ### get two identical connections 16 | my @dbhs = map { DBI->connect('dbi:ExampleP::memory:', undef, undef, { RaiseError => 1 }) } (1,2); 17 | 18 | ### get weakrefs on both handles 19 | %weak_dbhs = map { refdesc($_) => $_ } @dbhs; 20 | weaken $_ for values %weak_dbhs; 21 | 22 | ### tie the first one's cache 23 | if (1) { 24 | ok( 25 | tie( my %cache, 'Tie::StdHash'), 26 | refdesc($dbhs[0]) . ' cache tied' 27 | ); 28 | $dbhs[0]->{CachedKids} = \%cache; 29 | } 30 | 31 | ### prepare something on both 32 | $_->prepare_cached( 'SELECT name FROM .' ) 33 | for @dbhs; 34 | 35 | ### get weakrefs of both caches 36 | %weak_caches = map { 37 | sprintf( 'statement cache of %s (%s)', 38 | refdesc($_), 39 | refdesc($_->{CachedKids}) 40 | ) => $_->{CachedKids} 41 | } @dbhs; 42 | weaken $_ for values %weak_caches; 43 | 44 | ### check both caches have entries 45 | is (scalar keys %{$weak_caches{$_}}, 1, "One cached statement found in $_") 46 | for keys %weak_caches; 47 | 48 | ### check both caches have sane refcounts 49 | is ( refcount( $weak_caches{$_} ), 1, "Refcount of $_ correct") 50 | for keys %weak_caches; 51 | 52 | ### check both dbh have sane refcounts 53 | is ( refcount( $weak_dbhs{$_} ), 1, "Refcount of $_ correct") 54 | for keys %weak_dbhs; 55 | 56 | note "Exiting scope"; 57 | @dbhs=(); 58 | } 59 | 60 | # check both $dbh weakrefs are gone 61 | is ($weak_dbhs{$_}, undef, "$_ garbage collected") 62 | for keys %weak_dbhs; 63 | 64 | is ($weak_caches{$_}, undef, "$_ garbage collected") 65 | for keys %weak_caches; 66 | 67 | 68 | 69 | sub refdesc { 70 | sprintf '%s%s(0x%x)', 71 | ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ), 72 | reftype $_[0], 73 | refaddr($_[0]), 74 | ; 75 | } 76 | 77 | sub refcount { 78 | B::svref_2object($_[0])->REFCNT; 79 | } 80 | 81 | done_testing; 82 | -------------------------------------------------------------------------------- /doc/Bundle-DBI.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |Bundle::DBI - A bundle to install DBI and required modules.
25 | 26 |perl -MCPAN -e 'install Bundle::DBI'DBI - for to get to know thyself
33 | 34 |DBI::Shell 11.91 - the DBI command line shell
35 | 36 |Storable 2.06 - for DBD::Proxy, DBI::ProxyServer, DBD::Forward
37 | 38 |Net::Daemon 0.37 - for DBD::Proxy and DBI::ProxyServer
39 | 40 |RPC::PlServer 0.2016 - for DBD::Proxy and DBI::ProxyServer
41 | 42 |DBD::Multiplex 1.19 - treat multiple db handles as one
43 | 44 |This bundle includes all the modules used by the Perl Database Interface (DBI) module, created by Tim Bunce.
47 | 48 |A Bundle is a module that simply defines a collection of other modules. It is used by the CPAN module to automate the fetching, building and installing of modules from the CPAN ftp archive sites.
49 | 50 |This bundle does not deal with the various database drivers (e.g. DBD::Informix, DBD::Oracle etc), most of which require software from sources other than CPAN. You'll need to fetch and build those drivers yourself.
51 | 52 |Jonathan Leffler, Jochen Wiedmann and Tim Bunce.
55 | 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /dbivport.h: -------------------------------------------------------------------------------- 1 | /* dbivport.h 2 | 3 | Provides macros that enable greater portability between DBI versions. 4 | 5 | This file should be *copied* and included in driver distributions 6 | and #included into the source, after #include DBIXS.h 7 | 8 | New driver releases should include an updated copy of dbivport.h 9 | from the most recent DBI release. 10 | */ 11 | 12 | #ifndef DBI_VPORT_H 13 | #define DBI_VPORT_H 14 | 15 | #ifndef DBIh_SET_ERR_CHAR 16 | /* Emulate DBIh_SET_ERR_CHAR 17 | Only uses the err_i, errstr and state parameters. 18 | */ 19 | #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ 20 | sv_setiv(DBIc_ERR(imp_xxh), err_i); \ 21 | (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ 22 | sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) 23 | #endif 24 | 25 | #ifndef DBIcf_Executed 26 | #define DBIcf_Executed 0x080000 27 | #endif 28 | 29 | #ifndef DBIc_TRACE_LEVEL_MASK 30 | #define DBIc_TRACE_LEVEL_MASK 0x0000000F 31 | #define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 32 | #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) 33 | #define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) 34 | #define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) 35 | /* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) 36 | DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) 37 | */ 38 | #define DBIc_TRACE_MATCHES(s1, s2) \ 39 | ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ 40 | || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) 41 | /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level 42 | DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 43 | DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 44 | DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level 45 | */ 46 | #define DBIc_TRACE(imp, flags, flaglevel, level) \ 47 | ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ 48 | || (level && DBIc_TRACE_LEVEL(imp) >= level) ) 49 | #endif 50 | 51 | 52 | #endif /* !DBI_VPORT_H */ 53 | -------------------------------------------------------------------------------- /dbilogstrip.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # -*- perl -*- 3 | my $file = $ARGV[0] || 'dbilogstrip'; 4 | 5 | my $script = <<'SCRIPT'; 6 | ~startperl~ 7 | 8 | =head1 NAME 9 | 10 | dbilogstrip - filter to normalize DBI trace logs for diff'ing 11 | 12 | =head1 SYNOPSIS 13 | 14 | Read DBI trace file CDBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing
26 | 27 |$original_dsn = "...";
30 | DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...)or, enable by setting the DBI_AUTOPROXY environment variable:
33 | 34 |export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone"Connect via DBD::Gofer and execute each request by starting executing a subprocess.
39 | 40 |This is, as you might imagine, spectacularly inefficient!
41 | 42 |It's only intended for testing. Specifically it demonstrates that the server side is completely stateless.
43 | 44 |It also provides a base class for the much more useful DBD::Gofer::Transport::stream transport.
45 | 46 |Tim Bunce, http://www.tim.bunce.name
49 | 50 |Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
53 | 54 |This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic.
55 | 56 |