"'$class' is unwise.");
}
+ my $name = $field;
+
+ ($name, $field) = @$field if ref $field;
+
my $accessor = $self->$maker($group, $field);
- my $alias = "_${field}_accessor";
+ my $alias = "_${name}_accessor";
#warn "$class $group $field $alias";
- *{$class."\:\:$field"} = $accessor;
+ *{$class."\:\:$name"} = $accessor;
#unless defined &{$class."\:\:$field"}
*{$class."\:\:$alias"} = $accessor;
DBIx::Class::CDBICompat::Constructor
DBIx::Class::CDBICompat::AccessorMapping
DBIx::Class::CDBICompat::ColumnCase
+ DBIx::Class::CDBICompat::HasMany
DBIx::Class::CDBICompat::HasA
DBIx::Class::CDBICompat::LazyLoading
DBIx::Class::CDBICompat::AutoUpdate
use NEXT;
-sub _mk_column_accessors {
- my ($class, @cols) = @_;
+sub mk_group_accessors {
+ my ($class, $group, @cols) = @_;
unless ($class->can('accessor_name') || $class->can('mutator_name')) {
- return $class->NEXT::_mk_column_accessors('column' => @cols);
+ return $class->NEXT::mk_group_accessors($group => @cols);
}
foreach my $col (@cols) {
my $ro_meth = ($class->can('accessor_name')
? $class->mutator_name($col)
: $col);
if ($ro_meth eq $wo_meth) {
- $class->mk_group_accessors('column' => $col);
+ $class->mk_group_accessors($group => [ $ro_meth => $col ]);
} else {
- $class->mk_group_ro_accessors('column' => $ro_meth);
- $class->mk_group_wo_accessors('column' => $wo_meth);
+ $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
+ $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]);
}
}
}
return 1;
}
+sub has_many {
+ my ($class, $rel, $f_class, $f_key, @rest) = @_;
+ return $class->NEXT::ACTUAL::has_many($rel, $f_class, lc($f_key), @rest);
+}
+
sub get_has_a {
my ($class, $get, @rest) = @_;
return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest);
sub _mk_group_accessors {
my ($class, $type, $group, @fields) = @_;
- my %fields;
- $fields{$_} = 1 for @fields,
- map lc, grep { !defined &{"${class}::${_}"} } @fields;
- return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group, keys %fields);
+ #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
+ my @extra;
+ foreach (@fields) {
+ my ($acc, $field) = ref $_ ? @$_ : ($_, $_);
+ next if defined &{"${class}::${acc}"};
+ push(@extra, [ lc $acc => $field ]);
+ }
+ return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group,
+ @fields, @extra);
}
sub _cond_key {
sub _register_column_group {
my ($class, $group, @cols) = @_;
+
+ my $groups = { %{$class->_column_groups} };
+
if ($group eq 'Primary') {
$class->set_primary_key(@cols);
+ $groups->{'Essential'}{$_} ||= {} for @cols;
}
- my $groups = { %{$class->_column_groups} };
-
if ($group eq 'All') {
unless (exists $class->_column_groups->{'Primary'}) {
$groups->{'Primary'}{$cols[0]} = {};
$class->set_primary_key($cols[0]);
}
unless (exists $class->_column_groups->{'Essential'}) {
+ #$class->_register_column_group('Essential' => $cols[0]);
$groups->{'Essential'}{$cols[0]} = {};
+ #$groups->{'Essential'}{$_} ||= {} for keys %{ $class->_primaries || {} };
}
}
$groups->{$group}{$_} ||= {} for @cols;
- if ($group eq 'Essential') {
- $groups->{$group}{$_} ||= {} for keys %{ $class->_primaries || {} };
- }
+ #if ($group eq 'Essential') {
+ # $groups->{$group}{$_} ||= {} for keys %{ $class->_primaries || {} };
+ #}
+
$class->_column_groups($groups);
}
--- /dev/null
+package DBIx::Class::CDBICompat::HasA;
+
+use strict;
+use warnings;
+
+sub has_a {
+ my ($self, $col, $f_class) = @_;
+ die "No such column ${col}" unless $self->_columns->{$col};
+ eval "require $f_class";
+ my ($pri, $too_many) = keys %{ $f_class->_primaries };
+ die "has_a only works with a single primary key; ${f_class} has more"
+ if $too_many;
+ $self->add_relationship($col, $f_class,
+ { "foreign.${pri}" => "self.${col}" },
+ { _type => 'has_a' } );
+ $self->delete_accessor($col);
+ $self->mk_group_accessors('has_a' => $col);
+ return 1;
+}
+
+sub get_has_a {
+ my ($self, $rel) = @_;
+ #warn $rel;
+ #warn join(', ', %{$self->{_column_data}});
+ return $self->{_relationship_data}{$rel}
+ if $self->{_relationship_data}{$rel};
+ return undef unless $self->get_column($rel);
+ #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0];
+ return $self->{_relationship_data}{$rel} =
+ ($self->search_related($rel, {}, {}))[0]
+ || do {
+ my $f_class = $self->_relationships->{$rel}{class};
+ my ($pri) = keys %{$f_class->_primaries};
+ $f_class->new({ $pri => $self->get_column($rel) }); };
+}
+
+sub set_has_a {
+ my ($self, $rel, @rest) = @_;
+ my $ret = $self->store_has_a($rel, @rest);
+ $self->{_dirty_columns}{$rel} = 1;
+ return $ret;
+}
+
+sub store_has_a {
+ my ($self, $rel, $obj) = @_;
+ return $self->set_column($rel, $obj) unless ref $obj;
+ my $rel_obj = $self->_relationships->{$rel};
+ die "Can't set $rel: object $obj is not of class ".$rel_obj->{class}
+ unless $obj->isa($rel_obj->{class});
+ $self->{_relationship_data}{$rel} = $obj;
+ $self->set_column($rel, ($obj->_ident_values)[0]);
+ return $obj;
+}
+
+sub new {
+ my ($class, $attrs, @rest) = @_;
+ my %hasa;
+ foreach my $key (keys %$attrs) {
+ my $rt = $class->_relationships->{$key}{attrs}{_type};
+ next unless $rt && $rt eq 'has_a' && ref $attrs->{$key};
+ $hasa{$key} = delete $attrs->{$key};
+ }
+ my $new = $class->NEXT::ACTUAL::new($attrs, @rest);
+ foreach my $key (keys %hasa) {
+ $new->store_has_a($key, $hasa{$key});
+ }
+ return $new;
+}
+
+sub _cond_value {
+ my ($self, $attrs, $key, $value) = @_;
+ if ( my $rel_obj = $self->_relationships->{$key} ) {
+ my $rel_type = $rel_obj->{attrs}{_type} || '';
+ if ($rel_type eq 'has_a' && ref $value) {
+ die "Object $value is not of class ".$rel_obj->{class}
+ unless $value->isa($rel_obj->{class});
+ $value = ($value->_ident_values)[0];
+ #warn $value;
+ }
+ }
+ return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value);
+}
+
+1;
--- /dev/null
+package DBIx::Class::CDBICompat::HasMany;
+
+use strict;
+use warnings;
+
+sub has_many {
+ my ($class, $rel, $f_class, $f_key, $args) = @_;
+ #die "No such column ${col}" unless $class->_columns->{$col};
+ eval "require $f_class";
+ my ($pri, $too_many) = keys %{ $class->_primaries };
+ die "has_many only works with a single primary key; ${class} has more"
+ if $too_many;
+ if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
+ unless ($f_key) {
+ ($f_key) = grep { $f_class && $_->{class} eq $class }
+ $f_class->_relationships;
+ }
+ die "Unable to resolve foreign key for has_many from ${class} to ${f_class}"
+ unless $f_key;
+ die "No such column ${f_key} on foreign class ${f_class}"
+ unless $f_class->_columns->{$f_key};
+ $class->add_relationship($rel, $f_class,
+ { "foreign.${f_key}" => "self.${pri}" },
+ { _type => 'has_many', %{$args || {}} } );
+ {
+ no strict 'refs';
+ *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); };
+ *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); };
+ }
+ return 1;
+}
+
+sub delete {
+ my ($self, @rest) = @_;
+ return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
+ # I'm just ignoring this for class deletes because hell, the db should
+ # be handling this anyway. Assuming we have joins we probably actually
+ # *could* do them, but I'd rather not.
+
+ my $ret = $self->NEXT::ACTUAL::delete(@rest);
+
+ my %rels = %{ $self->_relationships };
+ my @hm = grep { $rels{$_}{attrs}{_type}
+ && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
+ foreach my $has_many (@hm) {
+ $_->delete for $self->search_related($has_many);
+ }
+ return $ret;
+}
+1;
sub _flesh {
my ($self, @groups) = @_;
+ @groups = ('All') unless @groups;
my %want;
$want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
- #warn "@want";
my $sth = $self->_get_sth('select', \@want, $self->_table_name,
$self->_ident_cond);
$sth->execute($self->_ident_values);
use warnings;
use base qw/DBIx::Class::Relationship
+ DBIx::Class::SQL::OrderBy
DBIx::Class::SQL::Abstract
DBIx::Class::PK
DBIx::Class::Table
--- /dev/null
+package DBIx::Class::PK::Auto;
+
+use strict;
+use warnings;
+
+sub insert {
+ my ($self, @rest) = @_;
+ my $ret = $self->NEXT::ACTUAL::insert(@rest);
+ my ($pri, $too_many) =
+ (grep { $self->_primaries->{$_}{'auto_increment'} }
+ keys %{ $self->_primaries })
+ || (keys %{ $self->_primaries });
+ die "More than one possible key found for auto-inc on ".ref $self
+ if $too_many;
+ unless (exists $self->{_column_data}{$pri}) {
+ die "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;
+ die "Can't get last insert id" unless $id;
+ $self->store_column($pri => $id);
+ }
+ return $ret;
+}
+
+1;
--- /dev/null
+package DBIx::Class::PK::Auto::SQLite;
+
+use strict;
+use warnings;
+
+sub _last_insert_id {
+ return $_[0]->_get_dbh->func('last_insert_rowid');
+}
+
+1;
--- /dev/null
+package DBIx::Class::Relationship;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_relationships', { } );
+
+sub add_relationship {
+ my ($class, $rel, $f_class, $cond, $attrs) = @_;
+ my %rels = %{ $class->_relationships };
+ $rels{$rel} = { class => $f_class,
+ cond => $cond,
+ attrs => $attrs };
+ $class->_relationships(\%rels);
+}
+
+sub _cond_key {
+ my ($self, $attrs, $key) = @_;
+ my $action = $attrs->{_action} || '';
+ if ($action eq 'convert') {
+ unless ($key =~ s/^foreign\.//) {
+ die "Unable to convert relationship to WHERE clause: invalid key ${key}";
+ }
+ return $key;
+ } elsif ($action eq 'join') {
+ my ($type, $field) = split(/\./, $key);
+ if ($attrs->{_aliases}{$type}) {
+ return join('.', $attrs->{_aliases}{$type}, $field);
+ } else {
+ die "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases}{$type} || {}});
+ }
+ }
+ return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
+}
+
+sub _cond_value {
+ my ($self, $attrs, $key, $value) = @_;
+ my $action = $attrs->{_action} || '';
+ if ($action eq 'convert') {
+ unless ($value =~ s/^self\.//) {
+ die "Unable to convert relationship to WHERE clause: invalid value ${value}";
+ }
+ unless ($self->can($value)) {
+ die "Unable to convert relationship to WHERE clause: no such accessor ${value}";
+ }
+ push(@{$attrs->{bind}}, $self->get_column($value));
+ return '?';
+ } elsif ($action eq 'join') {
+ my ($type, $field) = split(/\./, $value);
+ if ($attrs->{_aliases}{$type}) {
+ return join('.', $attrs->{_aliases}{$type}, $field);
+ } else {
+ die "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases}{$type} || {}});
+ }
+ }
+
+ return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
+}
+
+sub search_related {
+ my $self = shift;
+ my $rel = shift;
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+ my $rel_obj = $self->_relationships->{$rel};
+ die "No such relationship ${rel}" unless $rel;
+ $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}} };
+ my $s_cond;
+ if (@_) {
+ die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1));
+ my $query = ((@_ > 1) ? {@_} : shift);
+ $s_cond = $self->_cond_resolve($query, $attrs);
+ }
+ $attrs->{_action} = 'convert';
+ my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
+ $cond = "${s_cond} AND ${cond}" if $s_cond;
+ return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || {}});
+}
+
+sub create_related {
+ my ($self, $rel, $values, $attrs) = @_;
+ die "Can't call create_related as class method" unless ref $self;
+ die "create_related needs a hash" unless (ref $values eq 'HASH');
+ my $rel_obj = $self->_relationships->{$rel};
+ die "No such relationship ${rel}" unless $rel;
+ die "Can't abstract implicit create for ${rel}, condition not a hash"
+ unless ref $rel_obj->{cond} eq 'HASH';
+ $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
+ my %fields = %$values;
+ while (my ($k, $v) = each %{$rel_obj->{cond}}) {
+ $self->_cond_value($attrs, $k => $v);
+ $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
+ }
+ return $rel_obj->{class}->create(\%fields);
+}
+
+1;
sub _get_sql {
my ($class, $name, $cols, $from, $cond) = @_;
my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond);
- #warn $sql;
return $sql;
}
--- /dev/null
+package DBIx::Class::SQL::Abstract;
+
+# Many thanks to SQL::Abstract, from which I stole most of this
+
+sub _debug { }
+
+sub _cond_resolve {
+ my ($self, $cond, $attrs, $join) = @_;
+ my $ref = ref $cond || '';
+ $join ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND');
+ my $cmp = uc($attrs->{cmp}) || '=';
+
+ # For assembling SQL fields and values
+ my(@sqlf) = ();
+
+ # If an arrayref, then we join each element
+ if ($ref eq 'ARRAY') {
+ # need to use while() so can shift() for arrays
+ while (my $el = shift @$cond) {
+ my $subjoin = 'OR';
+
+ # skip empty elements, otherwise get invalid trailing AND stuff
+ if (my $ref2 = ref $el) {
+ if ($ref2 eq 'ARRAY') {
+ next unless @$el;
+ } elsif ($ref2 eq 'HASH') {
+ next unless %$el;
+ $subjoin = 'AND';
+ } elsif ($ref2 eq 'SCALAR') {
+ # literal SQL
+ push @sqlf, $$el;
+ next;
+ }
+ $self->_debug("$ref2(*top) means join with $subjoin");
+ } else {
+ # top-level arrayref with scalars, recurse in pairs
+ $self->_debug("NOREF(*top) means join with $subjoin");
+ $el = {$el => shift(@$cond)};
+ }
+ push @sqlf, scalar $self->_cond_resolve($el, $attrs, $subjoin);
+ }
+ }
+ elsif ($ref eq 'HASH') {
+ # Note: during recursion, the last element will always be a hashref,
+ # since it needs to point a column => value. So this be the end.
+ for my $k (sort keys %$cond) {
+ my $v = $cond->{$k};
+ if (! defined($v)) {
+ # undef = null
+ $self->_debug("UNDEF($k) means IS NULL");
+ push @sqlf, $k . ' IS NULL'
+ } elsif (ref $v eq 'ARRAY') {
+ # multiple elements: multiple options
+ $self->_debug("ARRAY($k) means multiple elements: [ @$v ]");
+
+ # map into an array of hashrefs and recurse
+ my @w = ();
+ push @w, { $k => $_ } for @$v;
+ push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
+
+ } elsif (ref $v eq 'HASH') {
+ # modified operator { '!=', 'completed' }
+ for my $f (sort keys %$v) {
+ my $x = $v->{$f};
+ $self->_debug("HASH($k) means modified operator: { $f }");
+
+ # check for the operator being "IN" or "BETWEEN" or whatever
+ if ($f =~ /^([\s\w]+)$/i && ref $x eq 'ARRAY') {
+ my $u = uc($1);
+ if ($u =~ /BETWEEN/) {
+ # SQL sucks
+ die "BETWEEN must have exactly two arguments" unless @$x == 2;
+ push @sqlf, join ' ',
+ $self->_cond_key($attrs => $k), $u,
+ $self->_cond_value($attrs => $k => $x->[0]),
+ 'AND',
+ $self->_cond_value($attrs => $k => $x->[1]);
+ } else {
+ push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(',
+ join(', ',
+ map { $self->_cond_value($attrs, $k, $_) } @$x),
+ ')';
+ }
+ } elsif (ref $x eq 'ARRAY') {
+ # multiple elements: multiple options
+ $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
+
+ # map into an array of hashrefs and recurse
+ my @w = ();
+ push @w, { $k => { $f => $_ } } for @$x;
+ push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
+
+ } elsif (! defined($x)) {
+ # undef = NOT null
+ my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : '';
+ push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL";
+ } else {
+ # regular ol' value
+ push @sqlf, join ' ', $self->_cond_key($attrs => $k), $f,
+ $self->_cond_value($attrs => $k => $x);
+ }
+ }
+ } elsif (ref $v eq 'SCALAR') {
+ # literal SQL
+ $self->_debug("SCALAR($k) means literal SQL: $$v");
+ push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v;
+ } else {
+ # standard key => val
+ $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v");
+ push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp,
+ $self->_cond_value($attrs => $k => $v);
+ }
+ }
+ }
+ elsif ($ref eq 'SCALAR') {
+ # literal sql
+ $self->_debug("SCALAR(*top) means literal SQL: $$cond");
+ push @sqlf, $$cond;
+ }
+ elsif (defined $cond) {
+ # literal sql
+ $self->_debug("NOREF(*top) means literal SQL: $cond");
+ push @sqlf, $cond;
+ }
+
+ # assemble and return sql
+ my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '';
+ return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql;
+}
+
+sub _cond_key {
+ my ($self, $attrs, $key) = @_;
+ return $key;
+}
+
+sub _cond_value {
+ my ($self, $attrs, $key, $value) = @_;
+ push(@{$attrs->{bind}}, $value);
+ return '?';
+}
+
+1;
--- /dev/null
+package DBIx::Class::SQL::OrderBy;
+
+use strict;
+use warnings;
+
+sub _cond_resolve {
+ my ($self, $cond, $attrs, @rest) = @_;
+ return $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest)
+ unless wantarray;
+ my ($sql, @bind) = $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest);
+ if ($attrs->{order_by}) {
+ $sql .= " ORDER BY ".join(', ', (ref $attrs->{order_by} eq 'ARRAY'
+ ? @{$attrs->{order_by}}
+ : $attrs->{order_by}));
+ }
+ return ($sql, @bind);
+}
+
+1;
sub delete {
my $self = shift;
if (ref $self) {
+ #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
my $sth = $self->_get_sth('delete', undef,
$self->_table_name, $self->_ident_cond);
$sth->execute($self->_ident_values);
$cond =~ s/^\s*WHERE//i;
my @cols = $class->_select_columns;
my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
+ #warn "$cond @vals";
return $class->sth_to_objects($sth, \@vals, \@cols);
}
=head1 NAME
-DBIx::Class::Test::SQLite - Base class for DBIx::Class tests, shamelessly ripped from Class::DBI::Test::SQLite
+DBIx::Class::Test::SQLite - Base class for running Class::DBI tests against DBIx::Class compat layer, shamelessly ripped from Class::DBI::Test::SQLite
=head1 SYNOPSIS
use strict;
-use base 'DBIx::Class';
+use base qw/DBIx::Class::PK::Auto::SQLite DBIx::Class::PK::Auto DBIx::Class/;
use File::Temp qw/tempfile/;
my (undef, $DB) = tempfile();
END { unlink $DB if -e $DB }
--- /dev/null
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 30);
+}
+
+
+use lib 't/testlib';
+use Film;
+use Actor;
+Film->has_many(actors => Actor => 'Film', { order_by => 'name' });
+Actor->has_a(Film => 'Film');
+is(Actor->primary_column, 'id', "Actor primary OK");
+
+ok(Actor->can('Salary'), "Actor table set-up OK");
+ok(Film->can('actors'), " and have a suitable method in Film");
+
+Film->create_test_film;
+
+ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
+
+ok(
+ my $pvj = Actor->create(
+ {
+ Name => 'Peter Vere-Jones',
+ Film => undef,
+ Salary => '30_000', # For a voice!
+ }
+ ),
+ 'create Actor'
+);
+is $pvj->Name, "Peter Vere-Jones", "PVJ name ok";
+is $pvj->Film, undef, "No film";
+ok $pvj->set_Film($btaste), "Set film";
+$pvj->update;
+is $pvj->Film->id, $btaste->id, "Now film";
+{
+ my @actors = $btaste->actors;
+ is(@actors, 1, "Bad taste has one actor");
+ is($actors[0]->Name, $pvj->Name, " - the correct one");
+}
+
+my %pj_data = (
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+);
+
+eval { my $pj = Film->add_to_actors(\%pj_data) };
+like $@, qr/class/, "add_to_actors must be object method";
+
+eval { my $pj = $btaste->add_to_actors(%pj_data) };
+like $@, qr/needs/, "add_to_actors takes hash";
+
+ok(
+ my $pj = $btaste->add_to_actors(
+ {
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+ }
+ ),
+ 'add_to_actors'
+);
+is $pj->Name, "Peter Jackson", "PJ ok";
+is $pvj->Name, "Peter Vere-Jones", "PVJ still ok";
+
+{
+ my @actors = $btaste->actors;
+ is @actors, 2, " - so now we have 2";
+ is $actors[0]->Name, $pj->Name, "PJ first";
+ is $actors[1]->Name, $pvj->Name, "PVJ first";
+}
+
+eval {
+ my @actors = $btaste->actors(Name => $pj->Name);
+ is @actors, 1, "One actor from restricted (sorted) has_many";
+ is $actors[0]->Name, $pj->Name, "It's PJ";
+};
+is $@, '', "No errors";
+
+my $as = Actor->create(
+ {
+ Name => 'Arnold Schwarzenegger',
+ Film => 'Terminator 2',
+ Salary => '15_000_000'
+ }
+);
+
+eval { $btaste->actors($pj, $pvj, $as) };
+ok $@, $@;
+is($btaste->actors, 2, " - so we still only have 2 actors");
+
+my @bta_before = Actor->search(Film => 'Bad Taste');
+is(@bta_before, 2, "We have 2 actors in bad taste");
+ok($btaste->delete, "Delete bad taste");
+my @bta_after = Actor->search(Film => 'Bad Taste');
+is(@bta_after, 0, " - after deleting there are no actors");
+
+# While we're here, make sure Actors have unreadable mutators and
+# unwritable accessors
+
+eval { $as->Name("Paul Reubens") };
+ok $@, $@;
+eval { my $name = $as->set_Name };
+ok $@, $@;
+
+is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");
+
projects / dbsrgits/DBIx-Class.git / commitdiff