lib/DBIx/Class/Optional/Dependencies.pod
pm_to_blib
t/var/
+.*.sw?
--- /dev/null
+# This file allows us to map authors more correctly
+# so if someone were to legally change their name, we could use it to fix that
+# while maintaining the integrity of the repository
+
+# I've mapped the old single quote version of my name to the double quote
+# version for consistency
+Arthur Axel "fREW" Schmidt <frioux@gmail.com> Arthur Axel 'fREW' Schmidt <frioux@gmail.com>
Revision history for DBIx::Class
+ * New Features / Changes
+ - Add quote_names connection option. When set to true automatically
+ sets quote_char and name_sep appropriate for your RDBMS
+ - Support for MS Access databases via DBD::ODBC and DBD::ADO (only
+ Win32 support currently tested)
+ - IC::DateTime support for MSSQL over DBD::ADO
+ - Both the ::ODBC and ::ADO dispatchers now warn if a rdbms-specific
+ driver is not found for this connection before falling back to
+ plain ::Storage::DBI
+ - ::Storage::DBI::sth was mistakenly marked/documented as public,
+ privatize and warn on deprecated use
+ - Massive overhaul of bind values/attributes handling - slightly
+ changes the output of as_query (should not cause compat issues)
+ - Support ancient DB2 versions (5.4 and older), with proper limit
+ dialect
+
+ * Fixes
+ - Fix ::Storage::DBI::* MRO problems on 5.8.x perls
+ - Disable mysql_auto_reconnect for MySQL - depending on the ENV
+ it sometimes defaults to on and causes major borkage on older
+ DBD::mysql versions
+ - Fix dropped bind values in select/group_by on Oracle (omission
+ from 0542ec57 and 4c2b30d6)
+ - Fix remaining errors with Oracle and identifiers longer than the
+ Oracle-imposed maximum of 30 characters (RT#66390)
+ - Fix older oracle-specific "WhereJoins" to work properly with
+ name quoting
+ - Fix problems with M.A.D. under CGI::SpeedyCGI (RT#65131)
+ - Better error handling when prepare() fails silently
+ - Fixes skipped lines when a comment is followed by a statement
+ when deploying a schema via sql file
+ - Fix reverse_relationship_info on prototypical result sources
+ (sources not yet registered with a schema)
+ - Warn and skip relationships missing from a partial schema during
+ dbic cascade_delete
+ - Automatically require the requested cursor class before use
+ (RT#64795)
+ - Work around a Firebird ODBC driver bug exposed by DBD::ODBC 1.29
+ - Fix exiting via next warnings in ResultSource::sequence()
+ - Fix stripping of table qualifiers in update/delete in arrayref
+ condition elements
+ - Change SQLMaker carp-monkeypatch to be compatible with versions
+ of SQL::Abstract >= 1.73
+ - Fix using \[] literals in the from resultset attribute
+ - Fix populate() with \[], arrays (datatype) and other exotic values
+
+ * Misc
+ - Rewire all warnings to a new Carp-like implementation internal
+ to DBIx::Class, and remove the Carp::Clan dependency
+ - Only load Class::C3 and friends if necessary ($] < 5.010)
+ - Greatly reduced loading of non-essential modules to aid startup
+ time (mainly benefiting CGI users)
+ - Make sure all namespaces are clean of rogue imports
+
0.08190-TRIAL 2011-01-24 15:35 (UTC)
* New Features / Changes
'Test::Exception' => '0.31',
'Test::More' => '0.92',
'Test::Warn' => '0.21',
+
+ # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t
+ # remove and do a manual glob-collection if n::c is no longer a dep
+ 'Package::Stash' => '0.28',
};
my $runtime_requires = {
- 'Carp::Clan' => '6.0',
'Class::Accessor::Grouped' => '0.10002',
- 'Class::C3::Componentised' => '1.0005',
+ 'Class::C3::Componentised' => '1.0009',
'Class::Inspector' => '1.24',
'Config::Any' => '0.20',
'Context::Preserve' => '0.01',
- 'Data::Dumper::Concise' => '1.000',
+ 'Data::Dumper::Concise' => '2.020',
'Data::Page' => '2.00',
'Hash::Merge' => '0.12',
'MRO::Compat' => '0.09',
# temporary(?) until I get around to fix M::I wrt xt/
# needs Module::Install::AuthorTests
eval {
+ # this should not be necessary since the autoloader is supposed
+ # to work, but there were reports of it failing
+ require Module::Install::AuthorTests;
recursive_author_tests (qw/xt/);
1;
} || do {
if ($Module::Install::AUTHOR && ! $args->{skip_author_deps}) {
my $err = $@;
+
+ # better error message in case of missing dep
eval { require Module::Install::AuthorTests }
|| die "\nYou need Module::Install::AuthorTests installed to run this Makefile.PL in author mode (or supply --skip_author_deps):\n\n$@\n";
- die $@;
+
+ die $err;
}
};
|);
no_index package => $_ for (qw/
DBIx::Class::Storage::DBIHacks
+ DBIx::Class::Carp
/);
WriteAll();
use strict;
use warnings;
-use MRO::Compat;
+BEGIN {
+ package DBIx::Class::_ENV_;
+
+ if ($] < 5.009_005) {
+ require MRO::Compat;
+ *OLD_MRO = sub () { 1 };
+ }
+ else {
+ require mro;
+ *OLD_MRO = sub () { 0 };
+ }
+
+ # ::Runmode would only be loaded by DBICTest, which in turn implies t/
+ *DBICTEST = eval { DBICTest::RunMode->is_author }
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+ # During 5.13 dev cycle HELEMs started to leak on copy
+ *PEEPEENESS = (defined $ENV{DBICTEST_ALL_LEAKS}
+ # request for all tests would force "non-leaky" illusion and vice-versa
+ ? ! $ENV{DBICTEST_ALL_LEAKS}
+
+ # otherwise confess that this perl is busted ONLY on smokers
+ : do {
+ if (eval { DBICTest::RunMode->is_smoker }) {
+
+ # leaky 5.13.6 (fixed in blead/cefd5c7c)
+ if ($] == '5.013006') { 1 }
+
+ # not sure why this one leaks, but disable anyway - ANDK seems to make it weep
+ elsif ($] == '5.013005') { 1 }
+
+ else { 0 }
+ }
+ else { 0 }
+ }
+ ) ? sub () { 1 } : sub () { 0 };
+}
+
use mro 'c3';
use DBIx::Class::Optional::Dependencies;
use vars qw($VERSION);
-use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
+use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
use DBIx::Class::StartupCheck;
+__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
+__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny');
+
sub mk_classdata {
shift->mk_classaccessor(@_);
}
gphat: Cory G Watson <gphat@cpan.org>
+Grant Street Group L<http://www.grantstreet.com/>
+
groditi: Guillermo Roditi <groditi@cpan.org>
Haarg: Graham Knop <haarg@haarg.org>
initself: Mike Baas <mike@initselftech.com>
+jawnsy: Jonathan Yu <jawnsy@cpan.org>
+
jasonmay: Jason May <jason.a.may@gmail.com>
jesper: Jesper Krogh
mattlaw: Matt Lawrence
+mattp: Matt Phillips <mattp@cpan.org>
+
michaelr: Michael Reddick <michael.reddick@gmail.com>
+milki: Jonathan Chu <milki@rescomp.berkeley.edu>
+
ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm@cpan.org>
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Robert Olson <bob@rdolson.org>
+
Roman: Roman Filippov <romanf@cpan.org>
Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
talexb: Alex Beamish <talexb@gmail.com>
+tamias: Ronald J Kimball <rjk@tamias.net>
+
teejay : Aaron Trevena <teejay@cpan.org>
Todd Lipcon
use warnings;
use base qw/Class::Accessor::Grouped/;
+use Scalar::Util qw/weaken/;
+use namespace::clean;
+
+my $successfully_loaded_components;
+
+sub get_component_class {
+ my $class = $_[0]->get_inherited($_[1]);
+
+ if (defined $class and ! $successfully_loaded_components->{$class} ) {
+ $_[0]->ensure_class_loaded($class);
+
+ no strict 'refs';
+ $successfully_loaded_components->{$class}
+ = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ = do { \(my $anon = 'loaded') };
+ weaken($successfully_loaded_components->{$class});
+ }
+
+ $class;
+};
+
+sub set_component_class {
+ shift->set_inherited(@_);
+}
1;
# check deps
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
+ die('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
}
=back
-L<create> will generate sql for the supplied schema_class in sql_dir. The
+C<create> will generate sql for the supplied schema_class in sql_dir. The
flavour of sql to generate can be controlled by supplying a sqlt_type which
should be a L<SQL::Translator> name.
print "return is $ret\n" if (!$self->quiet);
}
elsif ($schema->get_db_version() and $self->force ) {
- carp "Forcing install may not be a good idea";
+ warn "Forcing install may not be a good idea\n";
if($self->_confirm() ) {
$self->schema->_set_db_version({ version => $version});
}
package # hide from PAUSE
DBIx::Class::Admin::Descriptive;
-use DBIx::Class::Admin::Usage;
use base 'Getopt::Long::Descriptive';
+require DBIx::Class::Admin::Usage;
sub usage_class { 'DBIx::Class::Admin::Usage'; }
1;
use base 'Class::Accessor::Grouped';
-use Class::C3;
-
__PACKAGE__->mk_group_accessors('simple', 'synopsis', 'short_description');
sub prog_name {
use strict;
use warnings;
use base qw/DBIx::Class::Core DBIx::Class::DB/;
-use Carp::Clan qw/^DBIx::Class/;
# Modules CDBICompat needs that DBIx::Class does not.
my @Extra_Modules = qw(
for my $module (@Extra_Modules) {
push @didnt_load, $module unless eval qq{require $module};
}
-croak("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
+__PACKAGE__->throw_exception("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
if @didnt_load;
sub {
my $sql = $sql;
my $class = shift;
- return $class->storage->sth($class->transform_sql($sql, @_));
+ return $class->storage->_sth($class->transform_sql($sql, @_));
};
if ($sql =~ /select/i) {
my $search_name = "search_${name}";
--- /dev/null
+package DBIx::Class::Carp;
+
+use strict;
+use warnings;
+
+# This is here instead of DBIx::Class because of load-order issues
+BEGIN {
+ ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
+ # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
+ # see if this starts working
+ *DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN = ($] < 5.008005)
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+}
+
+use Carp ();
+use namespace::clean ();
+
+sub __find_caller {
+ my ($skip_pattern, $class) = @_;
+
+ my $skip_class_data = $class->_skip_namespace_frames
+ if ($class and $class->can('_skip_namespace_frames'));
+
+ $skip_pattern = qr/$skip_pattern|$skip_class_data/
+ if $skip_class_data;
+
+ my $fr_num = 1; # skip us and the calling carp*
+ my @f;
+ while (@f = caller($fr_num++)) {
+ last unless $f[0] =~ $skip_pattern;
+ }
+
+ my ($ln, $calling) = @f # if empty - nothing matched - full stack
+ ? ( "at $f[1] line $f[2]", $f[3] )
+ : ( Carp::longmess(), '{UNKNOWN}' )
+ ;
+
+ return (
+ $ln,
+ $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+ );
+};
+
+my $warn = sub {
+ my ($ln, @warn) = @_;
+ @warn = "Warning: something's wrong" unless @warn;
+
+ # back-compat with Carp::Clan - a warning ending with \n does
+ # not include caller info
+ warn (
+ @warn,
+ $warn[-1] =~ /\n$/ ? '' : " $ln\n"
+ );
+};
+
+sub import {
+ my (undef, $skip_pattern) = @_;
+ my $into = caller;
+
+ $skip_pattern = $skip_pattern
+ ? qr/ ^ $into $ | $skip_pattern /xo
+ : qr/ ^ $into $ /xo
+ ;
+
+ no strict 'refs';
+
+ *{"${into}::carp"} = sub {
+ $warn->(
+ __find_caller($skip_pattern, $into),
+ @_
+ );
+ };
+
+ my $fired;
+ *{"${into}::carp_once"} = sub {
+ return if $fired;
+ $fired = 1;
+
+ $warn->(
+ __find_caller($skip_pattern, $into),
+ @_,
+ );
+ };
+
+ my $seen;
+ *{"${into}::carp_unique"} = sub {
+ my ($ln, $calling) = __find_caller($skip_pattern, $into);
+ my $msg = join ('', $calling, @_);
+
+ # unique carping with a hidden caller makes no sense
+ $msg =~ s/\n+$//;
+
+ return if $seen->{$ln}{$msg};
+ $seen->{$ln}{$msg} = 1;
+
+ $warn->(
+ $ln,
+ $msg,
+ );
+ };
+
+ # cleanup after ourselves
+ namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/)
+ ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
+ # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
+ # see if this starts working
+ unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+}
+
+sub unimport {
+ die (__PACKAGE__ . " does not implement unimport yet\n");
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
+
+=head1 DESCRIPTION
+
+Documentation is lacking on purpose - this an experiment not yet fit for
+mass consumption. If you use this do not count on any kind of stability,
+in fact don't even count on this module's continuing existence (it has
+been noindexed for a reason).
+
+In addition to the classic interface:
+
+ use DBIx::Class::Carp '^DBIx::Class'
+
+this module also supports a class-data based way to specify the exclusion
+regex. A message is only carped from a callsite that matches neither the
+closed over string, nor the value of L</_skip_namespace_frames> as declared
+on the B<first> callframe origin.
+
+=head1 CLASS ATTRIBUTES
+
+=head2 _skip_namespace_frames
+
+A classdata attribute holding the stringified regex matching callsites that
+should be skipped by the carp methods below. An empty string C<q{}> is treated
+like no setting/C<undef> (the distinction is necessary due to semantics of the
+class data accessors provided by L<Class::Accessor::Grouped>)
+
+=head1 EXPORTED FUNCTIONS
+
+This module export the following 3 functions. Only warning related C<carp*>
+is being handled here, for C<croak>-ing you must use
+L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
+
+=head2 carp
+
+Carps message with the file/line of the first callsite not matching
+L</_skip_namespace_frames> nor the closed-over arguments to
+C<use DBIx::Class::Carp>.
+
+=head2 carp_unique
+
+Like L</carp> but warns once for every distinct callsite (subject to the
+same ruleset as L</carp>).
+
+=head2 carp_once
+
+Like L</carp> but warns only once for the life of the perl interpreter
+(regardless of callsite).
+
+=cut
use warnings;
use base 'Class::C3::Componentised';
-use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
use mro 'c3';
-my $warned;
+use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised';
# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
# if and only if it is placed before something overriding store_column
for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
if ($comp->isa ($_) ) {
$keep_checking = 0; # no use to check from this point on
- carp "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
- unless ($warned->{UTF8Columns}++ || $ENV{DBIC_UTF8COLUMNS_OK});
+ carp_once "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
+ unless $ENV{DBIC_UTF8COLUMNS_OK};
last;
}
}
__PACKAGE__->load_components(qw/ResultSetProxy/);
-{
- no warnings 'once';
- *dbi_commit = \&txn_commit;
- *dbi_rollback = \&txn_rollback;
-}
-
sub storage { shift->schema_instance(@_)->storage; }
+sub dbi_commit { shift->txn_commit(@_) }
+sub dbi_rollback { shift->txn_rollback(@_) }
=head1 NAME
****DEPRECATED****
-See L<class_resolver>
+See L</class_resolver>
=head2 dbi_commit
****DEPRECATED****
-Alias for L<txn_commit>
+Alias for L</txn_commit>
=head2 dbi_rollback
****DEPRECATED****
-Alias for L<txn_rollback>
+Alias for L</txn_rollback>
=end HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
-use Try::Tiny;
-use namespace::clean;
+use DBIx::Class::Carp ();
use overload
'""' => sub { shift->{msg} },
Exception objects of this class are used internally by
the default error handling of L<DBIx::Class::Schema/throw_exception>
-to prevent confusing and/or redundant re-application of L<Carp>'s
-stack trace information.
+and derivatives.
These objects stringify to the contained error message, and use
overload fallback to give natural boolean/numeric values.
code, and shouldn't be used directly elsewhere.
Expects a scalar exception message. The optional argument
-C<$stacktrace> tells it to use L<Carp/longmess> instead of
-L<Carp::Clan/croak>.
+C<$stacktrace> tells it to output a full trace similar to L<Carp/confess>.
DBIx::Class::Exception->throw('Foo');
try { ... } catch { DBIx::Class::Exception->throw(shift) }
# Don't re-encapsulate exception objects of any kind
die $msg if ref($msg);
- # use Carp::Clan's croak if we're not stack tracing
+ # all exceptions include a caller
+ $msg =~ s/\n$//;
+
if(!$stacktrace) {
- try { croak $msg } catch { $msg = shift };
+ # skip all frames that match the original caller, or any of
+ # the dbic-wide classdata patterns
+ my ($ln, $calling) = DBIx::Class::Carp::__find_caller(
+ '^' . caller() . '$',
+ 'DBIx::Class',
+ );
+
+ $msg = "${calling}${msg} ${ln}\n";
}
else {
$msg = Carp::longmess($msg);
use strict;
use warnings;
-use Scalar::Util qw/blessed/;
use base qw/DBIx::Class::Row/;
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
use File::Path;
use File::Copy;
use Path::Class;
+use DBIx::Class::Carp;
+use namespace::clean;
-use Carp::Clan qw/^DBIx::Class/;
carp 'InflateColumn::File has entered a deprecation cycle. This component '
.'has a number of architectural deficiencies that can quickly drive '
.'your filesystem and database out of sync and is not recommended '
.'DBIC_IC_FILE_NOWARN to a true value to disable this warning.'
unless $ENV{DBIC_IC_FILE_NOWARN};
+
+
__PACKAGE__->load_components(qw/InflateColumn/);
sub register_column {
you override insert() but the DBIx::Class::Row component is loaded first
then your insert() will never be called, since the DBIx::Class::Row insert()
will be called first. If you are unsure as to why a given method is not
-being called try printing out the Class::C3 inheritance stack.
+being called try printing out the current linearized MRO.
- print join ', ' => Class::C3::calculateMRO('YourClass::Name');
-
-Check out the L<Class::C3> docs for more information about inheritance.
+ print join ', ' => mro::get_linear_isa('YourClass::Name');
=head1 EXISTING COMPONENTS
});
my $rs = $schema->resultset('CD')->search({
- artist_id => { 'IN' => $inside_rs->get_column('id')->as_query },
+ artist_id => { -in => $inside_rs->get_column('id')->as_query },
});
-The usual operators ( =, !=, IN, NOT IN, etc.) are supported.
+The usual operators ( '=', '!=', -in, -not_in, etc.) are supported.
B<NOTE>: You have to explicitly use '=' when doing an equality comparison.
The following will B<not> work:
__PACKAGE__->has_many('pages' => 'Page', 'book', { where => { scrap => 0 } } );
-=head2 Many-to-many relationships
+=head2 Many-to-many relationship bridges
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
L<DBIx::Class::Schema::Loader> will connect to a database and create a
L<DBIx::Class::Schema> and associated sources by examining the database.
-The recommend way of achieving this is to use the
+The recommend way of achieving this is to use the L<dbicdump> utility or the
+L<Catalyst> helper, as described in
+L<Manual::Intro|DBIx::Class::Manual::Intro/Using DBIx::Class::Schema::Loader>.
+
+Alternatively, use the
L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> method:
perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib \
- -e 'make_schema_at("My::Schema", { debug => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
+ -e 'make_schema_at("My::Schema", \
+ { db_schema => 'myschema', components => ["InflateColumn::DateTime"] }, \
+ [ "dbi:Pg:dbname=foo", "username", "password" ])'
-This will create a tree of files rooted at C<./lib/My/Schema/> containing
-source definitions for all the tables found in the C<foo> database.
+This will create a tree of files rooted at C<./lib/My/Schema/> containing source
+definitions for all the tables found in the C<myschema> schema in the C<foo>
+database.
=head2 Creating DDL SQL
$self->squared( $value * $value );
}
- $self->next::method(@_);
+ $self->$orig(@_);
}
-Note that the hard work is done by the call to C<next::method>, which
+Note that the hard work is done by the call to C<< $self->$orig >>, which
redispatches your call to store_column in the superclass(es).
Generally, if this is a calculation your database can easily do, try
the tables are to be joined. The condition may contain as many fields
as you like. See L<DBIx::Class::Relationship::Base>.
-=item .. define a relationship across an intermediate table? (many-to-many)
+=item .. define a relationship bridge across an intermediate table? (many-to-many)
-Read the documentation on L<DBIx::Class::Relationship/many_to_many>.
+The term 'relationship' is used loosely with many_to_many as it is not considered a
+relationship in the fullest sense. For more info, read the documentation on L<DBIx::Class::Relationship/many_to_many>.
=item .. stop DBIx::Class from attempting to cascade deletes on my has_many and might_have relationships?
=head2 Active Community
-Currently (June 9, 2010) 6 active branches (commited to
+Currently (June 9, 2010) 6 active branches (committed to
in the last two weeks) in git. Last release (0.08122)
had 14 new features, and 16 bug fixes. Of course that
L<ebbs and flows|http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=blob;f=Changes>.)
See L<DBIx::Class::Relationship::Base/create_related> and L<DBIx::Class::Relationship::Base/add_to_$rel>
-Note that it automaticaly fills in foreign key for you
+Note that it automatically fills in foreign key for you
=head2 Excellent Transaction Support
artist_id => { -in => $inner_query },
});
-See L<DBIx::Class::Manual::Cookbook#Subqueries>
+See L<DBIx::Class::Manual::Cookbook/Subqueries>
=head2 Bare SQL w/ Placeholders
price => \['price + ?', [inc => $inc]],
});
-See L<SQL::Abstract#Literal_SQL_with_placeholders_and_bind_values_(subqueries)>
+See L<SQL::Abstract/Literal_SQL_with_placeholders_and_bind_values_(subqueries)>
Let's look at how you can set and use your first native L<DBIx::Class> tree.
First we'll see how you can set up your classes yourself. If you want them to
-be auto-discovered, just skip to the next section, which shows you how to use
+be auto-discovered, just skip to the L<next section|/Using
+DBIx::Class::Schema::Loader>, which shows you how to use
L<DBIx::Class::Schema::Loader>.
=head2 Setting it up manually
See L<DBIx::Class::Relationship> for more information about the various types of
available relationships and how you can design your own.
-=head2 Using L<DBIx::Class::Schema::Loader>
+=head2 Using DBIx::Class::Schema::Loader
-This is an external module, and not part of the L<DBIx::Class> distribution.
-It inspects your database, and automatically creates classes for all the tables
-in your database.
+This module (L<DBIx::Class::Schema::Loader>) is an external module, and not part
+of the L<DBIx::Class> distribution. It inspects your database, and automatically
+creates classes for all the tables in your schema.
The simplest way to use it is via the L<dbicdump> script from the
L<DBIx::Class::Schema::Loader> distribution. For example:
- $ dbicdump -o dump_directory=./lib MyApp::Schema dbi:mysql:mydb user pass
+ $ dbicdump -o dump_directory=./lib \
+ -o components='["InflateColumn::DateTime"]' \
+ MyApp::Schema dbi:mysql:mydb user pass
If you have a mixed-case database, use the C<preserve_case> option, e.g.:
- $ dbicdump -o dump_directory=./lib -o preserve_case=1 MyApp::Schema \
- dbi:mysql:mydb user pass
+ $ dbicdump -o dump_directory=./lib -o preserve_case=1 \
+ -o components='["InflateColumn::DateTime"]' \
+ MyApp::Schema dbi:mysql:mydb user pass
If you are using L<Catalyst>, then you can use the helper that comes with
L<Catalyst::Model::DBIC::Schema>:
use warnings;
use strict;
-use Carp;
+use Carp ();
# NO EXTERNAL NON-5.8.1 CORE DEPENDENCIES EVER (e.g. C::A::G)
# This module is to be loaded by Makefile.PM on a pristine system
my $rdbms_mssql_sybase = {
'DBD::Sybase' => '0',
};
+my $rdbms_mssql_ado = {
+ 'DBD::ADO' => '0',
+};
+my $rdbms_msaccess_odbc = {
+ 'DBD::ODBC' => '0',
+};
+my $rdbms_msaccess_ado = {
+ 'DBD::ADO' => '0',
+};
my $rdbms_mysql = {
'DBD::mysql' => '0',
};
my $rdbms_db2 = {
'DBD::DB2' => '0',
};
+my $rdbms_firebird_odbc = {
+ 'DBD::ODBC' => '0',
+};
my $reqs = {
dist => {
req => $id_shortener,
},
+ test_component_accessor => {
+ req => {
+ 'Class::Unload' => '0.07',
+ },
+ },
+
test_pod => {
req => {
'Test::Pod' => '1.41',
},
pod => {
title => 'MSSQL support via DBD::Sybase',
- desc => 'Modules required to connect to MSSQL support via DBD::Sybase',
+ desc => 'Modules required to connect to MSSQL via DBD::Sybase',
+ },
+ },
+
+ rdbms_mssql_ado => {
+ req => {
+ %$rdbms_mssql_ado,
+ },
+ pod => {
+ title => 'MSSQL support via DBD::ADO (Windows only)',
+ desc => 'Modules required to connect to MSSQL via DBD::ADO. This particular DBD is available on Windows only',
+ },
+ },
+
+ rdbms_msaccess_odbc => {
+ req => {
+ %$rdbms_msaccess_odbc,
+ },
+ pod => {
+ title => 'MS Access support via DBD::ODBC',
+ desc => 'Modules required to connect to MS Access via DBD::ODBC',
+ },
+ },
+
+ rdbms_msaccess_ado => {
+ req => {
+ %$rdbms_msaccess_ado,
+ },
+ pod => {
+ title => 'MS Access support via DBD::ADO (Windows only)',
+ desc => 'Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only',
},
},
},
},
+ test_rdbms_mssql_ado => {
+ req => {
+ $ENV{DBICTEST_MSSQL_ADO_DSN}
+ ? (
+ %$rdbms_mssql_ado,
+ ) : ()
+ },
+ },
+
test_rdbms_mssql_sybase => {
req => {
$ENV{DBICTEST_MSSQL_DSN}
},
},
+ test_rdbms_msaccess_odbc => {
+ req => {
+ $ENV{DBICTEST_MSACCESS_ODBC_DSN}
+ ? (
+ %$rdbms_msaccess_odbc,
+ %$datetime_basic,
+ 'Data::GUID' => '0',
+ ) : ()
+ },
+ },
+
+ test_rdbms_msaccess_ado => {
+ req => {
+ $ENV{DBICTEST_MSACCESS_ADO_DSN}
+ ? (
+ %$rdbms_msaccess_ado,
+ %$datetime_basic,
+ 'Data::GUID' => 0,
+ ) : ()
+ },
+ },
+
test_rdbms_mysql => {
req => {
$ENV{DBICTEST_MYSQL_DSN}
},
},
+ test_rdbms_firebird_odbc => {
+ req => {
+ $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
+ ? (
+ %$rdbms_firebird_odbc,
+ ) : ()
+ },
+ },
+
test_memcached => {
req => {
$ENV{DBICTEST_MEMCACHED}
sub req_list_for {
my ($class, $group) = @_;
- croak "req_list_for() expects a requirement group name"
+ Carp::croak "req_list_for() expects a requirement group name"
unless $group;
my $deps = $reqs->{$group}{req}
- or croak "Requirement group '$group' does not exist";
+ or Carp::croak "Requirement group '$group' does not exist";
return { %$deps };
}
sub req_ok_for {
my ($class, $group) = @_;
- croak "req_ok_for() expects a requirement group name"
+ Carp::croak "req_ok_for() expects a requirement group name"
unless $group;
return $class->_check_deps($group)->{status};
sub req_missing_for {
my ($class, $group) = @_;
- croak "req_missing_for() expects a requirement group name"
+ Carp::croak "req_missing_for() expects a requirement group name"
unless $group;
return $class->_check_deps($group)->{missing};
sub req_errorlist_for {
my ($class, $group) = @_;
- croak "req_errorlist_for() expects a requirement group name"
+ Carp::croak "req_errorlist_for() expects a requirement group name"
unless $group;
return $class->_check_deps($group)->{errorlist};
if (keys %errors) {
my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
$missing .= " (see $class for details)" if $reqs->{$group}{pod};
+ $missing .= "\n";
$res = {
status => 0,
errorlist => \%errors,
'You may distribute this code under the same terms as Perl itself',
);
- open (my $fh, '>', $podfn) or croak "Unable to write to $podfn: $!";
+ open (my $fh, '>', $podfn) or Carp::croak "Unable to write to $podfn: $!";
print $fh join ("\n\n", @chunks);
close ($fh);
}
Shifts all siblings with B<positions values> in the range @between
(inclusive) by one position as specified by $direction (left if < 0,
right if > 0). By default simply increments/decrements each
-L<position_column> value by 1, doing so in a way as to not violate
+L</position_column> value by 1, doing so in a way as to not violate
any existing constraints.
Note that if you override this method and have unique constraints
-including the L<position_column> the shift is not a trivial task.
+including the L</position_column> the shift is not a trivial task.
Refer to the implementation source of the default method for more
information.
use strict;
use warnings;
+use DBIx::Class::Carp;
our %_pod_inherit_config =
(
my $ret = $self->next::method(@rest);
foreach my $rel (@cascade) {
- $self->search_related($rel)->delete_all;
+ if( my $rel_rs = eval{ $self->search_related($rel) } ) {
+ $rel_rs->delete_all;
+ } else {
+ carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
+ next;
+ }
}
$guard->commit;
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Sub::Name qw/subname/;
use Scalar::Util qw/blessed/;
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
-use Data::Page;
use DBIx::Class::ResultSetColumn;
-use DBIx::Class::ResultSourceHandle;
-use Hash::Merge ();
use Scalar::Util qw/blessed weaken/;
use Try::Tiny;
-use Storable qw/nfreeze thaw/;
# not importing first() as it will clash with our own method
use List::Util ();
-use namespace::clean;
-
-
BEGIN {
# De-duplication in _merge_attr() is disabled, but left in for reference
# (the merger is used for other things that ought not to be de-duped)
*__HM_DEDUP = sub () { 0 };
}
+use namespace::clean;
+
use overload
'0+' => "count",
'bool' => "_bool",
year => $request->param('year'),
});
- $self->apply_security_policy( $cd_rs );
+ $cd_rs = $self->apply_security_policy( $cd_rs );
return $cd_rs->all();
}
=cut
-my $callsites_warned;
sub search_rs {
my $self = shift;
} if @_;
if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
- carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
- unless $callsites_warned->{$callsite}++;
+ carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead';
}
for ($old_where, $call_cond) {
return \%aliased;
}
-my $callsites_warned_ucond;
sub _build_unique_cond {
my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_;
and
my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond)
) {
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ( sprintf (
+ carp_unique ( sprintf (
"NULL/undef values supplied for requested unique constraint '%s' (NULL "
. 'values in column(s): %s). This is almost certainly not what you wanted, '
. 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
$constraint_name,
join (', ', map { "'$_'" } @undefs),
- )) unless $callsites_warned_ucond->{$callsite}++;
+ ));
}
return $final_cond;
sub search_like {
my $class = shift;
- carp (
+ carp_unique (
'search_like() is deprecated and will be removed in DBIC version 0.09.'
.' Instead use ->search({ x => { -like => "y%" } })'
.' (note the outer pair of {}s - they are important!)'
### necessary for future development of DBIx::DS. Do *NOT* change this code
### before talking to ribasushi/mst
+ require Data::Page;
my $pager = Data::Page->new(
0, #start with an empty set
$attrs->{rows},
# subquery (since a group_by is present)
if (delete $attrs->{distinct}) {
if ($attrs->{group_by}) {
- carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
+ carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
}
else {
# distinct affects only the main selection part, not what prefetch may
sub _merge_attr {
$hm ||= do {
+ require Hash::Merge;
my $hm = Hash::Merge->new;
$hm->specify_behavior({
# A cursor in progress can't be serialized (and would make little sense anyway)
delete $to_serialize->{cursor};
- nfreeze($to_serialize);
+ Storable::nfreeze($to_serialize);
}
# need this hook for symmetry
sub STORABLE_thaw {
my ($self, $cloning, $serialized) = @_;
- %$self = %{ thaw($serialized) };
+ %$self = %{ Storable::thaw($serialized) };
$self;
}
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
+B<NOTE:> You need to explicitly quote '+columns' when defining the attribute.
+Not doing so causes Perl to incorrectly interpret +columns as a bareword with a
+unary plus operator before it.
+
=head2 include_columns
=over 4
e.g. an C<ORDER BY> clause. This is done via the C<-as> B<select function
attribute> supplied as shown in the example above.
+B<NOTE:> You need to explicitly quote '+select'/'+as' when defining the attributes.
+Not doing so causes Perl to incorrectly interpret them as a bareword with a
+unary plus operator before it.
+
=head2 +select
=over 4
identical to creating a non-pages resultset and then calling ->page($page)
on it.
-If L<rows> attribute is not specified it defaults to 10 rows per page.
+If L</rows> attribute is not specified it defaults to 10 rows per page.
When you have a paged resultset, L</count> will only return the number
of rows in the page. To get the total, use the L</pager> and call
use warnings;
use base 'DBIx::Class';
-
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
# not importing first() as it will clash with our own method
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use List::Util 'first';
use Scalar::Util qw/blessed weaken isweak/;
-use Storable qw/nfreeze thaw/;
use namespace::clean;
use base qw/DBIx::Class/;
my $columns_info = $source->columns_info;
Like L</column_info> but returns information for the requested columns. If
-the optional column-list arrayref is ommitted it returns info on all columns
+the optional column-list arrayref is omitted it returns info on all columns
currently defined on the ResultSource via L</add_columns>.
=cut
my ($self,$seq) = @_;
my @pks = $self->primary_columns
- or next;
+ or return;
$_->{sequence} = $seq
for values %{ $self->columns_info (\@pks) };
sub reverse_relationship_info {
my ($self, $rel) = @_;
- my $rel_info = $self->relationship_info($rel);
+
+ my $rel_info = $self->relationship_info($rel)
+ or $self->throw_exception("No such relationship '$rel'");
+
my $ret = {};
return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
- my @cond = keys(%{$rel_info->{cond}});
- my @refkeys = map {/^\w+\.(\w+)$/} @cond;
- my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+ my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
- # Get the related result source for this relationship
- my $othertable = $self->related_source($rel);
+ my $rsrc_schema_moniker = $self->source_name
+ if try { $self->schema };
+
+ # this may be a partial schema or something else equally esoteric
+ my $other_rsrc = try { $self->related_source($rel) }
+ or return $ret;
# Get all the relationships for that source that related to this source
# whose foreign column set are our self columns on $rel and whose self
- # columns are our foreign columns on $rel.
- my @otherrels = $othertable->relationships();
- my $otherrelationship;
- foreach my $otherrel (@otherrels) {
- # this may be a partial schema with the related source not being
- # available at all
- my $back = try { $othertable->related_source($otherrel) } or next;
-
- # did we get back to ourselves?
- next unless $back->source_name eq $self->source_name;
-
- my $otherrel_info = $othertable->relationship_info($otherrel);
- my @othertestconds;
-
- if (ref $otherrel_info->{cond} eq 'HASH') {
- @othertestconds = ($otherrel_info->{cond});
- }
- elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
- @othertestconds = @{$otherrel_info->{cond}};
+ # columns are our foreign columns on $rel
+ foreach my $other_rel ($other_rsrc->relationships) {
+
+ # only consider stuff that points back to us
+ # "us" here is tricky - if we are in a schema registration, we want
+ # to use the source_names, otherwise we will use the actual classes
+
+ # the schema may be partial
+ my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ or next;
+
+ if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+ next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
}
else {
- next;
+ next unless $self->result_class eq $roundtrip_rsrc->result_class;
}
- foreach my $othercond (@othertestconds) {
- my @other_cond = keys(%$othercond);
- my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
- my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
- next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
- !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
- $ret->{$otherrel} = $otherrel_info;
- }
+ my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+ # this can happen when we have a self-referential class
+ next if $other_rel_info eq $rel_info;
+
+ next unless ref $other_rel_info->{cond} eq 'HASH';
+ my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+ $ret->{$other_rel} = $other_rel_info if (
+ $self->_compare_relationship_keys (
+ [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+ )
+ and
+ $self->_compare_relationship_keys (
+ [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+ )
+ );
}
+
return $ret;
}
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+ +{
+ map
+ { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+ keys %{$_[1]}
+ }
+}
+
sub compare_relationship_keys {
carp 'compare_relationship_keys is a private method, stop calling it';
my $self = shift;
# Returns true if both sets of keynames are the same, false otherwise.
sub _compare_relationship_keys {
- my ($self, $keys1, $keys2) = @_;
-
- # Make sure every keys1 is in keys2
- my $found;
- foreach my $key (@$keys1) {
- $found = 0;
- foreach my $prim (@$keys2) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
-
- # Make sure every key2 is in key1
- if ($found) {
- foreach my $prim (@$keys2) {
- $found = 0;
- foreach my $key (@$keys1) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
- }
-
- return $found;
+# my ($self, $keys1, $keys2) = @_;
+ return
+ join ("\x00", sort @{$_[1]})
+ eq
+ join ("\x00", sort @{$_[2]})
+ ;
}
# Returns the {from} structure used to express JOIN conditions
if( !$self->has_relationship( $rel ) ) {
$self->throw_exception("No such relationship '$rel' on " . $self->source_name);
}
- return $self->schema->source($self->relationship_info($rel)->{source});
+
+ # if we are not registered with a schema - just use the prototype
+ # however if we do have a schema - ask for the source by name (and
+ # throw in the process if all fails)
+ if (my $schema = try { $self->schema }) {
+ $schema->source($self->relationship_info($rel)->{source});
+ }
+ else {
+ my $class = $self->relationship_info($rel)->{class};
+ $self->ensure_class_loaded($class);
+ $class->result_source_instance;
+ }
}
=head2 related_class
{
my $global_phase_destroy;
- END { $global_phase_destroy++ }
+ # SpeedyCGI runs END blocks every cycle but keeps object instances
+ # hence we have to disable the globaldestroy hatch, and rely on the
+ # eval trap below (which appears to work, but is risky done so late)
+ END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
sub DESTROY {
return if $global_phase_destroy;
);
# weaken our schema hold forcing the schema to find somewhere else to live
- weaken $_[0]->{schema};
+ # during global destruction (if we have not yet bailed out) this will throw
+ # which will serve as a signal to not try doing anything else
+ local $@;
+ eval {
+ weaken $_[0]->{schema};
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ return;
+ };
+
- # if schema is still there reintroduce ourselves with strong refs back
+ # if schema is still there reintroduce ourselves with strong refs back to us
if ($_[0]->{schema}) {
my $srcregs = $_[0]->{schema}->source_registrations;
for (keys %$srcregs) {
+ next unless $srcregs->{$_};
$srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
}
}
}
}
-sub STORABLE_freeze { nfreeze($_[0]->handle) }
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
sub STORABLE_thaw {
my ($self, $cloning, $ice) = @_;
- %$self = %{ (thaw $ice)->resolve };
+ %$self = %{ (Storable::thaw($ice))->resolve };
}
=head2 throw_exception
use base qw/DBIx::Class/;
-use Storable qw/nfreeze thaw/;
use DBIx::Class::Exception;
use Try::Tiny;
: $self->{_detached_source}->result_class
;
- nfreeze($to_serialize);
+ Storable::nfreeze($to_serialize);
}
=head2 STORABLE_thaw
sub STORABLE_thaw {
my ($self, $cloning, $ice) = @_;
- %$self = %{ thaw($ice) };
+ %$self = %{ Storable::thaw($ice) };
my $from_class = delete $self->{_frozen_from_class};
use DBIx::Class::Exception;
use Scalar::Util 'blessed';
use Try::Tiny;
-use namespace::clean;
###
### Internal method
: sub () { 0 };
}
+use namespace::clean;
+
=head1 NAME
DBIx::Class::Row - Basic row methods
use base qw/
DBIx::Class::SQLMaker::LimitDialects
SQL::Abstract
- Class::Accessor::Grouped
+ DBIx::Class
/;
use mro 'c3';
use Sub::Name 'subname';
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
use namespace::clean;
__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
;
}
+# FIXME when we bring in the storage weaklink, check its schema
+# weaklink and channel through $schema->throw_exception
+sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
+
BEGIN {
- # reinstall the carp()/croak() functions imported into SQL::Abstract
- # as Carp and Carp::Clan do not like each other much
+ # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
+ # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
no warnings qw/redefine/;
- no strict qw/refs/;
- for my $f (qw/carp croak/) {
-
- my $orig = \&{"SQL::Abstract::$f"};
- my $clan_import = \&{$f};
- *{"SQL::Abstract::$f"} = subname "SQL::Abstract::$f" =>
- sub {
- if (Carp::longmess() =~ /DBIx::Class::SQLMaker::[\w]+ .+? called \s at/x) {
- goto $clan_import;
- }
- else {
- goto $orig;
- }
- };
- }
+
+ *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
+ my($func) = (caller(1))[3];
+ carp "[$func] Warning: ", @_;
+ };
+
+ *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
+ my($func) = (caller(1))[3];
+ __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
+ };
+
+ # Current SQLA pollutes its namespace - clean for the time being
+ namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
}
# the "oh noes offset/top without limit" constant
my $self = shift;
my ($op, $rhs) = splice @_, -2;
if (ref $rhs) {
- croak "-$op takes a single scalar argument (a quotable identifier)";
+ $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
}
# in case we are called as a top level special op (no '=')
my $lhs = shift;
my @bind = [
- ($lhs || $self->{_nested_func_lhs} || croak "Unable to find bindtype for -value $rhs"),
+ ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
$rhs
];
;
}
-my $callsites_warned;
sub _where_op_NEST {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ("-nest in search conditions is deprecated, you most probably wanted:\n"
+ carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
.q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
- ) unless $callsites_warned->{$callsite}++;
+ );
shift->next::method(@_);
}
$fields = $self->_recurse_fields($fields);
if (defined $offset) {
- croak ('A supplied offset must be a non-negative integer')
+ $self->throw_exception('A supplied offset must be a non-negative integer')
if ( $offset =~ /\D/ or $offset < 0 );
}
$offset ||= 0;
if (defined $limit) {
- croak ('A supplied limit must be a positive integer')
+ $self->throw_exception('A supplied limit must be a positive integer')
if ( $limit =~ /\D/ or $limit <= 0 );
}
elsif ($offset) {
||
do {
my $dialect = $self->limit_dialect
- or croak "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found";
+ or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
$self->can ("_$dialect")
- or croak (__PACKAGE__ . " does not implement the requested dialect '$dialect'");
+ or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
}
;
};
sub _lock_select {
my ($self, $type) = @_;
- my $sql = $for_syntax->{$type} || croak "Unknown SELECT .. FOR type '$type' requested";
+ my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
return " $sql";
}
# there should be only one pair
if (@toomany) {
- croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
+ $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
}
if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
- croak (
+ $self->throw_exception (
'The select => { distinct => ... } syntax is not supported for multiple columns.'
.' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
.' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
return $$fields->[0];
}
else {
- croak($ref . qq{ unexpected in _recurse_fields()})
+ $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
}
}
elsif ($ref eq 'HASH') {
return $_[0]->_recurse_from($_[1]);
}
+ elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
+ my ($sql, @bind) = @{ ${$_[1]} };
+ push @{$_[0]->{from_bind}}, @bind;
+ return $sql
+ }
}
-
return $_[0]->next::method ($_[1]);
}
sub _generate_join_clause {
my ($self, $join_type) = @_;
+ $join_type = $self->{_default_jointype}
+ if ! defined $join_type;
+
return sprintf ('%s JOIN ',
- $join_type ? ' ' . $self->_sqlcase($join_type) : ''
+ $join_type ? $self->_sqlcase($join_type) : ''
);
}
sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push @sqlf, $self->_from_chunk_to_sql($from);
+ my $self = shift;
+
+ return join (' ', $self->_gen_from_blocks(@_) );
+}
- for (@join) {
+sub _gen_from_blocks {
+ my ($self, $from, @joins) = @_;
+
+ my @fchunks = $self->_from_chunk_to_sql($from);
+
+ for (@joins) {
my ($to, $on) = @$_;
# check whether a join type exists
$join_type =~ s/^\s+ | \s+$//xg;
}
- $join_type = $self->{_default_jointype} if not defined $join_type;
-
- push @sqlf, $self->_generate_join_clause( $join_type );
+ my @j = $self->_generate_join_clause( $join_type );
if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_from_chunk_to_sql($to));
+ push(@j, '(', $self->_recurse_from(@$to), ')');
+ }
+ else {
+ push(@j, $self->_from_chunk_to_sql($to));
}
my ($sql, @bind) = $self->_join_condition($on);
- push(@sqlf, ' ON ', $sql);
+ push(@j, ' ON ', $sql);
push @{$self->{from_bind}}, @bind;
+
+ push @fchunks, join '', @j;
}
- return join('', @sqlf);
+ return @fchunks;
}
sub _from_chunk_to_sql {
( grep { $_ !~ /^\-/ } keys %$fromspec )
);
- croak "Only one table/as pair expected in from-spec but an exra '$toomuch' key present"
+ $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
if defined $toomuch;
($self->_from_chunk_to_sql($table), $self->_quote($as) );
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::ACCESS;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::SQLMaker';
+
+# MSAccess is retarded wrt multiple joins in FROM - it requires a certain
+# way of parenthesizing each left part before each next right part
+sub _recurse_from {
+ my @j = shift->_gen_from_blocks(@_);
+
+ # first 2 steps need no parenthesis
+ my $fin_join = join (' ', splice @j, 0, 2);
+
+ while (@j) {
+ $fin_join = sprintf '( %s ) %s', $fin_join, (shift @j);
+ }
+
+ # the entire FROM is *ALSO* expected aprenthesized
+ "( $fin_join )";
+}
+
+1;
use warnings;
use strict;
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
use List::Util 'first';
use namespace::clean;
-# FIXME
-# This dialect has not been ported to the subquery-realiasing code
-# that all other subquerying dialects are using. It is very possible
-# that this dialect is entirely unnecessary - it is currently only
-# used by ::Storage::DBI::ODBC::DB2_400_SQL which *should* be able to
-# just subclass ::Storage::DBI::DB2 and use the already rewritten
-# RowNumberOver. However nobody has access to this specific database
-# engine, thus keeping legacy code as-is
-# IF someone ever manages to test DB2-AS/400 with RNO, all the code
-# in this block should go on to meet its maker
-{
- sub _FetchFirst {
- my ( $self, $sql, $order, $rows, $offset ) = @_;
-
- my $last = $rows + $offset;
-
- my ( $order_by_up, $order_by_down ) = $self->_order_directions( $order );
-
- $sql = "
- SELECT * FROM (
- SELECT * FROM (
- $sql
- $order_by_up
- FETCH FIRST $last ROWS ONLY
- ) foo
- $order_by_down
- FETCH FIRST $rows ROWS ONLY
- ) bar
- $order_by_up
- ";
-
- return $sql;
- }
-
- sub _order_directions {
- my ( $self, $order ) = @_;
-
- return unless $order;
-
- my $ref = ref $order;
-
- my @order;
-
- CASE: {
- @order = @$order, last CASE if $ref eq 'ARRAY';
- @order = ( $order ), last CASE unless $ref;
- @order = ( $$order ), last CASE if $ref eq 'SCALAR';
- croak __PACKAGE__ . ": Unsupported data struct $ref for ORDER BY";
- }
-
- my ( $order_by_up, $order_by_down );
-
- foreach my $spec ( @order )
- {
- my @spec = split ' ', $spec;
- croak( "bad column order spec: $spec" ) if @spec > 2;
- push( @spec, 'ASC' ) unless @spec == 2;
- my ( $col, $up ) = @spec; # or maybe down
- $up = uc( $up );
- croak( "bad direction: $up" ) unless $up =~ /^(?:ASC|DESC)$/;
- $order_by_up .= ", $col $up";
- my $down = $up eq 'ASC' ? 'DESC' : 'ASC';
- $order_by_down .= ", $col $down";
- }
-
- s/^,/ORDER BY/ for ( $order_by_up, $order_by_down );
-
- return $order_by_up, $order_by_down;
- }
-}
-### end-of-FIXME
-
=head1 NAME
DBIx::Class::SQLMaker::LimitDialects - SQL::Abstract::Limit-like functionality for DBIx::Class::SQLMaker
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
# get selectors, and scan the order_by (if any)
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
$sql =~ s/^ \s* SELECT \s+ //ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
return sprintf ('SELECT %s%s%s%s',
$offset
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
$sql =~ s/^ \s* SELECT \s+ //ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
return sprintf ('SELECT %s%s%s%s',
sprintf ('FIRST %u ', $rows),
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
my ($insel, $outsel) = $self->_subqueried_limit_attrs ($rs_attrs);
return $sql;
}
-=head2 Top
-
- SELECT * FROM
-
- SELECT TOP $limit FROM (
- SELECT TOP $limit FROM (
- SELECT TOP ($limit+$offset) ...
- ) ORDER BY $reversed_original_order
- ) ORDER BY $original_order
-
-Unreliable Top-based implementation, supported by B<< MSSQL < 2005 >>.
-
-=head3 CAVEAT
-
-Due to its implementation, this limit dialect returns B<incorrect results>
-when $limit+$offset > total amount of rows in the resultset.
-
-=cut
-sub _Top {
- my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+# used by _Top and _FetchFirst
+sub _prep_for_skimming_limit {
+ my ( $self, $sql, $rs_attrs ) = @_;
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
+
+ my %r = ( inner_sql => $sql );
# get selectors
- my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
+ my ($alias_map, $extra_order_sel);
+ ($r{in_sel}, $r{out_sel}, $alias_map, $extra_order_sel)
= $self->_subqueried_limit_attrs ($rs_attrs);
my $requested_order = delete $rs_attrs->{order_by};
-
- my $order_by_requested = $self->_order_by ($requested_order);
+ $r{order_by_requested} = $self->_order_by ($requested_order);
# make up an order unless supplied
- my $inner_order = ($order_by_requested
+ my $inner_order = ($r{order_by_requested}
? $requested_order
: [ map
{ "$rs_attrs->{alias}.$_" }
]
);
- my ($order_by_inner, $order_by_reversed);
-
# localise as we already have all the bind values we need
{
local $self->{order_bind};
- $order_by_inner = $self->_order_by ($inner_order);
+ $r{order_by_inner} = $self->_order_by ($inner_order);
my @out_chunks;
for my $ch ($self->_order_by_chunks ($inner_order)) {
push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' );
}
- $order_by_reversed = $self->_order_by (\@out_chunks);
+ $r{order_by_reversed} = $self->_order_by (\@out_chunks);
}
# this is the order supplement magic
- my $mid_sel = $out_sel;
+ $r{mid_sel} = $r{out_sel};
if ($extra_order_sel) {
for my $extra_col (sort
{ $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
keys %$extra_order_sel
) {
- $in_sel .= sprintf (', %s AS %s',
+ $r{in_sel} .= sprintf (', %s AS %s',
$extra_col,
$extra_order_sel->{$extra_col},
);
- $mid_sel .= ', ' . $extra_order_sel->{$extra_col};
+ $r{mid_sel} .= ', ' . $extra_order_sel->{$extra_col};
}
# since whatever order bindvals there are, they will be realiased
for my $col (keys %$map) {
my $re_col = quotemeta ($col);
$_ =~ s/$re_col/$map->{$col}/
- for ($order_by_reversed, $order_by_requested);
+ for ($r{order_by_reversed}, $r{order_by_requested});
}
}
# generate the rest of the sql
- my $grpby_having = $self->_parse_rs_attrs ($rs_attrs);
+ $r{grpby_having} = $self->_parse_rs_attrs ($rs_attrs);
+
+ $r{quoted_rs_alias} = $self->_quote ($rs_attrs->{alias});
+
+ \%r;
+}
+
+=head2 Top
+
+ SELECT * FROM
+
+ SELECT TOP $limit FROM (
+ SELECT TOP $limit FROM (
+ SELECT TOP ($limit+$offset) ...
+ ) ORDER BY $reversed_original_order
+ ) ORDER BY $original_order
- my $quoted_rs_alias = $self->_quote ($rs_attrs->{alias});
+Unreliable Top-based implementation, supported by B<< MSSQL < 2005 >>.
+
+=head3 CAVEAT
+
+Due to its implementation, this limit dialect returns B<incorrect results>
+when $limit+$offset > total amount of rows in the resultset.
+
+=cut
+
+sub _Top {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
$sql = sprintf ('SELECT TOP %u %s %s %s %s',
$rows + ($offset||0),
- $in_sel,
- $sql,
- $grpby_having,
- $order_by_inner,
+ $l{in_sel},
+ $l{inner_sql},
+ $l{grpby_having},
+ $l{order_by_inner},
);
$sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
- $mid_sel,
+ $l{mid_sel},
$sql,
- $quoted_rs_alias,
- $order_by_reversed,
+ $l{quoted_rs_alias},
+ $l{order_by_reversed},
) if $offset;
$sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
- $out_sel,
+ $l{out_sel},
$sql,
- $quoted_rs_alias,
- $order_by_requested,
- ) if ( ($offset && $order_by_requested) || ($mid_sel ne $out_sel) );
+ $l{quoted_rs_alias},
+ $l{order_by_requested},
+ ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
+
+ return $sql;
+}
+
+=head2 FetchFirst
+
+ SELECT * FROM
+ (
+ SELECT * FROM (
+ SELECT * FROM (
+ SELECT * FROM ...
+ ) ORDER BY $reversed_original_order
+ FETCH FIRST $limit ROWS ONLY
+ ) ORDER BY $original_order
+ FETCH FIRST $limit ROWS ONLY
+ )
+
+Unreliable FetchFirst-based implementation, supported by B<< IBM DB2 <= V5R3 >>.
+
+=head3 CAVEAT
+
+Due to its implementation, this limit dialect returns B<incorrect results>
+when $limit+$offset > total amount of rows in the resultset.
+
+=cut
+
+sub _FetchFirst {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
+
+ $sql = sprintf ('SELECT %s %s %s %s FETCH FIRST %u ROWS ONLY',
+ $l{in_sel},
+ $l{inner_sql},
+ $l{grpby_having},
+ $l{order_by_inner},
+ $rows + ($offset||0),
+ );
+
+ $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
+ $l{mid_sel},
+ $sql,
+ $l{quoted_rs_alias},
+ $l{order_by_reversed},
+ $rows,
+ ) if $offset;
+
+ $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
+ $l{out_sel},
+ $sql,
+ $l{quoted_rs_alias},
+ $l{order_by_requested},
+ $rows,
+ ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
return $sql;
}
Otherwise we fall back to L</GenericSubQ>
=cut
+
sub _RowCountOrGenericSubQ {
my $self = shift;
my ($sql, $rs_attrs, $rows, $offset) = @_;
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
my ($order_by, @rest) = do {
local $self->{quote_char};
( ref $order_by eq 'ARRAY' and @$order_by == 1 )
)
) {
- croak (
+ $self->throw_exception (
'Generic Subquery Limit does not work on resultsets without an order, or resultsets '
. 'with complex order criteria (multicolumn and/or functions). Provide a single, '
. 'unique-column order criteria.'
$rs_attrs->{from}, [$order_by, $unq_sort_col]
);
- my $ord_colinfo = $inf->{$order_by} || croak "Unable to determine source of order-criteria '$order_by'";
+ my $ord_colinfo = $inf->{$order_by} || $self->throw_exception("Unable to determine source of order-criteria '$order_by'");
if ($ord_colinfo->{-result_source}->name ne $root_tbl_name) {
- croak "Generic Subquery Limit order criteria can be only based on the root-source '"
- . $root_rsrc->source_name . "' (aliased as '$rs_attrs->{alias}')";
+ $self->throw_exception(sprintf
+ "Generic Subquery Limit order criteria can be only based on the root-source '%s'"
+ . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias},
+ );
}
# make sure order column is qualified
last;
}
}
- croak "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
- unless $is_u;
+ $self->throw_exception(
+ "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
+ ) unless $is_u;
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
= $self->_subqueried_limit_attrs ($rs_attrs);
sub _subqueried_limit_attrs {
my ($self, $rs_attrs) = @_;
- croak 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
- unless ref ($rs_attrs) eq 'HASH';
+ $self->throw_exception(
+ 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
+ ) unless ref ($rs_attrs) eq 'HASH';
my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} );
||
$rs_attrs->{as}[$i]
||
- croak "Select argument $i ($s) without corresponding 'as'"
+ $self->throw_exception("Select argument $i ($s) without corresponding 'as'")
,
};
DBIx::Class::SQLMaker::MSSQL;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
#
# MSSQL does not support ... OVER() ... RNO limits
DBIx::Class::SQLMaker::MySQL;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
#
# MySQL does not understand the standard INSERT INTO $table DEFAULT VALUES
sub _lock_select {
my ($self, $type) = @_;
- my $sql = $for_syntax->{$type} || croak "Unknown SELECT .. FOR type '$type' requested";
+ my $sql = $for_syntax->{$type}
+ || $self->throw_exception("Unknown SELECT .. FOR type '$type' requested");
return " $sql";
}
use strict;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class::Optional::Dependencies;
- croak('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') )
+ die('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') . "\n" )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
}
sub _assemble_binds {
my $self = shift;
- return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/from where oracle_connect_by having order/);
+ return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where oracle_connect_by group having order/);
}
return ($sql, @bind);
}
+# use this codepath to hook all identifiers and mangle them if necessary
+# this is invoked regardless of quoting being on or off
+sub _quote {
+ my ($self, $label) = @_;
+
+ return '' unless defined $label;
+ return ${$label} if ref($label) eq 'SCALAR';
+
+ $label =~ s/ ( [^\.]{31,} ) /$self->_shorten_identifier($1)/gxe;
+
+ $self->next::method($label);
+}
+
# this takes an identifier and shortens it if necessary
# optionally keywords can be passed as an arrayref to generate useful
# identifiers
return $to_shorten
if length($to_shorten) <= $max_len;
- croak 'keywords needs to be an arrayref'
+ $self->throw_exception("'keywords' needs to be an arrayref")
if defined $keywords && ref $keywords ne 'ARRAY';
# if no keywords are passed use the identifier as one
});
my $rc_ref = $options->{returning_container}
- or croak ('No returning container supplied for IR values');
+ or $self->throw_exception('No returning container supplied for IR values');
@$rc_ref = (undef) x @f_names;
package # Hide from PAUSE
DBIx::Class::SQLMaker::OracleJoins;
+use warnings;
+use strict;
+
use base qw( DBIx::Class::SQLMaker::Oracle );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
sub select {
my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
+ # pull out all join conds as regular WHEREs from all extra tables
if (ref($table) eq 'ARRAY') {
- $where = $self->_oracle_joins($where, @{ $table });
+ $where = $self->_oracle_joins($where, @{ $table }[ 1 .. $#$table ]);
}
- return $self->SUPER::select($table, $fields, $where, $rs_attrs, @rest);
+ return $self->next::method($table, $fields, $where, $rs_attrs, @rest);
}
sub _recurse_from {
}
sub _oracle_joins {
- my ($self, $where, $from, @join) = @_;
- my $join_where = {};
- $self->_recurse_oracle_joins($join_where, $from, @join);
+ my ($self, $where, @join) = @_;
+ my $join_where = $self->_recurse_oracle_joins(@join);
+
if (keys %$join_where) {
if (!defined($where)) {
$where = $join_where;
}
sub _recurse_oracle_joins {
- my ($self, $where, $from, @join) = @_;
+ my $self = shift;
- foreach my $j (@join) {
+ my @where;
+ for my $j (@_) {
my ($to, $on) = @{ $j };
- if (ref $to eq 'ARRAY') {
- $self->_recurse_oracle_joins($where, @{ $to });
- }
+ push @where, $self->_recurse_oracle_joins(@{ $to })
+ if (ref $to eq 'ARRAY');
- my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $join_opts = ref $to eq 'ARRAY' ? $to->[0] : $to;
my $left_join = q{};
my $right_join = q{};
- if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
+ if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) {
#TODO: Support full outer joins -- this would happen much earlier in
#the sequence since oracle 8's full outer join syntax is best
#described as INSANE.
- croak "Can't handle full outer joins in Oracle 8 yet!\n"
- if $to_jt->{-join_type} =~ /full/i;
+ $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n")
+ if $jt =~ /full/i;
- $left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
- && $to_jt->{-join_type} !~ /inner/i;
+ $left_join = q{(+)} if $jt =~ /left/i
+ && $jt !~ /inner/i;
- $right_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
- && $to_jt->{-join_type} !~ /inner/i;
+ $right_join = q{(+)} if $jt =~ /right/i
+ && $jt !~ /inner/i;
}
- foreach my $lhs (keys %{ $on }) {
- $where->{$lhs . $left_join} = \"= $on->{ $lhs }$right_join";
- }
+ # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops
+ push @where, map { \sprintf ('%s%s = %s%s',
+ ref $_ ? $self->_recurse_where($_) : $self->_quote($_),
+ $left_join,
+ ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}),
+ $right_join,
+ )} keys %$on;
}
+
+ return { -and => \@where };
}
1;
=head1 PURPOSE
-This module was originally written to support Oracle < 9i where ANSI joins
-weren't supported at all, but became the module for Oracle >= 8 because
-Oracle's optimising of ANSI joins is horrible.
+This module is used with Oracle < 9.0 due to lack of support for standard
+ANSI join syntax.
=head1 SYNOPSIS
=over
-=item select ($\@$;$$@)
-
-Replaces DBIx::Class::SQLMaker's select() method, which calls _oracle_joins()
-to modify the column and table list before calling SUPER::select().
-
-=item _recurse_from ($$\@)
-
-Recursive subroutine that builds the table list.
-
-=item _oracle_joins ($$$@)
+=item select
-Creates the left/right relationship in the where query.
+Overrides DBIx::Class::SQLMaker's select() method, which calls _oracle_joins()
+to modify the column and table list before calling next::method().
=back
=head1 BUGS
-Does not support full outer joins.
-Probably lots more.
+Does not support full outer joins (however neither really does DBIC itself)
=head1 SEE ALSO
DBIx::Class::SQLMaker::SQLite;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
#
# SQLite does not understand SELECT ... FOR UPDATE
use warnings;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Carp;
use Try::Tiny;
use Scalar::Util 'weaken';
-use File::Spec;
use Sub::Name 'subname';
-use Module::Find();
-use Storable();
-use B qw/svref_2object/;
+use B 'svref_2object';
use namespace::clean;
use base qw/DBIx::Class/;
__PACKAGE__->load_namespaces();
__PACKAGE__->load_namespaces(
- result_namespace => 'Res',
- resultset_namespace => 'RSet',
- default_resultset_class => '+MyDB::Othernamespace::RSet',
- );
+ result_namespace => 'Res',
+ resultset_namespace => 'RSet',
+ default_resultset_class => '+MyDB::Othernamespace::RSet',
+ );
+
+With no arguments, this method uses L<Module::Find> to load all of the
+Result and ResultSet classes under the namespace of the schema from
+which it is called. For example, C<My::Schema> will by default find
+and load Result classes named C<My::Schema::Result::*> and ResultSet
+classes named C<My::Schema::ResultSet::*>.
+
+ResultSet classes are associated with Result class of the same name.
+For example, C<My::Schema::Result::CD> will get the ResultSet class
+C<My::Schema::ResultSet::CD> if it is present.
+
+Both Result and ResultSet namespaces are configurable via the
+C<result_namespace> and C<resultset_namespace> options.
-With no arguments, this method uses L<Module::Find> to load all your
-Result classes from a sub-namespace F<Result> under your Schema class'
-namespace, i.e. with a Schema of I<MyDB::Schema> all files in
-I<MyDB::Schema::Result> are assumed to be Result classes.
+Another option, C<default_resultset_class> specifies a custom default
+ResultSet class for Result classes with no corresponding ResultSet.
-It also finds all ResultSet classes in the namespace F<ResultSet> and
-loads them into the appropriate Result classes using for you. The
-matching is done by assuming the package name of the ResultSet class
-is the same as that of the Result class.
+All of the namespace and classname options are by default relative to
+the schema classname. To specify a fully-qualified name, prefix it
+with a literal C<+>. For example, C<+Other::NameSpace::Result>.
+
+=head3 Warnings
You will be warned if ResultSet classes are discovered for which there
are no matching Result classes like this:
We found ResultSet class '$rs_class' for '$result', but it seems
that you had already set '$result' to use '$rs_set' instead
-Both of the sub-namespaces are configurable if you don't like the defaults,
-via the options C<result_namespace> and C<resultset_namespace>.
-
-If (and only if) you specify the option C<default_resultset_class>, any found
-Result classes for which we do not find a corresponding
-ResultSet class will have their C<resultset_class> set to
-C<default_resultset_class>.
-
-All of the namespace and classname options to this method are relative to
-the schema classname by default. To specify a fully-qualified name, prefix
-it with a literal C<+>.
-
-Examples:
+=head3 Examples
# load My::Schema::Result::CD, My::Schema::Result::Artist,
# My::Schema::ResultSet::CD, etc...
resultset_namespace => '+Another::Place::RSets',
);
-If you'd like to use multiple namespaces of each type, simply use an arrayref
-of namespaces for that option. In the case that the same result
-(or resultset) class exists in multiple namespaces, the latter entries in
-your list of namespaces will override earlier ones.
+To search multiple namespaces for either Result or ResultSet classes,
+use an arrayref of namespaces for that option. In the case that the
+same result (or resultset) class exists in multiple namespaces, later
+entries in the list of namespaces will override earlier ones.
My::Schema->load_namespaces(
# My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
my $proto = shift;
my $ns = shift || ref $proto || $proto;
+ require Module::Find;
my @mods = Module::Find::findallmod($ns);
# try to untaint module names. mods where this fails
my @to_register;
{
- no warnings 'redefine';
- local *Class::C3::reinitialize = sub { };
- use warnings 'redefine';
+ no warnings qw/redefine/;
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
# ensure classes are loaded and attached in inheritance order
for my $res (values %results) {
. 'corresponding Result class';
}
- Class::C3->reinitialize;
+ Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
+
$class->register_class(@$_) for (@to_register);
return;
my @to_register;
{
no warnings qw/redefine/;
- local *Class::C3::reinitialize = sub { };
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
+
foreach my $prefix (keys %comps_for) {
foreach my $comp (@{$comps_for{$prefix}||[]}) {
my $comp_class = "${prefix}::${comp}";
}
}
}
- Class::C3->reinitialize;
+ Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
foreach my $to (@to_register) {
$class->register_class(@$to);
my $schema = $self->clone;
{
no warnings qw/redefine/;
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
+
no strict qw/refs/;
-# local *Class::C3::reinitialize = sub { };
foreach my $moniker ($schema->sources) {
my $source = $schema->source($moniker);
my $target_class = "${target}::${moniker}";
$schema->register_source($moniker, $source);
}
}
-# Class::C3->reinitialize();
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
{
no strict 'refs';
no warnings 'redefine';
=back
-Throws an exception. Defaults to using L<Carp::Clan> to report errors from
-user's perspective. See L</exception_action> for details on overriding
+Throws an exception. Obeys the exemption rules of L<DBIx::Class::Carp> to report
+errors from outer-user's perspective. See L</exception_action> for details on overriding
this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
default behavior will provide a detailed stack trace.
sub ddl_filename {
my ($self, $type, $version, $dir, $preversion) = @_;
+ require File::Spec;
+
my $filename = ref($self);
$filename =~ s/::/-/g;
$filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
sub thaw {
my ($self, $obj) = @_;
local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ require Storable;
return Storable::thaw($obj);
}
=cut
sub freeze {
+ require Storable;
return Storable::nfreeze($_[1]);
}
sub dclone {
my ($self, $obj) = @_;
local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ require Storable;
return Storable::dclone($obj);
}
{
my $global_phase_destroy;
- END { $global_phase_destroy++ }
+ # SpeedyCGI runs END blocks every cycle but keeps object instances
+ # hence we have to disable the globaldestroy hatch, and rely on the
+ # eval trap below (which appears to work, but is risky done so late)
+ END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
sub DESTROY {
return if $global_phase_destroy;
for my $moniker (keys %$srcs) {
# find first source that is not about to be GCed (someone other than $self
# holds a reference to it) and reattach to it, weakening our own link
+ #
+ # during global destruction (if we have not yet bailed out) this will throw
+ # which will serve as a signal to not try doing anything else
if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) {
- $srcs->{$moniker}->schema($self);
+ local $@;
+ eval {
+ $srcs->{$moniker}->schema($self);
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ last;
+ };
+
weaken $srcs->{$moniker};
last;
}
use warnings;
use base 'DBIx::Class::Schema';
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Time::HiRes qw/gettimeofday/;
use Try::Tiny;
use namespace::clean;
# db and schema at same version. do nothing
if ( $db_version eq $self->schema_version ) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
# db and schema at same version. do nothing
if ($db_version eq $target_version) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
$self->create_upgrade_path({ upgrade_file => $upgrade_file });
unless (-f $upgrade_file) {
- carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
return;
}
if($pversion eq $self->schema_version)
{
-# carp "This version is already installed\n";
+ #carp "This version is already installed";
return 1;
}
if(!$pversion)
{
- carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
return 1;
}
carp "Versions out of sync. This is " . $self->schema_version .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
+ ", your database contains version $pversion, please call upgrade on your Schema.";
}
# is this just a waste of time? if not then merge with DBI.pm
print $file $diff;
close($file);
- carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
+ carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.";
}
package DBIx::Class::Serialize::Storable;
use strict;
use warnings;
-use Storable;
-use Carp::Clan qw/^DBIx::Class/;
+use Storable();
+use DBIx::Class::Carp;
carp 'The Serialize::Storable component is now *DEPRECATED*. It has not '
.'been providing any useful functionality for quite a while, and in fact '
use DBIx::Class::Exception;
use Scalar::Util 'weaken';
-use IO::File;
use DBIx::Class::Storage::TxnScopeGuard;
use Try::Tiny;
use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' => qw/debug schema/);
-__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
+__PACKAGE__->mk_group_accessors('component_class' => 'cursor_class');
__PACKAGE__->cursor_class('DBIx::Class::Cursor');
=head2 debug
-Causes trace information to be emitted on the C<debugobj> object.
-(or C<STDERR> if C<debugobj> has not specifically been set).
+Causes trace information to be emitted on the L</debugobj> object.
+(or C<STDERR> if L</debugobj> has not specifically been set).
This is the equivalent to setting L</DBIC_TRACE> in your
shell environment.
reference. Callback is executed as $sub->($op, $info) where $op is
SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
-See L<debugobj> for a better way.
+See L</debugobj> for a better way.
=cut
=head2 DBIC_TRACE
If C<DBIC_TRACE> is set then trace information
-is produced (as when the L<debug> method is set).
+is produced (as when the L</debug> method is set).
If the value is of the form C<1=/path/name> then the trace output is
written to the file C</path/name>.
use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
-use DBI;
-use DBIx::Class::Storage::DBI::Cursor;
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use List::Util qw/first/;
-use Data::Dumper::Concise 'Dumper';
use Sub::Name 'subname';
use Try::Tiny;
-use File::Path 'make_path';
use overload ();
use namespace::clean;
-
# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
-__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class sql_limit_dialect/);
+__PACKAGE__->mk_group_accessors('inherited' => qw/
+ sql_limit_dialect sql_quote_char sql_name_sep
+/);
+
+__PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class datetime_parser_type/);
+
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
+__PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default
+
+__PACKAGE__->sql_name_sep('.');
__PACKAGE__->mk_group_accessors('simple' => qw/
_connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
no strict qw/refs/;
no warnings qw/redefine/;
*{__PACKAGE__ ."::$meth"} = subname $meth => sub {
- if (not $_[0]->_driver_determined and not $_[0]->{_in_determine_driver}) {
+ if (
+ # only fire when invoked on an instance, a valid class-based invocation
+ # would e.g. be setting a default for an inherited accessor
+ ref $_[0]
+ and
+ ! $_[0]->_driver_determined
+ and
+ ! $_[0]->{_in_determine_driver}
+ ) {
$_[0]->_determine_driver;
# This for some reason crashes and burns on perl 5.8.1
my $cref = $_[0]->can ($meth);
goto $cref;
}
+
goto $orig;
};
}
default L</sql_limit_dialect> setting of the storage (if any). For a list
of available limit dialects see L<DBIx::Class::SQLMaker::LimitDialects>.
+=item quote_names
+
+When true automatically sets L</quote_char> and L</name_sep> to the characters
+appropriate for your particular RDBMS. This option is preferred over specifying
+L</quote_char> directly.
+
=item quote_char
Specifies what characters to use to quote table and column names.
delete @attrs{@storage_opts} if @storage_opts;
my @sql_maker_opts = grep exists $attrs{$_},
- qw/limit_dialect quote_char name_sep/;
+ qw/limit_dialect quote_char name_sep quote_names/;
@{ $info{sql_maker_options} }{@sql_maker_opts} =
delete @attrs{@sql_maker_opts} if @sql_maker_opts;
# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
# It also informs dbh_do to bypass itself while under the direction of txn_do,
-# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
+# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
sub txn_do {
my $self = shift;
my $coderef = shift;
my ($self) = @_;
unless ($self->_sql_maker) {
my $sql_maker_class = $self->sql_maker_class;
- $self->ensure_class_loaded ($sql_maker_class);
my %opts = %{$self->_sql_maker_opts||{}};
my $dialect =
"Your storage class ($s_class) does not set sql_limit_dialect and you "
. 'have not supplied an explicit limit_dialect in your connection_info. '
. 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
- . 'databases but can be (and often is) painfully slow.'
+ . 'databases but can be (and often is) painfully slow. '
+ . "Please file an RT ticket against '$s_class' ."
);
'GenericSubQ';
}
;
+ my ($quote_char, $name_sep);
+
+ if ($opts{quote_names}) {
+ $quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do {
+ my $s_class = (ref $self) || $self;
+ carp (
+ "You requested 'quote_names' but your storage class ($s_class) does "
+ . 'not explicitly define a default sql_quote_char and you have not '
+ . 'supplied a quote_char as part of your connection_info. DBIC will '
+ .q{default to the ANSI SQL standard quote '"', which works most of }
+ . "the time. Please file an RT ticket against '$s_class'."
+ );
+
+ '"'; # RV
+ };
+
+ $name_sep = (delete $opts{name_sep}) || $self->sql_name_sep;
+ }
+
$self->_sql_maker($sql_maker_class->new(
bindtype=>'columns',
array_datatypes => 1,
limit_dialect => $dialect,
- name_sep => '.',
+ ($quote_char ? (quote_char => $quote_char) : ()),
+ name_sep => ($name_sep || '.'),
%opts,
));
}
}
sub _get_server_version {
- shift->_get_dbh->get_info(18);
+ shift->_dbh_get_info(18);
+}
+
+sub _dbh_get_info {
+ my ($self, $info) = @_;
+
+ return try { $self->_get_dbh->get_info($info) } || undef;
}
sub _determine_driver {
$self->_driver_determined(1);
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
$self->_init; # run driver-specific initializations
$self->_run_connection_actions
my $attrs = shift @do_args;
my @bind = map { [ undef, $_ ] } @do_args;
- $self->_query_start($sql, @bind);
+ $self->_query_start($sql, \@bind);
$self->_get_dbh->do($sql, $attrs, @do_args);
- $self->_query_end($sql, @bind);
+ $self->_query_end($sql, \@bind);
}
return $self;
try {
if(ref $info[0] eq 'CODE') {
- $dbh = $info[0]->();
+ $dbh = $info[0]->();
}
else {
- $dbh = DBI->connect(@info);
+ require DBI;
+ $dbh = DBI->connect(@info);
}
if (!$dbh) {
else {
# the handler may be invoked by something totally out of
# the scope of DBIC
- croak ("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
+ DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
}
}, '__DBIC__DBH__ERROR__HANDLER__';
}->($self, $dbh);
# easier to override in NoBindVars without duping the rest. It takes up
# all of _execute's args, and emits $sql, @bind.
sub _prep_for_execute {
- my ($self, $op, $extra_bind, $ident, $args) = @_;
+ my ($self, $op, $ident, $args) = @_;
- if( blessed $ident && $ident->isa("DBIx::Class::ResultSource") ) {
- $ident = $ident->from();
- }
+ my ($sql, @bind) = $self->sql_maker->$op(
+ blessed($ident) ? $ident->from : $ident,
+ @$args,
+ );
- my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
+ my (@final_bind, $colinfos);
+ my $resolve_bindinfo = sub {
+ $colinfos ||= $self->_resolve_column_info($ident);
+ if (my $col = $_[1]->{dbic_colname}) {
+ $_[1]->{sqlt_datatype} ||= $colinfos->{$col}{data_type}
+ if $colinfos->{$col}{data_type};
+ $_[1]->{sqlt_size} ||= $colinfos->{$col}{size}
+ if $colinfos->{$col}{size};
+ }
+ $_[1];
+ };
+
+ for my $e (@{$args->[2]{bind}||[]}, @bind) {
+ push @final_bind, [ do {
+ if (ref $e ne 'ARRAY') {
+ ({}, $e)
+ }
+ elsif (! defined $e->[0]) {
+ ({}, $e->[1])
+ }
+ elsif (ref $e->[0] eq 'HASH') {
+ (
+ (first { $e->[0]{$_} } qw/dbd_attrs sqlt_datatype/) ? $e->[0] : $self->$resolve_bindinfo($e->[0]),
+ $e->[1]
+ )
+ }
+ elsif (ref $e->[0] eq 'SCALAR') {
+ ( { sqlt_datatype => ${$e->[0]} }, $e->[1] )
+ }
+ else {
+ ( $self->$resolve_bindinfo({ dbic_colname => $e->[0] }), $e->[1] )
+ }
+ }];
+ }
- unshift(@bind,
- map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
- if $extra_bind;
- return ($sql, \@bind);
+ ($sql, \@final_bind);
}
+sub _format_for_trace {
+ #my ($self, $bind) = @_;
-sub _fix_bind_params {
- my ($self, @bind) = @_;
+ ### Turn @bind from something like this:
+ ### ( [ "artist", 1 ], [ \%attrs, 3 ] )
+ ### to this:
+ ### ( "'1'", "'3'" )
- ### Turn @bind from something like this:
- ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
- ### to this:
- ### ( "'1'", "'1'", "'3'" )
- return
- map {
- if ( defined( $_ && $_->[1] ) ) {
- map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
- }
- else { q{NULL}; }
- } @bind;
+ map {
+ defined( $_ && $_->[1] )
+ ? qq{'$_->[1]'}
+ : q{NULL}
+ } @{$_[1] || []};
}
sub _query_start {
- my ( $self, $sql, @bind ) = @_;
-
- if ( $self->debug ) {
- @bind = $self->_fix_bind_params(@bind);
+ my ( $self, $sql, $bind ) = @_;
- $self->debugobj->query_start( $sql, @bind );
- }
+ $self->debugobj->query_start( $sql, $self->_format_for_trace($bind) )
+ if $self->debug;
}
sub _query_end {
- my ( $self, $sql, @bind ) = @_;
+ my ( $self, $sql, $bind ) = @_;
- if ( $self->debug ) {
- @bind = $self->_fix_bind_params(@bind);
- $self->debugobj->query_end( $sql, @bind );
- }
+ $self->debugobj->query_end( $sql, $self->_format_for_trace($bind) )
+ if $self->debug;
}
-sub _dbh_execute {
- my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
-
- my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+my $sba_compat;
+sub _dbi_attrs_for_bind {
+ my ($self, $ident, $bind) = @_;
- $self->_query_start( $sql, @$bind );
+ if (! defined $sba_compat) {
+ $self->_determine_driver;
+ $sba_compat = $self->can('source_bind_attributes') == \&source_bind_attributes
+ ? 0
+ : 1
+ ;
+ }
- my $sth = $self->sth($sql,$op);
+ my $sba_attrs;
+ if ($sba_compat) {
+ my $class = ref $self;
+ carp_unique (
+ "The source_bind_attributes() override in $class relies on a deprecated codepath. "
+ .'You are strongly advised to switch your code to override bind_attribute_by_datatype() '
+ .'instead. This legacy compat shim will also disappear some time before DBIC 0.09'
+ );
- my $placeholder_index = 1;
+ my $sba_attrs = $self->source_bind_attributes
+ }
- foreach my $bound (@$bind) {
- my $attributes = {};
- my($column_name, @data) = @$bound;
+ my @attrs;
- if ($bind_attributes) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
+ for (map { $_->[0] } @$bind) {
+ push @attrs, do {
+ if ($_->{dbd_attrs}) {
+ $_->{dbd_attrs}
+ }
+ elsif($_->{sqlt_datatype}) {
+ $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+ }
+ elsif ($sba_attrs and $_->{dbic_colname}) {
+ $sba_attrs->{$_->{dbic_colname}} || undef;
+ }
+ else {
+ undef; # always push something at this position
+ }
}
+ }
- foreach my $data (@data) {
- my $ref = ref $data;
+ return \@attrs;
+}
- if ($ref and overload::Method($data, '""') ) {
- $data = "$data";
- }
- elsif ($ref eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts
- $sth->bind_param_inout(
- $placeholder_index++,
- $data,
- $self->_max_column_bytesize($ident, $column_name),
- $attributes
- );
- next;
- }
+sub _execute {
+ my ($self, $op, $ident, @args) = @_;
+
+ my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args);
+
+ shift->dbh_do( # retry over disconnects
+ '_dbh_execute',
+ $sql,
+ $bind,
+ $self->_dbi_attrs_for_bind($ident, $bind)
+ );
+}
- $sth->bind_param($placeholder_index++, $data, $attributes);
+sub _dbh_execute {
+ my ($self, undef, $sql, $bind, $bind_attrs) = @_;
+
+ $self->_query_start( $sql, $bind );
+ my $sth = $self->_sth($sql);
+
+ for my $i (0 .. $#$bind) {
+ if (ref $bind->[$i][1] eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts
+ $sth->bind_param_inout(
+ $i + 1, # bind params counts are 1-based
+ $bind->[$i][1],
+ $bind->[$i][0]{dbd_size} || $self->_max_column_bytesize($bind->[$i][0]), # size
+ $bind_attrs->[$i],
+ );
+ }
+ else {
+ $sth->bind_param(
+ $i + 1,
+ (ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""'))
+ ? "$bind->[$i][1]"
+ : $bind->[$i][1]
+ ,
+ $bind_attrs->[$i],
+ );
}
}
$sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...'
) if !$rv;
- $self->_query_end( $sql, @$bind );
+ $self->_query_end( $sql, $bind );
return (wantarray ? ($rv, $sth, @$bind) : $rv);
}
-sub _execute {
- my $self = shift;
- $self->dbh_do('_dbh_execute', @_); # retry over disconnects
-}
-
sub _prefetch_autovalues {
my ($self, $source, $to_insert) = @_;
}
}
- my $bind_attributes = $self->source_bind_attributes($source);
-
- my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $sqla_opts);
+ my ($rv, $sth) = $self->_execute('insert', $source, $to_insert, $sqla_opts);
my %returned_cols;
}
-## Currently it is assumed that all values passed will be "normal", i.e. not
-## scalar refs, or at least, all the same type as the first set, the statement is
-## only prepped once.
sub insert_bulk {
my ($self, $source, $cols, $data) = @_;
- my %colvalues;
- @colvalues{@$cols} = (0..$#$cols);
-
- for my $i (0..$#$cols) {
- my $first_val = $data->[0][$i];
- next unless ref $first_val eq 'SCALAR';
-
- $colvalues{ $cols->[$i] } = $first_val;
+ # FIXME - perhaps this is not even needed? does DBI stringify?
+ #
+ # forcibly stringify whatever is stringifiable
+ for my $r (0 .. $#$data) {
+ for my $c (0 .. $#{$data->[$r]}) {
+ $data->[$r][$c] = "$data->[$r][$c]"
+ if ( ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') );
+ }
}
- # check for bad data and stringify stringifiable objects
- my $bad_slice = sub {
- my ($msg, $col_idx, $slice_idx) = @_;
- $self->throw_exception(sprintf "%s for column '%s' in populate slice:\n%s",
- $msg,
- $cols->[$col_idx],
- do {
- local $Data::Dumper::Maxdepth = 1; # don't dump objects, if any
- Dumper {
- map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
- },
- }
- );
- };
-
- for my $datum_idx (0..$#$data) {
- my $datum = $data->[$datum_idx];
+ # check the data for consistency
+ # report a sensible error on bad data
+ #
+ # also create a list of dynamic binds (ones that will be changing
+ # for each row)
+ my $dyn_bind_idx;
+ for my $col_idx (0..$#$cols) {
+
+ # the first "row" is used as a point of reference
+ my $reference_val = $data->[0][$col_idx];
+ my $is_literal = ref $reference_val eq 'SCALAR';
+ my $is_literal_bind = ( !$is_literal and (
+ ref $reference_val eq 'REF'
+ and
+ ref $$reference_val eq 'ARRAY'
+ ) );
+
+ $dyn_bind_idx->{$col_idx} = 1
+ if (!$is_literal and !$is_literal_bind);
+
+ # use a closure for convenience (less to pass)
+ my $bad_slice = sub {
+ my ($msg, $slice_idx) = @_;
+ $self->throw_exception(sprintf "%s for column '%s' in populate slice:\n%s",
+ $msg,
+ $cols->[$col_idx],
+ do {
+ require Data::Dumper::Concise;
+ local $Data::Dumper::Maxdepth = 2;
+ Data::Dumper::Concise::Dumper ({
+ map { $cols->[$_] =>
+ $data->[$slice_idx][$_]
+ } (0 .. $#$cols)
+ }),
+ }
+ );
+ };
- for my $col_idx (0..$#$cols) {
- my $val = $datum->[$col_idx];
- my $sqla_bind = $colvalues{ $cols->[$col_idx] };
- my $is_literal_sql = (ref $sqla_bind) eq 'SCALAR';
+ for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1
+ my $val = $data->[$row_idx][$col_idx];
- if ($is_literal_sql) {
- if (not ref $val) {
- $bad_slice->('bind found where literal SQL expected', $col_idx, $datum_idx);
+ if ($is_literal) {
+ if (ref $val ne 'SCALAR') {
+ $bad_slice->(
+ "Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
+ $row_idx
+ );
}
- elsif ((my $reftype = ref $val) ne 'SCALAR') {
- $bad_slice->("$reftype reference found where literal SQL expected",
- $col_idx, $datum_idx);
+ elsif ($$val ne $$reference_val) {
+ $bad_slice->(
+ "Inconsistent literal SQL value (expecting \\'$$reference_val')",
+ $row_idx
+ );
+ }
+ }
+ elsif ($is_literal_bind) {
+ if (ref $val ne 'REF' or ref $$val ne 'ARRAY') {
+ $bad_slice->(
+ "Incorrect value (expecting ARRAYREF-ref \\['${$reference_val}->[0]', ... ])",
+ $row_idx
+ );
}
- elsif ($$val ne $$sqla_bind){
- $bad_slice->("inconsistent literal SQL value, expecting: '$$sqla_bind'",
- $col_idx, $datum_idx);
+ elsif (${$val}->[0] ne ${$reference_val}->[0]) {
+ $bad_slice->(
+ "Inconsistent literal SQL-bind value (expecting \\['${$reference_val}->[0]', ... ])",
+ $row_idx
+ );
}
}
- elsif (my $reftype = ref $val) {
- require overload;
- if (overload::Method($val, '""')) {
- $datum->[$col_idx] = "".$val;
+ elsif (ref $val) {
+ if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) {
+ $bad_slice->("Literal SQL found where a plain bind value is expected", $row_idx);
}
else {
- $bad_slice->("$reftype reference found where bind expected",
- $col_idx, $datum_idx);
+ $bad_slice->("$val reference found where bind expected", $row_idx);
}
}
}
}
- my ($sql, $bind) = $self->_prep_for_execute (
- 'insert', undef, $source, [\%colvalues]
+ # Get the sql with bind values interpolated where necessary. For dynamic
+ # binds convert the values of the first row into a literal+bind combo, with
+ # extra positional info in the bind attr hashref. This will allow us to match
+ # the order properly, and is so contrived because a user-supplied literal
+ # bind (or something else specific to a resultsource and/or storage driver)
+ # can inject extra binds along the way, so one can't rely on "shift
+ # positions" ordering at all. Also we can't just hand SQLA a set of some
+ # known "values" (e.g. hashrefs that can be later matched up by address),
+ # because we want to supply a real value on which perhaps e.g. datatype
+ # checks will be performed
+ my ($sql, $proto_bind) = $self->_prep_for_execute (
+ 'insert',
+ $source,
+ [ { map { $cols->[$_] => $dyn_bind_idx->{$_}
+ ? \[ '?', [
+ { dbic_colname => $cols->[$_], _bind_data_slice_idx => $_ }
+ =>
+ $data->[0][$_]
+ ] ]
+ : $data->[0][$_]
+ } (0..$#$cols) } ],
);
- if (! @$bind) {
- # if the bindlist is empty - make sure all "values" are in fact
- # literal scalarrefs. If not the case this means the storage ate
- # them away (e.g. the NoBindVars component) and interpolated them
- # directly into the SQL. This obviosly can't be good for multi-inserts
-
- $self->throw_exception('Cannot insert_bulk without support for placeholders')
- if first { ref $_ ne 'SCALAR' } values %colvalues;
+ if (! @$proto_bind and keys %$dyn_bind_idx) {
+ # if the bindlist is empty and we had some dynamic binds, this means the
+ # storage ate them away (e.g. the NoBindVars component) and interpolated
+ # them directly into the SQL. This obviosly can't be good for multi-inserts
+ $self->throw_exception('Cannot insert_bulk without support for placeholders');
}
# neither _execute_array, nor _execute_inserts_with_no_binds are
# scope guard
my $guard = $self->txn_scope_guard;
- $self->_query_start( $sql, @$bind ? [ dummy => '__BULK_INSERT__' ] : () );
- my $sth = $self->sth($sql);
+ $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () );
+ my $sth = $self->_sth($sql);
my $rv = do {
- if (@$bind) {
- #@bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
- $self->_execute_array( $source, $sth, $bind, $cols, $data );
+ if (@$proto_bind) {
+ # proto bind contains the information on which pieces of $data to pull
+ # $cols is passed in only for prettier error-reporting
+ $self->_execute_array( $source, $sth, $proto_bind, $cols, $data );
}
else {
# bind_param_array doesn't work if there are no binds
}
};
- $self->_query_end( $sql, @$bind ? [ dummy => '__BULK_INSERT__' ] : () );
+ $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
$guard->commit;
- return (wantarray ? ($rv, $sth, @$bind) : $rv);
+ return (wantarray ? ($rv, $sth, @$proto_bind) : $rv);
}
sub _execute_array {
- my ($self, $source, $sth, $bind, $cols, $data, @extra) = @_;
+ my ($self, $source, $sth, $proto_bind, $cols, $data, @extra) = @_;
## This must be an arrayref, else nothing works!
my $tuple_status = [];
- ## Get the bind_attributes, if any exist
- my $bind_attributes = $self->source_bind_attributes($source);
-
- ## Bind the values and execute
- my $placeholder_index = 1;
-
- foreach my $bound (@$bind) {
-
- my $attributes = {};
- my ($column_name, $data_index) = @$bound;
+ my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
- if( $bind_attributes ) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
- }
-
- my @data = map { $_->[$data_index] } @$data;
+ # Bind the values by column slices
+ for my $i (0 .. $#$proto_bind) {
+ my $data_slice_idx = (
+ ref $proto_bind->[$i][0] eq 'HASH'
+ and
+ exists $proto_bind->[$i][0]{_bind_data_slice_idx}
+ ) ? $proto_bind->[$i][0]{_bind_data_slice_idx} : undef;
$sth->bind_param_array(
- $placeholder_index,
- [@data],
- (%$attributes ? $attributes : ()),
+ $i+1, # DBI bind indexes are 1-based
+ defined $data_slice_idx
+ # either get a "column" of dynamic values, or just repeat the same
+ # bind over and over
+ ? [ map { $_->[$data_slice_idx] } @$data ]
+ : [ ($proto_bind->[$i][1]) x @$data ]
+ ,
+ defined $bind_attrs->[$i] ? $bind_attrs->[$i] : (), # some DBDs throw up when given an undef
);
- $placeholder_index++;
}
my ($rv, $err);
$self->throw_exception("Unexpected populate error: $err")
if ($i > $#$tuple_status);
- $self->throw_exception(sprintf "%s for populate slice:\n%s",
+ require Data::Dumper::Concise;
+ $self->throw_exception(sprintf "execute_array() aborted with '%s' at populate slice:\n%s",
($tuple_status->[$i][1] || $err),
- Dumper { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) },
+ Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
);
}
}
sub _dbh_execute_array {
- my ($self, $sth, $tuple_status, @extra) = @_;
-
- return $sth->execute_array({ArrayTupleStatus => $tuple_status});
+ #my ($self, $sth, $tuple_status, @extra) = @_;
+ return $_[1]->execute_array({ArrayTupleStatus => $_[2]});
}
sub _dbh_execute_inserts_with_no_binds {
}
sub update {
- my ($self, $source, @args) = @_;
-
- my $bind_attrs = $self->source_bind_attributes($source);
-
- return $self->_execute('update' => [], $source, $bind_attrs, @args);
+ #my ($self, $source, @args) = @_;
+ shift->_execute('update', @_);
}
sub delete {
- my ($self, $source, @args) = @_;
-
- my $bind_attrs = $self->source_bind_attributes($source);
-
- return $self->_execute('delete' => [], $source, $bind_attrs, @args);
+ #my ($self, $source, @args) = @_;
+ shift->_execute('delete', @_);
}
# We were sent here because the $rs contains a complex search
sub _select_args_to_query {
my $self = shift;
- # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $rs_attrs, $rows, $offset)
+ # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
# = $self->_select_args($ident, $select, $cond, $attrs);
- my ($op, $bind, $ident, $bind_attrs, @args) =
+ my ($op, $ident, @args) =
$self->_select_args(@_);
- # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
- my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, \@args);
+ # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
+ my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $ident, \@args);
$prepared_bind ||= [];
return wantarray
- ? ($sql, $prepared_bind, $bind_attrs)
+ ? ($sql, $prepared_bind)
: \[ "($sql)", @$prepared_bind ]
;
}
,
};
- # calculate bind_attrs before possible $ident mangling
- my $bind_attrs = {};
- for my $alias (keys %$alias2source) {
- my $bindtypes = $self->source_bind_attributes ($alias2source->{$alias}) || {};
- for my $col (keys %$bindtypes) {
-
- my $fqcn = join ('.', $alias, $col);
- $bind_attrs->{$fqcn} = $bindtypes->{$col} if $bindtypes->{$col};
-
- # Unqialified column names are nice, but at the same time can be
- # rather ambiguous. What we do here is basically go along with
- # the loop, adding an unqualified column slot to $bind_attrs,
- # alongside the fully qualified name. As soon as we encounter
- # another column by that name (which would imply another table)
- # we unset the unqualified slot and never add any info to it
- # to avoid erroneous type binding. If this happens the users
- # only choice will be to fully qualify his column name
-
- if (exists $bind_attrs->{$col}) {
- $bind_attrs->{$col} = {};
- }
- else {
- $bind_attrs->{$col} = $bind_attrs->{$fqcn};
- }
- }
- }
-
# Sanity check the attributes (SQLMaker does it too, but
# in case of a software_limit we'll never reach there)
if (defined $attrs->{offset}) {
$self->throw_exception('A supplied offset attribute must be a non-negative integer')
if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
}
- $attrs->{offset} ||= 0;
if (defined $attrs->{rows}) {
$self->throw_exception("The rows attribute must be a positive integer if present")
= $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
}
elsif (! $attrs->{software_limit} ) {
- push @limit, $attrs->{rows}, $attrs->{offset};
+ push @limit, (
+ $attrs->{rows} || (),
+ $attrs->{offset} || (),
+ );
}
# try to simplify the joinmap further (prune unreferenced type-single joins)
# invoked, and that's just bad...
###
- return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $attrs, @limit);
+ return ('select', $ident, $select, $where, $attrs, @limit);
}
# Returns a counting SELECT for a simple count
return { count => '*' };
}
-
sub source_bind_attributes {
- my ($self, $source) = @_;
-
- my $bind_attributes;
-
- my $colinfo = $source->columns_info;
-
- for my $col (keys %$colinfo) {
- if (my $dt = $colinfo->{$col}{data_type} ) {
- $bind_attributes->{$col} = $self->bind_attribute_by_data_type($dt)
- }
- }
-
- return $bind_attributes;
+ shift->throw_exception(
+ 'source_bind_attributes() was never meant to be a callable public method - '
+ .'please contact the DBIC dev-team and describe your use case so that a reasonable '
+ .'solution can be provided'
+ ."\nhttp://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT"
+ );
}
=head2 select
=head2 sql_limit_dialect
This is an accessor for the default SQL limit dialect used by a particular
-storage driver. Can be overriden by supplying an explicit L</limit_dialect>
+storage driver. Can be overridden by supplying an explicit L</limit_dialect>
to L<DBIx::Class::Schema/connect>. For a list of available limit dialects
see L<DBIx::Class::SQLMaker::LimitDialects>.
# XXX You would think RaiseError would make this impossible,
# but apparently that's not true :(
- $self->throw_exception($dbh->errstr) if !$sth;
+ $self->throw_exception(
+ $dbh->errstr
+ ||
+ sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
+ .'an exception and/or setting $dbh->errstr',
+ length ($sql) > 20
+ ? substr($sql, 0, 20) . '...'
+ : $sql
+ ,
+ 'DBD::' . $dbh->{Driver}{Name},
+ )
+ ) if !$sth;
$sth;
}
sub sth {
+ carp_unique 'sth was mistakenly marked/documented as public, stop calling it (will be removed before DBIC v0.09)';
+ shift->_sth(@_);
+}
+
+sub _sth {
my ($self, $sql) = @_;
$self->dbh_do('_dbh_sth', $sql); # retry over disconnects
}
=cut
sub is_datatype_numeric {
- my ($self, $dt) = @_;
+ #my ($self, $dt) = @_;
- return 0 unless $dt;
+ return 0 unless $_[1];
- return $dt =~ /^ (?:
+ $_[1] =~ /^ (?:
numeric | int(?:eger)? | (?:tiny|small|medium|big)int | dec(?:imal)? | real | float | double (?: \s+ precision)? | (?:big)?serial
) $/ix;
}
} else {
-d $dir
or
- make_path ("$dir") # make_path does not like objects (i.e. Path::Class::Dir)
+ (require File::Path and File::Path::make_path ("$dir")) # make_path does not like objects (i.e. Path::Class::Dir)
or
$self->throw_exception(
- "Failed to create '$dir': " . ($! || $@ || 'error unknow')
+ "Failed to create '$dir': " . ($! || $@ || 'error unknown')
);
}
my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
+ # FIXME replace this block when a proper sane sql parser is available
my $file;
open($file, "<$filename")
or $self->throw_exception("Can't open $filename ($!)");
return wantarray ? @ret : $ret[0];
}
+# FIXME deploy() currently does not accurately report sql errors
+# Will always return true while errors are warned
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
my $deploy = sub {
my $line = shift;
- return if($line =~ /^--/);
return if(!$line);
+ return if($line =~ /^--/);
# next if($line =~ /^DROP/m);
return if($line =~ /^BEGIN TRANSACTION/m);
return if($line =~ /^COMMIT/m);
}
}
elsif (@statements == 1) {
- foreach my $line ( split(";\n", $statements[0])) {
+ # split on single line comments and end of statements
+ foreach my $line ( split(/\s*--.*\n|;\n/, $statements[0])) {
$deploy->( $line );
}
}
=head2 datetime_parser_type
-Defines (returns) the datetime parser class - currently hardwired to
-L<DateTime::Format::MySQL>
-
-=cut
-
-sub datetime_parser_type { "DateTime::Format::MySQL"; }
+Defines the datetime parser class - currently defaults to L<DateTime::Format::MySQL>
=head2 build_datetime_parser
sub build_datetime_parser {
my $self = shift;
my $type = $self->datetime_parser_type(@_);
- $self->ensure_class_loaded ($type);
return $type;
}
# version and it may be necessary to amend or override it for a specific storage
# if such binds are necessary.
sub _max_column_bytesize {
- my ($self, $source, $col) = @_;
+ my ($self, $attr) = @_;
- my $inf = $source->column_info($col);
- return $inf->{_max_bytesize} ||= do {
+ my $max_size;
- my $max_size;
+ if ($attr->{sqlt_datatype}) {
+ my $data_type = lc($attr->{sqlt_datatype});
- if (my $data_type = $inf->{data_type}) {
- $data_type = lc($data_type);
+ if ($attr->{sqlt_size}) {
# String/sized-binary types
- if ($data_type =~ /^(?:l?(?:var)?char(?:acter)?(?:\s*varying)?
- |(?:var)?binary(?:\s*varying)?|raw)\b/x
+ if ($data_type =~ /^(?:
+ l? (?:var)? char(?:acter)? (?:\s*varying)?
+ |
+ (?:var)? binary (?:\s*varying)?
+ |
+ raw
+ )\b/x
) {
- $max_size = $inf->{size};
+ $max_size = $attr->{sqlt_size};
}
# Other charset/unicode types, assume scale of 4
- elsif ($data_type =~ /^(?:national\s*character(?:\s*varying)?|nchar
- |univarchar
- |nvarchar)\b/x
+ elsif ($data_type =~ /^(?:
+ national \s* character (?:\s*varying)?
+ |
+ nchar
+ |
+ univarchar
+ |
+ nvarchar
+ )\b/x
) {
- $max_size = $inf->{size} * 4 if $inf->{size};
- }
- # Blob types
- elsif ($self->_is_lob_type($data_type)) {
- # default to longreadlen
- }
- else {
- $max_size = 100; # for all other (numeric?) datatypes
+ $max_size = $attr->{sqlt_size} * 4;
}
}
- $max_size ||= $self->_get_dbh->{LongReadLen} || 8000;
- };
+ if (!$max_size and !$self->_is_lob_type($data_type)) {
+ $max_size = 100 # for all other (numeric?) datatypes
+ }
+ }
+
+ $max_size || $self->_dbic_connect_attributes->{LongReadLen} || $self->_get_dbh->{LongReadLen} || 8000;
}
# Determine if a data_type is some type of BLOB
sub _is_lob_type {
my ($self, $data_type) = @_;
- $data_type && ($data_type =~ /(?:lob|bfile|text|image|bytea|memo)/i
- || $data_type =~ /^long(?:\s*(?:raw|bit\s*varying|varbit|binary
+ $data_type && ($data_type =~ /lob|bfile|text|image|bytea|memo/i
+ || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary
|varchar|character\s*varying|nvarchar
- |national\s*character\s*varying))?$/xi);
+ |national\s*character\s*varying))?\z/xi);
+}
+
+sub _is_binary_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /blob|bfile|image|bytea/i
+ || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary))?\z/xi);
+}
+
+sub _is_text_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /^(?:clob|memo)\z/i
+ || $data_type =~ /^long(?:\s+(?:varchar|character\s*varying|nvarchar
+ |national\s*character\s*varying))\z/xi);
}
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::ACCESS;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::UniqueIdentifier';
+use mro 'c3';
+
+use List::Util 'first';
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('Top');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::ACCESS');
+__PACKAGE__->sql_quote_char ([qw/[ ]/]);
+
+sub sqlt_type { 'ACCESS' }
+
+__PACKAGE__->new_guid(undef);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ACCESS - Support specific to MS Access
+
+=head1 DESCRIPTION
+
+This is the base class for Microsoft Access support.
+
+This driver supports L<last_insert_id|DBIx::Class::Storage::DBI/last_insert_id>,
+empty inserts for tables with C<AUTOINCREMENT> columns, nested transactions via
+L<auto_savepoint|DBIx::Class::Storage::DBI/auto_savepoint>, C<GUID> columns via
+L<DBIx::Class::Storage::DBI::UniqueIdentifier>.
+
+=head1 SUPPORTED VERSIONS
+
+This module has currently only been tested on MS Access 2010.
+
+Information about how well it works on different version of MS Access is welcome
+(write the mailing list, or submit a ticket to RT if you find bugs.)
+
+=head1 USING GUID COLUMNS
+
+If you have C<GUID> PKs or other C<GUID> columns with
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> you will need to set a
+L<new_guid|DBIx::Class::Storage::DBI::UniqueIdentifier/new_guid> callback, like
+so:
+
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+Under L<Catalyst> you can use code similar to this in your
+L<Catalyst::Model::DBIC::Schema> C<Model.pm>:
+
+ after BUILD => sub {
+ my $self = shift;
+ $self->storage->new_guid(sub { Data::GUID->new->as_string });
+ };
+
+=cut
+
+sub _dbh_last_insert_id { $_[1]->selectrow_array('select @@identity') }
+
+# support empty insert
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $columns_info = $source->columns_info;
+
+ if (keys %$to_insert == 0) {
+ my $autoinc_col = first {
+ $columns_info->{$_}{is_auto_increment}
+ } keys %$columns_info;
+
+ if (not $autoinc_col) {
+ $self->throw_exception(
+'empty insert only supported for tables with an autoincrement column'
+ );
+ }
+
+ my $table = $source->from;
+ $table = $$table if ref $table;
+
+ $to_insert->{$autoinc_col} = \"dmax('${autoinc_col}', '${table}')+1";
+ }
+
+ return $self->next::method(@_);
+}
+
+sub bind_attribute_by_data_type {
+ my $self = shift;
+ my ($data_type) = @_;
+
+ my $attributes = $self->next::method(@_) || {};
+
+ if ($self->_is_text_lob_type($data_type)) {
+ $attributes->{TYPE} = DBI::SQL_LONGVARCHAR;
+ }
+ elsif ($self->_is_binary_lob_type($data_type)) {
+ $attributes->{TYPE} = DBI::SQL_LONGVARBINARY;
+ }
+
+ return $attributes;
+}
+
+# savepoints are not supported, but nested transactions are.
+# Unfortunately DBI does not support nested transactions.
+# WARNING: this code uses the undocumented 'BegunWork' DBI attribute.
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->throw_exception(
+ 'cannot BEGIN a nested transaction on a disconnected handle'
+ ) unless $self->_dbh;
+
+ local $self->_dbh->{AutoCommit} = 1;
+ local $self->_dbh->{BegunWork} = 0;
+ $self->_dbh_begin_work;
+}
+
+# A new nested transaction on the same level releases the previous one.
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->throw_exception(
+ 'cannot ROLLBACK a nested transaction on a disconnected handle'
+ ) unless $self->_dbh;
+
+ local $self->_dbh->{AutoCommit} = 0;
+ local $self->_dbh->{BegunWork} = 1;
+ $self->_dbh_rollback;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
-package # hide from PAUSE
- DBIx::Class::Storage::DBI::ADO;
+package DBIx::Class::Storage::DBI::ADO;
use base 'DBIx::Class::Storage::DBI';
-use Try::Tiny;
+use mro 'c3';
+
+use Sub::Name;
use namespace::clean;
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO - Support for L<DBD::ADO>
+
+=head1 DESCRIPTION
+
+This class provides a mechanism for discovering and loading a sub-class
+for a specific ADO backend, as well as some workarounds for L<DBD::ADO>. It
+should be transparent to the user.
+
+=cut
+
sub _rebless {
my $self = shift;
-# check for MSSQL
-# XXX This should be using an OpenSchema method of some sort, but I don't know
-# how.
-# Current version is stolen from Sybase.pm
- try {
- my $dbtype = @{$self->_get_dbh
- ->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})
- }[2];
-
- $dbtype =~ s/\W/_/gi;
- my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
- }
+ my $dbtype = $self->_dbh_get_info(17);
+
+ if (not $dbtype) {
+ warn "Unable to determine ADO driver, failling back to generic support.\n";
+ return;
+ }
+
+ $dbtype =~ s/\W/_/gi;
+
+ my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
+
+ return if $self->isa($subclass);
+
+ if ($self->load_optional_class($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
+ }
+ else {
+ warn "Expected driver '$subclass' not found, using generic support. " .
+ "Please file an RT.\n";
+ }
+}
+
+# cleanup some warnings from DBD::ADO
+# RT#65563, not fixed as of DBD::ADO v2.98
+sub _dbh_get_info {
+ my $self = shift;
+
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_)
+ unless $_[0] =~ m{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm};
};
+
+ $self->next::method(@_);
+}
+
+# Monkeypatch out the horrible warnings during global destruction.
+# A patch to DBD::ADO has been submitted as well.
+# https://rt.cpan.org/Ticket/Display.html?id=65563
+sub _init {
+ no warnings 'redefine';
+ require DBD::ADO;
+
+ if ($DBD::ADO::VERSION <= 2.98) {
+ my $disconnect = *DBD::ADO::db::disconnect{CODE};
+
+ *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_)
+ unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
+ };
+ $disconnect->(@_);
+ };
+ }
}
# Here I was just experimenting with ADO cursor types, left in as a comment in
#}
1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::MS_Jet;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Storage::DBI::ADO
+ DBIx::Class::Storage::DBI::ACCESS
+/;
+use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor ();
+
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::MS_Jet - Support for MS Access over ADO
+
+=head1 DESCRIPTION
+
+This driver is a subclass of L<DBIx::Class::Storage::DBI::ADO> and
+L<DBIx::Class::Storage::DBI::ACCESS> for connecting to MS Access via
+L<DBD::ADO>.
+
+See the documentation for L<DBIx::Class::Storage::DBI::ACCESS> for
+information on the MS Access driver for L<DBIx::Class>.
+
+This driver implements workarounds for C<TEXT/IMAGE/MEMO> columns, sets the
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor> to normalize returned
+C<GUID> values and provides L<DBIx::Class::InflateColumn::DateTime> support
+for C<DATETIME> columns.
+
+=head1 EXAMPLE DSNs
+
+ # older Access versions:
+ dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb
+
+ # newer Access versions:
+ dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False'
+
+=head1 TEXT/IMAGE/MEMO COLUMNS
+
+The ADO driver does not suffer from the
+L<problems|DBIx::Class::Storage::DBI::ODBC::ACCESS/"TEXT/IMAGE/MEMO COLUMNS">
+the L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver has with these types
+of columns. You can use them safely.
+
+When you execute a C<CREATE TABLE> statement over this driver with a C<TEXT>
+column, it will be converted to C<MEMO>, while in the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver it is converted to
+C<VARCHAR(255)>.
+
+However, the caveat about L<LongReadLen|DBI/LongReadLen> having to be twice the
+max size of your largest C<MEMO/TEXT> column C<+1> still applies. L<DBD::ADO>
+sets L<LongReadLen|DBI/LongReadLen> to a large value by default, so it should be
+safe to just leave it unset. If you do pass a L<LongReadLen|DBI/LongReadLen> in
+your L<connect_info|DBIx::Class::Storage::DBI/connect_info>, it will be
+multiplied by two and C<1> added, just as for the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver.
+
+=cut
+
+# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO)
+sub _run_connection_actions {
+ my $self = shift;
+
+ my $long_read_len = $self->_dbh->{LongReadLen};
+
+# This is the DBD::ADO default.
+ if ($long_read_len != 2147483647) {
+ $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
+ }
+
+ return $self->next::method(@_);
+}
+
+# AutoCommit does not get reset properly after transactions for some reason
+# (probably because of my nested transaction hacks in ACCESS.pm) fix it up
+# here.
+
+sub _dbh_commit {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_dbh->{AutoCommit} = $self->_dbh_autocommit
+ if $self->{transaction_depth} == 1;
+}
+
+sub _dbh_rollback {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_dbh->{AutoCommit} = $self->_dbh_autocommit
+ if $self->{transaction_depth} == 1;
+}
+
+# Fix up GUIDs for ->find, for cursors see the cursor_class above.
+
+sub select_single {
+ my $self = shift;
+ my ($ident, $select) = @_;
+
+ my @row = $self->next::method(@_);
+
+ return @row unless
+ $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
+
+ my $col_info = $self->_resolve_column_info($ident);
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($self->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
+
+ $row[$select_idx] = substr($returned, 1, 36)
+ if substr($returned, 0, 1) eq '{';
+ }
+ }
+
+ return @row;
+}
+
+sub datetime_parser_type {
+ 'DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format'
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format;
+
+my $datetime_format = '%m/%d/%Y %I:%M:%S %p';
+my $datetime_parser;
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor - GUID Support for MS Access over
+ADO
+
+=head1 DESCRIPTION
+
+This class is for normalizing GUIDs retrieved from Microsoft Access over ADO.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::ACCESS> for information on the Microsoft
+Access driver.
+
+Unfortunately when using L<DBD::ADO>, GUIDs come back wrapped in braces, the
+purpose of this class is to remove them.
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by default.
+It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> safely with this class and not lose
+the GUID normalizing functionality,
+L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data
+for the inner cursor class.
+
+=cut
+
+sub _dbh_next {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @row = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
+
+ $row[$select_idx] = substr($returned, 1, 36)
+ if substr($returned, 0, 1) eq '{';
+ }
+ }
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $row (@rows) {
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row->[$select_idx];
+
+ $row->[$select_idx] = substr($returned, 1, 36)
+ if substr($returned, 0, 1) eq '{';
+ }
+ }
+ }
+
+ return @rows;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+# vim:sts=2 sw=2:
/;
use mro 'c3';
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
+SQL Server via DBD::ADO
+
+=head1 SYNOPSIS
+
+This subclass supports MSSQL server connections via L<DBD::ADO>.
+
+=head1 DESCRIPTION
+
+The MSSQL specific functionality is provided by
+L<DBIx::Class::Storage::DBI::MSSQL>.
+
+=head1 EXAMPLE DSN
+
+ dbi:ADO:provider=sqlncli10;server=EEEBOX\SQLEXPRESS
+
+=head1 CAVEATS
+
+=head2 identities
+
+C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
+with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
+for caveats regarding this.
+
+=head2 truncation bug
+
+There is a bug with MSSQL ADO providers where data gets truncated based on the
+size of the bind sizes in the first prepare call:
+
+L<https://rt.cpan.org/Ticket/Display.html?id=52048>
+
+The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
+approximate maximum size of the data_type of the bound column, or 8000 (maximum
+VARCHAR size) if the data_type is not available.
+
+This code is incomplete and may be buggy. Particularly, C<VARCHAR(MAX)> is not
+supported yet. The data_type list for other DBs is also incomplete. Please
+report problems (and send patches.)
+
+=head2 fractional seconds
+
+Fractional seconds with L<DBIx::Class::InflateColumn::DateTime> are not
+currently supported, datetimes are truncated at the second.
+
+=cut
+
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format'
+);
+
sub _rebless {
my $self = shift;
$self->_identity_method('@@identity');
}
-sub source_bind_attributes {
- my $self = shift;
- my ($source) = @_;
+# work around a bug in the ADO driver - use the max VARCHAR size for all
+# binds that do not specify one via bind_attributes_by_data_type()
+sub _dbi_attrs_for_bind {
+ my $attrs = shift->next::method(@_);
- my $bind_attributes = $self->next::method(@_);
-
- foreach my $column ($source->columns) {
- $bind_attributes->{$column}{ado_size} ||= 8000; # max VARCHAR
+ for (@$attrs) {
+ $_->{ado_size} ||= 8000 if $_;
}
- return $bind_attributes;
+ $attrs;
}
sub bind_attribute_by_data_type {
}
}
-1;
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
-SQL Server via DBD::ADO
-
-=head1 SYNOPSIS
-
-This subclass supports MSSQL server connections via L<DBD::ADO>.
-
-=head1 DESCRIPTION
-
-The MSSQL specific functionality is provided by
-L<DBIx::Class::Storage::DBI::MSSQL>.
-
-=head2 CAVEATS
-
-=head3 identities
-
-C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
-with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
-for caveats regarding this.
-
-=head3 truncation bug
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format;
-There is a bug with MSSQL ADO providers where data gets truncated based on the
-size of the bind sizes in the first prepare call:
+my $datetime_format = '%m/%d/%Y %I:%M:%S %p';
+my $datetime_parser;
-L<https://rt.cpan.org/Ticket/Display.html?id=52048>
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
-The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
-approximate maximum size of the data_type of the bound column, or 8000 (maximum
-VARCHAR size) if the data_type is not available.
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
-This code is incomplete and may be buggy. Particularly, C<VARCHAR(MAX)> is not
-supported yet. The data_type list for other DBs is also incomplete. Please
-report problems (and send patches.)
+1;
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
my ($sql, $bind) = $self->next::method (@_);
# gets skippeed.
if ($self->auto_cast && @$bind) {
my $new_sql;
- my @sql_part = split /\?/, $sql;
- my $col_info = $self->_resolve_column_info($ident,[ map $_->[0], @$bind ]);
-
- foreach my $bound (@$bind) {
- my $col = $bound->[0];
- my $type = $self->_native_data_type($col_info->{$col}{data_type});
-
- foreach my $data (@{$bound}[1..$#$bound]) {
- $new_sql .= shift(@sql_part) .
- ($type ? "CAST(? AS $type)" : '?');
- }
+ my @sql_part = split /\?/, $sql, scalar @$bind + 1;
+ for (@$bind) {
+ my $cast_type = $self->_native_data_type($_->[0]{sqlt_datatype});
+ $new_sql .= shift(@sql_part) . ($cast_type ? "CAST(? AS $cast_type)" : '?');
}
- $new_sql .= join '', @sql_part;
- $sql = $new_sql;
+ $sql = $new_sql . shift @sql_part;
}
return ($sql, $bind);
use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' =>
- qw/sth/
+ qw/sth storage args pos attrs _dbh_gen/
);
=head1 NAME
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
-__PACKAGE__->sql_limit_dialect ('RowNumberOver');
+__PACKAGE__->datetime_parser_type('DateTime::Format::DB2');
+__PACKAGE__->sql_quote_char ('"');
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
+# lazy-default kind of thing
+sub sql_name_sep {
+ my $self = shift;
- my $sth = $dbh->prepare_cached('VALUES(IDENTITY_VAL_LOCAL())', {}, 3);
- $sth->execute();
+ my $v = $self->next::method(@_);
- my @res = $sth->fetchrow_array();
+ if (! defined $v and ! @_) {
+ $v = $self->next::method($self->_dbh_get_info(41) || '.');
+ }
- return @res ? $res[0] : undef;
+ return $v;
}
-sub datetime_parser_type { "DateTime::Format::DB2"; }
+sub sql_limit_dialect {
+ my $self = shift;
-1;
+ my $v = $self->next::method(@_);
-=head1 NAME
+ if (! defined $v and ! @_) {
+ $v = $self->next::method(
+ ($self->_server_info->{normalized_dbms_version}||0) >= 5.004
+ ? 'RowNumberOver'
+ : 'FetchFirst'
+ );
+ }
+
+ return $v;
+}
+
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
-DBIx::Class::Storage::DBI::DB2 - Automatic primary key class for DB2
+ my $name_sep = $self->sql_name_sep;
-=head1 SYNOPSIS
+ my $sth = $dbh->prepare_cached(
+ # An older equivalent of 'VALUES(IDENTITY_VAL_LOCAL())', for compat
+ # with ancient DB2 versions. Should work on modern DB2's as well:
+ # http://publib.boulder.ibm.com/infocenter/db2luw/v8/topic/com.ibm.db2.udb.doc/admin/r0002369.htm?resultof=%22%73%79%73%64%75%6d%6d%79%31%22%20
+ "SELECT IDENTITY_VAL_LOCAL() FROM sysibm${name_sep}sysdummy1",
+ {},
+ 3
+ );
+ $sth->execute();
+
+ my @res = $sth->fetchrow_array();
+
+ return @res ? $res[0] : undef;
+}
+
+1;
+
+=head1 NAME
- # In your table classes
- use base 'DBIx::Class::Core';
- __PACKAGE__->set_primary_key('id');
+DBIx::Class::Storage::DBI::DB2 - IBM DB2 support for DBIx::Class
=head1 DESCRIPTION
-This class implements autoincrements for DB2.
+This class implements autoincrements for DB2, sets the limit dialect to
+RowNumberOver over FetchFirst depending on the availability of support for
+RowNumberOver, queries the server name_sep from L<DBI> and sets the L<DateTime>
+parser to L<DateTime::Format::DB2>.
-=head1 AUTHORS
+=head1 AUTHOR
-Jess Robinson
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('SkipFirst');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::Informix::DateTime::Format'
+);
+
__PACKAGE__->mk_group_accessors('simple' => '__last_insert_id');
$ENV{GL_DATETIME} = "%Y-%m-%d %H:%M:%S%F5";
}
-sub datetime_parser_type {
- 'DBIx::Class::Storage::DBI::Informix::DateTime::Format'
-}
-
package # hide from PAUSE
DBIx::Class::Storage::DBI::Informix::DateTime::Format;
# set default
__PACKAGE__->_use_insert_returning (1);
__PACKAGE__->sql_limit_dialect ('FirstSkip');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type(
+ 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
+);
sub _sequence_fetch {
my ($self, $nextval, $sequence) = @_;
}
sub _svp_begin {
- my ($self, $name) = @_;
+ my ($self, $name) = @_;
- $self->_get_dbh->do("SAVEPOINT $name");
+ $self->_dbh->do("SAVEPOINT $name");
}
sub _svp_release {
- my ($self, $name) = @_;
+ my ($self, $name) = @_;
- $self->_get_dbh->do("RELEASE SAVEPOINT $name");
+ $self->_dbh->do("RELEASE SAVEPOINT $name");
}
sub _svp_rollback {
- my ($self, $name) = @_;
+ my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
sub _ping {
$self->_get_dbh->{ib_time_all} = 'ISO';
}
-sub datetime_parser_type {
- 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
-}
package # hide from PAUSE
DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL');
+__PACKAGE__->sql_quote_char([qw/[ ]/]);
+
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
+);
+
+
+__PACKAGE__->new_guid('NEWID()');
+
sub _set_identity_insert {
my ($self, $table) = @_;
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
+ my ($op, $ident, $args) = @_;
# cast MONEY values properly
if ($op eq 'insert' || $op eq 'update') {
my $self = shift;
my ($op) = @_;
- my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+ my ($rv, $sth, @bind) = $self->next::method(@_);
if ($op eq 'insert') {
$self->_get_dbh->do("ROLLBACK TRANSACTION $name");
}
-sub datetime_parser_type {
- 'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
-}
-
sub sqlt_type { 'SQLServer' }
sub sql_limit_dialect {
my ($sql, $bind) = $self->next::method(@_);
# stringify bind args, quote via $dbh, and manually insert
- #my ($op, $extra_bind, $ident, $args) = @_;
- my $ident = $_[2];
+ #my ($op, $ident, $args) = @_;
+ my $ident = $_[1];
my @sql_part = split /\?/, $sql;
my $new_sql;
- my $col_info = $self->_resolve_column_info($ident, [ map $_->[0], @$bind ]);
+ my $col_info = $self->_resolve_column_info(
+ $ident, [ map { $_->[0]{dbic_colname} || () } @$bind ]
+ );
- foreach my $bound (@$bind) {
- my $col = shift @$bound;
+ for (@$bind) {
+ my $datatype = $col_info->{ $_->[0]{dbic_colname}||'' }{data_type};
- my $datatype = $col_info->{$col}{data_type};
+ my $data = (ref $_->[1]) ? "$_->[1]" : $_->[1]; # always stringify
- foreach my $data (@$bound) {
- $data = ''.$data if ref $data;
+ $data = $self->_prep_interpolated_value($datatype, $data)
+ if $datatype;
- $data = $self->_prep_interpolated_value($datatype, $data)
- if $datatype;
+ $data = $self->_get_dbh->quote($data)
+ unless $self->interpolate_unquoted($datatype, $data);
- $data = $self->_dbh->quote($data)
- unless $self->interpolate_unquoted($datatype, $data);
-
- $new_sql .= shift(@sql_part) . $data;
- }
+ $new_sql .= shift(@sql_part) . $data;
}
+
$new_sql .= join '', @sql_part;
return ($new_sql, []);
package DBIx::Class::Storage::DBI::ODBC;
use strict;
use warnings;
-
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
-use Try::Tiny;
-use namespace::clean;
sub _rebless {
my ($self) = @_;
- try {
- my $dbtype = $self->_get_dbh->get_info(17);
-
+ if (my $dbtype = $self->_dbh_get_info(17)) {
# Translate the backend name into a perl identifier
$dbtype =~ s/\W/_/gi;
my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
+ return if $self->isa($subclass);
+
+ if ($self->load_optional_class($subclass)) {
bless $self, $subclass;
$self->_rebless;
}
- };
+ else {
+ warn "Expected driver '$subclass' not found, using generic support. " .
+ "Please file an RT.\n";
+ }
+ }
+ else {
+ warn "Could not determine your database type, using generic support.\n";
+ }
}
1;
This class simply provides a mechanism for discovering and loading a sub-class
for a specific ODBC backend. It should be transparent to the user.
-=head1 AUTHORS
+=head1 AUTHOR
-Marc Mims C<< <marc@questright.com> >>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
package DBIx::Class::Storage::DBI::ODBC::ACCESS;
+
use strict;
use warnings;
-
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::ACCESS
+/;
use mro 'c3';
-use DBI;
-
-my $ERR_MSG_START = __PACKAGE__ . ' failed: ';
+__PACKAGE__->mk_group_accessors(inherited =>
+ 'disable_sth_caching_for_image_insert_or_update'
+);
-__PACKAGE__->sql_limit_dialect ('Top');
-
-sub insert {
- my $self = shift;
- my ( $source, $to_insert ) = @_;
+__PACKAGE__->disable_sth_caching_for_image_insert_or_update(1);
- my $bind_attributes = $self->source_bind_attributes( $source );
- my ( undef, $sth ) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert );
-
- #store the identity here since @@IDENTITY is connection global and this prevents
- #possibility that another insert to a different table overwrites it for this resultsource
- my $identity = 'SELECT @@IDENTITY';
- my $max_sth = $self->{ _dbh }->prepare( $identity )
- or $self->throw_exception( $ERR_MSG_START . $self->{ _dbh }->errstr() );
- $max_sth->execute() or $self->throw_exception( $ERR_MSG_START . $max_sth->errstr );
-
- my $row = $max_sth->fetchrow_arrayref()
- or $self->throw_exception( $ERR_MSG_START . "$identity did not return any result." );
-
- $self->{ last_pk }->{ $source->name() } = $row;
+=head1 NAME
- return $to_insert;
-}
+DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
-sub last_insert_id {
- my $self = shift;
- my ( $result_source ) = @_;
+=head1 DESCRIPTION
- return @{ $self->{ last_pk }->{ $result_source->name() } };
-}
+This class implements support specific to Microsoft Access over ODBC.
-sub bind_attribute_by_data_type {
- my $self = shift;
+It is a subclass of L<DBIx::Class::Storage::DBI::ODBC> and
+L<DBIx::Class::Storage::DBI::ACCESS>, see those classes for more
+information.
- my ( $data_type ) = @_;
+It is loaded automatically by by L<DBIx::Class::Storage::DBI::ODBC> when it
+detects a MS Access back-end.
- return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR;
+This driver implements workarounds for C<IMAGE> and C<MEMO> columns, and
+L<DBIx::Class::InflateColumn::DateTime> support for C<DATETIME> columns.
- return;
-}
+=head1 EXAMPLE DSN
-sub sqlt_type { 'ACCESS' }
+ dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb
-1;
+=head1 TEXT/IMAGE/MEMO COLUMNS
-=head1 NAME
+Avoid using C<TEXT> columns as they will be truncated to 255 bytes. Some other
+drivers (like L<ADO|DBIx::Class::Storage::DBI::ADO::MS_Jet>) will automatically
+convert C<TEXT> columns to C<MEMO>, but the ODBC driver does not.
-DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
+C<IMAGE> columns work correctly, but the statements for inserting or updating an
+C<IMAGE> column will not be L<cached|DBI/prepare_cached>, due to a bug in the
+Access ODBC driver.
-=head1 WARNING
+C<MEMO> columns work correctly as well, but you must take care to set
+L<LongReadLen|DBI/LongReadLen> to C<$max_memo_size * 2 + 1>. This is done for
+you automatically if you pass L<LongReadLen|DBI/LongReadLen> in your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>; but if you set this
+attribute directly on the C<$dbh>, keep this limitation in mind.
-I am not a DBI, DBIx::Class or MS Access guru. Use this module with that in
-mind.
+=cut
-This module is currently considered alpha software and can change without notice.
+# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO)
+sub _run_connection_actions {
+ my $self = shift;
-=head1 DESCRIPTION
+ my $long_read_len = $self->_dbh->{LongReadLen};
-This class implements support specific to Microsoft Access over ODBC.
+ # 80 is another default (just like 0) on some drivers
+ if ($long_read_len != 0 && $long_read_len != 80) {
+ $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
+ }
-It is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it
-detects a MS Access back-end.
+ return $self->next::method(@_);
+}
-=head1 SUPPORTED VERSIONS
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
-This module have currently only been tested on MS Access 2003 using the Jet 4.0 engine.
+ my $columns_info = $source->columns_info;
-As far as my knowledge it should work on MS Access 2000 or later, but that have not been tested.
-Information about support for different version of MS Access is welcome.
+ my $is_image_insert = 0;
-=head1 IMPLEMENTATION NOTES
+ for my $col (keys %$to_insert) {
+ if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) {
+ $is_image_insert = 1;
+ last;
+ }
+ }
-MS Access supports the @@IDENTITY function for retrieving the id of the latest inserted row.
-@@IDENTITY is global to the connection, so to support the possibility of getting the last inserted
-id for different tables, the insert() function stores the inserted id on a per table basis.
-last_insert_id() then just returns the stored value.
+ local $self->{disable_sth_caching} = 1 if $is_image_insert
+ && $self->disable_sth_caching_for_image_insert_or_update;
-=head1 KNOWN ACCESS PROBLEMS
+ return $self->next::method(@_);
+}
-=over
+sub update {
+ my $self = shift;
+ my ($source, $fields) = @_;
-=item Invalid precision value
+ my $columns_info = $source->columns_info;
-This error message is received when trying to store more than 255 characters in a MEMO field.
-The problem is (to my knowledge) an error in the MS Access ODBC driver. The problem is fixed
-by setting the C<data_type> of the column to C<SQL_LONGVARCHAR> in C<add_columns>.
-C<SQL_LONGVARCHAR> is a constant in the C<DBI> module.
+ my $is_image_insert = 0;
-=back
+ for my $col (keys %$fields) {
+ if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) {
+ $is_image_insert = 1;
+ last;
+ }
+ }
-=head1 IMPLEMENTED FUNCTIONS
+ local $self->{disable_sth_caching} = 1 if $is_image_insert
+ && $self->disable_sth_caching_for_image_insert_or_update;
-=head2 bind_attribute_by_data_type
+ return $self->next::method(@_);
+}
-This function currently supports the SQL_LONGVARCHAR column type.
+sub datetime_parser_type {
+ 'DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format'
+}
-=head2 insert
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format;
-=head2 last_insert_id
+my $datetime_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part
+my $datetime_parser;
-=head2 sqlt_type
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
-=head1 BUGS
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
-Most likely. Bug reports are welcome.
+1;
-=head1 AUTHORS
+=head1 AUTHOR
-Øystein Torget C<< <oystein.torget@dnv.com> >>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
-=head1 COPYRIGHT
+=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
-Det Norske Veritas AS (DNV)
-
-http://www.dnv.com
-
=cut
-
+# vim:sts=2 sw=2:
package DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL;
+
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::ODBC/;
+use base qw/
+ DBIx::Class::Storage::DBI::DB2
+ DBIx::Class::Storage::DBI::ODBC
+/;
use mro 'c3';
-warn 'Major advances took place in the DBIC codebase since this driver'
- .' (::Storage::DBI::ODBC::DB2_400_SQL) was written. However since the'
- .' RDBMS in question is so rare it is not possible for us to test any'
- .' of the "new hottness". If you are using DB2 on AS-400 please get'
- .' in contact with the developer team:'
- .' http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT'
- ."\n"
-;
-
-# FIXME
-# Most likely all of this code is redundant and unnecessary. We should
-# be able to simply use base qw/DBIx::Class::Storage::DBI::DB2/;
-# Unfortunately nobody has an RDBMS engine to test with, so keeping
-# things as-is for the time being
-
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
-
- # get the schema/table separator:
- # '.' when SQL naming is active
- # '/' when system naming is active
- my $sep = $dbh->get_info(41);
- my $sth = $dbh->prepare_cached(
- "SELECT IDENTITY_VAL_LOCAL() FROM SYSIBM${sep}SYSDUMMY1", {}, 3);
- $sth->execute();
-
- my @res = $sth->fetchrow_array();
-
- return @res ? $res[0] : undef;
-}
-
-sub _sql_maker_opts {
- my ($self) = @_;
-
- $self->dbh_do(sub {
- my ($self, $dbh) = @_;
-
- return {
- limit_dialect => 'FetchFirst',
- name_sep => $dbh->get_info(41)
- };
- });
-}
-
1;
=head1 NAME
DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL - Support specific to DB2/400
over ODBC
-=head1 SYNOPSIS
-
- # In your result (table) classes
- use base 'DBIx::Class::Core';
- __PACKAGE__->set_primary_key('id');
-
-
=head1 DESCRIPTION
-This class implements support specific to DB2/400 over ODBC, including
-auto-increment primary keys, SQL::Abstract::Limit dialect, and name separator
-for connections using either SQL naming or System naming.
-
-
-=head1 AUTHORS
+This is an empty subclass of L<DBIx::Class::Storage::DBI::DB2>.
-Marc Mims C<< <marc@questright.com> >>
+=head1 AUTHOR
-Based on DBIx::Class::Storage::DBI::DB2 by Jess Robinson.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::InterBase/;
+use base 'DBIx::Class::Storage::DBI::InterBase';
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
=cut
+__PACKAGE__->datetime_parser_type ('DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format');
+
# XXX seemingly no equivalent to ib_time_all from DBD::InterBase via ODBC
sub connect_call_datetime_setup { 1 }
# ODBC uses dialect 3 by default, good
sub _set_sql_dialect { 1 }
-# releasing savepoints doesn't work, but that shouldn't matter
+# releasing savepoints doesn't work for some reason, but that shouldn't matter
sub _svp_release { 1 }
-sub datetime_parser_type {
- 'DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format'
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ try {
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ }
+ catch {
+ # Firebird ODBC driver bug, ignore
+ if (not /Unable to fetch information about the error/) {
+ $self->throw_exception($_);
+ }
+ };
}
package # hide from PAUSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
use mro 'c3';
use Scalar::Util 'reftype';
use Try::Tiny;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
=over 8
-=item * L</connect_call_use_mars>
+=item * L<mars|/connect_call_use_mars>
-=item * L</connect_call_use_dynamic_cursors>
+=item * L<dynamic_cursors|/connect_call_use_dynamic_cursors>
-=item * L</connect_call_use_server_cursors>
+=item * L<server_cursors|/connect_call_use_server_cursors>
=back
on_connect_call => 'use_mars'
+in your connection info, or alternatively specify it directly:
+
+ Your::Schema->connect (
+ $original_dsn . '; MARS_Connection=Yes',
+ $user,
+ $pass,
+ \%attrs,
+ )
+
Use to enable a feature of SQL Server 2005 and later, "Multiple Active Result
Sets". See L<DBD::ODBC::FAQ/Does DBD::ODBC support Multiple Active Statements?>
for more information.
}
if (my ($data_source) = $dsn =~ /^dbi:ODBC:([\w-]+)\z/i) { # prefix with DSN
- warn "Bare DSN in ODBC connect string, rewriting to DSN=$data_source\n";
- $dsn = "dbi:ODBC:DSN=$data_source";
+ warn "Bare DSN in ODBC connect string, rewriting as 'dsn=$data_source'"
+ ." for MARS\n";
+ $dsn = "dbi:ODBC:dsn=$data_source";
}
$self->_dbi_connect_info->[0] = "$dsn;MARS_Connection=Yes";
on_connect_call => 'use_dynamic_cursors'
-in your L<connect_info|DBIx::Class::Storage::DBI/connect_info> as one way to enable multiple
-concurrent statements.
+Which will add C<< odbc_cursortype => 2 >> to your DBI connection
+attributes, or alternatively specify the necessary flag directly:
-Will add C<< odbc_cursortype => 2 >> to your DBI connection attributes. See
-L<DBD::ODBC/odbc_cursortype> for more information.
+ Your::Schema->connect (@dsn, { ... odbc_cursortype => 2 })
-Alternatively, you can add it yourself and dynamic cursor support will be
-automatically enabled.
+See L<DBD::ODBC/odbc_cursortype> for more information.
If you're using FreeTDS, C<tds_version> must be set to at least C<8.0>.
This will not work with CODE ref connect_info's.
-B<WARNING:> this will break C<SCOPE_IDENTITY()>, and C<SELECT @@IDENTITY> will
-be used instead, which on SQL Server 2005 and later will return erroneous
-results on tables which have an on insert trigger that inserts into another
-table with an C<IDENTITY> column.
+B<WARNING:> on FreeTDS (and maybe some other drivers) this will break
+C<SCOPE_IDENTITY()>, and C<SELECT @@IDENTITY> will be used instead, which on SQL
+Server 2005 and later will return erroneous results on tables which have an on
+insert trigger that inserts into another table with an C<IDENTITY> column.
=cut
sub connect_call_use_dynamic_cursors {
my $self = shift;
- if (ref($self->_dbi_connect_info->[0]) eq 'CODE') {
- $self->throw_exception ('Cannot set DBI attributes on a CODE ref connect_info');
- }
-
- my $dbi_attrs = $self->_dbi_connect_info->[-1];
+ my $conn_info = $self->_dbi_connect_info;
- unless (ref $dbi_attrs eq 'HASH') {
- $dbi_attrs = {};
- push @{ $self->_dbi_connect_info }, $dbi_attrs;
+ if (ref($conn_info->[0]) eq 'CODE') {
+ $self->throw_exception ('Cannot set DBI attributes on a CODE ref connect_info');
}
- if (not exists $dbi_attrs->{odbc_cursortype}) {
- # turn on support for multiple concurrent statements, unless overridden
- $dbi_attrs->{odbc_cursortype} = 2;
+ if (
+ ref($conn_info->[-1]) ne 'HASH'
+ or
+ ($conn_info->[-1]{odbc_cursortype}||0) < 2
+ ) {
+ # reenter connection information with the attribute re-set
+ $self->connect_info(
+ @{$conn_info}[0,1,2],
+ { %{$self->_dbix_connect_attributes}, odbc_cursortype => 2 },
+ );
$self->disconnect; # resetting dbi attrs, so have to reconnect
$self->ensure_connected;
- $self->_set_dynamic_cursors;
}
}
-sub _set_dynamic_cursors {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- try {
- local $dbh->{RaiseError} = 1;
- local $dbh->{PrintError} = 0;
- $dbh->do('SELECT @@IDENTITY');
- } catch {
- $self->throw_exception (<<'EOF');
-
-Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2),
-if you're using FreeTDS, make sure to set tds_version to 8.0 or greater.
-EOF
- };
-
- $self->_using_dynamic_cursors(1);
- $self->_identity_method('@@identity');
-}
-
-sub _init {
+sub _run_connection_actions {
my $self = shift;
+ # keep the dynamic_cursors_support and driver-state in sync
+ # on every reconnect
+ my $use_dyncursors = ($self->_dbic_connect_attributes->{odbc_cursortype} || 0) > 1;
if (
- ref($self->_dbi_connect_info->[0]) ne 'CODE'
- &&
- ref ($self->_dbi_connect_info->[-1]) eq 'HASH'
- &&
- ($self->_dbi_connect_info->[-1]{odbc_cursortype} || 0) > 1
+ $use_dyncursors
+ xor
+ !!$self->_using_dynamic_cursors
) {
- $self->_set_dynamic_cursors;
- }
- else {
- $self->_using_dynamic_cursors(0);
+ if ($use_dyncursors) {
+ try {
+ my $dbh = $self->_dbh;
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
+ $dbh->do('SELECT @@IDENTITY');
+ } catch {
+ $self->throw_exception (
+ 'Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2).'
+ . (
+ $self->using_freetds
+ ? ' If you are using FreeTDS, make sure to set tds_version to 8.0 or greater.'
+ : ''
+ )
+ );
+ };
+
+ $self->_using_dynamic_cursors(1);
+ $self->_identity_method('@@identity');
+ }
+ else {
+ $self->_using_dynamic_cursors(0);
+ $self->_identity_method(undef);
+ }
}
+
+ $self->next::method (@_);
}
=head2 connect_call_use_server_cursors
$dsn = '' if ref $dsn eq 'CODE';
- my $dbh = $self->_get_dbh;
-
return 1 if $dsn =~ /driver=FreeTDS/i
- || (try { $dbh->get_info(6) }||'') =~ /tdsodbc/i;
+ || ($self->_dbh_get_info(6)||'') =~ /tdsodbc/i;
return 0;
}
All functionality is provided by L<DBIx::Class::Storage::DBI::SQLAnywhere>, see
that module for details.
+=head1 CAVEATS
+
+=head2 uniqueidentifierstr data type
+
+If you use the C<uniqueidentifierstr> type with this driver, your queries may
+fail with:
+
+ Data truncated (SQL-01004)
+
+B<WORKAROUND:> use the C<uniqueidentifier> type instead, it is more efficient
+anyway.
+
=head1 AUTHOR
See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
my ($self) = @_;
# Default driver
- my $class = $self->_server_info->{normalized_dbms_version} <= 8
+ my $class = $self->_server_info->{normalized_dbms_version} < 9
? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
: 'DBIx::Class::Storage::DBI::Oracle::Generic';
This class simply provides a mechanism for discovering and loading a sub-class
for a specific version Oracle backend. It should be transparent to the user.
-For Oracle major versions <= 8 it loads the ::Oracle::WhereJoins subclass,
+For Oracle major versions < 9 it loads the ::Oracle::WhereJoins subclass,
which unrolls the ANSI join style DBIC normally generates into entries in
the WHERE clause for compatibility purposes. To force usage of this version
no matter the database version, add
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('RowNum');
+__PACKAGE__->sql_quote_char ('"');
=head1 NAME
This class implements base Oracle support. The subclass
L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
-versions before 9.
+versions before 9.0.
=head1 METHODS
use mro 'c3';
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
+__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
sub _determine_supports_insert_returning {
my $self = shift;
}
sub _dbh_execute {
- my $self = shift;
- my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+ my ($self, $dbh, $sql, @args) = @_;
my (@res, $tried);
my $want = wantarray;
my $next = $self->next::can;
do {
try {
- my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
+ my $exec = sub { $self->$next($dbh, $sql, @args) };
if (!defined $want) {
$exec->();
if (! $tried and $_ =~ /ORA-01003/) {
# ORA-01003: no statement parsed (someone changed the table somehow,
# invalidating your cursor.)
- my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
delete $dbh->{CachedKids}{$sql};
}
else {
This sets the proper DateTime::Format module for use with
L<DBIx::Class::InflateColumn::DateTime>.
-=cut
-
-sub datetime_parser_type { return "DateTime::Format::Oracle"; }
-
=head2 connect_call_datetime_setup
Used as:
);
}
-=head2 source_bind_attributes
-
-Handle LOB types in Oracle. Under a certain size (4k?), you can get away
-with the driver assuming your input is the deprecated LONG type if you
-encode it as a hex string. That ain't gonna fly at larger values, where
-you'll discover you have to do what this does.
-
-This method had to be overridden because we need to set ora_field to the
-actual column, and that isn't passed to the call (provided by Storage) to
-bind_attribute_by_data_type.
-
-According to L<DBD::Oracle>, the ora_field isn't always necessary, but
-adding it doesn't hurt, and will save your bacon if you're modifying a
-table with more than one LOB column.
-
-=cut
-
-sub source_bind_attributes
-{
- require DBD::Oracle;
- my $self = shift;
- my($source) = @_;
-
- my %bind_attributes;
-
- foreach my $column ($source->columns) {
- my $data_type = $source->column_info($column)->{data_type}
- or next;
+### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
+### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
+#
+# Handle LOB types in Oracle. Under a certain size (4k?), you can get away
+# with the driver assuming your input is the deprecated LONG type if you
+# encode it as a hex string. That ain't gonna fly at larger values, where
+# you'll discover you have to do what this does.
+#
+# This method had to be overridden because we need to set ora_field to the
+# actual column, and that isn't passed to the call (provided by Storage) to
+# bind_attribute_by_data_type.
+#
+# According to L<DBD::Oracle>, the ora_field isn't always necessary, but
+# adding it doesn't hurt, and will save your bacon if you're modifying a
+# table with more than one LOB column.
+#
+sub _dbi_attrs_for_bind {
+ my ($self, $ident, $bind) = @_;
+ my $attrs = $self->next::method($ident, $bind);
+
+ for my $i (0 .. $#$attrs) {
+ if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
+ $attrs->[$i]{ora_field} = $col;
+ }
+ }
- my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
+ $attrs;
+}
- if ($data_type =~ /^[BC]LOB$/i) {
- if ($DBD::Oracle::VERSION eq '1.23') {
- $self->throw_exception(
-"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
-"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
- );
- }
+my $dbd_loaded;
+sub bind_attribute_by_data_type {
+ my ($self, $dt) = @_;
+
+ $dbd_loaded ||= do {
+ require DBD::Oracle;
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ $self->throw_exception(
+ "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
+ "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
+ );
+ }
+ 1;
+ };
- $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
+ if ($self->_is_lob_type($dt)) {
+ return {
+ ora_type => $self->_is_text_lob_type($dt)
? DBD::Oracle::ORA_CLOB()
: DBD::Oracle::ORA_BLOB()
- ;
- $column_bind_attrs{'ora_field'} = $column;
- }
-
- $bind_attributes{$column} = \%column_bind_attrs;
+ };
}
-
- return \%bind_attributes;
}
sub _svp_begin {
my $alias = $self->next::method(@_);
- return $self->sql_maker->_shorten_identifier($alias, [$relname]);
+ # we need to shorten here in addition to the shortening in SQLA itself,
+ # since the final relnames are a crucial for the join optimizer
+ return $self->sql_maker->_shorten_identifier($alias);
}
=head2 with_deferred_fk_checks
=head1 PURPOSE
-This module was originally written to support Oracle < 9i where ANSI joins
-weren't supported at all, but became the module for Oracle >= 8 because
-Oracle's optimising of ANSI joins is horrible.
+This module is used with Oracle < 9.0 due to lack of support for standard
+ANSI join syntax.
=head1 SYNOPSIS
/;
use mro 'c3';
-use DBD::Pg qw(:pg_types);
use Scope::Guard ();
use Context::Preserve 'preserve_context';
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('LimitOffset');
-
-# Ask for a DBD::Pg with array support
-warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
- if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type ('DateTime::Format::Pg');
sub _determine_supports_insert_returning {
return shift->_server_info->{normalized_dbms_version} >= 8.002
return 'PostgreSQL';
}
-sub datetime_parser_type { return "DateTime::Format::Pg"; }
-
+my $bind_attributes;
sub bind_attribute_by_data_type {
my ($self,$data_type) = @_;
- my $bind_attributes = {
- bytea => { pg_type => DBD::Pg::PG_BYTEA },
- blob => { pg_type => DBD::Pg::PG_BYTEA },
+ $bind_attributes ||= do {
+ require DBD::Pg;
+
+ # Ask for a DBD::Pg with array support
+ warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
+ if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
+ {
+ bytea => { pg_type => DBD::Pg::PG_BYTEA() },
+ blob => { pg_type => DBD::Pg::PG_BYTEA() },
+ };
};
if( defined $bind_attributes->{$data_type} ) {
package DBIx::Class::Storage::DBI::Replicated;
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') )
+ die('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') . "\n" )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
The following methods are delegated all the methods required for the
L<DBIx::Class::Storage::DBI> interface.
-=head2 read_handler
-
-Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
-
-=cut
-
-has 'read_handler' => (
- is=>'rw',
- isa=>Object,
- lazy_build=>1,
- handles=>[qw/
- select
- select_single
- columns_info_for
- _dbh_columns_info_for
- _select
- /],
-);
-
-=head2 write_handler
-
-Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
-as well as methods that don't write or read that can be called on only one
-storage, methods that return a C<$dbh>, and any methods that don't make sense to
-run on a replicant.
-
=cut
-has 'write_handler' => (
- is=>'ro',
- isa=>Object,
- lazy_build=>1,
- handles=>[qw/
+my $method_dispatch = {
+ writer => [qw/
on_connect_do
on_disconnect_do
on_connect_call
txn_commit
txn_rollback
txn_scope_guard
- sth
deploy
with_deferred_fk_checks
dbh_do
- reload_row
- with_deferred_fk_checks
_prep_for_execute
-
- backup
is_datatype_numeric
_count_select
_subq_update_delete
svp_release
relname_to_table_alias
_dbh_last_insert_id
- _fix_bind_params
_default_dbi_connect_attributes
_dbi_connect_info
_dbic_connect_attributes
auto_savepoint
- _sqlt_version_ok
+ _query_start
_query_end
+ _format_for_trace
+ _dbi_attrs_for_bind
bind_attribute_by_data_type
transaction_depth
_dbh
_select_args
_dbh_execute_array
_sql_maker
- _query_start
- _sqlt_version_error
_per_row_update_delete
_dbh_begin_work
_dbh_execute_inserts_with_no_binds
_select_args_to_query
_svp_generate_name
_multipk_update_delete
- source_bind_attributes
_normalize_connect_info
_parse_connect_do
_dbh_commit
_execute_array
savepoints
- _sqlt_minimum_version
_sql_maker_opts
_conn_pid
_dbh_autocommit
_resolve_column_info
_prune_unused_joins
_strip_cond_qualifiers
+ _strip_cond_qualifiers_from_array
_resolve_aliastypes_from_select_args
_execute
_do_query
+ _sth
_dbh_sth
_dbh_execute
/],
-);
+ reader => [qw/
+ select
+ select_single
+ columns_info_for
+ _dbh_columns_info_for
+ _select
+ /],
+ unimplemented => [qw/
+ _arm_global_destructor
+ _verify_pid
-my @unimplemented = qw(
- _arm_global_destructor
- _verify_pid
+ source_bind_attributes
- get_use_dbms_capability
- set_use_dbms_capability
- get_dbms_capability
- set_dbms_capability
- _dbh_details
+ get_use_dbms_capability
+ set_use_dbms_capability
+ get_dbms_capability
+ set_dbms_capability
+ _dbh_details
+ _dbh_get_info
- sql_limit_dialect
+ sql_limit_dialect
+ sql_quote_char
+ sql_name_sep
- _inner_join_to_node
- _group_over_selection
- _prefetch_autovalues
- _extract_order_criteria
- _max_column_bytesize
- _is_lob_type
-);
+ _inner_join_to_node
+ _group_over_selection
+ _extract_order_criteria
-# the capability framework
-# not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem
-push @unimplemented, ( grep
- { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x }
- ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names )
-);
+ _prefetch_autovalues
+
+ _max_column_bytesize
+ _is_lob_type
+ _is_binary_lob_type
+ _is_text_lob_type
+
+ sth
+ /,(
+ # the capability framework
+ # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem
+ grep
+ { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x }
+ ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names )
+ )],
+};
+
+if (DBIx::Class::_ENV_::DBICTEST) {
+
+ my $seen;
+ for my $type (keys %$method_dispatch) {
+ for (@{$method_dispatch->{$type}}) {
+ push @{$seen->{$_}}, $type;
+ }
+ }
+
+ if (my @dupes = grep { @{$seen->{$_}} > 1 } keys %$seen) {
+ die(join "\n", '',
+ 'The following methods show up multiple times in ::Storage::DBI::Replicated handlers:',
+ (map { "$_: " . (join ', ', @{$seen->{$_}}) } sort @dupes),
+ '',
+ );
+ }
-for my $method (@unimplemented) {
+ if (my @cant = grep { ! DBIx::Class::Storage::DBI->can($_) } keys %$seen) {
+ die(join "\n", '',
+ '::Storage::DBI::Replicated specifies handling of the following *NON EXISTING* ::Storage::DBI methods:',
+ @cant,
+ '',
+ );
+ }
+}
+
+for my $method (@{$method_dispatch->{unimplemented}}) {
__PACKAGE__->meta->add_method($method, sub {
- croak "$method must not be called on ".(blessed shift).' objects';
+ my $self = shift;
+ $self->throw_exception("$method must not be called on ".(blessed $self).' objects');
});
}
+=head2 read_handler
+
+Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
+
+=cut
+
+has 'read_handler' => (
+ is=>'rw',
+ isa=>Object,
+ lazy_build=>1,
+ handles=>$method_dispatch->{reader},
+);
+
+=head2 write_handler
+
+Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
+as well as methods that don't write or read that can be called on only one
+storage, methods that return a C<$dbh>, and any methods that don't make sense to
+run on a replicant.
+
+=cut
+
+has 'write_handler' => (
+ is=>'ro',
+ isa=>Object,
+ lazy_build=>1,
+ handles=>$method_dispatch->{writer},
+);
+
+
+
has _master_connect_info_opts =>
(is => 'rw', isa => HashRef, default => sub { {} });
=head2 auto_validate_every ($seconds)
-If auto_validate has some sort of value, run the L<validate_replicants> every
-$seconds. Be careful with this, because if you set it to 0 you will end up
-validating every query.
+If auto_validate has some sort of value, run
+L<DBIx::Class::Storage::DBI::Replicated::Pool/validate_replicants>
+every $seconds. Be careful with this, because if you set it to 0 you
+will end up validating every query.
=cut
use List::Util 'sum';
use Scalar::Util 'reftype';
use DBI ();
-use Carp::Clan qw/^DBIx::Class/;
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use Try::Tiny;
defined by L</maximum_lag>. Replicants that fail any of these tests are set to
inactive, and thus removed from the replication pool.
-This tests L<all_replicants>, since a replicant that has been previous marked
+This tests L</all_replicants>, since a replicant that has been previous marked
as inactive can be reactivated should it start to pass the validation tests again.
See L<DBIx::Class::Storage::DBI> for more about checking if a replicating
use mro 'c3';
use List::Util 'first';
use Try::Tiny;
+use DBIx::Class::Storage::DBI::SQLAnywhere::Cursor ();
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/_identity/);
__PACKAGE__->sql_limit_dialect ('RowNumberOver');
+__PACKAGE__->sql_quote_char ('"');
+
+__PACKAGE__->new_guid('UUIDTOSTR(NEWID())');
+
+# default to the UUID decoding cursor, overridable by the user
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::SQLAnywhere::Cursor');
=head1 NAME
-DBIx::Class::Storage::DBI::SQLAnywhere - Driver for Sybase SQL Anywhere
+DBIx::Class::Storage::DBI::SQLAnywhere - Driver for SQL Anywhere
=head1 DESCRIPTION
-This class implements autoincrements for Sybase SQL Anywhere and provides
-L<DBIx::Class::InflateColumn::DateTime> support.
+This class implements autoincrements for SQL Anywhere and provides
+L<DBIx::Class::InflateColumn::DateTime> support and support for the
+C<uniqueidentifier> type (via
+L<DBIx::Class::Storage::DBI::SQLAnywhere::Cursor>.)
You need the C<DBD::SQLAnywhere> driver that comes with the SQL Anywhere
distribution, B<NOT> the one on CPAN. It is usually under a path such as:
sub last_insert_id { shift->_identity }
-sub _new_uuid { 'UUIDTOSTR(NEWID())' }
-
sub _prefetch_autovalues {
my $self = shift;
my ($source, $to_insert) = @_;
return $values;
}
-# convert UUIDs to strings in selects
-sub _select_args {
+sub _uuid_to_str {
+ my ($self, $data) = @_;
+
+ $data = unpack 'H*', $data;
+
+ for my $pos (8, 13, 18, 23) {
+ substr($data, $pos, 0) = '-';
+ }
+
+ return $data;
+}
+
+# select_single does not invoke a cursor object at all, hence UUID decoding happens
+# here if the proper cursor class is set
+sub select_single {
my $self = shift;
+
+ my @row = $self->next::method(@_);
+
+ return @row
+ unless $self->cursor_class->isa('DBIx::Class::Storage::DBI::SQLAnywhere::Cursor');
+
my ($ident, $select) = @_;
my $col_info = $self->_resolve_column_info($ident);
next if ref $selected;
- my $data_type = $col_info->{$selected}{data_type};
+ my $data_type = $col_info->{$selected}{data_type}
+ or next;
+
+ if ($self->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
- if ($data_type && lc($data_type) eq 'uniqueidentifier') {
- $select->[$select_idx] = { UUIDTOSTR => $selected };
+ if (length $returned == 16) {
+ $row[$select_idx] = $self->_uuid_to_str($returned);
+ }
}
}
- return $self->next::method(@_);
+ return @row;
}
# this sub stolen from MSSQL
--- /dev/null
+package DBIx::Class::Storage::DBI::SQLAnywhere::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::SQLAnywhere::Cursor - GUID Support for SQL Anywhere
+over L<DBD::SQLAnywhere>
+
+=head1 DESCRIPTION
+
+This class is for normalizing GUIDs retrieved from SQL Anywhere via
+L<DBD::SQLAnywhere>.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::SQLAnywhere> for information on the SQL Anywhere
+driver.
+
+Unfortunately when using L<DBD::SQLAnywhere>, GUIDs come back in binary, the
+purpose of this class is to transform them to text.
+L<DBIx::Class::Storage::DBI::SQLAnywhere> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by default.
+It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> safely with this class and not lose
+the GUID normalizing functionality,
+L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data
+for the inner cursor class.
+
+=cut
+
+sub _dbh_next {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @row = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
+
+ if (length $returned == 16) {
+ $row[$select_idx] = $storage->_uuid_to_str($returned);
+ }
+ }
+ }
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $row (@rows) {
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row->[$select_idx];
+
+ if (length $returned == 16) {
+ $row->[$select_idx] = $storage->_uuid_to_str($returned);
+ }
+ }
+ }
+ }
+
+ return @rows;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite');
__PACKAGE__->sql_limit_dialect ('LimitOffset');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type ('DateTime::Format::SQLite');
sub backup {
$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
}
-sub datetime_parser_type { return "DateTime::Format::SQLite"; }
+sub bind_attribute_by_data_type {
+ $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium|big)int ) $/ix
+ ? do { require DBI; DBI::SQL_INTEGER() }
+ : undef
+ ;
+}
=head2 connect_call_use_foreign_keys
DBIx::Class::Storage::DBI::AutoCast
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Scalar::Util 'blessed';
use List::Util 'first';
use Sub::Name();
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('RowCountOrGenericSubQ');
+__PACKAGE__->sql_quote_char ([qw/[ ]/]);
+__PACKAGE__->datetime_parser_type('DateTime::Format::Sybase');
__PACKAGE__->mk_group_accessors('simple' =>
qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
+ my ($op, $ident, $args) = @_;
my ($sql, $bind) = $self->next::method (@_);
my $table = blessed $ident ? $ident->from : $ident;
my $bind_info = $self->_resolve_column_info(
- $ident, [map $_->[0], @{$bind}]
+ $ident, [map { $_->[0]{dbic_colname} || () } @{$bind}]
);
my $bound_identity_col =
first { $bind_info->{$_}{is_auto_increment} }
my $self = shift;
my ($op) = @_;
- my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+ my ($rv, $sth, @bind) = $self->next::method(@_);
if ($op eq 'insert') {
$self->_identity($sth->fetchrow_array);
}
);
- my @bind = do {
- my $idx = 0;
- map [ $_, $idx++ ], @source_columns;
- };
+ my @bind = map { [ $source_columns[$_] => $_ ] } (0 .. $#source_columns);
$self->_execute_array(
$source, $sth, \@bind, \@source_columns, \@new_data, sub {
=cut
-{
- my $old_dbd_warned = 0;
+sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else {
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ .'DBIx::Class::InflateColumn::DateTime, please upgrade!';
$dbh->do('SET DATEFORMAT mdy');
-
1;
}
}
-sub datetime_parser_type { "DateTime::Format::Sybase" }
# ->begin_work and such have no effect with FreeTDS but we run them anyway to
# let the DBD keep any state it needs to.
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
carp 'Setting of storage_type is redundant as connections through DBD::Sybase'
.' are now properly recognized and reblessed into the appropriate subclass'
$schema->storage_type('::DBI::Sybase::MSSQL');
$schema->connect_info('dbi:Sybase:....', ...);
-=head1 BUGS
-
-Currently, this doesn't work right unless you call C<Class::C3::reinitialize()>
-after connecting.
-
=head1 AUTHORS
Brandon L Black <blblack@gmail.com>
DBIx::Class::Storage::DBI::MSSQL
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-# Temporary fix for mysterious MRO fail on 5.8 perls
-Class::C3::reinitialize if $] < '5.01';
+use DBIx::Class::Carp;
+
+__PACKAGE__->datetime_parser_type(
+ 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format'
+);
sub _rebless {
my $self = shift;
=cut
-{
- my $old_dbd_warned = 0;
-
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
+sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else{
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ . 'DBIx::Class::InflateColumn::DateTime, please upgrade!';
}
}
-sub datetime_parser_type {
- 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format'
-}
package # hide from PAUSE
DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format;
use base 'DBIx::Class::Storage::DBI';
use mro 'c3';
+__PACKAGE__->mk_group_accessors(inherited => 'new_guid');
+
=head1 NAME
DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
-supporting the 'uniqueidentifier' type
+supporting GUID types
=head1 DESCRIPTION
-This is a storage component for databases that support the C<uniqueidentifier>
-type and the C<NEWID()> function for generating UUIDs.
+This is a storage component for databases that support GUID types such as
+C<uniqueidentifier>, C<uniqueidentifierstr> or C<guid>.
+
+GUIDs are generated automatically for PK columns with a supported
+L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> set.
+
+=head1 METHODS
+
+=head2 new_guid
+
+The composing class must set C<new_guid> to the method used to generate a new
+GUID. It can also set it to C<undef>, in which case the user is required to set
+it, or a runtime error will be thrown. It can be:
+
+=over 4
+
+=item string
+
+In which case it is used as the name of database function to create a new GUID,
+
+=item coderef
-UUIDs are generated automatically for PK columns with the C<uniqueidentifier>
-L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with this
-L<data_type|DBIx::Class::ResultSource/data_type> and
-L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>.
+In which case the coderef should return a string GUID, using L<Data::GUID>, or
+whatever GUID generation method you prefer.
-Currently used by L<DBIx::Class::Storage::DBI::MSSQL> and
-L<DBIx::Class::Storage::DBI::SQLAnywhere>.
+=back
-The composing class can define a C<_new_uuid> method to override the function
-used to generate a new UUID.
+For example:
+
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
=cut
-sub _new_uuid { 'NEWID()' }
+my $GUID_TYPE = qr/^(?:uniqueidentifier(?:str)?|guid)\z/i;
+
+sub _is_guid_type {
+ my ($self, $data_type) = @_;
+
+ return $data_type =~ $GUID_TYPE;
+}
sub insert {
my $self = shift;
my @pk_guids = grep {
$col_info->{$_}{data_type}
&&
- $col_info->{$_}{data_type} =~ /^uniqueidentifier/i
+ $col_info->{$_}{data_type} =~ $GUID_TYPE
} @pk_cols;
my @auto_guids = grep {
$col_info->{$_}{data_type}
&&
- $col_info->{$_}{data_type} =~ /^uniqueidentifier/i
+ $col_info->{$_}{data_type} =~ $GUID_TYPE
&&
$col_info->{$_}{auto_nextval}
} grep { not exists $pk_cols{$_} } $source->columns;
my $updated_cols = {};
for my $guid_col (@get_guids_for) {
- my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT '.$self->_new_uuid);
+ my $new_guid;
+
+ my $guid_method = $self->new_guid;
+
+ if (not defined $guid_method) {
+ $self->throw_exception(
+ 'You must set new_guid on your storage. See perldoc '
+ .'DBIx::Class::Storage::DBI::UniqueIdentifier'
+ );
+ }
+
+ if (ref $guid_method eq 'CODE') {
+ $new_guid = $guid_method->();
+ }
+ else {
+ ($new_guid) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
+ }
+
$updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
}
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL');
__PACKAGE__->sql_limit_dialect ('LimitXY');
+__PACKAGE__->sql_quote_char ('`');
sub with_deferred_fk_checks {
my ($self, $sub) = @_;
$dbh->{mysql_insertid};
}
+# here may seem like an odd place to override, but this is the first
+# method called after we are connected *and* the driver is determined
+# ($self is reblessed). See code flow in ::Storage::DBI::_populate_dbh
+sub _run_connection_actions {
+ my $self = shift;
+
+ # default mysql_auto_reconnect to off unless explicitly set
+ if (
+ $self->_dbh->{mysql_auto_reconnect}
+ and
+ ! exists $self->_dbic_connect_attributes->{mysql_auto_reconnect}
+ ) {
+ $self->_dbh->{mysql_auto_reconnect} = 0;
+ }
+
+ $self->next::method(@_);
+}
+
# we need to figure out what mysql version we're running
sub sql_maker {
my $self = shift;
my $maker = $self->next::method (@_);
# mysql 3 does not understand a bare JOIN
- my $mysql_ver = $self->_get_dbh->get_info(18);
+ my $mysql_ver = $self->_dbh_get_info(18);
$maker->{_default_jointype} = 'INNER' if $mysql_ver =~ /^3/;
}
use base 'DBIx::Class::Storage';
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
use List::Util 'first';
use Scalar::Util 'blessed';
use namespace::clean;
# the fake group_by is so that the pruner throws away all non-selecting, non-restricting
# multijoins (since we def. do not care about those inside the subquery)
- my $subq_joinspec = do {
+ my $inner_subq = do {
# must use it here regardless of user requests
local $self->{_use_join_optimizer} = 1;
local $self->{_use_join_optimizer} = 0;
# generate the subquery
- my $subq = $self->_select_args_to_query (
+ $self->_select_args_to_query (
$inner_from,
$inner_select,
$where,
$inner_attrs,
);
-
- +{
- -alias => $attrs->{alias},
- -rsrc => $inner_from->[0]{-rsrc},
- $attrs->{alias} => $subq,
- };
};
# Generate the outer from - this is relatively easy (really just replace
$j = [ $j ] unless ref $j eq 'ARRAY'; # promote the head-from to an AoH
if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap
+
push @outer_from, [
- $subq_joinspec,
+ {
+ -alias => $attrs->{alias},
+ -rsrc => $j->[0]{-rsrc},
+ $attrs->{alias} => $inner_subq,
+ },
@{$j}[1 .. $#$j],
];
last; # we'll take care of what's left in $from below
or next;
$return{$col} = {
- %{ ( $colinfos->{$source_alias} ||= $rsrc->columns_info )->{$colname} },
+ %{
+ ( $colinfos->{$source_alias} ||= $rsrc->columns_info )->{$colname}
+ ||
+ $self->throw_exception(
+ "No such column '$colname' on source " . $rsrc->source_name
+ );
+ },
-result_source => $rsrc,
-source_alias => $source_alias,
};
# at all. What this code tries to do (badly) is introspect the condition
# and remove all column qualifiers. If it bails out early (returns undef)
# the calling code should try another approach (e.g. a subquery)
+
+sub _strip_cond_qualifiers_from_array {
+ my ($self, $where) = @_;
+ my @cond;
+ for (my $i = 0; $i < @$where; $i++) {
+ my $entry = $where->[$i];
+ my $hash;
+ my $ref = ref $entry;
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
+ $hash = $self->_strip_cond_qualifiers($entry);
+ }
+ elsif (! $ref) {
+ $entry =~ /([^.]+)$/;
+ $hash->{$1} = $where->[++$i];
+ }
+ push @cond, $hash;
+ }
+ return \@cond;
+}
+
sub _strip_cond_qualifiers {
my ($self, $where) = @_;
return $cond unless $where;
if (ref $where eq 'ARRAY') {
- $cond = [
- map {
- my %hash;
- foreach my $key (keys %{$_}) {
- $key =~ /([^.]+)$/;
- $hash{$1} = $_->{$key};
- }
- \%hash;
- } @$where
- ];
+ $cond = $self->_strip_cond_qualifiers_from_array($where);
}
elsif (ref $where eq 'HASH') {
if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
- $cond->{-and} = [];
- my @cond = @{$where->{-and}};
- for (my $i = 0; $i < @cond; $i++) {
- my $entry = $cond[$i];
- my $hash;
- my $ref = ref $entry;
- if ($ref eq 'HASH' or $ref eq 'ARRAY') {
- $hash = $self->_strip_cond_qualifiers($entry);
- }
- elsif (! $ref) {
- $entry =~ /([^.]+)$/;
- $hash->{$1} = $cond[++$i];
- }
- else {
- $self->throw_exception ("_strip_cond_qualifiers() is unable to handle a condition reftype $ref");
- }
- push @{$cond->{-and}}, $hash;
- }
+ $cond->{-and} =
+ $self->_strip_cond_qualifiers_from_array($where->{-and});
}
else {
foreach my $key (keys %$where) {
use base qw/DBIx::Class/;
use IO::File;
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/callback _debugfh silence/);
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
use Try::Tiny;
use Scalar::Util qw/weaken blessed/;
use DBIx::Class::Exception;
-use namespace::clean;
+use DBIx::Class::Carp;
# temporary until we fix the $@ issue in core
# we also need a real appendable, stackable exception object
}
}
+use namespace::clean;
+
my ($guards_count, $compat_handler, $foreign_handler);
sub new {
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
-use Carp::Clan qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Exception;
use Scalar::Util qw/weaken blessed/;
use Try::Tiny;
use namespace::clean;
$dbicschema ||= $args->{'package'};
my $limit_sources = $args->{'sources'};
- croak 'No DBIx::Class::Schema' unless ($dbicschema);
+ DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema);
if (!ref $dbicschema) {
eval "require $dbicschema"
- or croak "Can't load $dbicschema: $@";
+ or DBIx::Class::Exception->throw("Can't load $dbicschema: $@");
}
my $schema = $tr->schema;
use strict;
use Test::More;
-use MRO::Compat;
use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
+use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed)
{
package AAA;
ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
-use B;
is_deeply (
mro::get_linear_isa('DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'),
DBIx::Class
DBIx::Class::Componentised
Class::C3::Componentised
+ DBIx::Class::AccessorGroup
Class::Accessor::Grouped
/],
'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'
);
-my $dialect_ref = DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server->can('sql_limit_dialect');
+my $storage = DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server->new;
+$storage->_determine_driver;
is (
- B::svref_2object($dialect_ref)->GV->STASH->NAME,
- 'DBIx::Class::Storage::DBI::MSSQL',
+ $storage->can('sql_limit_dialect'),
+ 'DBIx::Class::Storage::DBI::MSSQL'->can('sql_limit_dialect'),
'Correct method picked'
);
+if ($] >= 5.010) {
+ ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+');
+
+ # Class::C3::Componentised loads MRO::Compat unconditionally to satisfy
+ # the assumption that once Class::C3::X is loaded, so is Class::C3
+ #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+');
+}
+
done_testing;
}
} ('Huey', 'Dewey', $ex_title, 'Louie')
])
-}, qr/columns .+ are not unique for populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
+}, qr/\Qexecute_array() aborted with 'constraint failed\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
## make sure populate honors fields/orders in list context
## schema order
name => 'foo3',
},
]);
-} qr/slice/, 'bad slice';
+} qr/\Qexecute_array() aborted with 'datatype mismatch'/, 'bad slice';
is($rs->count, 0, 'populate is atomic');
name => \"'foo'",
}
]);
-} qr/bind expected/, 'literal sql where bind expected throws';
+} qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
# ... and vice-versa.
name => \"'foo'",
}
]);
-} qr/literal SQL expected/i, 'bind where literal sql expected throws';
+} qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
throws_ok {
$rs->populate([
name => \"'bar'",
}
]);
-} qr/inconsistent/, 'literal sql must be the same in all slices';
+} qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
# the stringification has nothing to do with the artist name
# this is solely for testing consistency
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Time::HiRes qw/gettimeofday/;
+
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used
+
+our $src_count = 100;
+
+for (1 .. $src_count) {
+ eval <<EOM or die $@;
+
+ package DBICTest::NS::Stress::Schema::Result::T$_;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table($_);
+ __PACKAGE__->add_columns (
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ data => { data_type => 'varchar', size => 255 },
+ );
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->add_unique_constraint(['data']);
+
+EOM
+}
+
+{
+ package DBICTest::NS::Stress::Schema;
+
+ use base qw/DBIx::Class::Schema/;
+
+ sub _findallmod {
+ return $_[1] eq ( __PACKAGE__ . '::Result' )
+ ? ( map { __PACKAGE__ . "::Result::T$_" } 1 .. $::src_count )
+ : ()
+ ;
+ }
+}
+
+is (DBICTest::NS::Stress::Schema->sources, 0, 'Start with no sources');
+
+
+note gettimeofday . ":\tload_namespaces start";
+DBICTest::NS::Stress::Schema->load_namespaces;
+note gettimeofday . ":\tload_namespaces finished";
+
+is (DBICTest::NS::Stress::Schema->sources, $src_count, 'All sources attached');
+
+done_testing;
use warnings;
use Test::More;
-# README: If you set the env var to a number greater than 10,
-# we will use that many children
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-my $num_children = $ENV{DBICTEST_FORK_STRESS};
-
-plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test'
- unless $num_children;
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
. ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
+# README: If you set the env var to a number greater than 10,
+# we will use that many children
+my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
}
BEGIN {
- plan skip_all => 'Minimum of perl 5.8.3 required for thread tests (DBD::Pg mandated)'
- if $] < '5.008003';
+ plan skip_all => 'Minimum of perl 5.8.5 required for thread tests (DBD::Pg mandated)'
+ if $] < '5.008005';
}
use threads;
# README: If you set the env var to a number greater than 10,
# we will use that many children
-my $num_children = $ENV{DBICTEST_THREAD_STRESS};
-
-plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
- unless $num_children;
-
+my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
use_ok('DBICTest::Schema');
-diag "\n\nIt is ok if you see series of 'Attempt to free unreferenced scalar: ...' warnings during this test\n "
- if $] < '5.008005';
-
my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
my $parent_rs;
}
BEGIN {
- plan skip_all => 'Minimum of perl 5.8.3 required for thread tests (DBD::Pg mandated)'
- if $] < '5.008003';
+ plan skip_all => 'Minimum of perl 5.8.5 required for thread tests (DBD::Pg mandated)'
+ if $] < '5.008005';
}
. ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-my $num_children = $ENV{DBICTEST_THREAD_STRESS};
-plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
- unless $num_children;
-
+my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
use_ok('DBICTest::Schema');
-diag "\n\nIt is ok if you see series of 'Attempt to free unreferenced scalar: ...' warnings during this test\n "
- if $] < '5.008005';
-
my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
my $parent_rs;
+# work around brain damage in PPerl (yes, it has to be a global)
+$SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/
+} if ($ENV{DBICTEST_IN_PERSISTENT_ENV});
+
+# the persistent environments run with this flag first to see if
+# we will run at all (e.g. it will fail if $^X doesn't match)
+exit 0 if $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY};
+
# Do the override as early as possible so that CORE::bless doesn't get compiled away
# We will replace $bless_override only if we are in author mode
my $bless_override;
use warnings;
use Test::More;
+my $TB = Test::More->builder;
+if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
+ # without this explicit close ->reset below warns
+ close ($TB->$_) for qw/output failure_output/;
+
+ # so done_testing can work
+ $TB->reset;
+
+ # this simulates a subtest
+ $TB->_indent(' ' x 4);
+}
+
use lib qw(t/lib);
use DBICTest::RunMode;
+use DBIx::Class;
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
- if DBICTest::RunMode->peepeeness;
+ if DBIx::Class::_ENV_::PEEPEENESS();
}
use Scalar::Util qw/refaddr reftype weaken/;
# this is what holds all weakened refs to be checked for leakage
my $weak_registry = {};
+# whether or to invoke IC::DT
+my $has_dt;
+
# Skip the heavy-duty leak tracing when just doing an install
unless (DBICTest::RunMode->is_plain) {
-
# Some modules are known to install singletons on-load
# Load them before we swap out $bless_override
require DBI;
require Hash::Merge;
require Storable;
+ # this loads the DT armada as well
+ $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite');
+
no warnings qw/redefine once/;
no strict qw/refs/;
}
{
- require DBICTest;
+ use_ok ('DBICTest');
my $schema = DBICTest->init_schema;
my $rs = $schema->resultset ('Artist');
dbh => $storage->_dbh,
);
+ if ($has_dt) {
+ my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event');
+
+ my $now = DateTime->now;
+ for (1..5) {
+ $base_collection->{"icdt_row_$_"} = $rs->create({
+ created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ),
+ starts_at => $now->clone->add(days => $_),
+ });
+ }
+
+ # re-search
+ my @dummy = $rs->all;
+ }
+
memory_cycle_ok ($base_collection, 'No cycles in the object collection')
if $have_test_cycle;
# Naturally we have some exceptions
my $cleared;
for my $slot (keys %$weak_registry) {
- if ($slot =~ /^\QTest::Builder/) {
+ if ($slot =~ /^Test::Builder/) {
# T::B 2.0 has result objects and other fancyness
delete $weak_registry->{$slot};
}
- elsif ($slot =~ /^\QSQL::Translator/) {
+ elsif ($slot =~ /^SQL::Translator/) {
# SQLT is a piece of shit, leaks all over
delete $weak_registry->{$slot};
}
- elsif ($slot =~ /^\QHash::Merge/) {
+ elsif ($slot =~ /^Hash::Merge/) {
# only clear one object of a specific behavior - more would indicate trouble
delete $weak_registry->{$slot}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
# For reasons I can not yet fully understand the table() god-method (located in
# ::ResultSourceProxy::Table) attaches an actual source instance to each class
# as virtually *immortal* class-data.
-# For now just blow away these instances manually but there got to be a saner way
-$_->result_source_instance(undef) for (
+# For now just ignore these instances manually but there got to be a saner way
+for ( map { $_->result_source_instance } (
'DBICTest::BaseResult',
map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
-);
+)) {
+ delete $weak_registry->{$_};
+}
# FIXME
# same problem goes for the schema - its classdata contains live result source
# objects, which to add insult to the injury are *different* instances from the
-# ones we destroyed above
-DBICTest::Schema->source_registrations(undef);
+# ones we ignored above
+for ( values %{DBICTest::Schema->source_registrations || {}} ) {
+ delete $weak_registry->{$_};
+}
-my $tb = Test::More->builder;
for my $slot (sort keys %$weak_registry) {
ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
my $diag = '';
$diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
- if ( $ENV{TEST_VERBOSE} && try { require Devel::FindRef });
+ if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
if (my $stack = $weak_registry->{$slot}{strace}) {
$diag .= " Reference first seen$stack";
};
}
+
+# we got so far without a failure - this is a good thing
+# now let's try to rerun this script under a "persistent" environment
+# this is ugly and dirty but we do not yet have a Test::Embedded or
+# similar
+
+my @pperl_cmd = (qw/pperl --prefork=1/, __FILE__);
+my @pperl_term_cmd = @pperl_cmd;
+splice @pperl_term_cmd, 1, 0, '--kill';
+
+# scgi is smart and will auto-reap after -t amount of seconds
+my @scgi_cmd = (qw/speedy -- -t5/, __FILE__);
+
+SKIP: {
+ skip 'Test already in a persistent loop', 1
+ if $ENV{DBICTEST_IN_PERSISTENT_ENV};
+
+ skip 'Persistence test disabled on regular installs', 1
+ if DBICTest::RunMode->is_plain;
+
+ skip 'Main test failed - skipping persistent env tests', 1
+ unless $TB->is_passing;
+
+ # set up -I
+ require Config;
+ local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+
+ local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1;
+
+ # try with pperl
+ SKIP: {
+ skip 'PPerl persistent environment tests require PPerl', 1
+ unless eval { require PPerl };
+
+ # since PPerl is racy and sucks - just prime the "server"
+ {
+ local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1;
+ system(@pperl_cmd);
+ sleep 1;
+
+ # see if it actually runs - if not might as well bail now
+ skip "Something is wrong with pperl ($!)", 1
+ if system(@pperl_cmd);
+ }
+
+ for (1,2,3) {
+ system(@pperl_cmd);
+ ok (!$?, "Run in persistent env (PPerl pass $_): exit $?");
+ }
+
+ ok (! system (@pperl_term_cmd), 'killed pperl instance');
+ }
+
+ # try with speedy-cgi
+ SKIP: {
+ skip 'SPeedyCGI persistent environment tests require CGI::SpeedyCGI', 1
+ unless eval { require CGI::SpeedyCGI };
+
+ {
+ local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1;
+ skip "Something is wrong with speedy ($!)", 1
+ if system(@scgi_cmd);
+ sleep 1;
+ }
+
+ for (1,2,3) {
+ system(@scgi_cmd);
+ ok (!$?, "Run in persistent env (SpeedyCGI pass $_): exit $?");
+ }
+ }
+}
+
done_testing;
+
+# just an extra precaution in case we blew away from the SKIP - since there are no
+# PID files to go by (man does pperl really suck :(
+END {
+ unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
+ close STDOUT;
+ close STDERR;
+ local $?; # otherwise test will inherit $? of the system()
+ system (@pperl_term_cmd);
+ }
+}
--- /dev/null
+# Use a require override instead of @INC munging (less common)
+# Do the override as early as possible so that CORE::require doesn't get compiled away
+# We will replace $req_override in a bit
+
+my $test_hook;
+BEGIN {
+ $test_hook = sub {}; # noop at first
+ *CORE::GLOBAL::require = sub {
+ $test_hook->(@_);
+ CORE::require($_[0]);
+ };
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ my $core_modules = { map { $_ => 1 } qw/
+ strict
+ warnings
+ vars
+
+ base
+ parent
+ mro
+ overload
+
+ B
+ locale
+
+ namespace::clean
+ Try::Tiny
+ Sub::Name
+
+ Scalar::Util
+ List::Util
+ Hash::Merge
+
+ DBI
+ SQL::Abstract
+
+ Carp
+
+ Class::Accessor::Grouped
+ Class::C3::Componentised
+ /, $] < 5.010 ? 'MRO::Compat' : () };
+
+ $test_hook = sub {
+
+ my $req = $_[0];
+ $req =~ s/\.pm$//;
+ $req =~ s/\//::/g;
+
+ return if $req =~ /^DBIx::Class|^DBICTest::Schema/;
+
+ my $up = 1;
+ my @caller;
+ do { @caller = caller($up++) } while (
+ @caller and (
+ $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector) $/x
+ or
+ $caller[1] =~ / \( eval \s \d+ \) /x
+ )
+ );
+
+ if ( $caller[0] =~ /^DBIx::Class/) {
+ fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])")
+ unless $core_modules->{$req};
+ }
+ };
+}
+
+use lib 't/lib';
+use DBICTest;
+
+# these envvars bring in more stuff
+delete $ENV{$_} for qw/
+ DBICTEST_SQLT_DEPLOY
+ DBIC_TRACE
+/;
+
+my $schema = DBICTest->init_schema;
+is ($schema->resultset('Artist')->next->name, 'Caterwauler McCrae');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use File::Find;
+use File::Spec;
+use B qw/svref_2object/;
+use Package::Stash;
+
+# makes sure we can load at least something
+use DBIx::Class;
+use DBIx::Class::Carp;
+
+my @modules = grep {
+ my $mod = $_;
+
+ # trap deprecation warnings and whatnot
+ local $SIG{__WARN__} = sub {};
+
+ # not all modules are loadable at all times
+ eval "require $mod" ? $mod : do {
+ SKIP: { skip "Failed require of $mod: $@", 1 };
+ ();
+ };
+
+
+} find_modules();
+
+# have an exception table for old and/or weird code we are not sure
+# we *want* to clean in the first place
+my $skip_idx = { map { $_ => 1 } (
+ (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch
+ 'SQL::Translator::Producer::DBIx::Class::File', # ditto
+
+ # not sure how to handle type libraries
+ 'DBIx::Class::Storage::DBI::Replicated::Types',
+ 'DBIx::Class::Admin::Types',
+
+ # G::L::D is unclean, but we never inherit from it
+ 'DBIx::Class::Admin::Descriptive',
+ 'DBIx::Class::Admin::Usage',
+) };
+
+my $has_cmop = eval { require Class::MOP };
+
+# can't use Class::Inspector for the mundane parts as it does not
+# distinguish imports from anything else, what a crock of...
+# Class::MOP is not always available either - hence just do it ourselves
+
+my $seen; #inheritance means we will see the same method multiple times
+
+for my $mod (@modules) {
+ SKIP: {
+ skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod};
+
+ my %all_method_like = (map
+ { %{Package::Stash->new($_)->get_all_symbols('CODE')} }
+ (reverse @{mro::get_linear_isa($mod)})
+ );
+
+ my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)};
+
+ my %roles;
+ if ($has_cmop and my $mc = Class::MOP::class_of($mod)) {
+ if ($mc->can('calculate_all_roles_with_inheritance')) {
+ $roles{$_->name} = 1 for ($mc->calculate_all_roles_with_inheritance);
+ }
+ }
+
+ for my $name (keys %all_method_like) {
+
+ next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN() and $name =~ /^carp(?:_unique|_once)?$/ );
+
+ # overload is a funky thing - it is neither cleaned, and its imports are named funny
+ next if $name =~ /^\(/;
+
+ my $gv = svref_2object($all_method_like{$name})->GV;
+ my $origin = $gv->STASH->NAME;
+
+ TODO: {
+ local $TODO = 'CAG does not clean its BEGIN constants' if $name =~ /^__CAG_/;
+ is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod
+ ? ''
+ : " (inherited by $mod)"
+ ));
+ }
+
+ next if $seen->{"${origin}:${name}"}++;
+
+ if ($origin eq $mod) {
+ pass ("$name is a native $mod method");
+ }
+ elsif ($roles{$origin}) {
+ pass ("${mod}::${name} came from consumption of role $origin");
+ }
+ elsif ($parents{$origin}) {
+ pass ("${mod}::${name} came from proper parent-class $origin");
+ }
+ else {
+ my $via;
+ for (reverse @{mro::get_linear_isa($mod)} ) {
+ if ( ($_->can($name)||'') eq $all_method_like{$name} ) {
+ $via = $_;
+ last;
+ }
+ }
+ fail ("${mod}::${name} appears to have entered inheritance chain by import into "
+ . ($via || 'UNKNOWN')
+ );
+ }
+ }
+
+ next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+
+ # some common import names (these should never ever be methods)
+ for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) {
+ if ($mod->can($f)) {
+ my $via;
+ for (reverse @{mro::get_linear_isa($mod)} ) {
+ if ( ($_->can($f)||'') eq $all_method_like{$f} ) {
+ $via = $_;
+ last;
+ }
+ }
+ fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at "
+ . ($via || 'UNKNOWN')
+ );
+ }
+ else {
+ pass ("Import $f not leaked into method list of $mod");
+ }
+ }
+ }
+}
+
+sub find_modules {
+ my @modules;
+
+ find({
+ wanted => sub {
+ -f $_ or return;
+ s/\.pm$// or return;
+ s/^ (?: lib | blib . (?:lib|arch) ) . //x;
+ push @modules, join ('::', File::Spec->splitdir($_));
+ },
+ no_chdir => 1,
+ }, (-e 'blib' ? 'blib' : 'lib') );
+
+ return sort @modules;
+}
+
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-
-# XXX obviously, the guts of this test haven't been written yet --blblack
-
-use lib qw(t/lib);
-
-plan skip_all => 'Set $ENV{DBICTEST_STORAGE_STRESS} to run this test'
- . ' (it is very resource intensive!)'
- unless $ENV{DBICTEST_STORAGE_STRESS};
-
-my $NKIDS = 20;
-my $CYCLES = 5;
-my @KILL_RATES = qw/0 0.001 0.01 0.1 0.2 0.5 0.75 1.0/;
-
-# Stress the storage with these parameters...
-sub stress_storage {
- my ($connect_info, $num_kids, $cycles, $kill_rate) = @_;
-
- foreach my $cycle (1..$cycles) {
- my $schema = DBICTest::Schema->connection(@$connect_info, { AutoCommit => 1 });
- foreach my $kidno (1..$num_kids) {
- ok(1);
- }
- }
-}
-
-# Get a set of connection information -
-# whatever the user has supplied for the vendor-specific tests
-sub get_connect_infos {
- my @connect_infos;
- foreach my $db_prefix (qw/PG MYSQL DB2 MSSQL ORA/) {
- my @conn_info = @ENV{
- map { "DBICTEST_${db_prefix}_${_}" } qw/DSN USER PASS/
- };
- push(@connect_infos, \@conn_info) if $conn_info[0];
- }
- \@connect_infos;
-}
-
-my $connect_infos = get_connect_infos();
-
-plan skip_all => 'This test needs some non-sqlite connect info!'
- unless @$connect_infos;
-
-plan tests => (1 * @$connect_infos * $NKIDS * $CYCLES * @KILL_RATES) + 1;
-
-use_ok('DBICTest::Schema');
-
-foreach my $connect_info (@$connect_infos) {
- foreach my $kill_rate (@KILL_RATES) {
- stress_storage($connect_info, $NKIDS, $CYCLES, $kill_rate);
- }
-}
{
my $handle = $schema->source('Artist')->handle;
- my $rowdata = {
- artistid => 3,
- charfield => undef,
- name => "We Are In Rehab",
- rank => 13
- };
+ my $rowdata = { $schema->resultset('Artist')->next->get_columns };
my $rs = DBIx::Class::ResultSet->new($handle);
my $rs_result = $rs->next;
use Test::More;
use Test::Exception;
+
+use DBI::Const::GetInfoType;
+use Scalar::Util qw/weaken/;
+
use lib qw(t/lib);
use DBICTest;
-use DBI::Const::GetInfoType;
use DBIC::SqlMakerTest;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
);
}
-## If find() is the first query after connect()
-## DBI::Storage::sql_maker() will be called before
-## _determine_driver() and so the ::SQLHacks class for MySQL
-## will not be used
+# make sure find hooks determine driver
+{
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema->resultset("Artist")->find(4);
+ isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL');
+}
+
+# make sure the mysql_auto_reconnect buggery is avoided
+{
+ local $ENV{MOD_PERL} = 'boogiewoogie';
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ ok (! $schema->storage->_get_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect unset regardless of ENV' );
+
+ # Make sure hardcore forking action still works even if mysql_auto_reconnect
+ # is true (test inspired by ether)
+
+ my $schema_autorecon = DBICTest::Schema->connect($dsn, $user, $pass, { mysql_auto_reconnect => 1 });
+ my $orig_dbh = $schema_autorecon->storage->_get_dbh;
+ weaken $orig_dbh;
+
+ ok ($orig_dbh, 'Got weak $dbh ref');
+ ok ($orig_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect is properly set if explicitly requested' );
+
+ my $rs = $schema_autorecon->resultset('Artist');
+
+ my $pid = fork();
+ if (! defined $pid ) {
+ die "fork() failed: $!"
+ }
+ elsif ($pid) {
+ # sanity check
+ $schema_autorecon->storage->dbh_do(sub {
+ is ($_[1], $orig_dbh, 'Storage holds correct $dbh in parent');
+ });
+
+ # kill our $dbh
+ $schema_autorecon->storage->_dbh(undef);
+
+ TODO: {
+ local $TODO = "Perl $] is known to leak like a sieve"
+ if DBIx::Class::_ENV_::PEEPEENESS();
+
+ ok (! defined $orig_dbh, 'Parent $dbh handle is gone');
+ }
+ }
+ else {
+ # wait for parent to kill its $dbh
+ sleep 1;
+
+ #simulate a subtest to not confuse the parent TAP emission
+ Test::More->builder->reset;
+ Test::More->builder->plan('no_plan');
+ Test::More->builder->_indent(' ' x 4);
+
+ ok ($orig_dbh, 'Now dead $dbh is still there for the child');
+
+ # try to do something dbic-esque
+ $rs->create({ name => "Hardcore Forker $$" });
-my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
-$schema2->resultset("Artist")->find(4);
-isa_ok($schema2->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL');
+
+ TODO: {
+ local $TODO = "Perl $] is known to leak like a sieve"
+ if DBIx::Class::_ENV_::PEEPEENESS();
+
+ ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone');
+ }
+
+ exit 0;
+ }
+
+ wait;
+ ok(!$?, 'Child subtests passed');
+
+ ok ($rs->find({ name => "Hardcore Forker $pid" }), 'Expected row created');
+}
done_testing;
arrayfield => [5, 6],
});
+ lives_ok {
+ $schema->populate('ArrayTest', [
+ [ qw/arrayfield/ ],
+ [ [0,0] ],
+ ]);
+ } 'inserting arrayref using void ctx populate';
+
# Search using arrays
lives_ok {
is_deeply (
for my $stat (
'DROP SCHEMA dbic_t_schema_5 CASCADE',
- 'DROP SEQUENCE public.artist_artistid_seq',
+ 'DROP SEQUENCE public.artist_artistid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_4 CASCADE',
'DROP SCHEMA dbic_t_schema CASCADE',
- 'DROP SEQUENCE pkid1_seq',
- 'DROP SEQUENCE pkid2_seq',
- 'DROP SEQUENCE nonpkid_seq',
+ 'DROP SEQUENCE pkid1_seq CASCADE',
+ 'DROP SEQUENCE pkid2_seq CASCADE',
+ 'DROP SEQUENCE nonpkid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_2 CASCADE',
'DROP SCHEMA dbic_t_schema_3 CASCADE',
) {
# the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way
$dbh->do(qq[
- CREATE TABLE bindtype_test
+ CREATE TABLE bindtype_test
(
id serial NOT NULL PRIMARY KEY,
bytea bytea NULL,
blob bytea NULL,
- clob text NULL
+ clob text NULL,
+ a_memo text NULL
);
],{ RaiseError => 1, PrintError => 1 });
}
$new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
ok($new->id, "Created a bytea row");
- is($new->bytea, $big_long_string, "Set the blob correctly.");
+ ok($new->bytea eq $big_long_string, "Set the blob correctly.");
}
# test retrieval of the bytea column
{
my $row = $schema->resultset('BindType')->find({ id => $new->id });
- is($row->get_column('bytea'), $big_long_string, "Created the blob correctly.");
+ ok($row->get_column('bytea') eq $big_long_string, "Created the blob correctly.");
}
{
$schema->txn_do(sub {
$rs->update({ bytea => $new_big_long_string });
my $row = $schema->resultset('BindType')->find({ id => $new->id });
- is($row ? $row->get_column('bytea') : undef, $new_big_long_string,
+ ok( ($row ? $row->get_column('bytea') : '') eq $new_big_long_string,
"Updated the row correctly (searching on the bytea column)."
);
$schema->txn_rollback;
# create with blob from $rs
$new = $rs->create({});
- is($new->bytea, $big_long_string, 'Object has bytea value from $rs');
+ ok($new->bytea eq $big_long_string, 'Object has bytea value from $rs');
$new->discard_changes;
- is($new->bytea, $big_long_string, 'bytea value made it to db');
+ ok($new->bytea eq $big_long_string, 'bytea value made it to db');
}
done_testing;
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use Sub::Name;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
+# optional:
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
+ unless ($dsn && $user && $pass);
+
{
package # hide from PAUSE
DBICTest::Schema::ArtistFQN;
1;
}
-use strict;
-use warnings;
-
-use Test::Exception;
-use Test::More;
-use Sub::Name;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
-
-$ENV{NLS_SORT} = "BINARY";
-$ENV{NLS_COMP} = "BINARY";
-$ENV{NLS_LANG} = "AMERICAN";
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
-
-# optional:
-my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
- unless ($dsn && $user && $pass);
-
DBICTest::Schema->load_classes('ArtistFQN');
# This is in Core now, but it's here just to test that it doesn't break
DBICTest::Schema::Track->load_components('PK::Auto::Oracle');
+# check if we indeed do support stuff
+my $v = do {
+ my $v = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_dbh_get_info(18);
+ $v =~ /^(\d+)\.(\d+)/
+ or die "Unparseable Oracle server version: $v\n";
+
+ sprintf('%d.%03d', $1, $2);
+};
+
+# while 8i (8.1) does not document support for ansi joins, and the the drivers do not use
+# them because performance sucks, there is strong evidence they are in fact supported
+# means we can test 'em :)
+my $test_server_supports_only_orajoins = $v < 8.001;
+
+# TODO find out which version supports the RETURNING syntax
+# 8i (8.1) has it and earlier docs are a 404 on oracle.com
+my $test_server_supports_insert_returning = $v >= 8.001;
+
+is (
+ DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
+ $test_server_supports_insert_returning,
+ 'insert returning capability guessed correctly'
+);
+
##########
# recyclebin sometimes comes in the way
my $on_connect_sql = ["ALTER SESSION SET recyclebin = OFF"];
# iterate all tests on following options
my @tryopt = (
{ on_connect_do => $on_connect_sql },
- { quote_char => '"', on_connect_do => $on_connect_sql, },
+ { quote_char => '"', on_connect_do => $on_connect_sql },
);
# keep a database handle open for cleanup
my ($dbh, $dbh2);
-# test insert returning
-
-# check if we indeed do support stuff
-my $test_server_supports_insert_returning = do {
- my $v = DBICTest::Schema->connect($dsn, $user, $pass)
- ->storage
- ->_get_dbh
- ->get_info(18);
- $v =~ /^(\d+)\.(\d+)/
- or die "Unparseable Oracle server version: $v\n";
-
-# TODO find out which version supports the RETURNING syntax
-# 8i has it and earlier docs are a 404 on oracle.com
- ( $1 > 8 || ($1 == 8 && $2 >= 1) ) ? 1 : 0;
-};
-is (
- DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
- $test_server_supports_insert_returning,
- 'insert returning capability guessed correctly'
-);
-
my $schema;
-for my $use_insert_returning ($test_server_supports_insert_returning
- ? (1,0)
- : (0)
-) {
-
- no warnings qw/once/;
- local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
- my $s = shift->next::method (@_);
- $s->storage->_use_insert_returning ($use_insert_returning);
- $s;
- };
-
- for my $opt (@tryopt) {
- # clean all cached sequences from previous run
- for (map { values %{DBICTest::Schema->source($_)->columns_info} } (qw/Artist CD Track/) ) {
- delete $_->{sequence};
- }
+for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) {
+ for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) {
+
+ no warnings qw/once/;
+ local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+ my $s = shift->next::method (@_);
+ $s->storage->_use_insert_returning ($use_insert_returning);
+ $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins;
+ $s;
+ };
+
+ for my $opt (@tryopt) {
+ # clean all cached sequences from previous run
+ for (map { values %{DBICTest::Schema->source($_)->columns_info} } (qw/Artist CD Track/) ) {
+ delete $_->{sequence};
+ }
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt);
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt);
- $dbh = $schema->storage->dbh;
- my $q = $schema->storage->sql_maker->quote_char || '';
+ $dbh = $schema->storage->dbh;
+ my $q = $schema->storage->sql_maker->quote_char || '';
- do_creates($dbh, $q);
+ do_creates($dbh, $q);
- _run_tests($schema, $opt);
+ _run_tests($schema, $opt);
+ }
}
}
is( $it->next->name, "Artist 6", "iterator->next ok" );
is( $it->next, undef, "next past end of resultset ok" );
-
# test identifiers over the 30 char limit
lives_ok {
my @results = $schema->resultset('CD')->search(undef, {
is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
} 'query with rel name over 30 chars survived and worked';
+# test rel names over the 30 char limit using group_by and join
+ {
+ my @group_cols = ( 'me.name' );
+ my $query = $schema->resultset('Artist')->search({
+ artistid => 1
+ }, {
+ select => \@group_cols,
+ as => [map { /^\w+\.(\w+)$/ } @group_cols],
+ join => [qw( cds_very_very_very_long_relationship_name )],
+ group_by => \@group_cols,
+ });
+
+ lives_and {
+ my @got = $query->get_column('name')->all();
+ is_deeply \@got, [$new_artist->name];
+ } 'query with rel name over 30 chars worked on join, group_by for me col';
+
+ lives_and {
+ is $query->count(), 1
+ } 'query with rel name over 30 chars worked on join, group_by, count for me col';
+ }
+ {
+ my @group_cols = ( 'cds_very_very_very_long_relationship_name.title' );
+ my $query = $schema->resultset('Artist')->search({
+ artistid => 1
+ }, {
+ select => \@group_cols,
+ as => [map { /^\w+\.(\w+)$/ } @group_cols],
+ join => [qw( cds_very_very_very_long_relationship_name )],
+ group_by => \@group_cols,
+ });
+
+ lives_and {
+ my @got = $query->get_column('title')->all();
+ is_deeply \@got, [$new_cd->title];
+ } 'query with rel name over 30 chars worked on join, group_by for long rel col';
+
+ lives_and {
+ is $query->count(), 1
+ } 'query with rel name over 30 chars worked on join, group_by, count for long rel col';
+ }
+
# rel name over 30 char limit with user condition
# This requires walking the SQLA data structure.
{
- local $TODO = 'user condition on rel longer than 30 chars';
-
$query = $schema->resultset('Artist')->search({
'cds_very_very_very_long_relationship_name.title' => 'EP C'
}, {
$schema->storage->debug (0);
local $TODO = 'Something is confusing column bindtype assignment when quotes are active'
+ . ': https://rt.cpan.org/Ticket/Display.html?id=64206'
if $q;
foreach my $type (qw( blob clob )) {
'Partially failed populate did not alter table contents'
);
+# test complex join (exercise orajoins)
+ lives_ok {
+ my @hri = $schema->resultset('CD')->search(
+ { 'artist.name' => 'pop_art_1', 'me.cdid' => { '!=', 999} },
+ { join => 'artist', prefetch => 'tracks', rows => 4, order_by => 'tracks.trackid' }
+ )->hri_dump->all;
+
+ my $expect = [{
+ artist => 1,
+ cdid => 1,
+ genreid => undef,
+ single_track => undef,
+ title => "EP C",
+ tracks => [
+ {
+ cd => 1,
+ last_updated_at => undef,
+ last_updated_on => undef,
+ position => 1,
+ title => "Track1",
+ trackid => 1
+ },
+ {
+ cd => 1,
+ last_updated_at => undef,
+ last_updated_on => undef,
+ position => 1,
+ title => "Track2",
+ trackid => 2
+ },
+ ],
+ year => 2003
+ }];
+
+ is_deeply (
+ \@hri,
+ $expect,
+ 'Correct set of data prefetched',
+ );
+
+ } 'complex prefetch ok';
+
# test sequence detection from a different schema
SKIP: {
TODO: {
$dbh->do("CREATE TABLE ${q}track${q} (${q}trackid${q} NUMBER(12), ${q}cd${q} NUMBER(12) REFERENCES CD(${q}cdid${q}) DEFERRABLE, ${q}position${q} NUMBER(12), ${q}title${q} VARCHAR(255), ${q}last_updated_on${q} DATE, ${q}last_updated_at${q} DATE)");
$dbh->do("ALTER TABLE ${q}track${q} ADD (CONSTRAINT ${q}track_pk${q} PRIMARY KEY (${q}trackid${q}))");
- $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}clob${q} clob NULL)");
+ $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}clob${q} clob NULL, ${q}a_memo${q} integer NULL)");
$dbh->do(qq{
CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_auto${q}
START WITH name = ?
CONNECT BY parentid = PRIOR artistid
)',
- [ [ name => 'root'] ],
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
);
is_deeply (
[ $rs->get_column ('name')->all ],
START WITH name = ?
CONNECT BY parentid = PRIOR artistid
)',
- [ [ name => 'root'] ],
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
);
is( $rs->count, 5, 'Connect By count ok' );
CONNECT BY parentid = PRIOR artistid
ORDER SIBLINGS BY name DESC
)',
- [ [ name => 'root'] ],
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
);
is_deeply (
START WITH name = ?
CONNECT BY parentid = PRIOR artistid
)',
- [ [ name => 'root'] ],
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
);
is_deeply(
START WITH me.name = ?
CONNECT BY parentid = PRIOR artistid
)',
- [ [ 'cds.title' => '%cd' ], [ 'me.name' => 'root' ] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 }
+ => '%cd'],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
);
is_deeply(
START WITH me.name = ?
CONNECT BY parentid = PRIOR artistid
)',
- [ [ 'cds.title' => '%cd' ], [ 'me.name' => 'root' ] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 }
+ => '%cd'],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
);
is( $rs->count, 1, 'Connect By with a join; count ok' );
CONNECT BY parentid = PRIOR artistid
ORDER BY LEVEL ASC, name ASC
)',
- [ [ name => 'root' ] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
);
) me
WHERE ROWNUM <= 2
)',
- [ [ name => 'root' ] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
);
is_deeply (
WHERE ROWNUM <= 2
) me
)',
- [ [ name => 'root' ] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
);
is( $rs->count, 2, 'Connect By; LIMIT count ok' );
}
# combine a connect_by with group_by and having
+ # add some bindvals to make sure things still work
{
my $rs = $schema->resultset('Artist')->search({}, {
- select => { count => 'rank', -as => 'cnt' },
+ select => \[ 'COUNT(rank) + ?', [ __cbind => 3 ] ],
+ as => 'cnt',
start_with => { name => 'root' },
connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
- group_by => ['rank'],
+ group_by => \[ 'rank + ? ', [ __gbind => 1] ],
having => \[ 'count(rank) < ?', [ cnt => 2 ] ],
});
is_same_sql_bind (
$rs->as_query,
'(
- SELECT COUNT(rank) AS cnt
+ SELECT COUNT(rank) + ?
FROM artist me
START WITH name = ?
CONNECT BY parentid = PRIOR artistid
- GROUP BY rank HAVING count(rank) < ?
+ GROUP BY( rank + ? ) HAVING count(rank) < ?
)',
- [ [ name => 'root' ], [ cnt => 2 ] ],
+ [
+ [ { dbic_colname => '__cbind' }
+ => 3 ],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ [ { dbic_colname => '__gbind' }
+ => 1 ],
+ [ { dbic_colname => 'cnt' }
+ => 2 ],
+ ],
);
is_deeply (
[ $rs->get_column ('cnt')->all ],
- [1, 1],
+ [4, 4],
'Group By a Connect By query - correct values'
);
}
START WITH name = ?
CONNECT BY NOCYCLE parentid = PRIOR artistid
)',
- [ [ name => 'cycle-root'] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'cycle-root'],
+ ],
);
is_deeply (
[ $rs->get_column ('name')->all ],
START WITH name = ?
CONNECT BY NOCYCLE parentid = PRIOR artistid
)',
- [ [ name => 'cycle-root'] ],
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'cycle-root'],
+ ],
);
is( $rs->count, 4, 'Connect By Nocycle count ok' );
use Test::More;
use Test::Exception;
+use Try::Tiny;
use lib qw(t/lib);
use DBICTest;
my $dbh = $schema->storage->dbh;
+# test RNO and name_sep detection
+my $name_sep = $dbh->get_info(41);
+
+is $schema->storage->sql_maker->name_sep, $name_sep,
+ 'name_sep detection';
+
+my $have_rno = try {
+ $dbh->selectrow_array(
+"SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1"
+ );
+ 1;
+};
+
+is $schema->storage->sql_maker->limit_dialect,
+ ($have_rno ? 'RowNumberOver' : 'FetchFirst'),
+ 'limit_dialect detection';
+
eval { $dbh->do("DROP TABLE artist") };
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
is( $lim->next->artistid, 102, "iterator->next ok" );
is( $lim->next, undef, "next past end of resultset ok" );
+# test FetchFirst limit dialect syntax
+{
+ local $schema->storage->sql_maker->{limit_dialect} = 'FetchFirst';
+
+ my $lim = $ars->search({}, {
+ rows => 3,
+ offset => 2,
+ order_by => 'artistid',
+ });
+
+ is $lim->count, 3, 'fetch first limit count ok';
+
+ is $lim->all, 3, 'fetch first number of ->all objects matches count';
+
+ is $lim->next->artistid, 3, 'iterator->next ok';
+ is $lim->next->artistid, 66, 'iterator->next ok';
+ is $lim->next->artistid, 101, 'iterator->next ok';
+ is $lim->next, undef, 'iterator->next past end of resultset ok';
+}
my $test_type_info = {
'artistid' => {
);
my ($sql, @bind) = @${$owners->page(3)->as_query};
- is_deeply (
+ is_same_bind (
\@bind,
[
- $dialect eq 'Top' ? [ test => 'xxx' ] : (), # the extra re-order bind
- ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 # double because of the prefetch subq
+ $dialect eq 'Top' ? [ { dbic_colname => 'test' } => 'xxx' ] : (), # the extra re-order bind
+ (map {
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' }
+ => 'somebogusstring' ],
+ [ { dbic_colname => 'test' }
+ => 'xxx' ],
+ } (1,2)), # double because of the prefetch subq
],
);
);
($sql, @bind) = @${$books->page(3)->as_query};
- is_deeply (
+ is_same_bind (
\@bind,
[
# inner
- [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'wiggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'woggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
+ [ { dbic_colname => 'test' }
+ => '1' ],
+
# outer
- [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'wiggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'woggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
],
);
$dbh->do(qq[
CREATE TABLE bindtype_test
(
- id INT IDENTITY PRIMARY KEY,
- bytea IMAGE NULL,
- blob IMAGE NULL,
- clob TEXT NULL
+ id INT IDENTITY PRIMARY KEY,
+ bytea IMAGE NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo IMAGE NULL
)
],{ RaiseError => 1, PrintError => 0 });
}
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
{
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
]);
} 'insert_bulk with blobs does not die';
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
{
id => 2,
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
]);
} 'insert_bulk with blobs and explicit identity does NOT die';
use lib qw(t/lib);
use DBICTest;
+# Example DSN (from frew):
+# dbi:ADO:PROVIDER=sqlncli10;SERVER=tcp:172.24.2.10;MARS Connection=True;Initial Catalog=CIS;UID=cis_web;PWD=...;DataTypeCompatibility=80;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test'
isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server' );
+my $ver = $schema->storage->_server_info->{normalized_dbms_version};
+
+ok $ver, 'can introspect DBMS version';
+
+is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'),
+ 'correct limit dialect detected';
+
$schema->storage->dbh_do (sub {
my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE artist") };
+ eval { local $^W = 0; $dbh->do("DROP TABLE artist") };
$dbh->do(<<'SQL');
CREATE TABLE artist (
artistid INT IDENTITY NOT NULL,
# test large column list in select
$found = $schema->resultset('Artist')->search({ name => 'foo' }, {
- select => ['artistid', 'name', map "'foo' foo_$_", 0..50],
- as => ['artistid', 'name', map "foo_$_", 0..50],
+ select => ['artistid', 'name', map \"'foo' foo_$_", 0..50],
+ as => ['artistid', 'name', map "foo_$_", 0..50],
})->first;
is $found->artistid, $new->artistid, 'select with big column list';
is $found->get_column('foo_50'), 'foo', 'last item in big column list';
# clean up our mess
END {
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_) unless $_[0] =~ /Not a Win32::OLE object/
+ };
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
for qw/artist/;
use Test::More;
use Test::Exception;
use Scope::Guard ();
+use Try::Tiny;
use lib qw(t/lib);
use DBICTest;
$dbh->do(qq[
CREATE TABLE bindtype_test
(
- id INT NOT NULL PRIMARY KEY,
- bytea INT NULL,
- blob LONG BINARY NULL,
- clob LONG VARCHAR NULL
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob LONG BINARY NULL,
+ clob LONG VARCHAR NULL,
+ a_memo INT NULL
)
],{ RaiseError => 1, PrintError => 1 });
my @uuid_types = qw/uniqueidentifier uniqueidentifierstr/;
-# test uniqueidentifiers
+# test uniqueidentifiers (and the cursor_class).
+
for my $uuid_type (@uuid_types) {
local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
= $uuid_type;
SQL
});
+ local $TODO = 'something wrong with uniqueidentifierstr over ODBC'
+ if $dsn =~ /:ODBC:/ && $uuid_type eq 'uniqueidentifierstr';
+
my $row;
lives_ok {
$row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
);
diag $@ if $@;
- my $row_from_db = $schema->resultset('ArtistGUID')
- ->search({ name => 'mtfnpy' })->first;
+ my $row_from_db = try { $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first }
+ catch { diag $_ };
+
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->search->next)';
+
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->next)';
+
+ $row_from_db = try { $schema->resultset('ArtistGUID')
+ ->find($row->artistid) }
+ catch { diag $_ };
+
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->find)';
+
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->find)';
+
+ ($row_from_db) = try { $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all }
+ catch { diag $_ };
- is $row_from_db->artistid, $row->artistid,
- 'PK GUID round trip';
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->search->all)';
- is $row_from_db->a_guid, $row->a_guid,
- 'NON-PK GUID round trip';
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->all)';
}
}
my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
+# test transaction commit
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_transaction' });
+ });
+ ok (($ars->search({ name => 'in_transaction' })->first),
+ 'transaction committed');
+ is $schema->storage->_dbh->{AutoCommit}, 1,
+ '$dbh->{AutoCommit} is correct after transaction commit';
+
+ $ars->search({ name => 'in_transaction' })->delete;
+
# test savepoints
throws_ok {
$schema->txn_do(sub {
} qr/rolling back outer txn/,
'correct exception for rollback';
+ is $schema->storage->_dbh->{AutoCommit}, 1,
+ '$dbh->{AutoCommit} is correct after transaction rollback';
+
ok ((not $ars->search({ name => 'in_outer_txn' })->first),
'outer txn rolled back');
"id" INT PRIMARY KEY,
"bytea" INT,
"blob" BLOB,
- "clob" BLOB SUB_TYPE TEXT
+ "clob" BLOB SUB_TYPE TEXT,
+ "a_memo" INT
)
]);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+DBICTest::Schema->load_classes('ArtistGUID');
+
+# Example DSNs (32bit only):
+# dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb
+# dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb
+# dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False'
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.\nWarning: this test drops and creates the tables 'artist', 'cd', 'bindtype_test' and 'artist_guid'.
+EOF
+
+plan skip_all => 'Test needs ' .
+DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc')
+. ' or ' .
+DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado')
+ unless
+ DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc')
+ or
+ DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado');
+
+my @info = (
+ [ $dsn, $user || '', $pass || '' ],
+ [ $dsn2, $user2 || '', $pass2 || '' ],
+);
+
+my $schema;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+# Check that we can connect without any options.
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ lives_ok {
+ $schema->storage->ensure_connected;
+ } 'connection without any options';
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ quote_names => 1,
+ auto_savepoint => 1,
+ LongReadLen => $maxloblen,
+ });
+
+ my $guard = Scope::Guard->new(\&cleanup);
+
+ my $dbh = $schema->storage->dbh;
+
+ # turn off warnings for OLE exception from ADO about nonexistant table
+ eval { local $^W = 0; $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid AUTOINCREMENT PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT NULL
+ )
+EOF
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+ my $first_artistid = $new->artistid;
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# test joins
+ eval { local $^W = 0; $dbh->do("DROP TABLE cd") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE cd (
+ cdid AUTOINCREMENT PRIMARY KEY,
+ artist INTEGER NULL,
+ title VARCHAR(255) NULL,
+ [year] CHAR(4) NULL,
+ genreid INTEGER NULL,
+ single_track INTEGER NULL
+ )
+EOF
+
+ $dbh->do(<<EOF);
+ CREATE TABLE track (
+ trackid AUTOINCREMENT PRIMARY KEY,
+ cd INTEGER REFERENCES cd(cdid),
+ [position] INTEGER,
+ title VARCHAR(255),
+ last_updated_on DATETIME,
+ last_updated_at DATETIME
+ )
+EOF
+
+ my $cd = $schema->resultset('CD')->create({
+ artist => $first_artistid,
+ title => 'Some Album',
+ });
+
+# one-step join
+ my $joined_artist = $schema->resultset('Artist')->search({
+ artistid => $first_artistid,
+ }, {
+ join => [ 'cds' ],
+ '+select' => [ 'cds.title' ],
+ '+as' => [ 'cd_title' ],
+ })->next;
+
+ is $joined_artist->get_column('cd_title'), 'Some Album',
+ 'one-step join works';
+
+# two-step join
+ my $track = $schema->resultset('Track')->create({
+ cd => $cd->cdid,
+ position => 1,
+ title => 'my track',
+ });
+
+ my $joined_track = try {
+ $schema->resultset('Artist')->search({
+ artistid => $first_artistid,
+ }, {
+ join => [{ cds => 'tracks' }],
+ '+select' => [ 'tracks.title' ],
+ '+as' => [ 'track_title' ],
+ })->next;
+ }
+ catch {
+ diag "Could not execute two-step join: $_";
+ };
+
+ is try { $joined_track->get_column('track_title') }, 'my track',
+ 'two-step join works';
+
+# test basic transactions
+ $schema->txn_do(sub {
+ $ars->create({ name => 'transaction_commit' });
+ });
+ ok($ars->search({ name => 'transaction_commit' })->first,
+ 'transaction committed');
+ $ars->search({ name => 'transaction_commit' })->delete,
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'transaction_rollback' });
+ die 'rolling back';
+ });
+ } qr/rolling back/, 'rollback executed';
+ is $ars->search({ name => 'transaction_rollback' })->first, undef,
+ 'transaction rolled back';
+
+# test two-phase commit and inner transaction rollback from nested transactions
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_outer_transaction' });
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction' });
+ });
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction visible in outer transaction');
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction_rolling_back' });
+ die 'rolling back inner transaction';
+ });
+ } qr/rolling back inner transaction/, 'inner transaction rollback executed';
+ });
+ ok($ars->search({ name => 'in_outer_transaction' })->first,
+ 'commit from outer transaction');
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction');
+ is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
+ undef,
+ 'rollback from inner transaction';
+ $ars->search({ name => 'in_outer_transaction' })->delete;
+ $ars->search({ name => 'in_inner_transaction' })->delete;
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+# not testing offset because access only supports TOP
+ my $lim = $ars->search( {},
+ {
+ rows => 2,
+ offset => 0,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( $lim->next->artistid, 1, "iterator->next ok" );
+ is( $lim->next->artistid, 66, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ my $current_artistid = $ars->search({}, {
+ select => [ { max => 'artistid' } ], as => ['artistid']
+ })->first->artistid;
+
+ my $row;
+ lives_ok { $row = $ars->create({}) }
+ 'empty insert works';
+
+ $row->discard_changes;
+
+ is $row->artistid, $current_artistid+1,
+ 'empty insert generated correct PK';
+
+# test that autoinc column still works after empty insert
+ $row = $ars->create({ name => 'after_empty_insert' });
+
+ is $row->artistid, $current_artistid+2,
+ 'autoincrement column functional aftear empty insert';
+
+# test blobs (stolen from 73oracle.t)
+
+# turn off horrendous binary DBIC_TRACE output
+ {
+ local $schema->storage->{debug} = 0;
+
+ eval { local $^W = 0; $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo MEMO NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob a_memo )) {
+ foreach my $size (qw( small large )) {
+ SKIP: {
+ skip 'TEXT columns not cast to MEMO over ODBC', 2
+ if $type eq 'clob' && $size eq 'large' && $dsn =~ /:ODBC:/;
+
+ $id++;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying" or next;
+
+ my $from_db = eval { $rs->find($id)->$type } || '';
+ diag $@ if $@;
+
+ ok($from_db eq $binstr{$size}, "verified inserted $size $type" )
+ or do {
+ my $hexdump = sub {
+ join '', map sprintf('%02X', ord), split //, shift
+ };
+ diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...',
+ substr($hexdump->($from_db),-255);
+ diag 'Size: ', length($from_db);
+ diag 'Expected Size: ', length($binstr{$size});
+ diag 'Expected: ', "\n",
+ substr($hexdump->($binstr{$size}), 0, 255),
+ "...", substr($hexdump->($binstr{$size}),-255);
+ };
+ }
+ }
+ }
+# test IMAGE update
+ lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{small} });
+ } 'updated IMAGE to small binstr without dying';
+
+ lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{large} });
+ } 'updated IMAGE to large binstr without dying';
+ }
+
+# test GUIDs (and the cursor GUID fixup stuff for ADO)
+
+ require Data::GUID;
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+ local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
+ = 'guid';
+
+ local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
+ = 'guid';
+
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist_guid (
+ artistid GUID NOT NULL,
+ name VARCHAR(100),
+ rank INT NULL,
+ charfield CHAR(10) NULL,
+ a_guid GUID,
+ primary key(artistid)
+)
+SQL
+ });
+
+ lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+ } 'created a row with a GUID';
+
+ ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+ );
+ diag $@ if $@;
+
+ ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+ );
+ diag $@ if $@;
+
+ my $row_from_db = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first;
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->search->next)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->next)';
+
+ $row_from_db = $schema->resultset('ArtistGUID')
+ ->find($row->artistid);
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->find)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->find)';
+
+ ($row_from_db) = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all;
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->search->all)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->all)';
+}
+
+done_testing;
+
+sub cleanup {
+ if (my $storage = eval { $schema->storage }) {
+ # cannot drop a table if it has been used, have to reconnect first
+ $schema->storage->disconnect;
+ local $^W = 0; # for ADO OLE exceptions
+ $schema->storage->dbh->do("DROP TABLE $_")
+ for qw/artist track cd bindtype_test artist_guid/;
+ }
+}
+
+# vim:sts=2 sw=2:
'no spurious warnings issued',
);
+warnings_like (
+ sub {
+ package A::Test1Loud;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [qr/Use of DBIx::Class::UTF8Columns is strongly discouraged/],
+ 'issued deprecation warning',
+);
+
+
my $test1_mro;
my $idx = 0;
for (@{mro::get_linear_isa ('A::Test1')} ) {
'tracks.last_updated_at' => { '!=', undef },
'tracks.last_updated_on' => { '<', 2009 },
'tracks.position' => 4,
- 'tracks.single_track' => \[ '= ?', [ single_track => [1, 2, 3 ] ] ],
+ 'me.single_track' => \[ '= ?', [ single_track => [1, 2, 3 ] ] ],
}, { join => 'tracks' });
my $bind = [
- [ cdid => 5 ],
- [ 'tracks.last_updated_on' => 2009 ],
- [ 'tracks.position' => 4 ],
- [ 'single_track' => [ 1, 2, 3] ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'cdid' }
+ => 5 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'single_track' }
+ => [ 1, 2, 3] ],
+ [ { sqlt_datatype => 'datetime', dbic_colname => 'tracks.last_updated_on' }
+ => 2009 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 4 ],
];
is_same_sql_bind (
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE
cdid > ?
+ AND me.single_track = ?
AND tracks.last_updated_at IS NOT NULL
AND tracks.last_updated_on < ?
AND tracks.position = ?
- AND tracks.single_track = ?
)',
$bind,
'expected sql with casting off',
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE
cdid > CAST(? AS INT)
+ AND me.single_track = CAST(? AS INT)
AND tracks.last_updated_at IS NOT NULL
AND tracks.last_updated_on < CAST (? AS DateTime)
AND tracks.position = ?
- AND tracks.single_track = CAST(? AS INT)
)',
$bind,
'expected sql with casting on',
use Test::Warn;
use Test::Exception;
+use Path::Class;
+use File::Copy;
+use Time::HiRes qw/time sleep/;
+
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used
+
my ($dsn, $user, $pass);
BEGIN {
unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
-use Path::Class;
-use File::Copy;
-use Time::HiRes qw/time sleep/;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
use_ok('DBICVersion_v1');
my $version_table_name = 'dbix_class_schema_versions';
# attempt v1 -> v3 upgrade
{
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v3->upgrade();
is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
}
# Then attempt v1 -> v3 upgrade
{
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v3->upgrade();
is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0');
$schema_v2->deploy;
}
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v2->upgrade();
is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');
use Test::More;
use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
}
-use lib qw(t/lib);
-use DBICTest;
-
my $schema = DBICTest->init_schema();
my $artist_rs = $schema->resultset('Artist');
my $cd_rs = $schema->resultset('CD');
use Test::Exception;
use Scalar::Util ();
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all =>
unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::Schema;
-
# Test for SQLT-related leaks
{
my $s = DBICTest::Schema->clone;
use Test::Exception;
use Test::Warn;
+use Path::Class;
+
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
}
-use lib qw(t/lib);
-use DBICTest;
-
-use Path::Class;
-
use_ok 'DBIx::Class::Admin';
-
my $sql_dir = dir(qw/t var/);
my @connect_info = DBICTest->_database(
no_deploy=>1,
use Test::More;
use Test::Exception;
+use lib 't/lib';
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
}
-use lib 't/lib';
-use DBICTest;
-
use_ok 'DBIx::Class::Admin';
use warnings;
use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
eval "use DBIx::Class::CDBICompat; use DateTime 0.55; use Clone;";
plan skip_all => "Clone, DateTime 0.55, Class::Trigger and DBIx::ContextualFetch required"
plan tests => 6;
-use lib qw(t/lib);
-use DBICTest;
-
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
use strict;
use Test::More;
-
+use Class::Inspector ();
BEGIN {
eval "use DBIx::Class::CDBICompat;";
use Test::More;
+use lib 't/lib';
+use DBICTest;
+
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
next;
}
- plan tests => 10;
+ plan tests => 9;
}
-use lib 't/lib';
-
-use_ok('DBICTest');
-
DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
my $schema = DBICTest->init_schema(compose_connection => 1);
LIMIT 3 OFFSET 8
) tracks
)',
- [ [ position => 1 ], [ position => 2 ] ],
+ [
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 2 ],
+ ],
'count_rs db-side limit applied',
);
}
LIMIT 3 OFFSET 4
) cds
)',
- [ [ 'tracks.position' => 1 ], [ 'tracks.position' => 2 ] ],
+ [
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 2 ],
+ ],
'count_rs db-side limit applied',
);
}
HAVING newest_cd_year = ?
) me
)',
- [ [ 'newest_cd_year' => '2001' ],],
+ [ [ { dbic_colname => 'newest_cd_year' }
+ => '2001' ] ],
'count with having clause keeps sql as alias',
);
GROUP BY cds.cdid
) cds
)',
- [ map { [ 'tracks.position' => $_ ] } (1, 2) ],
+ [ map { [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' } => $_ ] } (1, 2) ],
);
}
)
genre
)',
- [ [ 'genre.name' => 'emo' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'genre.name' }
+ => 'emo' ]
+ ],
);
}
LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid
WHERE lyrics.lyric_id IS NULL AND (position = ? OR position = ?)
)',
- [ map { [ position => $_ ] } (1, 2) ],
+ [ map { [ { sqlt_datatype => 'int', dbic_colname => 'position' } => $_ ] } (1, 2) ],
);
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+
+use lib 't/lib';
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+$schema->_unregister_source('CD');
+
+warnings_like {
+ lives_ok {
+ $_->delete for $schema->resultset('Artist')->all;
+ } 'delete on rows with dangling rels lives';
+} [
+ # 12 == 3 artists * failed cascades:
+ # cds
+ # cds_unordered
+ # cds_very_very_very_long_relationship_name
+ (qr/skipping cascad/i) x 9
+], 'got warnings about cascading deletes';
+
+done_testing;
+
my $init_count = $artist_rs->count;
ok ($init_count, 'Some artists is database');
-$artist_rs->populate ([
- {
- name => 'foo',
- },
- {
- name => 'bar',
- }
-]);
-
-is ($artist_rs->count, $init_count + 2, '2 Artists created');
-
-$artist_rs->search ({
- -and => [
- { 'me.artistid' => { '!=', undef } },
+foreach my $delete_arg (
[ { 'me.name' => 'foo' }, { 'me.name' => 'bar' } ],
- ],
-})->delete;
-
-is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+ [ 'me.name' => 'foo', 'me.name' => 'bar' ],
+) {
+ $artist_rs->populate ([
+ {
+ name => 'foo',
+ },
+ {
+ name => 'bar',
+ }
+ ]);
+
+ is ($artist_rs->count, $init_count + 2, '2 Artists created');
+
+ $artist_rs->search ({
+ -and => [
+ { 'me.artistid' => { '!=', undef } },
+ $delete_arg,
+ ],
+ })->delete;
+
+ is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+}
done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan tests => 8;
-
-my $schema = DBICTest->init_schema();
-my $art_rs = $schema->resultset('Artist');
-my $cdrs = $schema->resultset('CD');
-
-{
- my $cdrs2 = $cdrs->search({
- artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
- });
-
- is_same_sql_bind(
- $cdrs2->as_query,
- "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT me.id FROM artist me LIMIT 1 ))",
- [],
- );
-}
-
-{
- my $rs = $art_rs->search(
- {},
- {
- 'select' => [
- $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT (SELECT me.id FROM cd me LIMIT 1) FROM artist me)",
- [],
- );
-}
-
-{
- my $rs = $art_rs->search(
- {},
- {
- '+select' => [
- $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT me.id FROM cd me LIMIT 1) FROM artist me)",
- [],
- );
-}
-
-# simple from
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( id > ? )
- ) cd2)",
- [
- [ 'id', 20 ]
- ],
- );
-}
-
-# nested from
-{
- my $art_rs2 = $schema->resultset('Artist')->search({},
- {
- from => [ { 'me' => 'artist' },
- [ { 'cds' => $cdrs->search({},{ 'select' => [\'me.artist as cds_artist' ]})->as_query },
- { 'me.artistid' => 'cds_artist' } ] ]
- });
-
- is_same_sql_bind(
- $art_rs2->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist)",
- []
- );
-
-
-}
-
-# nested subquery in from
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search(
- { id => { '>' => 20 } },
- {
- alias => 'cd3',
- from => [
- { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
- ],
- }, )->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
- FROM
- (SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
- FROM
- (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me WHERE ( id < ? ) ) cd3
- WHERE ( id > ? ) ) cd2)",
- [
- [ 'id', 40 ],
- [ 'id', 20 ]
- ],
- );
-
-}
-
-{
- my $rs = $cdrs->search({
- year => {
- '=' => $cdrs->search(
- { artistid => { '=' => \'me.artistid' } },
- { alias => 'inner' }
- )->get_column('year')->max_rs->as_query,
- },
- });
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid))",
- [],
- );
-}
-
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search({ title => 'Thriller' })->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( title = ? )
- ) cd2)",
- [ [ 'title', 'Thriller' ] ],
- );
-}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.\nWarning: this test drops and creates the table 'track'.
+EOF
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
+
+my @connect_info = (
+ [ $dsn, $user || '', $pass || '' ],
+ [ $dsn2, $user2 || '', $pass2 || '' ],
+);
+
+my $schema;
+
+for my $connect_info (@connect_info) {
+ my ($dsn, $user, $pass) = @$connect_info;
+
+ next unless $dsn;
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ on_connect_call => 'datetime_setup',
+ quote_names => 1,
+ });
+
+ my $guard = Scope::Guard->new(\&cleanup);
+
+ try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE track (
+ trackid AUTOINCREMENT PRIMARY KEY,
+ cd INT,
+ [position] INT,
+ last_updated_at DATETIME
+)
+SQL
+
+ ok(my $dt = DateTime->new({
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ second => 48,
+ }));
+
+ ok(my $row = $schema->resultset('Track')->create({
+ last_updated_at => $dt,
+ cd => 1
+ }));
+ ok($row = $schema->resultset('Track')
+ ->search({ trackid => $row->trackid }, { select => ['last_updated_at'] })
+ ->first
+ );
+ is($row->last_updated_at, $dt, "DATETIME roundtrip" );
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+ # have to reconnect to drop a table that's in use
+ if (my $storage = eval { $schema->storage }) {
+ local $^W = 0;
+ $storage->disconnect;
+ $storage->dbh->do('DROP TABLE track');
+ }
+}
}
}
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/};
+my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
-if (not ($dsn || $dsn2)) {
+if (not ($dsn || $dsn2 || $dsn3)) {
plan skip_all =>
- 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} _USER '
- .'and _PASS to run this test' .
- "\nWarning: This test drops and creates a table called 'small_dt'";
+ 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} and/or '
+ .'$ENV{DBICTEST_MSSQL_ADO_DSN} _USER and _PASS to run this test' .
+ "\nWarning: This test drops and creates tables called 'event_small_dt' and"
+ ." 'track'.";
}
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
my @connect_info = (
[ $dsn, $user, $pass ],
[ $dsn2, $user2, $pass2 ],
+ [ $dsn3, $user3, $pass3 ],
);
my $schema;
my $guard = Scope::Guard->new(\&cleanup);
- try { $schema->storage->dbh->do("DROP TABLE track") };
+ # $^W because DBD::ADO is a piece of crap
+ try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") };
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE track (
trackid INT IDENTITY PRIMARY KEY,
last_updated_at DATETIME,
)
SQL
- try { $schema->storage->dbh->do("DROP TABLE event_small_dt") };
+ try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") };
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE event_small_dt (
id INT IDENTITY PRIMARY KEY,
for my $dt_type (@dt_types) {
my ($type, $col, $source, $pk, $create_extra, $sample_dt) = @$dt_type;
+ delete $sample_dt->{nanosecond} if $dsn =~ /:ADO:/;
+
ok(my $dt = DateTime->new($sample_dt));
my $row;
use Test::More;
use lib qw(t/lib);
-# inject IC::File into the result baseclass for testing
-BEGIN {
- $ENV{DBIC_IC_FILE_NOWARN} = 1;
- require DBICTest::BaseResult;
- DBICTest::BaseResult->load_components (qw/InflateColumn::File/);
-}
-
use DBICTest;
+use DBICTest::Schema;
use File::Compare;
use Path::Class qw/file/;
+{
+ local $ENV{DBIC_IC_FILE_NOWARN} = 1;
+
+ package DBICTest::Schema::FileColumn;
+
+ use strict;
+ use warnings;
+ use base qw/DBICTest::BaseResult/;
+
+ use File::Temp qw/tempdir/;
+
+ __PACKAGE__->load_components (qw/InflateColumn::File/);
+ __PACKAGE__->table('file_columns');
+
+ __PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ file => {
+ data_type => 'varchar',
+ is_file_column => 1,
+ file_column_path => tempdir(CLEANUP => 1),
+ size => 255
+ }
+ );
+
+ __PACKAGE__->set_primary_key('id');
+}
+DBICTest::Schema->load_classes('FileColumn');
+
my $schema = DBICTest->init_schema;
plan tests => 10;
+if (not $ENV{DBICTEST_SQLT_DEPLOY}) {
+ $schema->storage->dbh->do(<<'EOF');
+ CREATE TABLE file_columns (
+ id INTEGER PRIMARY KEY,
+ file VARCHAR(255)
+ )
+EOF
+}
+
my $rs = $schema->resultset('FileColumn');
my $source_file = file(__FILE__);
my $fname = $source_file->basename;
for ($db_file, "${db_file}-journal") {
next unless -e $_;
unlink ($_) or carp (
- "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!\n"
+ "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
);
}
}
sub __mk_disconnect_guard {
- return if DBICTest::RunMode->peepeeness; # leaks handles, delaying DESTROY, can't work right
+ return if DBIx::Class::_ENV_::PEEPEENESS(); # leaks handles, delaying DESTROY, can't work right
my $db_file = shift;
return unless -f $db_file;
--- /dev/null
+package DBICTest::Cursor;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::Cursor/;
+
+1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::RunMode;
use strict;
use warnings;
+BEGIN {
+ if ($INC{'DBIx/Class.pm'}) {
+ my ($fr, @frame) = 1;
+ while (@frame = caller($fr++)) {
+ last if $frame[1] !~ m|^t/lib/DBICTest|;
+ }
+
+ die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n";
+ }
+}
+
use Path::Class qw/file dir/;
_check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION};
}
}
-sub peepeeness {
- return ! $ENV{DBICTEST_ALL_LEAKS} if defined $ENV{DBICTEST_ALL_LEAKS};
-
- # don't smoke perls with known issues:
- if (__PACKAGE__->is_smoker) {
- if ($] == '5.013006') {
- # leaky 5.13.6 (fixed in blead/cefd5c7c)
- return 1;
- }
- elsif ($] == '5.013005') {
- # not sure why this one leaks, but disable anyway - ANDK seems to make it weep
- return 1;
- }
- }
-
- return 0;
-}
-
# Mimic $Module::Install::AUTHOR
sub is_author {
BindType
Employee
CD
- FileColumn
Genre
Bookmark
Link
__PACKAGE__->has_many(
'mapped_artists', 'DBICTest::Schema::Artist',
[ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ],
+ { cascade_delete => 0 },
);
1;
data_type => 'clob',
is_nullable => 1,
},
+ 'a_memo' => {
+ data_type => 'memo',
+ is_nullable => 1,
+ },
);
__PACKAGE__->set_primary_key('id');
+++ /dev/null
-package
-DBICTest::Schema::FileColumn;
-
-use strict;
-use warnings;
-use base qw/DBICTest::BaseResult/;
-use File::Temp qw/tempdir/;
-
-__PACKAGE__->table('file_columns');
-
-__PACKAGE__->add_columns(
- id => { data_type => 'integer', is_auto_increment => 1 },
- file => {
- data_type => 'varchar',
- is_file_column => 1,
- file_column_path => tempdir(CLEANUP => 1),
- size => 255
- }
-);
-
-__PACKAGE__->set_primary_key('id');
-
-1;
'hello' => { data_type => 'integer' },
'goodbye' => { data_type => 'integer' },
'sensors' => { data_type => 'character', size => 10 },
- 'read_count' => { data_type => 'integer', is_nullable => 1 },
+ 'read_count' => { data_type => 'int', is_nullable => 1 },
);
__PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Thu Nov 18 08:18:15 2010
+-- Created on Tue Feb 22 18:42:16 2011
--
--
id INTEGER PRIMARY KEY NOT NULL,
bytea blob,
blob blob,
- clob clob
+ clob clob,
+ a_memo memo
);
--
);
--
--- Table: file_columns
---
-CREATE TABLE file_columns (
- id INTEGER PRIMARY KEY NOT NULL,
- file varchar(255) NOT NULL
-);
-
---
-- Table: fourkeys
--
CREATE TABLE fourkeys (
--- /dev/null
+--
+-- This table line should not be skipped
+--
+CREATE TABLE artist (
+ artistid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100),
+ rank integer NOT NULL DEFAULT 13,
+ charfield char(10)
+);
+
+CREATE INDEX artist_name_hookidx ON artist (name); -- This line should error if artist was not parsed correctly
'+columns' => { sibling_count => $cdrs->search(
{
'siblings.artist' => { -ident => 'me.artist' },
- 'siblings.cdid' => { '!=' => ['-and', { -ident => 'me.cdid' }, 'bogus condition'] },
+ 'siblings.cdid' => { '!=' => ['-and', { -ident => 'me.cdid' }, 23414] },
}, { alias => 'siblings' },
)->count_rs->as_query,
},
[
# subselect
- [ 'siblings.cdid' => 'bogus condition' ],
- [ 'me.artist' => 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
# outher WHERE
- [ 'me.artist' => 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
],
'Expected SQL on correlated realiased subquery'
);
# first add a lone non-as-ed select
# it should be reordered to appear at the end without throwing prefetch/bind off
-$c_rs = $c_rs->search({}, { '+select' => \[ 'me.cdid + ?', [ __add => 1 ] ] });
+$c_rs = $c_rs->search({}, { '+select' => \[ 'me.cdid + ?', [ \ 'inTEger' => 1 ] ] });
# now add an unbalanced select/as pair
$c_rs = $c_rs->search ({}, {
[
# first subselect
- [ 'siblings.cdid' => 'bogus condition' ],
- [ 'me.artist' => 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
# second subselect
- [ 'me.artist' => 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
# the addition
- [ __add => 1 ],
+ [ { sqlt_datatype => 'inTEger' }
+ => 1 ],
# outher WHERE
- [ 'me.artist' => 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
],
'Expected SQL on correlated realiased subquery'
);
JOIN track tracks ON tracks.cd = cds.cdid
WHERE ( me.artistid = ? )
)',
- [ [ 'me.artistid' => 4 ] ],
+ [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artistid' }
+ => 4 ] ],
);
)
me
)',
- [ map { [ 'me.cd' => $_] } ($cd_rs->get_column ('cdid')->all) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
'count() query generated expected SQL',
);
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
)',
- [ map { [ 'me.cd' => $_] } ( ($cd_rs->get_column ('cdid')->all) x 2 ) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ( ($cd_rs->get_column ('cdid')->all) x 2 ) ],
'next() query generated expected SQL',
);
)
me
)',
- [ map { [ 'me.cd' => $_] } ($cd_rs->get_column ('cdid')->all) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
'count() query generated expected SQL',
);
}
GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
artist.artistid, artist.name, artist.rank, artist.charfield
)',
- [ map { [ 'tracks.title' => 'ugabuganoexist' ] } (1 .. 2) ],
+ [ map { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' }
+ => 'ugabuganoexist' ] } (1,2)
+ ],
);
}
WHERE ( me.rank = ? )
ORDER BY me.name ASC, me.artistid DESC, tracks.cd
)},
- [ [ 'me.rank' => 13 ], [ 'me.rank' => 13 ] ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' }
+ => 13 ] } (1,2)
+ ],
'correct SQL on limited prefetch over search_related ordered by root',
);
cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
-$rs = $schema->resultset("Artist")->search(
- {},
- { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
-);
+$rs = $schema->resultset("Artist")->search({}, {
+ join => [qw/ cds /],
+ group_by => [qw/ me.name /],
+ having => \[ 'MAX(cds.cdid) < ?', [ \'int' => 5 ] ],
+});
cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
}
);
-# add a floating +select to make sure it does nto throw things off
+# add a floating +select to make sure it does not throw things off
# we also expect it to appear in both selectors, as we can not know
# for sure which part of the query it applies to (may be order_by,
# maybe something else)
# we use a reference to the same array in bind vals, because
# is_deeply picks up this difference too (not sure if bug or
# feature)
-my $bind_one = [ __add => 1 ];
$use_prefetch = $use_prefetch->search({}, {
- '+select' => \[ 'me.artistid + ?', $bind_one ],
+ '+select' => \[ 'me.artistid + ?', [ \ 'inTEger' => 1 ] ],
});
+my $bind_int_resolved = sub { [ { sqlt_datatype => 'inTEger' } => 1 ] };
+my $bind_vc_resolved = sub { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' }
+ => 'blah-blah-1234568'
+] };
is_same_sql_bind (
$use_prefetch->as_query,
'(
ORDER BY name DESC, cds.artist, cds.year ASC
)',
[
- $bind_one, # outer select
- $bind_one, # inner select
- [ 'tracks.title' => 'blah-blah-1234568' ], # inner where
- $bind_one, # inner group_by
- [ 'tracks.title' => 'blah-blah-1234568' ], # outer where
- $bind_one, # outer group_by
+ $bind_int_resolved->(), # outer select
+ $bind_int_resolved->(), # inner select
+ $bind_vc_resolved->(), # inner where
+ $bind_int_resolved->(), # inner group_by
+ $bind_vc_resolved->(), # outer where
+ $bind_int_resolved->(), # outer group_by
],
'Expected SQL on complex limited prefetch'
);
WHERE ( ( artist.name = ? AND me.year = ? ) )
ORDER BY tracks.cd
)',
- [
- [ 'artist.name' => 'foo' ],
- [ 'me.year' => 2010 ],
- [ 'artist.name' => 'foo' ],
- [ 'me.year' => 2010 ],
- ],
+ [ map {
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'artist.name' }
+ => 'foo' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 2010 ],
+ } (1,2)],
'No grouping of non-multiplying resultsets',
);
ON artist_undirected_maps.id1 = me.artistid OR artist_undirected_maps.id2 = me.artistid
WHERE ( artistid = ? )
)',
- [[artistid => 1]],
+ [[ { sqlt_datatype => 'integer', dbic_colname => 'artistid' }
+ => 1 ]],
'expected join sql produced',
);
WHERE ( ( me.artist = ? AND ( me.year < ? AND me.year > ? ) ) )
)',
[
- [ 'me.artist' => 21 ],
- [ 'me.year' => 1990 ],
- [ 'me.year' => 1979 ],
- ]
+ [
+ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 21
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1990
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1979
+ ],
+ ],
);
my @cds_80s = $cds_80s_rs->all;
is(@cds_80s, 6, '6 80s cds found (1980 - 1985)');
WHERE ( artist__row.artistid = ? )
)',
[
- [ 'me.year' => 2000 ],
- [ 'me.year' => 1989 ],
- [ 'artist__row.artistid' => 22 ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 2000
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1989
+ ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist__row.artistid' }
+ => 22
+ ],
]
);
my @cds_90s = $cds_90s_rs->all;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+#
+# The test must be performed on non-registered result classes
+#
+{
+ package DBICTest::Thing;
+ use warnings;
+ use strict;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table('thing');
+ __PACKAGE__->add_columns(qw/id ancestor_id/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->has_many(children => __PACKAGE__, 'id');
+ __PACKAGE__->belongs_to(parent => __PACKAGE__, 'id', { join_type => 'left' } );
+
+ __PACKAGE__->has_many(subthings => 'DBICTest::SubThing', 'thing_id');
+}
+
+{
+ package DBICTest::SubThing;
+ use warnings;
+ use strict;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table('subthing');
+ __PACKAGE__->add_columns(qw/thing_id/);
+ __PACKAGE__->belongs_to(thing => 'DBICTest::Thing', 'thing_id');
+ __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } );
+}
+
+my $schema = DBICTest->init_schema;
+
+for my $without_schema (1,0) {
+
+ my ($t, $s) = $without_schema
+ ? (qw/DBICTest::Thing DBICTest::SubThing/)
+ : do {
+ $schema->register_class(relinfo_thing => 'DBICTest::Thing');
+ $schema->register_class(relinfo_subthing => 'DBICTest::SubThing');
+
+ map { $schema->source ($_) } qw/relinfo_thing relinfo_subthing/;
+ }
+ ;
+
+ is_deeply(
+ [ sort $t->relationships ],
+ [qw/ children parent subthings/],
+ "Correct relationships on $t",
+ );
+
+ is_deeply(
+ [ sort $s->relationships ],
+ [qw/ thing thing2 /],
+ "Correct relationships on $s",
+ );
+
+ is_deeply(
+ _instance($s)->reverse_relationship_info('thing'),
+ { subthings => $t->relationship_info('subthings') },
+ 'reverse_rel_info works cross-class belongs_to direction',
+ );
+ is_deeply(
+ _instance($s)->reverse_relationship_info('thing2'),
+ { subthings => $t->relationship_info('subthings') },
+ 'reverse_rel_info works cross-class belongs_to direction 2',
+ );
+
+ is_deeply(
+ _instance($t)->reverse_relationship_info('subthings'),
+ { map { $_ => $s->relationship_info($_) } qw/thing thing2/ },
+ 'reverse_rel_info works cross-class has_many direction',
+ );
+
+ is_deeply(
+ _instance($t)->reverse_relationship_info('parent'),
+ { children => $t->relationship_info('children') },
+ 'reverse_rel_info works in-class belongs_to direction',
+ );
+ is_deeply(
+ _instance($t)->reverse_relationship_info('children'),
+ { parent => $t->relationship_info('parent') },
+ 'reverse_rel_info works in-class has_many direction',
+ );
+}
+
+sub _instance {
+ $_[0]->isa('DBIx::Class::ResultSource')
+ ? $_[0]
+ : $_[0]->result_source_instance
+}
+
+done_testing;
use Test::More;
-plan ( tests => 5 );
-
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
$art_rs = $art_rs->search({ name => 'Billy Joel' });
+my $name_resolved_bind = [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'name' }
+ => 'Billy Joel'
+];
+
{
is_same_sql_bind(
$art_rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( name = ? ))",
- [ [ name => 'Billy Joel' ] ],
+ [ $name_resolved_bind ],
);
}
$art_rs = $art_rs->search({ rank => 2 });
+my $rank_resolved_bind = [
+ { sqlt_datatype => 'integer', dbic_colname => 'rank' }
+ => 2
+];
+
{
is_same_sql_bind(
$art_rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ [ $rank_resolved_bind, $name_resolved_bind ],
);
}
is_same_sql_bind(
$rscol->as_query,
"(SELECT me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ [ $rank_resolved_bind, $name_resolved_bind ],
);
}
my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $rs->get_column('cdid')->as_query } } );
is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count');
}
+
+
+is_same_sql_bind($schema->resultset('Artist')->search({
+ rank => 1,
+}, {
+ from => $schema->resultset('Artist')->search({ 'name' => 'frew'})->as_query,
+})->as_query,
+ '(SELECT me.artistid, me.name, me.rank, me.charfield FROM (
+ SELECT me.artistid, me.name, me.rank, me.charfield FROM
+ artist me
+ WHERE (
+ ( name = ? )
+ )
+ ) WHERE (
+ ( rank = ? )
+ )
+ )',
+ [
+ [{ dbic_colname => 'name', sqlt_datatype => 'varchar', sqlt_size => 100 }, 'frew'],
+ [{ dbic_colname => 'rank' }, 1],
+ ],
+ 'from => ...->as_query works'
+);
+
+done_testing;
WHERE ( source = ? )
) me
)',
- [ [ source => 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
'Resultset-class attributes do not seep outside of the subselect',
);
$rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
- [ '!!dummy' => '1999' ],
- [ '!!dummy' => 'Spoon%' ]
+ [ {} => '1999' ],
+ [ {} => 'Spoon%' ]
],
'got correct SQL'
);
$rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
- [ '!!dummy' => '1999' ],
- [ '!!dummy' => 'Spoon%' ]
+ [ {} => '1999' ],
+ [ {} => 'Spoon%' ]
],
'got correct SQL (cookbook arbitrary SQL, in separate file)'
);
is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class');
ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded');
+
DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A');
-ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded automatically');
+
+ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET');
is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
+ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET');
my $schema = DBICTest->init_schema;
my $resultset = $schema->resultset('Artist')->search;
+use warnings;
+use strict;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
package My::Schema::Result::User;
use strict;
1;
package main;
-
-use lib qw(t/lib);
-use DBICTest;
-
-use Test::More;
-
my $user_data = {
email => 'someguy@place.com',
password => 'pass1',
use Test::Exception;
use lib qw(t/lib);
+use DBICTest;
use DBIC::SqlMakerTest;
use DBIC::DebugObj;
-use DBICTest;
# use Data::Dumper comparisons to avoid mesing with coderefs
use Data::Dumper;
my $schema = DBICTest->init_schema();
my $rs = $schema->resultset('CD')->search (
- { 'tracks.id' => { '!=', 666 }},
+ { 'tracks.trackid' => { '!=', 666 }},
{ join => 'artist', prefetch => 'tracks', rows => 2 }
);
FROM cd me
JOIN artist artist ON artist.artistid = me.artist
LEFT JOIN track tracks ON tracks.cd = me.cdid
- WHERE ( tracks.id != ? )
+ WHERE ( tracks.trackid != ? )
LIMIT 2
) me
JOIN artist artist ON artist.artistid = me.artist
GROUP BY tags.tagid, tags.cd, tags.tag
)',
- [ [ 'tracks.id' => 666 ] ],
+ [ [ { sqlt_datatype => 'integer', dbic_colname => 'tracks.trackid' }
+ => 666 ]
+ ],
'Prefetch spec successfully stripped on search_related'
);
attrs => { rows => 5 },
sqlbind => \[
"( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
- [ title => 'buahaha' ],
- [ year => '20%' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' }
+ => 'buahaha' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'year' }
+ => '20%' ],
],
},
{
rs => $cdrs,
search => {
- artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
+ artistid => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'artistid' )->as_query },
},
sqlbind => \[
- "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT me.id FROM artist me LIMIT 1 ) )",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artistid IN ( SELECT me.artistid FROM artist me LIMIT 1 ) )",
],
},
attrs => {
alias => 'cd2',
from => [
- { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
+ { cd2 => $cdrs->search({ artist => { '>' => 20 } })->as_query },
],
},
sqlbind => \[
"( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE id > ?
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist > ?
) cd2
)",
- [ 'id', 20 ]
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 20 ]
],
},
alias => 'cd2',
from => [
{ cd2 => $cdrs->search(
- { id => { '>' => 20 } },
+ { artist => { '>' => 20 } },
{
alias => 'cd3',
from => [
- { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
+ { cd3 => $cdrs->search( { artist => { '<' => 40 } } )->as_query }
],
}, )->as_query },
],
(SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
FROM
(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me WHERE id < ?) cd3
- WHERE id > ?) cd2
+ FROM cd me WHERE artist < ?) cd3
+ WHERE artist > ?) cd2
)",
- [ 'id', 40 ],
- [ 'id', 20 ]
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 40 ],
+ [ { dbic_colname => 'artist' } => 20 ], # no rsrc in outer manual from - hence no resolution
],
},
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE title = ?
) cd2
)",
- [ 'title',
- 'Thriller'
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' }
+ => 'Thriller'
]
],
},
my $schema = DBICTest->init_schema();
-my $ne_bind = [ _ne => 'bar' ];
my $rs = $schema->resultset('CD')->search({ -and => [
- 'me.artist' => { '!=', 'foo' },
- 'me.artist' => { '!=', \[ '?', $ne_bind ] },
+ 'me.artist' => { '!=', '666' },
+ 'me.artist' => { '!=', \[ '?', [ _ne => 'bar' ] ] },
]});
# bogus sql query to make sure bind composition happens properly
LIMIT 1 OFFSET 2
)',
[
- [ 'me.artist' => 'foo' ],
- $ne_bind,
- [ _add => 1 ],
- [ 'me.artist' => 'foo' ],
- $ne_bind,
- [ _sub => 2 ],
- [ _lt => 3 ],
- [ _mu => 4 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 666 ],
+ [ { dbic_colname => '_ne' } => 'bar' ],
+ [ { dbic_colname => '_add' } => 1 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 666 ],
+ [ { dbic_colname => '_ne' } => 'bar' ],
+ [ { dbic_colname => '_sub' } => 2 ],
+ [ { dbic_colname => '_lt' } => 3 ],
+ [ { dbic_colname => '_mu' } => 4 ],
],
'Correct crazy sql',
);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+# based on toplimit.t
+delete $schema->storage->_sql_maker->{_cached_syntax};
+$schema->storage->_sql_maker->limit_dialect ('FetchFirst');
+
+my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 2, offset => 3 });
+
+for my $null_order (
+ undef,
+ '',
+ {},
+ [],
+ [{}],
+) {
+ my $rs = $books_45_and_owners->search ({}, {order_by => $null_order });
+ is_same_sql_bind(
+ $rs->as_query,
+ '(SELECT id, source, owner, title, price, owner__id, owner__name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name AS owner__name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.id
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY me.id DESC
+ FETCH FIRST 2 ROWS ONLY
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+
+for my $ord_set (
+ {
+ order_by => \'foo DESC',
+ order_inner => 'foo DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'foo AS ORDER__BY__1',
+ },
+ {
+ order_by => { -asc => 'foo' },
+ order_inner => 'foo ASC',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1 ASC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'foo AS ORDER__BY__1',
+ },
+ {
+ order_by => { -desc => 'foo' },
+ order_inner => 'foo DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'foo AS ORDER__BY__1',
+ },
+ {
+ order_by => 'foo',
+ order_inner => 'foo',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'foo AS ORDER__BY__1',
+ },
+ {
+ order_by => [ qw{ foo me.owner} ],
+ order_inner => 'foo, me.owner',
+ order_outer => 'ORDER__BY__1 DESC, me.owner DESC',
+ order_req => 'ORDER__BY__1, me.owner',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'foo AS ORDER__BY__1',
+ },
+ {
+ order_by => ['foo', { -desc => 'bar' } ],
+ order_inner => 'foo, bar DESC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => { -asc => [qw{ foo bar }] },
+ order_inner => 'foo ASC, bar ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC',
+ order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => [
+ 'foo',
+ { -desc => [qw{bar}] },
+ { -asc => [qw{me.owner sensors}]},
+ ],
+ order_inner => 'foo, bar DESC, me.owner ASC, sensors ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3',
+ exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3',
+ },
+) {
+ my $o_sel = $ord_set->{exselect_outer}
+ ? ', ' . $ord_set->{exselect_outer}
+ : ''
+ ;
+ my $i_sel = $ord_set->{exselect_inner}
+ ? ', ' . $ord_set->{exselect_inner}
+ : ''
+ ;
+
+ is_same_sql_bind(
+ $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query,
+ "(SELECT id, source, owner, title, price, owner__id, owner__name
+ FROM (
+ SELECT id, source, owner, title, price, owner__id, owner__name$o_sel
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY $ord_set->{order_inner}
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY $ord_set->{order_outer}
+ FETCH FIRST 2 ROWS ONLY
+ ) me
+ ORDER BY $ord_set->{order_req}
+ FETCH FIRST 2 ROWS ONLY
+ )",
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+# with groupby
+is_same_sql_bind (
+ $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query,
+ '(SELECT me.id, me.source, me.owner, me.title, me.price, owner.id, owner.name
+ FROM (
+ SELECT id, source, owner, title, price
+ FROM (
+ SELECT id, source, owner, title, price
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ GROUP BY title
+ ORDER BY title
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY title DESC
+ FETCH FIRST 2 ROWS ONLY
+ ) me
+ ORDER BY title
+ FETCH FIRST 2 ROWS ONLY
+ ) me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY title
+ )',
+ [ map { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ]
+ } (1,2) ],
+);
+
+# test deprecated column mixing over join boundaries
+my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1
+});
+
+is_same_sql_bind( $rs_selectas_top->search({})->as_query,
+ '(SELECT
+ me.id, me.source, me.owner, me.title, me.price,
+ owner.name AS owner_name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.id
+ FETCH FIRST 1 ROWS ONLY
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'name',
+ offset => 1,
+ order_by => 'name',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+done_testing;
) < 2
ORDER BY me.title
)',
- [ [ 'source', 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
is_deeply (
) BETWEEN 1 AND 3
ORDER BY "title" DESC
)',
- [ [ 'source', 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
is_deeply (
) BETWEEN 1 AND 4294967295
ORDER BY "title"
)',
- [ [ 'source', 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
is_deeply (
) me
WHERE rno__row__index BETWEEN 1 AND 1
)',
- [ [ 'source', 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
$schema->storage->_sql_maker->quote_char ([qw/ [ ] /]);
) [me]
WHERE [rno__row__index] BETWEEN 1 AND 1
)',
- [ [ 'source', 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
{
) me
ORDER BY me.id DESC
)',
- [ [ source => 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
}
) me
ORDER BY $ord_set->{order_req}
)",
- [ [ source => 'Library' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
}
WHERE ( source = ? )
ORDER BY title
)',
- [ [ source => 'Library' ], [ source => 'Library' ] ],
+ [ map { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ]
+ } (1,2) ],
);
# test deprecated column mixing over join boundaries
JOIN owners owner ON owner.id = me.owner
WHERE ( source = ? )
ORDER BY me.id
- )',
- [ [ 'source', 'Library' ] ],
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
);
{
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema(no_populate => 1);
+my $ars = $schema->resultset('Artist');
+
+my $rank = \13;
+my $ref1 = \['?', [name => 'foo']];
+my $ref2 = \['?', [name => 'bar']];
+my $ref3 = \['?', [name => 'baz']];
+
+# do it twice, make sure the args are untouched
+for (1,2) {
+ $ars->delete;
+
+ lives_ok {
+ $ars->create({ artistid => 666, name => $ref1, rank => $rank });
+ } 'inserted row using literal sql';
+
+ ok (($ars->search({ name => 'foo' })->first),
+ 'row was inserted');
+
+ lives_ok {
+ $ars->search({ name => { '=' => $ref1} })->update({ name => $ref2, rank => $rank });
+ } 'search/updated row using literal sql';
+
+ ok (($ars->search({ name => 'bar' })->first),
+ 'row was updated');
+
+ lives_ok {
+ $ars->populate([{ artistid => 777, name => $ref3, rank => $rank }]);
+ } 'populated row using literal sql';
+
+ ok (($ars->search({ name => 'baz' })->first),
+ 'row was populated');
+}
+
+is_deeply(
+ $ref1,
+ \['?', [name => 'foo']],
+ 'ref1 unchanged',
+);
+is_deeply(
+ $ref2,
+ \['?', [name => 'bar']],
+ 'ref2 unchanged',
+);
+is_deeply(
+ $ref3,
+ \['?', [name => 'baz']],
+ 'ref3 unchanged',
+);
+
+done_testing;
+
+# vim:sts=2 sw=2:
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+use DBIx::Class::SQLMaker::ACCESS;
+
+my $sa = DBIx::Class::SQLMaker::ACCESS->new;
+
+# my ($self, $table, $fields, $where, $order, @rest) = @_;
+my ($sql, @bind) = $sa->select(
+ [
+ { me => "cd" },
+ [
+ { "-join_type" => "LEFT", artist => "artist" },
+ { "artist.artistid" => "me.artist" },
+ ],
+ ],
+ [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ undef,
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM (cd me LEFT JOIN artist artist ON artist.artistid = me.artist)', [],
+ 'one-step join parenthesized'
+);
+
+($sql, @bind) = $sa->select(
+ [
+ { me => "cd" },
+ [
+ { "-join_type" => "LEFT", track => "track" },
+ { "track.cd" => "me.cdid" },
+ ],
+ [
+ { "-join_type" => "LEFT", artist => "artist" },
+ { "artist.artistid" => "me.artist" },
+ ],
+ ],
+ [ 'track.title', 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ undef,
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT track.title, cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM ((cd me LEFT JOIN track track ON track.cd = me.cdid) LEFT JOIN artist artist ON artist.artistid = me.artist)', [],
+ 'two-step join parenthesized'
+);
+
+done_testing;
}
use lib qw(t/lib);
-use DBIx::Class::SQLMaker::OracleJoins;
use DBICTest;
+use DBIx::Class::SQLMaker::OracleJoins;
use DBIC::SqlMakerTest;
my $sa = DBIx::Class::SQLMaker::OracleJoins->new;
ORDER BY $args->{order_req}
)",
[
- [qw(foo bar)],
- [qw(read_count 5)],
- [qw(read_count 8)],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'foo' }
+ => 'bar' ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'read_count' }
+ => 5 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'read_count' }
+ => 8 ],
$args->{bind}
- ? @{ $args->{bind} }
+ ? map { [ { dbic_colname => $_->[0] } => $_->[1] ] } @{ $args->{bind} }
: ()
],
) || diag Dumper $args->{order_by};
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor');
+
+lives_ok {
+ is($schema->resultset("Artist")->search(), 3, "Three artists returned");
+} 'Custom cursor autoloaded';
+
+SKIP: {
+ eval { require Class::Unload }
+ or skip 'component_class reentrancy test requires Class::Unload', 1;
+
+ Class::Unload->unload('DBICTest::Cursor');
+
+ lives_ok {
+ is($schema->resultset("Artist")->search(), 3, "Three artists still returned");
+ } 'Custom cursor auto re-loaded';
+}
+
+done_testing;
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use File::Spec;
use Path::Class qw/dir/;
use File::Path qw/make_path remove_tree/;
+
+lives_ok( sub {
+ my $parse_schema = DBICTest->init_schema(no_deploy => 1);
+ $parse_schema->deploy({},'t/lib/test_deploy');
+ $parse_schema->resultset("Artist")->all();
+}, 'artist table deployed correctly' );
+
my $schema = DBICTest->init_schema();
my $var = dir (qw| t var create_ddl_dir |);
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
-my $sth_one = $schema->storage->sth('SELECT 42');
-my $sth_two = $schema->storage->sth('SELECT 42');
+my $sth_one = $schema->storage->_sth('SELECT 42');
+my $sth_two = $schema->storage->_sth('SELECT 42');
$schema->storage->disable_sth_caching(1);
-my $sth_three = $schema->storage->sth('SELECT 42');
+my $sth_three = $schema->storage->_sth('SELECT 42');
ok($sth_one == $sth_two, "statement caching works");
ok($sth_two != $sth_three, "disabling statement caching works");
# exception fallback:
SKIP: {
- if (DBICTest::RunMode->peepeeness) {
+ if (DBIx::Class::_ENV_::PEEPEENESS()) {
skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1;
}
sub _populate_dbh {
my $self = shift;
+
my $death = $self->_dbi_connect_info->[3]{die};
die "storage test died: $death" if $death eq 'before_populate';
}
for (qw/before_populate after_populate/) {
- dies_ok (sub {
+ throws_ok (sub {
my $schema = DBICTest::Schema->clone;
$schema->storage_type ('Dying::Storage');
$schema->connection (DBICTest->_database, { die => $_ });
$schema->storage->ensure_connected;
- }, "$_ exception found");
+ }, qr/$_/, "$_ exception found");
}
done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Data::Dumper::Concise;
+use lib qw(t/lib);
+use DBICTest;
+
+my %expected = (
+ 'DBIx::Class::Storage::DBI' =>
+ # no default quote_char
+ { name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::MSSQL' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::DB2' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Informix' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::InterBase' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::mysql' =>
+ { quote_char => '`', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Pg' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::ODBC::ACCESS' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+
+# Not testing this one, it's a pain.
+# 'DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL' =>
+# { quote_char => '"', name_sep => qr/must be connected/ },
+
+ 'DBIx::Class::Storage::DBI::Oracle::Generic' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::SQLAnywhere' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::SQLite' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Sybase::ASE' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+);
+
+for my $class (keys %expected) { SKIP: {
+ eval "require ${class}"
+ or skip "Skipping test of quotes for $class due to missing dependencies", 1;
+
+ my $mapping = $expected{$class};
+ my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/};
+ my $instance = $class->new;
+
+ my $quote_char_text = dumper($quote_char);
+
+ if (exists $mapping->{quote_char}) {
+ is_deeply $instance->sql_quote_char, $quote_char,
+ "sql_quote_char for $class is $quote_char_text";
+ }
+
+ is $instance->sql_name_sep, $name_sep,
+ "sql_name_sep for $class is '$name_sep'";
+}}
+
+# Try quote_names with available DBs.
+
+# SQLite first.
+
+my $schema = DBICTest->init_schema(quote_names => 1);
+
+is $schema->storage->sql_maker->quote_char, '"',
+ q{quote_names => 1 sets correct quote_char for SQLite ('"')};
+
+is $schema->storage->sql_maker->name_sep, '.',
+ q{quote_names => 1 sets correct name_sep for SQLite (".")};
+
+# Now the others.
+
+# Env var to base class mapping, these are the DBs I actually have.
+# -- Caelum
+my %dbs = (
+ ORA => 'DBIx::Class::Storage::DBI::Oracle::Generic',
+ PG => 'DBIx::Class::Storage::DBI::Pg',
+ MYSQL => 'DBIx::Class::Storage::DBI::mysql',
+ DB2 => 'DBIx::Class::Storage::DBI::DB2',
+ SYBASE => 'DBIx::Class::Storage::DBI::Sybase::ASE',
+ SQLANYWHERE => 'DBIx::Class::Storage::DBI::SQLAnywhere',
+ SQLANYWHERE_ODBC => 'DBIx::Class::Storage::DBI::SQLAnywhere',
+ FIREBIRD => 'DBIx::Class::Storage::DBI::InterBase',
+ FIREBIRD_ODBC => 'DBIx::Class::Storage::DBI::InterBase',
+ INFORMIX => 'DBIx::Class::Storage::DBI::Informix',
+ MSSQL_ODBC => 'DBIx::Class::Storage::DBI::MSSQL',
+);
+
+while (my ($db, $base_class) = each %dbs) {
+ my ($dsn, $user, $pass) = map $ENV{"DBICTEST_${db}_$_"}, qw/DSN USER PASS/;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ quote_names => 1
+ });
+
+ my $expected_quote_char = $expected{$base_class}{quote_char};
+ my $quote_char_text = dumper($expected_quote_char);
+
+ is_deeply $schema->storage->sql_maker->quote_char,
+ $expected_quote_char,
+ "$db quote_char with quote_names => 1 is $quote_char_text";
+
+ my $expected_name_sep = $expected{$base_class}{name_sep};
+
+ is $schema->storage->sql_maker->name_sep,
+ $expected_name_sep,
+ "$db name_sep with quote_names => 1 is '$expected_name_sep'";
+}
+
+done_testing;
+
+sub dumper {
+ my $val = shift;
+
+ my $dd = DumperObject;
+ $dd->Indent(0);
+ return $dd->Values([ $val ])->Dump;
+}
+
+1;
use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated')
unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated');
}
-use lib qw(t/lib);
-use DBICTest;
if (DBICTest::RunMode->is_smoker) {
my $mver = Moose->VERSION;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+{
+ package DBICTest::Legacy::Storage;
+ use base 'DBIx::Class::Storage::DBI::SQLite';
+
+ use Data::Dumper::Concise;
+
+ sub source_bind_attributes { return {} }
+}
+
+
+my $schema = DBICTest::Schema->clone;
+$schema->storage_type('DBICTest::Legacy::Storage');
+$schema->connection('dbi:SQLite::memory:');
+
+$schema->storage->dbh_do( sub { $_[1]->do(<<'EOS') } );
+CREATE TABLE artist (
+ artistid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100),
+ rank integer NOT NULL DEFAULT 13,
+ charfield char(10)
+)
+EOS
+
+my $legacy = sub { $schema->resultset('Artist')->search({ name => 'foo'})->next };
+if (DBIx::Class->VERSION >= 0.09) {
+ &throws_ok(
+ $legacy,
+ qr/XXXXXXXXX not sure what error to put here yet XXXXXXXXXXXXXXX/,
+ 'deprecated use of source_bind_attributes throws',
+ );
+}
+else {
+ &warnings_exist (
+ $legacy,
+ qr/\QThe source_bind_attributes() override in DBICTest::Legacy::Storage relies on a deprecated codepath/,
+ 'Warning issued during invocation of legacy storage codepath',
+ );
+}
+
+done_testing;
no strict 'refs';
no warnings 'redefine';
+
local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
throws_ok (sub {
my $guard = $schema->txn_scope_guard;
no strict 'refs';
no warnings 'redefine';
local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
=begin
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+
+my @defined = grep { $ENV{$_} } qw/
+ DATA_DUMPER_TEST
+ DBICTEST_STORAGE_STRESS
+ DBICTEST_FORK_STRESS
+ DBICTEST_THREAD_STRESS
+/;
+
+$SIG{ALRM} = sub { die "\n\nENVCHECK prompt timeout\n\n\n" };
+if (@defined) {
+ diag join "\n",
+ 'The following ENV variables used to control the test suite, '
+ .'but no longer do so, please remove them from your environment',
+ @defined,
+ '',
+ '(press Enter to continue)',
+ ;
+ alarm(10);
+ <>;
+ alarm(0);
+}
+ok(1);
+
+done_testing;
mk_classaccessor
/]
},
+ 'DBIx::Class::Carp' => {
+ ignore => [qw/
+ unimport
+ /]
+ },
'DBIx::Class::Row' => {
ignore => [qw/
MULTICREATE_DEBUG
'DBIx::Class::Admin::*' => { skip => 1 },
'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 },
'DBIx::Class::Componentised' => { skip => 1 },
+ 'DBIx::Class::AccessorGroup' => { skip => 1 },
'DBIx::Class::Relationship::*' => { skip => 1 },
'DBIx::Class::ResultSetProxy' => { skip => 1 },
'DBIx::Class::ResultSourceProxy' => { skip => 1 },
projects / dbsrgits/DBIx-Class.git / commitdiff