Revision history for DBIx::Class
+ - marked DB.pm as deprecated and noted it will be removed by 1.0
+ - add ResultSetColumn
+ - refactor ResultSet code to resolve attrs as late as poss
+ - merge prefetch attrs into join attrs
+ - add +select and +as attributes to ResultSet
+ - added AutoInflate::DateTime component
- refactor debugging to allow for profiling using Storage::Statistics
- removed Data::UUID from deps, made other optionals required
- modified SQLT parser to skip dupe table names
SQLT modules so an app can do its own deploy without SQLT on the target
system
+2006-05-25 by mst (TODOed by bluefeet)
+ Add the search attributes "limit" and "rows_per_page".
+ limit: work as expected just like offset does
+ rows_per_page: only be used if you used the page attr or called $rs->page
+ rows: modify to be an alias that gets used to populate either as appropriate,
+ if you haven't specified one of the others
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.06002';
+$VERSION = '0.06003';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
jguenther: Justin Guenther <guentherj@agr.gc.ca>
+captainL: Luke Saunders <luke.saunders@gmail.com>
+
draven: Marcus Ramberg <mramberg@cpan.org>
nigel: Nigel Metheringham <nigelm@cpan.org>
sszabo: Stephan Szabo <sszabo@bigpanda.com>
-captainL: Luke Saunders <luke.saunders@gmail.com>
-
Todd Lipcon
wdh: Will Hawes
sub has_a {
my ($self, $col, $f_class, %args) = @_;
$self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
- eval "require $f_class";
+ $self->ensure_class_loaded($f_class);
if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
if (!ref $args{'inflate'}) {
my $meth = $args{'inflate'};
use warnings;
use Class::C3;
+use Class::Inspector;
sub inject_base {
my ($class, $target, @to_inject) = @_;
{
no strict 'refs';
- my %seen;
- unshift( @{"${target}::ISA"},
- grep { !$seen{ $_ }++ && $target ne $_ && !$target->isa($_) }
- @to_inject
- );
+ foreach my $to (reverse @to_inject) {
+ unshift( @{"${target}::ISA"}, $to )
+ unless ($target eq $to || $target->isa($to));
+ }
}
# Yes, this is hack. But it *does* work. Please don't submit tickets about
sub _load_components {
my ($class, @comp) = @_;
foreach my $comp (@comp) {
- eval "use $comp";
- die $@ if $@;
+ $class->ensure_class_loaded($comp);
}
$class->inject_base($class => @comp);
}
+# TODO: handle ->has_many('rel', 'Class'...) instead of
+# ->has_many('rel', 'Some::Schema::Class'...)
+sub ensure_class_loaded {
+ my ($class, $f_class) = @_;
+ eval "require $f_class";
+ my $err = $@;
+ Class::Inspector->loaded($f_class)
+ or die $err || "require $f_class was successful but the package".
+ "is not defined";
+}
+
1;
Serialize::Storable
InflateColumn
Relationship
+ PK::Auto
PK
Row
ResultSourceProxy::Table
=head1 NAME
-DBIx::Class::DB - Non-recommended classdata schema component
+DBIx::Class::DB - (DEPRECATED) classdata schema component
=head1 SYNOPSIS
This class is designed to support the Class::DBI connection-as-classdata style
for DBIx::Class. You are *strongly* recommended to use a DBIx::Class::Schema
-instead; DBIx::Class::DB will continue to be supported but new development
-will be focused on Schema-based DBIx::Class setups.
+instead; DBIx::Class::DB will not undergo new development and will be moved
+to being a CDBICompat-only component before 1.0.
=head1 METHODS
(Replace L<DateTime::Format::Pg> with the appropriate module for your
database, or consider L<DateTime::Format::DBI>.)
+The coderefs you set for inflate and deflate are called with two parameters,
+the first is the value of the column to be inflated/deflated, the second is the
+row object itself. Thus you can call C<< ->result_source->schema->storage->dbh >> on
+it, to feed to L<DateTime::Format::DBI>.
+
In this example, calls to an event's C<insert_time> accessor return a
L<DateTime> object. This L<DateTime> object is later "deflated" when
used in the database layer.
--- /dev/null
+package DBIx::Class::InflateColumn::DateTime;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/InflateColumn/);
+
+__PACKAGE__->mk_group_accessors('simple' => '__datetime_parser');
+
+sub register_column {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ if ($info->{data_type} =~ /^datetime$/i) {
+ $self->inflate_column(
+ $column =>
+ {
+ inflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_datetime_parser->parse_datetime($value);
+ },
+ deflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_datetime_parser->format_datetime($value);
+ },
+ }
+ );
+ }
+}
+
+sub _datetime_parser {
+ my $self = shift;
+ if (my $parser = $self->__datetime_parser) {
+ return $parser;
+ }
+ my $parser = $self->result_source->storage->datetime_parser(@_);
+ return $self->__datetime_parser($parser);
+}
+
+1;
so no additional SQL statements are executed. You now have a much more
efficient query.
-Note that as of L<DBIx::Class> 0.04, C<prefetch> cannot be used with
-C<has_many> relationships. You will get an error along the lines of "No
-accessor for prefetched ..." if you try.
+Note that as of L<DBIx::Class> 0.05999_01, C<prefetch> I<can> be used with
+C<has_many> relationships.
Also note that C<prefetch> should only be used when you know you will
definitely use data from a related table. Pre-fetching related tables when you
my $genus = $schema->resultset('Genus')->find(12);
+ my $coderef2 = sub {
+ $genus->extinct(1);
+ $genus->update;
+ };
+
my $coderef1 = sub {
- my ($schema, $genus, $code) = @_;
$genus->add_to_species({ name => 'troglodyte' });
$genus->wings(2);
$genus->update;
- $schema->txn_do($code, $genus); # Can have a nested transaction
+ $schema->txn_do($coderef2); # Can have a nested transaction
return $genus->species;
};
- my $coderef2 = sub {
- my ($genus) = @_;
- $genus->extinct(1);
- $genus->update;
- };
-
my $rs;
eval {
- $rs = $schema->txn_do($coderef1, $schema, $genus, $coderef2);
+ $rs = $schema->txn_do($coderef1);
};
if ($@) { # Transaction failed
You could then create average, high and low execution times for an SQL
statement and dig down to see if certain parameters cause aberrant behavior.
+=head2 Getting the value of the primary key for the last database insert
+
+AKA getting last_insert_id
+
+If you are using PK::Auto, this is straightforward:
+
+ my $foo = $rs->create(\%blah);
+ # do more stuff
+ my $id = $foo->id; # foo->my_primary_key_field will also work.
+
+If you are not using autoincrementing primary keys, this will probably
+not work, but then you already know the value of the last primary key anyway.
+
=cut
holding the foreign key. If $cond is not given, the relname is used as
the column name.
+Cascading deletes are off per default on a C<belongs_to> relationship, to turn
+them on, pass C<< cascade_delete => 1 >> in the $attr hashref.
+
NOTE: If you are used to L<Class::DBI> relationships, this is the equivalent
of C<has_a>.
L<DBIx::Class::Relationship::Base/"create_related">.
If you delete an object in a class with a C<has_many> relationship, all
-related objects will be deleted as well. However, any database-level
-cascade or restrict will take precedence.
+the related objects will be deleted as well. However, any database-level
+cascade or restrict will take precedence. To turn this behavior off, pass
+C<< cascade_delete => 0 >> in the $attr hashref.
=head2 might_have
If you update or delete an object in a class with a C<might_have>
relationship, the related object will be updated or deleted as well.
Any database-level update or delete constraints will override this behaviour.
+To turn off this behavior, add C<< cascade_delete => 0 >> to the $attr hashref.
=head2 has_one
sub belongs_to {
my ($class, $rel, $f_class, $cond, $attrs) = @_;
- eval "require $f_class";
- if ($@) {
- $class->throw_exception($@) unless $@ =~ /Can't locate/;
- }
-
+ $class->ensure_class_loaded($f_class);
# no join condition or just a column name
if (!ref $cond) {
my %f_primaries = map { $_ => 1 } eval { $f_class->primary_columns };
sub has_many {
my ($class, $rel, $f_class, $cond, $attrs) = @_;
-
- eval "require $f_class";
- if ($@) {
- $class->throw_exception($@) unless $@ =~ /Can't locate/;
- }
+
+ $class->ensure_class_loaded($f_class);
unless (ref $cond) {
my ($pri, $too_many) = $class->primary_columns;
sub _has_one {
my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_;
- eval "require $f_class";
- if ($@) {
- $class->throw_exception($@) unless $@ =~ /Can't locate/;
- }
-
+ $class->ensure_class_loaded($f_class);
unless (ref $cond) {
my ($pri, $too_many) = $class->primary_columns;
$class->throw_exception( "might_have/has_one can only infer join for a single primary key; ${class} has more" )
fallback => 1;
use Data::Page;
use Storable;
+use Data::Dumper;
use Scalar::Util qw/weaken/;
use DBIx::Class::ResultSetColumn;
my ($source, $attrs) = @_;
weaken $source;
- $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } };
- #use Data::Dumper; warn Dumper($attrs);
- my $alias = ($attrs->{alias} ||= 'me');
-
- $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols};
- delete $attrs->{as} if $attrs->{columns};
- $attrs->{columns} ||= [ $source->columns ] unless $attrs->{select};
- $attrs->{select} = [
- map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}}
- ] if $attrs->{columns};
- $attrs->{as} ||= [
- map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}}
- ];
- if (my $include = delete $attrs->{include_columns}) {
- push(@{$attrs->{select}}, @$include);
- push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include);
- }
- #use Data::Dumper; warn Dumper(@{$attrs}{qw/select as/});
-
- $attrs->{from} ||= [ { $alias => $source->from } ];
- $attrs->{seen_join} ||= {};
- my %seen;
- if (my $join = delete $attrs->{join}) {
- foreach my $j (ref $join eq 'ARRAY' ? @$join : ($join)) {
- if (ref $j eq 'HASH') {
- $seen{$_} = 1 foreach keys %$j;
- } else {
- $seen{$j} = 1;
- }
- }
- push(@{$attrs->{from}}, $source->resolve_join(
- $join, $attrs->{alias}, $attrs->{seen_join})
- );
- }
-
- $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
- $attrs->{order_by} = [ $attrs->{order_by} ] if
- $attrs->{order_by} and !ref($attrs->{order_by});
- $attrs->{order_by} ||= [];
-
- my $collapse = $attrs->{collapse} || {};
- if (my $prefetch = delete $attrs->{prefetch}) {
- my @pre_order;
- foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
- if ( ref $p eq 'HASH' ) {
- foreach my $key (keys %$p) {
- push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
- unless $seen{$key};
- }
- } else {
- push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
- unless $seen{$p};
- }
- my @prefetch = $source->resolve_prefetch(
- $p, $attrs->{alias}, {}, \@pre_order, $collapse);
- push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
- push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
- }
- push(@{$attrs->{order_by}}, @pre_order);
- }
- $attrs->{collapse} = $collapse;
-# use Data::Dumper; warn Dumper($collapse) if keys %{$collapse};
if ($attrs->{page}) {
$attrs->{rows} ||= 10;
$attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
}
+ $attrs->{alias} ||= 'me';
+
bless {
result_source => $source,
result_class => $attrs->{result_class} || $source->result_class,
cond => $attrs->{where},
- from => $attrs->{from},
- collapse => $collapse,
+# from => $attrs->{from},
+# collapse => $collapse,
count => undef,
page => delete $attrs->{page},
pager => undef,
sub search_rs {
my $self = shift;
- my $attrs = { %{$self->{attrs}} };
- my $having = delete $attrs->{having};
- $attrs = { %$attrs, %{ pop(@_) } } if @_ > 1 and ref $_[$#_] eq 'HASH';
+ my $our_attrs = { %{$self->{attrs}} };
+ my $having = delete $our_attrs->{having};
+ my $attrs = {};
+ $attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
+
+ # merge new attrs into old
+ foreach my $key (qw/join prefetch/) {
+ next unless (exists $attrs->{$key});
+ if (exists $our_attrs->{$key}) {
+ $our_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
+ } else {
+ $our_attrs->{$key} = $attrs->{$key};
+ }
+ delete $attrs->{$key};
+ }
+ if (exists $our_attrs->{prefetch}) {
+ $our_attrs->{join} = $self->_merge_attr($our_attrs->{join}, $our_attrs->{prefetch}, 1);
+ }
+
+ my $new_attrs = { %{$our_attrs}, %{$attrs} };
+
+ # merge new where and having into old
my $where = (@_
? ((@_ == 1 || ref $_[0] eq "HASH")
? shift
: {@_}))
: undef());
if (defined $where) {
- $attrs->{where} = (defined $attrs->{where}
+ $new_attrs->{where} = (defined $new_attrs->{where}
? { '-and' =>
[ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
- $where, $attrs->{where} ] }
+ $where, $new_attrs->{where} ] }
: $where);
}
if (defined $having) {
- $attrs->{having} = (defined $attrs->{having}
+ $new_attrs->{having} = (defined $new_attrs->{having}
? { '-and' =>
[ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
- $having, $attrs->{having} ] }
+ $having, $new_attrs->{having} ] }
: $having);
}
- my $rs = (ref $self)->new($self->result_source, $attrs);
+ my $rs = (ref $self)->new($self->result_source, $new_attrs);
+ $rs->{_parent_rs} = $self->{_parent_rs} if ($self->{_parent_rs}); #XXX - hack to pass through parent of related resultsets
unless (@_) { # no search, effectively just a clone
my $rows = $self->get_cache;
# Add the ResultSet's alias
foreach my $key (grep { ! m/\./ } keys %$unique_query) {
- $unique_query->{"$self->{attrs}{alias}.$key"} = delete $unique_query->{$key};
+ my $alias = $self->{attrs}->{alias};
+ $unique_query->{"$alias.$key"} = delete $unique_query->{$key};
}
push @unique_queries, $unique_query if %$unique_query;
# Run the query
if (keys %$attrs) {
my $rs = $self->search($query, $attrs);
- return keys %{$rs->{collapse}} ? $rs->next : $rs->single;
+ $rs->_resolve;
+ return keys %{$rs->{_attrs}->{collapse}} ? $rs->next : $rs->single;
}
else {
- return keys %{$self->{collapse}}
+ $self->_resolve;
+ return (keys %{$self->{_attrs}->{collapse}})
? $self->search($query)->next
: $self->single($query);
}
sub cursor {
my ($self) = @_;
- my $attrs = { %{$self->{attrs}} };
+
+ $self->_resolve;
+ my $attrs = { %{$self->{_attrs}} };
return $self->{cursor}
- ||= $self->result_source->storage->select($self->{from}, $attrs->{select},
+ ||= $self->result_source->storage->select($attrs->{from}, $attrs->{select},
$attrs->{where},$attrs);
}
sub single {
my ($self, $where) = @_;
- my $attrs = { %{$self->{attrs}} };
+ $self->_resolve;
+ my $attrs = { %{$self->{_attrs}} };
if ($where) {
if (defined $attrs->{where}) {
$attrs->{where} = {
$attrs->{where} = $where;
}
}
+
my @data = $self->result_source->storage->select_single(
- $self->{from}, $attrs->{select},
+ $attrs->{from}, $attrs->{select},
$attrs->{where},$attrs);
return (@data ? $self->_construct_object(@data) : ());
}
@{delete $self->{stashed_row}} :
$self->cursor->next
);
-# warn Dumper(\@row); use Data::Dumper;
return unless (@row);
return $self->_construct_object(@row);
}
+sub _resolve {
+ my $self = shift;
+
+ return if(exists $self->{_attrs}); #return if _resolve has already been called
+
+ my $attrs = $self->{attrs};
+ my $source = ($self->{_parent_rs}) ? $self->{_parent_rs} : $self->{result_source};
+
+ # XXX - lose storable dclone
+ my $record_filter = delete $attrs->{record_filter} if (defined $attrs->{record_filter});
+ $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } };
+ $attrs->{record_filter} = $record_filter if ($record_filter);
+ $self->{attrs}->{record_filter} = $record_filter if ($record_filter);
+
+ my $alias = $attrs->{alias};
+
+ $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols};
+ delete $attrs->{as} if $attrs->{columns};
+ $attrs->{columns} ||= [ $self->{result_source}->columns ] unless $attrs->{select};
+ my $select_alias = ($self->{_parent_rs}) ? $self->{attrs}->{_live_join} : $alias;
+ $attrs->{select} = [
+ map { m/\./ ? $_ : "${select_alias}.$_" } @{delete $attrs->{columns}}
+ ] if $attrs->{columns};
+ $attrs->{as} ||= [
+ map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}}
+ ];
+ if (my $include = delete $attrs->{include_columns}) {
+ push(@{$attrs->{select}}, @$include);
+ push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include);
+ }
+
+ $attrs->{from} ||= [ { $alias => $source->from } ];
+ $attrs->{seen_join} ||= {};
+ my %seen;
+ if (my $join = delete $attrs->{join}) {
+ foreach my $j (ref $join eq 'ARRAY' ? @$join : ($join)) {
+ if (ref $j eq 'HASH') {
+ $seen{$_} = 1 foreach keys %$j;
+ } else {
+ $seen{$j} = 1;
+ }
+ }
+
+ push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}, $attrs->{seen_join}));
+ }
+ $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
+ $attrs->{order_by} = [ $attrs->{order_by} ] if
+ $attrs->{order_by} and !ref($attrs->{order_by});
+ $attrs->{order_by} ||= [];
+
+ if(my $seladds = delete($attrs->{'+select'})) {
+ my @seladds = (ref($seladds) eq 'ARRAY' ? @$seladds : ($seladds));
+ $attrs->{select} = [
+ @{ $attrs->{select} },
+ map { (m/\./ || ref($_)) ? $_ : "${alias}.$_" } $seladds
+ ];
+ }
+ if(my $asadds = delete($attrs->{'+as'})) {
+ my @asadds = (ref($asadds) eq 'ARRAY' ? @$asadds : ($asadds));
+ $attrs->{as} = [ @{ $attrs->{as} }, @asadds ];
+ }
+
+ my $collapse = $attrs->{collapse} || {};
+ if (my $prefetch = delete $attrs->{prefetch}) {
+ my @pre_order;
+ foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
+ if ( ref $p eq 'HASH' ) {
+ foreach my $key (keys %$p) {
+ push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
+ unless $seen{$key};
+ }
+ } else {
+ push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
+ unless $seen{$p};
+ }
+ my @prefetch = $source->resolve_prefetch(
+ $p, $attrs->{alias}, {}, \@pre_order, $collapse);
+ push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
+ push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
+ }
+ push(@{$attrs->{order_by}}, @pre_order);
+ }
+ $attrs->{collapse} = $collapse;
+ $self->{_attrs} = $attrs;
+}
+
+sub _merge_attr {
+ my ($self, $a, $b, $is_prefetch) = @_;
+
+ return $b unless $a;
+ if (ref $b eq 'HASH' && ref $a eq 'HASH') {
+ foreach my $key (keys %{$b}) {
+ if (exists $a->{$key}) {
+ $a->{$key} = $self->_merge_attr($a->{$key}, $b->{$key}, $is_prefetch);
+ } else {
+ $a->{$key} = delete $b->{$key};
+ }
+ }
+ return $a;
+ } else {
+ $a = [$a] unless (ref $a eq 'ARRAY');
+ $b = [$b] unless (ref $b eq 'ARRAY');
+
+ my $hash = {};
+ my $array = [];
+ foreach ($a, $b) {
+ foreach my $element (@{$_}) {
+ if (ref $element eq 'HASH') {
+ $hash = $self->_merge_attr($hash, $element, $is_prefetch);
+ } elsif (ref $element eq 'ARRAY') {
+ $array = [@{$array}, @{$element}];
+ } else {
+ if (($b == $_) && $is_prefetch) {
+ $self->_merge_array($array, $element, $is_prefetch);
+ } else {
+ push(@{$array}, $element);
+ }
+ }
+ }
+ }
+
+ if ((keys %{$hash}) && (scalar(@{$array} > 0))) {
+ return [$hash, @{$array}];
+ } else {
+ return (keys %{$hash}) ? $hash : $array;
+ }
+ }
+}
+
+sub _merge_array {
+ my ($self, $a, $b) = @_;
+
+ $b = [$b] unless (ref $b eq 'ARRAY');
+ # add elements from @{$b} to @{$a} which aren't already in @{$a}
+ foreach my $b_element (@{$b}) {
+ push(@{$a}, $b_element) unless grep {$b_element eq $_} @{$a};
+ }
+}
+
sub _construct_object {
my ($self, @row) = @_;
- my @as = @{ $self->{attrs}{as} };
-
+ my @as = @{ $self->{_attrs}{as} };
+
my $info = $self->_collapse_result(\@as, \@row);
-
my $new = $self->result_class->inflate_result($self->result_source, @$info);
-
- $new = $self->{attrs}{record_filter}->($new)
- if exists $self->{attrs}{record_filter};
+ $new = $self->{_attrs}{record_filter}->($new)
+ if exists $self->{_attrs}{record_filter};
return $new;
}
sub _collapse_result {
my ($self, $as, $row, $prefix) = @_;
+ my $live_join = $self->{attrs}->{_live_join} ||="";
my %const;
my @copy = @$row;
my $info = [ {}, {} ];
foreach my $key (keys %const) {
- if (length $key) {
+ if (length $key && $key ne $live_join) {
my $target = $info;
my @parts = split(/\./, $key);
foreach my $p (@parts) {
if (defined $prefix) {
@collapse = map {
m/^\Q${prefix}.\E(.+)$/ ? ($1) : ()
- } keys %{$self->{collapse}}
+ } keys %{$self->{_attrs}->{collapse}}
} else {
- @collapse = keys %{$self->{collapse}};
+ @collapse = keys %{$self->{_attrs}->{collapse}};
};
if (@collapse) {
$target = $target->[1]->{$p} ||= [];
}
my $c_prefix = (defined($prefix) ? "${prefix}.${c}" : $c);
- my @co_key = @{$self->{collapse}{$c_prefix}};
+ my @co_key = @{$self->{_attrs}->{collapse}{$c_prefix}};
my %co_check = map { ($_, $target->[0]->{$_}); } @co_key;
my $tree = $self->_collapse_result($as, $row, $c_prefix);
my (@final, @raw);
$row = $self->{stashed_row} = \@raw;
$tree = $self->_collapse_result($as, $row, $c_prefix);
}
- @$target = (@final ? @final : [ {}, {} ]);
+ @$target = (@final ? @final : [ {}, {} ]);
# single empty result to indicate an empty prefetched has_many
}
-
return $info;
}
sub _count { # Separated out so pager can get the full count
my $self = shift;
my $select = { count => '*' };
- my $attrs = { %{ $self->{attrs} } };
+
+ $self->_resolve;
+ my $attrs = { %{ $self->{_attrs} } };
if (my $group_by = delete $attrs->{group_by}) {
delete $attrs->{having};
my @distinct = (ref $group_by ? @$group_by : ($group_by));
}
$select = { count => { distinct => \@distinct } };
- #use Data::Dumper; die Dumper $select;
}
$attrs->{select} = $select;
# offset, order by and page are not needed to count. record_filter is cdbi
delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
-
my ($count) = (ref $self)->new($self->result_source, $attrs)->cursor->next;
return $count;
}
my @obj;
- if (keys %{$self->{collapse}}) {
+ # TODO: don't call resolve here
+ $self->_resolve;
+ if (keys %{$self->{_attrs}->{collapse}}) {
+# if ($self->{attrs}->{prefetch}) {
# Using $self->cursor->all is really just an optimisation.
# If we're collapsing has_many prefetches it probably makes
# very little difference, and this is cleaner than hacking
# _construct_object to survive the approach
- $self->cursor->reset;
my @row = $self->cursor->next;
while (@row) {
push(@obj, $self->_construct_object(@row));
sub reset {
my ($self) = @_;
+ delete $self->{_attrs} if (exists $self->{_attrs});
+
$self->{all_cache_position} = 0;
$self->cursor->reset;
return $self;
$cond->{-and} = [];
my @cond = @{$self->{cond}{-and}};
- for (my $i = 0; $i < @cond - 1; $i++) {
+ for (my $i = 0; $i <= @cond - 1; $i++) {
my $entry = $cond[$i];
my %hash;
}
else {
$entry =~ /([^.]+)$/;
- $hash{$entry} = $cond[++$i];
+ $hash{$1} = $cond[++$i];
}
push @{$cond->{-and}}, \%hash;
sub set_cache {
my ( $self, $data ) = @_;
$self->throw_exception("set_cache requires an arrayref")
- if defined($data) && (ref $data ne 'ARRAY');
+ if defined($data) && (ref $data ne 'ARRAY');
$self->{all_cache} = $data;
}
sub related_resultset {
my ( $self, $rel ) = @_;
+
$self->{related_resultsets} ||= {};
return $self->{related_resultsets}{$rel} ||= do {
- #warn "fetching related resultset for rel '$rel'";
+ #warn "fetching related resultset for rel '$rel' " . $self->result_source->{name};
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 = $self->search(undef, { join => $rel });
- my $alias = defined $rs->{attrs}{seen_join}{$rel}
- && $rs->{attrs}{seen_join}{$rel} > 1
- ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
- : $rel;
-
- $self->result_source->schema->resultset($rel_obj->{class}
+ my $rs = $self->result_source->schema->resultset($rel_obj->{class}
)->search( undef,
- { %{$rs->{attrs}},
- alias => $alias,
+ { %{$self->{attrs}},
select => undef,
- as => undef }
+ as => undef,
+ join => $rel,
+ _live_join => $rel }
);
+
+ # keep reference of the original resultset
+ $rs->{_parent_rs} = $self->result_source;
+ return $rs;
};
}
through directly to SQL, so you can give e.g. C<year DESC> for a
descending order on the column `year'.
+Please note that if you have quoting enabled (see
+L<DBIx::Class::Storage/quote_char>) you will need to do C<\'year DESC' > to
+specify an order. (The scalar ref causes it to be passed as raw sql to the DB,
+so you will need to manually quote things as appropriate.)
+
=head2 columns
=over 4
attribute, the column names returned are storage-dependent. E.g. MySQL would
return a column named C<count(employeeid)> in the above example.
+=head2 +select
+
+=over 4
+
+Indicates additional columns to be selected from storage. Works the same as
+L<select> but adds columns to the selection.
+
+=back
+
+=head2 +as
+
+=over 4
+
+Indicates additional column names for those added via L<+select>.
+
+=back
+
=head2 as
=over 4
You can create your own accessors if required - see
L<DBIx::Class::Manual::Cookbook> for details.
+Please note: This will NOT insert an C<AS employee_count> into the SQL statement
+produced, it is used for internal access only. Thus attempting to use the accessor
+in an C<order_by> clause or similar will fail misrably.
+
=head2 join
=over 4
Makes the resultset paged and specifies the page to retrieve. Effectively
identical to creating a non-pages resultset and then calling ->page($page)
-on it.
+on it.
+
+If L<rows> attribute is not specified it defualts to 10 rows per page.
=head2 rows
Specifes the maximum number of rows for direct retrieval or the number of
rows per page if the page attribute or method is used.
+=head2 offset
+
+=over 4
+
+=item Value: $offset
+
+=back
+
+Specifies the (zero-based) row number for the first row to be returned, or the
+of the first row of the first page if paging is used.
+
=head2 group_by
=over 4
my $cond = shift;
my $attrs = shift || {};
$attrs->{order_by} = 'year DESC';
- $self->next::method($cond, $attrs);
+ $self->search($cond, $attrs);
}
$rs = $schema->resultset('CD')->search_by_year_desc({ artist => 'Tool' });
{
$self->{_columns_info_loaded}++;
my $info;
+ my $lc_info;
# eval for the case of storage without table
- eval { $info = $self->storage->columns_info_for($self->from) };
+ eval { $info = $self->storage->columns_info_for( $self->from, keys %{$self->_columns} ) };
unless ($@) {
+ for my $realcol ( keys %{$info} ) {
+ $lc_info->{lc $realcol} = $info->{$realcol};
+ }
foreach my $col ( keys %{$self->_columns} ) {
- foreach my $i ( keys %{$info->{$col}} ) {
- $self->_columns->{$col}{$i} = $info->{$col}{$i};
- }
+ $self->_columns->{$col} = $info->{$col} || $lc_info->{lc $col};
}
}
}
my $f_source = $self->schema->source($f_source_name);
unless ($f_source) {
- eval "require $f_source_name;";
- if ($@) {
- die $@ unless $@ =~ /Can't locate/;
- }
+ $self->ensure_class_loaded($f_source_name);
$f_source = $f_source_name->result_source;
#my $s_class = ref($self->schema);
#$f_source_name =~ m/^${s_class}::(.*)$/;
foreach my $prefix (keys %comps_for) {
foreach my $comp (@{$comps_for{$prefix}||[]}) {
my $comp_class = "${prefix}::${comp}";
- eval "use $comp_class"; # If it fails, assume the user fixed it
- if ($@) {
- $comp_class =~ s/::/\//g;
- die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/;
- warn $@ if $@;
- }
-
+ $class->ensure_class_loaded($comp_class);
$comp_class->source_name($comp) unless $comp_class->source_name;
push(@to_register, [ $comp_class->source_name, $comp_class ]);
For example,
my $author_rs = $schema->resultset('Author')->find(1);
+ my @titles = qw/Night Day It/;
my $coderef = sub {
- my ($author, @titles) = @_;
-
# If any one of these fails, the entire transaction fails
- $author->create_related('books', {
+ $author_rs->create_related('books', {
title => $_
}) foreach (@titles);
my $rs;
eval {
- $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/);
+ $rs = $schema->txn_do($coderef);
};
- if ($@) {
- my $error = $@;
- if ($error =~ /Rollback failed/) {
- die "something terrible has happened!";
- } else {
- deal_with_failed_transaction();
- }
+ if ($@) { # Transaction failed
+ die "something terrible has happened!" #
+ if ($@ =~ /Rollback failed/); # Rollback failed
+
+ deal_with_failed_transaction();
}
In a nested transaction (calling txn_do() from within a txn_do() coderef) only
Executes the sql statements given as a listref on every db connect.
+=head2 quote_char
+
+Specifies what characters to use to quote table and column names. If
+you use this you will want to specify L<name_sep> as well.
+
+quote_char expectes either a single character, in which case is it is placed
+on either side of the table/column, or an array of length 2 in which case the
+table/column name is placed between the elements.
+
+For example under MySQL you'd use C<quote_char('`')>, and user SQL Server you'd
+use C<quote_char(qw/[ ]/)>.
+
+=head2 name_sep
+
+This only needs to be used in conjunction with L<quote_char>, and is used to
+specify the charecter that seperates elements (schemas, tables, columns) from
+each other. In most cases this is simply a C<.>.
+
=head2 debug
Causes SQL trace information to be emitted on the C<debugobj> object.
sub txn_commit {
my $self = shift;
+ my $dbh = $self->dbh;
if ($self->{transaction_depth} == 0) {
- my $dbh = $self->dbh;
unless ($dbh->{AutoCommit}) {
$self->debugobj->txn_commit()
if ($self->debug);
if (--$self->{transaction_depth} == 0) {
$self->debugobj->txn_commit()
if ($self->debug);
- $self->dbh->commit;
+ $dbh->commit;
}
}
}
my $self = shift;
eval {
+ my $dbh = $self->dbh;
if ($self->{transaction_depth} == 0) {
- my $dbh = $self->dbh;
unless ($dbh->{AutoCommit}) {
$self->debugobj->txn_rollback()
if ($self->debug);
if (--$self->{transaction_depth} == 0) {
$self->debugobj->txn_rollback()
if ($self->debug);
- $self->dbh->rollback;
+ $dbh->rollback;
}
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
my $sth = eval { $self->sth($sql,$op) };
if (!$sth || $@) {
- $self->throw_exception('no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql");
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
+ );
}
-
@bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
my $rv;
if ($sth) {
$column_info{size} = $info->{COLUMN_SIZE};
$column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
$column_info{default_value} = $info->{COLUMN_DEF};
+ my $col_name = $info->{COLUMN_NAME};
+ $col_name =~ s/^\"(.*)\"$/$1/;
- $result{$info->{COLUMN_NAME}} = \%column_info;
+ $result{$col_name} = \%column_info;
}
};
$dbh->{RaiseError} = $old_raise_err;
}
}
+sub datetime_parser {
+ my $self = shift;
+ return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
+}
+
+sub datetime_parser_type { "DateTime::Format::MySQL"; }
+
+sub build_datetime_parser {
+ my $self = shift;
+ my $type = $self->datetime_parser_type(@_);
+ eval "use ${type}";
+ $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ return $type;
+}
+
sub DESTROY { shift->disconnect }
1;
}
+sub datetime_parser_type { "DateTime::Format::DB2"; }
+
1;
=head1 NAME
my( $id ) = $_[0]->_dbh->selectrow_array('SELECT @@IDENTITY' );
return $id;
}
+
+sub build_datetime_parser {
+ my $self = shift;
+ my $type = "DateTime::Format::Strptime";
+ eval "use ${type}";
+ $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ return $type->new( pattern => '%m/%d/%Y %H:%M:%S' );
+}
\r
1;
\r
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC400;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+sub last_insert_id
+{
+ my ($self) = @_;
+
+ my $dbh = $self->_dbh;
+
+ # get the schema/table separator:
+ # '.' when SQL naming is active
+ # '/' when system naming is active
+ my $sep = $dbh->get_info(41);
+ my $sth = $dbh->prepare_cached(
+ "SELECT IDENTITY_VAL_LOCAL() FROM SYSIBM${sep}SYSDUMMY1", {}, 3);
+ $sth->execute();
+
+ my @res = $sth->fetchrow_array();
+
+ return @res ? $res[0] : undef;
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC400 - Automatic primary key class for DB2/400
+over ODBC
+
+=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/400 over ODBC.
+
+
+=head1 AUTHORS
+
+Marc Mims C<< <marc@questright.com> >>
+
+Based on DBIx::Class::Storage::DBI::DB2 by Jess Robinson.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
return 'PostgreSQL';
}
+sub datetime_parser_type { return "DateTime::Format::Pg"; }
+
1;
=head1 NAME
use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto CDBICompat Core DB/);
+__PACKAGE__->load_components(qw/CDBICompat Core DB/);
use File::Temp qw/tempfile/;
my (undef, $DB) = tempfile();
+++ /dev/null
-package DBIx::Class::UUIDColumns;
-
-use strict;
-use warnings;
-
-use base qw/DBIx::Class/;
-
-__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 nastiness 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
-
-DBIx::Class::UUIDColumns - Implicit uuid columns
-
-=head1 SYNOPSIS
-
- package Artist;
- __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
- __PACKAGE__->uuid_columns( 'artist_id' );
-
-=head1 DESCRIPTION
-
-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(@columns)
-
-Takes a list of columns to be filled with uuids during insert.
-
- __PACKAGE__->uuid_columns('id');
-
-=head2 uuid_class($classname)
-
-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.
+++ /dev/null
-package DBIx::Class::UUIDMaker;
-
-use strict;
-use warnings;
-
-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 incantations...
- 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 strict;
-use warnings;
-
-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 strict;
-use warnings;
-
-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 strict;
-use warnings;
-
-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 strict;
-use warnings;
-
-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 strict;
-use warnings;
-
-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 strict;
-use warnings;
-
-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.
# Test for inject_base to filter out duplicates
{ package DBICTest::_InjectBaseTest;
use base qw/ DBIx::Class /;
+ package DBICTest::_InjectBaseTest::A;
+ package DBICTest::_InjectBaseTest::B;
+ package DBICTest::_InjectBaseTest::C;
}
DBICTest::_InjectBaseTest->inject_base( 'DBICTest::_InjectBaseTest', qw/
DBICTest::_InjectBaseTest::A
--- /dev/null
+use Test::More;
+use strict;
+use warnings;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+plan tests => 7;
+
+my $schema = DBICTest->schema;
+my $total_cds = $schema->resultset('CD')->count;
+cmp_ok($total_cds, '>', 0, 'need cd records');
+
+# test that delete_related w/o conditions deletes all related records only
+my $artist = $schema->resultset("Artist")->find(3);
+my $artist_cds = $artist->cds->count;
+cmp_ok($artist_cds, '<', $total_cds, 'need more cds than just related cds');
+
+ok($artist->delete_related('cds'));
+cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist_cds), 'too many cds were deleted');
+
+$total_cds -= $artist_cds;
+
+# test that delete_related w/conditions deletes just the matched related records only
+my $artist2 = $schema->resultset("Artist")->find(2);
+my $artist2_cds = $artist2->search_related('cds')->count;
+cmp_ok($artist2_cds, '<', $total_cds, 'need more cds than related cds');
+
+ok($artist2->delete_related('cds', {title => {like => '%'}}));
+cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist2_cds), 'too many cds were deleted');
my $schema = DBICTest::Schema;
-plan tests => 33;
+plan tests => 31;
my $translator = SQL::Translator->new(
parser_args => {
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
'needed' => 1, on_delete => '', on_update => ''},
- {'display' => 'twokeytreelike -> twokeytreelike for parent1,parent2',
- 'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
- 'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
- 'needed' => 1, on_delete => '', on_update => ''},
+
+ # shouldn't this be generated?
+ #
+ #{'display' => 'twokeytreelike -> twokeytreelike for parent1,parent2',
+ # 'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
+ # 'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
+ # 'needed' => 1, on_delete => '', on_update => ''},
+
{'display' => 'tags -> cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/29inflate_datetime.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/30ensure_class_loaded.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/30join_torture.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+# belongs to t/run/30ensure_class_loaded.tl
+package # hide from PAUSE
+ DBICTest::FakeComponent;
+use warnings;
+use strict;
+
+1;
CD
Link
Bookmark
+ #Casecheck
#dummy
Track
Tag
'Producer',
'CD_to_Producer',
),
- qw/SelfRefAlias TreeLike TwoKeyTreeLike/
+ qw/SelfRefAlias TreeLike TwoKeyTreeLike Event/
);
sub deploy {
--- /dev/null
+package DBICTest::Schema::Event;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/InflateColumn::DateTime PK::Auto Core/);
+
+__PACKAGE__->table('event');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ starts_at => { data_type => 'datetime' }
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
},
);
__PACKAGE__->set_primary_key(qw/id/);
-__PACKAGE__->belongs_to('parent', 'TreeLike',
+__PACKAGE__->belongs_to('parent', 'DBICTest::Schema::TreeLike',
{ 'foreign.id' => 'self.parent' });
1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sun May 14 18:25:49 2006
+-- Created on Tue May 23 21:10:54 2006
--
BEGIN TRANSACTION;
);
--
+-- Table: event
+--
+CREATE TABLE event (
+ id INTEGER PRIMARY KEY NOT NULL,
+ starts_at datetime NOT NULL
+);
+
+--
-- Table: twokeys
--
CREATE TABLE twokeys (
ok($art->update, 'Update run');
+my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next;
+
+ok($record_jp, "prefetch on same rel okay");
+
+my $record_fn = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search({'cds.cdid' => '1'}, {join => 'artist_undirected_maps'})->next;
+
+ok($record_fn, "funny join is okay");
+
@art = $schema->resultset("Artist")->search({ name => 'We Are In Rehab' });
cmp_ok(@art, '==', 1, "Changed artist returned by search");
#warn "$dsn $user $pass";
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
+ . ' (note: creates and drops tables named artist and casecheck!)' unless ($dsn && $user);
-plan tests => 4;
+plan tests => 8;
DBICTest::Schema->compose_connection('PgTest' => $dsn, $user, $pass);
my $dbh = PgTest->schema->storage->dbh;
PgTest->schema->source("Artist")->name("testschema.artist");
$dbh->do("CREATE SCHEMA testschema;");
-$dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(255), charfield CHAR(10));");
+
+$dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10));");
+ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
PgTest::Artist->load_components('PK::Auto');
'name' => {
'data_type' => 'character varying',
'is_nullable' => 1,
- 'size' => 255,
+ 'size' => 100,
'default_value' => undef,
},
'charfield' => {
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
+my $name_info = PgTest::Casecheck->column_info( 'name' );
+is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
+
+my $NAME_info = PgTest::Casecheck->column_info( 'NAME' );
+is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
+
+my $uc_name_info = PgTest::Casecheck->column_info( 'uc_name' );
+is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
+
$dbh->do("DROP TABLE testschema.artist;");
+$dbh->do("DROP TABLE testschema.casecheck;");
$dbh->do("DROP SCHEMA testschema;");
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 44 );
+ : ( tests => 42 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
);
cmp_ok( scalar $rs->all, '==', scalar $rs->slice(0, $rs->count - 1), 'slice() with join has same count as all()' );
-eval { $rs->search(undef, { rows => 0, offset => 3 })->all; };
-
-ok($@, "rows => 0 errors: $@");
-
$rs = $schema->resultset("Artist")->search(
{ 'liner_notes.notes' => 'Kill Yourself!' },
{ join => { 'cds' => 'liner_notes' } });
cmp_ok($queries, '==', 1, 'Only one query run');
-# has_many resulting in an additional select if no records available despite prefetch
-my $track = $schema->resultset("Artist")->create( {
- artistid => 4,
- name => 'Artist without CDs',
-} );
-
-$queries = 0;
-$schema->storage->debug(1);
-
-my $artist_without_cds = $schema->resultset("Artist")->find(4, {
- join => [qw/ cds /],
- prefetch => [qw/ cds /],
-});
-my @no_cds = $artist_without_cds->cds;
-
-is($queries, 1, 'prefetch ran only 1 sql statement');
-
-$schema->storage->debug(0);
-
my $schema = DBICTest::init_schema();
-plan tests => 5;
+plan tests => 8;
my $rs = $cd = $schema->resultset("CD")->search({});
cmp_ok($rs_year->sum, '==', 9996, "three artists returned");
+my $psrs = $schema->resultset('CD')->search({},
+ {
+ '+select' => \'COUNT(*)',
+ '+as' => 'count'
+ }
+);
+ok(defined($psrs->get_column('count')), '+select/+as count');
+
+$psrs = $schema->resultset('CD')->search({},
+ {
+ '+select' => [ \'COUNT(*)', 'title' ],
+ '+as' => [ 'count', 'addedtitle' ]
+ }
+);
+ok(defined($psrs->get_column('count')), '+select/+as arrayref count');
+ok(defined($psrs->get_column('addedtitle')), '+select/+as title');
+
--- /dev/null
+sub run_tests {
+my $schema = shift;
+
+eval { require DateTime::Format::MySQL };
+plan skip_all => "Need DateTime::Format::MySQL for inflation tests" if $@;
+
+plan tests => 2;
+
+# inflation test
+my $event = $schema->resultset("Event")->find(1);
+
+isa_ok($event->starts_at, 'DateTime', 'DateTime returned');
+
+is($event->starts_at, '2006-04-25T22:24:33', 'Correct date/time');
+
+}
+
+1;
--- /dev/null
+use Class::Inspector;
+
+BEGIN {
+ package TestPackage::A;
+ sub some_method {}
+}
+
+sub run_tests {
+
+my $schema = shift;
+plan tests => 6;
+
+ok(Class::Inspector->loaded('TestPackage::A'),
+ 'anon. package exists');
+eval {
+ $schema->ensure_class_loaded('TestPackage::A');
+};
+
+ok(!$@, 'ensure_class_loaded detected an anon. class');
+
+eval {
+ $schema->ensure_class_loaded('FakePackage::B');
+};
+
+like($@, qr/Can't locate/,
+ 'ensure_class_loaded threw exception for nonexistent class');
+
+ok(!Class::Inspector->loaded('DBICTest::FakeComponent'),
+ 'DBICTest::FakeComponent not loaded yet');
+
+eval {
+ $schema->ensure_class_loaded('DBICTest::FakeComponent');
+};
+
+ok(!$@, 'ensure_class_loaded detected an existing but non-loaded class');
+ok(Class::Inspector->loaded('DBICTest::FakeComponent'),
+ 'DBICTest::FakeComponent now loaded');
+}
+
+1;
--- /dev/null
+sub run_tests {
+my $schema = shift;
+
+plan tests => 4;
+
+my $rs1 = $schema->resultset("Artist")->search({ 'tags.tag' => 'Blue' }, { join => {'cds' => 'tracks'}, prefetch => {'cds' => 'tags'} });
+my @artists = $rs1->all;
+cmp_ok(@artists, '==', 1, "Two artists returned");
+
+my $rs2 = $rs1->search({ artistid => '1' }, { join => {'cds' => {'cd_to_producer' => 'producer'} } });
+my $rs3 = $rs2->search_related('cds')->search({'cds.title' => 'Forkful of bees'});
+cmp_ok($rs3->count, '==', 3, "Three artists returned");
+
+my $rs4 = $schema->resultset("CD")->search({ 'artist.artistid' => '1' }, { join => ['tracks', 'artist'], prefetch => 'artist' });
+my @rs4_results = $rs4->all;
+
+
+is($rs4_results[0]->cdid, 1, "correct artist returned");
+
+my $rs5 = $rs4->search({'tracks.title' => 'Sticky Honey'});
+is($rs5->count, 1, "search without using previous joins okay");
+
+}
+
+1;
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff