X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=e15745b08f613eca147ae6aa8c63d4d7f738892d;hb=dd369c8a18080c4f27237f23b5842d53da05f570;hp=dd9af06c71472df111a129e51bda562173becf65;hpb=41a93152a01bdeab5ada42fd423f985554ade78e;p=maypole.git diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index dd9af06..e15745b 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,6 +1,8 @@ package Maypole::Model::CDBI; use strict; +use Data::Dumper; + =head1 NAME Maypole::Model::CDBI - Model class based on Class::DBI @@ -16,29 +18,48 @@ It implements a base set of methods required for a Maypole Data Model. It inherits accessor and helper methods from L. +When specified as the application model, it will use Class::DBI::Loader +to generate the model classes from the provided database. If you do not +wish to use this functionality, use L which +will instead use Class::DBI classes provided. + =cut use base qw(Maypole::Model::Base Class::DBI); -use Maypole::Model::CDBI::AsForm; -use CGI::Untaint::Maypole; - -use Class::DBI::FromCGI; +#use Class::DBI::Plugin::Type; use Class::DBI::Loader; use Class::DBI::AbstractSearch; use Class::DBI::Plugin::RetrieveAll; use Class::DBI::Pager; - use Lingua::EN::Inflect::Number qw(to_PL); +use attributes (); +use Maypole::Model::CDBI::AsForm; +use Maypole::Model::CDBI::FromCGI; +use CGI::Untaint::Maypole; -############################################################################### -# Helper methods +=head2 Untainter + +Set the class you use to untaint and validate form data +Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint + +=cut +sub Untainter { 'CGI::Untaint::Maypole' }; + +# or if you like bugs + +#use Class::DBI::FromCGI; +#use CGI::Untaint; +#sub Untainter { 'CGI::Untaint' }; + + +__PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/); =head1 Action Methods Action methods are methods that are accessed through web (or other public) interface. -=item do_edit +=head2 do_edit If there is an object in C<$r-Eobjects>, then it should be edited with the parameters in C<$r-Eparams>; otherwise, a new object should @@ -54,15 +75,15 @@ sub do_edit : Exported { my $config = $r->config; my $table = $r->table; - # handle cancel button hits + # handle cancel button hit if ( $r->{params}->{cancel} ) { $r->template("list"); $r->objects( [$self->retrieve_all] ); return; } - my $required_cols = $config->{$table}->{required_cols} || []; - my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || []; + my $required_cols = $config->{$table}{required_cols} || $self->required_columns; + my $ignored_cols = $config->{$table}{ignore_cols} || []; ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); @@ -72,14 +93,35 @@ sub do_edit : Exported { if (%errors) { # Set it up as it was: $r->template_args->{cgi_params} = $r->params; - $r->template_args->{errors} = \%errors; + + # replace user unfriendly error messages with something nicer + + foreach (@{$config->{$table}->{required_cols}}) { + next unless ($errors{$_}); + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value'; + $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value'; + delete $errors{$key}; + } + + foreach (keys %errors) { + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field'; + $r->template_args->{errors}{$key} = 'Please provide a valid value for this field'; + } undef $obj if $creating; + + die "do_update failed with error : $fatal" if ($fatal); $r->template("edit"); } else { $r->template("view"); } + + $r->objects( $obj ? [$obj] : []); } @@ -89,7 +131,8 @@ sub _do_update_or_create { my $fatal; my $creating = 0; - my $h = CGI::Untaint::Maypole->new( %{$r->params} ); + + my $h = $self->Untainter->new( %{$r->params} ); # update or create if ($obj) { @@ -97,25 +140,27 @@ sub _do_update_or_create { eval { $obj->update_from_cgi( $h => { required => $required_cols, ignore => $ignored_cols, - } ) }; + }); + $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit' + }; $fatal = $@; } else { - eval { - $obj = $self->create_from_cgi( $h => { + eval { + $obj = $self->create_from_cgi( $h => { required => $required_cols, ignore => $ignored_cols, - } ) - }; - - if ($fatal = $@) { - warn "$fatal" if $r->debug; - } - $creating++; + } ); + }; + $fatal = $@; + $creating++; } - return $obj, $fatal, $creating; } +=head2 delete + +Deprecated method that calls do_delete or a given classes delete method, please +use do_delete instead =head2 do_delete @@ -128,20 +173,29 @@ This method replaces the, now deprecated, delete method provided in prior versio sub delete : Exported { my $self = shift; my ($sub) = (caller(1))[3]; + # So subclasses can still send delete down ... $sub =~ /^(.+)::([^:]+)$/; - # So subclasses can still send search down ... - return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ? - $self->SUPER::search(@_) : $self->do_delete(@_); + if ($1 ne "Maypole::Model::Base" && $2 ne "delete") { + $self->SUPER::delete(@_); + } else { + warn "Maypole::Model::CDBI delete method is deprecated\n"; + $self->do_delete(@_); + } } sub do_delete { my ( $self, $r ) = @_; + # FIXME: handle fatal error with exception $_->SUPER::delete for @{ $r->objects || [] }; +# $self->dbi_commit; $r->objects( [ $self->retrieve_all ] ); $r->{template} = "list"; $self->list($r); } +=head2 search + +Deprecated searching method - use do_search instead. =head2 do_search @@ -153,10 +207,13 @@ the, now deprecated, search method previously provided. sub search : Exported { my $self = shift; my ($sub) = (caller(1))[3]; - $sub =~ /^(.+)::([^:]+)$/; # So subclasses can still send search down ... - return ($1 ne "Maypole::Model::Base" && $2 ne "search") ? - $self->SUPER::search(@_) : $self->do_search(@_); + if ($sub =~ /^(.+)::([^:]+)$/) { + return ($1 ne "Maypole::Model::Base" && $2 ne "search") ? + $self->SUPER::search(@_) : $self->do_search(@_); + } else { + $self->SUPER::search(@_); + } } sub do_search : Exported { @@ -201,85 +258,6 @@ sub list : Exported { } } -####################### -# _process_local_srch # -####################### - -# Makes the local part of the db search query -# Puts search prams local to this table in where array. -# Returns a where array ref and search criteria string. -# This is factored out of do_search so sub classes can override this part -sub _process_local_srch { - my ($self, $hashed) = @_; - my %fields = map { $_ => 1 } $self->columns; - my $moniker = $self->moniker; - my %colnames = $self->column_names; - my $srch_crit = ''; - my ($oper, $wc); - my @where = map { - # prelim - $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'"; - $oper = $self->sql_search_oper($_); - $wc = $oper =~ /LIKE/i ? '%':''; # match any substr - "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause - } - grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} } - keys %$hashed; - - return (\@where, $srch_crit); -} - -######################### -# _process_foreign_srch # -######################### - -# puts foreign search fields into select statement -# changes @where by ref and return sel and srch_criteria string -sub _process_foreign_srch { - my ($self, $hashed, $sel, $where, $srch_crit) = @_; - my %colnames = $self->column_names; - my $moniker = $self->moniker; - my %foreign; - foreach (keys %$hashed) { - $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_}; - } - my %accssr_class = %{$self->accessor_classes}; - while (my ( $accssr, $prms) = each %foreign ) { - my $fclass = $accssr_class{$accssr}; - my %fields = map { $_ => 1 } $fclass->columns; - my %colnames = $fclass->column_names; - my ($oper, $wc); - my @this_where = - # TODO make field name match in all cases in srch crit - map { - # prelim - $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'"; - $oper = $fclass->sql_search_oper($_); - $wc = $oper =~ /LIKE/i ? '%':''; - "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where - } - grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} } - keys %$prms; - - next unless @this_where; - $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from - - # map relationships -- TODO use constraints in has_many and mhaves - # and make general - my $pk = $self->primary_column; - if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) { - unshift @this_where, ("$accssr.owner_id = $moniker.$pk", - "$accssr.owner_table = '" . $self->table ."'"); - } - # for has_own, has_a where foreign id is in self's table - elsif ( my $fk = $self->find_column($fclass->primary_column) ) { - unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name; - } - push @$where, @this_where; - } - return ($sel, $srch_crit); -} - ############################################################################### # Helper methods @@ -301,67 +279,6 @@ sub adopt { } } -=head2 is_public - -Should return true if a certain action is supported, or false otherwise. -Defaults to checking if the sub has the C<:Exported> attribute. - -=cut - -sub is_public { - my ( $self, $action, $attrs ) = @_; - my $cv = $self->can($action); - warn "is_public failed . action is $action. self is $self" and return 0 unless $cv; - unless ($attrs) { - my @attrs = attributes::get($cv) || (); - $attrs = join " ", @attrs; - } - do { - warn "is_public failed .$action not exported" if Maypole->debug; - return 0; - } unless $attrs =~ /\bExported\b/i; - return 1; -} - - -=head2 is_class - -Tell if action is a class method (See Maypole::Plugin::Menu) - -=cut - -sub is_class { - my ( $self, $method, $attrs ) = @_; - die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); - return 1 if $attrs =~ /\bClass\b/i; - return 1 if $method =~ /^list$/; # default class actions - return 0; -} - -=head2 is_object - -Tell if action is a object method (See Maypole::Plugin::Menu) - -=cut - -sub is_object { - my ( $self, $method, $attrs ) = @_; - die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); - return 1 if $attrs =~ /\bObject\b/i; - return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions - return 0; -} - -# Get string of joined attributes for matching -sub method_attrs { - my ($class, $method) = @_; - my $cv = $class->can($method); - return 0 unless $cv; - my @attrs = attributes::get($cv) || (); - return join " ", @attrs; -} =head2 related @@ -402,56 +319,30 @@ sub related_class { } } -=head2 isa_class +=head2 related_meta -Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels) + $class->related_meta($col); -=cut - -sub isa_class { - my ($class, $col) = @_; - $class->_croak( "Need a column for isa_class." ) unless $col; - my $isaclass; - # class col is first found in is returned - my $isa = $class->meta_info("is_a") || {}; - foreach ( keys %$isa ) { - $isaclass = $isa->{$_}->foreign_class; - return $isaclass if ($isaclass->find_column($col)); - } - return 0; # col not in a is_a class -} - -=head2 accessor_classes - -Returns hash ref of classes for accessors. - -This is an attempt at a more efficient method than calling "related_class()" -a bunch of times when you need it for many relations. +Returns the hash ref of relationship meta info for a given column. =cut -sub accessor_classes { - my ($self, $class) = @_; # can pass a class arg to get accssor classes for - $class ||= $self; - my $meta = $class->meta_info; - my %res; - foreach my $rel (keys %$meta) { - my $rel_meta = $meta->{$rel}; - %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} } - keys %$rel_meta ); - } - return \%res; - - # 2 liner to get class of accessor for $name - #my $meta = $class->meta_info; - #my ($isa) = map $_->foreign_class, grep defined, - # map $meta->{$_}->{$name}, keys %$meta; - +sub related_meta { + my ($self,$r, $accssr) = @_; + $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; + my $class_meta = $self->meta_info; + if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } + keys %$class_meta) + { return $class_meta->{$rel_type}->{$accssr} }; } + =head2 stringify_column + Returns the name of the column to use when stringifying + and object. + =cut sub stringify_column { @@ -466,6 +357,13 @@ sub stringify_column { =head2 do_pager + Sets the pager template argument ($r->{template_args}{pager}) + to a Class::DBI::Pager object based on the rows_per_page + value set in the configuration of the application. + + This pager is used via the pager macro in TT Templates, and + is also accessible via Mason. + =cut sub do_pager { @@ -480,6 +378,16 @@ sub do_pager { =head2 order + Returns the SQL order syntax based on the order parameter passed + to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'. + + $sql .= $self->order($r); + + If the order column is not a column of this table, + or an order argument is not passed, then the return value is undefined. + + Note: the returned value does not start with a space. + =cut sub order { @@ -492,8 +400,27 @@ sub order { return $order; } +=head2 setup + + This method is inherited from Maypole::Model::Base and calls setup_database, + which uses Class::DBI::Loader to create and load Class::DBI classes from + the given database schema. + +=cut + =head2 setup_database +The $opts argument is a hashref of options. The "options" key is a hashref of +Database connection options . Other keys may be various Loader arguments or +flags. It has this form: + { + # DB connection options + options { AutoCommit => 1 , ... }, + # Loader args + relationships => 1, + ... + } + =cut sub setup_database { @@ -515,15 +442,29 @@ sub setup_database { ); $config->{classes} = [ $config->{loader}->classes ]; $config->{tables} = [ $config->{loader}->tables ]; - warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } ) + + my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} }; + warn( 'Loaded tables to classes: ' . join ', ', @table_class ) if $namespace->debug; } +=head2 class_of + + returns class for given table + +=cut + sub class_of { my ( $self, $r, $table ) = @_; return $r->config->loader->_table2class($table); # why not find_class ? } +=head2 fetch_objects + +Returns 1 or more objects of the given class when provided with the request + +=cut + sub fetch_objects { my ($class, $r)=@_; my @pcs = $class->primary_columns; @@ -536,14 +477,302 @@ sub fetch_objects { } -############################################################################### -# private / internal functions and classes + + +=head2 _isa_class + +Private method to return the class a column +belongs to that was inherited by an is_a relationship. +This should probably be public but need to think of API + +=cut + +sub _isa_class { + my ($class, $col) = @_; + $class->_croak( "Need a column for _isa_class." ) unless $col; + my $isaclass; + my $isa = $class->meta_info("is_a") || {}; + foreach ( keys %$isa ) { + $isaclass = $isa->{$_}->foreign_class; + return $isaclass if ($isaclass->find_column($col)); + } + return; # col not in a is_a class +} + + +# Thanks to dave baird -- form builder for these private functions +# sub _column_info { sub _column_info { - my $class = shift; - $class = ref $class || $class; - no strict 'refs'; - return ${$class . '::COLUMN_INFO'}; + my $self = shift; + my $dbh = $self->db_Main; + + my $meta; # The info we are after + my ($catalog, $schema) = (undef, undef); + # Dave is suspicious this (above undefs) could + # break things if driver useses this info + + my $original_metadata; + # '%' is a search pattern for columns - matches all columns + if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) { + $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr; + $self->COLUMN_INFO ($self->_hash_type_meta( $sth )); + } else { + $self->COLUMN_INFO ($self->_hash_typeless_meta( )); + } + + return $self->COLUMN_INFO; +} + +sub _hash_type_meta { + my ($self, $sth) = @_; + my $meta; + while ( my $row = $sth->fetchrow_hashref ) { + my $colname = $row->{COLUMN_NAME} || $row->{column_name}; + + # required / nullable + $meta->{$colname}{nullable} = $row->{NULLABLE}; + $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0; + + # default + if (defined $row->{COLUMN_DEF}) { + my $default = $row->{COLUMN_DEF}; + $default =~ s/['"]?(.*?)['"]?::.*$/$1/; + $meta->{$colname}{default} = $default; + }else { + $meta->{$colname}{default} = ''; + } + + # type + my $type = $row->{mysql_type_name} || $row->{type}; + unless ($type) { + $type = $row->{TYPE_NAME}; + if ($row->{COLUMN_SIZE}) { + $type .= "($row->{COLUMN_SIZE})"; + } + } + $type =~ s/['"]?(.*)['"]?::.*$/$1/; + # Bool if tinyint + if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) { + $type = 'BOOL'; + } + $meta->{$colname}{type} = $type; + + # order + $meta->{$colname}{position} = $row->{ORDINAL_POSITION} + } + return $meta; +} + +# typeless db e.g. sqlite +sub _hash_typeless_meta { + my ( $self ) = @_; + + $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' ) + unless $self->can( 'sql_fb_meta_dummy' ); + + my $sth = $self->sql_fb_meta_dummy; + + $sth->execute or die "Error executing column info: " . $sth->errstr;; + + # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes + my $cols = $sth->{NAME}; + my $types = $sth->{TYPE}; + # my $sizes = $sth->{PRECISION}; # empty + # my $nulls = $sth->{NULLABLE}; # empty + + # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to + $sth->finish; + + my $order = 0; + my $meta; + foreach my $col ( @$cols ) { + my $col_meta; + $col_meta->{nullable} = 1; + $col_meta->{required} = 0; + $col_meta->{default} = ''; + $col_meta->{position} = $order++; + # type_name is taken literally from the schema, but is not actually used by sqlite, + # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc. + my $type = shift( @$types ); + $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ; + $meta->{$col} = $col_meta; + } + return $meta; } +=head2 column_type + + my $type = $class->column_type('column_name'); + +This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.) +For now, it returns "BOOL" for tinyints. + +TODO :: TEST with enums + +=cut + +sub column_type { + my $class = shift; + my $colname = shift or die "Need a column for column_type"; + $class->_column_info() unless (ref $class->COLUMN_INFO); + + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_type($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{type}; +} + +=head2 required_columns + + Accessor to get/set required columns for forms, validation, etc. + + Returns list of required columns. Accepts an array ref of column names. + + $class->required_columns([qw/foo bar baz/]); + + Allows you to specify the required columns for a class, over-riding any + assumptions and guesses made by Maypole. + + Use this instead of $config->{$table}{required_cols} + + Note : you need to setup the model class before calling this method. + +=cut + +sub required_columns { + my ($class, $columns) = @_; + $class->_column_info() unless ref $class->COLUMN_INFO; + my $column_info = $class->COLUMN_INFO; + + if ($columns) { + foreach my $colname ( @$columns ) { + if ($class->_isa_class($colname)) { + $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1 + unless ($class->_isa_class($colname)->column_required); + next; + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + next; + } + $column_info->{$colname}{required} = 1; + } + $class->COLUMN_INFO($column_info); + } + + return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ; +} + +=head2 column_required + + Returns true if a column is required + + my $required = $class->column_required($column_name); + + Columns can be required by the application but not the database, but not the other way around, + hence there is also a column_nullable method which will tell you if the column is nullable + within the database itself. + +=cut + +sub column_required { + my ($class, $colname) = @_; + $colname or $class->_croak( "Need a column for column_nullable" ); + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_required($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{required} || 0; +} + +=head2 column_nullable + + Returns true if a column can be NULL within the underlying database and false if not. + + my $nullable = $class->column_nullable($column_name); + + Any columns that are not nullable will automatically be specified as required, you can + also specify nullable columns as required within your application. + + It is recomended you use column_required rather than column_nullable within your + application, this method is more useful if extending the model or handling your own + validation. + +=cut + +sub column_nullable { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_nullable" ); + + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_nullable($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{nullable} || 0; +} + +=head2 column_default + +Returns default value for column or the empty string. +Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times +have '' returned. + +=cut + +sub column_default { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_default"); + $class->_column_info() unless (ref $class->COLUMN_INFO); + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_default($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + + return $class->COLUMN_INFO->{$colname}{default}; +} + +=head2 get_classmetadata + +Gets class meta data *excluding cgi input* for the passed in class or the +calling class. *NOTE* excludes cgi inputs. This method is handy to call from +templates when you need some metadata for a related class. + +=cut + +sub get_classmetadata { + my ($self, $class) = @_; # class is class we want data for + $class ||= $self; + $class = ref $class || $class; + + my %res; + $res{name} = $class; + $res{colnames} = {$class->column_names}; + $res{columns} = [$class->display_columns]; + $res{list_columns} = [$class->list_columns]; + $res{moniker} = $class->moniker; + $res{plural} = $class->plural_moniker; + $res{table} = $class->table; + $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ; + return \%res; +} + + 1;