Class-Tables
view release on metacpan or search on metacpan
lib/Class/Tables.pm view on Meta::CPAN
package Class::Tables;
use Carp;
use Storable qw/retrieve nstore/;
use strict;
use warnings;
use vars qw/$VERSION $DBH $DB_DRIVER $SQL_DEBUG $INFLECT $SQL_QUERIES $CASCADE/;
$VERSION = "0.28";
$INFLECT = 1;
$CASCADE = 1;
## flyweight data
my ( %CLASS, %OBJ, %TABLE_MAP, $SCHEMA_CACHE );
######################
## public interface ##
######################
sub import {
my ($class, %args) = @_;
$CASCADE = $args{cascade} if exists $args{cascade};
$INFLECT = $args{inflect} if exists $args{inflect};
$SCHEMA_CACHE = $args{cache} if exists $args{cache};
}
sub dbh {
my ($super, $dbh) = @_;
croak "No DBH given" unless $dbh;
($DBH, $DB_DRIVER, %CLASS, %OBJ, %TABLE_MAP) =
($dbh, "Class::Tables::$dbh->{Driver}{Name}");
eval "use $DB_DRIVER; 1;"
or croak "$dbh->{Driver}{Name} is an unsupported database driver";
$super->_parse_tables();
}
#############################
## inherited class methods ##
#############################
sub fetch {
my ($class, $id) = @_;
my $id_col = $class->_id_col;
return exists $OBJ{$class}{$id}
? $class->_mk_obj($id)
: scalar $class->_get_objs("where $id_col=?", $id);
}
sub search {
my ($class, %params) = @_;
return unless defined wantarray;
my @fields = grep { exists $CLASS{$class}{accessors}{$_} }
keys %params;
my @binds = map { UNIVERSAL::can($_, 'id') ? $_->id : $_ }
grep { defined } @params{@fields};
my $clause = (@fields ? "where " : "");
$clause .= join " and " => map {
my $col = $CLASS{$class}{accessors}{$_}{col};
defined $params{$_} ? "$col=?" : "$col is null"
} @fields;
$clause .= " order by " . $class->_order_by;
$clause .= " limit 1" unless wantarray;
return $class->_get_objs($clause, @binds);
}
sub new {
my ($class, %params) = @_;
delete $params{id};
my @fields = grep { exists $CLASS{$class}{accessors}{$_} } keys %params;
my @binds = map { UNIVERSAL::can($_, 'id') ? $_->id : $_ } @params{@fields};
my @cols = map { $CLASS{$class}{accessors}{$_}{col} } @fields;
my $table = $class->_table;
my $sql = sprintf "insert into $table (%s) values (%s)",
lib/Class/Tables.pm view on Meta::CPAN
my $id = $self->id;
my $class = ref $self;
my $table = $class->_table;
my $id_col = $class->_id_col;
return keys %{ $CLASS{$class}{accessors} }
unless defined $field;
croak qq{Can't locate accessor "$field" via package "$class"}
unless exists $CLASS{$class}{accessors}{$field};
my $type = $CLASS{$class}{accessors}{$field}{type};
my $ref = $CLASS{$class}{accessors}{$field}{ref};
my $col = $CLASS{$class}{accessors}{$field}{col};
return $TABLE_MAP{$ref}->search( $col => $id, @_ )
if $type eq '1-to-n';
## lazy-load columns now
$OBJ{$class}{$id}{$col} =
sql_do("select $col from $table where $id_col=?", $id)
if not exists $OBJ{$class}{$id}{$col};
if ( $type eq '1-to-1' ) {
if (@_) {
my $ref_id = UNIVERSAL::can($_[0], 'id') ? $_[0]->id : $_[0];
sql_do("update $table set $col=? where $id_col=?", $ref_id, $id)
and $OBJ{$class}{$id}{$col} = $ref_id;
}
## inflate keys
return unless defined wantarray;
return $TABLE_MAP{$ref}->fetch( $OBJ{$class}{$id}{$col} )
if defined $OBJ{$class}{$id}{$col};
} elsif ( $type eq 'normal' ) {
if (@_) {
if (defined $_[0]) {
sql_do("update $table set $col=? where $id_col=?", $_[0], $id)
and $OBJ{$class}{$id}{$col} = shift;
} else {
sql_do("update $table set $col=null where $id_col=?", $id)
and $OBJ{$class}{$id}{$col} = shift;
}
}
}
return $OBJ{$class}{$id}{$col};
}
sub delete {
my $self = shift;
my $id = $self->id;
my $class = ref $self;
my $table = $class->_table;
my $id_col = $class->_id_col;
if ($CASCADE) {
my @cascade = grep { $CLASS{$class}{accessors}{$_}{type} eq '1-to-n' }
keys %{ $CLASS{$class}{accessors} };
for my $accessor (@cascade) {
$_->delete for $self->$accessor;
}
}
sql_do("delete from $table where $id_col=?", $id);
delete $OBJ{$class}{$id};
}
use overload
fallback => 1,
'""' => sub {
my $self = shift;
my $class = ref $self;
return exists $CLASS{$class}{accessors}{'name'}
? $self->name
: $class . ":" . $self->id;
},
'bool' => sub { 1 };
###################################
## play nice with HTML::Template ##
###################################
sub dump {
my ($self, @ignore) = @_;
my $class = ref $self;
my $table = $class->_table;
my %ignore = map { $_ => 1 } @ignore;
my @fields = grep { not $ignore{ $CLASS{$class}{accessors}{$_}{ref} } }
keys %{ $CLASS{$class}{accessors} };
push @ignore, $table;
my %h = map {
my $type = $CLASS{$class}{accessors}{$_}{type};
my @result = $self->$_;
my %values;
if ($type eq '1-to-n') {
$values{$_} = [ map { $_->dump(@ignore) } @result ];
} elsif ($type eq '1-to-1') {
if ($result[0]) {
my $r = $result[0]->dump(@ignore);
my $prefix = $_;
%values = map {; "$prefix.$_" => $r->{$_} } keys %$r;
} else {
$values{$_} = undef;
}
} elsif ($type eq 'normal') {
$values{$_} = $result[0];
}
%values;
lib/Class/Tables.pm view on Meta::CPAN
C<integer primary key>) using the same naming conventions as above.
Alternatively, you may omit an explicit primary key column and Class::Tables
will use the hidden C<ROWID> column.
In Postgres, the primary key column must be a C<serial primary key>. Using
the hidden C<oid> column as primary key is not (yet) supported.
=item Foreign Key Inflating
If a column has the same name as another table (plus or minus pluralization),
that column is treated as a foreign key reference to that table. The column
name may also have an optional C<_id> suffix and C<tablename_> prefix, where
C<tablename> is the name of the current table (plus or minus pluralization).
The name of the accessor is the name of the column, without the optional
prefix and suffix.
In our above example, the foreign key column relating each employee with a
department could have been anything matching
C</^(employees?_)?(departments?)(_id)?$/>, with the accessor being named the
value of $2 in that expression. Again, the flexibility allows for a meaningful
column name whether your table names are singular or plural. (See
L<Plural And Singular Nouns>).
The foreign key relationship is also reversed as described in the example. The
name of the accessor in the opposite 1-to-1ion is the name of the table. In
our example, this means that objects of the C<Departments> class get an
accessor named C<employees>. For this reason, it is often convenient to name
the tables as plural nouns.
=item Lazy Loading
All C<*blob> and C<*text> columns will be lazy-loaded: not loaded from the
database until their values are requested or changed.
=item Automatic Sort Order
The first column in the table which is not the primary key is the default
sort order for the class. All operations that return a list of objects will be
sorted in this order (ascending). In our above example, both tables are sorted
on C<name>.
=item Stringification
If the table has a C<name> accessor, then any objects of that type will
stringify to the value of C<< $obj->name >>. Otherwise, the object will
stringify to C<CLASS:ID>.
=back
=head2 Public Interface
=over
=item C<< use Class::Tables %args >>
Valid argument keys are:
=over
=item cascade
Takes a boolean value indicating whether to perform cascading deletes. See
C<delete> below for information on cascading deletes. If you need to change
cascading delete behavior on the fly, localize C<$Class::Tables::CASCADE>.
=item inflect
Takes a boolean value indicating whether to use
L<Lingua::EN::Inflect|Lingua::EN::Inflect> for plural & singular nouns. See
L<Plural And Singular Nouns> for more information on noun pluralization.
=item cache
Takes a filename argument of a schema cache. This speeds up slow databases and
large schemas. It uses L<Storable|Storable> to save the results of the schema
mapping, and on each subsequent execution, uses the cache to keep from doing
the mapping again. If your database's schema changes, simply empty the cache
file to force a re-mapping.
You can omit this arg or pass a false value to disable this feature.
=back
The default behavior is:
use Class::Tables cascade => 1, inflect => 1, cache => undef;
=item C<< Class::Tables->dbh($dbh) >>
You must pass Class::Tables an active database handle before you can use any
generated object classes.
=back
=head2 Object Instance Methods
Every object in a Class::Tables-generated class has the following methods:
=over
=item C<< $obj->id >>
This readonly accessor returns the primary key of the object.
=item C<< $obj->delete >>
Removes the object from the database. The behavior of further method calls on
the object are undefined.
If cascading deletes are enabled, then all other objects in the database that
have foreign keys pointing to C<$obj> are deleted as well, and so on. Cyclic
references are not handled gracefully, so if you have a complicated
database structure, you should disable cascading deletes. You can roll your
own cascading delete (to add finer control) very simply:
package Department;
sub delete {
my $self = shift;
$_->delete for $self->employees;
$self->SUPER::delete;
}
It's important to point out that in this process, if an object looses all
foreign key references to it, it is not deleted. For example, if all
Employees in a certain department are deleted, the department object is not
automatically deleted. If you want this behavior, you must add it yourself
in the Employees::delete method.
=item C<< $obj->attrib >> and C<< $obj->attrib($new_val) >>
For normal columns in the table (that is, columns not determined to be a
foreign key reference), accessor/mutator methods are provided to get and
set the value of the column, depending if an argument is given.
For foreign key reference columns, calling the method as an accessor is
equivalent to a C<fetch> (see below) on the appropriate class, so will return
the referent object or C<undef> if there is no such object. When called as a
mutator, the argument may be either an ID or an appropriate object:
## both are ok:
$self->department( $marketing );
$self->department( 10 );
For the reverse-mapped foreign key references, the method is readonly, and
returns a list of objects. It is equivalent to a C<search> (see below) on the
( run in 1.102 second using v1.01-cache-2.11-cpan-df04353d9ac )