Revision history for DBIx::Class
+ - minor tweak to tests for join edge case
+ - added cascade_copy relationship attribute
+ (sponsored by Airspace Software, http://www.airspace.co.uk/)
+ - clean up set_from_related
+ - made copy() automatically null out auto-inc columns
+
0.05006 2006-02-17 15:32:40
- storage fix for fork() and workaround for Apache::DBI
- made update(\%hash) work on row as well as rs
0.05003 2006-02-08 17:50:20
- add component_class accessors and use them for *_class
- small fixes to Serialize and ResultSetManager
- - prevent accidental table-wide update/delete on row-object
- from PK-less table
- rollback on disconnect, and disconnect on DESTROY
- - fixes to deep search and search_relateduser
0.05002 2006-02-06 12:12:03
- Added recommends for Class::Inspector
0.03004
- Added an || '' to the CDBICompat stringify to avoid null warnings
- Updated name section for manual pods
-
0.03003 2005-11-03 17:00:00
- POD fixes.
- Changed use to require in Relationship/Base to avoid import.
lib/DBIx/Class/ResultSourceProxy/Table.pm
lib/DBIx/Class/Row.pm
lib/DBIx/Class/Schema.pm
-lib/DBIx/Class/Serialize.pm
+lib/DBIx/Class/Serialize/Storable.pm
lib/DBIx/Class/Storage/DBI.pm
lib/DBIx/Class/Storage/DBI/Cursor.pm
+lib/DBIx/Class/Storage/DBI/DB2.pm
+lib/DBIx/Class/Storage/DBI/MSSQL.pm
+lib/DBIx/Class/Storage/DBI/mysql.pm
+lib/DBIx/Class/Storage/DBI/Oracle.pm
+lib/DBIx/Class/Storage/DBI/Pg.pm
+lib/DBIx/Class/Storage/DBI/SQLite.pm
lib/DBIx/Class/Test/SQLite.pm
lib/DBIx/Class/UUIDColumns.pm
+lib/DBIx/Class/UUIDMaker.pm
+lib/DBIx/Class/UUIDMaker/APR/UUID.pm
+lib/DBIx/Class/UUIDMaker/Data/Uniqid.pm
+lib/DBIx/Class/UUIDMaker/Data/UUID.pm
+lib/DBIx/Class/UUIDMaker/UUID.pm
+lib/DBIx/Class/UUIDMaker/Win32/Guidgen.pm
+lib/DBIx/Class/UUIDMaker/Win32API/GUID.pm
lib/DBIx/Class/Validation.pm
lib/SQL/Translator/Parser/DBIx/Class.pm
lib/SQL/Translator/Producer/DBIx/Class/File.pm
Makefile.PL
MANIFEST This list of files
-META.yml
README
t/02pod.t
t/03podcoverage.t.disabled
t/basicrels/11mysql.t
t/basicrels/12pg.t
t/basicrels/13oracle.t
+t/basicrels/145db2.t
t/basicrels/14mssql.t
t/basicrels/15limit.t
t/basicrels/16joins.t
t/basicrels/17join_count.t
t/basicrels/18self_referencial.t
t/basicrels/19uuid.t
+t/basicrels/20unique.t
+t/basicrels/21serialize.t
t/cdbi-sweet-t/08pager.t
t/cdbi-t/01-columns.t
t/cdbi-t/02-Film.t
t/helperrels/11mysql.t
t/helperrels/12pg.t
t/helperrels/13oracle.t
+t/helperrels/145db2.t
t/helperrels/14mssql.t
t/helperrels/15limit.t
t/helperrels/16joins.t
t/helperrels/18self_referencial.t
t/helperrels/19uuid.t
t/helperrels/20unique.t
+t/helperrels/21serialize.t
t/lib/DBICTest.pm
t/lib/DBICTest/BasicRels.pm
t/lib/DBICTest/Extra.pm
t/run/11mysql.tl
t/run/12pg.tl
t/run/13oracle.tl
+t/run/145db2.tl
t/run/14mssql.tl
t/run/15limit.tl
t/run/16joins.tl
t/run/18self_referencial.tl
t/run/19uuid.tl
t/run/20unique.tl
+t/run/21serialize.tl
t/testlib/Actor.pm
t/testlib/ActorAlias.pm
t/testlib/Binary.pm
t/testlib/Order.pm
t/testlib/OtherFilm.pm
t/testlib/PgBase.pm
+META.yml
Brandon Black
+Christopher H. Laco
+
Scotty Allen <scotty@scottyallen.com>
=head1 LICENSE
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/
+ Serialize::Storable
InflateColumn
Relationship
PK
sub storage { shift->schema_instance(@_)->storage; }
sub resultset_instance {
- my $class = shift;
+ my $class = ref $_[0] || $_[0];
my $source = $class->result_source_instance;
if ($source->result_class ne $class) {
$source = $source->new($source);
my ($self, @rest) = @_;
my $ret = $self->next::method(@rest);
- # if all primaries are already populated, skip auto-inc
- my $populated = 0;
- map { $populated++ if defined $self->get_column($_) } $self->primary_columns;
- return $ret if ( $populated == scalar $self->primary_columns );
-
- my ($pri, $too_many) =
- (grep { $self->column_info($_)->{'auto_increment'} }
- $self->primary_columns)
- || $self->primary_columns;
+ my ($pri, $too_many) = grep { !defined $self->get_column($_) } $self->primary_columns;
+ return $ret unless defined $pri; # if all primaries are already populated, skip auto-inc
$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
- if $too_many;
- unless (defined $self->get_column($pri)) {
- $self->throw_exception( "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method" )
- unless $self->can('last_insert_id');
- my $id = $self->last_insert_id;
- $self->throw_exception( "Can't get last insert id" ) unless $id;
- $self->store_column($pri => $id);
- }
+ if defined $too_many;
+
+ my $id = $self->result_source->storage->last_insert_id($self->result_source,$pri);
+ $self->throw_exception( "Can't get last insert id" ) unless $id;
+ $self->store_column($pri => $id);
+
return $ret;
}
=cut
-__PACKAGE__->mk_classdata('sequence');
+sub sequence {
+ my ($self,$seq) = @_;
+ foreach my $pri ($self->primary_columns) {
+ $self->column_info($pri)->{sequence} = $seq;
+ }
+}
1;
__PACKAGE__->load_components(qw/PK::Auto/);
-sub last_insert_id
-{
- my ($self) = @_;
-
- my $dbh = $self->result_source->storage->dbh;
- my $sth = $dbh->prepare_cached("VALUES(IDENTITY_VAL_LOCAL())", {}, 3);
- $sth->execute();
-
- my @res = $sth->fetchrow_array();
-
- return @res ? $res[0] : undef;
-
-}
-
1;
=head1 NAME
-DBIx::Class::PK::Auto::DB2 - Automatic primary key class for DB2
+DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto::DB2 Core/);
- __PACKAGE__->set_primary_key('id');
-
-=head1 DESCRIPTION
-
-This class implements autoincrements for DB2.
+Just load PK::Auto instead; auto-inc is now handled by Storage.
=head1 AUTHORS
-Jess Robinson
+Matt S Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
-package DBIx::Class::PK::Auto::MSSQL;\r
-\r
-use strict;\r
-use warnings;\r
-\r
-use base qw/DBIx::Class/;\r
-\r
-__PACKAGE__->load_components(qw/PK::Auto/);\r
-\r
-sub last_insert_id {\r
- my( $id ) = $_[0]->result_source->storage->dbh->selectrow_array(\r
- 'SELECT @@IDENTITY' );\r
- return $id;\r
-}\r
-\r
-1;\r
-\r
-=head1 NAME \r
-\r
-DBIx::Class::PK::Auto::MSSQL - Automatic primary key class for MSSQL\r
-\r
-=head1 SYNOPSIS\r
-\r
- # In your table classes\r
- __PACKAGE__->load_components(qw/PK::Auto::MSSQL Core/);\r
- __PACKAGE__->set_primary_key('id');\r
-\r
-=head1 DESCRIPTION\r
-\r
-This class implements autoincrements for MSSQL.\r
-\r
-=head1 AUTHORS\r
-\r
-Brian Cassidy <bricas@cpan.org>\r
-\r
-=head1 LICENSE\r
-\r
-You may distribute this code under the same terms as Perl itself.\r
-\r
-=cut\r
+package DBIx::Class::PK::Auto::MSSQL;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/PK::Auto/);
+
+1;
+
+=head1 NAME
+
+DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL
+
+=head1 SYNOPSIS
+
+Just load PK::Auto instead; auto-inc is now handled by Storage.
+
+=head1 AUTHORS
+
+Matt S Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
__PACKAGE__->load_components(qw/PK::Auto/);
-sub last_insert_id {
- return $_[0]->result_source->storage->dbh->{mysql_insertid};
-}
-
1;
=head1 NAME
-DBIx::Class::PK::Auto::MySQL - Automatic primary key class for MySQL
+DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto::MySQL Core/);
- __PACKAGE__->set_primary_key('id');
-
-=head1 DESCRIPTION
-
-This class implements autoincrements for MySQL.
+Just load PK::Auto instead; auto-inc is now handled by Storage.
=head1 AUTHORS
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+Matt S Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
use strict;
use warnings;
-use Carp qw/croak/;
-
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/PK::Auto/);
-sub last_insert_id {
- my $self = shift;
- $self->get_autoinc_seq unless $self->{_autoinc_seq};
- my $sql = "SELECT " . $self->{_autoinc_seq} . ".currval FROM DUAL";
- my ($id) = $self->result_source->storage->dbh->selectrow_array($sql);
- return $id;
-}
-
-sub get_autoinc_seq {
- my $self = shift;
-
- # return the user-defined sequence if known
- if ($self->sequence) {
- return $self->{_autoinc_seq} = $self->sequence;
- }
-
- # look up the correct sequence automatically
- my $dbh = $self->result_source->storage->dbh;
- my $sql = qq{
- SELECT trigger_body FROM ALL_TRIGGERS t
- WHERE t.table_name = ?
- AND t.triggering_event = 'INSERT'
- AND t.status = 'ENABLED'
- };
- # trigger_body is a LONG
- $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
- my $sth = $dbh->prepare($sql);
- $sth->execute( uc($self->result_source->name) );
- while (my ($insert_trigger) = $sth->fetchrow_array) {
- if ($insert_trigger =~ m!(\w+)\.nextval!i ) {
- $self->{_autoinc_seq} = uc($1);
- }
- }
- unless ($self->{_autoinc_seq}) {
- croak "Unable to find a sequence INSERT trigger on table '" . $self->_table_name . "'.";
- }
-}
-
1;
=head1 NAME
-DBIx::Class::PK::Auto::Oracle - Automatic primary key class for Oracle
+DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto::Oracle Core/);
- __PACKAGE__->set_primary_key('id');
-
-=head1 DESCRIPTION
-
-This class implements autoincrements for Oracle.
+Just load PK::Auto instead; auto-inc is now handled by Storage.
=head1 AUTHORS
-Andy Grundman <andy@hybridized.org>
-
-Scott Connelly <scottsweep@yahoo.com>
+Matt S Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
__PACKAGE__->load_components(qw/PK::Auto/);
-sub last_insert_id {
- my $self = shift;
- $self->get_autoinc_seq unless $self->{_autoinc_seq};
- $self->result_source->storage->dbh->last_insert_id(undef,undef,undef,undef,
- {sequence=>$self->{_autoinc_seq}});
-}
-
-sub get_autoinc_seq {
- my $self = shift;
-
- # return the user-defined sequence if known
- if ($self->sequence) {
- return $self->{_autoinc_seq} = $self->sequence;
- }
-
- my @pri = $self->primary_columns;
- my $dbh = $self->result_source->storage->dbh;
- my ($schema,$table) = $self->table =~ /^(.+)\.(.+)$/ ? ($1,$2) : (undef,$self->table);
- while (my $col = shift @pri) {
- my $info = $dbh->column_info(undef,$schema,$table,$col)->fetchrow_arrayref;
- if (defined $info->[12] and $info->[12] =~
- /^nextval\('"?([^"']+)"?'::(?:text|regclass)\)/)
- {
- $self->{_autoinc_seq} = $1;
- last;
- }
- }
-}
-
1;
=head1 NAME
-DBIx::Class::PK::Auto::Pg - Automatic primary key class for PostgreSQL
+DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto::Pg Core/);
- __PACKAGE__->set_primary_key('id');
-
-=head1 DESCRIPTION
-
-This class implements autoincrements for PostgreSQL.
+Just load PK::Auto instead; auto-inc is now handled by Storage.
=head1 AUTHORS
-Marcus Ramberg <m.ramberg@cpan.org>
+Matt S Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
__PACKAGE__->load_components(qw/PK::Auto/);
-sub last_insert_id {
- return $_[0]->result_source->storage->dbh->func('last_insert_rowid');
-}
-
1;
=head1 NAME
-DBIx::Class::PK::Auto::SQLite - Automatic primary key class for SQLite
+DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto::SQLite Core/);
- __PACKAGE__->set_primary_key('id');
-
-=head1 DESCRIPTION
-
-This class implements autoincrements for SQLite.
+Just load PK::Auto instead; auto-inc is now handled by Storage.
=head1 AUTHORS
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+Matt S Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
=cut
sub search_related {
- my $self = shift;
- die "Can't call *_related as class methods" unless ref $self;
- my $rel = shift;
- my $attrs = { };
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %{ pop(@_) } };
- }
- my $rel_obj = $self->relationship_info($rel);
- $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
- $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
-
- $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
- my $query = ((@_ > 1) ? {@_} : shift);
-
- my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
- if (ref $cond eq 'ARRAY') {
- $cond = [ map { my %hash;
- foreach my $key (keys %{$_}) {
- unless ($key =~ m/\./) {
- $hash{"me.$key"} = $_->{$key};
- } else {
- $hash{$key} = $_->{$key};
- }
- }; \%hash; } @$cond ];
- } else {
- foreach my $key (keys %$cond) {
- unless ($key =~ m/\./) {
- $cond->{"me.$key"} = delete $cond->{$key};
- }
- }
- }
- $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
- #use Data::Dumper; warn Dumper($cond);
- #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
- return $self->result_source->related_source($rel
- )->resultset->search($query, $attrs);
+ return shift->related_resultset(shift)->search(@_);
}
=head2 count_related
sub create_related {
my $self = shift;
my $rel = shift;
- return $self->search_related($rel)->create(@_);
+ my $obj = $self->search_related($rel)->create(@_);
+ delete $self->{related_resultsets}->{$rel};
+ return $obj;
}
=head2 new_related
my $f_class = $self->result_source->schema->class($rel_obj->{class});
$self->throw_exception( "Object $f_obj isn't a ".$f_class )
unless $f_obj->isa($f_class);
- foreach my $key (keys %$cond) {
- next if ref $cond->{$key}; # Skip literals and complex conditions
- $self->throw_exception("set_from_related can't handle $key as key")
- unless $key =~ m/^foreign\.([^\.]+)$/;
- my $val = $f_obj->get_column($1);
- $self->throw_exception("set_from_related can't handle ".$cond->{$key}." as value")
- unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
- $self->set_column($1 => $val);
- }
+ $self->set_columns(
+ $self->result_source->resolve_condition(
+ $rel_obj->{cond}, $f_obj, $rel));
return 1;
}
sub delete_related {
my $self = shift;
- return $self->search_related(@_)->delete;
+ my $obj = $self->search_related(@_)->delete;
+ delete $self->{related_resultsets}->{$_[0]};
+ return $obj;
}
1;
+=head2 related_resultset($name)
+
+Returns a L<DBIx::Class::ResultSet> for the relationship named $name.
+
+ $rs = My::Table->related_resultset('related_table');
+
+=cut
+
+sub related_resultset {
+ my $self = shift;
+ $self->throw_exception("Can't call *_related as class methods") unless ref $self;
+ my $rel = shift;
+ $self->{related_resultsets} ||= {};
+ #use Data::Dumper; warn "related_resultsets: ", Dumper $self->{related_resultsets};
+ my $resultsets = $self->{related_resultsets};
+ if( !exists $resultsets->{$rel} ) {
+
+ #warn "creating related resultset for relation '$rel'", \$self;
+ my $source = $self->result_source;
+ # if relation exists but resultset doesn't, create the resultset
+
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+
+ my $rel_obj = $self->relationship_info($rel);
+ $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
+ $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
+
+ $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
+ my $query = ((@_ > 1) ? {@_} : shift);
+
+ my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
+ if (ref $cond eq 'ARRAY') {
+ $cond = [ map { my %hash;
+ foreach my $key (keys %{$_}) {
+ unless ($key =~ m/\./) {
+ $hash{"me.$key"} = $_->{$key};
+ } else {
+ $hash{$key} = $_->{$key};
+ }
+ }; \%hash; } @$cond ];
+ } else {
+ foreach my $key (keys %$cond) {
+ unless ($key =~ m/\./) {
+ $cond->{"me.$key"} = delete $cond->{$key};
+ }
+ }
+ }
+ $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
+ #use Data::Dumper; warn Dumper($cond);
+ #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
+ $resultsets->{$rel} =
+ $self->result_source->related_source($rel)->resultset->search($query, $attrs);
+ }
+ return $resultsets->{$rel};
+}
+
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
{ accessor => 'multi',
join_type => 'LEFT',
cascade_delete => 1,
+ cascade_copy => 1,
%{$attrs||{}} } );
}
my $self = shift;
#use Data::Dumper;warn Dumper(@_);
+ my $rs;
+ if( @_ ) {
+
+ my $attrs = { %{$self->{attrs}} };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %$attrs, %{ pop(@_) } };
+ }
- my $attrs = { %{$self->{attrs}} };
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %$attrs, %{ pop(@_) } };
- }
-
- my $where = (@_ ? ((@_ == 1 || ref $_[0] eq "HASH") ? shift : {@_}) : undef());
- if (defined $where) {
- $where = (defined $attrs->{where}
+ my $where = (@_ ? ((@_ == 1 || ref $_[0] eq "HASH") ? shift : {@_}) : undef());
+ if (defined $where) {
+ $where = (defined $attrs->{where}
? { '-and' =>
[ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
$where, $attrs->{where} ] }
: $where);
- $attrs->{where} = $where;
- }
-
- my $rs = (ref $self)->new($self->result_source, $attrs);
+ $attrs->{where} = $where;
+ }
+ $rs = (ref $self)->new($self->result_source, $attrs);
+ }
+ else {
+ $rs = $self;
+ $rs->reset();
+ }
return (wantarray ? $rs->all : $rs);
}
$query->{$self->{attrs}{alias}.'.'.$_} = delete $query->{$_};
}
#warn Dumper($query);
- return $self->search($query,$attrs)->next;
+ return (keys %$attrs
+ ? $self->search($query,$attrs)->single
+ : $self->single($query));
}
=head2 search_related
=cut
sub search_related {
- my ($self, $rel, @rest) = @_;
- my $rel_obj = $self->result_source->relationship_info($rel);
- $self->throw_exception(
- "No such relationship ${rel} in search_related")
- unless $rel_obj;
- my $rs = $self->search(undef, { join => $rel });
- my $alias = ($rs->{attrs}{seen_join}{$rel} > 1
- ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
- : $rel);
- return $self->result_source->schema->resultset($rel_obj->{class}
- )->search( undef,
- { %{$rs->{attrs}},
- alias => $alias,
- select => undef(),
- as => undef() }
- )->search(@rest);
+ return shift->related_resultset(shift)->search(@_);
}
=head2 cursor
$attrs->{where},$attrs);
}
+=head2 single
+
+Inflates the first result without creating a cursor
+
+=cut
+
+sub single {
+ my ($self, $extra) = @_;
+ my ($attrs) = $self->{attrs};
+ $attrs = { %$attrs };
+ if ($extra) {
+ if (defined $attrs->{where}) {
+ $attrs->{where} = {
+ '-and'
+ => [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
+ delete $attrs->{where}, $extra ]
+ };
+ } else {
+ $attrs->{where} = $extra;
+ }
+ }
+ my @data = $self->result_source->storage->select_single(
+ $self->{from}, $attrs->{select},
+ $attrs->{where},$attrs);
+ return (@data ? $self->_construct_object(@data) : ());
+}
+
+
=head2 search_like
Perform a search, but use C<LIKE> instead of equality as the condition. Note
sub next {
my ($self) = @_;
+ my $cache = $self->get_cache;
+ if( @$cache ) {
+ $self->{all_cache_position} ||= 0;
+ my $obj = $cache->[$self->{all_cache_position}];
+ $self->{all_cache_position}++;
+ return $obj;
+ }
my @row = $self->cursor->next;
# warn Dumper(\@row); use Data::Dumper;
return unless (@row);
sub _construct_object {
my ($self, @row) = @_;
+ my @row_orig = @row; # copy @row for key comparison later, because @row will change
my @as = @{ $self->{attrs}{as} };
#warn "@cols -> @row";
my $info = [ {}, {} ];
foreach my $as (@as) {
+ my $rs = $self;
my $target = $info;
my @parts = split(/\./, $as);
my $col = pop(@parts);
foreach my $p (@parts) {
$target = $target->[1]->{$p} ||= [];
+
+ # if cache is enabled, fetch inflated objs for prefetch
+ if( $rs->{attrs}->{cache} ) {
+ my $rel_info = $rs->result_source->relationship_info($p);
+ my $cond = $rel_info->{cond};
+ my $parent_rs = $rs;
+ $rs = $rs->related_resultset($p);
+ $rs->{attrs}->{cache} = 1;
+ my @objs = ();
+
+ # populate related resultset's cache if empty
+ if( !@{ $rs->get_cache } ) {
+ $rs->all;
+ }
+
+ # get ordinals for pk columns in $row, so values can be compared
+ my $map = {};
+ keys %$cond;
+ my $re = qr/^\w+\./;
+ while( my( $rel_key, $pk ) = ( each %$cond ) ) {
+ $rel_key =~ s/$re//;
+ $pk =~ s/$re//;
+ $map->{$rel_key} = $pk;
+ } #die Dumper $map;
+
+ keys %$map;
+ while( my( $rel_key, $pk ) = each( %$map ) ) {
+ my $i = 0;
+ foreach my $col ( $parent_rs->result_source->columns ) {
+ if( $col eq $pk ) {
+ $map->{$rel_key} = $i;
+ }
+ $i++;
+ }
+ } #die Dumper $map;
+
+ $rs->reset(); # reset cursor/cache position
+
+ # get matching objects for inflation
+ OBJ: while( my $rel_obj = $rs->next ) {
+ keys %$map;
+ KEYS: while( my( $rel_key, $ordinal ) = each %$map ) {
+ # use get_column to avoid auto inflation (want scalar value)
+ if( $rel_obj->get_column($rel_key) ne $row_orig[$ordinal] ) {
+ next OBJ;
+ }
+ push @objs, $rel_obj;
+ }
+ }
+ $target->[0] = \@objs;
+ }
}
- $target->[0]->{$col} = shift @row;
+ $target->[0]->{$col} = shift @row
+ if ref($target->[0]) ne 'ARRAY'; # arrayref is pre-inflated objects, do not overwrite
}
#use Data::Dumper; warn Dumper(\@as, $info);
my $new = $self->result_source->result_class->inflate_result(
my $self = shift;
return $self->search(@_)->count if @_ && defined $_[0];
unless (defined $self->{count}) {
+ return scalar @{ $self->get_cache }
+ if @{ $self->get_cache };
my $group_by;
my $select = { 'count' => '*' };
if( $group_by = delete $self->{attrs}{group_by} ) {
sub all {
my ($self) = @_;
+ return @{ $self->get_cache }
+ if @{ $self->get_cache };
+ if( $self->{attrs}->{cache} ) {
+ my @obj = map { $self->_construct_object(@$_); }
+ $self->cursor->all;
+ $self->set_cache( \@obj );
+ return @{ $self->get_cache };
+ }
return map { $self->_construct_object(@$_); }
$self->cursor->all;
}
sub reset {
my ($self) = @_;
+ $self->{all_cache_position} = 0;
$self->cursor->reset;
return $self;
}
return $row;
}
+=head2 get_cache
+
+Gets the contents of the cache for the resultset.
+
+=cut
+
+sub get_cache {
+ my $self = shift;
+ return $self->{all_cache} || [];
+}
+
+=head2 set_cache
+
+Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset.
+
+=cut
+
+sub set_cache {
+ my ( $self, $data ) = @_;
+ $self->throw_exception("set_cache requires an arrayref")
+ if ref $data ne 'ARRAY';
+ my $result_class = $self->result_source->result_class;
+ foreach( @$data ) {
+ $self->throw_exception("cannot cache object of type '$_', expected '$result_class'")
+ if ref $_ ne $result_class;
+ }
+ $self->{all_cache} = $data;
+}
+
+=head2 clear_cache
+
+Clears the cache for the resultset.
+
+=cut
+
+sub clear_cache {
+ my $self = shift;
+ $self->set_cache([]);
+}
+
+=head2 related_resultset
+
+Returns a related resultset for the supplied relationship name.
+
+ $rs = $rs->related_resultset('foo');
+
+=cut
+
+sub related_resultset {
+ my ( $self, $rel, @rest ) = @_;
+ $self->{related_resultsets} ||= {};
+ my $resultsets = $self->{related_resultsets};
+ if( !exists $resultsets->{$rel} ) {
+ #warn "fetching related resultset for rel '$rel'";
+ my $rel_obj = $self->result_source->relationship_info($rel);
+ $self->throw_exception(
+ "search_related: result source '" . $self->result_source->name .
+ "' has no such relationship ${rel}")
+ unless $rel_obj; #die Dumper $self->{attrs};
+ my $rs;
+ if( $self->{attrs}->{cache} ) {
+ $rs = $self->search(undef);
+ }
+ else {
+ $rs = $self->search(undef, { join => $rel });
+ }
+ #use Data::Dumper; die Dumper $rs->{attrs};#$rs = $self->search( undef );
+ #use Data::Dumper; warn Dumper $self->{attrs}, Dumper $rs->{attrs};
+ my $alias = (defined $rs->{attrs}{seen_join}{$rel}
+ && $rs->{attrs}{seen_join}{$rel} > 1
+ ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
+ : $rel);
+ $resultsets->{$rel} =
+ $self->result_source->schema->resultset($rel_obj->{class}
+ )->search( undef,
+ { %{$rs->{attrs}},
+ alias => $alias,
+ select => undef(),
+ as => undef() }
+ )->search(@rest);
+ }
+ return $resultsets->{$rel};
+}
+
=head2 throw_exception
See Schema's throw_exception
use Carp::Clan qw/^DBIx::Class/;
use Storable;
+use Scalar::Util qw/weaken/;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/AccessorGroup/);
sub new {
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
- my $new = bless({ %{$attrs || {}} }, $class);
+ my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
$new->{resultset_class} ||= 'DBIx::Class::ResultSet';
$new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
$new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
#warn "$self $k $for $v";
$ret{$k} = $for->get_column($v);
#warn %ret;
+ } elsif (ref $as) { # reverse object
+ $ret{$v} = $as->get_column($k);
} else {
$ret{"${as}.${k}"} = "${for}.${v}";
}
sub resultset {
my $self = shift;
- return $self->resultset_class->new($self, $self->{resultset_attributes});
+ return $self->{_resultset} if ref $self->{_resultset} eq $self->resultset_class;
+ return $self->{_resultset} = do {
+ my $rs = $self->resultset_class->new($self, $self->{resultset_attributes});
+ weaken $rs->result_source;
+ $rs;
+ };
}
=head2 throw_exception
$source->storage->insert($source->from, { $self->get_columns });
$self->in_storage(1);
$self->{_dirty_columns} = {};
+ $self->{related_resultsets} = {};
return $self;
}
$self->throw_exception("Can't update ${self}: updated more than one row");
}
$self->{_dirty_columns} = {};
+ $self->{related_resultsets} = {};
return $self;
}
sub copy {
my ($self, $changes) = @_;
- my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
+ $changes ||= {};
+ my $col_data = { %{$self->{_column_data}} };
+ foreach my $col (keys %$col_data) {
+ delete $col_data->{$col}
+ if $self->result_source->column_info($col)->{is_auto_increment};
+ }
+ my $new = bless({ _column_data => $col_data }, ref $self);
$new->set_column($_ => $changes->{$_}) for keys %$changes;
- return $new->insert;
+ $new->insert;
+ foreach my $rel ($self->result_source->relationships) {
+ my $rel_info = $self->result_source->relationship_info($rel);
+ if ($rel_info->{attrs}{cascade_copy}) {
+ my $resolved = $self->result_source->resolve_condition(
+ $rel_info->{cond}, $rel, $new);
+ foreach my $related ($self->search_related($rel)) {
+ $related->copy($resolved);
+ }
+ }
+ }
+ $new;
}
=head2 store_column
},
ref $class || $class);
my $schema;
- PRE: foreach my $pre (keys %{$prefetch||{}}) {
- my $pre_source = $source->related_source($pre);
- $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
- my $fetched;
- unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
- and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
- {
- $fetched = $pre_source->result_class->inflate_result(
- $pre_source, @{$prefetch->{$pre}});
+ foreach my $pre (keys %{$prefetch||{}}) {
+ my $pre_val = $prefetch->{$pre};
+ # if first prefetch item is arrayref, assume this is a has_many prefetch
+ # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure)
+ if( ref $pre_val->[0] eq 'ARRAY' ) {
+ $new->related_resultset($pre)->set_cache( $pre_val->[0] );
}
- 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("Don't know how to store prefetched $pre");
+ else {
+ my $pre_source = $source->related_source($pre);
+ $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source;
+ my $fetched;
+ unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
+ and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
+ {
+ $fetched = $pre_source->result_class->inflate_result(
+ $pre_source, @{$prefetch->{$pre}});
+ }
+ 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;
+ } elsif ($accessor eq 'multi') {
+ $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'");
+ } else {
+ $class->throw_exception("Prefetch not supported with accessor '$accessor'");
+ }
}
}
return $new;
-package DBIx::Class::Serialize;
+package DBIx::Class::Serialize::Storable;
use strict;
-use Storable qw/freeze thaw/;
+use Storable;
sub STORABLE_freeze {
my ($self,$cloning) = @_;
- #return if $cloning;
my $to_serialize = { %$self };
delete $to_serialize->{result_source};
- return (freeze($to_serialize));
+ return (Storable::freeze($to_serialize));
}
sub STORABLE_thaw {
my ($self,$cloning,$serialized) = @_;
- %$self = %{ thaw($serialized) };
- $self->result_source($self->result_source_instance);
+ %$self = %{ Storable::thaw($serialized) };
+ $self->result_source($self->result_source_instance) if $self->can('result_source_instance');
}
1;
=head1 NAME
- DBIx::Class::Serialize - hooks for Storable freeze/thaw (EXPERIMENTAL)
+ DBIx::Class::Serialize::Storable - hooks for Storable freeze/thaw (EXPERIMENTAL)
=head1 SYNOPSIS
# in a table class definition
- __PACKAGE__->load_components(qw/Serialize/);
+ __PACKAGE__->load_components(qw/Serialize::Storable/);
# meanwhile, in a nearby piece of code
my $obj = $schema->resultset('Foo')->find(12);
my ($self) = @_;
my @info = @{$self->connect_info || []};
$self->_dbh($self->_connect(@info));
-
+ my $driver = $self->_dbh->{Driver}->{Name};
+ eval "require DBIx::Class::Storage::DBI::${driver}";
+ unless ($@) {
+ bless $self, "DBIx::Class::Storage::DBI::${driver}";
+ }
# if on-connect sql statements are given execute them
foreach my $sql_statement (@{$self->on_connect_do || []}) {
$self->_dbh->do($sql_statement);
return \%result;
}
+sub last_insert_id {
+ my ($self, $row) = @_;
+
+ return $self->dbh->func('last_insert_rowid');
+
+}
+
+
+
sub DESTROY { shift->disconnect }
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::DB2;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub last_insert_id
+{
+ my ($self) = @_;
+
+ my $dbh = $self->_dbh;
+ my $sth = $dbh->prepare_cached("VALUES(IDENTITY_VAL_LOCAL())", {}, 3);
+ $sth->execute();
+
+ my @res = $sth->fetchrow_array();
+
+ return @res ? $res[0] : undef;
+
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::DB2 - Automatic primary key class for DB2
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->set_primary_key('id');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for DB2.
+
+=head1 AUTHORS
+
+Jess Robinson
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Storage::DBI::MSSQL;\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use base qw/DBIx::Class::Storage::DBI/;\r
+\r
+# __PACKAGE__->load_components(qw/PK::Auto/);\r
+\r
+sub last_insert_id {\r
+ my( $id ) = $_[0]->_dbh->selectrow_array('SELECT @@IDENTITY' );\r
+ return $id;\r
+}\r
+\r
+1;\r
+\r
+=head1 NAME \r
+\r
+DBIx::Class::Storage::DBI::MSSQL - Automatic primary key class for MSSQL\r
+\r
+=head1 SYNOPSIS\r
+\r
+ # In your table classes\r
+ __PACKAGE__->load_components(qw/PK::Auto Core/);\r
+ __PACKAGE__->set_primary_key('id');\r
+\r
+=head1 DESCRIPTION\r
+\r
+This class implements autoincrements for MSSQL.\r
+\r
+=head1 AUTHORS\r
+\r
+Brian Cassidy <bricas@cpan.org>\r
+\r
+=head1 LICENSE\r
+\r
+You may distribute this code under the same terms as Perl itself.\r
+\r
+=cut\r
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub last_insert_id {
+ my ($self,$source,$col) = @_;
+ my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ my $sql = "SELECT " . $seq . ".currval FROM DUAL";
+ my ($id) = $self->_dbh->selectrow_array($sql);
+ return $id;
+}
+
+sub get_autoinc_seq {
+ my ($self,$source,$col) = @_;
+
+ # look up the correct sequence automatically
+ my $dbh = $self->_dbh;
+ my $sql = q{
+ SELECT trigger_body FROM ALL_TRIGGERS t
+ WHERE t.table_name = ?
+ AND t.triggering_event = 'INSERT'
+ AND t.status = 'ENABLED'
+ };
+ # trigger_body is a LONG
+ $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
+ my $sth = $dbh->prepare($sql);
+ $sth->execute( uc($source->name) );
+ while (my ($insert_trigger) = $sth->fetchrow_array) {
+ return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
+ }
+ croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'.";
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->sequence('mysequence');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Oracle.
+
+=head1 AUTHORS
+
+Andy Grundman <andy@hybridized.org>
+
+Scott Connelly <scottsweep@yahoo.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Storage::DBI::Pg;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub last_insert_id {
+ my ($self,$source,$col) = @_;
+ my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ $self->_dbh->last_insert_id(undef,undef,undef,undef, {sequence => $seq});
+}
+
+sub get_autoinc_seq {
+ my ($self,$source,$col) = @_;
+
+ my @pri = $source->primary_columns;
+ my $dbh = $self->_dbh;
+ my ($schema,$table) = $source->name =~ /^(.+)\.(.+)$/ ? ($1,$2)
+ : (undef,$source->name);
+ while (my $col = shift @pri) {
+ my $info = $dbh->column_info(undef,$schema,$table,$col)->fetchrow_arrayref;
+ if (defined $info->[12] and $info->[12] =~
+ /^nextval\('"?([^"']+)"?'::(?:text|regclass)\)/)
+ {
+ return $1;
+ }
+ }
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->sequence('mysequence');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for PostgreSQL.
+
+=head1 AUTHORS
+
+Marcus Ramberg <m.ramberg@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Storage::DBI::SQLite;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+sub last_insert_id {
+ return $_[0]->dbh->func('last_insert_rowid');
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::PK::Auto::SQLite - Automatic primary key class for SQLite
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto::SQLite Core/);
+ __PACKAGE__->set_primary_key('id');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for SQLite.
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Storage::DBI::mysql;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub last_insert_id {
+ return $_[0]->_dbh->{mysql_insertid};
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::mysql - Automatic primary key class for MySQL
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->set_primary_key('id');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for MySQL.
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
package DBIx::Class::UUIDColumns;
use base qw/DBIx::Class/;
-use Data::UUID;
-
__PACKAGE__->mk_classdata( 'uuid_auto_columns' => [] );
+__PACKAGE__->mk_classdata( 'uuid_maker' );
+__PACKAGE__->uuid_class( __PACKAGE__->_find_uuid_module );
+
+# be compatible with Class::DBI::UUID
+sub uuid_columns {
+ my $self = shift;
+ for (@_) {
+ $self->throw_exception("column $_ doesn't exist") unless $self->has_column($_);
+ }
+ $self->uuid_auto_columns(\@_);
+}
+
+sub uuid_class {
+ my ($self, $class) = @_;
+
+ if ($class) {
+ $class = "DBIx::Class::UUIDMaker$class" if $class =~ /^::/;
+
+ if (!eval "require $class") {
+ $self->throw_exception("$class could not be loaded: $@");
+ } elsif (!$class->isa('DBIx::Class::UUIDMaker')) {
+ $self->throw_exception("$class is not a UUIDMaker subclass");
+ } else {
+ $self->uuid_maker($class->new);
+ };
+ };
+
+ return ref $self->uuid_maker;
+};
+
+sub insert {
+ my $self = shift;
+ for my $column (@{$self->uuid_auto_columns}) {
+ $self->store_column( $column, $self->get_uuid )
+ unless defined $self->get_column( $column );
+ }
+ $self->next::method(@_);
+}
+
+sub get_uuid {
+ return shift->uuid_maker->as_string;
+}
+
+sub _find_uuid_module {
+ if (eval{require Data::UUID}) {
+ return '::Data::UUID';
+ } elsif ($^O ne 'openbsd' && eval{require APR::UUID}) {
+ # APR::UUID on openbsd causes some as yet unfound nastyness for XS
+ return '::APR::UUID';
+ } elsif (eval{require UUID}) {
+ return '::UUID';
+ } elsif (eval{
+ # squelch the 'too late for INIT' warning in Win32::API::Type
+ local $^W = 0;
+ require Win32::Guidgen;
+ }) {
+ return '::Win32::Guidgen';
+ } elsif (eval{require Win32API::GUID}) {
+ return '::Win32API::GUID';
+ } else {
+ shift->throw_exception('no suitable uuid module could be found')
+ };
+};
+
+1;
+__END__
=head1 NAME
=head1 SYNOPSIS
- pacakge Artist;
+ package Artist;
__PACKAGE__->load_components(qw/UUIDColumns Core DB/);
__PACKAGE__->uuid_columns( 'artist_id' );
This L<DBIx::Class> component resembles the behaviour of
L<Class::DBI::UUID>, to make some columns implicitly created as uuid.
+When loaded, C<UUIDColumns> will search for a suitable uuid generation module
+from the following list of supported modules:
+
+ Data::UUID
+ APR::UUID*
+ UUID
+ Win32::Guidgen
+ Win32API::GUID
+
+If no supporting module can be found, an exception will be thrown.
+
+*APR::UUID will not be loaded under OpenBSD due to an as yet unidentified XS
+issue.
+
+If you would like to use a specific module, you can set C<uuid_class>:
+
+ __PACKAGE__->uuid_class('::Data::UUID');
+ __PACKAGE__->uuid_class('MyUUIDGenerator');
+
Note that the component needs to be loaded before Core.
=head1 METHODS
-=head2 uuid_columns
+=head2 uuid_columns(@columns)
-=cut
+Takes a list of columns to be filled with uuids during insert.
-# be compatible with Class::DBI::UUID
-sub uuid_columns {
- my $self = shift;
- for (@_) {
- $self->throw_exception("column $_ doesn't exist") unless $self->has_column($_);
- }
- $self->uuid_auto_columns(\@_);
-}
+ __PACKAGE__->uuid_columns('id');
-sub insert {
- my $self = shift;
- for my $column (@{$self->uuid_auto_columns}) {
- $self->store_column( $column, $self->get_uuid )
- unless defined $self->get_column( $column );
- }
- $self->next::method(@_);
-}
+=head2 uuid_class($classname)
-sub get_uuid {
- return Data::UUID->new->to_string(Data::UUID->new->create),
-}
+Takes the name of a UUIDMaker subclass to be used for uuid value generation.
+This can be a fully qualified class name, or a shortcut name starting with ::
+that matches one of the available DBIx::Class::UUIDMaker subclasses:
+
+ __PACKAGE__->uuid_class('CustomUUIDGenerator');
+ # loads CustomeUUIDGenerator
+
+ __PACKAGE->uuid_class('::Data::UUID');
+ # loads DBIx::Class::UUIDMaker::Data::UUID;
+
+Note that C<uuid_class> chacks to see that the specified class isa
+DBIx::Class::UUIDMaker subbclass and throws and exception if it isn't.
+
+=head2 uuid_maker
+
+Returns the current UUIDMaker instance for the given module.
+
+ my $uuid = __PACKAGE__->uuid_maker->as_string;
+
+=head1 SEE ALSO
+
+L<DBIx::Class::UUIDMaker>
=head1 AUTHORS
Chia-liang Kao <clkao@clkao.org>
+Chris Laco <claco@chrislaco.com>
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-1;
--- /dev/null
+package DBIx::Class::UUIDMaker;
+
+sub new {
+ return bless {}, shift;
+};
+
+sub as_string {
+ return undef;
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker - UUID wrapper module
+
+=head1 SYNOPSIS
+
+ package CustomUUIDMaker;
+ use base qw/DBIx::Class::/;
+
+ sub as_string {
+ my $uuid;
+ ...magic encantations...
+ return $uuid;
+ };
+
+=head1 DESCRIPTION
+
+DBIx::Class::UUIDMaker is a base class used by the various uuid generation
+subclasses.
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::UUIDMaker>,
+L<DBIx::Class::UUIDMaker::UUID>,
+L<DBIx::Class::UUIDMaker::APR::UUID>,
+L<DBIx::Class::UUIDMaker::Data::UUID>,
+L<DBIx::Class::UUIDMaker::Win32::Guidgen>,
+L<DBIx::Class::UUIDMaker::Win32API::GUID>,
+L<DBIx::Class::UUIDMaker::Data::Uniqid>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::APR::UUID;
+use base qw/DBIx::Class::UUIDMaker/;
+use APR::UUID ();
+
+sub as_string {
+ return APR::UUID->new->format;
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::APR::UUID - Create uuids using APR::UUID
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::APR::UUID');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses APR::UUID to generate uuid
+strings in the following format:
+
+ 098f2470-bae0-11cd-b579-08002b30bfeb
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<APR::UUID>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::Data::UUID;
+use base qw/DBIx::Class::UUIDMaker/;
+use Data::UUID ();
+
+sub as_string {
+ return Data::UUID->new->to_string(Data::UUID->new->create);
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::Data::UUID - Create uuids using Data::UUID
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::Data::UUID');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses Data::UUID to generate uuid
+strings in the following format:
+
+ 098f2470-bae0-11cd-b579-08002b30bfeb
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<Data::UUID>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::Data::Uniqid;
+use base qw/DBIx::Class::UUIDMaker/;
+use Data::Uniqid ();
+
+sub as_string {
+ return Data::Uniqid->luniqid;
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::Data::Uniqid - Create uuids using Data::Uniqid
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::Data::Uniqid');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses Data::Uniqid to generate uuid
+strings using Data::Uniqid::luniqid.
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<Data::Data::Uniqid>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::UUID;
+use base qw/DBIx::Class::UUIDMaker/;
+use UUID ();
+
+sub as_string {
+ my ($uuid, $uuidstring);
+ UUID::generate($uuid);
+ UUID::unparse($uuid, $uuidstring);
+
+ return $uuidstring;
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::UUID - Create uuids using UUID
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::UUID');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses UUID to generate uuid
+strings in the following format:
+
+ 098f2470-bae0-11cd-b579-08002b30bfeb
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<UUID>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::Win32::Guidgen;
+use base qw/DBIx::Class::UUIDMaker/;
+use Win32::Guidgen ();
+
+sub as_string {
+ my $uuid = Win32::Guidgen::create();
+ $uuid =~ s/(^\{|\}$)//g;
+
+ return $uuid;
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::Win32:::Guidgen - Create uuids using Win32::Guidgen
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::Win32::Guidgen');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses Win32::Guidgen to generate uuid
+strings in the following format:
+
+ 098f2470-bae0-11cd-b579-08002b30bfeb
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<Win32::Guidgen>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::UUIDMaker::Win32API::GUID;
+use base qw/DBIx::Class::UUIDMaker/;
+use Win32API::GUID ();
+
+sub as_string {
+ return Win32API::GUID::CreateGuid();
+};
+
+1;
+__END__
+
+=head1 NAME
+
+DBIx::Class::UUIDMaker::Win32API:::GUID - Create uuids using Win32API::GUID
+
+=head1 SYNOPSIS
+
+ package Artist;
+ __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
+ __PACKAGE__->uuid_columns( 'artist_id' );
+ __PACKAGE__->uuid_class('::Win32API::GUID');
+
+=head1 DESCRIPTION
+
+This DBIx::Class::UUIDMaker subclass uses Win32API::GUID to generate uuid
+strings in the following format:
+
+ 098f2470-bae0-11cd-b579-08002b30bfeb
+
+=head1 METHODS
+
+=head2 as_string
+
+Returns the new uuid as a string.
+
+=head1 SEE ALSO
+
+L<Win32API::GUID>
+
+=head1 AUTHOR
+
+Chris Laco <claco@chrislaco.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
--- /dev/null
+#!/usr/bin/perl
+
+die "must be run from DBIx::Class root dir" unless -d 't/run';
+
+gen_tests($_) for qw/BasicRels HelperRels/;
+
+sub gen_tests {
+ my $variant = shift;
+ my $dir = lc $variant;
+ system("rm -f t/$dir/*.t");
+
+ foreach my $test (map { m[^t/run/(.+)\.tl$]; $1 } split(/\n/, `ls t/run/*.tl`)) {
+ open(my $fh, '>', "t/$dir/${test}.t") or die $!;
+ print $fh <<"EOF";
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::$variant;
+
+require "t/run/${test}.tl";
+run_tests(DBICTest->schema);
+EOF
+ close $fh;
+ }
+}
\ No newline at end of file
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/145db2.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/20unique.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/21serialize.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/22cache.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/22cascade_copy.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/145db2.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/21serialize.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/22cascade_copy.tl";
+run_tests(DBICTest->schema);
use base 'DBIx::Class::Core';
+__PACKAGE__->load_components('PK::Auto');
+
DBICTest::Schema::Artist->table('artist');
DBICTest::Schema::Artist->add_columns(
'artistid' => {
DBICTest::Schema::Artist->add_relationship(
cds => 'DBICTest::Schema::CD',
{ 'foreign.artist' => 'self.artistid' },
- { order_by => 'year', join_type => 'LEFT', cascade_delete => 1 }
+ { order_by => 'year', join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1, accessor => 'multi' }
);
DBICTest::Schema::Artist->add_relationship(
twokeys => 'DBICTest::Schema::TwoKeys',
- { 'foreign.artist' => 'self.artistid' }
+ { 'foreign.artist' => 'self.artistid' },
+ { cascade_copy => 1 }
);
DBICTest::Schema::Artist->add_relationship(
onekeys => 'DBICTest::Schema::OneKey',
DBICTest::Schema::CD->add_relationship(
tags => 'DBICTest::Schema::Tag',
{ 'foreign.cd' => 'self.cdid' },
- { join_type => 'LEFT', cascade_delete => 1 }
+ { join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1 }
);
#DBICTest::Schema::CD->might_have(liner_notes => 'DBICTest::Schema::LinerNotes' => qw/notes/);
DBICTest::Schema::CD->add_relationship(
use base 'DBIx::Class::Core';
+__PACKAGE__->load_components('PK::Auto');
+
DBICTest::Schema::CD->table('cd');
DBICTest::Schema::CD->add_columns(
'cdid' => {
);
DBICTest::Schema::Artist->has_many(
'artist_undirected_maps', 'DBICTest::Schema::ArtistUndirectedMap',
- [{'foreign.id1' => 'self.artistid'}, {'foreign.id2' => 'self.artistid'}]
+ [{'foreign.id1' => 'self.artistid'}, {'foreign.id2' => 'self.artistid'}],
+ { cascade_copy => 0 } # this would *so* not make sense
);
DBICTest::Schema::ArtistUndirectedMap->belongs_to(
'artist1', 'DBICTest::Schema::Artist', 'id1');
use base 'DBIx::Class::Core';
+__PACKAGE__->load_components('PK::Auto');
+
DBICTest::Schema::OneKey->table('onekey');
DBICTest::Schema::OneKey->add_columns(
'id' => {
use base qw/DBIx::Class::Core/;
+__PACKAGE__->load_components('PK::Auto');
+
DBICTest::Schema::Tag->table('tags');
DBICTest::Schema::Tag->add_columns(
'tagid' => {
- data_type => 'varchar',
+ data_type => 'integer',
is_auto_increment => 1,
},
'cd' => {
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Mon Feb 6 01:07:16 2006
+-- Created on Tue Feb 14 16:16:19 2006
--
BEGIN TRANSACTION;
-- Table: tags
--
CREATE TABLE tags (
- tagid varchar NOT NULL,
+ tagid INTEGER PRIMARY KEY NOT NULL,
cd integer NOT NULL,
- tag varchar NOT NULL,
- PRIMARY KEY (tagid)
+ tag varchar NOT NULL
);
--
plan tests => 2;
$schema->class("Artist")->load_components(qw/PK::Auto::SQLite/);
+ # Should just be PK::Auto but this ensures the compat shim works
# add an artist without primary key to test Auto
my $artist = $schema->resultset("Artist")->create( { name => 'Auto' } );
#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
-MySQLTest::Artist->load_components('PK::Auto::MySQL');
+MySQLTest::Artist->load_components('PK::Auto');
# test primary key handling
my $new = MySQLTest::Artist->create({ name => 'foo' });
$dbh->do("CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(255), charfield CHAR(10));");
-PgTest::Artist->load_components('PK::Auto::Pg');
+PgTest::Artist->load_components('PK::Auto');
my $new = PgTest::Artist->create({ name => 'foo' });
END;
});
-OraTest::Artist->load_components('PK::Auto::Oracle');
+OraTest::Artist->load_components('PK::Auto');
# test primary key handling
my $new = OraTest::Artist->create({ name => 'foo' });
--- /dev/null
+sub run_tests {
+my $schema = shift;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/};
+
+#warn "$dsn $user $pass";
+
+plan skip_all, 'Set $ENV{DBICTEST_DB2_DSN}, _USER and _PASS to run this test'
+ unless ($dsn && $user);
+
+plan tests => 5;
+
+DBICTest::Schema->compose_connection('DB2Test' => $dsn, $user, $pass);
+
+my $dbh = DB2Test->schema->storage->dbh;
+
+$dbh->do("DROP TABLE artist;");
+
+$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10));");
+
+#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
+
+DB2Test::Artist->load_components('PK::Auto');
+
+# test primary key handling
+my $new = DB2Test::Artist->create({ name => 'foo' });
+ok($new->artistid, "Auto-PK worked");
+
+# test LIMIT support
+for (1..6) {
+ DB2Test::Artist->create({ name => 'Artist ' . $_ });
+}
+my $it = DB2Test::Artist->search( {},
+ { rows => 3,
+ order_by => 'artistid'
+ }
+);
+is( $it->count, 3, "LIMIT count ok" );
+is( $it->next->name, "Artist 2", "iterator->next ok" );
+$it->next;
+$it->next;
+is( $it->next, undef, "next past end of resultset ok" );
+
+my $test_type_info = {
+ 'artistid' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 0,
+ 'size' => 11
+ },
+ 'name' => {
+ 'data_type' => 'VARCHAR',
+ 'is_nullable' => 1,
+ 'size' => 255
+ },
+ 'charfield' => {
+ 'data_type' => 'VARCHAR',
+ 'is_nullable' => 1,
+ 'size' => 10
+ },
+};
+
+
+my $type_info = DB2Test->schema->storage->columns_info_for('artist');
+is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
+
+
+
+# clean up our mess
+$dbh->do("DROP TABLE artist");
+
+}
+
+1;
my $cd = $schema->resultset('CD')->find(1,
{
cols => [qw/title artist.name/],
- join => 'artist'
+ join => { 'artist' => {} }
}
);
ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
--- /dev/null
+use Storable;
+
+sub run_tests {
+my $schema = shift;
+
+plan tests => 1;
+
+my $artist = $schema->resultset('Artist')->find(1);
+my $copy = eval { Storable::dclone($artist) };
+is_deeply($copy, $artist, 'serialize row object works');
+
+}
+
+1;
--- /dev/null
+sub run_tests {
+my $schema = shift;
+
+eval "use DBD::SQLite";
+plan skip_all => 'needs DBD::SQLite for testing' if $@;
+plan tests => 8;
+
+my $rs = $schema->resultset("Artist")->search(
+ { artistid => 1 }
+);
+
+my $artist = $rs->first;
+
+is( scalar @{ $rs->get_cache }, 0, 'cache is not populated without cache attribute' );
+
+$rs = $schema->resultset("Artist")->search(
+ { 'artistid' => 1 },
+ {
+ prefetch => [qw/ cds /],
+ cache => 1,
+ }
+);
+
+# use Data::Dumper; $Data::Dumper::Deparse = 1;
+
+# start test for prefetch SELECT count
+unlink 't/var/dbic.trace' if -e 't/var/dbic.trace';
+DBI->trace(1, 't/var/dbic.trace');
+
+$artist = $rs->first;
+$rs->reset();
+
+# make sure artist contains a related resultset for cds
+is( ref $artist->{related_resultsets}->{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' );
+
+# check if $artist->cds->get_cache is populated
+is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records');
+
+# ensure that $artist->cds returns correct number of objects
+is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' );
+
+# ensure that $artist->cds->count returns correct value
+is( $artist->cds->count, 3, 'artist->cds->count returns correct value' );
+
+# ensure that $artist->count_related('cds') returns correct value
+is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' );
+
+# count the SELECTs
+DBI->trace(0, undef);
+my $selects = 0;
+my $trace = IO::File->new('t/var/dbic.trace', '<')
+ or die "Unable to read trace file";
+while (<$trace>) {
+ $selects++ if /SELECT/;
+}
+$trace->close;
+unlink 't/var/dbic.trace';
+is($selects, 2, 'only one SQL statement for each cached table');
+
+# make sure related_resultset is deleted after object is updated
+$artist->set_column('name', 'New Name');
+$artist->update();
+
+is( scalar keys %{$artist->{related_resultsets}}, 0, 'related resultsets deleted after update' );
+
+# todo: make sure caching works with nested prefetch e.g. $artist->cds->tracks
+$rs = $schema->resultset("Artist")->search(
+ { artistid => 1 },
+ {
+ prefetch => {
+ cds => 'tags'
+ },
+ cache => 1
+ }
+);
+
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+sub run_tests {
+my $schema = shift;
+
+plan tests => 4;
+my $artist = $schema->resultset('Artist')->find(1);
+my $artist_cds = $artist->search_related('cds');
+my $cover_band = $artist->copy;
+my $cover_cds = $cover_band->search_related('cds');
+cmp_ok($cover_band->id, '!=', $artist->id, 'ok got new column id...');
+is($cover_cds->count, $artist_cds->count, 'duplicated rows count ok');
+
+#check multi-keyed
+cmp_ok($cover_band->search_related('twokeys')->count, '>', 0, 'duplicated multiPK ok');
+
+#and check copying a few relations away
+cmp_ok($cover_cds->search_related('tags')->count, '==',
+ $artist_cds->search_related('tags')->count , 'duplicated count ok');
+
+}
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff