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
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
$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
$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
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}||[]}];
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
-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::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);
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;
--- /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;
projects / dbsrgits/DBIx-Class.git / commitdiff