sub create {
my ($class, $attrs, @rest) = @_;
- die "create needs a hashref" unless ref $attrs eq 'HASH';
+ $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
$attrs = { %$attrs };
my %att;
foreach my $col (keys %{ $class->_columns }) {
sub has_a {
my ($self, $col, $f_class) = @_;
- die "No such column ${col}" unless $self->_columns->{$col};
+ $self->throw( "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"
+ $self->throw( "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}" },
return $self->store_column($rel, $obj);
}
my $rel_obj = $self->_relationships->{$rel};
- die "Can't set $rel: object $obj is not of class ".$rel_obj->{class}
+ $self->throw( "Can't set $rel: object $obj is not of class ".$rel_obj->{class} )
unless $obj->isa($rel_obj->{class});
$self->{_relationship_data}{$rel} = $obj;
#warn "Storing $obj: ".($obj->_ident_values)[0];
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}
+ $self->throw( "Object $value is not of class ".$rel_obj->{class} )
unless $value->isa($rel_obj->{class});
$value = ($value->_ident_values)[0];
#warn $value;
if (!$self_key || $self_key eq 'id') {
my ($pri, $too_many) = keys %{ $class->_primaries };
- die "has_many only works with a single primary key; ${class} has more"
+ $class->throw( "has_many only works with a single primary key; ${class} has more" )
if $too_many;
$self_key = $pri;
}
$f_key = lc $1 if $f_class->_columns->{lc $1};
}
- die "Unable to resolve foreign key for has_many from ${class} to ${f_class}"
+ $class->throw( "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}"
+ $class->throw( "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.${self_key}" },
($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
values %{ $from_class->_relationships };
}
- die "No relationship to JOIN from ${from_class} to ${to_class}"
+ $self->throw( "No relationship to JOIN from ${from_class} to ${to_class}" )
unless $rel_obj;
my $attrs = {
_aliases => { self => $from, foreign => $to },
DBIx::Class::Table
DBIx::Class::SQL
DBIx::Class::DB
+ DBIx::Class::Exception
DBIx::Class::AccessorGroup/;
1;
--- /dev/null
+package DBIx::Class::Exception;
+
+use strict;
+use vars qw[@ISA $DBIC_EXCEPTION_CLASS];
+use UNIVERSAL::require;
+
+BEGIN {
+ push( @ISA, $DBIC_EXCEPTION_CLASS || 'DBIx::Class::Exception::Base' );
+}
+
+package DBIx::Class::Exception::Base;
+
+use strict;
+use Carp ();
+
+=head1 NAME
+
+DBIx::Class::Exception - DBIC Exception Class
+
+=head1 SYNOPSIS
+
+ DBIx::Class::Exception->throw( qq/Fatal exception/ );
+
+See also L<DBIx::Class>.
+
+=head1 DESCRIPTION
+
+This is a generic Exception class for DBIx::Class. You can easily
+replace this with any mechanism implementing 'throw' by setting
+$DBix::Class::Exception::DBIC_EXCEPTION_CLASS
+
+=head1 METHODS
+
+=over 4
+
+=item throw( $message )
+
+=item throw( message => $message )
+
+=item throw( error => $error )
+
+Throws a fatal exception.
+
+=cut
+
+sub throw {
+ my $class = shift;
+ my %params = @_ == 1 ? ( error => $_[0] ) : @_;
+
+ my $message = $params{message} || $params{error} || $! || '';
+
+ local $Carp::CarpLevel = 1;
+
+ Carp::croak($message);
+}
+
+=back
+
+=head1 AUTHOR
+
+Marcus Ramberg <mramberg@cpan.org>
+
+=head1 THANKS
+
+Thanks to the L<Catalyst> framework, where this module was borrowed
+from.
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
my ($class, @vals) = @_;
my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
my @pk = keys %{$class->_primaries};
- die "Can't retrieve unless primary columns are defined" unless @pk;
+ $class->throw( "Can't retrieve unless primary columns are defined" )
+ unless @pk;
my $query;
if (ref $vals[0] eq 'HASH') {
$query = $vals[0];
} else {
$query = {@vals};
}
- die "Can't retrieve unless all primary keys are specified"
+ $class->throw( "Can't retrieve unless all primary keys are specified" )
unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
# column names etc. Not sure what to do yet
my $ret = ($class->search($query))[0];
sub id {
my ($self) = @_;
- die "Can't call id() as a class method" unless ref $self;
+ $self->throw( "Can't call id() as a class method" ) unless ref $self;
my @pk = $self->_ident_values;
return (wantarray ? @pk : $pk[0]);
}
(grep { $self->_primaries->{$_}{'auto_increment'} }
keys %{ $self->_primaries })
|| (keys %{ $self->_primaries });
- die "More than one possible key found for auto-inc on ".ref $self
+ $self->throw( "More than one possible key found for auto-inc on ".ref $self )
if $too_many;
unless (defined $self->get_column($pri)) {
- die "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method"
+ $self->throw( "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->throw( "Can't get last insert id" ) unless $id;
$self->store_column($pri => $id);
}
return $ret;
my $action = $attrs->{_action} || '';
if ($action eq 'convert') {
unless ($key =~ s/^foreign\.//) {
- die "Unable to convert relationship to WHERE clause: invalid key ${key}";
+ $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
}
return $key;
} elsif ($action eq 'join') {
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} || {}});
+ $self->throw( "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases}{$type} || {}}) );
}
}
return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
my $action = $attrs->{_action} || '';
if ($action eq 'convert') {
unless ($value =~ s/^self\.//) {
- die "Unable to convert relationship to WHERE clause: invalid value ${value}";
+ $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
}
unless ($self->_columns->{$value}) {
- die "Unable to convert relationship to WHERE clause: no such accessor ${value}";
+ $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
}
push(@{$attrs->{bind}}, $self->get_column($value));
return '?';
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} || {}});
+ $self->throw( "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases}{$type} || {}}) );
}
}
$attrs = { %{ pop(@_) } };
}
my $rel_obj = $self->_relationships->{$rel};
- die "No such relationship ${rel}" unless $rel;
+ $self->throw( "No such relationship ${rel}" ) unless $rel;
$attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
my $s_cond;
if (@_) {
- die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1));
+ $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
my $query = ((@_ > 1) ? {@_} : shift);
$s_cond = $self->_cond_resolve($query, $attrs);
}
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');
+ $self->throw( "Can't call create_related as class method" )
+ unless ref $self;
+ $self->throw( "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"
+ $self->throw( "No such relationship ${rel}" ) unless $rel;
+ $self->throw( "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;
my $u = uc($1);
if ($u =~ /BETWEEN/) {
# SQL sucks
- die "BETWEEN must have exactly two arguments" unless @$x == 2;
+ $self->throw( "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]),
$class = ref $class if ref $class;
my $new = bless({ _column_data => { } }, $class);
if ($attrs) {
- die "attrs must be a hashref" unless ref($attrs) eq 'HASH';
+ $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
while (my ($k, $v) = each %{$attrs}) {
$new->store_column($k => $v);
}
sub create {
my ($class, $attrs) = @_;
- die "create needs a hashref" unless ref $attrs eq 'HASH';
+ $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
return $class->new($attrs)->insert;
}
sub update {
my ($self) = @_;
- die "Not in database" unless $self->in_database;
+ $self->throw( "Not in database" ) unless $self->in_database;
my @to_update = keys %{$self->{_dirty_columns} || {}};
return -1 unless @to_update;
my $sth = $self->_get_sth('update', \@to_update,
$self->_ident_values );
$sth->finish;
if ($rows == 0) {
- die "Can't update $self: row not found";
+ $self->throw( "Can't update $self: row not found" );
} elsif ($rows > 1) {
- die "Can't update $self: updated more than one row";
+ $self->throw("Can't update $self: updated more than one row");
}
$self->{_dirty_columns} = {};
return $self;
sub delete {
my $self = shift;
if (ref $self) {
- die "Not in database" unless $self->in_database;
+ $self->throw( "Not in database" ) unless $self->in_database;
#warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
my $sth = $self->_get_sth('delete', undef,
$self->_table_name, $self->_ident_cond);
sub get_column {
my ($self, $column) = @_;
- die "Can't fetch data as class method" unless ref $self;
- die "No such column '${column}'" unless $self->_columns->{$column};
+ $self->throw( "Can't fetch data as class method" ) unless ref $self;
+ $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column};
return $self->{_column_data}{$column}
if exists $self->{_column_data}{$column};
return undef;
sub store_column {
my ($self, $column, $value) = @_;
- die "No such column '${column}'" unless $self->_columns->{$column};
- die "set_column called for ${column} without value" if @_ < 3;
+ $self->throw( "No such column '${column}'" )
+ unless $self->_columns->{$column};
+ $self->throw( "set_column called for ${column} without value" )
+ if @_ < 3;
return $self->{_column_data}{$column} = $value;
}
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff