_build/
blib/
inc/
+lib/DBIx/Class/Optional/Dependencies.pod
pm_to_blib
t/var/
Revision history for DBIx::Class
+ - Add $rs->is_ordered to test for existing order_by on a resultset
+ - Add as_subselect_rs to DBIC::ResultSet from
+ DBIC::Helper::ResultSet::VirtualView::as_virtual_view
+ - Refactor dbicadmin adding DDL manipulation capabilities
+ - New optional dependency manager to aid extension writers
+ - Depend on newest bugfixed Moose
+ - Make resultset chaining consistent wrt selection specification
+ - Storage::DBI::Replicated cleanup
+ - Fix autoinc PKs without an autoinc flag on Sybase ASA
+
+0.08118 2010-02-08 11:53:00 (UTC)
+ - Fix a bug causing UTF8 columns not to be decoded (RT#54395)
+ - Fix bug in One->Many->One prefetch-collapse handling (RT#54039)
+ - Cleanup handling of relationship accessor types
+
+0.08117 2010-02-05 17:10:00 (UTC)
- Perl 5.8.1 is now the minimum supported version
- Massive optimization of the join resolution code - now joins
will be removed from the resulting SQL if DBIC can prove they
are not referenced by anything
- Subqueries no longer marked experimental
- Support for Informix RDBMS (limit/offset and auto-inc columns)
+ - Support for Sybase SQLAnywhere, both native and via ODBC
- might_have/has_one now warn if applied calling class's column
has is_nullable set to true.
- Fixed regression in deploy() with a {sources} table limit applied
parsed by SQL::Translator::Parser::DBIx::Class
- Stop the SQLT parser from auto-adding indexes identical to the
Primary Key
+ - InflateColumn::DateTime refactoring to allow fine grained method
+ overloads
- Fix ResultSetColumn improperly selecting more than the requested
column when +columns/+select is present
+ - Fix failure when update/delete of resultsets with complex WHERE
+ SQLA structures
- Fix regression in context sensitiveness of deployment_statements
- Fix regression resulting in overcomplicated query on
search_related from prefetching resultsets
-use inc::Module::Install 0.89;
+use inc::Module::Install 0.93;
use strict;
use warnings;
use POSIX ();
use 5.008001;
-# ****** DO NOT ADD OPTIONAL DEPENDENCIES. EVER. --mst ******
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+###
+### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends()
+### All of them should go to DBIx::Class::Optional::Dependencies
+###
+
name 'DBIx-Class';
perl_version '5.008001';
all_from 'lib/DBIx/Class.pm';
+my $build_requires = {
+ 'DBD::SQLite' => '1.25',
+};
+
+my $test_requires = {
+ 'File::Temp' => '0.22',
+ 'Test::Builder' => '0.33',
+ 'Test::Deep' => '0',
+ 'Test::Exception' => '0',
+ 'Test::More' => '0.92',
+ 'Test::Warn' => '0.21',
+};
+
+my $runtime_requires = {
+ # Core
+ 'List::Util' => '0',
+ 'Scalar::Util' => '0',
+ 'Storable' => '0',
+
+ # Dependencies
+ 'Carp::Clan' => '6.0',
+ 'Class::Accessor::Grouped' => '0.09002',
+ 'Class::C3::Componentised' => '1.0005',
+ 'Class::Inspector' => '1.24',
+ 'Data::Page' => '2.00',
+ 'DBI' => '1.609',
+ 'MRO::Compat' => '0.09',
+ 'Module::Find' => '0.06',
+ 'Path::Class' => '0.18',
+ 'Scope::Guard' => '0.03',
+ 'SQL::Abstract' => '1.61',
+ 'SQL::Abstract::Limit' => '0.13',
+ 'Sub::Name' => '0.04',
+ 'Data::Dumper::Concise' => '1.000',
+};
+
+# this is so we can order requires alphabetically
+# copies are needed for author requires injection
+my $reqs = {
+ build_requires => { %$build_requires },
+ requires => { %$runtime_requires },
+ test_requires => { %$test_requires },
+};
+
+# re-build README and require extra modules for testing if we're in a checkout
+if ($Module::Install::AUTHOR) {
+
+ print "Regenerating README\n";
+ system('pod2text lib/DBIx/Class.pm > README');
+
+ if (-f 'MANIFEST') {
+ print "Removing MANIFEST\n";
+ unlink 'MANIFEST';
+ }
+
+ print "Regenerating Optional/Dependencies.pod\n";
+ require DBIx::Class::Optional::Dependencies;
+ DBIx::Class::Optional::Dependencies->_gen_pod;
+
+# FIXME Disabled due to unsolved issues, ask theorbtwo
+# require Module::Install::Pod::Inherit;
+# PodInherit();
+
+ warn <<'EOW';
+******************************************************************************
+******************************************************************************
+*** ***
+*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
+*** ***
+******************************************************************************
+******************************************************************************
+
+EOW
+
+ $reqs->{test_requires} = {
+ %{$reqs->{test_requires}},
+ %{DBIx::Class::Optional::Dependencies->_all_optional_requirements},
+ };
+}
+
+# compose final req list, for alphabetical ordering
+my %final_req;
+for my $rtype (keys %$reqs) {
+ for my $mod (keys %{$reqs->{$rtype}} ) {
+
+ # sanity check req duplications
+ if ($final_req{$mod}) {
+ die "$mod specified as both a '$rtype' and a '$final_req{$mod}[0]'\n";
+ }
-test_requires 'Test::Builder' => '0.33';
-test_requires 'Test::Deep' => '0';
-test_requires 'Test::Exception' => '0';
-test_requires 'Test::More' => '0.92';
-test_requires 'Test::Warn' => '0.21';
-
-test_requires 'File::Temp' => '0.22';
-
-
-# Core
-requires 'List::Util' => '0';
-requires 'Scalar::Util' => '0';
-requires 'Storable' => '0';
-
-# Dependencies (keep in alphabetical order)
-requires 'Carp::Clan' => '6.0';
-requires 'Class::Accessor::Grouped' => '0.09002';
-requires 'Class::C3::Componentised' => '1.0005';
-requires 'Class::Inspector' => '1.24';
-requires 'Data::Page' => '2.00';
-requires 'DBD::SQLite' => '1.25';
-requires 'DBI' => '1.609';
-requires 'JSON::Any' => '1.18';
-requires 'MRO::Compat' => '0.09';
-requires 'Module::Find' => '0.06';
-requires 'Path::Class' => '0.16';
-requires 'Scope::Guard' => '0.03';
-requires 'SQL::Abstract' => '1.60';
-requires 'SQL::Abstract::Limit' => '0.13';
-requires 'Sub::Name' => '0.04';
-requires 'Data::Dumper::Concise' => '1.000';
-
-my %replication_requires = (
- 'Moose', => '0.90',
- 'MooseX::Types', => '0.21',
- 'namespace::clean' => '0.11',
- 'Hash::Merge', => '0.11',
-);
-
-#************************************************************************#
-# Make *ABSOLUTELY SURE* that nothing on this list is a real require, #
-# since every module listed in %force_requires_if_author is deleted #
-# from the final META.yml (thus will never make it as a CPAN dependency) #
-#************************************************************************#
-my %force_requires_if_author = (
- %replication_requires,
-
- # when changing also adjust $DBIx::Class::Storage::DBI::minimum_sqlt_version
- 'SQL::Translator' => '0.11002',
-
-# 'Module::Install::Pod::Inherit' => '0.01',
-
- # when changing also adjust version in t/02pod.t
- 'Test::Pod' => '1.26',
-
- # when changing also adjust version in t/06notabs.t
-# 'Test::NoTabs' => '0.9',
-
- # when changing also adjust version in t/07eol.t
-# 'Test::EOL' => '0.6',
-
- # when changing also adjust version in t/03podcoverage.t
- 'Test::Pod::Coverage' => '1.08',
- 'Pod::Coverage' => '0.20',
-
- # CDBI-compat related
- 'DBIx::ContextualFetch' => '0',
- 'Class::DBI::Plugin::DeepAbstractSearch' => '0',
- 'Class::Trigger' => '0',
- 'Time::Piece::MySQL' => '0',
- 'Clone' => '0',
- 'Date::Simple' => '3.03',
-
- # t/52cycle.t
- 'Test::Memory::Cycle' => '0',
- 'Devel::Cycle' => '1.10',
-
- # t/36datetime.t
- # t/60core.t
- 'DateTime::Format::SQLite' => '0',
-
- # t/96_is_deteministic_value.t
- 'DateTime::Format::Strptime'=> '0',
-
- # database-dependent reqs
- #
- $ENV{DBICTEST_PG_DSN}
- ? (
- 'Sys::SigAction' => '0',
- 'DBD::Pg' => '2.009002',
- 'DateTime::Format::Pg' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_MYSQL_DSN}
- ? (
- 'DateTime::Format::MySQL' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_ORA_DSN}
- ? (
- 'DateTime::Format::Oracle' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_SYBASE_DSN}
- ? (
- 'DateTime::Format::Sybase' => 0,
- ) : ()
- ,
-);
-#************************************************************************#
-# Make ABSOLUTELY SURE that nothing on the list above is a real require, #
-# since every module listed in %force_requires_if_author is deleted #
-# from the final META.yml (thus will never make it as a CPAN dependency) #
-#************************************************************************#
+ $final_req{$mod} = [ $rtype, $reqs->{$rtype}{$mod}||0 ],
+ }
+}
+# actual require
+for my $mod (sort keys %final_req) {
+ my ($rtype, $ver) = @{$final_req{$mod}};
+ no strict 'refs';
+ $rtype->($mod, $ver);
+}
install_script (qw|
script/dbicadmin
DBIx::Class::SQLAHacks DBIx::Class::Storage::DBIHacks
/);
-# re-build README and require extra modules for testing if we're in a checkout
-
-if ($Module::Install::AUTHOR) {
- warn <<'EOW';
-******************************************************************************
-******************************************************************************
-*** ***
-*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
-*** ***
-******************************************************************************
-******************************************************************************
-
-EOW
-
- foreach my $module (sort keys %force_requires_if_author) {
- build_requires ($module => $force_requires_if_author{$module});
- }
-
- print "Regenerating README\n";
- system('pod2text lib/DBIx/Class.pm > README');
-
- if (-f 'MANIFEST') {
- print "Removing MANIFEST\n";
- unlink 'MANIFEST';
- }
-
-# require Module::Install::Pod::Inherit;
-# PodInherit();
-}
auto_install();
WriteAll();
+
# Re-write META.yml to _exclude_ all forced requires (we do not want to ship this)
if ($Module::Install::AUTHOR) {
+ # FIXME test_requires is not yet part of META
+ my %original_build_requires = ( %$build_requires, %$test_requires );
+
+ print "Regenerating META with author requires excluded\n";
Meta->{values}{build_requires} = [ grep
- { not exists $force_requires_if_author{$_->[0]} }
- ( @{Meta->{values}{build_requires}} )
+ { exists $original_build_requires{$_->[0]} }
+ ( @{Meta->{values}{build_requires}} )
];
Meta->write;
use MRO::Compat;
use mro 'c3';
+use DBIx::Class::Optional::Dependencies;
+
use vars qw($VERSION);
use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
use DBIx::Class::StartupCheck;
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08115';
+$VERSION = '0.08118_01';
$VERSION = eval $VERSION; # numify for warning-free dev releases
bluefeet: Aran Deltac <bluefeet@cpan.org>
+boghead: Bryan Beeley <cpan@beeley.org>
+
bricas: Brian Cassidy <bricas@cpan.org>
brunov: Bruno Vecchi <vecchi.b@gmail.com>
debolaz: Anders Nor Berle <berle@cpan.org>
+dew: Dan Thomas <dan@godders.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
dnm: Justin Wheeler <jwheeler@datademons.com>
frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
+goraxe: Gordon Irving <goraxe@cpan.org>
+
gphat: Cory G Watson <gphat@cpan.org>
groditi: Guillermo Roditi <groditi@cpan.org>
--- /dev/null
+package DBIx::Class::Admin;
+
+# 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') )
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
+}
+
+use Moose;
+use MooseX::Types::Moose qw/Int Str Any Bool/;
+use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
+use MooseX::Types::JSON qw(JSON);
+use MooseX::Types::Path::Class qw(Dir File);
+use Try::Tiny;
+use JSON::Any qw(DWIW XS JSON);
+use namespace::autoclean;
+
+=head1 NAME
+
+DBIx::Class::Admin - Administration object for schemas
+
+=head1 SYNOPSIS
+
+ $ dbicadmin --help
+
+ $ dbicadmin --schema=MyApp::Schema \
+ --connect='["dbi:SQLite:my.db", "", ""]' \
+ --deploy
+
+ $ dbicadmin --schema=MyApp::Schema --class=Employee \
+ --connect='["dbi:SQLite:my.db", "", ""]' \
+ --op=update --set='{ "name": "New_Employee" }'
+
+ use DBIx::Class::Admin;
+
+ # ddl manipulation
+ my $admin = DBIx::Class::Admin->new(
+ schema_class=> 'MY::Schema',
+ sql_dir=> $sql_dir,
+ connect_info => { dsn => $dsn, user => $user, password => $pass },
+ );
+
+ # create SQLite sql
+ $admin->create('SQLite');
+
+ # create SQL diff for an upgrade
+ $admin->create('SQLite', {} , "1.0");
+
+ # upgrade a database
+ $admin->upgrade();
+
+ # install a version for an unversioned schema
+ $admin->install("3.0");
+
+=head1 REQUIREMENTS
+
+The Admin interface has additional requirements not currently part of
+L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
+
+=head1 ATTRIBUTES
+
+=head2 schema_class
+
+the class of the schema to load
+
+=cut
+
+has 'schema_class' => (
+ is => 'ro',
+ isa => Str,
+);
+
+
+=head2 schema
+
+A pre-connected schema object can be provided for manipulation
+
+=cut
+
+has 'schema' => (
+ is => 'ro',
+ isa => 'DBIx::Class::Schema',
+ lazy_build => 1,
+);
+
+sub _build_schema {
+ my ($self) = @_;
+ require Class::MOP;
+ Class::MOP::load_class($self->schema_class);
+
+ $self->connect_info->[3]->{ignore_version} =1;
+ return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
+}
+
+
+=head2 resultset
+
+a resultset from the schema to operate on
+
+=cut
+
+has 'resultset' => (
+ is => 'rw',
+ isa => Str,
+);
+
+
+=head2 where
+
+a hash ref or json string to be used for identifying data to manipulate
+
+=cut
+
+has 'where' => (
+ is => 'rw',
+ isa => DBICHashRef,
+ coerce => 1,
+);
+
+
+=head2 set
+
+a hash ref or json string to be used for inserting or updating data
+
+=cut
+
+has 'set' => (
+ is => 'rw',
+ isa => DBICHashRef,
+ coerce => 1,
+);
+
+
+=head2 attrs
+
+a hash ref or json string to be used for passing additonal info to the ->search call
+
+=cut
+
+has 'attrs' => (
+ is => 'rw',
+ isa => DBICHashRef,
+ coerce => 1,
+);
+
+
+=head2 connect_info
+
+connect_info the arguments to provide to the connect call of the schema_class
+
+=cut
+
+has 'connect_info' => (
+ is => 'ro',
+ isa => DBICConnectInfo,
+ lazy_build => 1,
+ coerce => 1,
+);
+
+sub _build_connect_info {
+ my ($self) = @_;
+ return $self->_find_stanza($self->config, $self->config_stanza);
+}
+
+
+=head2 config_file
+
+config_file provide a config_file to read connect_info from, if this is provided
+config_stanze should also be provided to locate where the connect_info is in the config
+The config file should be in a format readable by Config::General
+
+=cut
+
+has config_file => (
+ is => 'ro',
+ isa => File,
+ coerce => 1,
+);
+
+
+=head2 config_stanza
+
+config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
+designed for use with catalyst config files
+
+=cut
+
+has 'config_stanza' => (
+ is => 'ro',
+ isa => Str,
+);
+
+
+=head2 config
+
+Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
+config_stanza will still be required.
+
+=cut
+
+has config => (
+ is => 'ro',
+ isa => DBICHashRef,
+ lazy_build => 1,
+);
+
+sub _build_config {
+ my ($self) = @_;
+
+ eval { require Config::Any }
+ or die ("Config::Any is required to parse the config file.\n");
+
+ my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
+
+ # just grab the config from the config file
+ $cfg = $cfg->{$self->config_file};
+ return $cfg;
+}
+
+
+=head2 sql_dir
+
+The location where sql ddl files should be created or found for an upgrade.
+
+=cut
+
+has 'sql_dir' => (
+ is => 'ro',
+ isa => Dir,
+ coerce => 1,
+);
+
+
+=head2 version
+
+Used for install, the version which will be 'installed' in the schema
+
+=cut
+
+has version => (
+ is => 'rw',
+ isa => Str,
+);
+
+
+=head2 preversion
+
+Previouse version of the schema to create an upgrade diff for, the full sql for that version of the sql must be in the sql_dir
+
+=cut
+
+has preversion => (
+ is => 'rw',
+ isa => Str,
+);
+
+
+=head2 force
+
+Try and force certain operations.
+
+=cut
+
+has force => (
+ is => 'rw',
+ isa => Bool,
+);
+
+
+=head2 quiet
+
+Be less verbose about actions
+
+=cut
+
+has quiet => (
+ is => 'rw',
+ isa => Bool,
+);
+
+has '_confirm' => (
+ is => 'bare',
+ isa => Bool,
+);
+
+
+=head1 METHODS
+
+=head2 create
+
+=over 4
+
+=item Arguments: $sqlt_type, \%sqlt_args, $preversion
+
+=back
+
+L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
+generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
+
+Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
+
+Optional preversion can be supplied to generate a diff to be used by upgrade.
+
+=cut
+
+sub create {
+ my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
+
+ $preversion ||= $self->preversion();
+
+ my $schema = $self->schema();
+ # create the dir if does not exist
+ $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
+
+ $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
+}
+
+
+=head2 upgrade
+
+=over 4
+
+=item Arguments: <none>
+
+=back
+
+upgrade will attempt to upgrade the connected database to the same version as the schema_class.
+B<MAKE SURE YOU BACKUP YOUR DB FIRST>
+
+=cut
+
+sub upgrade {
+ my ($self) = @_;
+ my $schema = $self->schema();
+ if (!$schema->get_db_version()) {
+ # schema is unversioned
+ $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
+ } else {
+ my $ret = $schema->upgrade();
+ return $ret;
+ }
+}
+
+
+=head2 install
+
+=over 4
+
+=item Arguments: $version
+
+=back
+
+install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
+database. install will take a version and add the version tracking tables and 'install' the version. No
+further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
+already versioned databases.
+
+=cut
+
+sub install {
+ my ($self, $version) = @_;
+
+ my $schema = $self->schema();
+ $version ||= $self->version();
+ if (!$schema->get_db_version() ) {
+ # schema is unversioned
+ print "Going to install schema version\n";
+ my $ret = $schema->install($version);
+ print "retun is $ret\n";
+ }
+ elsif ($schema->get_db_version() and $self->force ) {
+ carp "Forcing install may not be a good idea";
+ if($self->_confirm() ) {
+ $self->schema->_set_db_version({ version => $version});
+ }
+ }
+ else {
+ $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
+ }
+
+}
+
+
+=head2 deploy
+
+=over 4
+
+=item Arguments: $args
+
+=back
+
+deploy will create the schema at the connected database. C<$args> are passed straight to
+L<DBIx::Class::Schema/deploy>.
+
+=cut
+
+sub deploy {
+ my ($self, $args) = @_;
+ my $schema = $self->schema();
+ if (!$schema->get_db_version() ) {
+ # schema is unversioned
+ $schema->deploy( $args, $self->sql_dir)
+ or $schema->throw_exception ("Could not deploy schema.\n"); # FIXME deploy() does not return 1/0 on success/fail
+ } else {
+ $schema->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
+ }
+}
+
+=head2 insert
+
+=over 4
+
+=item Arguments: $rs, $set
+
+=back
+
+insert takes the name of a resultset from the schema_class and a hashref of data to insert
+into that resultset
+
+=cut
+
+sub insert {
+ my ($self, $rs, $set) = @_;
+
+ $rs ||= $self->resultset();
+ $set ||= $self->set();
+ my $resultset = $self->schema->resultset($rs);
+ my $obj = $resultset->create( $set );
+ print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
+}
+
+
+=head2 update
+
+=over 4
+
+=item Arguments: $rs, $set, $where
+
+=back
+
+update takes the name of a resultset from the schema_class, a hashref of data to update and
+a where hash used to form the search for the rows to update.
+
+=cut
+
+sub update {
+ my ($self, $rs, $set, $where) = @_;
+
+ $rs ||= $self->resultset();
+ $where ||= $self->where();
+ $set ||= $self->set();
+ my $resultset = $self->schema->resultset($rs);
+ $resultset = $resultset->search( ($where||{}) );
+
+ my $count = $resultset->count();
+ print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
+
+ if ( $self->force || $self->_confirm() ) {
+ $resultset->update_all( $set );
+ }
+}
+
+
+=head2 delete
+
+=over 4
+
+=item Arguments: $rs, $where, $attrs
+
+=back
+
+delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
+The found data is deleted and cannot be recovered.
+
+=cut
+
+sub delete {
+ my ($self, $rs, $where, $attrs) = @_;
+
+ $rs ||= $self->resultset();
+ $where ||= $self->where();
+ $attrs ||= $self->attrs();
+ my $resultset = $self->schema->resultset($rs);
+ $resultset = $resultset->search( ($where||{}), ($attrs||()) );
+
+ my $count = $resultset->count();
+ print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
+
+ if ( $self->force || $self->_confirm() ) {
+ $resultset->delete_all();
+ }
+}
+
+
+=head2 select
+
+=over 4
+
+=item Arguments: $rs, $where, $attrs
+
+=back
+
+select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
+The found data is returned in a array ref where the first row will be the columns list.
+
+=cut
+
+sub select {
+ my ($self, $rs, $where, $attrs) = @_;
+
+ $rs ||= $self->resultset();
+ $where ||= $self->where();
+ $attrs ||= $self->attrs();
+ my $resultset = $self->schema->resultset($rs);
+ $resultset = $resultset->search( ($where||{}), ($attrs||()) );
+
+ my @data;
+ my @columns = $resultset->result_source->columns();
+ push @data, [@columns];#
+
+ while (my $row = $resultset->next()) {
+ my @fields;
+ foreach my $column (@columns) {
+ push( @fields, $row->get_column($column) );
+ }
+ push @data, [@fields];
+ }
+
+ return \@data;
+}
+
+sub _confirm {
+ my ($self) = @_;
+ print "Are you sure you want to do this? (type YES to confirm) \n";
+ # mainly here for testing
+ return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
+ my $response = <STDIN>;
+ return 1 if ($response=~/^YES/);
+ return;
+}
+
+sub _find_stanza {
+ my ($self, $cfg, $stanza) = @_;
+ my @path = split /::/, $stanza;
+ while (my $path = shift @path) {
+ if (exists $cfg->{$path}) {
+ $cfg = $cfg->{$path};
+ }
+ else {
+ die ("Could not find $stanza in config, $path does not seem to exist.\n");
+ }
+ }
+ return $cfg;
+}
+
+=head1 AUTHOR
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself
+
+=cut
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::Admin::Types;
+
+use MooseX::Types -declare => [qw(
+ DBICConnectInfo
+ DBICArrayRef
+ DBICHashRef
+)];
+use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any Bool/;
+use MooseX::Types::JSON qw(JSON);
+
+subtype DBICArrayRef,
+ as ArrayRef;
+
+subtype DBICHashRef,
+ as HashRef;
+
+coerce DBICArrayRef,
+ from JSON,
+ via { _json_to_data ($_) };
+
+coerce DBICHashRef,
+ from JSON,
+ via { _json_to_data($_) };
+
+subtype DBICConnectInfo,
+ as ArrayRef;
+
+coerce DBICConnectInfo,
+ from JSON,
+ via { return _json_to_data($_) } ;
+
+coerce DBICConnectInfo,
+ from Str,
+ via { return _json_to_data($_) };
+
+coerce DBICConnectInfo,
+ from HashRef,
+ via { [ $_ ] };
+
+sub _json_to_data {
+ my ($json_str) = @_;
+ my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
+ my $ret = $json->jsonToObj($json_str);
+ return $ret;
+}
+
+1;
$self->throw_exception("inflate_column needs attr hashref")
unless ref $attrs eq 'HASH';
$self->column_info($col)->{_inflate_info} = $attrs;
- $self->mk_group_accessors('inflated_column' => [$self->column_info($col)->{accessor} || $col, $col]);
+ my $acc = $self->column_info($col)->{accessor};
+ $self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]);
return 1;
}
}
}
- my $timezone;
if ( defined $info->{extra}{timezone} ) {
carp "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
"please put it directly into the '$column' column definition.";
- $timezone = $info->{extra}{timezone};
+ $info->{timezone} = $info->{extra}{timezone} unless defined $info->{timezone};
}
- my $locale;
if ( defined $info->{extra}{locale} ) {
carp "Putting locale into extra => { locale => '...' } has been deprecated, ".
"please put it directly into the '$column' column definition.";
- $locale = $info->{extra}{locale};
+ $info->{locale} = $info->{extra}{locale} unless defined $info->{locale};
}
- $locale = $info->{locale} if defined $info->{locale};
- $timezone = $info->{timezone} if defined $info->{timezone};
-
my $undef_if_invalid = $info->{datetime_undef_if_invalid};
if ($type eq 'datetime' || $type eq 'date' || $type eq 'timestamp') {
$self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $err");
}
- $dt->set_time_zone($timezone) if $timezone;
- $dt->set_locale($locale) if $locale;
- return $dt;
+ return $obj->_post_inflate_datetime( $dt, \%info );
},
deflate => sub {
my ($value, $obj) = @_;
- if ($timezone) {
- carp "You're using a floating timezone, please see the documentation of"
- . " DBIx::Class::InflateColumn::DateTime for an explanation"
- if ref( $value->time_zone ) eq 'DateTime::TimeZone::Floating'
- and not $info{floating_tz_ok}
- and not $ENV{DBIC_FLOATING_TZ_OK};
- $value->set_time_zone($timezone);
- $value->set_locale($locale) if $locale;
- }
+
+ $value = $obj->_pre_deflate_datetime( $value, \%info );
$obj->_deflate_from_datetime( $value, \%info );
},
}
shift->result_source->storage->datetime_parser (@_);
}
+sub _post_inflate_datetime {
+ my( $self, $dt, $info ) = @_;
+
+ $dt->set_time_zone($info->{timezone}) if defined $info->{timezone};
+ $dt->set_locale($info->{locale}) if defined $info->{locale};
+
+ return $dt;
+}
+
+sub _pre_deflate_datetime {
+ my( $self, $dt, $info ) = @_;
+
+ if (defined $info->{timezone}) {
+ carp "You're using a floating timezone, please see the documentation of"
+ . " DBIx::Class::InflateColumn::DateTime for an explanation"
+ if ref( $dt->time_zone ) eq 'DateTime::TimeZone::Floating'
+ and not $info->{floating_tz_ok}
+ and not $ENV{DBIC_FLOATING_TZ_OK};
+
+ $dt->set_time_zone($info->{timezone});
+ }
+
+ $dt->set_locale($info->{locale}) if defined $info->{locale};
+
+ return $dt;
+}
+
1;
__END__
second one will use a default port of 5433, while L<DBD::Pg> is compiled with a
default port of 5432.
-You can chance the port setting in C<postgresql.conf>.
+You can change the port setting in C<postgresql.conf>.
=item I've lost or forgotten my mysql password
--- /dev/null
+package DBIx::Class::Optional::Dependencies;
+
+use warnings;
+use strict;
+
+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
+
+# POD is generated automatically by calling _gen_pod from the
+# Makefile.PL in $AUTHOR mode
+
+my $moose_basic = {
+ 'Moose' => '0.98',
+ 'MooseX::Types' => '0.21',
+};
+
+my $admin_basic = {
+ %$moose_basic,
+ 'MooseX::Types::Path::Class' => '0.05',
+ 'MooseX::Types::JSON' => '0.02',
+ 'JSON::Any' => '1.22',
+ 'namespace::autoclean' => '0.09',
+};
+
+my $reqs = {
+ dist => {
+ #'Module::Install::Pod::Inherit' => '0.01',
+ },
+
+ replicated => {
+ req => {
+ %$moose_basic,
+ 'namespace::clean' => '0.11',
+ 'Hash::Merge' => '0.11',
+ },
+ pod => {
+ title => 'Storage::Replicated',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI::Replicated>',
+ },
+ },
+
+ admin => {
+ req => {
+ %$admin_basic,
+ },
+ pod => {
+ title => 'DBIx::Class::Admin',
+ desc => 'Modules required for the DBIx::Class administrative library',
+ },
+ },
+
+ admin_script => {
+ req => {
+ %$moose_basic,
+ %$admin_basic,
+ 'Getopt::Long::Descriptive' => '0.081',
+ 'Text::CSV' => '1.16',
+ },
+ pod => {
+ title => 'dbicadmin',
+ desc => 'Modules required for the CLI DBIx::Class interface dbicadmin',
+ },
+ },
+
+ deploy => {
+ req => {
+ 'SQL::Translator' => '0.11002',
+ },
+ pod => {
+ title => 'Storage::DBI::deploy()',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI/deploy> and L<DBIx::Class::Storage::DBI/deploymen_statements>',
+ },
+ },
+
+ author => {
+ req => {
+ 'Test::Pod' => '1.26',
+ 'Test::Pod::Coverage' => '1.08',
+ 'Pod::Coverage' => '0.20',
+ #'Test::NoTabs' => '0.9',
+ #'Test::EOL' => '0.6',
+ },
+ },
+
+ core => {
+ req => {
+ # t/52cycle.t
+ 'Test::Memory::Cycle' => '0',
+ 'Devel::Cycle' => '1.10',
+
+ # t/36datetime.t
+ # t/60core.t
+ 'DateTime::Format::SQLite' => '0',
+
+ # t/96_is_deteministic_value.t
+ 'DateTime::Format::Strptime'=> '0',
+ },
+ },
+
+ cdbicompat => {
+ req => {
+ 'DBIx::ContextualFetch' => '0',
+ 'Class::DBI::Plugin::DeepAbstractSearch' => '0',
+ 'Class::Trigger' => '0',
+ 'Time::Piece::MySQL' => '0',
+ 'Clone' => '0',
+ 'Date::Simple' => '3.03',
+ },
+ },
+
+ rdbms_pg => {
+ req => {
+ $ENV{DBICTEST_PG_DSN}
+ ? (
+ 'Sys::SigAction' => '0',
+ 'DBD::Pg' => '2.009002',
+ 'DateTime::Format::Pg' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_mysql => {
+ req => {
+ $ENV{DBICTEST_MYSQL_DSN}
+ ? (
+ 'DateTime::Format::MySQL' => '0',
+ 'DBD::mysql' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_oracle => {
+ req => {
+ $ENV{DBICTEST_ORA_DSN}
+ ? (
+ 'DateTime::Format::Oracle' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_ase => {
+ req => {
+ $ENV{DBICTEST_SYBASE_DSN}
+ ? (
+ 'DateTime::Format::Sybase' => 0,
+ ) : ()
+ },
+ },
+
+ rdbms_asa => {
+ req => {
+ grep $_, @ENV{qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/}
+ ? (
+ 'DateTime::Format::Strptime' => 0,
+ ) : ()
+ },
+ },
+};
+
+
+sub _all_optional_requirements {
+ return { map { %{ $reqs->{$_}{req} || {} } } (keys %$reqs) };
+}
+
+sub req_list_for {
+ my ($class, $group) = @_;
+
+ croak "req_list_for() expects a requirement group name"
+ unless $group;
+
+ my $deps = $reqs->{$group}{req}
+ or croak "Requirement group '$group' does not exist";
+
+ return { %$deps };
+}
+
+
+our %req_availability_cache;
+sub req_ok_for {
+ my ($class, $group) = @_;
+
+ croak "req_ok_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{status};
+}
+
+sub req_missing_for {
+ my ($class, $group) = @_;
+
+ croak "req_missing_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{missing};
+}
+
+sub req_errorlist_for {
+ my ($class, $group) = @_;
+
+ croak "req_errorlist_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{errorlist};
+}
+
+sub _check_deps {
+ my ($class, $group) = @_;
+
+ my $deps = $class->req_list_for ($group);
+
+ my %errors;
+ for my $mod (keys %$deps) {
+ if (my $ver = $deps->{$mod}) {
+ eval "use $mod $ver ()";
+ }
+ else {
+ eval "require $mod";
+ }
+
+ $errors{$mod} = $@ if $@;
+ }
+
+ if (keys %errors) {
+ my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
+ $missing .= " (see $class for details)" if $reqs->{$group}{pod};
+ $req_availability_cache{$group} = {
+ status => 0,
+ errorlist => { %errors },
+ missing => $missing,
+ };
+ }
+ else {
+ $req_availability_cache{$group} = {
+ status => 1,
+ errorlist => {},
+ missing => '',
+ };
+ }
+}
+
+sub _gen_pod {
+ my $class = shift;
+ my $modfn = __PACKAGE__ . '.pm';
+ $modfn =~ s/\:\:/\//g;
+
+ my @chunks = (
+ <<"EOC",
+#########################################################################
+##################### A U T O G E N E R A T E D ########################
+#########################################################################
+#
+# The contents of this POD file are auto-generated. Any changes you make
+# will be lost. If you need to change the generated text edit _gen_pod()
+# at the end of $modfn
+#
+EOC
+ '=head1 NAME',
+ "$class - Optional module dependency specifications",
+ '=head1 DESCRIPTION',
+ <<'EOD',
+Some of the less-frequently used features of L<DBIx::Class> have external
+module dependencies on their own. In order not to burden the average user
+with modules he will never use, these optional dependencies are not included
+in the base Makefile.PL. Instead an exception with a descriptive message is
+thrown when a specific feature is missing one or several modules required for
+its operation. This module is the central holding place for the current list
+of such dependencies.
+EOD
+ '=head1 CURRENT REQUIREMENT GROUPS',
+ <<'EOD',
+Dependencies are organized in C<groups> and each group can list one or more
+required modules, with an optional minimum version (or 0 for any version).
+The group name can be used in the
+EOD
+ );
+
+ for my $group (sort keys %$reqs) {
+ my $p = $reqs->{$group}{pod}
+ or next;
+
+ my $modlist = $reqs->{$group}{req}
+ or next;
+
+ next unless keys %$modlist;
+
+ push @chunks, (
+ "=head2 $p->{title}",
+ "$p->{desc}",
+ '=over',
+ ( map { "=item * $_" . ($modlist->{$_} ? " >= $modlist->{$_}" : '') } (sort keys %$modlist) ),
+ '=back',
+ "Requirement group: B<$group>",
+ );
+ }
+
+ push @chunks, (
+ '=head1 METHODS',
+ '=head2 req_list_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: \%list_of_module_version_pairs',
+ '=back',
+ <<EOD,
+This method should be used by DBIx::Class extension authors, to determine the
+version of modules which a specific feature requires in the current version of
+DBIx::Class. For example if you write a module/extension that requires
+DBIx::Class and also requires the availability of
+L<DBIx::Class::Storage::DBI/deploy>, you can do the following in your
+C<Makefile.PL> or C<Build.PL>
+
+ require $class;
+ my \$dep_list = $class->req_list_for ('deploy');
+
+Which will give you a list of module/version pairs necessary for the particular
+feature to function with this version of DBIx::Class.
+EOD
+
+ '=head2 req_ok_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: 1|0',
+ '=back',
+ 'Returns true or false depending on whether all modules required by C<$group_name> are present on the system and loadable',
+
+ '=head2 req_missing_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: $error_message_string',
+ '=back',
+ <<EOD,
+Returns a single line string suitable for inclusion in larger error messages.
+This method would normally be used by DBIx::Class core-module author, to
+indicate to the user that he needs to install specific modules before he will
+be able to use a specific feature.
+
+For example if the requirements for C<replicated> are not available, the
+returned string would look like:
+
+ Moose >= 0.98, MooseX::Types >= 0.21, namespace::clean (see $class for details)
+
+The author is expected to prepend the necessary text to this message before
+returning the actual error seen by the user.
+EOD
+
+ '=head2 req_errorlist_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: \%list_of_loaderrors_per_module',
+ '=back',
+ <<'EOD',
+Returns a hashref containing the actual errors that occured while attempting
+to load each module in the requirement group.
+EOD
+ '=head1 AUTHOR',
+ 'See L<DBIx::Class/CONTRIBUTORS>.',
+ '=head1 LICENSE',
+ 'You may distribute this code under the same terms as Perl itself',
+ );
+
+ my $fn = __FILE__;
+ $fn =~ s/\.pm$/\.pod/;
+
+ open (my $fh, '>', $fn) or croak "Unable to write to $fn: $!";
+ print $fh join ("\n\n", @chunks);
+ close ($fh);
+}
+
+1;
__PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
+=head3 condition
+
The condition needs to be an L<SQL::Abstract>-style representation of the
join between the tables. When resolving the condition for use in a C<JOIN>,
keys using the pseudo-table C<foreign> are resolved to mean "the Table on the
To add an C<OR>ed condition, use an arrayref of hashrefs. See the
L<SQL::Abstract> documentation for more details.
-In addition to the
-L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES>,
-the following attributes are also valid:
+=head3 attributes
+
+The L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES> may
+be used as relationship attributes. In particular, the 'where' attribute is
+useful for filtering relationships:
+
+ __PACKAGE__->has_many( 'valid_users', 'MyApp::Schema::User',
+ { 'foreign.user_id' => 'self.user_id' },
+ { where => { valid => 1 } }
+ );
+
+The following attributes are also valid:
=over 4
if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
my $reverse = $source->reverse_relationship_info($rel);
foreach my $rev_rel (keys %$reverse) {
- if ($reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
$attrs->{related_objects}{$rev_rel} = [ $self ];
Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
} else {
my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
foreach my $rel (@cascade) {
next if (
+ $rels{$rel}{attrs}{accessor}
+ &&
$rels{$rel}{attrs}{accessor} eq 'single'
- && !exists($self->{_relationship_data}{$rel})
+ &&
+ !exists($self->{_relationship_data}{$rel})
);
$_->update for grep defined, $self->$rel;
}
$rows = $self->get_cache;
}
+ # reset the selector list
+ if (List::Util::first { exists $attrs->{$_} } qw{columns select as}) {
+ delete @{$our_attrs}{qw{select as columns +select +as +columns include_columns}};
+ }
+
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
- foreach my $key (qw/join prefetch +select +as bind/) {
+ foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) {
next unless exists $attrs->{$key};
$new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
}
return !!$self->{attrs}{page};
}
+=head2 is_ordered
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: true, if the resultset has been ordered with C<order_by>.
+
+=back
+
+=cut
+
+sub is_ordered {
+ my ($self) = @_;
+ return scalar $self->result_source->storage->_parse_order_by($self->{attrs}{order_by});
+}
+
=head2 related_resultset
=over 4
->relname_to_table_alias($rel, $join_count);
# since this is search_related, and we already slid the select window inwards
- # (the select/as attrs were deleted in the beginning), we need to flip all
+ # (the select/as attrs were deleted in the beginning), we need to flip all
# left joins to inner, so we get the expected results
# read the comment on top of the actual function to see what this does
$attrs->{from} = $rsrc->schema->storage->_straight_join_to_node ($attrs->{from}, $alias);
return ($self->{attrs} || {})->{alias} || 'me';
}
+=head2 as_subselect_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+Act as a barrier to SQL symbols. The resultset provided will be made into a
+"virtual view" by including it as a subquery within the from clause. From this
+point on, any joined tables are inaccessible to ->search on the resultset (as if
+it were simply where-filtered without joins). For example:
+
+ my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' });
+
+ # 'x' now pollutes the query namespace
+
+ # So the following works as expected
+ my $ok_rs = $rs->search({'x.other' => 1});
+
+ # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and
+ # def) we look for one row with contradictory terms and join in another table
+ # (aliased 'x_2') which we never use
+ my $broken_rs = $rs->search({'x.name' => 'def'});
+
+ my $rs2 = $rs->as_subselect_rs;
+
+ # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away
+ my $not_joined_rs = $rs2->search({'x.other' => 1});
+
+ # works as expected: finds a 'table' row related to two x rows (abc and def)
+ my $correctly_joined_rs = $rs2->search({'x.name' => 'def'});
+
+Another example of when one might use this would be to select a subset of
+columns in a group by clause:
+
+ my $rs = $schema->resultset('Bar')->search(undef, {
+ group_by => [qw{ id foo_id baz_id }],
+ })->as_subselect_rs->search(undef, {
+ columns => [qw{ id foo_id }]
+ });
+
+In the above example normally columns would have to be equal to the group by,
+but because we isolated the group by into a subselect the above works.
+
+=cut
+
+sub as_subselect_rs {
+ my $self = shift;
+
+ return $self->result_source->resultset->search( undef, {
+ alias => $self->current_source_alias,
+ from => [{
+ $self->current_source_alias => $self->as_query,
+ -alias => $self->current_source_alias,
+ -source_handle => $self->result_source->handle,
+ }]
+ });
+}
+
# This code is called by search_related, and makes sure there
# is clear separation between the joins before, during, and
# after the relationship. This information is needed later
# build columns (as long as select isn't set) into a set of as/select hashes
unless ( $attrs->{select} ) {
- my @cols = ( ref($attrs->{columns}) eq 'ARRAY' )
- ? @{ delete $attrs->{columns}}
- : (
- ( delete $attrs->{columns} )
- ||
- $source->columns
- )
- ;
+ my @cols;
+ if ( ref $attrs->{columns} eq 'ARRAY' ) {
+ @cols = @{ delete $attrs->{columns}}
+ } elsif ( defined $attrs->{columns} ) {
+ @cols = delete $attrs->{columns}
+ } else {
+ @cols = $source->columns
+ }
- @colbits = map {
- ( ref($_) eq 'HASH' )
- ? $_
- : {
- (
- /^\Q${alias}.\E(.+)$/
- ? "$1"
- : "$_"
- )
- =>
- (
- /\./
- ? "$_"
- : "${alias}.$_"
- )
- }
- } @cols;
+ for (@cols) {
+ if ( ref $_ eq 'HASH' ) {
+ push @colbits, $_
+ } else {
+ my $key = /^\Q${alias}.\E(.+)$/
+ ? "$1"
+ : "$_";
+ my $value = /\./
+ ? "$_"
+ : "${alias}.$_";
+ push @colbits, { $key => $value };
+ }
+ }
}
# add the additional columns on
- foreach ( 'include_columns', '+columns' ) {
- push @colbits, map {
- ( ref($_) eq 'HASH' )
- ? $_
- : { ( split( /\./, $_ ) )[-1] => ( /\./ ? $_ : "${alias}.$_" ) }
- } ( ref($attrs->{$_}) eq 'ARRAY' ) ? @{ delete $attrs->{$_} } : delete $attrs->{$_} if ( $attrs->{$_} );
+ foreach (qw{include_columns +columns}) {
+ if ( $attrs->{$_} ) {
+ my @list = ( ref($attrs->{$_}) eq 'ARRAY' )
+ ? @{ delete $attrs->{$_} }
+ : delete $attrs->{$_};
+ for (@list) {
+ if ( ref($_) eq 'HASH' ) {
+ push @colbits, $_
+ } else {
+ my $key = ( split /\./, $_ )[-1];
+ my $value = ( /\./ ? $_ : "$alias.$_" );
+ push @colbits, { $key => $value };
+ }
+ }
+ }
}
# start with initial select items
( ref $attrs->{select} eq 'ARRAY' )
? [ @{ $attrs->{select} } ]
: [ $attrs->{select} ];
- $attrs->{as} = (
- $attrs->{as}
- ? (
- ref $attrs->{as} eq 'ARRAY'
- ? [ @{ $attrs->{as} } ]
- : [ $attrs->{as} ]
+
+ if ( $attrs->{as} ) {
+ $attrs->{as} =
+ (
+ ref $attrs->{as} eq 'ARRAY'
+ ? [ @{ $attrs->{as} } ]
+ : [ $attrs->{as} ]
)
- : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{ $attrs->{select} } ]
- );
+ } else {
+ $attrs->{as} = [ map {
+ m/^\Q${alias}.\E(.+)$/
+ ? $1
+ : $_
+ } @{ $attrs->{select} }
+ ]
+ }
}
else {
}
# now add colbits to select/as
- push( @{ $attrs->{select} }, map { values( %{$_} ) } @colbits );
- push( @{ $attrs->{as} }, map { keys( %{$_} ) } @colbits );
+ push @{ $attrs->{select} }, map values %{$_}, @colbits;
+ push @{ $attrs->{as} }, map keys %{$_}, @colbits;
- my $adds;
- if ( $adds = delete $attrs->{'+select'} ) {
+ if ( my $adds = delete $attrs->{'+select'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(
- @{ $attrs->{select} },
- map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds
- );
+ push @{ $attrs->{select} },
+ map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds;
}
- if ( $adds = delete $attrs->{'+as'} ) {
+ if ( my $adds = delete $attrs->{'+as'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push( @{ $attrs->{as} }, @$adds );
+ push @{ $attrs->{as} }, @$adds;
}
- $attrs->{from} ||= [ {
+ $attrs->{from} ||= [{
-source_handle => $source->handle,
-alias => $self->{attrs}{alias},
$self->{attrs}{alias} => $source->from,
- } ];
+ }];
if ( $attrs->{join} || $attrs->{prefetch} ) {
$join,
$alias,
{ %{ $attrs->{seen_join} || {} } },
- ($attrs->{seen_join} && keys %{$attrs->{seen_join}})
+ ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
? $attrs->{from}[-1][0]{-join_path}
: []
,
my %already_grouped = map { $_ => 1 } (@{$attrs->{group_by}});
my $storage = $self->result_source->schema->storage;
- my $sql_maker = $storage->sql_maker;
- local $sql_maker->{quote_char}; #disable quoting
my $rs_column_list = $storage->_resolve_column_info ($attrs->{from});
- my @chunks = $sql_maker->_order_by_chunks ($attrs->{order_by});
- for my $chunk (map { ref $_ ? @$_ : $_ } (@chunks) ) {
- $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ for my $chunk ($storage->_parse_order_by($attrs->{order_by})) {
if ($rs_column_list->{$chunk} && not $already_grouped{$chunk}++) {
push @{$attrs->{group_by}}, $chunk;
}
$rs->throw_exception('column must be supplied') unless $column;
my $orig_attrs = $rs->_resolved_attrs;
- my $new_parent_rs = $rs->search_rs;
- my $new_attrs = $new_parent_rs->{attrs} ||= {};
-
- # since what we do is actually chain to the original resultset, we need to throw
- # away all selectors (otherwise they'll chain)
- delete $new_attrs->{$_} for (qw/columns +columns select +select as +as cols include_columns/);
-
- # prefetch causes additional columns to be fetched, but we can not just make a new
- # rs via the _resolved_attrs trick - we need to retain the separation between
- # +select/+as and select/as. At the same time we want to preserve any joins that the
- # prefetch would otherwise generate.
- $new_attrs->{join} = $rs->_merge_attr( delete $new_attrs->{join}, delete $new_attrs->{prefetch} );
# If $column can be found in the 'as' list of the parent resultset, use the
# corresponding element of its 'select' list (to keep any custom column
my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list;
my $select = defined $as_index ? $select_list->[$as_index] : $column;
+ my $new_parent_rs;
+ # analyze the order_by, and see if it is done over a function/nonexistentcolumn
+ # if this is the case we will need to wrap a subquery since the result of RSC
+ # *must* be a single column select
+ my %collist = map { $_ => 1 } ($rs->result_source->columns, $column);
+ if (
+ scalar grep
+ { ! $collist{$_} }
+ ( $rs->result_source->schema->storage->_parse_order_by ($orig_attrs->{order_by} ) )
+ ) {
+ my $alias = $rs->current_source_alias;
+ # nuke the prefetch before collapsing to sql
+ my $subq_rs = $rs->search;
+ $subq_rs->{attrs}{join} = $subq_rs->_merge_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} );
+
+ $new_parent_rs = $rs->result_source->resultset->search ( {}, {
+ alias => $alias,
+ from => [{
+ $alias => $subq_rs->as_query,
+ -alias => $alias,
+ -source_handle => $rs->result_source->handle,
+ }]
+ });
+ }
+
+ $new_parent_rs ||= $rs->search_rs;
+ my $new_attrs = $new_parent_rs->{attrs} ||= {};
+
+ # prefetch causes additional columns to be fetched, but we can not just make a new
+ # rs via the _resolved_attrs trick - we need to retain the separation between
+ # +select/+as and select/as. At the same time we want to preserve any joins that the
+ # prefetch would otherwise generate.
+ $new_attrs->{join} = $rs->_merge_attr( $new_attrs->{join}, delete $new_attrs->{prefetch} );
+
# {collapse} would mean a has_many join was injected, which in turn means
# we need to group *IF WE CAN* (only if the column in question is unique)
if (!$new_attrs->{group_by} && keys %{$orig_attrs->{collapse}}) {
return $found;
}
-sub resolve_join {
- carp 'resolve_join is a private method, stop calling it';
- my $self = shift;
- $self->_resolve_join (@_);
-}
-
# Returns the {from} structure used to express JOIN conditions
sub _resolve_join {
my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
: $rel_info->{attrs}{join_type}
,
-join_path => [@$jpath, { $join => $as } ],
- -is_single => (List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) ),
+ -is_single => (
+ $rel_info->{attrs}{accessor}
+ &&
+ List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
+ ),
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
},
}
}
-# Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
-sub resolve_prefetch {
- carp 'resolve_prefetch is a private method, stop calling it';
-
- my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
- $seen ||= {};
- if( ref $pre eq 'ARRAY' ) {
- return
- map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
- @$pre;
- }
- elsif( ref $pre eq 'HASH' ) {
- my @ret =
- map {
- $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
- $self->related_source($_)->resolve_prefetch(
- $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
- } keys %$pre;
- return @ret;
- }
- elsif( ref $pre ) {
- $self->throw_exception(
- "don't know how to resolve prefetch reftype ".ref($pre));
- }
- else {
- my $count = ++$seen->{$pre};
- my $as = ($count > 1 ? "${pre}_${count}" : $pre);
- my $rel_info = $self->relationship_info( $pre );
- $self->throw_exception( $self->name . " has no such relationship '$pre'" )
- unless $rel_info;
- my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
- my $rel_source = $self->related_source($pre);
-
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
- $self->throw_exception(
- "Can't prefetch has_many ${pre} (join cond too complex)")
- unless ref($rel_info->{cond}) eq 'HASH';
- my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
- if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
- keys %{$collapse}) {
- my ($last) = ($fail =~ /([^\.]+)$/);
- carp (
- "Prefetching multiple has_many rels ${last} and ${pre} "
- .(length($as_prefix)
- ? "at the same level (${as_prefix}) "
- : "at top level "
- )
- . 'will explode the number of row objects retrievable via ->next or ->all. '
- . 'Use at your own risk.'
- );
- }
- #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
- # values %{$rel_info->{cond}};
- $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
- # action at a distance. prepending the '.' allows simpler code
- # in ResultSet->_collapse_result
- my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
- keys %{$rel_info->{cond}};
- my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
- ? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
- ? ($rel_info->{attrs}{order_by})
- : ()));
- push(@$order, map { "${as}.$_" } (@key, @ord));
- }
-
- return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
- $rel_source->columns;
- }
-}
# Accepts one or more relationships for the current source and returns an
# array of column names for each of those relationships. Column names are
my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
my $rel_source = $self->related_source($pre);
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
+ if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
$self->throw_exception(
"Can't prefetch has_many ${pre} (join cond too complex)")
unless ref($rel_info->{cond}) eq 'HASH';
keys %{$rel_info->{cond}};
my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
+
+ : (defined $rel_info->{attrs}{order_by}
? ($rel_info->{attrs}{order_by})
: ()));
push(@$order, map { "${as}.$_" } (@key, @ord));
$new->throw_exception("Can't do multi-create without result source")
unless $source;
my $info = $source->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
+ my $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type eq 'single') {
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
$related->{$key} = $rel_obj;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi'
- && ref $attrs->{$key} eq 'ARRAY') {
+ }
+ elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) {
my $others = delete $attrs->{$key};
my $total = @$others;
my @objects;
}
$related->{$key} = \@objects;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'filter')
- {
+ }
+ elsif ($acc_type eq 'filter') {
## 'filter' should disappear and get merged in with 'single' above!
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
for my $col (keys %loaded_colinfo) {
if (exists $loaded_colinfo{$col}{accessor}) {
my $acc = $loaded_colinfo{$col}{accessor};
- if (defined $acc) {
- $inflated{$col} = $self->$acc;
- }
+ $inflated{$col} = $self->$acc if defined $acc;
}
else {
$inflated{$col} = $self->$col;
foreach my $key (keys %$upd) {
if (ref $upd->{$key}) {
my $info = $self->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
+ my $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type eq 'single') {
my $rel = delete $upd->{$key};
$self->set_from_related($key => $rel);
$self->{_relationship_data}{$key} = $rel;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi') {
- $self->throw_exception(
- "Recursive update is not supported over relationships of type multi ($key)"
- );
}
- elsif ($self->has_column($key)
- && exists $self->column_info($key)->{_inflate_info})
- {
+ elsif ($acc_type eq 'multi') {
+ $self->throw_exception(
+ "Recursive update is not supported over relationships of type '$acc_type' ($key)"
+ );
+ }
+ elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
$self->set_inflated_column($key, delete $upd->{$key});
}
}
my ($source_handle) = $source;
if ($source->isa('DBIx::Class::ResultSourceHandle')) {
- $source = $source_handle->resolve
- } else {
- $source_handle = $source->handle
+ $source = $source_handle->resolve
+ }
+ else {
+ $source_handle = $source->handle
}
my $new = {
};
bless $new, (ref $class || $class);
- my $schema;
foreach my $pre (keys %{$prefetch||{}}) {
- my $pre_val = $prefetch->{$pre};
- my $pre_source = $source->related_source($pre);
- $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
- unless $pre_source;
- if (ref($pre_val->[0]) eq 'ARRAY') { # multi
- my @pre_objects;
- for my $me_pref (@$pre_val) {
+ my $pre_source = $source->related_source($pre)
+ or $class->throw_exception("Can't prefetch non-existent relationship ${pre}");
+
+ my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
+ or $class->throw_exception("No accessor for prefetched $pre");
+
+ my @pre_vals;
+ if (ref $prefetch->{$pre}[0] eq 'ARRAY') {
+ @pre_vals = @{$prefetch->{$pre}};
+ }
+ elsif ($accessor eq 'multi') {
+ $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor 'multi'");
+ }
+ else {
+ @pre_vals = $prefetch->{$pre};
+ }
+
+ my @pre_objects;
+ for my $me_pref (@pre_vals) {
+ # FIXME - this should not be necessary
# the collapser currently *could* return bogus elements with all
# columns set to undef
my $has_def;
push @pre_objects, $pre_source->result_class->inflate_result(
$pre_source, @$me_pref
);
- }
+ }
- $new->related_resultset($pre)->set_cache(\@pre_objects);
- } elsif (defined $pre_val->[0]) {
- my $fetched;
- unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
- and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
- {
- $fetched = $pre_source->result_class->inflate_result(
- $pre_source, @{$pre_val});
- }
- my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
- $class->throw_exception("No accessor for prefetched $pre")
- unless defined $accessor;
- if ($accessor eq 'single') {
- $new->{_relationship_data}{$pre} = $fetched;
- } elsif ($accessor eq 'filter') {
- $new->{_inflated_column}{$pre} = $fetched;
- } else {
- $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor '$accessor'");
- }
- $new->related_resultset($pre)->set_cache([ $fetched ]);
+ if ($accessor eq 'single') {
+ $new->{_relationship_data}{$pre} = $pre_objects[0];
}
+ elsif ($accessor eq 'filter') {
+ $new->{_inflated_column}{$pre} = $pre_objects[0];
+ }
+
+ $new->related_resultset($pre)->set_cache(\@pre_objects);
}
$new->in_storage (1);
$self->_sqlcase($func),
$self->_recurse_fields($args),
$as
- ? sprintf (' %s %s', $self->_sqlcase('as'), $as)
+ ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
: ''
);
return;
}
- $self->throw_exception($self->storage->_sqlt_version_error)
- if (not $self->storage->_sqlt_version_ok);
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
+ $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
my $db_tr = SQL::Translator->new({
add_drop_table => 1,
use Data::Dumper::Concise();
use Sub::Name ();
-# what version of sqlt do we require if deploy() without a ddl_dir is invoked
-# when changing also adjust the corresponding author_require in Makefile.PL
-my $minimum_sqlt_version = '0.11002';
-
-
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
_conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
&&
(ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
&&
- scalar $sql_maker->_order_by_chunks ($attrs->{order_by})
+ scalar $self->_parse_order_by ($attrs->{order_by})
) {
# the RNO limit dialect above mangles the SQL such that the join gets lost
# wrap a subquery here
=cut
sub _dbh_last_insert_id {
- # All Storage's need to register their own _dbh_last_insert_id
- # the old SQLite-based method was highly inappropriate
+ my ($self, $dbh, $source, $col) = @_;
- my $self = shift;
- my $class = ref $self;
- $self->throw_exception (<<EOE);
+ my $id = eval { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+
+ return $id if defined $id;
-No _dbh_last_insert_id() method found in $class.
-Since the method of obtaining the autoincrement id of the last insert
-operation varies greatly between different databases, this method must be
-individually implemented for every storage class.
-EOE
+ my $class = ref $self;
+ $self->throw_exception ("No storage specific _dbh_last_insert_id() method implemented in $class, and the generic DBI::last_insert_id() failed");
}
sub last_insert_id {
%{$sqltargs || {}}
};
- $self->throw_exception("Can't create a ddl file without SQL::Translator: " . $self->_sqlt_version_error)
- if !$self->_sqlt_version_ok;
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
+ $self->throw_exception("Can't create a ddl file without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
my $sqlt = SQL::Translator->new( $sqltargs );
return join('', @rows);
}
- $self->throw_exception("Can't deploy without either SQL::Translator or a ddl_dir: " . $self->_sqlt_version_error )
- if !$self->_sqlt_version_ok;
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) {
+ $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
# sources needs to be a parser arg, but for simplicty allow at top level
# coming in
return;
}
-# SQLT version handling
-{
- my $_sqlt_version_ok; # private
- my $_sqlt_version_error; # private
-
- sub _sqlt_version_ok {
- if (!defined $_sqlt_version_ok) {
- eval "use SQL::Translator $minimum_sqlt_version";
- if ($@) {
- $_sqlt_version_ok = 0;
- $_sqlt_version_error = $@;
- }
- else {
- $_sqlt_version_ok = 1;
- }
- }
- return $_sqlt_version_ok;
- }
-
- sub _sqlt_version_error {
- shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
- return $_sqlt_version_error;
- }
-
- sub _sqlt_minimum_version { $minimum_sqlt_version };
-}
-
=head2 relname_to_table_alias
=over 4
# some databases need this to stop spewing warnings
if (my $dbh = $self->_dbh) {
local $@;
- eval { $dbh->disconnect };
+ eval {
+ %{ $dbh->{CachedKids} } = ();
+ $dbh->disconnect;
+ };
}
$self->_dbh(undef);
# see if this is an ordered subquery
my $attrs = $_[3];
- if ( scalar $self->sql_maker->_order_by_chunks ($attrs->{order_by}) ) {
+ if ( scalar $self->_parse_order_by ($attrs->{order_by}) ) {
$self->throw_exception(
'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL
') unless $attrs->{unsafe_subselect_ok};
}
}
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
-
- # punt: if there is no derived class for the specific backend, attempt
- # to use the DBI->last_insert_id, which may not be sufficient (see the
- # discussion of last_insert_id in perldoc DBI)
- return $dbh->last_insert_id(undef, undef, $source->from, $col);
-}
-
1;
=head1 NAME
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC::SQL_Anywhere;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::SQLAnywhere/;
+use mro 'c3';
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC::SQL_Anywhere - Driver for using Sybase SQL
+Anywhere through ODBC
+
+=head1 SYNOPSIS
+
+All functionality is provided by L<DBIx::Class::Storage::DBI::SQLAnywhere>, see
+that module for details.
+
+=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
my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
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"
+ );
+ }
+
$column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
? DBD::Oracle::ORA_CLOB()
: DBD::Oracle::ORA_BLOB()
BEGIN {
use Carp::Clan qw/^DBIx::Class/;
-
- ## Modules required for Replication support not required for general DBIC
- ## use, so we explicitly test for these.
-
- my %replication_required = (
- 'Moose' => '0.90',
- 'MooseX::Types' => '0.21',
- 'namespace::clean' => '0.11',
- 'Hash::Merge' => '0.11'
- );
-
- my @didnt_load;
-
- for my $module (keys %replication_required) {
- eval "use $module $replication_required{$module}";
- push @didnt_load, "$module $replication_required{$module}"
- if $@;
- }
-
- croak("@{[ join ', ', @didnt_load ]} are missing and are required for Replication")
- if @didnt_load;
+ use DBIx::Class;
+ croak('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') )
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
use Moose;
use MooseX::Types::Moose qw/ClassName HashRef Object/;
use Scalar::Util 'reftype';
use Hash::Merge 'merge';
+use List::Util qw/min max/;
use namespace::clean -except => 'meta';
=head1 REQUIREMENTS
-Replicated Storage has additional requirements not currently part of L<DBIx::Class>
-
- Moose => '0.90',
- MooseX::Types => '0.21',
- namespace::clean => '0.11',
- Hash::Merge => '0.11'
-
-You will need to install these modules manually via CPAN or make them part of the
-Makefile for your distribution.
+Replicated Storage has additional requirements not currently part of
+L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
=head1 ATTRIBUTES
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>.
+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
handles=>[qw/
on_connect_do
on_disconnect_do
+ on_connect_call
+ on_disconnect_call
connect_info
+ _connect_info
throw_exception
sql_maker
sqlt_type
svp_rollback
svp_begin
svp_release
+ relname_to_table_alias
+ _straight_join_to_node
+ _dbh_last_insert_id
+ _fix_bind_params
+ _default_dbi_connect_attributes
+ _dbi_connect_info
+ auto_savepoint
+ _sqlt_version_ok
+ _query_end
+ bind_attribute_by_data_type
+ transaction_depth
+ _dbh
+ _select_args
+ _dbh_execute_array
+ _sql_maker_args
+ _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
+ _placeholders_supported
+ _verify_pid
+ savepoints
+ _sqlt_minimum_version
+ _sql_maker_opts
+ _conn_pid
+ _typeless_placeholders_supported
+ _conn_tid
+ _dbh_autocommit
+ _native_data_type
+ _get_dbh
+ sql_maker_class
+ _dbh_rollback
+ _adjust_select_args_for_complex_prefetch
+ _resolve_ident_sources
+ _resolve_column_info
+ _prune_unused_joins
+ _strip_cond_qualifiers
+ _parse_order_by
+ _resolve_aliastypes_from_select_args
+ _execute
+ _do_query
+ _dbh_sth
+ _dbh_execute
/],
);
my $master = $self->master;
$master->_determine_driver;
Moose::Meta::Class->initialize(ref $master);
+
DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
+ # link pool back to master
+ $self->pool->master($master);
+
$wantarray ? @res : $res;
};
=head2 debugobj
-set a debug object across all storages
+set a debug object
=cut
sub debugobj {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugobj(@_);
- }
- }
- return $self->master->debugobj;
+ return $self->master->debugobj(@_);
}
=head2 debugfh
-set a debugfh object across all storages
+set a debugfh object
=cut
sub debugfh {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugfh(@_);
- }
- }
- return $self->master->debugfh;
+ return $self->master->debugfh(@_);
}
=head2 debugcb
-set a debug callback across all storages
+set a debug callback
=cut
sub debugcb {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugcb(@_);
- }
- }
- return $self->master->debugcb;
+ return $self->master->debugcb(@_);
}
=head2 disconnect
$self->master->cursor_class;
}
+=head2 cursor
+
+set cursor class on all storages, or return master's, alias for L</cursor_class>
+above.
+
+=cut
+
+sub cursor {
+ my ($self, $cursor_class) = @_;
+
+ if ($cursor_class) {
+ $_->cursor($cursor_class) for $self->all_storages;
+ }
+ $self->master->cursor;
+}
+
+=head2 unsafe
+
+sets the L<DBIx::Class::Storage::DBI/unsafe> option on all storages or returns
+master's current setting
+
+=cut
+
+sub unsafe {
+ my $self = shift;
+
+ if (@_) {
+ $_->unsafe(@_) for $self->all_storages;
+ }
+
+ return $self->master->unsafe;
+}
+
+=head2 disable_sth_caching
+
+sets the L<DBIx::Class::Storage::DBI/disable_sth_caching> option on all storages
+or returns master's current setting
+
+=cut
+
+sub disable_sth_caching {
+ my $self = shift;
+
+ if (@_) {
+ $_->disable_sth_caching(@_) for $self->all_storages;
+ }
+
+ return $self->master->disable_sth_caching;
+}
+
+=head2 lag_behind_master
+
+returns the highest Replicant L<DBIx::Class::Storage::DBI/lag_behind_master>
+setting
+
+=cut
+
+sub lag_behind_master {
+ my $self = shift;
+
+ return max map $_->lag_behind_master, $self->replicants;
+}
+
+=head2 is_replicating
+
+returns true if all replicants return true for
+L<DBIx::Class::Storage::DBI/is_replicating>
+
+=cut
+
+sub is_replicating {
+ my $self = shift;
+
+ return (grep $_->is_replicating, $self->replicants) == ($self->replicants);
+}
+
+=head2 connect_call_datetime_setup
+
+calls L<DBIx::Class::Storage::DBI/connect_call_datetime_setup> for all storages
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+ $_->connect_call_datetime_setup for $self->all_storages;
+}
+
+sub _populate_dbh {
+ my $self = shift;
+ $_->_populate_dbh for $self->all_storages;
+}
+
+sub _connect {
+ my $self = shift;
+ $_->_connect for $self->all_storages;
+}
+
+sub _rebless {
+ my $self = shift;
+ $_->_rebless for $self->all_storages;
+}
+
+sub _determine_driver {
+ my $self = shift;
+ $_->_determine_driver for $self->all_storages;
+}
+
+sub _driver_determined {
+ my $self = shift;
+
+ if (@_) {
+ $_->_driver_determined(@_) for $self->all_storages;
+ }
+
+ return $self->master->_driver_determined;
+}
+
+sub _init {
+ my $self = shift;
+
+ $_->_init for $self->all_storages;
+}
+
+sub _run_connection_actions {
+ my $self = shift;
+
+ $_->_run_connection_actions for $self->all_storages;
+}
+
+sub _do_connection_actions {
+ my $self = shift;
+
+ if (@_) {
+ $_->_do_connection_actions(@_) for $self->all_storages;
+ }
+}
+
+sub connect_call_do_sql {
+ my $self = shift;
+ $_->connect_call_do_sql(@_) for $self->all_storages;
+}
+
+sub disconnect_call_do_sql {
+ my $self = shift;
+ $_->disconnect_call_do_sql(@_) for $self->all_storages;
+}
+
+sub _seems_connected {
+ my $self = shift;
+
+ return min map $_->_seems_connected, $self->all_storages;
+}
+
+sub _ping {
+ my $self = shift;
+
+ return min map $_->_ping, $self->all_storages;
+}
+
=head1 GOTCHAS
Due to the fact that replicants can lag behind a master, you must take care to
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 namespace::clean -except => 'meta';
},
);
+=head2 master
+
+Reference to the master Storage.
+
+=cut
+
+has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+
=head1 METHODS
This class defines the following methods.
$replicant->_determine_driver
});
- DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+ Moose::Meta::Class->initialize(ref $replicant);
+
+ DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+
+ # link back to master
+ $replicant->master($self->master);
+
return $replicant;
}
requires qw/_query_start/;
with 'DBIx::Class::Storage::DBI::Replicated::WithDSN';
use MooseX::Types::Moose qw/Bool Str/;
+use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use namespace::clean -except => 'meta';
has dsn => (is => 'rw', isa => Str);
has id => (is => 'rw', isa => Str);
+=head2 master
+
+Reference to the master Storage.
+
+=cut
+
+has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+
=head1 METHODS
This class defines the following methods.
=cut
sub debugobj {
- return shift->schema->storage->debugobj;
+ my $self = shift;
+
+ return $self->master->debugobj;
}
=head1 ALSO SEE
--- /dev/null
+package DBIx::Class::Storage::DBI::SQLAnywhere;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use List::Util ();
+
+__PACKAGE__->mk_group_accessors(simple => qw/
+ _identity
+/);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::SQLAnywhere - Driver for Sybase SQL Anywhere
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Sybase SQL Anywhere, selects the
+RowNumberOver limit implementation and provides
+L<DBIx::Class::InflateColumn::DateTime> support.
+
+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:
+
+ /opt/sqlanywhere11/sdk/perl
+
+Recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
+
+ on_connect_call => 'datetime_setup'
+
+=head1 METHODS
+
+=cut
+
+sub last_insert_id { shift->_identity }
+
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $identity_col = List::Util::first {
+ $source->column_info($_)->{is_auto_increment}
+ } $source->columns;
+
+# user might have an identity PK without is_auto_increment
+ if (not $identity_col) {
+ foreach my $pk_col ($source->primary_columns) {
+ if (not exists $to_insert->{$pk_col}) {
+ $identity_col = $pk_col;
+ last;
+ }
+ }
+ }
+
+ if ($identity_col && (not exists $to_insert->{$identity_col})) {
+ my $dbh = $self->_get_dbh;
+ my $table_name = $source->from;
+ $table_name = $$table_name if ref $table_name;
+
+ my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
+
+ $to_insert->{$identity_col} = $identity;
+
+ $self->_identity($identity);
+ }
+
+ return $self->next::method(@_);
+}
+
+# this sub stolen from DB2
+
+sub _sql_maker_opts {
+ my ( $self, $opts ) = @_;
+
+ if ( $opts ) {
+ $self->{_sql_maker_opts} = { %$opts };
+ }
+
+ return { limit_dialect => 'RowNumberOver', %{$self->{_sql_maker_opts}||{}} };
+}
+
+# this sub stolen from MSSQL
+
+sub build_datetime_parser {
+ my $self = shift;
+ my $type = "DateTime::Format::Strptime";
+ eval "use ${type}";
+ $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ return $type->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' );
+}
+
+=head2 connect_call_datetime_setup
+
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<DBIx::Class::Storage::DBI/connect_info> to set the date and timestamp
+formats (as temporary options for the session) for use with
+L<DBIx::Class::InflateColumn::DateTime>.
+
+The C<TIMESTAMP> data type supports up to 6 digits after the decimal point for
+second precision. The full precision is used.
+
+The C<DATE> data type supposedly stores hours and minutes too, according to the
+documentation, but I could not get that to work. It seems to only store the
+date.
+
+You will need the L<DateTime::Format::Strptime> module for inflation to work.
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+
+ $self->_do_query(
+ "set temporary option timestamp_format = 'yyyy-mm-dd hh:mm:ss.ssssss'"
+ );
+ $self->_do_query(
+ "set temporary option date_format = 'yyyy-mm-dd hh:mm:ss.ssssss'"
+ );
+}
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("SAVEPOINT $name");
+}
+
+# can't release savepoints that have been rolled back
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
+1;
+
+=head1 MAXIMUM CURSORS
+
+A L<DBIx::Class>> application can use a lot of cursors, due to the usage of
+L<DBI/prepare_cached>.
+
+The default cursor maximum is C<50>, which can be a bit too low. This limit can
+be turned off (or increased) by the DBA by executing:
+
+ set option max_statement_count = 0
+ set option max_cursor_count = 0
+
+Highly recommended.
+
+=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
use File::Copy;
use File::Spec;
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- $dbh->func('last_insert_rowid');
-}
-
sub backup
{
my ($self, $dir) = @_;
# check for empty insert
# INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
- # try to insert explicit 'DEFAULT's instead (except for identity)
+ # try to insert explicit 'DEFAULT's instead (except for identity, timestamp
+ # and computed columns)
if (not %$to_insert) {
for my $col ($source->columns) {
next if $col eq $identity_col;
+
+ my $info = $source->column_info($col);
+
+ next if ref $info->{default_value} eq 'SCALAR'
+ || (exists $info->{data_type} && (not defined $info->{data_type}));
+
+ next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i;
+
$to_insert->{$col} = \'DEFAULT';
}
}
=head1 Schema::Loader Support
-There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
-allow you to dump a schema from most (if not all) versions of Sybase.
-
-It is available via subversion from:
-
- http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/
+As of version C<0.05000>, L<DBIx::Class::Schema::Loader> should work well with
+most (if not all) versions of Sybase ASE.
=head1 FreeTDS
When inserting IMAGE columns using this method, you'll need to use
L</connect_call_blob_setup> as well.
+=head1 COMPUTED COLUMNS
+
+If you have columns such as:
+
+ created_dtm AS getdate()
+
+represent them in your Result classes as:
+
+ created_dtm => {
+ data_type => undef,
+ default_value => \'getdate()',
+ is_nullable => 0,
+ }
+
+The C<data_type> must exist and must be C<undef>. Then empty inserts will work
+on tables with such columns.
+
+=head1 TIMESTAMP COLUMNS
+
+C<timestamp> columns in Sybase ASE are not really timestamps, see:
+L<http://dba.fyicenter.com/Interview-Questions/SYBASE/The_timestamp_datatype_in_Sybase_.html>.
+
+They should be defined in your Result classes as:
+
+ ts => {
+ data_type => 'timestamp',
+ is_nullable => 0,
+ inflate_datetime => 0,
+ }
+
+The C<<inflate_datetime => 0>> is necessary if you use
+L<DBIx::Class::InflateColumn::DateTime>, and most people do, and still want to
+be able to read these values.
+
+The values will come back as hexadecimal.
+
=head1 TODO
=over
my $group_by_sql = $sql_maker->_order_by({
map { $_ => $attrs->{$_} } qw/group_by having/
});
- my @order_by_chunks = (map
- { ref $_ ? $_->[0] : $_ }
- $sql_maker->_order_by_chunks ($attrs->{order_by})
- );
+ my @order_by_chunks = ($self->_parse_order_by ($attrs->{order_by}) );
# match every alias to the sql chunks above
for my $alias (keys %$alias_list) {
for (my $i = 0; $i < @cond; $i++) {
my $entry = $cond[$i];
my $hash;
- if (ref $entry eq 'HASH') {
+ my $ref = ref $entry;
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
$hash = $self->_strip_cond_qualifiers($entry);
}
- else {
+ 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;
}
}
return $cond;
}
+sub _parse_order_by {
+ my ($self, $order_by) = @_;
+
+ return scalar $self->sql_maker->_order_by_chunks ($order_by)
+ unless wantarray;
+
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{quote_char}; #disable quoting
+ my @chunks;
+ for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ push @chunks, $chunk;
+ }
+
+ return @chunks;
+}
1;
use strict;
use warnings;
use base qw/DBIx::Class/;
-use utf8;
__PACKAGE__->mk_classdata( '_utf8_columns' );
# override this if you want to force everything to be encoded/decoded
sub _is_utf8_column {
- return (shift->utf8_columns || {})->{shift};
+ # my ($self, $col) = @_;
+ return ($_[0]->utf8_columns || {})->{$_[1]};
}
=head1 AUTHORS
#!/usr/bin/perl
+
use strict;
use warnings;
-use Getopt::Long;
-use Pod::Usage;
-use JSON::Any;
-
-
-my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1);
-
-GetOptions(
- 'schema=s' => \my $schema_class,
- 'class=s' => \my $resultset_class,
- 'connect=s' => \my $connect,
- 'op=s' => \my $op,
- 'set=s' => \my $set,
- 'where=s' => \my $where,
- 'attrs=s' => \my $attrs,
- 'format=s' => \my $format,
- 'force' => \my $force,
- 'trace' => \my $trace,
- 'quiet' => \my $quiet,
- 'help' => \my $help,
- 'tlibs' => \my $t_libs,
-);
-
-if ($t_libs) {
- unshift( @INC, 't/lib', 'lib' );
+BEGIN {
+ use DBIx::Class;
+ die ( "The following modules are required for the dbicadmin utility\n"
+ . DBIx::Class::Optional::Dependencies->req_missing_for ('admin_script')
+ ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin_script');
}
-pod2usage(1) if ($help);
-$ENV{DBIC_TRACE} = 1 if ($trace);
-
-die('No op specified') if(!$op);
-die('Invalid op') if ($op!~/^insert|update|delete|select$/s);
-my $csv_class;
-if ($op eq 'select') {
- $format ||= 'tsv';
- die('Invalid format') if ($format!~/^tsv|csv$/s);
- $csv_class = 'Text::CSV_XS';
- eval{ require Text::CSV_XS };
- if ($@) {
- $csv_class = 'Text::CSV_PP';
- eval{ require Text::CSV_PP };
- die('The select op requires either the Text::CSV_XS or the Text::CSV_PP module') if ($@);
- }
-}
-
-die('No schema specified') if(!$schema_class);
-eval("require $schema_class");
-die('Unable to load schema') if ($@);
-$connect = $json->jsonToObj( $connect ) if ($connect);
-my $schema = $schema_class->connect(
- ( $connect ? @$connect : () )
+use Getopt::Long::Descriptive;
+use DBIx::Class::Admin;
+
+my ($opts, $usage) = describe_options(
+ "%c: %o",
+ (
+ ['Actions'],
+ ["action" => hidden => { one_of => [
+ ['create|c' => 'Create version diffs needs preversion',],
+ ['upgrade|u' => 'Upgrade the database to the current schema '],
+ ['install|i' => 'Install the schema to the database',],
+ ['deploy|d' => 'Deploy the schema to the database',],
+ ['select|s' => 'Select data from the schema', ],
+ ['insert|i' => 'Insert data into the schema', ],
+ ['update|u' => 'Update data in the schema', ],
+ ['delete|D' => 'Delete data from the schema',],
+ ['op:s' => 'compatiblity option all of the above can be suppied as --op=<action>'],
+ ['help|h' => 'display this help'],
+ ], required=> 1 }],
+ ['Options'],
+ ['schema-class|schema|C:s' => 'The class of the schema to load', { required => 1 } ],
+ ['resultset|resultset_class|class|r:s' => 'The resultset to operate on for data manipulation' ],
+ ['config-stanza|S:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',],
+ ['config|f:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
+ ['connect-info|n:s%' => 'Supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '],
+ ['connect:s' => 'Supply the connect info as a json string' ],
+ ['sql-dir|q:s' => 'The directory where sql diffs will be created'],
+ ['sql-type|t:s' => 'The RDBMs flavour you wish to use'],
+ ['version|v:i' => 'Supply a version install'],
+ ['preversion|p:s' => 'The previous version to diff against',],
+ ['set:s' => 'JSON data used to perform data operations' ],
+ ['lib|I:s' => 'Additonal library path to search in'],
+ ['attrs:s' => 'JSON string to be used for the second argument for search'],
+ ['where:s' => 'JSON string to be used for the where clause of search'],
+ ['force' => 'Be forceful with some operations'],
+ ['trace' => 'Turn on DBIx::Class trace output'],
+ ['quiet' => 'Be less verbose'],
+ )
);
-die('No class specified') if(!$resultset_class);
-my $resultset = eval{ $schema->resultset($resultset_class) };
-die('Unable to load the class with the schema') if ($@);
-
-$set = $json->jsonToObj( $set ) if ($set);
-$where = $json->jsonToObj( $where ) if ($where);
-$attrs = $json->jsonToObj( $attrs ) if ($attrs);
+die "please only use one of --config or --connect-info\n" if ($opts->{config} and $opts->{connect_info});
-if ($op eq 'insert') {
- die('Do not use the where option with the insert op') if ($where);
- die('Do not use the attrs option with the insert op') if ($attrs);
- my $obj = $resultset->create( $set );
- print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$quiet);
+# option compatability mangle
+if($opts->{connect}) {
+ $opts->{connect_info} = delete $opts->{connect};
}
-elsif ($op eq 'update') {
- $resultset = $resultset->search( ($where||{}) );
- my $count = $resultset->count();
- print "This action will modify $count ".ref($resultset)." records.\n" if (!$quiet);
- if ( $force || confirm() ) {
- $resultset->update_all( $set );
- }
-}
-elsif ($op eq 'delete') {
- die('Do not use the set option with the delete op') if ($set);
- $resultset = $resultset->search( ($where||{}), ($attrs||()) );
- my $count = $resultset->count();
- print "This action will delete $count ".ref($resultset)." records.\n" if (!$quiet);
- if ( $force || confirm() ) {
- $resultset->delete_all();
- }
-}
-elsif ($op eq 'select') {
- die('Do not use the set option with the select op') if ($set);
- my $csv = $csv_class->new({
- sep_char => ( $format eq 'tsv' ? "\t" : ',' ),
- });
- $resultset = $resultset->search( ($where||{}), ($attrs||()) );
- my @columns = $resultset->result_source->columns();
- $csv->combine( @columns );
- print $csv->string()."\n";
- while (my $row = $resultset->next()) {
- my @fields;
- foreach my $column (@columns) {
- push( @fields, $row->get_column($column) );
- }
- $csv->combine( @fields );
- print $csv->string()."\n";
- }
-}
-
-sub confirm {
- print "Are you sure you want to do this? (type YES to confirm) ";
- my $response = <STDIN>;
- return 1 if ($response=~/^YES/);
- return;
-}
-
-__END__
-
-=head1 NAME
-
-dbicadmin - Execute operations upon DBIx::Class objects.
-
-=head1 SYNOPSIS
-
- dbicadmin --op=insert --schema=My::Schema --class=Class --set=JSON
- dbicadmin --op=update --schema=My::Schema --class=Class --set=JSON --where=JSON
- dbicadmin --op=delete --schema=My::Schema --class=Class --where=JSON
- dbicadmin --op=select --schema=My::Schema --class=Class --where=JSON --format=tsv
-
-=head1 DESCRIPTION
-
-This utility provides the ability to run INSERTs, UPDATEs,
-DELETEs, and SELECTs on any DBIx::Class object.
-
-=head1 OPTIONS
-
-=head2 op
-The type of operation. Valid values are insert, update, delete,
-and select.
+my $admin = DBIx::Class::Admin->new( %$opts );
-=head2 schema
-The name of your schema class.
+my $action = $opts->{action};
-=head2 class
+$action = $opts->{op} if ($action eq 'op');
-The name of the class, within your schema, that you want to run
-the operation on.
+print "Performig action $action...\n";
-=head2 connect
+my $res = $admin->$action();
+if ($action eq 'select') {
-A JSON array to be passed to your schema class upon connecting.
-The array will need to be compatible with whatever the DBIC
-->connect() method requires.
+ my $format = $opts->{format} || 'tsv';
+ die('Invalid format') if ($format!~/^tsv|csv$/s);
-=head2 set
+ require Text::CSV;
-This option must be valid JSON data string and is passed in to
-the DBIC update() method. Use this option with the update
-and insert ops.
+ my $csv = Text::CSV->new({
+ sep_char => ( $format eq 'tsv' ? "\t" : ',' ),
+ });
-=head2 where
-
-This option must be valid JSON data string and is passed in as
-the first argument to the DBIC search() method. Use this
-option with the update, delete, and select ops.
-
-=head2 attrs
-
-This option must be valid JSON data string and is passed in as
-the second argument to the DBIC search() method. Use this
-option with the update, delete, and select ops.
-
-=head2 help
-
-Display this help page.
-
-=head2 force
-
-Suppresses the confirmation dialogues that are usually displayed
-when someone runs a DELETE or UPDATE action.
-
-=head2 quiet
-
-Do not display status messages.
-
-=head2 trace
-
-Turns on tracing on the DBI storage, thus printing SQL as it is
-executed.
-
-=head2 tlibs
-
-This option is purely for testing during the DBIC installation. Do
-not use it.
-
-=head1 JSON
-
-JSON is a lightweight data-interchange format. It allows you
-to express complex data structures for use in the where and
-set options.
-
-This module turns on L<JSON>'s BareKey and QuotApos options so
-that your data can look a bit more readable.
-
- --where={"this":"that"} # generic JSON
- --where={this:'that'} # with BareKey and QuoteApos
-
-Consider wrapping your JSON in outer quotes so that you don't
-have to escape your inner quotes.
-
- --where={this:\"that\"} # no outer quote
- --where='{this:"that"}' # outer quoted
+ foreach my $row (@$res) {
+ $csv->combine( @$row );
+ print $csv->string()."\n";
+ }
+}
=head1 AUTHOR
-Aran Deltac <bluefeet@cpan.org>
+See L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
-You may distribute this code under the same terms as Perl itself.
+You may distribute this code under the same terms as Perl itself
+=cut
/]
},
+ 'DBIx::Class::Storage::DBI::Replicated*' => {
+ ignore => [ qw/
+ connect_call_do_sql
+ disconnect_call_do_sql
+ /]
+ },
+
+ 'DBIx::Class::Admin::Types' => { skip => 1 },
'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 },
'DBIx::Class::Componentised' => { skip => 1 },
'DBIx::Class::Relationship::*' => { skip => 1 },
'DBIx::Class::Storage::DBI::Replicated::Types' => { skip => 1 },
# test some specific components whose parents are exempt below
- 'DBIx::Class::Storage::DBI::Replicated*' => {},
'DBIx::Class::Relationship::Base' => {},
# internals
--- /dev/null
+use strict;
+use warnings;
+no warnings qw/once/;
+
+use Test::More;
+use lib qw(t/lib);
+use Scalar::Util; # load before we break require()
+
+use_ok 'DBIx::Class::Optional::Dependencies';
+
+my $sqlt_dep = DBIx::Class::Optional::Dependencies->req_list_for ('deploy');
+is_deeply (
+ [ keys %$sqlt_dep ],
+ [ 'SQL::Translator' ],
+ 'Correct deploy() dependency list',
+);
+
+# make module loading impossible, regardless of actual libpath contents
+@INC = (sub { die('Optional Dep Test') } );
+
+ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps missing',
+);
+
+like (
+ DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
+ qr/^SQL::Translator \>\= \d/,
+ 'expected missing string contents',
+);
+
+like (
+ DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy')->{'SQL::Translator'},
+ qr/Optional Dep Test/,
+ 'custom exception found in errorlist',
+);
+
+
+#make it so module appears loaded
+$INC{'SQL/Translator.pm'} = 1;
+$SQL::Translator::VERSION = 999;
+
+ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps missing cached properly',
+);
+
+#reset cache
+%DBIx::Class::Optional::Dependencies::req_availability_cache = ();
+
+
+ok (
+ DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps present',
+);
+
+is (
+ DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
+ '',
+ 'expected null missing string',
+);
+
+is_deeply (
+ DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy'),
+ {},
+ 'expected empty errorlist',
+);
+
+
+done_testing;
# make sure we got rid of the compat shims
SKIP: {
- skip "Remove in 0.09", 5 if $DBIx::Class::VERSION < 0.09;
+ skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082;
- for (qw/compare_relationship_keys pk_depends_on resolve_condition resolve_join resolve_prefetch/) {
+ for (qw/compare_relationship_keys pk_depends_on resolve_condition/) {
ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource");
}
}
is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
SKIP: {
- skip 'buggy BLOB support in DBD::Oracle 1.23', 8
- if $DBD::Oracle::VERSION == 1.23;
-
my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
$binstr{'large'} = $binstr{'small'} x 1024;
my $rs = $schema->resultset('BindType');
my $id = 0;
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ throws_ok { $rs->create({ id => 1, blob => $binstr{large} }) }
+ qr/broken/,
+ 'throws on blob insert with DBD::Oracle == 1.23';
+
+ skip 'buggy BLOB support in DBD::Oracle 1.23', 7;
+ }
+
foreach my $type (qw( blob clob )) {
foreach my $size (qw( small large )) {
$id++;
having => \['1 = ?', [ test => 1 ] ], #test having propagation
prefetch => 'owner',
rows => 2, # 3 results total
- order_by => { -desc => 'owner' },
+ order_by => { -desc => 'me.owner' },
unsafe_subselect_ok => 1,
},
);
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
-my $TESTS = 63 + 2;
+my $TESTS = 66 + 2;
if (not ($dsn && $user)) {
plan skip_all =>
'updated money value to NULL round-trip'
);
diag $@ if $@;
+
+# Test computed columns and timestamps
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE computed_column_test") };
+ $dbh->do(<<'SQL');
+CREATE TABLE computed_column_test (
+ id INT IDENTITY PRIMARY KEY,
+ a_computed_column AS getdate(),
+ a_timestamp timestamp,
+ charfield VARCHAR(20) DEFAULT 'foo'
+)
+SQL
+ });
+
+ require DBICTest::Schema::ComputedColumn;
+ $schema->register_class(
+ ComputedColumn => 'DBICTest::Schema::ComputedColumn'
+ );
+
+ ok (($rs = $schema->resultset('ComputedColumn')),
+ 'got rs for ComputedColumn');
+
+ lives_ok { $row = $rs->create({}) }
+ 'empty insert for a table with computed columns survived';
+
+ lives_ok {
+ $row->update({ charfield => 'bar' })
+ } 'update of a table with computed columns survived';
}
is $ping_count, 0, 'no pings';
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
- for qw/artist bindtype_test money_test/;
+ for qw/artist bindtype_test money_test computed_column_test/;
}
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+# tests stolen from 748informix.t
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN},
+_USER and _PASS to run these tests
+EOF
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my @handles_to_clean;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1
+ });
+
+ my $dbh = $schema->storage->dbh;
+
+ push @handles_to_clean, $dbh;
+
+ eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid INT IDENTITY PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT DEFAULT 13
+ )
+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");
+
+# 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 savepoints
+ eval {
+ $schema->txn_do(sub {
+ eval {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_savepoint' });
+ die "rolling back savepoint";
+ });
+ };
+ ok ((not $ars->search({ name => 'in_savepoint' })->first),
+ 'savepoint rolled back');
+ $ars->create({ name => 'in_outer_txn' });
+ die "rolling back outer txn";
+ });
+ };
+
+ like $@, qr/rolling back outer txn/,
+ 'correct exception for rollback';
+
+ ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+ 'outer txn rolled back');
+
+# 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
+ my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ 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, 101, "iterator->next ok" );
+ is( $lim->next->artistid, 102, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ {
+ local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
+
+ lives_ok { $ars->create({}) }
+ 'empty insert works';
+ }
+
+# test blobs (stolen from 73oracle.t)
+ eval { $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob LONG BINARY NULL,
+ clob LONG VARCHAR NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+ local $schema->storage->{debug} = 0;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
+ }
+}
$sub_rs->single,
{
artist => 1,
- track_position => 2,
- tracks => {
+ tracks => {
+ title => 'Apiary',
trackid => 17,
- title => 'Apiary',
},
},
'columns/select/as fold properly on sub-searches',
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use utf8;
warning_like (
sub {
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => 'øni', year => '2048' } );
-my $utf8_char = 'uniuni';
-
+my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
+
ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
-utf8::decode($utf8_char);
-$cd->title($utf8_char);
+$cd->title('nonunicode');
+ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
use DBICTest;
BEGIN {
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
my $schema = DBICTest->init_schema (no_deploy => 1);
# test +select/+as for single column
my $psrs = $schema->resultset('CD')->search({},
{
- '+select' => \'COUNT(*)',
- '+as' => 'count'
+ '+select' => \'MAX(year)',
+ '+as' => 'last_year'
}
);
-lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as additional column "count" present (scalar)');
+lives_ok(sub { $psrs->get_column('last_year')->next }, '+select/+as additional column "last_year" present (scalar)');
dies_ok(sub { $psrs->get_column('noSuchColumn')->next }, '+select/+as nonexistent column throws exception');
# test +select/+as for overriding a column
# test +select/+as for multiple columns
$psrs = $schema->resultset('CD')->search({},
{
- '+select' => [ \'COUNT(*)', 'title' ],
- '+as' => [ 'count', 'addedtitle' ]
+ '+select' => [ \'LENGTH(title) AS title_length', 'title' ],
+ '+as' => [ 'tlength', 'addedtitle' ]
}
);
-lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as multiple additional columns, "count" column present');
+lives_ok(sub { $psrs->get_column('tlength')->next }, '+select/+as multiple additional columns, "tlength" column present');
lives_ok(sub { $psrs->get_column('addedtitle')->next }, '+select/+as multiple additional columns, "addedtitle" column present');
# test that +select/+as specs do not leak
);
is_same_sql_bind (
- $psrs->get_column('count')->as_query,
- '(SELECT COUNT(*) FROM cd me)',
+ $psrs->get_column('tlength')->as_query,
+ '(SELECT LENGTH(title) AS title_length FROM cd me)',
[],
'Correct SQL for get_column/+as func'
);
-
+# test that order_by over a function forces a subquery
+lives_ok ( sub {
+ is_deeply (
+ [ $psrs->search ({}, { order_by => { -desc => 'title_length' } })->get_column ('title')->all ],
+ [
+ "Generic Manufactured Singles",
+ "Come Be Depressed With Us",
+ "Caterwaulin' Blues",
+ "Spoonful of bees",
+ "Forkful of bees",
+ ],
+ 'Subquery count induced by aliased ordering function',
+ );
+});
+
+# test for prefetch not leaking
{
my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' });
my $rsc = $rs->get_column('year');
WHERE
cdid > CAST(? AS INT)
AND tracks.last_updated_at IS NOT NULL
- AND tracks.last_updated_on < CAST (? AS yyy)
+ AND tracks.last_updated_on < CAST (? AS DateTime)
AND tracks.position = ?
AND tracks.single_track = CAST(? AS INT)
)',
|| plan skip_all => 'Test needs Time::HiRes';
Time::HiRes->import(qw/time sleep/);
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
use lib qw(t/lib);
use Scalar::Util ();
BEGIN {
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
# Test for SQLT-related leaks
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+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_ok 'DBIx::Class::Admin';
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+
+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');
+
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('deploy')
+ 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,
+ no_populate=>1,
+ sqlite_use_file => 1,
+);
+{ # create the schema
+
+# make sure we are clean
+clean_dir($sql_dir);
+
+
+my $admin = DBIx::Class::Admin->new(
+ schema_class=> "DBICTest::Schema",
+ sql_dir=> $sql_dir,
+ connect_info => \@connect_info,
+);
+isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
+lives_ok { $admin->create('MySQL'); } 'Can create MySQL sql';
+lives_ok { $admin->create('SQLite'); } 'Can Create SQLite sql';
+}
+
+{ # upgrade schema
+
+#my $schema = DBICTest->init_schema(
+# no_deploy => 1,
+# no_populat => 1,
+# sqlite_use_file => 1,
+#);
+
+clean_dir($sql_dir);
+require DBICVersion_v1;
+
+my $admin = DBIx::Class::Admin->new(
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $sql_dir,
+ connect_info => \@connect_info,
+);
+
+my $schema = $admin->schema();
+
+lives_ok { $admin->create($schema->storage->sqlt_type(), {add_drop_table=>0}); } 'Can create DBICVersionOrig sql in ' . $schema->storage->sqlt_type;
+lives_ok { $admin->deploy( ) } 'Can Deploy schema';
+
+# connect to now deployed schema
+lives_ok { $schema = DBICVersion::Schema->connect(@{$schema->storage->connect_info()}); } 'Connect to deployed Database';
+
+is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema deployed and versions match');
+
+
+require DBICVersion_v2;
+
+$admin = DBIx::Class::Admin->new(
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $sql_dir,
+ connect_info => \@connect_info
+);
+
+lives_ok { $admin->create($schema->storage->sqlt_type(), {}, "1.0" ); } 'Can create diff for ' . $schema->storage->sqlt_type;
+{
+ local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /DB version .+? is lower than the schema version/ };
+ lives_ok {$admin->upgrade();} 'upgrade the schema';
+}
+
+is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versions match');
+
+}
+
+{ # install
+
+clean_dir($sql_dir);
+
+my $admin = DBIx::Class::Admin->new(
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $sql_dir,
+ _confirm => 1,
+ connect_info => \@connect_info,
+);
+
+$admin->version("3.0");
+lives_ok { $admin->install(); } 'install schema version 3.0';
+is($admin->schema->get_db_version, "3.0", 'db thinks its version 3.0');
+dies_ok { $admin->install("4.0"); } 'cannot install to allready existing version';
+
+$admin->force(1);
+warnings_exist ( sub {
+ lives_ok { $admin->install("4.0") } 'can force install to allready existing version'
+}, qr/Forcing install may not be a good idea/, 'Force warning emitted' );
+is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0');
+#clean_dir($sql_dir);
+}
+
+sub clean_dir {
+ my ($dir) = @_;
+ $dir = $dir->resolve;
+ if ( ! -d $dir ) {
+ $dir->mkpath();
+ }
+ foreach my $file ($dir->children) {
+ # skip any hidden files
+ next if ($file =~ /^\./);
+ unlink $file;
+ }
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Test::Exception;
+use Test::Deep;
+
+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';
+
+
+{ # test data maniplulation functions
+
+ # create a DBICTest so we can steal its connect info
+ my $schema = DBICTest->init_schema(
+ sqlite_use_file => 1,
+ );
+
+ my $admin = DBIx::Class::Admin->new(
+ schema_class=> "DBICTest::Schema",
+ connect_info => $schema->storage->connect_info(),
+ quiet => 1,
+ _confirm=>1,
+ );
+ isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
+
+ $admin->insert('Employee', { name => 'Matt' });
+ my $employees = $schema->resultset('Employee');
+ is ($employees->count(), 1, "insert okay" );
+
+ my $employee = $employees->find(1);
+ is($employee->name(), 'Matt', "insert valid" );
+
+ $admin->update('Employee', {name => 'Trout'}, {name => 'Matt'});
+
+ $employee = $employees->find(1);
+ is($employee->name(), 'Trout', "update Matt to Trout" );
+
+ $admin->insert('Employee', {name =>'Aran'});
+
+ my $expected_data = [
+ [$employee->result_source->columns() ],
+ [1,1,undef,undef,undef,'Trout'],
+ [2,2,undef,undef,undef,'Aran']
+ ];
+ my $data;
+ lives_ok { $data = $admin->select('Employee')} 'can retrive data from database';
+ cmp_deeply($data, $expected_data, 'DB matches whats expected');
+
+ $admin->delete('Employee', {name=>'Trout'});
+ my $del_rs = $employees->search({name => 'Trout'});
+ is($del_rs->count(), 0, "delete Trout" );
+ is ($employees->count(), 1, "left Aran" );
+}
+
+done_testing;
# vim: filetype=perl
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Config;
use lib qw(t/lib);
+$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
use DBICTest;
-eval 'require JSON::Any';
-plan skip_all => 'Install JSON::Any to run this test' if ($@);
-
-eval 'require Text::CSV_XS';
-if ($@) {
- eval 'require Text::CSV_PP';
- plan skip_all => 'Install Text::CSV_XS or Text::CSV_PP to run this test' if ($@);
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin_script')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for('admin_script');
}
my @json_backends = qw/XS JSON DWIW/;
open(my $fh, "-|", _prepare_system_args( qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
my $data = do { local $/; <$fh> };
close($fh);
- ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" );
+ if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) {
+ diag ("data from select is $data")
+ };
}
system( _prepare_system_args( qw|--op=delete --where={"name":"Trout"}| ) );
#
sub _prepare_system_args {
my $perl = $^X;
+
my @args = (
- qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|,
+ qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee|,
q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
- qw|--force --tlibs|,
+ qw|--force|,
@_,
);
->search({ artistid => 1});
is ( $rs->count, 1, 'where/bind first' );
-
+
$rs = $schema->resultset('Artist')->search({ artistid => 1})
->search({}, $where_bind);
$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
is_same_sql_bind(
$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 = ?) WHERE title LIKE ?)",
+ "(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%' ]
$rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
is_same_sql_bind(
$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 = ?) WHERE title LIKE ?)",
+ "(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%' ]
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+my $artist_rs = $schema->resultset ('Artist');
+
+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 } },
+ [ { 'me.name' => 'foo' }, { 'me.name' => 'bar' } ],
+ ],
+})->delete;
+
+is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+
+done_testing;
+
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 id FROM artist me LIMIT 1 ))",
+ "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ))",
[],
);
}
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)",
+ "(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 ]
],
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
+ "(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)",
[
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)",
+ "(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' ] ],
);
}
if ($@) {
plan skip_all => 'needs DateTime and DateTime::Format::Sybase for testing';
}
- else {
- plan tests => (4 * 2 * 2) + 2; # (tests * dt_types * storage_types) + storage_tests
- }
}
my @storage_types = (
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE track (
trackid INT IDENTITY PRIMARY KEY,
- cd INT,
- position INT,
- $col $type,
+ cd INT NULL,
+ position INT NULL,
+ $col $type NULL
)
SQL
ok(my $dt = DateTime::Format::Sybase->parse_datetime($sample_dt));
);
is( $row->$col, $dt, 'DateTime roundtrip' );
}
+
+ # test a computed datetime column
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT NULL,
+ position INT NULL,
+ title VARCHAR(100) NULL,
+ last_updated_on DATETIME NULL,
+ last_updated_at AS getdate(),
+ small_dt SMALLDATETIME NULL
+)
+SQL
+
+ my $now = DateTime->now;
+ sleep 1;
+ my $new_row = $schema->resultset('Track')->create({});
+ $new_row->discard_changes;
+
+ lives_and {
+ cmp_ok (($new_row->last_updated_at - $now)->seconds, '>=', 1)
+ } 'getdate() computed column works';
}
+done_testing;
+
# clean up our mess
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
+
+if (not ($dsn || $dsn2)) {
+ plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN}
+_USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'track'";
+EOF
+} else {
+ eval "use DateTime; use DateTime::Format::Strptime;";
+ if ($@) {
+ plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
+ }
+}
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my @handles_to_clean;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->clone;
+
+ $schema->connection($dsn, $user, $pass, {
+ on_connect_call => [ 'datetime_setup' ],
+ });
+
+ push @handles_to_clean, $schema->storage->dbh;
+
+# coltype, col, date
+ my @dt_types = (
+ ['TIMESTAMP', 'last_updated_at', '2004-08-21 14:36:48.080445'],
+# date only (but minute precision according to ASA docs)
+ ['DATE', 'small_dt', '2004-08-21 00:00:00.000000'],
+ );
+
+ for my $dt_type (@dt_types) {
+ my ($type, $col, $sample_dt) = @$dt_type;
+
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+ CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT,
+ position INT,
+ $col $type,
+ )
+SQL
+ ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt));
+
+ my $row;
+ ok( $row = $schema->resultset('Track')->create({
+ $col => $dt,
+ cd => 1,
+ }));
+ ok( $row = $schema->resultset('Track')
+ ->search({ trackid => $row->trackid }, { select => [$col] })
+ ->first
+ );
+ is( $row->$col, $dt, 'DateTime roundtrip' );
+
+ is $row->$col->nanosecond, $dt->nanosecond,
+ 'nanoseconds survived' if 0+$dt->nanosecond;
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/track/;
+ }
+}
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::ComputedColumn;
+
+# for sybase and mssql computed column tests
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('computed_column_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'a_computed_column' => {
+ data_type => undef,
+ is_nullable => 0,
+ default_value => \'getdate()',
+ },
+ 'a_timestamp' => {
+ data_type => 'timestamp',
+ is_nullable => 0,
+ },
+ 'charfield' => {
+ data_type => 'varchar',
+ size => 20,
+ default_value => 'foo',
+ is_nullable => 0,
+ }
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
# Normally this would not appear as a FK constraint
# since it uses the PK
-__PACKAGE__->might_have(
- 'artist_1', 'DBICTest::Schema::Artist', {
- 'foreign.artistid' => 'self.artist',
- }, {
- is_foreign_key_constraint => 1,
- },
+__PACKAGE__->might_have('artist_1', 'DBICTest::Schema::Artist',
+ { 'foreign.artistid' => 'self.artist' },
+ { is_foreign_key_constraint => 1 },
);
# Normally this would appear as a FK constraint
-__PACKAGE__->might_have(
- 'cd_1', 'DBICTest::Schema::CD', {
- 'foreign.cdid' => 'self.cd',
- }, {
- is_foreign_key_constraint => 0,
- },
+__PACKAGE__->might_have('cd_1', 'DBICTest::Schema::CD',
+ { 'foreign.cdid' => 'self.cd' },
+ { is_foreign_key_constraint => 0 },
);
# Normally this would appear as a FK constraint
-__PACKAGE__->belongs_to(
- 'cd_3', 'DBICTest::Schema::CD', {
- 'foreign.cdid' => 'self.cd',
- }, {
- is_foreign_key_constraint => 0,
- },
+__PACKAGE__->belongs_to('cd_3', 'DBICTest::Schema::CD',
+ { 'foreign.cdid' => 'self.cd' },
+ { is_foreign_key_constraint => 0 },
);
1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Thu Jan 28 11:26:22 2010
+-- Created on Sat Jan 30 19:18:55 2010
--
;
],
});
},
- qr/Recursive update is not supported over relationships of type multi/,
+ qr/Recursive update is not supported over relationships of type 'multi'/,
'create via update of multi relationships throws an exception'
);
'(
SELECT me.cd, me.track_count, cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track
FROM (
- SELECT me.cd, COUNT (me.trackid) AS track_count,
+ SELECT me.cd, COUNT (me.trackid) AS track_count
FROM track me
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
GROUP BY me.cd
- ) as me
+ ) me
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
)',
tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, tracks.small_dt,
liner_notes.liner_id, liner_notes.notes
FROM (
- SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr,
+ SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr
FROM cd me
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE ( me.cdid IS NOT NULL )
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $artist = $schema->resultset ('Artist')->find ({artistid => 1});
+is ($artist->cds->count, 3, 'Correct number of CDs');
+is ($artist->cds->search_related ('genre')->count, 1, 'Only one of the cds has a genre');
+
+my $queries = 0;
+my $orig_cb = $schema->storage->debugcb;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+
+my $pref = $schema->resultset ('Artist')
+ ->search ({ 'me.artistid' => $artist->id }, { prefetch => { cds => 'genre' } })
+ ->next;
+
+is ($pref->cds->count, 3, 'Correct number of CDs prefetched');
+is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre');
+
+
+is ($queries, 1, 'All happened within one query only');
+$schema->storage->debugcb($orig_cb);
+$schema->storage->debug(0);
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+my $new_rs = $schema->resultset('Artist')->search({
+ 'artwork_to_artist.artist_id' => 1
+}, {
+ join => 'artwork_to_artist'
+});
+lives_ok { $new_rs->count } 'regular search works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->count }
+ '... and chaining off that using join works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->as_subselect_rs->count }
+ '... and chaining off the virtual view works';
+dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count }
+ q{... but chaining off of a virtual view using join doesn't work};
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use lib qw(t/lib);
+use Test::More;
+use Test::Exception;
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+my $rs = $schema->resultset('Artist');
+
+ok !$rs->is_ordered, 'vanilla resultset is not ordered';
+
+# Simple ordering with a single column
+{
+ my $ordered = $rs->search(undef, { order_by => 'artistid' });
+ ok $ordered->is_ordered, 'Simple column ordering detected by is_ordered';
+}
+
+# Hashref order direction
+{
+ my $ordered = $rs->search(undef, { order_by => { -desc => 'artistid' } });
+ ok $ordered->is_ordered, 'resultset with order direction is_ordered';
+}
+
+# Column ordering with literal SQL
+{
+ my $ordered = $rs->search(undef, { order_by => \'artistid DESC' });
+ ok $ordered->is_ordered, 'resultset with literal SQL is_ordered';
+}
+
+# Multiple column ordering
+{
+ my $ordered = $rs->search(undef, { order_by => ['artistid', 'name'] });
+ ok $ordered->is_ordered, 'ordering with multiple columns as arrayref is ordered';
+}
+
+# More complicated ordering
+{
+ my $ordered = $rs->search(undef, {
+ order_by => [
+ { -asc => 'artistid' },
+ { -desc => 'name' },
+ ]
+ });
+ ok $ordered->is_ordered, 'more complicated resultset ordering is_ordered';
+}
+
+# Empty multi-column ordering arrayref
+{
+ my $ordered = $rs->search(undef, { order_by => [] });
+ ok !$ordered->is_ordered, 'ordering with empty arrayref is not ordered';
+}
+
+# Multi-column ordering syntax with empty hashref
+{
+ my $ordered = $rs->search(undef, { order_by => [{}] });
+ ok !$ordered->is_ordered, 'ordering with [{}] is not ordered';
+}
+
+# Remove ordering after being set
+{
+ my $ordered = $rs->search(undef, { order_by => 'artistid' });
+ ok $ordered->is_ordered, 'resultset with ordering applied works..';
+ my $unordered = $ordered->search(undef, { order_by => undef });
+ ok !$unordered->is_ordered, '..and is not ordered with ordering removed';
+}
+
+# Search without ordering
+{
+ my $ordered = $rs->search({ name => 'We Are Goth' }, { join => 'cds' });
+ ok !$ordered->is_ordered, 'WHERE clause but no order_by is not ordered';
+}
+
+# Other functions without ordering
+{
+ # Join
+ my $joined = $rs->search(undef, { join => 'cds' });
+ ok !$joined->is_ordered, 'join but no order_by is not ordered';
+
+ # Group By
+ my $grouped = $rs->search(undef, { group_by => 'rank' });
+ ok !$grouped->is_ordered, 'group_by but no order_by is not ordered';
+
+ # Paging
+ my $paged = $rs->search(undef, { page=> 5 });
+ ok !$paged->is_ordered, 'paging but no order_by is not ordered';
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+
+
+my $schema = DBICTest->init_schema();
+
+my @chain = (
+ {
+ columns => [ 'cdid' ],
+ '+columns' => [ { title_lc => { lower => 'title' } } ],
+ '+select' => [ 'genreid' ],
+ '+as' => [ 'genreid' ],
+ } => 'SELECT me.cdid, LOWER( title ), me.genreid FROM cd me',
+
+ {
+ '+columns' => [ { max_year => { max => 'me.year' }}, ],
+ '+select' => [ { count => 'me.cdid' }, ],
+ '+as' => [ 'cnt' ],
+ } => 'SELECT me.cdid, LOWER( title ), MAX( me.year ), me.genreid, COUNT( me.cdid ) FROM cd me',
+
+ {
+ select => [ { min => 'me.cdid' }, ],
+ as => [ 'min_id' ],
+ } => 'SELECT MIN( me.cdid ) FROM cd me',
+
+ {
+ '+columns' => [ { cnt => { count => 'cdid' } } ],
+ } => 'SELECT MIN( me.cdid ), COUNT ( cdid ) FROM cd me',
+
+ {
+ columns => [ 'year' ],
+ } => 'SELECT me.year FROM cd me',
+);
+
+my $rs = $schema->resultset('CD');
+
+my $testno = 1;
+while (@chain) {
+ my $attrs = shift @chain;
+ my $sql = shift @chain;
+
+ $rs = $rs->search ({}, $attrs);
+
+ is_same_sql_bind (
+ $rs->as_query,
+ "($sql)",
+ [],
+ "Test $testno of SELECT assembly ok",
+ );
+
+ $testno++;
+}
+
+done_testing;
search => \[ "title = ? AND year LIKE ?", 'buahaha', '20%' ],
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)",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
'buahaha',
'20%',
],
artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->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 id FROM artist me LIMIT 1 ) )",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ) )",
],
},
],
},
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 > ?) cd2 )",
+ "( 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 ]
],
},
sqlbind => \[
"( 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
+ (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
+ (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me WHERE id < ?) cd3
WHERE id > ?) cd2
)",
],
},
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 title = ?) cd2)",
+ "(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'
]
{
order_by => [ qw{ foo bar} ],
order_req => 'foo, bar',
- order_inner => 'foo ASC,bar ASC',
+ order_inner => 'foo ASC, bar ASC',
order_outer => 'foo DESC, bar DESC',
},
{
my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
is_same_sql_bind(
$sql, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) ): '1', '1', '3'",
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) )",
[qw/'1' '1' '3'/],
'got correct SQL with all bind parameters (debugcb)'
);
use IO::Handle;
BEGIN {
- eval "use DBIx::Class::Storage::DBI::Replicated; use Test::Moose";
- plan skip_all => "Deps not installed: $@" if $@;
+ eval { require Test::Moose; Test::Moose->import() };
+ plan skip_all => "Need Test::Moose to run this test" if $@;
+ require DBIx::Class;
+
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
use_ok 'DBIx::Class::Storage::DBI::Replicated::Pool';
=> 'configured balancer_type';
}
+### check that all Storage::DBI methods are handled by ::Replicated
+{
+ my @storage_dbi_methods = Class::MOP::Class
+ ->initialize('DBIx::Class::Storage::DBI')->get_all_method_names;
+
+ my @replicated_methods = DBIx::Class::Storage::DBI::Replicated->meta
+ ->get_all_method_names;
+
+# remove constants and OTHER_CRAP
+ @storage_dbi_methods = grep !/^[A-Z_]+\z/, @storage_dbi_methods;
+
+# remove CAG accessors
+ @storage_dbi_methods = grep !/_accessor\z/, @storage_dbi_methods;
+
+# remove DBIx::Class (the root parent, with CAG and stuff) methods
+ my @root_methods = Class::MOP::Class->initialize('DBIx::Class')
+ ->get_all_method_names;
+ my %count;
+ $count{$_}++ for (@storage_dbi_methods, @root_methods);
+
+ @storage_dbi_methods = grep $count{$_} != 2, @storage_dbi_methods;
+
+# make hashes
+ my %storage_dbi_methods;
+ @storage_dbi_methods{@storage_dbi_methods} = ();
+ my %replicated_methods;
+ @replicated_methods{@replicated_methods} = ();
+
+# remove ::Replicated-specific methods
+ for my $method (@replicated_methods) {
+ delete $replicated_methods{$method}
+ unless exists $storage_dbi_methods{$method};
+ }
+ @replicated_methods = keys %replicated_methods;
+
+# check that what's left is implemented
+ %count = ();
+ $count{$_}++ for (@storage_dbi_methods, @replicated_methods);
+
+ if ((grep $count{$_} == 2, @storage_dbi_methods) == @storage_dbi_methods) {
+ pass 'all DBIx::Class::Storage::DBI methods implemented';
+ }
+ else {
+ my @unimplemented = grep $count{$_} == 1, @storage_dbi_methods;
+
+ fail 'the following DBIx::Class::Storage::DBI methods are unimplemented: '
+ . "@unimplemented";
+ }
+}
+
ok $replicated->schema->storage->meta
=> 'has a meta object';