Hello community,
here is the log from the commit of package perl-DBI for openSUSE:Factory
checked in at Wed Jan 12 09:36:17 CET 2011.
--------
--- perl-DBI/perl-DBI.changes 2010-12-01 14:43:12.000000000 +0100
+++ /mounts/work_src_done/STABLE/perl-DBI/perl-DBI.changes 2011-01-11 10:21:08.000000000 +0100
@@ -1,0 +2,15 @@
+Fri Jan 7 14:44:15 UTC 2011 - vcizek@novell.com
+
+- update to 1.616
+ * Fixed RT#61513 by catching attribute assignment to tied table access
+ interface (Jens Rehsack)
+ * Fixed compiler warnings RT#62640
+
+ * Optimized connect() to remove redundant FETCH of \%attrib values.
+ Improved initialization phases in DBI::DBD::SqlEngine (Jens Rehsack)
+
+ * Added DBD::Gofer::Transport::corostream. An experimental proof-of-concept
+ transport that enables asynchronous database calls with few code changes.
+ It enables asynchronous use of DBI frameworks like DBIx::Class.
+
+-------------------------------------------------------------------
calling whatdependson for head-i586
Old:
----
DBI-1.615.tar.bz2
New:
----
DBI-1.616.tar.bz2
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ perl-DBI.spec ++++++
--- /var/tmp/diff_new_pack.O8VWKT/_old 2011-01-12 09:35:42.000000000 +0100
+++ /var/tmp/diff_new_pack.O8VWKT/_new 2011-01-12 09:35:42.000000000 +0100
@@ -1,7 +1,7 @@
#
-# spec file for package perl-DBI (Version 1.615)
+# spec file for package perl-DBI (Version 1.616)
#
-# Copyright (c) 2010 SUSE LINUX Products GmbH, Nuernberg, Germany.
+# Copyright (c) 2011 SUSE LINUX Products GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -22,8 +22,8 @@
Name: perl-DBI
%define cpan_name DBI
Summary: Database independent interface for Perl
-Version: 1.615
-Release: 2
+Version: 1.616
+Release: 1
License: GPL+ or Artistic
Group: Development/Libraries/Perl
Url: http://search.cpan.org/dist/DBI/
++++++ DBI-1.615.tar.bz2 -> DBI-1.616.tar.bz2 ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/Changes new/DBI-1.616/Changes
--- old/DBI-1.615/Changes 2010-09-21 12:08:23.000000000 +0200
+++ new/DBI-1.616/Changes 2010-12-30 11:11:03.000000000 +0100
@@ -2,10 +2,38 @@
DBI::Changes - List of significant changes to the DBI
-(As of $Date: 2010-09-21 11:08:21 +0100 (Tue, 21 Sep 2010) $ $Revision: 14438 $)
+(As of $Date: 2010-12-30 10:10:54 +0000 (Thu, 30 Dec 2010) $ $Revision: 14616 $)
=cut
+=head2 Changes in DBI 1.616 (svn r14616) 30th December 2010
+
+ Fixed spurious dbi_profile lines written to the log when
+ profiling is enabled and a trace flag, like SQL, is used.
+ Fixed to recognize SQL::Statement errors even if instantiated
+ with RaiseError=0 (Jens Rehsack)
+ Fixed RT#61513 by catching attribute assignment to tied table access
+ interface (Jens Rehsack)
+ Fixing some misbehavior of DBD::File when running within the Gofer
+ server.
+ Fixed compiler warnings RT#62640
+
+ Optimized connect() to remove redundant FETCH of \%attrib values.
+ Improved initialization phases in DBI::DBD::SqlEngine (Jens Rehsack)
+
+ Added DBD::Gofer::Transport::corostream. An experimental proof-of-concept
+ transport that enables asynchronous database calls with few code changes.
+ It enables asynchronous use of DBI frameworks like DBIx::Class.
+
+ Added additional notes on DBDs which avoid creating a statement in
+ the do() method and the effects on error handlers (Martin J. Evans)
+ Adding new attribute "sql_dialect" to DBI::DBD::SqlEngine to allow
+ users control used SQL dialect (ANSI, CSV or AnyData), defaults to
+ CSV (Jens Rehsack)
+ Add documentation for DBI::DBD::SqlEngine attributes (Jens Rehsack)
+ Documented dbd_st_execute return (Martin J. Evans)
+ Fixed typo in InactiveDestroy thanks to Emmanuel Rodriguez.
+
=head2 Changes in DBI 1.615 (svn r14438) 21st September 2010
Fixed t/51dbm_file for file/directory names with whitespaces in them
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/DBI.pm new/DBI-1.616/DBI.pm
--- old/DBI-1.615/DBI.pm 2010-09-21 12:08:23.000000000 +0200
+++ new/DBI-1.616/DBI.pm 2010-12-22 00:06:18.000000000 +0100
@@ -1,4 +1,4 @@
-# $Id: DBI.pm 14438 2010-09-21 10:08:21Z timbo $
+# $Id: DBI.pm 14568 2010-12-14 15:23:58Z mjevans $
# vim: ts=8:sw=4:et
#
# Copyright (c) 1994-2010 Tim Bunce Ireland
@@ -9,7 +9,7 @@
require 5.008_001;
BEGIN {
-$DBI::VERSION = "1.615"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.616"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -124,8 +124,8 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.615
-($Revision: 14438 $).
+This is the DBI specification that corresponds to the DBI version 1.616
+($Revision: 14568 $).
The DBI is evolving at a steady pace, so it's good to check that
you have the latest copy.
@@ -717,7 +717,8 @@
$dbh->{$a} = delete $apply->{$a};
}
while ( my ($a, $v) = each %$apply) {
- eval { $dbh->{$a} = $v } or $@ && warn $@;
+ eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH
+ warn $@ if $@;
}
}
@@ -2511,6 +2512,7 @@
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.
@@ -3628,7 +3630,7 @@
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
-perent process to cease working.
+parent process to cease working.
Either the parent or the child process, but not both, should set
C<InactiveDestroy> true on all their shared handles. Alternatively the
@@ -4392,6 +4394,11 @@
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($catalog, $schema, $table, $field);
@@ -5827,10 +5834,11 @@
Type: string, read-only
-Returns the statement string passed to the most recent L</prepare> method
-called in this database handle, even if that method failed. This is especially
-useful where C<RaiseError> is enabled and the exception handler checks $@
-and sees that a 'prepare' method call failed.
+Returns the statement string passed to the most recent L</prepare> or
+L</do> method called in this database handle, even if that method
+failed. This is especially useful where C<RaiseError> is enabled and
+the exception handler checks $@ and sees that a 'prepare' method call
+failed.
=head3 C<RowCacheSize>
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/DBI.xs new/DBI-1.616/DBI.xs
--- old/DBI-1.615/DBI.xs 2010-09-18 13:07:11.000000000 +0200
+++ new/DBI-1.616/DBI.xs 2010-12-21 23:59:27.000000000 +0100
@@ -1,6 +1,6 @@
/* vim: ts=8:sw=4:expandtab
*
- * $Id: DBI.xs 14422 2010-09-17 20:38:27Z mjevans $
+ * $Id: DBI.xs 14545 2010-11-22 10:13:15Z timbo $
*
* Copyright (c) 1994-2009 Tim Bunce Ireland.
*
@@ -2130,15 +2130,28 @@
int upcase = (key[5] == 'u');
AV *av = Nullav;
HV *hv = Nullhv;
+ int num_fields_mismatch = 0;
+
if (strEQ(&key[strlen(key)-5], "_hash"))
hv = newHV();
else av = newAV();
i = DBIc_NUM_FIELDS(imp_sth);
- if (DBIc_TRACE_LEVEL(imp_sth) >= 10)
+
+ /* catch invalid NUM_FIELDS */
+ if (i != AvFILL(name_av)+1) {
+ /* flag as mismatch, except for "-1 and empty" case */
+ if ( ! (i == -1 && 0 == AvFILL(name_av)+1) )
+ num_fields_mismatch = 1;
+ i = AvFILL(name_av)+1; /* limit for safe iteration over array */
+ }
+
+ if (DBIc_TRACE_LEVEL(imp_sth) >= 10 || (num_fields_mismatch && DBIc_WARN(imp_xxh))) {
PerlIO_printf(DBILOGFP," FETCH $h->{%s} from $h->{NAME} with $h->{NUM_OF_FIELDS} = %d"
- " and %ld entries in $h->{NAME}\n",
- neatsvpv(keysv,0), i, AvFILL(name_av)+1);
- assert((i == -1 && 0 == AvFILL(name_av)+1) || (i == AvFILL(name_av)+1));
+ " and %ld entries in $h->{NAME}%s\n",
+ neatsvpv(keysv,0), DBIc_NUM_FIELDS(imp_sth), AvFILL(name_av)+1,
+ (num_fields_mismatch) ? " (possible bug in driver)" : "");
+ }
+
while (--i >= 0) {
sv = newSVsv(AvARRAY(name_av)[i]);
name = SvPV_nolen(sv);
@@ -2660,8 +2673,8 @@
}
statement_pv = SvPV_nolen(statement_sv);
- if (DBIc_DBISTATE(imp_xxh)->debug >= 4)
- PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile +%fs %s %s\n",
+ if (DBIc_TRACE_LEVEL(imp_xxh) >= 4)
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile +%" NVff "s %s %s\n",
ti, method_pv, neatsvpv(statement_sv,0));
dest_node = _profile_next_node(profile, "Data");
@@ -3075,11 +3088,12 @@
#ifdef DBI_USE_THREADS
{
- PerlInterpreter * h_perl = DBIc_THR_USER(imp_xxh) ;
+ PerlInterpreter * h_perl;
+ is_DESTROY_wrong_thread:
+ h_perl = DBIc_THR_USER(imp_xxh) ;
if (h_perl != my_perl) {
/* XXX could call a 'handle clone' method here?, for dbh's at least */
if (is_DESTROY) {
- is_DESTROY_wrong_thread:
if (trace_level >= 3) {
PerlIO_printf(DBILOGFP," DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n",
dbih_htype_name(DBIc_TYPE(imp_xxh)), HvNAME(DBIc_IMP_STASH(imp_xxh)),
@@ -3513,7 +3527,7 @@
if (is_DESTROY) /* show handle as first arg to DESTROY */
/* want to show outer handle so trace makes sense */
/* but outer handle has been destroyed so we fake it */
- PerlIO_printf(logfp,"(%s=HASH(%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh));
+ PerlIO_printf(logfp,"(%s=HASH(0x%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh));
else
PerlIO_printf(logfp,"(%s", neatsvpv(st1,0));
if (items >= 3)
@@ -4424,7 +4438,7 @@
#ifdef MULTIPLICITY
(void *)my_perl,
#else
- 0,
+ NULL,
#endif
log_where(Nullsv, 0, "", "", 1, 1, 0)
);
@@ -5040,7 +5054,7 @@
/* we don't test IMPSET here because this code applies to pure-perl drivers */
if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */
DBIc_ACTIVE_off(imp_sth);
- if (DBIc_DBISTATE(imp_sth)->debug)
+ if (DBIc_TRACE_LEVEL(imp_sth))
PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth));
}
if (DBIc_ACTIVE(imp_sth)) {
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/DBIXS.h new/DBI-1.616/DBIXS.h
--- old/DBI-1.615/DBIXS.h 2010-08-27 22:55:55.000000000 +0200
+++ new/DBI-1.616/DBIXS.h 2010-12-21 23:59:30.000000000 +0100
@@ -1,6 +1,6 @@
/* vim: ts=8:sw=4:expandtab
*
- * $Id: DBIXS.h 14343 2010-08-27 20:55:43Z timbo $
+ * $Id: DBIXS.h 14562 2010-12-06 10:26:17Z mjevans $
*
* Copyright (c) 1994-2010 Tim Bunce Ireland
*
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/dbixs_rev.h new/DBI-1.616/dbixs_rev.h
--- old/DBI-1.615/dbixs_rev.h 2010-08-30 21:49:00.000000000 +0200
+++ new/DBI-1.616/dbixs_rev.h 2010-12-22 00:05:44.000000000 +0100
@@ -1,2 +1,4 @@
-/* Mon Aug 30 20:49:00 2010 */
-#define DBIXS_REVISION 14354
+/* Tue Dec 14 22:26:28 2010 */
+/* Mixed revision working copy (14564M:14571) */
+/* Code modified since last checkin */
+#define DBIXS_REVISION 14564
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/ex/corogofer.pl new/DBI-1.616/ex/corogofer.pl
--- old/DBI-1.615/ex/corogofer.pl 1970-01-01 01:00:00.000000000 +0100
+++ new/DBI-1.616/ex/corogofer.pl 2010-12-29 15:05:20.000000000 +0100
@@ -0,0 +1,32 @@
+#!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_PUREPERL} = 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..5) {
+ warn "entering DBI...\n";
+ $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver
+ warn "...returned\n";
+}
+
+warn "done.";
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBD/DBM.pm new/DBI-1.616/lib/DBD/DBM.pm
--- old/DBI-1.615/lib/DBD/DBM.pm 2010-09-16 11:31:10.000000000 +0200
+++ new/DBI-1.616/lib/DBD/DBM.pm 2010-12-21 23:59:58.000000000 +0100
@@ -254,6 +254,8 @@
@DBD::DBM::Table::ISA = qw(DBD::File::Table);
+my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir';
+
sub file2table
{
my ( $self, $meta, $file, $file_is_table, $quoted ) = @_;
@@ -272,7 +274,7 @@
__PACKAGE__->register_reset_on_modify( \%reset_on_modify );
my %compat_map = (
- map { $_ => "dbm_$_" } qw(type mldbm store_metadata),
+ ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ),
dbm_ext => 'f_ext',
dbm_file => 'f_file',
dbm_lockfile => ' f_lockfile',
@@ -444,9 +446,9 @@
$meta->{hash} and untie %{ $meta->{hash} };
$self->SUPER::drop($data);
# XXX extra_files
- -f $meta->{f_fqbn} . '.dir'
+ -f $meta->{f_fqbn} . $dirfext
and $meta->{f_ext} eq '.pag/r'
- and unlink( $meta->{f_fqbn} . '.dir' );
+ and unlink( $meta->{f_fqbn} . $dirfext );
return 1;
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBD/File.pm new/DBI-1.616/lib/DBD/File.pm
--- old/DBI-1.615/lib/DBD/File.pm 2010-09-21 00:13:21.000000000 +0200
+++ new/DBI-1.616/lib/DBD/File.pm 2010-12-21 23:59:54.000000000 +0100
@@ -218,9 +218,16 @@
# DBI::BD::SqlEngine::dr::connect will detect old-style drivers and
# don't call twice
- defined $phase or $phase = 0;
+ 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) {
+ # check whether we're running in a Gofer server or not (see
+ # validate_FETCH_attr for details)
+ $dbh->{f_in_gofer} = (defined $INC{"DBD/Gofer.pm"} && (caller(5))[0] eq "DBI::Gofer::Execute");
# f_ext should not be initialized
# f_map is deprecated (but might return)
$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
@@ -234,7 +241,7 @@
my $ro_attrs = $drv_prefix . "readonly_attrs";
my @comp_attrs = ();
- if (exists $dbh->{$drv_prefix . "meta"}) {
+ if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{f_in_gofer}) {
my $attr = $dbh->{$drv_prefix . "meta"};
defined $attr and defined $dbh->{$valid_attrs} and
!defined $dbh->{$valid_attrs}{$attr} and
@@ -265,6 +272,27 @@
return $_[0]->SUPER::disconnect ();
} # 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
+ # f_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->{f_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 = "f_meta";
+ }
+
+ return $attrib;
+ } # validate_FETCH_attr
+
sub validate_STORE_attr
{
my ($dbh, $attrib, $value) = @_;
@@ -281,6 +309,18 @@
carp "'$value' doesn't look like a valid file extension attribute\n";
}
+ (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix ($drv_class);
+
+ if (exists $dbh->{$drv_prefix . "meta"}) {
+ my $attr = $dbh->{$drv_prefix . "meta"};
+ if ($attrib eq $attr) {
+ while (my ($k, $v) = each %$value) {
+ $dbh->{$attrib}{$k} = $v;
+ }
+ }
+ }
+
return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
} # validate_STORE_attr
@@ -866,10 +906,10 @@
# 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->{f_meta}{$table} && defined($dbh->{f_meta}{$table}{initialized})) {
+ if (defined $dbh->{f_meta}{$table} && defined $dbh->{f_meta}{$table}{initialized}) {
$meta = $dbh->{f_meta}{$table};
$self->file2table ($meta, $table, $file_is_table, $respect_case) or
- return unless ($dbh->{f_meta}{$table}{initialized});
+ return unless $dbh->{f_meta}{$table}{initialized};
}
unless ($dbh->{f_meta}{$table}{initialized}) {
$self->init_table_meta ($dbh, $meta, $table);
@@ -1145,9 +1185,9 @@
=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.
+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 The following DBI attributes and methods are not supported:
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBD/Gofer/Transport/corostream.pm new/DBI-1.616/lib/DBD/Gofer/Transport/corostream.pm
--- old/DBI-1.615/lib/DBD/Gofer/Transport/corostream.pm 1970-01-01 01:00:00.000000000 +0100
+++ new/DBI-1.616/lib/DBD/Gofer/Transport/corostream.pm 2010-12-29 15:11:44.000000000 +0100
@@ -0,0 +1,144 @@
+package 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<BIG WIN> from using L<Coro> is that it enables the use of existing
+DBI frameworks like LDBIx::Class.
+
+=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, Lhttp://www.tim.bunce.name
+
+=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<perlartistic>.
+
+=head1 SEE ALSO
+
+LDBD::Gofer::Transport::stream
+
+LDBD::Gofer
+
+=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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBD/Gofer/Transport/stream.pm new/DBI-1.616/lib/DBD/Gofer/Transport/stream.pm
--- old/DBI-1.615/lib/DBD/Gofer/Transport/stream.pm 2008-03-10 23:01:06.000000000 +0100
+++ new/DBI-1.616/lib/DBD/Gofer/Transport/stream.pm 2010-12-21 23:59:49.000000000 +0100
@@ -1,6 +1,6 @@
package DBD::Gofer::Transport::stream;
-# $Id: stream.pm 10905 2008-03-10 22:01:04Z timbo $
+# $Id: stream.pm 14598 2010-12-21 22:53:25Z timbo $
#
# Copyright (c) 2007, Tim Bunce, Ireland
#
@@ -14,7 +14,7 @@
use base qw(DBD::Gofer::Transport::pipeone);
-our $VERSION = sprintf("0.%06d", q$Revision: 10905 $ =~ /(\d+)/o);
+our $VERSION = sprintf("0.%06d", q$Revision: 14598 $ =~ /(\d+)/o);
__PACKAGE__->mk_accessors(qw(
go_persist
@@ -127,15 +127,16 @@
# send frozen request
local $\;
- print $wfh $encoded_request # autoflush enabled
+ $wfh->print($encoded_request) # autoflush enabled
or do {
- # XXX should make new connection and retry
+ my $err = $!;
+ # XXX could/should make new connection and retry
$self->_connection_kill;
- die "Error sending request: $!";
+ die "Error sending request: $err";
};
$self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4;
- return;
+ return undef; # indicate no response yet (so caller calls receive_response_by_transport)
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBD/NullP.pm new/DBI-1.616/lib/DBD/NullP.pm
--- old/DBI-1.615/lib/DBD/NullP.pm 2007-06-14 22:14:24.000000000 +0200
+++ new/DBI-1.616/lib/DBD/NullP.pm 2010-12-21 23:59:51.000000000 +0100
@@ -5,9 +5,9 @@
require Carp;
@EXPORT = qw(); # Do NOT @EXPORT anything.
- $VERSION = sprintf("12.%06d", q$Revision: 9215 $ =~ /(\d+)/o);
+ $VERSION = sprintf("12.%06d", q$Revision: 14563 $ =~ /(\d+)/o);
-# $Id: NullP.pm 9215 2007-03-08 17:03:58Z timbo $
+# $Id: NullP.pm 14563 2010-12-06 11:25:20Z timbo $
#
# Copyright (c) 1994-2007 Tim Bunce
#
@@ -118,6 +118,15 @@
$sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
$sth->STORE(Active => 1);
}
+ 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;
+ }
+ }
1;
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBI/DBD/SqlEngine.pm new/DBI-1.616/lib/DBI/DBD/SqlEngine.pm
--- old/DBI-1.615/lib/DBI/DBD/SqlEngine.pm 2010-09-16 11:31:10.000000000 +0200
+++ new/DBI-1.616/lib/DBI/DBD/SqlEngine.pm 2010-12-22 00:00:15.000000000 +0100
@@ -33,7 +33,7 @@
use Carp;
use vars qw( @ISA $VERSION $drh %methods_installed);
-$VERSION = "0.02";
+$VERSION = "0.03";
$drh = undef; # holds driver handle(s) once initialized
@@ -133,7 +133,8 @@
{
# 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};
+ my $two_phased_init;
+ defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase};
my %second_phase_attrs;
my ( $var, $val );
@@ -191,10 +192,8 @@
$dbh->func( 1, "init_default_attributes" );
%$attr = %second_phase_attrs;
}
- else
- {
- $dbh->func("init_done");
- }
+
+ $dbh->func("init_done");
$dbh->STORE( Active => 1 );
}
@@ -273,9 +272,9 @@
{
$stmt = eval { $class->new($statement) };
}
- if ($@)
+ if ($@ || $stmt->{errstr})
{
- $dbh->set_err( $DBI::stderr, $@ );
+ $dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} );
undef $sth;
}
else
@@ -317,12 +316,14 @@
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
};
$dbh->{sql_readonly_attrs} = {
sql_engine_version => 1, # DBI::DBD::SqlEngine version
@@ -348,6 +349,7 @@
{
# we have an "old" driver here
$phase = defined $dbh->{sql_init_phase};
+ $phase and $phase = $dbh->{sql_init_phase};
}
if ( 0 == $phase )
@@ -360,6 +362,8 @@
$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
@@ -381,34 +385,31 @@
and $dbh->{$ro_attrs}{$attr} = 1;
}
}
- else
- {
- delete $dbh->{sql_init_phase};
- }
return $dbh;
} # init_default_attributes
sub init_done
{
- delete $_[0]->{sql_init_phase};
+ 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 = {
- dialect => "CSV",
RaiseError => $dbh->FETCH("RaiseError"),
PrintError => $dbh->FETCH("PrintError"),
};
my $sql_flags = $dbh->FETCH("sql_flags") || {};
%$parser = ( %$parser, %$sql_flags );
- $parser = SQL::Parser->new( $parser->{dialect}, $parser );
+ $parser = SQL::Parser->new( $dialect, $parser );
$dbh->{sql_parser_object} = $parser;
return $parser;
-} # cache_sql_parser_object
+} # sql_parser_object
sub sql_sponge_driver
{
@@ -444,9 +445,12 @@
$attrib eq "AutoCommit"
and return 1;
+ # Driver private attributes are lower cased
if ( $attrib eq ( lc $attrib ) )
{
- # Driver private attributes are lower cased
+ # 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;
@@ -459,8 +463,6 @@
my $valid_attrs = $attr_prefix . "valid_attrs";
my $ro_attrs = $attr_prefix . "readonly_attrs";
- $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return;
-
exists $dbh->{$valid_attrs}
and ( $dbh->{$valid_attrs}{$attrib}
or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) );
@@ -1005,6 +1007,148 @@
likely change in the near future to provide the table meta data basics
like DBD::File.
+=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<readonly>)
+
+=head4 sql_nano_version
+
+Contains the module version of DBI::SQL::Nano (B<readonly>)
+
+=head4 sql_statement_version
+
+Contains the module version of SQL::Statement, if available (B<readonly>)
+
+=head4 sql_handler
+
+Contains the SQL Statement engine, either DBI::SQL::Nano or SQL::Statement
+(B<readonly>).
+
+=head4 sql_parser_object
+
+Contains an instantiated instance of SQL::Parser (B<readonly>).
+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<readonly>).
+
+=head4 sql_valid_attrs
+
+Contains the list of valid attributes for each DBI::DBD::SqlEngine based
+driver (B<readonly>).
+
+=head4 sql_readonly_attrs
+
+Contains the list of those attributes which are readonly (B<readonly>).
+
+=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<readonly>). 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 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).
+
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBI/DBD.pm new/DBI-1.616/lib/DBI/DBD.pm
--- old/DBI-1.615/lib/DBI/DBD.pm 2010-09-21 00:29:45.000000000 +0200
+++ new/DBI-1.616/lib/DBI/DBD.pm 2010-12-22 00:08:30.000000000 +0100
@@ -5,10 +5,10 @@
# 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
-$VERSION = sprintf("12.%06d", q$Id: DBD.pm 14436 2010-09-20 22:29:43Z timbo $ =~ /(\d+)/o);
+$VERSION = sprintf("12.%06d", q$Id: DBD.pm 14600 2010-12-21 23:08:28Z timbo $ =~ /(\d+)/o);
-# $Id: DBD.pm 14436 2010-09-20 22:29:43Z timbo $
+# $Id: DBD.pm 14600 2010-12-21 23:08:28Z timbo $
#
# Copyright (c) 1997-2006 Jonathan Leffler, Jochen Wiedmann, Steffen
# Goeldner and Tim Bunce
@@ -2308,6 +2308,10 @@
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
@@ -3333,7 +3337,7 @@
q|END { delete $ENV{DBI_AUTOPROXY}; }| ],
},
n => { name => "DBI::SQL::Nano",
- match => qr/^(?:49dbd_file|5\ddbm_\w+|85gofer)\.t$/,
+ match => qr/^(?:48dbi_dbd_sqlengine|49dbd_file|5\ddbm_\w+|85gofer)\.t$/,
add => [ q{$ENV{DBI_SQL_NANO} = 1},
q|END { delete $ENV{DBI_SQL_NANO}; }| ],
},
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/lib/DBI/SQL/Nano.pm new/DBI-1.616/lib/DBI/SQL/Nano.pm
--- old/DBI-1.615/lib/DBI/SQL/Nano.pm 2010-09-09 12:04:35.000000000 +0200
+++ new/DBI-1.616/lib/DBI/SQL/Nano.pm 2010-12-22 00:08:30.000000000 +0100
@@ -28,7 +28,7 @@
BEGIN
{
- $VERSION = sprintf( "1.%06d", q$Revision: 14371 $ =~ /(\d+)/o );
+ $VERSION = sprintf( "1.%06d", q$Revision: 14600 $ =~ /(\d+)/o );
$versions->{nano_version} = $VERSION;
if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.28' } )
@@ -110,7 +110,7 @@
$self->{where_clause} = $self->parse_where_clause($clauses) if ($clauses);
}
};
- /^\s*INSERT\s+INTO\s+(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
+ /^\s*INSERT\s+(?:INTO\s+)?(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
&& do
{
$self->{command} = 'INSERT';
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/MANIFEST new/DBI-1.616/MANIFEST
--- old/DBI-1.615/MANIFEST 2010-09-22 14:21:10.000000000 +0200
+++ new/DBI-1.616/MANIFEST 2010-12-30 11:16:28.000000000 +0100
@@ -21,6 +21,7 @@
dbixs_rev.pl Utility to write dbixs_rev.h
ex/perl_dbi_nulls_test.pl A test script for forms of IS NULL qualification in SQL
ex/profile.pl A test script for DBI::Profile
+ex/corogofer.pl A test script for DBD::Gofer::Transport::corostream
lib/Bundle/DBI.pm A bundle for automatic installation via CPAN.
lib/DBD/DBM.pm A driver for DBM files (uses DBD::File)
lib/DBD/ExampleP.pm A very simple example Driver module
@@ -34,6 +35,7 @@
lib/DBD/Gofer/Policy/classic.pm Reasonable policy for typical usage
lib/DBD/Gofer/Policy/rush.pm Raw speed, fewest round trips, least transparent
lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport classes
+lib/DBD/Gofer/Transport/corostream.pm Async Gofer transport using Coro and AnyEvent
lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes in same process (for testing)
lib/DBD/Gofer/Transport/pipeone.pm DBD::Gofer transport to new subprocess for each request
lib/DBD/Gofer/Transport/stream.pm DBD::Gofer transport for ssh etc
@@ -95,6 +97,7 @@
t/41prof_dump.t
t/42prof_data.t
t/43prof_env.t
+t/48dbi_dbd_sqlengine.t Tests for DBI::DBD::SqlEngine
t/49dbd_file.t DBD::File API and very basic tests
t/50dbm_simple.t simple DBD::DBM tests
t/51dbm_file.t extended DBD::File tests (through DBD::DBM)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/META.yml new/DBI-1.616/META.yml
--- old/DBI-1.615/META.yml 2010-09-22 14:21:10.000000000 +0200
+++ new/DBI-1.616/META.yml 2010-12-30 11:16:28.000000000 +0100
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: DBI
-version: 1.615
+version: 1.616
abstract: Database independent interface for Perl
author:
- Tim Bunce (dbi-users@perl.org)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/t/40profile.t new/DBI-1.616/t/40profile.t
--- old/DBI-1.615/t/40profile.t 2010-09-21 00:29:59.000000000 +0200
+++ new/DBI-1.616/t/40profile.t 2010-10-08 13:21:18.000000000 +0200
@@ -3,7 +3,7 @@
#
# test script for DBI::Profile
-#
+#
use strict;
@@ -37,7 +37,7 @@
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
-# log file to store profile results
+# log file to store profile results
my $LOG_FILE = "profile$$.log";
my $orig_dbi_debug = $DBI::dbi_debug;
DBI->trace($DBI::dbi_debug, $LOG_FILE);
@@ -51,8 +51,8 @@
# make sure profiling starts disabled
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
-ok($dbh);
-ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE});
+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
@@ -94,23 +94,25 @@
# 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);
-cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1); # at least STORE
-ok( ref $dbh->{Profile}{Data}{""}{STORE} );
+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 $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);
-cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1);
-is( ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY');
+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";
@@ -144,23 +146,27 @@
# check that the proper key was set in Data
my $data = $dbh->{Profile}{Data}{$sql};
-ok($data);
-is(ref $data, 'ARRAY');
-ok(@$data == 7);
-ok((grep { defined($_) } @$data) == 7);
-ok((grep { DBI::looks_like_number($_) } @$data) == 7);
+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);
-ok($total > $first);
-ok($total > $longest) or warn "total $total > longest $longest: failed\n";
-ok($longest > 0) or warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable
-ok($longest > $shortest);
-ok($time1 >= $^T);
-ok($time2 >= $^T);
-ok($time1 <= $time2);
+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) or warn "next $next > first $time1: failed\n";
-ok($next > $time2) or warn "next $next > last $time2: failed\n";
+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 <{Profile});
$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
-is_deeply $tmp, bless {
+is_deeply $tmp, (bless {
'Path' => [ '!Statement' ],
'Data' => {
- '' => [ 7, 0, 0, 0, 0, 0, 0 ],
+ '' => [ 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';
+} => '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);
-ok($output =~ /^DBI::Profile:/);
-ok($output =~ /\((\d+) calls\)/);
-ok($1 >= $count);
+ok(length $output, 'non zero length');
+ok($output =~ /^DBI::Profile:/, 'DBI::Profile');
+ok($output =~ /\((\d+) calls\)/, 'some calls');
+ok($1 >= $count, 'calls >= count');
# -----------------------------------------------------------------------------------
@@ -213,7 +219,7 @@
undef $sth; # DESTROY
$tmp = sanitize_tree($dbh->{Profile});
-ok $tmp->{Data}{usrnam}{""}{foo}{STORE};
+ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored';
$tmp->{Data}{usrnam}{""}{foo} = {};
# make test insentitive to number of local files
#warn Dumper($tmp);
@@ -247,12 +253,11 @@
} => 'DBI::Profile';
$tmp = [ $dbh->{Profile}->as_node_path_list() ];
-is @$tmp, 9, 'should have 9 nodes';
+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' ],
- [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'FETCH' ],
[ [ 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' ],
@@ -351,10 +356,10 @@
}
$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
-is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 12, 0,0,0,0,0,0 ] } } };
+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' => [ 12, 0,0,0,0,0,0 ] } } };
+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';
@@ -362,7 +367,7 @@
# check what code ref sees in $_
$tmp = run_test1( { Path => [ sub { $_ } ] });
is_deeply $tmp, {
- '' => [ 7, 0, 0, 0, 0, 0, 0 ],
+ '' => [ 6, 0, 0, 0, 0, 0, 0 ],
'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
}, '$_ should contain statement';
@@ -401,7 +406,7 @@
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 ]");
+is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text');
# test sortsub
$dbh->{Profile}->{Data} = {
@@ -413,7 +418,7 @@
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 ");
+is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub');
# general test, including defaults
($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] });
@@ -421,14 +426,13 @@
$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 > FETCH > 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';
# -----------------------------------------------------------------------------------
@@ -437,20 +441,22 @@
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");
-is($total_time, 0.93);
+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");
-is($total_time, 2.93);
+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');
exit 0;
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/t/48dbi_dbd_sqlengine.t new/DBI-1.616/t/48dbi_dbd_sqlengine.t
--- old/DBI-1.615/t/48dbi_dbd_sqlengine.t 1970-01-01 01:00:00.000000000 +0100
+++ new/DBI-1.616/t/48dbi_dbd_sqlengine.t 2010-12-22 00:05:58.000000000 +0100
@@ -0,0 +1,81 @@
+#!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" );
+}
+
+done_testing ();
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/t/51dbm_file.t new/DBI-1.616/t/51dbm_file.t
--- old/DBI-1.615/t/51dbm_file.t 2010-09-21 00:13:21.000000000 +0200
+++ new/DBI-1.616/t/51dbm_file.t 2010-12-22 00:06:07.000000000 +0100
@@ -52,6 +52,14 @@
$dbh->do(q/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(q/insert into fRED (a,b) values(1,2)/), 'insert into mixed case table' );
# but change fRED to FRED and it works.
@@ -94,6 +102,29 @@
ok( @$r == 2, 'rows found via select via fully qualified path' );
}
-ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+if( $using_dbd_gofer )
+{
+ ok( $dbh->do(q/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 },
+ }
+ );
+
+ $r = $dbh->selectall_arrayref(q/select * from Fred/);
+ ok( @$r == 2, 'rows found after reconnect using "dbm_tables"' );
+
+ ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+ ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" );
+ ok( !-f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext removed" );
+}
done_testing();
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/DBI-1.615/t/52dbm_complex.t new/DBI-1.616/t/52dbm_complex.t
--- old/DBI-1.615/t/52dbm_complex.t 2010-09-09 12:04:35.000000000 +0200
+++ new/DBI-1.616/t/52dbm_complex.t 2010-12-22 00:06:01.000000000 +0100
@@ -92,7 +92,6 @@
plan skip_all => "Not running with SQL::Statement" unless ( $haveSS );
plan skip_all => "Not running with MLDBM" unless ( @mldbm_types );
-plan skip_all => "Needs more love to run with Gofer, too" if( $using_dbd_gofer );
do "t/lib.pl";
@@ -103,22 +102,30 @@
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, f_meta => $tbl_meta, dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm } );
+ $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 $last_suffix = $suffix;
(my $serializer = $dbmmldbm ) =~ s/::/_/g;
$suffix = join( "_", $$, $dbmtype, $serializer );
@@ -131,7 +138,7 @@
my ($readsth);
ok( $readsth = $dbh->prepare($readsql), "prepare: $readsql" );
ok( $readsth->execute(), "execute: $readsql" );
- ok( $dbh->do( $impsql, {}, $readsth ), $impsql );
+ ok( $dbh->do( $impsql, {}, $readsth ), $impsql ) or warn $dbh->errstr();
}
}
else
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Remember to have fun...
--
To unsubscribe, e-mail: opensuse-commit+unsubscribe@opensuse.org
For additional commands, e-mail: opensuse-commit+help@opensuse.org
