From: Jesse Vincent Date: Sat, 28 Jul 2007 01:25:06 +0000 (+0000) Subject: * Initial commit of the Jifty::DBI codebase before we start renaming and breaking... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c7aa4db670ad43ca05f70ddc2bdddb3a05e47af2;p=dbsrgits%2FDBIx-Class-Historic.git * Initial commit of the Jifty::DBI codebase before we start renaming and breaking things --- diff --git a/lib/DBIx/Class/JDBICompat.pm b/lib/DBIx/Class/JDBICompat.pm new file mode 100644 index 0000000..3ca72ff --- /dev/null +++ b/lib/DBIx/Class/JDBICompat.pm @@ -0,0 +1,213 @@ +package Jifty::DBI; +use warnings; +use strict; + +$Jifty::DBI::VERSION = '0.42'; + +=head1 NAME + +Jifty::DBI - An object-relational persistence framework + +=head1 DESCRIPTION + +Jifty::DBI deals with databases, so that you don't have to. + +This module provides an object-oriented mechanism for retrieving and +updating data in a DBI-accessible database. + +This module is the direct descendent of L. If you're familiar +with SearchBuilder, Jifty::DBI should be quite familiar to you. + +=head2 What is it trying to do. + +Jifty::DBI::Record abstracts the agony of writing the common and generally +simple SQL statements needed to serialize and de-serialize an object to the +database. In a traditional system, you would define various methods on +your object 'create', 'read', 'update', and 'delete' being the most common. +In each method you would have a SQL statement like: + + select * from table where value='blah'; + +If you wanted to control what data a user could modify, you would have to +do some special magic to make accessors do the right thing. Etc. The +problem with this approach is that in a majority of the cases, the SQL is +incredibly simple and the code from one method/object to the next was +basically the same. + + + +Enter, Jifty::DBI::Record. + +With ::Record, you can in the simple case, remove all of that code and +replace it by defining two methods and inheriting some code. It's pretty +simple and incredibly powerful. For more complex cases, you can +do more complicated things by overriding certain methods. Let's stick with +the simple case for now. + + + +=head2 An Annotated Example + +The example code below makes the following assumptions: + +=over 4 + +=item * + +The database is 'postgres', + +=item * + +The host is 'reason', + +=item * + +The login name is 'mhat', + +=item * + +The database is called 'example', + +=item * + +The table is called 'simple', + +=item * + +The table looks like so: + + id integer not NULL, primary_key(id), + foo varchar(10), + bar varchar(10) + +=back + +First, let's define our record class in a new module named "Simple.pm". + + use warnings; + use strict; + + package Simple; + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + column foo => type is 'text'; + column bar => type is 'text'; + }; + + # your custom code goes here. + + 1; + +Like all perl modules, this needs to end with a true value. + +Now, on to the code that will actually *do* something with this object. +This code would be placed in your Perl script. + + use Jifty::DBI::Handle; + use Simple; + +Use two packages, the first is where I get the DB handle from, the latter +is the object I just created. + + + my $handle = Jifty::DBI::Handle->new(); + $handle->connect( + driver => 'Pg', + database => 'test', + host => 'reason', + user => 'mhat', + password => '' + ); + +Creates a new Jifty::DBI::Handle, and then connects to the database using +that handle. Pretty straight forward, the password '' is what I use +when there is no password. I could probably leave it blank, but I find +it to be more clear to define it. + + + my $s = Simple->new( handle => $handle ); + + $s->load_by_cols(id=>1); + + +=over + +=item load_by_cols + +Takes a hash of column => value pairs and returns the *first* to match. +First is probably lossy across databases vendors. + +=item load_from_hash + +Populates this record with data from a Jifty::DBI::Collection. I'm +currently assuming that Jifty::DBI is what we use in +cases where we expect > 1 record. More on this later. + +=back + +Now that we have a populated object, we should do something with it! ::Record +automagically generates accessors and mutators for us, so all we need to do +is call the methods. accessors are named C(), and Mutators are named +C($). On to the example, just appending this to the code from +the last example. + + + print "ID : ", $s->id(), "\n"; + print "Foo : ", $s->foo(), "\n"; + print "Bar : ", $s->bar(), "\n"; + +Thats all you have to to get the data, now to change the data! + + + $s->set_bar('NewBar'); + +Pretty simple! Thats really all there is to it. Set($) returns +a boolean and a string describing the problem. Lets look at an example of +what will happen if we try to set a 'Id' which we previously defined as +read only. + + my ($res, $str) = $s->set_id('2'); + if (! $res) { + ## Print the error! + print "$str\n"; + } + +The output will be: + + >> Immutable column + +Currently Set updates the data in the database as soon as you call +it. In the future I hope to extend ::Record to better support transactional +operations, such that updates will only happen when "you" say so. + +Finally, adding and removing records from the database. ::Record provides a +Create method which simply takes a hash of key => value pairs. The keys +exactly map to database columns. + + ## Get a new record object. + $s1 = Simple->new( handle => $handle ); + my ($id, $status_msg) = $s1->create(id => 4, + foo => 'Foooooo', + bar => 'Barrrrr'); + +Poof! A new row in the database has been created! Now lets delete the +object! + + my $s2 = Simple->new( handle => $handle ); + $s2->load_by_cols(id=>4); + $s2->delete(); + +And it's gone. + +For simple use, thats more or less all there is to it. In the future, I hope to exapand +this HowTo to discuss using container classes, overloading, and what +ever else I think of. + +=head1 LICENSE + +Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC. +Jifty::DBI is distributed under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/DBIx/Class/JDBICompat/Class/Trigger.pm b/lib/DBIx/Class/JDBICompat/Class/Trigger.pm new file mode 100644 index 0000000..c212aab --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Class/Trigger.pm @@ -0,0 +1,365 @@ +package Jifty::DBI::Class::Trigger; + +use strict; +use vars qw($VERSION); +$VERSION = "0.11_01"; + +use Carp (); + +my (%Triggers, %TriggerPoints); + +sub import { + my $class = shift; + my $pkg = caller(0); + + $TriggerPoints{$pkg} = { map { $_ => 1 } @_ } if @_; + + # export mixin methods + no strict 'refs'; + my @methods = qw(add_trigger call_trigger last_trigger_results); + *{"$pkg\::$_"} = \&{$_} for @methods; +} + +sub add_trigger { + my $proto = shift; + + my $triggers = __fetch_triggers($proto); + + if (ref($_[1]) eq 'CODE') { + + while (my($when, $code) = splice @_, 0, 2) { + __validate_triggerpoint($proto, $when); + Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE'; + push @{$triggers->{$when}}, [$code, undef]; + } + } + elsif (grep {'name'} @_) { + my %args = ( name => undef, callback => undef, abortable => undef, @_); + my $when= $args{'name'}; + my $code = $args{'callback'}; + my $abortable = $args{'abortable'}; + __validate_triggerpoint($proto, $when); + Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE'; + push @{$triggers->{$when}}, [$code, $abortable]; + + + } else { + Carp::croak('add_trigger() needs coderef'); + + } + 1; +} + + +sub last_trigger_results { + my $self = shift; + my $result_store = ref($self) ? $self : ${Jifty::DBI::Class::Trigger::_trigger_results}->{$self}; + return $result_store->{'_class_trigger_results'}; +} + +sub call_trigger { + my $self = shift; + my $when = shift; + + my @return; + + my $result_store = ref($self) ? $self : ${Jifty::DBI::Class::Trigger::_trigger_results}->{$self}; + + $result_store->{'_class_trigger_results'} = []; + + if (my @triggers = __fetch_all_triggers($self, $when)) { # any triggers? + for my $trig (@triggers) { + my @return = $trig->[0]->($self, @_); + push @{$result_store->{'_class_trigger_results'}}, \@return; + return undef if ($trig->[1] and not $return[0]); # only abort on false values. + + } + } + else { + # if validation is enabled we can only add valid trigger points + # so we only need to check in call_trigger() if there's no + # trigger with the requested name. + __validate_triggerpoint($self, $when); + } + + return scalar @{$result_store->{'_class_trigger_results'}}; +} + +sub __fetch_all_triggers { + my ($obj, $when, $list, $order) = @_; + my $class = ref $obj || $obj; + my $return; + unless ($list) { + # Absence of the $list parameter conditions the creation of + # the unrolled list of triggers. These keep track of the unique + # set of triggers being collected for each class and the order + # in which to return them (based on hierarchy; base class + # triggers are returned ahead of descendant class triggers). + $list = {}; + $order = []; + $return = 1; + } + no strict 'refs'; + my @classes = @{$class . '::ISA'}; + push @classes, $class; + foreach my $c (@classes) { + next if $list->{$c}; + if (UNIVERSAL::can($c, 'call_trigger')) { + $list->{$c} = []; + __fetch_all_triggers($c, $when, $list, $order) + unless $c eq $class; + if (defined $when && $Triggers{$c}{$when}) { + push @$order, $c; + $list->{$c} = $Triggers{$c}{$when}; + } + } + } + if ($return) { + my @triggers; + foreach my $class (@$order) { + push @triggers, @{ $list->{$class} }; + } + if (ref $obj && defined $when) { + my $obj_triggers = $obj->{__triggers}{$when}; + push @triggers, @$obj_triggers if $obj_triggers; + } + return @triggers; + } +} + +sub __validate_triggerpoint { + return unless my $points = $TriggerPoints{ref $_[0] || $_[0]}; + my ($self, $when) = @_; + Carp::croak("$when is not valid triggerpoint for ".(ref($self) ? ref($self) : $self)) + unless $points->{$when}; +} + +sub __fetch_triggers { + my ($obj, $proto) = @_; + # check object based triggers first + return ref $obj ? $obj->{__triggers} ||= {} : $Triggers{$obj} ||= {}; +} + +1; +__END__ + +=head1 NAME + +Jifty::DBI::Class::Trigger - Mixin to add / call inheritable triggers + +=head1 WARNING + +This Module is a TEMPORARY FORK of Class::Trigger. It will be replaced +upon the release of new features in Class::Trigger that we depend on. + +ALL BUGS IN THIS MODULE ARE THE FAULT OF Jifty's DEVELOPERS AND NOT +Class::Trigger's DEVELOPERS. UNDER NO CIRCUMSTANCES SHOULD BUGS +BE REPORTED TO CLASS::TRIGGER'S DEVELOPERS. + +=head1 SYNOPSIS + + package Foo; + use Jifty::DBI::Class::Trigger; + + sub foo { + my $self = shift; + $self->call_trigger('before_foo'); + # some code ... + $self->call_trigger('middle_of_foo'); + # some code ... + $self->call_trigger('after_foo'); + } + + package main; + Foo->add_trigger(before_foo => \&sub1); + Foo->add_trigger(after_foo => \&sub2); + + my $foo = Foo->new; + $foo->foo; # then sub1, sub2 called + + # triggers are inheritable + package Bar; + use base qw(Foo); + + Bar->add_trigger(before_foo => \&sub); + + # triggers can be object based + $foo->add_trigger(after_foo => \&sub3); + $foo->foo; # sub3 would appply only to this object + +=head1 DESCRIPTION + +Jifty::DBI::Class::Trigger is a mixin class to add / call triggers (or hooks) +that get called at some points you specify. + +=head1 METHODS + +By using this module, your class is capable of following methods. + +=over 4 + +=item add_trigger + + Foo->add_trigger($triggerpoint => $sub); + $foo->add_trigger($triggerpoint => $sub); + + + Foo->add_trigger( name => $triggerpoint, + callback => sub {return undef}, + abortable => 1); + + # no further triggers will be called. Undef will be returned. + + +Adds triggers for trigger point. You can have any number of triggers +for each point. Each coderef will be passed a reference to the calling object, +as well as arguments passed in via L. Return values will be +captured in I. + +If add_trigger is called with named parameters and the C +parameter is passed a true value, a false return value from trigger +code will stop processing of this trigger point and return a C +value to the calling code. + +If C is called without the C flag, return +values will be captured by call_trigger, but failures will be ignored. + +If C is called as object method, whole current trigger +table will be copied onto the object and the new trigger added to +that. (The object must be implemented as hash.) + + my $foo = Foo->new; + + # this trigger ($sub_foo) would apply only to $foo object + $foo->add_trigger($triggerpoint => $sub_foo); + $foo->foo; + + # And not to another $bar object + my $bar = Foo->new; + $bar->foo; + +=item call_trigger + + $foo->call_trigger($triggerpoint, @args); + +Calls triggers for trigger point, which were added via C +method. Each triggers will be passed a copy of the object as the first argument. +Remaining arguments passed to C will be passed on to each trigger. +Triggers are invoked in the same order they were defined. + +If there are no C triggers or no C trigger point returns +a false value, C will return the number of triggers processed. + + +If an C trigger returns a false value, call trigger will stop execution +of the trigger point and return undef. + +=item last_trigger_results + + my @results = @{ $foo->last_trigger_results }; + +Returns a reference to an array of the return values of all triggers called +for the last trigger point. Results are ordered in the same order the triggers +were run. + + +=back + +=head1 TRIGGER POINTS + +By default you can make any number of trigger points, but if you want +to declare names of trigger points explicitly, you can do it via +C. + + package Foo; + use Jifty::DBI::Class::Trigger qw(foo bar baz); + + package main; + Foo->add_trigger(foo => \&sub1); # okay + Foo->add_trigger(hoge => \&sub2); # exception + +=head1 FAQ + +B Thanks to everyone at POOP mailing-list +(http://poop.sourceforge.net/). + +=over 4 + +=item Q. + +This module lets me add subs to be run before/after a specific +subroutine is run. Yes? + +=item A. + +You put various call_trigger() method in your class. Then your class +users can call add_trigger() method to add subs to be run in points +just you specify (exactly where you put call_trigger()). + +=item Q. + +Are you aware of the perl-aspects project and the Aspect module? Very +similar to Jifty::DBI::Class::Trigger by the look of it, but its not nearly as +explicit. Its not necessary for foo() to actually say "triggers go +*here*", you just add them. + +=item A. + +Yep ;) + +But the difference with Aspect would be that Jifty::DBI::Class::Trigger is so +simple that it's easy to learn, and doesn't require 5.6 or over. + +=item Q. + +How does this compare to Sub::Versive, or Hook::LexWrap? + +=item A. + +Very similar. But the difference with Jifty::DBI::Class::Trigger would be the +explicitness of trigger points. + +In addition, you can put hooks in any point, rather than pre or post +of a method. + +=item Q. + +It looks interesting, but I just can't think of a practical example of +its use... + +=item A. + +(by Tony Bowden) + +I originally added code like this to Class::DBI to cope with one +particular case: auto-upkeep of full-text search indices. + +So I added functionality in Class::DBI to be able to trigger an +arbitary subroutine every time something happened - then it was a +simple matter of setting up triggers on INSERT and UPDATE to reindex +that row, and on DELETE to remove that index row. + +See L and its source code to see it +in action. + +=back + +=head1 AUTHOR + +IMPORTANT: DO NOT REPORT BUGS TO THE AUTHORS MENTIONED BELOW. PLEASE +REPORT THEM TO JIFTY-DEVEL@LISTS.BESTPRACTICAL.COM. PLEASE SEE THE WARNING +ABOVE + +Original idea by Tony Bowden Etony@kasei.comE in Class::DBI. + +Code by Tatsuhiko Miyagawa Emiyagawa@bulknews.netE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut + diff --git a/lib/DBIx/Class/JDBICompat/Collection.pm b/lib/DBIx/Class/JDBICompat/Collection.pm new file mode 100755 index 0000000..5ba5d87 --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Collection.pm @@ -0,0 +1,1851 @@ +package Jifty::DBI::Collection; + +use warnings; +use strict; + +=head1 NAME + +Jifty::DBI::Collection - Encapsulate SQL queries and rows in simple +perl objects + +=head1 SYNOPSIS + + use Jifty::DBI::Collection; + + package My::ThingCollection; + use base qw/Jifty::DBI::Collection/; + + package My::Thing; + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + column column_1 => type is 'text'; + }; + + package main; + + use Jifty::DBI::Handle; + my $handle = Jifty::DBI::Handle->new(); + $handle->connect( driver => 'SQLite', database => "my_test_db" ); + + my $sb = My::ThingCollection->new( handle => $handle ); + + $sb->limit( column => "column_1", value => "matchstring" ); + + while ( my $record = $sb->next ) { + print $record->id; + } + +=head1 DESCRIPTION + +This module provides an object-oriented mechanism for retrieving and +updating data in a DBI-accessible database. + +In order to use this module, you should create a subclass of +L and a subclass of L for +each table that you wish to access. (See the documentation of +L for more information on subclassing it.) + +Your L subclass must override L, +and probably should override at least L also; at the very +least, L should probably call L and L to +set the database handle (a L object) and table +name for the class -- see the L for an example. + + +=cut + +use vars qw($VERSION); + +use Data::Page; +use Clone; +use Carp qw/croak/; +use base qw/Class::Accessor::Fast/; +__PACKAGE__->mk_accessors(qw/pager preload_columns preload_related/); + +=head1 METHODS + +=head2 new + +Creates a new L object and immediately calls +L with the same parameters that were passed to L. If +you haven't overridden L<_init> in your subclass, this means that you +should pass in a L (or one of its subclasses) like +this: + + my $sb = My::Jifty::DBI::Subclass->new( handle => $handle ); + +However, if your subclass overrides L you do not need to take +a handle argument, as long as your subclass takes care of calling the +L method somehow. This is useful if you want all of your +L objects to use a shared global handle and don't want to +have to explicitly pass it in each time, for example. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless( $self, $class ); + $self->record_class( $proto->record_class ) if ref $proto; + $self->_init(@_); + return ($self); +} + +=head2 _init + +This method is called by L with whatever arguments were passed to +L. By default, it takes a C object as a +C argument and calls L with that. + +=cut + +sub _init { + my $self = shift; + my %args = ( + handle => undef, + @_ + ); + $self->_handle( $args{'handle'} ) if ( $args{'handle'} ); + $self->table( $self->new_item->table() ); + $self->clean_slate(%args); +} + +sub _init_pager { + my $self = shift; + $self->pager( Data::Page->new ); + + $self->pager->total_entries(0); + $self->pager->entries_per_page(10); + $self->pager->current_page(1); +} + +=head2 clean_slate + +This completely erases all the data in the object. It's useful if a +subclass is doing funky stuff to keep track of a search and wants to +reset the object's data without losing its own data; it's probably +cleaner to accomplish that in a different way, though. + +=cut + +sub clean_slate { + my $self = shift; + my %args = (@_); + $self->redo_search(); + $self->_init_pager(); + $self->{'itemscount'} = 0; + $self->{'tables'} = ""; + $self->{'auxillary_tables'} = ""; + $self->{'where_clause'} = ""; + $self->{'limit_clause'} = ""; + $self->{'order'} = ""; + $self->{'alias_count'} = 0; + $self->{'first_row'} = 0; + $self->{'show_rows'} = 0; + @{ $self->{'aliases'} } = (); + + delete $self->{$_} for qw( + items + leftjoins + raw_rows + count_all + subclauses + restrictions + _open_parens + criteria_count + ); + + $self->implicit_clauses(%args); + $self->_is_limited(0); +} + +=head2 implicit_clauses + +Called by L to set up any implicit clauses that the +collection B has. Defaults to doing nothing. Is passed the +paramhash passed into L. + +=cut + +sub implicit_clauses { } + +=head2 _handle [DBH] + +Get or set this object's L object. + +=cut + +sub _handle { + my $self = shift; + if (@_) { + $self->{'DBIxhandle'} = shift; + } + return ( $self->{'DBIxhandle'} ); +} + +=head2 _do_search + +This internal private method actually executes the search on the +database; it is called automatically the first time that you actually +need results (such as a call to L). + +=cut + +sub _do_search { + my $self = shift; + + my $query_string = $self->build_select_query(); + + # If we're about to redo the search, we need an empty set of items + delete $self->{'items'}; + + my $records = $self->_handle->simple_query($query_string); + return 0 unless $records; + my @names = @{ $records->{NAME_lc} }; + my $data = {}; + my $column_map = {}; + foreach my $column (@names) { + if ($column =~ /^((\w+)_?(?:\d*))_(.*?)$/) { + $column_map->{$1}->{$2} =$column; + } + } + my @tables = keys %$column_map; + + + my @order; + while ( my $base_row = $records->fetchrow_hashref() ) { + my $main_pkey = $base_row->{$names[0]}; + push @order, $main_pkey unless ( $order[0] && $order[-1] eq $main_pkey); + + # let's chop the row into subrows; + foreach my $table (@tables) { + for ( keys %$base_row ) { + if ( $_ =~ /$table\_(.*)$/ ) { + $data->{$main_pkey}->{$table} ->{ ($base_row->{ $table . '_id' } ||$main_pkey )}->{$1} = $base_row->{$_}; + } + } + } + + } + + # For related "record" values, we can simply prepopulate the + # Jifty::DBI::Record cache and life will be good. (I suspect we want + # to do this _before_ doing the initial primary record load on the + # off chance that the primary record will try to do the relevant + # prefetch manually For related "collection" values, our job is a bit + # harder. we need to create a new empty collection object, set it's + # "must search" to 0 and manually add the records to it for each of + # the items we find. Then we need to ram it into place. + + foreach my $row_id ( @order) { + my $item; + foreach my $row ( values %{ $data->{$row_id}->{'main'} } ) { + $item = $self->new_item(); + $item->load_from_hash($row); + } + foreach my $alias ( grep { $_ ne 'main' } keys %{ $data->{$row_id} } ) { + + my $related_rows = $data->{$row_id}->{$alias}; + my ( $class, $col_name ) = $self->class_and_column_for_alias($alias); + if ($class) { + + if ( $class->isa('Jifty::DBI::Collection') ) { + my $collection = $class->new( handle => $self->_handle ); + foreach my $row( sort { $a->{id} <=> $b->{id} } values %$related_rows ) { + my $entry + = $collection->new_item( handle => $self->_handle ); + $entry->load_from_hash($row); + $collection->add_record($entry); + } + + $item->_prefetched_collection( $col_name => $collection ); + } elsif ( $class->isa('Jifty::DBI::Record') ) { + foreach my $related_row ( values %$related_rows ) { + my $item = $class->new( handle => $self->_handle ); + $item->load_from_hash($related_row); + } + } else { + Carp::cluck( + "Asked to preload $alias as a $class. Don't know how to handle $class" + ); + } + } + + + } + $self->add_record($item); + + } + if ( $records->err ) { + $self->{'must_redo_search'} = 0; + } + + return $self->_record_count; +} + +=head2 add_record RECORD + +Adds a record object to this collection. + +This method automatically sets our "must redo search" flag to 0 and our "we have limits" flag to 1. + +Without those two flags, counting the number of items wouldn't work. + +=cut + +sub add_record { + my $self = shift; + my $record = shift; + $self->_is_limited(1); + $self->{'must_redo_search'} = 0; + push @{ $self->{'items'} }, $record; +} + +=head2 _record_count + +This private internal method returns the number of +L objects saved as a result of the last query. + +=cut + +sub _record_count { + my $self = shift; + return 0 unless defined $self->{'items'}; + return scalar @{ $self->{'items'} }; +} + +=head2 _do_count + +This internal private method actually executes a counting operation on +the database; it is used by L and L. + +=cut + +sub _do_count { + my $self = shift; + my $all = shift || 0; + + my $query_string = $self->build_select_count_query(); + my $records = $self->_handle->simple_query($query_string); + return 0 unless $records; + + my @row = $records->fetchrow_array(); + return 0 if $records->err; + + $self->{ $all ? 'count_all' : 'raw_rows' } = $row[0]; + + return ( $row[0] ); +} + +=head2 _apply_limits STATEMENTREF + +This routine takes a reference to a scalar containing an SQL +statement. It massages the statement to limit the returned rows to +only C<< $self->rows_per_page >> rows, skipping C<< $self->first_row >> +rows. (That is, if rows are numbered starting from 0, row number +C<< $self->first_row >> will be the first row returned.) Note that it +probably makes no sense to set these variables unless you are also +enforcing an ordering on the rows (with L, say). + +=cut + +sub _apply_limits { + my $self = shift; + my $statementref = shift; + $self->_handle->apply_limits( $statementref, $self->rows_per_page, + $self->first_row ); + +} + +=head2 _distinct_query STATEMENTREF + +This routine takes a reference to a scalar containing an SQL +statement. It massages the statement to ensure a distinct result set +is returned. + +=cut + +sub _distinct_query { + my $self = shift; + my $statementref = shift; + $self->_handle->distinct_query( $statementref, $self ); +} + +=head2 _build_joins + +Build up all of the joins we need to perform this query. + +=cut + +sub _build_joins { + my $self = shift; + + return ( $self->_handle->_build_joins($self) ); + +} + +=head2 _is_joined + +Returns true if this collection will be joining multiple tables +together. + +=cut + +sub _is_joined { + my $self = shift; + if ( $self->{'leftjoins'} && keys %{ $self->{'leftjoins'} } ) { + return (1); + } else { + return ( @{ $self->{'aliases'} } ); + } + +} + +# LIMIT clauses are used for restricting ourselves to subsets of the +# search. +sub _limit_clause { + my $self = shift; + my $limit_clause; + + if ( $self->rows_per_page ) { + $limit_clause = " LIMIT "; + if ( $self->first_row != 0 ) { + $limit_clause .= $self->first_row . ", "; + } + $limit_clause .= $self->rows_per_page; + } else { + $limit_clause = ""; + } + return $limit_clause; +} + +=head2 _is_limited + +If we've limited down this search, return true. Otherwise, return +false. + +=cut + +sub _is_limited { + my $self = shift; + if (@_) { + $self->{'is_limited'} = shift; + } else { + return ( $self->{'is_limited'} ); + } +} + +=head2 build_select_query + +Builds a query string for a "SELECT rows from Tables" statement for +this collection + +=cut + +sub build_select_query { + my $self = shift; + + # The initial SELECT or SELECT DISTINCT is decided later + + my $query_string = $self->_build_joins . " "; + + if ( $self->_is_limited ) { + $query_string .= $self->_where_clause . " "; + } + if ( $self->distinct_required ) { + + # DISTINCT query only required for multi-table selects + $self->_distinct_query( \$query_string ); + } else { + $query_string + = "SELECT " . $self->_preload_columns . " FROM $query_string"; + $query_string .= $self->_group_clause; + $query_string .= $self->_order_clause; + } + + $self->_apply_limits( \$query_string ); + + return ($query_string) + +} + +=head2 preload_columns + +The columns that the query would load for result items. By default it's everything. + +XXX TODO: in the case of distinct, it needs to work as well. + +=cut + +sub _preload_columns { + my $self = shift; + + my @cols = (); + my $item = $self->new_item; + if( $self->{columns} and @{ $self->{columns} } ) { + push @cols, @{$self->{columns}}; + # push @cols, map { warn "Preloading $_"; "main.$_ as main_" . $_ } @{$preload_columns}; + } else { + push @cols, $self->_qualified_record_columns( 'main' => $item ); + } + my %preload_related = %{ $self->preload_related || {} }; + foreach my $alias ( keys %preload_related ) { + my $related_obj = $preload_related{$alias}; + if ( my $col_obj = $item->column($related_obj) ) { + my $reference_type = $col_obj->refers_to; + + my $reference_item; + + if ( !$reference_type ) { + Carp::cluck( + "Asked to prefetch $col_obj->name for $self. But $col_obj->name isn't a known reference" + ); + } elsif ( $reference_type->isa('Jifty::DBI::Collection') ) { + $reference_item = $reference_type->new->new_item(); + } elsif ( $reference_type->isa('Jifty::DBI::Record') ) { + $reference_item = $reference_type->new; + } else { + Carp::cluck( + "Asked to prefetch $col_obj->name for $self. But $col_obj->name isn't a known type" + ); + } + + push @cols, + $self->_qualified_record_columns( $alias => $reference_item ); + } + + # push @cols, map { $_ . ".*" } keys %{ $self->preload_related || {} }; + + } + return CORE::join( ', ', @cols ); +} + +=head2 class_and_column_for_alias + +Takes the alias you've assigned to a prefetched related object. Returns the class +of the column we've declared that alias preloads. + +=cut + +sub class_and_column_for_alias { + my $self = shift; + my $alias = shift; + my %preload_related = %{ $self->preload_related || {} }; + my $related_colname = $preload_related{$alias}; + if ( my $col_obj = $self->new_item->column($related_colname) ) { + return ( $col_obj->refers_to => $related_colname ); + } + return undef; +} + +sub _qualified_record_columns { + my $self = shift; + my $alias = shift; + my $item = shift; + grep {$_} map { + my $col = $_; + if ( $col->virtual ) { + undef; + } else { + $col = $col->name; + $alias . "." . $col . " as " . $alias . "_" . $col; + } + } $item->columns; +} + +=head2 prefetch ALIAS_NAME ATTRIBUTE + +prefetches all related rows from alias ALIAS_NAME into the record attribute ATTRIBUTE of the +sort of item this collection is. + +If you have employees who have many phone numbers, this method will let you search for all your employees + and prepopulate their phone numbers. + +Right now, in order to make this work, you need to do an explicit join between your primary table and the subsidiary tables AND then specify the name of the attribute you want to prefetch related data into. +This method could be a LOT smarter. since we already know what the relationships between our tables are, that could all be precomputed. + +XXX TODO: in the future, this API should be extended to let you specify columns. + +=cut + +sub prefetch { + my $self = shift; + my $alias = shift; + my $into_attribute = shift; + + my $preload_related = $self->preload_related() || {}; + + $preload_related->{$alias} = $into_attribute; + + $self->preload_related($preload_related); + +} + +=head2 distinct_required + +Returns true if Jifty::DBI expects that this result set will end up +with repeated rows and should be "condensed" down to a single row for +each unique primary key. + +Out of the box, this method returns true if you've joined to another table. +To add additional logic, feel free to override this method in your subclass. + +XXX TODO: it should be possible to create a better heuristic than the simple +"is it joined?" question we're asking now. Something along the lines of "are we +joining this table to something that is not the other table's primary key" + +=cut + +sub distinct_required { + my $self = shift; + return( $self->_is_joined ? 1 : 0 ); +} + +=head2 build_select_count_query + +Builds a SELECT statement to find the number of rows this collection + would find. + +=cut + +sub build_select_count_query { + my $self = shift; + + my $query_string = $self->_build_joins . " "; + + if ( $self->_is_limited ) { + $query_string .= $self->_where_clause . " "; + } + + # DISTINCT query only required for multi-table selects + if ( $self->_is_joined ) { + $query_string = $self->_handle->distinct_count( \$query_string ); + } else { + $query_string = "SELECT count(main.id) FROM " . $query_string; + } + + return ($query_string); +} + +=head2 do_search + +C usually does searches "lazily". That is, it +does a C on the fly the first time you ask +for results that would need one or the other. Sometimes, you need to +display a count of results found before you iterate over a collection, +but you know you're about to do that too. To save a bit of wear and tear +on your database, call C before that C. + +=cut + +sub do_search { + my $self = shift; + $self->_do_search() if $self->{'must_redo_search'}; + +} + +=head2 next + +Returns the next row from the set as an object of the type defined by +sub new_item. When the complete set has been iterated through, +returns undef and resets the search such that the following call to +L will start over with the first item retrieved from the +database. + +=cut + +sub next { + my $self = shift; + + my $item = $self->peek; + + if ( $self->{'itemscount'} < $self->_record_count ) + { + $self->{'itemscount'}++; + } else { #we've gone through the whole list. reset the count. + $self->goto_first_item(); + } + + return ($item); +} + +=head2 peek + +Exactly the same as next, only it doesn't move the iterator. + +=cut + +sub peek { + my $self = shift; + + return (undef) unless ( $self->_is_limited ); + + $self->_do_search() if $self->{'must_redo_search'}; + + if ( $self->{'itemscount'} < $self->_record_count ) + { #return the next item + my $item = ( $self->{'items'}[ $self->{'itemscount'} ] ); + return ($item); + } else { #no more items! + return (undef); + } +} + +=head2 goto_first_item + +Starts the recordset counter over from the first item. The next time +you call L, you'll get the first item returned by the database, +as if you'd just started iterating through the result set. + +=cut + +sub goto_first_item { + my $self = shift; + $self->goto_item(0); +} + +=head2 goto_item + +Takes an integer, n. Sets the record counter to n. the next time you +call L, you'll get the nth item. + +=cut + +sub goto_item { + my $self = shift; + my $item = shift; + $self->{'itemscount'} = $item; +} + +=head2 first + +Returns the first item + +=cut + +sub first { + my $self = shift; + $self->goto_first_item(); + return ( $self->next ); +} + +=head2 last + +Returns the last item + +=cut + +sub last { + my $self = shift; + $self->goto_item( ( $self->count ) - 1 ); + return ( $self->next ); +} + +=head2 items_array_ref + +Return a reference to an array containing all objects found by this +search. + +=cut + +sub items_array_ref { + my $self = shift; + + # If we're not limited, return an empty array + return [] unless $self->_is_limited; + + # Do a search if we need to. + $self->_do_search() if $self->{'must_redo_search'}; + + # If we've got any items in the array, return them. Otherwise, + # return an empty array + return ( $self->{'items'} || [] ); +} + +=head2 new_item + +Should return a new object of the correct type for the current collection. +Must be overridden by a subclassed. + +=cut + +sub new_item { + my $self = shift; + my $class = $self->record_class(); + + die "Jifty::DBI::Collection needs to be subclassed; override new_item\n" + unless $class; + + $class->require(); + return $class->new( handle => $self->_handle ); +} + +=head2 record_class + +Returns the record class which this is a collection of; override this +to subclass. Or, pass it the name of a class an an argument after +creating a C object to create an 'anonymous' +collection class. + +If you haven't specified a record class, this returns a best guess at +the name of the record class for this collection. + +It uses a simple heuristic to determine the record class name -- It +chops "Collection" off its own name. If you want to name your records +and collections differently, go right ahead, but don't say we didn't +warn you. + +=cut + +sub record_class { + my $self = shift; + if (@_) { + $self->{record_class} = shift if (@_); + $self->{record_class} = ref $self->{record_class} + if ref $self->{record_class}; + } elsif ( not $self->{record_class} ) { + my $class = ref($self); + $class =~ s/Collection$// + or die "Can't guess record class from $class"; + $self->{record_class} = $class; + } + return $self->{record_class}; +} + +=head2 redo_search + +Takes no arguments. Tells Jifty::DBI::Collection that the next time +it's asked for a record, it should requery the database + +=cut + +sub redo_search { + my $self = shift; + $self->{'must_redo_search'} = 1; + delete $self->{$_} for qw(items raw_rows count_all); + $self->{'itemscount'} = 0; +} + +=head2 unlimit + +Clears all restrictions and causes this object to return all +rows in the primary table. + +=cut + +sub unlimit { + my $self = shift; + + $self->clean_slate(); + $self->_is_limited(-1); +} + +=head2 limit + +Takes a hash of parameters with the following keys: + +=over 4 + +=item table + +Can be set to something different than this table if a join is +wanted (that means we can't do recursive joins as for now). + +=item alias + +Unless alias is set, the join criterias will be taken from EXT_LINKcolumn +and INT_LINKcolumn and added to the criterias. If alias is set, new +criterias about the foreign table will be added. + +=item column + +Column to be checked against. + +=item value + +Should always be set and will always be quoted. If the value is a +subclass of Jifty::DBI::Object, the value will be interpreted to be +the object's id. + +=item operator + +operator is the SQL operator to use for this phrase. Possible choices include: + +=over 4 + +=item "=" + +=item "!=" + +Any other standard SQL comparision operators that your underlying +database supports are also valid. + +=item "LIKE" + +=item "NOT LIKE" + +=item "MATCHES" + +MATCHES is like LIKE, except it surrounds the value with % signs. + +=item "STARTSWITH" + +STARTSWITH is like LIKE, except it only appends a % at the end of the string + +=item "ENDSWITH" + +ENDSWITH is like LIKE, except it prepends a % to the beginning of the string + +=back + +=item entry_aggregator + +Can be AND or OR (or anything else valid to aggregate two clauses in SQL) + +=item case_sensitive + +on some databases, such as postgres, setting case_sensitive to 1 will make +this search case sensitive. Note that this flag is ignored if the column +is numeric. + +=back + +=cut + +sub limit { + my $self = shift; + my %args = ( + table => $self->table, + column => undef, + value => undef, + alias => undef, + quote_value => 1, + entry_aggregator => 'or', + case_sensitive => undef, + operator => '=', + subclause => undef, + leftjoin => undef, + @_ # get the real argumentlist + ); + + # We need to be passed a column and a value, at very least + croak "Must provide a column to limit" + unless defined $args{column}; + croak "Must provide a value to limit to" + unless defined $args{value}; + + # make passing in an object DTRT + if ( ref( $args{value} ) && $args{value}->isa('Jifty::DBI::Record') ) { + $args{value} = $args{value}->id; + } + + #since we're changing the search criteria, we need to redo the search + $self->redo_search(); + + if ( $args{'column'} ) { + + #If it's a like, we supply the %s around the search term + if ( $args{'operator'} =~ /MATCHES/i ) { + $args{'value'} = "%" . $args{'value'} . "%"; + } elsif ( $args{'operator'} =~ /STARTSWITH/i ) { + $args{'value'} = $args{'value'} . "%"; + } elsif ( $args{'operator'} =~ /ENDSWITH/i ) { + $args{'value'} = "%" . $args{'value'}; + } + $args{'operator'} =~ s/(?:MATCHES|ENDSWITH|STARTSWITH)/LIKE/i; + + #if we're explicitly told not to to quote the value or + # we're doing an IS or IS NOT (null), don't quote the operator. + + if ( $args{'quote_value'} && $args{'operator'} !~ /IS/i ) { + my $tmp = $self->_handle->dbh->quote( $args{'value'} ); + + # Accomodate DBI drivers that don't understand UTF8 + if ( $] >= 5.007 ) { + require Encode; + if ( Encode::is_utf8( $args{'value'} ) ) { + Encode::_utf8_on($tmp); + } + } + $args{'value'} = $tmp; + } + } + + #TODO: $args{'value'} should take an array of values and generate + # the proper where clause. + + #If we're performing a left join, we really want the alias to be the + #left join criterion. + + if ( ( defined $args{'leftjoin'} ) + && ( not defined $args{'alias'} ) ) + { + $args{'alias'} = $args{'leftjoin'}; + } + + # {{{ if there's no alias set, we need to set it + + unless ( $args{'alias'} ) { + + #if the table we're looking at is the same as the main table + if ( $args{'table'} eq $self->table ) { + + # TODO this code assumes no self joins on that table. + # if someone can name a case where we'd want to do that, + # I'll change it. + + $args{'alias'} = 'main'; + } + + else { + $args{'alias'} = $self->new_alias( $args{'table'} ); + } + } + + # }}} + + # Set this to the name of the column and the alias, unless we've been + # handed a subclause name + + my $qualified_column = $args{'alias'} . "." . $args{'column'}; + my $clause_id = $args{'subclause'} || $qualified_column; + + # If we're trying to get a leftjoin restriction, lets set + # $restriction to point htere. otherwise, lets construct normally + + my $restriction; + if ( $args{'leftjoin'} ) { + $restriction = $self->{'leftjoins'}{ $args{'leftjoin'} }{'criteria'} + { $clause_id } ||= []; + } else { + $restriction = $self->{'restrictions'}{ $clause_id } ||= []; + } + + # If it's a new value or we're overwriting this sort of restriction, + + if ( $self->_handle->case_sensitive + && defined $args{'value'} + && $args{'quote_value'} + && !$args{'case_sensitive'} ) + { + + # don't worry about case for numeric columns_in_db + my $column_obj = $self->new_item()->column( $args{column} ); + if ( defined $column_obj ? $column_obj->is_string : 1 ) { + ( $qualified_column, $args{'operator'}, $args{'value'} ) + = $self->_handle->_make_clause_case_insensitive( + $qualified_column, $args{'operator'}, $args{'value'} ); + } + } + + my $clause = { + column => $qualified_column, + operator => $args{'operator'}, + value => $args{'value'}, + }; + + # Juju because this should come _AFTER_ the EA + my @prefix; + if ( $self->{'_open_parens'}{ $clause_id } ) { + @prefix = ('(') x delete $self->{'_open_parens'}{ $clause_id }; + } + + if ( lc( $args{'entry_aggregator'} || "" ) eq 'none' || !@$restriction ) { + @$restriction = (@prefix, $clause); + } else { + push @$restriction, $args{'entry_aggregator'}, @prefix , $clause; + } + + # We're now limited. people can do searches. + + $self->_is_limited(1); + + if ( defined( $args{'alias'} ) ) { + return ( $args{'alias'} ); + } else { + return (1); + } +} + +=head2 open_paren CLAUSE + +Places an open paren at the current location in the given C. +Note that this can be used for Deep Magic, and has a high likelyhood +of allowing you to construct malformed SQL queries. Its interface +will probably change in the near future, but its presence allows for +arbitrarily complex queries. + +=cut + +sub open_paren { + my ( $self, $clause ) = @_; + $self->{_open_parens}{$clause}++; +} + +=head2 close_paren CLAUSE + +Places a close paren at the current location in the given C. +Note that this can be used for Deep Magic, and has a high likelyhood +of allowing you to construct malformed SQL queries. Its interface +will probably change in the near future, but its presence allows for +arbitrarily complex queries. + +=cut + +# Immediate Action +sub close_paren { + my ( $self, $clause ) = @_; + my $restriction = $self->{'restrictions'}{ $clause } ||= []; + push @$restriction, ')'; +} + +sub _add_subclause { + my $self = shift; + my $clauseid = shift; + my $subclause = shift; + + $self->{'subclauses'}{"$clauseid"} = $subclause; + +} + +sub _where_clause { + my $self = shift; + my $where_clause = ''; + + # Go through all the generic restrictions and build up the + # "generic_restrictions" subclause. That's the only one that the + # collection builds itself. Arguably, the abstraction should be + # better, but I don't really see where to put it. + $self->_compile_generic_restrictions(); + + #Go through all restriction types. Build the where clause from the + #Various subclauses. + + my @subclauses = grep defined && length, values %{ $self->{'subclauses'} }; + + $where_clause = " WHERE " . CORE::join( ' AND ', @subclauses ) + if (@subclauses); + + return ($where_clause); + +} + +#Compile the restrictions to a WHERE Clause + +sub _compile_generic_restrictions { + my $self = shift; + + delete $self->{'subclauses'}{'generic_restrictions'}; + + # Go through all the restrictions of this type. Buld up the generic subclause + my $result = ''; + foreach my $restriction ( grep $_ && @$_, values %{ $self->{'restrictions'} } ) { + $result .= ' AND ' if $result; + $result .= '('; + foreach my $entry ( @$restriction ) { + unless ( ref $entry ) { + $result .= ' '. $entry . ' '; + } + else { + $result .= join ' ', @{$entry}{qw(column operator value)}; + } + } + $result .= ')'; + } + return ($self->{'subclauses'}{'generic_restrictions'} = $result); +} + +# set $self->{$type .'_clause'} to new value +# redo_search only if new value is really new +sub _set_clause { + my $self = shift; + my ( $type, $value ) = @_; + $type .= '_clause'; + if ( ( $self->{$type} || '' ) ne ( $value || '' ) ) { + $self->redo_search; + } + $self->{$type} = $value; +} + +=head2 order_by_cols DEPRECATED + +*DEPRECATED*. Use C method. + +=cut + +sub order_by_cols { + require Carp; + Carp::cluck("order_by_cols is deprecated, use order_by method"); + goto &order_by; +} + +=head2 order_by EMPTY|HASH|ARRAY_OF_HASHES + +Orders the returned results by column(s) and/or function(s) on column(s). + +Takes a paramhash of C, C and C +or C and C. +C defaults to main. +C defaults to ASC(ending), DES(cending) is also a valid value. +C and C have no default values. + +Use C instead of C and C to order by +the function value. Note that if you want use a column as argument of +the function then you have to build correct reference with alias +in the C format. + +Use array of hashes to order by many columns/functions. + +The results would be unordered if method called without arguments. + +Returns the current list of columns. + +=cut + +sub order_by { + my $self = shift; + if (@_) { + my @args = @_; + + unless ( UNIVERSAL::isa( $args[0], 'HASH' ) ) { + @args = {@args}; + } + $self->{'order_by'} = \@args; + $self->redo_search(); + } + return ( $self->{'order_by'} || []); +} + +=head2 _order_clause + +returns the ORDER BY clause for the search. + +=cut + +sub _order_clause { + my $self = shift; + + return '' unless $self->{'order_by'}; + + my $clause = ''; + foreach my $row ( @{ $self->{'order_by'} } ) { + + my %rowhash = ( + alias => 'main', + column => undef, + order => 'ASC', + %$row + ); + if ( $rowhash{'order'} =~ /^des/i ) { + $rowhash{'order'} = "DESC"; + } else { + $rowhash{'order'} = "ASC"; + } + + if ( $rowhash{'function'} ) { + $clause .= ( $clause ? ", " : " " ); + $clause .= $rowhash{'function'} . ' '; + $clause .= $rowhash{'order'}; + + } elsif ( (defined $rowhash{'alias'} ) + and ( $rowhash{'column'} ) ) + { + + $clause .= ( $clause ? ", " : " " ); + $clause .= $rowhash{'alias'} . "." if $rowhash{'alias'}; + $clause .= $rowhash{'column'} . " "; + $clause .= $rowhash{'order'}; + } + } + $clause = " ORDER BY$clause " if $clause; + return $clause; +} + +=head2 group_by_cols DEPRECATED + +*DEPRECATED*. Use group_by method. + +=cut + +sub group_by_cols { + require Carp; + Carp::cluck("group_by_cols is deprecated, use group_by method"); + goto &group_by; +} + +=head2 group_by EMPTY|HASH|ARRAY_OF_HASHES + +Groups the search results by column(s) and/or function(s) on column(s). + +Takes a paramhash of C and C or C. +C defaults to main. +C and C have no default values. + +Use C instead of C and C to group by +the function value. Note that if you want use a column as argument +of the function then you have to build correct reference with alias +in the C format. + +Use array of hashes to group by many columns/functions. + +The method is EXPERIMENTAL and subject to change. + +=cut + +sub group_by { + my $self = shift; + + my @args = @_; + + unless ( UNIVERSAL::isa( $args[0], 'HASH' ) ) { + @args = {@args}; + } + $self->{'group_by'} = \@args; + $self->redo_search(); +} + +=head2 _group_clause + +Private function to return the "GROUP BY" clause for this query. + +=cut + +sub _group_clause { + my $self = shift; + return '' unless $self->{'group_by'}; + + my $row; + my $clause; + + foreach $row ( @{ $self->{'group_by'} } ) { + my %rowhash = ( + alias => 'main', + + column => undef, + %$row + ); + if ( $rowhash{'function'} ) { + $clause .= ( $clause ? ", " : " " ); + $clause .= $rowhash{'function'}; + + } elsif ( ( $rowhash{'alias'} ) + and ( $rowhash{'column'} ) ) + { + + $clause .= ( $clause ? ", " : " " ); + $clause .= $rowhash{'alias'} . "."; + $clause .= $rowhash{'column'}; + } + } + if ($clause) { + return " GROUP BY" . $clause . " "; + } else { + return ''; + } +} + +=head2 new_alias table_OR_CLASS + +Takes the name of a table or a Jifty::DBI::Record subclass. +Returns the string of a new Alias for that table, which can be used +to Join tables or to limit what gets found by +a search. + +=cut + +sub new_alias { + my $self = shift; + my $refers_to = shift || die "Missing parameter"; + my $table; + + if ( $refers_to->can('table') ) { + $table = $refers_to->table; + } else { + $table = $refers_to; + } + + my $alias = $self->_get_alias($table); + + my $subclause = "$table $alias"; + + push( @{ $self->{'aliases'} }, $subclause ); + + return $alias; +} + +# _get_alias is a private function which takes an tablename and +# returns a new alias for that table without adding something +# to self->{'aliases'}. This function is used by new_alias +# and the as-yet-unnamed left join code + +sub _get_alias { + my $self = shift; + my $table = shift; + + $self->{'alias_count'}++; + my $alias = $table . "_" . $self->{'alias_count'}; + + return ($alias); + +} + +=head2 join + +Join instructs Jifty::DBI::Collection to join two tables. + +The standard form takes a param hash with keys C, C, C +and C. C and C are column aliases obtained from +$self->new_alias or a $self->limit. C and C are the columns +in C and C that should be linked, respectively. For this +type of join, this method has no return value. + +Supplying the parameter C => 'left' causes Join to perform a left +join. in this case, it takes C, C, C and +C. Because of the way that left joins work, this method needs a +table for the second column rather than merely an alias. For this type +of join, it will return the alias generated by the join. + +The parameter C defaults C<=>, but you can specify other +operators to join with. + +Instead of C/C, it's possible to specify expression, to join +C/C on an arbitrary expression. + +=cut + +sub join { + my $self = shift; + my %args = ( + type => 'normal', + column1 => undef, + alias1 => 'main', + table2 => undef, + column2 => undef, + alias2 => undef, + @_ + ); + + $self->_handle->join( collection => $self, %args ); + +} + +=head2 set_page_info [per_page => NUMBER,] [current_page => NUMBER] + +Sets the current page (one-based) and number of items per page on the +pager object, and pulls the number of elements from the collection. +This both sets up the collection's L object so that you +can use its calculations, and sets the L +C and C so that queries return values from +the selected page. + +=cut + +sub set_page_info { + my $self = shift; + my %args = ( + per_page => undef, + current_page => undef, # 1-based + @_ + ); + + $self->pager->total_entries( $self->count_all ) + ->entries_per_page( $args{'per_page'} ) + ->current_page( $args{'current_page'} ); + + $self->rows_per_page( $args{'per_page'} ); + $self->first_row( $self->pager->first || 1 ); + +} + +=head2 rows_per_page + +limits the number of rows returned by the database. Optionally, takes +an integer which restricts the # of rows returned in a result Returns +the number of rows the database should display. + +=cut + +sub rows_per_page { + my $self = shift; + $self->{'show_rows'} = shift if (@_); + + return ( $self->{'show_rows'} ); +} + +=head2 first_row + +Get or set the first row of the result set the database should return. +Takes an optional single integer argrument. Returns the currently set +integer first row that the database should return. + + +=cut + +# returns the first row +sub first_row { + my $self = shift; + if (@_) { + $self->{'first_row'} = shift; + + #SQL starts counting at 0 + $self->{'first_row'}--; + + #gotta redo the search if changing pages + $self->redo_search(); + } + return ( $self->{'first_row'} ); +} + +=head2 _items_counter + +Returns the current position in the record set. + +=cut + +sub _items_counter { + my $self = shift; + return $self->{'itemscount'}; +} + +=head2 count + +Returns the number of records in the set. + +=cut + +sub count { + my $self = shift; + + # An unlimited search returns no tickets + return 0 unless ( $self->_is_limited ); + + # If we haven't actually got all objects loaded in memory, we + # really just want to do a quick count from the database. + if ( $self->{'must_redo_search'} ) { + + # If we haven't already asked the database for the row count, do that + $self->_do_count unless ( $self->{'raw_rows'} ); + + #Report back the raw # of rows in the database + return ( $self->{'raw_rows'} ); + } + + # If we have loaded everything from the DB we have an + # accurate count already. + else { + return $self->_record_count; + } +} + +=head2 count_all + +Returns the total number of potential records in the set, ignoring any +limit_clause. + +=cut + +# 22:24 [Robrt(500@outer.space)] It has to do with Caching. +# 22:25 [Robrt(500@outer.space)] The documentation says it ignores the limit. +# 22:25 [Robrt(500@outer.space)] But I don't believe thats true. +# 22:26 [msg(Robrt)] yeah. I +# 22:26 [msg(Robrt)] yeah. I'm not convinced it does anything useful right now +# 22:26 [msg(Robrt)] especially since until a week ago, it was setting one variable and returning another +# 22:27 [Robrt(500@outer.space)] I remember. +# 22:27 [Robrt(500@outer.space)] It had to do with which Cached value was returned. +# 22:27 [msg(Robrt)] (given that every time we try to explain it, we get it Wrong) +# 22:27 [Robrt(500@outer.space)] Because Count can return a different number than actual NumberOfResults +# 22:28 [msg(Robrt)] in what case? +# 22:28 [Robrt(500@outer.space)] count_all _always_ used the return value of _do_count(), as opposed to Count which would return the cached number of +# results returned. +# 22:28 [Robrt(500@outer.space)] IIRC, if you do a search with a limit, then raw_rows will == limit. +# 22:31 [msg(Robrt)] ah. +# 22:31 [msg(Robrt)] that actually makes sense +# 22:31 [Robrt(500@outer.space)] You should paste this conversation into the count_all docs. +# 22:31 [msg(Robrt)] perhaps I'll create a new method that _actually_ do that. +# 22:32 [msg(Robrt)] since I'm not convinced it's been doing that correctly + +sub count_all { + my $self = shift; + + # An unlimited search returns no tickets + return 0 unless ( $self->_is_limited ); + + # If we haven't actually got all objects loaded in memory, we + # really just want to do a quick count from the database. + if ( $self->{'must_redo_search'} || !$self->{'count_all'} ) { + + # If we haven't already asked the database for the row count, do that + $self->_do_count(1) unless ( $self->{'count_all'} ); + + #Report back the raw # of rows in the database + return ( $self->{'count_all'} ); + } + + # If we have loaded everything from the DB we have an + # accurate count already. + else { + return $self->_record_count; + } +} + +=head2 is_last + +Returns true if the current row is the last record in the set. + +=cut + +sub is_last { + my $self = shift; + + return undef unless $self->count; + + if ( $self->_items_counter == $self->count ) { + return (1); + } else { + return (0); + } +} + +=head2 DEBUG + +Gets/sets the DEBUG flag. + +=cut + +sub DEBUG { + my $self = shift; + if (@_) { + $self->{'DEBUG'} = shift; + } + return ( $self->{'DEBUG'} ); +} + +=head2 column + +Normally a collection object contains record objects populated with all columns +in the database, but you can restrict the records to only contain some +particular columns, by calling the C method once for each column you +are interested in. + +Takes a hash of parameters; the C, C and C keys means +the same as in the C method. A special C key may contain +one of several possible kinds of expressions: + +=over 4 + +=item C + +Same as C. + +=item Expression with C in it + +The C is substituted with the column name, then passed verbatim to the +underlying C. + +=item Any other expression + +The expression is taken to be a function name. For example, C means +the same thing as C. + +=back + +=cut + +sub column { + my $self = shift; + my %args = ( + table => undef, + alias => undef, + column => undef, + function => undef, + @_ + ); + + my $table = $args{table} || do { + if ( my $alias = $args{alias} ) { + $alias =~ s/_\d+$//; + $alias; + } else { + $self->table; + } + }; + + my $name = ( $args{alias} || 'main' ) . '.' . $args{column}; + if ( my $func = $args{function} ) { + if ( $func =~ /^DISTINCT\s*COUNT$/i ) { + $name = "COUNT(DISTINCT $name)"; + } + + # If we want to substitute + elsif ( $func =~ /\?/ ) { + $name =~ s/\?/$name/g; + } + + # If we want to call a simple function on the column + elsif ( $func !~ /\(/ ) { + $name = "\U$func\E($name)"; + } else { + $name = $func; + } + + } + + my $column = "col" . @{ $self->{columns} ||= [] }; + $column = $args{column} if $table eq $self->table and !$args{alias}; + $column = ($args{'alias'}||'main')."_".$column; + push @{ $self->{columns} }, "$name AS \L$column"; + return $column; +} + +=head2 columns LIST + +Specify that we want to load only the columns in LIST, which is a + +=cut + +sub columns { + my $self = shift; + $self->column( column => $_ ) for @_; +} + +=head2 columns_in_db table + +Return a list of columns in table, lowercased. + +TODO: Why are they lowercased? + +=cut + +sub columns_in_db { + my $self = shift; + my $table = shift; + + my $dbh = $self->_handle->dbh; + + # TODO: memoize this + + return map lc( $_->[0] ), @{ + eval { + $dbh->column_info( '', '', $table, '' )->fetchall_arrayref( [3] ); + } + || $dbh->selectall_arrayref("DESCRIBE $table;") + || $dbh->selectall_arrayref("DESCRIBE \u$table;") + || [] + }; +} + +=head2 has_column { table => undef, column => undef } + +Returns true if table has column column. +Return false otherwise + +=cut + +sub has_column { + my $self = shift; + my %args = ( + column => undef, + table => undef, + @_ + ); + + my $table = $args{table} or die; + my $column = $args{column} or die; + return grep { $_ eq $column } $self->columns_in_db($table); +} + +=head2 table [table] + +If called with an argument, sets this collection's table. + +Always returns this collection's table. + +=cut + +sub table { + my $self = shift; + $self->{table} = shift if (@_); + return $self->{table}; +} + +=head2 clone + +Returns copy of the current object with all search restrictions. + +=cut + +sub clone { + my $self = shift; + + my $obj = bless {}, ref($self); + %$obj = %$self; + + $obj->redo_search(); # clean out the object of data + + $obj->{$_} = Clone::clone( $obj->{$_} ) for + grep exists $self->{ $_ }, $self->_cloned_attributes; + return $obj; +} + +=head2 _cloned_attributes + +Returns list of the object's fields that should be copied. + +If your subclass store references in the object that should be copied while +clonning then you probably want override this method and add own values to +the list. + +=cut + +sub _cloned_attributes { + return qw( + aliases + leftjoins + subclauses + restrictions + ); +} + +1; +__END__ + + + +=head1 TESTING + +In order to test most of the features of C, +you need to provide C with a test database. For each DBI +driver that you would like to test, set the environment variables +C, C, and C to a +database name, database username, and database password, where "FOO" +is the driver name in all uppercase. You can test as many drivers as +you like. (The appropriate C module needs to be installed in +order for the test to work.) Note that the C driver will +automatically be tested if C is installed, using a +temporary file as the database. For example: + + JDBI_TEST_MYSQL=test JDBI_TEST_MYSQL_USER=root JDBI_TEST_MYSQL_PASS=foo \ + JDBI_TEST_PG=test JDBI_TEST_PG_USER=postgres make test + + +=head1 AUTHOR + +Copyright (c) 2001-2005 Jesse Vincent, jesse@fsck.com. + +All rights reserved. + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + + +=head1 SEE ALSO + +Jifty::DBI::Handle, Jifty::DBI::Record. + +=cut + diff --git a/lib/DBIx/Class/JDBICompat/Collection/Union.pm b/lib/DBIx/Class/JDBICompat/Collection/Union.pm new file mode 100644 index 0000000..7c49f04 --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Collection/Union.pm @@ -0,0 +1,252 @@ +package Jifty::DBI::Collection::Union; +use strict; +use warnings; + +# WARNING --- This is still development code. It is experimental. + +our $VERSION = '0'; + +# This could inherit from Jifty::DBI, but there are _a lot_ +# of things in Jifty::DBI that we don't want, like Limit and +# stuff. It probably makes sense to (eventually) split out +# Jifty::DBI::Collection to contain all the iterator logic. +# This could inherit from that. + +=head1 NAME + +Jifty::DBI::Collection::Union - Deal with multiple L +result sets as one + +=head1 SYNOPSIS + + use Jifty::DBI::Collection::Union; + my $U = new Jifty::DBI::Collection::Union; + $U->add( $tickets1 ); + $U->add( $tickets2 ); + + $U->GotoFirstItem; + while (my $z = $U->Next) { + printf "%5d %30.30s\n", $z->Id, $z->Subject; + } + +=head1 WARNING + +This module is still experimental. + +=head1 DESCRIPTION + +Implements a subset of the L methods, but +enough to do iteration over a bunch of results. Useful for displaying +the results of two unrelated searches (for the same kind of objects) +in a single list. + +=head1 METHODS + +=head2 new + +Create a new L object. No arguments. + +=cut + +sub new { + bless { + data => [], + curp => 0, # current offset in data + item => 0, # number of indiv items from First + count => undef, + }, + shift; +} + +=head2 add COLLECTION + +Add L object I to the Union +object. + +It must be the same type as the first object added. + +=cut + +sub add { + my $self = shift; + my $newobj = shift; + + unless ( @{ $self->{data} } == 0 + || ref($newobj) eq ref( $self->{data}[0] ) ) + { + die + "All elements of a Jifty::DBI::Collection::Union must be of the same type. Looking for a " + . ref( $self->{data}[0] ) . "."; + } + + $self->{count} = undef; + push @{ $self->{data} }, $newobj; +} + +=head2 first + +Return the very first element of the Union (which is the first element +of the first Collection). Also reset the current pointer to that +element. + +=cut + +sub first { + my $self = shift; + + die "No elements in Jifty::DBI::Collection::Union" + unless @{ $self->{data} }; + + $self->{curp} = 0; + $self->{item} = 0; + $self->{data}[0]->First; +} + +=head2 next + +Return the next element in the Union. + +=cut + +sub next { + my $self = shift; + + return undef unless defined $self->{data}[ $self->{curp} ]; + + my $cur = $self->{data}[ $self->{curp} ]; + + # do the search to avoid the count query and then search + $cur->_do_search if $cur->{'must_redo_search'}; + + if ( $cur->_items_counter == $cur->count ) { + + # move to the next element + $self->{curp}++; + return undef unless defined $self->{data}[ $self->{curp} ]; + $cur = $self->{data}[ $self->{curp} ]; + $self->{data}[ $self->{curp} ]->goto_first_item; + } + $self->{item}++; + $cur->next; +} + +=head2 last + +Returns the last item + +=cut + +sub last { + die "Last doesn't work right now"; + my $self = shift; + $self->goto_item( ( $self->count ) - 1 ); + return ( $self->next ); +} + +=head2 count + +Returns the total number of elements in the Union'ed Collection + +=cut + +sub count { + my $self = shift; + my $sum = 0; + + # cache the results + return $self->{count} if defined $self->{count}; + + $sum += $_->count for ( @{ $self->{data} } ); + + $self->{count} = $sum; + + return $sum; +} + +=head2 goto_first_item + +Starts the recordset counter over from the first item. the next time +you call L, you'll get the first item returned by the database, +as if you'd just started iterating through the result set. + +=cut + +sub goto_first_item { + my $self = shift; + $self->goto_item(0); +} + +=head2 goto_item + +Unlike L, Union only supports going to the +first item in the collection. + +=cut + +sub goto_item { + my $self = shift; + my $item = shift; + + die "We currently only support going to the First item" + unless $item == 0; + + $self->{curp} = 0; + $self->{item} = 0; + $self->{data}[0]->goto_item(0); + + return $item; +} + +=head2 is_last + +Returns true if the current row is the last record in the set. + +=cut + +sub is_last { + my $self = shift; + + $self->{item} == $self->count ? 1 : undef; +} + +=head2 items_array_ref + +Return a reference to an array containing all objects found by this search. + +Will destroy any positional state. + +=cut + +sub items_array_ref { + my $self = shift; + + return [] unless $self->count; + + $self->goto_first_item(); + my @ret; + while ( my $r = $self->next ) { + push @ret, $r; + } + + return \@ret; +} + +=head1 AUTHOR + +Copyright (c) 2004 Robert Spier + +All rights reserved. + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L + +=cut + +1; + +__END__ + diff --git a/lib/DBIx/Class/JDBICompat/Collection/Unique.pm b/lib/DBIx/Class/JDBICompat/Collection/Unique.pm new file mode 100644 index 0000000..eee8e33 --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Collection/Unique.pm @@ -0,0 +1,70 @@ +package Jifty::DBI::Collection::Unique; +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT = qw(AddRecord); +our $VERSION = "0.01"; + +=head2 add_record + +Overrides add_record to ensure uniqueness. + +=cut + +sub add_record { + my $self = shift; + my $record = shift; + + # We're a mixin, so we can't override _CleanSlate, but if an object + # gets reused, we need to clean ourselves out. If there are no items, + # we're clearly doing a new search + $self->{"dbix_sb_unique_cache"} = {} unless ( @{ $self->{'items'} }[0] ); + return if $self->{"dbix_sb_unique_cache"}->{ $record->id }++; + push @{ $self->{'items'} }, $record; +} + +1; + +=head1 NAME + +Jifty::DBI::Collection::Unique - Ensure uniqueness of records in a collection + +=head1 SYNOPSIS + + package Foo::Collection; + use base 'Jifty::DBI::Collection'; + + use Jifty::DBI::Collection::Unique; # mixin + + my $collection = Foo::Collection->New(); + $collection->SetupComplicatedJoins; + $collection->OrderByMagic; + + while (my $thing = $collection->Next) { + # $thing is going to be distinct + } + +=head1 DESCRIPTION + +Currently, Jifty::DBI makes exceptions for databases which +cannot handle both C
, C, C, C, and +C. The first two should be obvious; C is where you +set the new value you want the column to have. The C column should +be the lvalue of Jifty::DBI::Record::PrimaryKeys(). Finally , +C is set when the Value is a SQL function. For example, you +might have C<< value => 'PASSWORD(string)' >>, by setting C to true, +that string will be inserted into the query directly rather then as a binding. + +=cut + +sub update_record_value { + my $self = shift; + my %args = ( + table => undef, + column => undef, + is_sql_function => undef, + primary_keys => undef, + @_ + ); + + return 1 unless grep {defined} values %{$args{primary_keys}}; + + my @bind = (); + my $query = 'UPDATE ' . $args{'table'} . ' '; + $query .= 'SET ' . $args{'column'} . '='; + + ## Look and see if the column is being updated via a SQL function. + if ( $args{'is_sql_function'} ) { + $query .= $args{'value'} . ' '; + } else { + $query .= '? '; + push( @bind, $args{'value'} ); + } + + ## Constructs the where clause. + my $where = 'WHERE '; + foreach my $key ( keys %{ $args{'primary_keys'} } ) { + $where .= $key . "=?" . " AND "; + push( @bind, $args{'primary_keys'}{$key} ); + } + $where =~ s/AND\s$//; + + my $query_str = $query . $where; + return ( $self->simple_query( $query_str, @bind ) ); +} + +=head2 update_table_value table COLUMN NEW_value RECORD_ID IS_SQL + +Update column COLUMN of table table where the record id = RECORD_ID. + +If IS_SQL is set, don't quote the NEW_VALUE. + +=cut + +sub update_table_value { + my $self = shift; + + ## This is just a wrapper to update_record_value(). + my %args = (); + $args{'table'} = shift; + $args{'column'} = shift; + $args{'value'} = shift; + $args{'primary_keys'} = shift; + $args{'is_sql_function'} = shift; + + return $self->update_record_value(%args); +} + +=head2 simple_query QUERY_STRING, [ BIND_VALUE, ... ] + +Execute the SQL string specified in QUERY_STRING + +=cut + +sub simple_query { + my $self = shift; + my $query_string = shift; + my @bind_values; + @bind_values = (@_) if (@_); + + my $sth = $self->dbh->prepare($query_string); + unless ($sth) { + if ($DEBUG) { + die "$self couldn't prepare the query '$query_string'" + . $self->dbh->errstr . "\n"; + } else { + warn "$self couldn't prepare the query '$query_string'" + . $self->dbh->errstr . "\n"; + my $ret = Class::ReturnValue->new(); + $ret->as_error( + errno => '-1', + message => "Couldn't prepare the query '$query_string'." + . $self->dbh->errstr, + do_backtrace => undef + ); + return ( $ret->return_value ); + } + } + + # Check @bind_values for HASH refs + for ( my $bind_idx = 0; $bind_idx < scalar @bind_values; $bind_idx++ ) { + if ( ref( $bind_values[$bind_idx] ) eq "HASH" ) { + my $bhash = $bind_values[$bind_idx]; + $bind_values[$bind_idx] = $bhash->{'value'}; + delete $bhash->{'value'}; + $sth->bind_param( $bind_idx + 1, undef, $bhash ); + } + + # Some databases, such as Oracle fail to cope if it's a perl utf8 + # string. they desperately want bytes. + Encode::_utf8_off( $bind_values[$bind_idx] ); + } + + my $basetime; + if ( $self->log_sql_statements ) { + $basetime = Time::HiRes::time(); + } + my $executed; + + local $@; + { + no warnings 'uninitialized'; # undef in bind_values makes DBI sad + eval { $executed = $sth->execute(@bind_values) }; + } + if ( $self->log_sql_statements ) { + $self->_log_sql_statement( $query_string, + Time::HiRes::time() - $basetime, @bind_values ); + + } + + if ( $@ or !$executed ) { + if ($DEBUG) { + die "$self couldn't execute the query '$query_string'" + . $self->dbh->errstr . "\n"; + + } else { + # XXX: This warn doesn't show up because we mask logging in Jifty::Test::END. + # and it usually fails because the test server is still running. + warn "$self couldn't execute the query '$query_string'"; + + my $ret = Class::ReturnValue->new(); + $ret->as_error( + errno => '-1', + message => "Couldn't execute the query '$query_string'" + . $self->dbh->errstr, + do_backtrace => undef + ); + return ( $ret->return_value ); + } + + } + return ($sth); + +} + +=head2 fetch_result QUERY, [ BIND_VALUE, ... ] + +Takes a SELECT query as a string, along with an array of BIND_VALUEs +If the select succeeds, returns the first row as an array. +Otherwise, returns a Class::ResturnValue object with the failure loaded +up. + +=cut + +sub fetch_result { + my $self = shift; + my $query = shift; + my @bind_values = @_; + my $sth = $self->simple_query( $query, @bind_values ); + if ($sth) { + return ( $sth->fetchrow ); + } else { + return ($sth); + } +} + +=head2 blob_params COLUMN_NAME COLUMN_TYPE + +Returns a hash ref for the bind_param call to identify BLOB types used +by the current database for a particular column type. + +=cut + +sub blob_params { + my $self = shift; + + # Don't assign to key 'value' as it is defined later. + return ( {} ); +} + +=head2 database_version + +Returns the database's version. + +If argument C is true returns short variant, in other +case returns whatever database handle/driver returns. By default +returns short version, e.g. '4.1.23' or '8.0-rc4'. + +Returns empty string on error or if database couldn't return version. + +The base implementation uses a C and C, whose values are array references to +the respective lists. + +=cut + +sub filters { + my $self = shift; + return { + output => $self->output_filters(@_), + input => $self->input_filters(@_) + }; +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/lib/DBIx/Class/JDBICompat/Record.pm b/lib/DBIx/Class/JDBICompat/Record.pm new file mode 100755 index 0000000..7586691 --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Record.pm @@ -0,0 +1,1529 @@ +package Jifty::DBI::Record; + +use strict; +use warnings; + +use Class::ReturnValue (); +use Lingua::EN::Inflect (); +use Jifty::DBI::Column (); +use UNIVERSAL::require (); +use Scalar::Util qw(blessed); +use Jifty::DBI::Class::Trigger; # exports by default + + +use base qw/ + Class::Data::Inheritable + Jifty::DBI::HasFilters + /; + +our $VERSION = '0.01'; + +Jifty::DBI::Record->mk_classdata(qw/COLUMNS/); +Jifty::DBI::Record->mk_classdata(qw/TABLE_NAME/ ); +Jifty::DBI::Record->mk_classdata(qw/_READABLE_COLS_CACHE/); +Jifty::DBI::Record->mk_classdata(qw/_WRITABLE_COLS_CACHE/); +Jifty::DBI::Record->mk_classdata(qw/_COLUMNS_CACHE/ ); + +=head1 NAME + +Jifty::DBI::Record - Superclass for records loaded by Jifty::DBI::Collection + +=head1 SYNOPSIS + + package MyRecord; + use base qw/Jifty::DBI::Record/; + +=head1 DESCRIPTION + +Jifty::DBI::Record encapsulates records and tables as part of the L +object-relational mapper. + +=head1 METHODS + +=head2 new ARGS + +Instantiate a new, empty record object. + +ARGS is a hash used to pass parameters to the C<_init()> function. + +Unless it is overloaded, the _init() function expects one key of +'handle' with a value containing a reference to a Jifty::DBI::Handle +object. + +=cut + +sub new { + my $proto = shift; + + my $class = ref($proto) || $proto; + my $self = {}; + bless( $self, $class ); + + $self->_init_columns() unless $self->COLUMNS; + $self->input_filters('Jifty::DBI::Filter::Truncate'); + + if ( scalar(@_) == 1 ) { + Carp::cluck("new(\$handle) is deprecated, use new( handle => \$handle )"); + $self->_init( handle => shift ); + } else { + $self->_init(@_); + } + + return $self; +} + +# Not yet documented here. Should almost certainly be overloaded. +sub _init { + my $self = shift; + my %args = (@_); + if ( $args{'handle'} ) { + $self->_handle( $args{'handle'} ); + } + +} + +sub import { + my $class = shift; + my ($flag) = @_; + if ($class->isa(__PACKAGE__) and defined $flag and $flag eq '-base') { + my $descendant = (caller)[0]; + no strict 'refs'; + push @{$descendant . '::ISA'}, $class; + shift; + + # run the schema callback + my $callback = shift; + $callback->() if $callback; + } + $class->SUPER::import(@_); + + # Turn off redefinition warnings in the caller's scope + @_ = (warnings => 'redefine'); + goto &warnings::unimport; +} + +=head2 id + +Returns this row's primary key. + +=cut + +sub id { + my $pkey = $_[0]->_primary_key(); + my $ret = $_[0]->{'values'}->{$pkey}; + return $ret; +} + +=head2 primary_keys + +Return a hash of the values of our primary keys for this function. + +=cut + +sub primary_keys { + my $self = shift; + my %hash + = map { $_ => $self->{'values'}->{$_} } @{ $self->_primary_keys }; + return (%hash); +} + + +=head2 _accessible COLUMN ATTRIBUTE + +Private method. + +DEPRECATED + +Returns undef unless C has a true value for C. + +Otherwise returns C's value for that attribute. + + +=cut + +sub _accessible { + my $self = shift; + my $column_name = shift; + my $attribute = lc( shift || '' ); + my $col = $self->column($column_name); + return undef unless ( $col and $col->can($attribute) ); + return $col->$attribute(); + +} + +=head2 _primary_keys + +Return our primary keys. (Subclasses should override this, but our +default is that we have one primary key, named 'id'.) + +=cut + +sub _primary_keys { + my $self = shift; + return ['id']; +} + +sub _primary_key { + my $self = shift; + my $pkeys = $self->_primary_keys(); + die "No primary key" unless ( ref($pkeys) eq 'ARRAY' and $pkeys->[0] ); + die "Too many primary keys" unless ( scalar(@$pkeys) == 1 ); + return $pkeys->[0]; +} + +=head2 _init_columns + +Sets up the primary key columns. + +=cut + +sub _init_columns { + my $self = shift; + + return if defined $self->COLUMNS; + + $self->COLUMNS( {} ); + + foreach my $column_name ( @{ $self->_primary_keys } ) { + my $column = $self->add_column($column_name); + $column->writable(0); + $column->readable(1); + $column->type('serial'); + $column->mandatory(1); + + $self->_init_methods_for_column($column); + } + +} + +=head2 _init_methods_for_columns + +This is an internal method responsible for calling L for each column that has been configured. + +=cut + +sub _init_methods_for_columns { + my $self = shift; + + for my $column (sort keys %{ $self->COLUMNS || {} }) { + $self->_init_methods_for_column($self->COLUMNS->{ $column }); + } +} + +=head2 schema_version + +If present, this method must return a string in '1.2.3' format to be used to determine which columns are currently active in the schema. That is, this value is used to determine which columns are defined, based upon comparison to values set in C and C. + +If no implementation is present, the "latest" schema version is assumed, meaning that any column defining a C is not active and all others are. + +=head2 _init_methods_for_column COLUMN + +This method is used internally to update the symbol table for the record class to include an accessor and mutator for each column based upon the column's name. + +In addition, if your record class defines the method L, it will automatically generate methods according to whether the column currently exists for the current application schema version returned by that method. The C method must return a value in the same form used by C and C. + +If the column doesn't currently exist, it will create the methods, but they will die with an error message stating that the column does not exist for the current version of the application. If it does exist, a normal accessor and mutator will be created. + +See also L, L, L for more information. + +=cut + +sub _init_methods_for_column { + my $self = $_[0]; + my $column = $_[1]; + my $column_name + = ( $column->aliased_as ? $column->aliased_as : $column->name ); + my $package = ref($self) || $self; + + # Make sure column has a record_class set as not all columns are added + # through add_column + $column->record_class( $package ) if not $column->record_class; + + # Check for the correct column type when the Storable filter is in use + if ( grep { $_ eq 'Jifty::DBI::Filter::Storable' } + ($column->input_filters, $column->output_filters) + and $column->type !~ /^(blob|bytea)$/i) + { + die "Column '$column_name' in @{[$column->record_class]} ". + "uses the Storable filter but is not of type 'blob'.\n"; + } + + no strict 'refs'; # We're going to be defining subs + + if ( not $self->can($column_name) ) { + # Accessor + my $subref; + if ( $column->active ) { + + + if ( $column->readable ) { + if ( UNIVERSAL::isa( $column->refers_to, "Jifty::DBI::Record" ) ) + { + $subref = sub { + if ( @_ > 1 ) { Carp::carp "Value passed to column accessor. You probably want to use the mutator." } + $_[0]->_to_record( $column_name, + $_[0]->__value($column_name) ); + }; + } elsif ( + UNIVERSAL::isa( + $column->refers_to, "Jifty::DBI::Collection" + ) + ) + { + $subref = sub { $_[0]->_collection_value($column_name) }; + } else { + $subref = sub { + if ( @_ > 1 ) { Carp::carp "Value passed to column accessor. You probably want to use the mutator." } + return ( $_[0]->_value($column_name) ); + }; + } + } else { + $subref = sub { return '' } + } + } + else { + # XXX sterling: should this be done with Class::ReturnValue instead + $subref = sub { + Carp::croak("column $column_name is not available for $package for schema version ".$self->schema_version); + }; + } + *{ $package . "::" . $column_name } = $subref; + + } + + if ( not $self->can( "set_" . $column_name ) ) { + # Mutator + my $subref; + if ( $column->active ) { + if ( $column->writable ) { + if ( UNIVERSAL::isa( $column->refers_to, "Jifty::DBI::Record" ) ) + { + $subref = sub { + my $self = shift; + my $val = shift; + + $val = $val->id + if UNIVERSAL::isa( $val, 'Jifty::DBI::Record' ); + return ( + $self->_set( column => $column_name, value => $val ) + ); + }; + } elsif ( + UNIVERSAL::isa( + $column->refers_to, "Jifty::DBI::Collection" + ) + ) + { # XXX elw: collections land here, now what? + my $ret = Class::ReturnValue->new(); + my $message = "Collection column '$column_name' not writable"; + $ret->as_array( 0, $message ); + $ret->as_error( + errno => 3, + do_backtrace => 0, + message => $message + ); + $subref = sub { return ( $ret->return_value ); }; + } else { + $subref = sub { + return ( + $_[0]->_set( column => $column_name, value => $_[1] ) + ); + }; + } + } else { + my $ret = Class::ReturnValue->new(); + my $message = 'Immutable column'; + $ret->as_array( 0, $message ); + $ret->as_error( + errno => 3, + do_backtrace => 0, + message => $message + ); + $subref = sub { return ( $ret->return_value ); }; + } + } + else { + # XXX sterling: should this be done with Class::ReturnValue instead + $subref = sub { + Carp::croak("column $column_name is not available for $package for schema version ".$self->schema_version); + }; + } + *{ $package . "::" . "set_" . $column_name } = $subref; + } +} + + +=head2 _to_record COLUMN VALUE + +This B method takes a column name and a value for that column. + +It returns C unless C is a valid column for this record +that refers to another record class. + +If it is valid, this method returns a new record object with an id +of C. + +=cut + +sub _to_record { + my $self = shift; + my $column_name = shift; + my $value = shift; + + my $column = $self->column($column_name); + my $classname = $column->refers_to(); + my $remote_column = $column->by() || 'id'; + + return unless defined $value; + return undef unless $classname; + return unless UNIVERSAL::isa( $classname, 'Jifty::DBI::Record' ); + + # XXX TODO FIXME we need to figure out the right way to call new here + # perhaps the handle should have an initiializer for records/collections + my $object = $classname->new( handle => $self->_handle ); + $object->load_by_cols( $remote_column => $value ); + return $object; +} + +sub _collection_value { + my $self = shift; + + my $method_name = shift; + return unless defined $method_name; + + my $column = $self->column($method_name); + my $classname = $column->refers_to(); + + return undef unless $classname; + return unless UNIVERSAL::isa( $classname, 'Jifty::DBI::Collection' ); + + if ( my $prefetched_col = $self->_prefetched_collection($method_name)) { + return $prefetched_col; + } + + my $coll = $classname->new( handle => $self->_handle ); + $coll->limit( column => $column->by(), value => $self->id ); + return $coll; +} + +sub _prefetched_collection { + my $self =shift; + my $column_name = shift; + if (@_) { + $self->{'_prefetched_collections'}->{$column_name} = shift; + } else { + return $self->{'_prefetched_collections'}->{$column_name}; + } + +} + + +=head2 add_column + +=cut + +sub add_column { + my $self = shift; + my $name = shift; + $name = lc $name; + + $self->COLUMNS->{$name} = Jifty::DBI::Column->new() + unless exists $self->COLUMNS->{$name}; + $self->_READABLE_COLS_CACHE(undef); + $self->_WRITABLE_COLS_CACHE(undef); + $self->_COLUMNS_CACHE(undef ); + $self->COLUMNS->{$name}->name($name); + + my $class = ref( $self ) || $self; + $self->COLUMNS->{$name}->record_class( $class ); + + return $self->COLUMNS->{$name}; +} + +=head2 column + + my $value = $self->column($column); + +Returns the $value of a $column. + +=cut + +sub column { + my $self = shift; + my $name = lc( shift || '' ); + my $col = $self->_columns_hashref; + return undef unless $col && exists $col->{$name}; + return $col->{$name}; + +} + +=head2 columns + + my @columns = $record->columns; + +Returns a sorted list of a $record's @columns. + +=cut + +sub columns { + my $self = shift; + return @{$self->_COLUMNS_CACHE() || $self->_COLUMNS_CACHE([ + sort { + ( ( ( $b->type || '' ) eq 'serial' ) + <=> ( ( $a->type || '' ) eq 'serial' ) ) + or ( ($a->sort_order || 0) <=> ($b->sort_order || 0)) + or ( $a->name cmp $b->name ) + } grep { $_->active } values %{ $self->_columns_hashref } + ])} +} + +=head2 all_columns + + my @all_columns = $record->all_columns; + +Returns all the columns for the table, even those that are inactive. + +=cut + +sub all_columns { + my $self = shift; + + # Not cached because it's not expected to be used often + return + sort { + ( ( ( $b->type || '' ) eq 'serial' ) + <=> ( ( $a->type || '' ) eq 'serial' ) ) + or ( ($a->sort_order || 0) <=> ($b->sort_order || 0)) + or ( $a->name cmp $b->name ) + } values %{ $self->_columns_hashref || {} } +} + +sub _columns_hashref { + my $self = shift; + + return ($self->COLUMNS||{}); +} + + +# sub {{{ readable_attributes + +=head2 readable_attributes + +Returns a list this table's readable columns + +=cut + +sub readable_attributes { + my $self = shift; + return @{$self->_READABLE_COLS_CACHE() || $self->_READABLE_COLS_CACHE([sort map { $_->name } grep { $_->readable } $self->columns])}; +} + +=head2 serialize_metadata + +Returns a hash which describes how this class is stored in the database. +Right now, the keys are C, C
, and C. C and C
+return simple scalars, but C returns a hash of C pairs +for all the columns in this model. See C for +the format of that hash. + + +=cut + +sub serialize_metadata { + my $self = shift; + return { + class => (ref($self) || $self), + table => $self->table, + columns => { $self->_serialize_columns }, + } +} + +sub _serialize_columns { + my $self = shift; + my %serialized_columns; + foreach my $column ( $self->columns ) { + $serialized_columns{ $column->name } = $column->serialize_metadata(); + } + + return %serialized_columns; +} + + + + +=head2 writable_attributes + +Returns a list of this table's writable columns + + +=cut + +sub writable_attributes { + my $self = shift; + return @{$self->_WRITABLE_COLS_CACHE() || $self->_WRITABLE_COLS_CACHE([sort map { $_->name } grep { $_->writable } $self->columns])}; +} + +=head2 record values + +As you've probably already noticed, C autocreates methods for your +standard get/set accessors. It also provides you with some hooks to massage the values +being loaded or stored. + +When you fetch a record value by calling C<$my_record-Esome_field>, C +provides the following hook + +=over + + + +=item after_I + +This hook is called with a reference to the value returned by +Jifty::DBI. Its return value is discarded. + +=back + +When you set a value, C provides the following hooks + +=over + +=item before_set_I PARAMHASH + +C passes this function a reference to a paramhash +composed of: + +=over + +=item column + +The name of the column we're updating. + +=item value + +The new value for I. + +=item is_sql_function + +A boolean that, if true, indicates that I is an SQL function, +not just a value. + +=back + +If before_set_I returns false, the new value isn't set. + +=item after_set_I PARAMHASH + +This hook will be called after a value is successfully set in the +database. It will be called with a reference to a paramhash that +contains C and C keys. If C was a SQL function, +it will now contain the actual value that was set. + +This hook's return value is ignored. + +=item validate_I VALUE + +This hook is called just before updating the database. It expects the +actual new value you're trying to set I to. It returns +two values. The first is a boolean with truth indicating success. The +second is an optional message. Note that validate_I may be +called outside the context of a I operation to validate a potential +value. (The Jifty application framework uses this as part of its AJAX +validation system.) + +=back + + +=cut + +=head2 _value + +_value takes a single column name and returns that column's value for +this row. Subclasses can override _value to insert custom access +control. + +=cut + +sub _value { + my $self = shift; + my $column = shift; + + my $value = $self->__value( $column => @_ ); + $self->_run_callback( name => "after_".$column, + args => \$value); + return $value; +} + +=head2 __value + +Takes a column name and returns that column's value. Subclasses should +never override __value. + +=cut + +sub __value { + my $self = shift; + + my $column_name = lc(shift); + # If the requested column is actually an alias for another, resolve it. + my $column = $self->column($column_name); + if ($column and defined $column->alias_for_column ) { + $column = $self->column($column->alias_for_column()); + $column_name = $column->name; + } + + return unless ($column); + + # In the default case of "yeah, we have a value", return it as + # fast as we can. + return $self->{'values'}{$column_name} + if ( $self->{'fetched'}{$column_name} + && $self->{'decoded'}{$column_name} ); + + if ( !$self->{'fetched'}{ $column_name } and my $id = $self->id() ) { + my $pkey = $self->_primary_key(); + my $query_string = "SELECT " . $column_name + . " FROM " + . $self->table + . " WHERE $pkey = ?"; + my $sth = $self->_handle->simple_query( $query_string, $id ); + my ($value) = eval { $sth->fetchrow_array() }; + warn $@ if $@; + + $self->{'values'}{ $column_name } = $value; + $self->{'fetched'}{ $column_name } = 1; + } + unless ( $self->{'decoded'}{ $column_name } ) { + $self->_apply_output_filters( + column => $column, + value_ref => \$self->{'values'}{ $column_name }, + ) if exists $self->{'values'}{ $column_name }; + $self->{'decoded'}{ $column_name } = 1; + } + + return $self->{'values'}{ $column_name }; +} + +=head2 as_hash + +Returns a version of this record's readable columns rendered as a hash of key => value pairs + +=cut + +sub as_hash { + my $self = shift; + my %values; + $values{$_} = $self->$_() for $self->readable_attributes; + return %values; +} + + + +=head2 _set + +_set takes a single column name and a single unquoted value. +It updates both the in-memory value of this column and the in-database copy. +Subclasses can override _set to insert custom access control. + +=cut + +sub _set { + my $self = shift; + my %args = ( + 'column' => undef, + 'value' => undef, + 'is_sql_function' => undef, + @_ + ); + + + my $ok = $self->_run_callback( name => "before_set_" . $args{column}, + args => \%args); + return $ok if( not defined $ok); + + $ok = $self->__set(%args); + return $ok if not $ok; + + # Fetch the value back to make sure we have the actual value + my $value = $self->_value($args{column}); + my $after_set_ret = $self->_run_callback( name => "after_set_" . $args{column}, args => + {column => $args{column}, value => $value}); + + return $ok; +} + +sub __set { + my $self = shift; + + my %args = ( + 'column' => undef, + 'value' => undef, + 'is_sql_function' => undef, + @_ + ); + + my $ret = Class::ReturnValue->new(); + + my $column = $self->column( $args{'column'} ); + unless ($column) { + $ret->as_array( 0, 'No column specified' ); + $ret->as_error( + errno => 5, + do_backtrace => 0, + message => "No column specified" + ); + return ( $ret->return_value ); + } + + $self->_apply_input_filters( + column => $column, + value_ref => \$args{'value'} + ); + + # if value is not fetched or it's allready decoded + # then we don't check eqality + # we also don't call __value because it decodes value, but + # we need encoded value + if ( $self->{'fetched'}{ $column->name } + || !$self->{'decoded'}{ $column->name } ) + { + if (( !defined $args{'value'} + && !defined $self->{'values'}{ $column->name } + ) + || ( defined $args{'value'} + && defined $self->{'values'}{ $column->name } + + # XXX: This is a bloody hack to stringify DateTime + # and other objects for compares + && $args{value} + . "" eq "" + . $self->{'values'}{ $column->name } + ) + ) + { + $ret->as_array( 1, "That is already the current value" ); + return ( $ret->return_value ); + } + } + + if ( my $sub = $column->validator ) { + my ( $ok, $msg ) = $sub->( $self, $args{'value'} ); + unless ($ok) { + $ret->as_array( 0, 'Illegal value for ' . $column->name ); + $ret->as_error( + errno => 3, + do_backtrace => 0, + message => "Illegal value for " . $column->name + ); + return ( $ret->return_value ); + } + } + + + # Implement 'is distinct' checking + if ( $column->distinct ) { + my $ret = $self->is_distinct( $column->name, $args{'value'} ); + return ( $ret ) if not ( $ret ); + } + + # The blob handling will destroy $args{'value'}. But we assign + # that back to the object at the end. this works around that + my $unmunged_value = $args{'value'}; + + if ( $column->type =~ /^(text|longtext|clob|blob|lob|bytea)$/i ) { + my $bhash = $self->_handle->blob_params( $column->name, $column->type ); + $bhash->{'value'} = $args{'value'}; + $args{'value'} = $bhash; + } + + my $val = $self->_handle->update_record_value( + %args, + table => $self->table(), + primary_keys => { $self->primary_keys() } + ); + + unless ($val) { + my $message + = $column->name . " could not be set to " . $args{'value'} . "."; + $ret->as_array( 0, $message ); + $ret->as_error( + errno => 4, + do_backtrace => 0, + message => $message + ); + return ( $ret->return_value ); + } + + # If we've performed some sort of "functional update" + # then we need to reload the object from the DB to know what's + # really going on. (ex SET Cost = Cost+5) + if ( $args{'is_sql_function'} ) { + + # XXX TODO primary_keys + $self->load_by_cols( id => $self->id ); + } else { + $self->{'values'}{ $column->name } = $unmunged_value; + $self->{'decoded'}{ $column->name } = 0; + } + $ret->as_array( 1, "The new value has been set." ); + return ( $ret->return_value ); +} + +=head2 load + +C can be called as a class or object method. + +Takes a single argument, $id. Calls load_by_cols to retrieve the row +whose primary key is $id. + +=cut + +sub load { + my $self = shift; + return unless @_ and defined $_[0]; + + return $self->load_by_cols( id => shift ); +} + +=head2 load_by_cols + +C can be called as a class or object method. + +Takes a hash of columns and values. Loads the first record that matches all +keys. + +The hash's keys are the columns to look at. + +The hash's values are either: scalar values to look for +OR hash references which contain 'operator' and 'value' + +=cut + +sub load_by_cols { + my $class = shift; + my %hash = (@_); + my ($self); + if (ref($class)) { + ($self,$class) = ($class,undef); + } else { + $self = $class->new( handle => (delete $hash{'_handle'} || undef)); + } + + my ( @bind, @phrases ); + foreach my $key ( keys %hash ) { + if ( defined $hash{$key} && $hash{$key} ne '' ) { + my $op; + my $value; + my $function = "?"; + if ( ref $hash{$key} eq 'HASH' ) { + $op = $hash{$key}->{operator}; + $value = $hash{$key}->{value}; + $function = $hash{$key}->{function} || "?"; + } else { + $op = '='; + $value = $hash{$key}; + } + + if (blessed $value && $value->isa('Jifty::DBI::Record') ) { + # XXX TODO: check for proper foriegn keyness here + $value = $value->id; + } + + + push @phrases, "$key $op $function"; + push @bind, $value; + } elsif (!defined $hash{$key}) { + push @phrases, "$key IS NULL"; + } else { + push @phrases, "($key IS NULL OR $key = ?)"; + my $column = $self->column($key); + + if ( $column->is_numeric ) { + push @bind, 0; + } else { + push @bind, ''; + } + + } + } + + my $query_string = "SELECT * FROM " . $self->table . " WHERE " . join( ' AND ', @phrases ); + if ($class) { $self->_load_from_sql( $query_string, @bind ); return $self} + else {return $self->_load_from_sql( $query_string, @bind );} + +} + +=head2 load_by_primary_keys + +Loads records with a given set of primary keys. + +=cut + +sub load_by_primary_keys { + my $self = shift; + my $data = ( ref $_[0] eq 'HASH' ) ? $_[0] : {@_}; + + my %cols = (); + foreach ( @{ $self->_primary_keys } ) { + return ( 0, "Missing PK column: '$_'" ) unless defined $data->{$_}; + $cols{$_} = $data->{$_}; + } + return ( $self->load_by_cols(%cols) ); +} + +=head2 load_from_hash + +Takes a hashref, such as created by Jifty::DBI and populates this record's +loaded values hash. + +=cut + +sub load_from_hash { + my $class = shift; + my $hashref = shift; + my ($self); + + if (ref($class)) { + ($self,$class) = ($class,undef); + } else { + $self = $class->new( handle => (delete $hashref->{'_handle'} || undef)); + } + + + foreach my $f ( keys %$hashref ) { + $self->{'fetched'}{ lc $f } = 1; + } + + $self->{'values'} = $hashref; + $self->{'decoded'} = {}; + return $self->id(); +} + +=head2 _load_from_sql QUERYSTRING @BIND_VALUES + +Load a record as the result of an SQL statement + +=cut + +sub _load_from_sql { + my $self = shift; + my $query_string = shift; + my @bind_values = (@_); + + my $sth = $self->_handle->simple_query( $query_string, @bind_values ); + + #TODO this only gets the first row. we should check if there are more. + + return ( 0, "Couldn't execute query" ) unless $sth; + + $self->{'values'} = $sth->fetchrow_hashref; + $self->{'fetched'} = {}; + $self->{'decoded'} = {}; + if ( !$self->{'values'} && $sth->err ) { + return ( 0, "Couldn't fetch row: " . $sth->err ); + } + + unless ( $self->{'values'} ) { + return ( 0, "Couldn't find row" ); + } + + ## I guess to be consistant with the old code, make sure the primary + ## keys exist. + + if ( grep { not defined } $self->primary_keys ) { + return ( 0, "Missing a primary key?" ); + } + + foreach my $f ( keys %{ $self->{'values'} } ) { + $self->{'fetched'}{ lc $f } = 1; + } + return ( 1, "Found object" ); + +} + +=head2 create PARAMHASH + +C can be called as either a class or object method + +This method creates a new record with the values specified in the PARAMHASH. + +This method calls two hooks in your subclass: + +=over + +=item before_create + + sub before_create { + my $self = shift; + my $args = shift; + + # Do any checks and changes on $args here. + $args->{first_name} = ucfirst $args->{first_name}; + + return; # false return vallue will abort the create + return 1; # true return value will allow create to continue + } + +This method is called before trying to create our row in the +database. It's handed a reference to your paramhash. (That means it +can modify your parameters on the fly). C returns a +true or false value. If it returns false, the create is aborted. + +=item after_create + + sub after_create { + my $self = shift; + my $insert_return_value_ref = shift; + + return unless $$insert_return_value_ref; # bail if insert failed + $self->load($$insert_return_value_ref); # load ourselves from db + + # Do whatever needs to be done here + + return; # return value is ignored + } + +This method is called after attempting to insert the record into the +database. It gets handed a reference to the return value of the +insert. That'll either be a true value or a L + +=back + + +=cut + +sub create { + my $class = shift; + my %attribs = @_; + + my ($self); + if (ref($class)) { + ($self,$class) = ($class,undef); + } else { + $self = $class->new( handle => (delete $attribs{'_handle'} || undef)); + } + + + + my $ok = $self->_run_callback( name => "before_create", args => \%attribs); + return $ok if ( not defined $ok); + + my $ret = $self->__create(%attribs); + + $ok = $self->_run_callback( name => "after_create", + args => \$ret); + return $ok if (not defined $ok); + + if ($class) { + $self->load_by_cols(id => $ret); + return ($self); + } + else { + return ($ret); + } +} + +sub __create { + my ($self, %attribs) = @_; + + foreach my $column_name ( keys %attribs ) { + my $column = $self->column($column_name); + unless ($column) { + # "Virtual" columns beginning with __ is passed through to handle without munging. + next if $column_name =~ /^__/; + + Carp::confess "$column_name isn't a column we know about"; + } + if ( $column->readable + and $column->refers_to + and UNIVERSAL::isa( $column->refers_to, "Jifty::DBI::Record" ) ) + { + $attribs{$column_name} = $attribs{$column_name}->id + if UNIVERSAL::isa( $attribs{$column_name}, + 'Jifty::DBI::Record' ); + } + + $self->_apply_input_filters( + column => $column, + value_ref => \$attribs{$column_name}, + ); + + # Implement 'is distinct' checking + if ( $column->distinct ) { + my $ret = $self->is_distinct( $column_name, $attribs{$column_name} ); + if (not $ret ) { + Carp::cluck("$self failed a 'is_distinct' check for $column_name on ".$attribs{$column_name}); + return ( $ret ) + } + } + + if ( $column->type =~ /^(text|longtext|clob|blob|lob|bytea)$/i ) { + my $bhash = $self->_handle->blob_params( $column_name, $column->type ); + $bhash->{'value'} = $attribs{$column_name}; + $attribs{$column_name} = $bhash; + } + } + + for my $column ($self->columns) { + if (not defined $attribs{$column->name} and defined $column->default and not ref $column->default) { + $attribs{$column->name} = $column->default; + } + if (not defined $attribs{$column->name} and $column->mandatory and $column->type ne "serial" ) { + # Enforce "mandatory" + Carp::carp "Did not supply value for mandatory column ".$column->name; + return ( 0 ); + } + } + + return $self->_handle->insert( $self->table, %attribs ); +} + +=head2 delete + +Delete this record from the database. On failure return a +Class::ReturnValue with the error. On success, return 1; + +This method has two hooks + +=over + +=item before_delete + +This method is called before the record deletion, if it exists. On +failure it returns a L with the error. On success +it returns 1. + +If this method returns an error, it causes the delete to abort and return +the return value from this hook. + +=item after_delete + +This method is called after deletion, with a reference to the return +value from the delete operation. + +=back + +=cut + +sub delete { + my $self = shift; + my $before_ret = $self->_run_callback( name => 'before_delete' ); + return $before_ret unless (defined $before_ret); + my $ret = $self->__delete; + + my $after_ret + = $self->_run_callback( name => 'after_delete', args => \$ret ); + return $after_ret unless (defined $after_ret); + return ($ret); + +} + +sub __delete { + my $self = shift; + + #TODO Check to make sure the key's not already listed. + #TODO Update internal data structure + + ## Constructs the where clause. + my %pkeys = $self->primary_keys(); + my $return = $self->_handle->delete( $self->table, $self->primary_keys ); + + if ( UNIVERSAL::isa( 'Class::ReturnValue', $return ) ) { + return ($return); + } else { + return (1); + } +} + +=head2 table + +This method returns this class's default table name. It uses +Lingua::EN::Inflect to pluralize the class's name as we believe that +class names for records should be in the singular and table names +should be plural. + +If your class name is C, your table name will default +to C. If your class name is C, your +default table name will be C. Not perfect, but +arguably correct. + +=cut + +sub table { + my $self = shift; + $self->TABLE_NAME($self->_guess_table_name) unless ($self->TABLE_NAME()); + return $self->TABLE_NAME(); +} + +=head2 collection_class + +Returns the collection class which this record belongs to; override this to +subclass. If you haven't specified a collection class, this returns a best +guess at the name of the collection class for this collection. + +It uses a simple heuristic to determine the collection class name -- It +appends "Collection" to its own name. If you want to name your records +and collections differently, go right ahead, but don't say we didn't +warn you. + +=cut + +sub collection_class { + my $self = shift; + my $class = ref($self) || $self; + $class . 'Collection'; +} + +=head2 _guess_table_name + +Guesses a table name based on the class's last part. + + +=cut + +sub _guess_table_name { + my $self = shift; + my $class = ref($self) ? ref($self) : $self; + die "Couldn't turn " . $class . " into a table name" + unless ( $class =~ /(?:\:\:)?(\w+)$/ ); + my $table = $1; + $table =~ s/(?<=[a-z])([A-Z]+)/"_" . lc($1)/eg; + $table =~ tr/A-Z/a-z/; + $table = Lingua::EN::Inflect::PL_N($table); + return ($table); + +} + +=head2 _handle + +Returns or sets the current Jifty::DBI::Handle object + +=cut + +sub _handle { + my $self = shift; + if (@_) { + $self->{'DBIxHandle'} = shift; + } + return ( $self->{'DBIxHandle'} ); +} + +=head2 PRIVATE refers_to + +used for the declarative syntax + + +=cut + +sub _filters { + my $self = shift; + my %args = ( direction => 'input', column => undef, @_ ); + + my @filters = (); + my @objs = ( $self, $args{'column'}, $self->_handle ); + @objs = reverse @objs if $args{'direction'} eq 'output'; + my $method = $args{'direction'} . "_filters"; + foreach my $obj (@objs) { + push @filters, $obj->$method(); + } + return grep $_, @filters; +} + +sub _apply_input_filters { + return (shift)->_apply_filters( direction => 'input', @_ ); +} + +sub _apply_output_filters { + return (shift)->_apply_filters( direction => 'output', @_ ); +} + +sub _apply_filters { + my $self = shift; + my %args = ( + direction => 'input', + column => undef, + value_ref => undef, + @_ + ); + + my @filters = $self->_filters(%args); + my $action = $args{'direction'} eq 'output' ? 'decode' : 'encode'; + foreach my $filter_class (@filters) { + local $UNIVERSAL::require::ERROR; + $filter_class->require() unless + $INC{ join('/', split(/::/,$filter_class)).".pm" }; + + if ($UNIVERSAL::require::ERROR) { + warn $UNIVERSAL::require::ERROR; + next; + } + my $filter = $filter_class->new( + record => $self, + column => $args{'column'}, + value_ref => $args{'value_ref'}, + ); + + # XXX TODO error proof this + $filter->$action(); + } +} + +=head2 is_distinct COLUMN_NAME, VALUE + +Checks to see if there is already a record in the database where +COLUMN_NAME equals VALUE. If no such record exists then the +COLUMN_NAME and VALUE pair is considered distinct and it returns 1. +If a value is already present the test is considered to have failed +and it returns a L with the error. + +=cut + +sub is_distinct { + my $self = shift; + my $column = shift; + my $value = shift; + + my $record = $self->new( handle => $self->_handle ); + $record->load_by_cols ( $column => $value ); + + my $ret = Class::ReturnValue->new(); + + if( $record->id ) { + $ret->as_array( 0, "Value already exists for unique column $column"); + $ret->as_error( + errno => 3, + do_backtrace => 0, + message => "Value already exists for unique column $column", + ); + return ( $ret->return_value ); + } else { + return (1); + } +} + + +=head2 run_canonicalization_for_column column => 'COLUMN', value => 'VALUE' + +Runs all canonicalizers for the specified column. + +=cut + +sub run_canonicalization_for_column { + my $self = shift; + my %args = ( column => undef, + value => undef, + @_); + + my ($ret,$value_ref) = $self->_run_callback ( name => "canonicalize_".$args{'column'}, args => $args{'value'}); + return unless defined $ret; + return ( exists $value_ref->[-1]->[0] ? $value_ref->[-1]->[0] : $args{'value'}); +} + +=head2 has_canonicalizer_for_column COLUMN + +Returns true if COLUMN has a canonicalizer, otherwise returns undef. + +=cut + +sub has_canonicalizer_for_column { + my $self = shift; + my $key = shift; + my $method = "canonicalize_$key"; + if( $self->can($method) ) { + return 1; + } else { + return undef; + } +} + + +=head2 run_validation_for_column column => 'COLUMN', value => 'VALUE' + +Runs all validators for the specified column. + +=cut + +sub run_validation_for_column { + my $self = shift; + my %args = ( + column => undef, + value => undef, + @_ + ); + my $key = $args{'column'}; + my $attr = $args{'value'}; + + + my ($ret, $results) = $self->_run_callback( name => "validate_".$key, args => $attr ); + + if (defined $ret) { + return ( 1, 'Validation ok' ); + } + else { + return (@{ $results->[-1]}); + } + +} + +=head2 has_validator_for_column COLUMN + +Returns true if COLUMN has a validator, otherwise returns undef. + +=cut + +sub has_validator_for_column { + my $self = shift; + my $key = shift; + if ( $self->can( "validate_" . $key ) ) { + return 1; + } else { + return undef; + } +} + + +sub _run_callback { + my $self = shift; + my %args = ( + name => undef, + args => undef, + @_ + ); + + my $ret; + my $method = $args{'name'}; + my @results; + if ( my $func = $self->can($method) ) { + @results = $func->( $self, $args{args} ); + return ( wantarray ? ( undef, [[@results]] ) : undef ) + unless $results[0]; + } + $ret = $self->call_trigger( $args{'name'} => $args{args} ); + return ( + wantarray + ? ( $ret, [ [@results], @{ $self->last_trigger_results } ] ) + : $ret ); +} + +1; + +__END__ + + + +=head1 AUTHOR + +Jesse Vincent , Alex Vandiver , David Glasser , Ruslan Zakirov + +Based on DBIx::SearchBuilder::Record, whose credits read: + + Jesse Vincent, + Enhancements by Ivan Kohler, + Docs by Matt Knopp + +=head1 SEE ALSO + +L + +=cut + + diff --git a/lib/DBIx/Class/JDBICompat/Record/Cachable.pm b/lib/DBIx/Class/JDBICompat/Record/Cachable.pm new file mode 100755 index 0000000..ce3660b --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Record/Cachable.pm @@ -0,0 +1,354 @@ +package Jifty::DBI::Record::Cachable; + +use base qw(Jifty::DBI::Record); + +use Jifty::DBI::Handle; + +use Cache::Simple::TimedExpiry; +use Scalar::Util qw/ blessed /; + +use strict; +use warnings; + +=head1 NAME + +Jifty::DBI::Record::Cachable - records with caching behavior + +=head1 SYNOPSIS + + package Myrecord; + use base qw/Jifty::DBI::Record::Cachable/; + +=head1 DESCRIPTION + +This module subclasses the main L package to add a +caching layer. + +The public interface remains the same, except that records which have +been loaded in the last few seconds may be reused by subsequent fetch +or load methods without retrieving them from the database. + +=head1 METHODS + +=cut + +my %_CACHES = (); + +sub _setup_cache { + my $self = shift; + my $cache = shift; + $_CACHES{$cache} = Cache::Simple::TimedExpiry->new(); + $_CACHES{$cache}->expire_after( $self->_cache_config->{'cache_for_sec'} ); +} + +=head2 flush_cache + +This class method flushes the _global_ Jifty::DBI::Record::Cachable +cache. All caches are immediately expired. + +=cut + +sub flush_cache { + %_CACHES = (); +} + +sub _key_cache { + my $self = shift; + my $cache = $self->_handle->dsn + . "-KEYS--" + . ( $self->{'_class'} ||= ref($self) ); + $self->_setup_cache($cache) unless exists( $_CACHES{$cache} ); + return ( $_CACHES{$cache} ); + +} + +=head2 _flush_key_cache + +Blow away this record type's key cache + +=cut + +sub _flush_key_cache { + my $self = shift; + my $cache = $self->_handle->dsn + . "-KEYS--" + . ( $self->{'_class'} ||= ref($self) ); + $self->_setup_cache($cache); +} + +sub _record_cache { + my $self = shift; + my $cache + = $self->_handle->dsn . "--" . ( $self->{'_class'} ||= ref($self) ); + $self->_setup_cache($cache) unless exists( $_CACHES{$cache} ); + return ( $_CACHES{$cache} ); + +} + +=head2 load_from_hash + +Overrides the implementation from L to add caching. + +=cut + + +sub load_from_hash { + my $self = shift; + + my ( $rvalue, $msg ); + if ( ref($self) ) { + + # Blow away the primary cache key since we're loading. + $self->{'_jifty_cache_pkey'} = undef; + ( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_); + + ## Check the return value, if its good, cache it! + $self->_store() if ($rvalue); + return ( $rvalue, $msg ); + } else { # Called as a class method; + $self = $self->SUPER::load_from_hash(@_); + ## Check the return value, if its good, cache it! + $self->_store() if ( $self->id ); + return ($self); + } + +} + +=head2 load_by_cols + +Overrides the implementation from L to add caching. + +=cut + +sub load_by_cols { + my ( $class, %attr ) = @_; + + my ($self); + if ( ref($class) ) { + ( $self, $class ) = ( $class, undef ); + } else { + $self = $class->new( + handle => ( delete $attr{'_handle'} || undef ) ); + } + + ## Generate the cache key + my $alt_key = $self->_gen_record_cache_key(%attr); + if ( $self->_fetch($alt_key) ) { + if ($class) { return $self } + else { return ( 1, "Fetched from cache" ) } + } + + # Blow away the primary cache key since we're loading. + $self->{'_jifty_cache_pkey'} = undef; + + ## Fetch from the DB! + my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr); + ## Check the return value, if its good, cache it! + if ($rvalue) { + ## Only cache the object if its okay to do so. + $self->_store(); + $self->_key_cache->set( + $alt_key => $self->_primary_record_cache_key ); + + } + if ($class) { return $self } + else { + return ( $rvalue, $msg ); + } +} + +# Function: __set +# Type : (overloaded) public instance +# Args : see Jifty::DBI::Record::_Set +# Lvalue : ? + +sub __set () { + my $self = shift; + + $self->_expire(); + return $self->SUPER::__set(@_); + +} + +# Function: delete +# Type : (overloaded) public instance +# Args : nil +# Lvalue : ? + +sub __delete () { + my $self = shift; + + $self->_expire(); + return $self->SUPER::__delete(@_); + +} + +# Function: _expire +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Removes this object from the cache. + +sub _expire (\$) { + my $self = shift; + $self->_record_cache->set( $self->_primary_record_cache_key, undef, time - 1 ); + + # We should be doing something more surgical to clean out the key cache. but we do need to expire it + $self->_flush_key_cache; + +} + +# Function: _fetch +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Get an object from the cache, and make this object that. + +sub _fetch () { + my ( $self, $cache_key ) = @_; + # If the alternate key is really the primary one + + + my $data = $self->_record_cache->fetch($cache_key); + + unless ($data) { + $cache_key = $self->_key_cache->fetch( $cache_key ); + $data = $self->_record_cache->fetch( $cache_key ) if $cache_key; + } + + return undef unless ($data); + + @{$self}{ keys %$data } = values %$data; # deserialize + return 1; + + +} + +#sub __value { +# my $self = shift; +# my $column = shift; +# +# # XXX TODO, should we be fetching directly from the cache? +# return ( $self->SUPER::__value($column) ); +#} + +# Function: _store +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Stores this object in the cache. + +sub _store (\$) { + my $self = shift; + $self->_record_cache->set( $self->_primary_record_cache_key, + { values => $self->{'values'}, + table => $self->table, + fetched => $self->{'fetched'}, + decoded => $self->{'decoded'}, + } + ); +} + + +# Function: _gen_record_cache_key +# Type : private instance +# Args : hash (attr) +# Lvalue : 1 +# Desc : Takes a perl hash and generates a key from it. + +sub _gen_record_cache_key { + my ( $self, %attr ) = @_; + + my @cols; + + while ( my ( $key, $value ) = each %attr ) { + unless ( defined $value ) { + push @cols, lc($key) . '=__undef'; + } + elsif ( ref($value) eq "HASH" ) { + push @cols, lc($key) . ( $value->{operator} || '=' ) + . defined $value->{value}? $value->{value}: '__undef'; + } + elsif ( blessed $value and $value->isa('Jifty::DBI::Record') ) { + push @cols, lc($key) . '=' . ( $value->id ); + } + else { + push @cols, lc($key) . "=" . $value; + } + } + return ( $self->table() . ':' . join( ',', @cols ) ); +} + +# Function: _fetch_record_cache_key +# Type : private instance +# Args : nil +# Lvalue : 1 + +sub _fetch_record_cache_key { + my ($self) = @_; + my $cache_key = $self->_cache_config->{'cache_key'}; + return ($cache_key); +} + +# Function: _primary_record_cache_key +# Type : private instance +# Args : none +# Lvalue: : 1 +# Desc : generate a primary-key based variant of this object's cache key +# primary keys is in the cache + +sub _primary_record_cache_key { + my ($self) = @_; + + unless ( $self->{'_jifty_cache_pkey'} ) { + + my @attributes; + my %pk = $self->primary_keys; + while ( my ($key, $value) = each %pk ) { + return unless defined $value; + push @attributes, lc( $key ) . '=' . $value; + } + + $self->{'_jifty_cache_pkey'} = $self->table .':' + . join ',', @attributes; + } + return ( $self->{'_jifty_cache_pkey'} ); + +} + +=head2 _cache_config + +You can override this method to change the duration of the caching +from the default of 5 seconds. + +For example, to cache records for up to 30 seconds, add the following +method to your class: + + sub _cache_config { + { 'cache_for_sec' => 30 } + } + +=cut + +sub _cache_config { + { 'cache_p' => 1, + 'cache_for_sec' => 5, + }; +} + +1; + +__END__ + + +=head1 AUTHOR + +Matt Knopp + +=head1 SEE ALSO + +L, L + +=cut + + diff --git a/lib/DBIx/Class/JDBICompat/Record/Memcached.pm b/lib/DBIx/Class/JDBICompat/Record/Memcached.pm new file mode 100755 index 0000000..b4ae61e --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Record/Memcached.pm @@ -0,0 +1,322 @@ +use warnings; +use strict; + +package Jifty::DBI::Record::Memcached; + +use Jifty::DBI::Record; +use Jifty::DBI::Handle; +use base qw (Jifty::DBI::Record); + +use Cache::Memcached; + + +=head1 NAME + +Jifty::DBI::Record::Memcached - records with caching behavior + +=head1 SYNOPSIS + + package Myrecord; + use base qw/Jifty::DBI::Record::Memcached/; + +=head1 DESCRIPTION + +This module subclasses the main L package to add a +caching layer. + +The public interface remains the same, except that records which have +been loaded in the last few seconds may be reused by subsequent get +or load methods without retrieving them from the database. + +=head1 METHODS + +=cut + + +use vars qw/$MEMCACHED/; + + + + +# Function: _init +# Type : class ctor +# Args : see Jifty::DBI::Record::new +# Lvalue : Jifty::DBI::Record::Cachable + +sub _init () { + my ( $self, @args ) = @_; + $MEMCACHED ||= Cache::Memcached->new( {$self->memcached_config} ); + $self->SUPER::_init(@args); +} + +=head2 load_from_hash + +Overrides the implementation from L to add support for caching. + +=cut + +sub load_from_hash { + my $self = shift; + + # Blow away the primary cache key since we're loading. + if ( ref($self) ) { + my ( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_); + ## Check the return value, if its good, cache it! + $self->_store() if ($rvalue); + return ( $rvalue, $msg ); + } else { + $self = $self->SUPER::load_from_hash(@_); + ## Check the return value, if its good, cache it! + $self->_store() if ( $self->id ); + return $self; + + } +} + +=head2 load_by_cols + +Overrides the implementation from L to add support for caching. + +=cut + +sub load_by_cols { + my ( $class, %attr ) = @_; + + my ($self); + if ( ref($class) ) { + ( $self, $class ) = ( $class, undef ); + } else { + $self = $self->new( handle => ( delete $attr{'_handle'} || undef ) ); + } + + ## Generate the cache key + my $key = $self->_gen_load_by_cols_key(%attr); + if ( $self->_get($key) ) { + if ($class) { return $self } + else { return ( 1, "Fetched from cache" ) } + } + ## Fetch from the DB! + my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr); + ## Check the return value, if its good, cache it! + if ($rvalue) { + $self->_store(); + if ( $key ne $self->_primary_key ) { + $MEMCACHED->add( $key, $self->_primary_cache_key, + $self->_cache_config->{'cache_for_sec'} ); + $self->{'loaded_by_cols'} = $key; + } + } + if ($class) { return $self } + else { + return ( $rvalue, $msg ); + } +} + +# Function: __set +# Type : (overloaded) public instance +# Args : see Jifty::DBI::Record::_Set +# Lvalue : ? + +sub __set () { + my ( $self, %attr ) = @_; + $self->_expire(); + return $self->SUPER::__set(%attr); + +} + +# Function: _delete +# Type : (overloaded) public instance +# Args : nil +# Lvalue : ? + +sub __delete () { + my ($self) = @_; + $self->_expire(); + return $self->SUPER::__delete(); +} + +# Function: _expire +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Removes this object from the cache. + +sub _expire (\$) { + my $self = shift; + $MEMCACHED->delete($self->_primary_cache_key); + $MEMCACHED->delete($self->{'loaded_by_cols'}) if ($self->{'loaded_by_cols'}); + +} + +# Function: _get +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Get an object from the cache, and make this object that. + +sub _get () { + my ( $self, $cache_key ) = @_; + my $data = $MEMCACHED->get($cache_key) or return; + # If the cache value is a scalar, that's another key + unless (ref $data) { $data = $MEMCACHED->get($data); } + unless (ref $data) { return undef; } + @{$self}{ keys %$data } = values %$data; # deserialize +} + +sub __value { + my $self = shift; + my $column = shift; + return ( $self->SUPER::__value($column) ); +} + +# Function: _store +# Type : private instance +# Args : string(cache_key) +# Lvalue : 1 +# Desc : Stores this object in the cache. + +sub _store (\$) { + my $self = shift; + # Blow away the primary cache key since we're loading. + $self->{'_jifty_cache_pkey'} = undef; + $MEMCACHED->set( $self->_primary_cache_key, + { values => $self->{'values'}, + table => $self->table, + fetched => $self->{'fetched'} + }, + $self->_cache_config->{'cache_for_sec'} + ); +} + + +# Function: _gen_load_by_cols_key +# Type : private instance +# Args : hash (attr) +# Lvalue : 1 +# Desc : Takes a perl hash and generates a key from it. + +sub _gen_load_by_cols_key { + my ( $self, %attr ) = @_; + + my $cache_key = $self->cache_key_prefix . '-'. $self->table() . ':'; + my @items; + while ( my ( $key, $value ) = each %attr ) { + $key ||= '__undef'; + $value ||= '__undef'; + + if ( ref($value) eq "HASH" ) { + $value = ( $value->{operator} || '=' ) . $value->{value}; + } else { + $value = "=" . $value; + } + push @items, $key.$value; + + } + $cache_key .= join(',',@items); + return ($cache_key); +} + +# Function: _primary_cache_key +# Type : private instance +# Args : none +# Lvalue: : 1 +# Desc : generate a primary-key based variant of this object's cache key +# primary keys is in the cache + +sub _primary_cache_key { + my ($self) = @_; + + return undef unless ( $self->id ); + + unless ( $self->{'_jifty_cache_pkey'} ) { + + my $primary_cache_key = $self->cache_key_prefix .'-' .$self->table() . ':'; + my @attributes; + foreach my $key ( @{ $self->_primary_keys } ) { + push @attributes, $key . '=' . $self->SUPER::__value($key); + } + + $primary_cache_key .= join( ',', @attributes ); + + $self->{'_jifty_cache_pkey'} = $primary_cache_key; + } + return ( $self->{'_jifty_cache_pkey'} ); + +} + +=head2 _cache_config + +You can override this method to change the duration of the caching +from the default of 5 seconds. + +For example, to cache records for up to 30 seconds, add the following +method to your class: + + sub _cache_config { + { 'cache_for_sec' => 30 } + } + +=cut + +sub _cache_config { + { + 'cache_for_sec' => 180, + }; +} + +=head2 memcached_config + +Returns a hash containing arguments to pass to L during construction. The defaults are like: + + ( + services => [ '127.0.0.1:11211' ], + debug => 0, + ) + +You may want to override this method if you want a customized cache configuration: + + sub memcached_config { + ( + servers => [ '10.0.0.15:11211', '10.0.0.15:11212', + '10.0.0.17:11211', [ '10.0.0.17:11211', 3 ] ], + debug => 0, + compress_threshold => 10_000, + ); + } + +=cut + + +sub memcached_config { + servers => ['127.0.0.1:11211'], + debug => 0 + +} + +=head2 cache_key_prefix + +Returns the prefix we should prepend to all cache keys. If you're using one memcached for multiple +applications, you want this to be different for each application or they might end up mingling data. + +=cut + +sub cache_key_prefix { + return 'Jifty-DBI'; +} + +1; + +__END__ + + +=head1 AUTHOR + +Matt Knopp + +=head1 SEE ALSO + +L, L + +=cut + + diff --git a/lib/DBIx/Class/JDBICompat/Record/Plugin.pm b/lib/DBIx/Class/JDBICompat/Record/Plugin.pm new file mode 100644 index 0000000..79712d7 --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Record/Plugin.pm @@ -0,0 +1,128 @@ +package Jifty::DBI::Record::Plugin; + +use warnings; +use strict; + +use base qw/Exporter/; + +=head1 NAME + +Jifty::DBI::Record::Plugin - Record model mixins for Jifty::DBI + +=head1 SYNOPSIS + + # Define a mixin + package MyApp::FavoriteColor; + use base qw/ Jifty::DBI::Record::Plugin /; + + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + column favorite_color => + type is 'text', + label is 'Favorite Color', + valid_values are qw/ red green blue yellow /; + }; + + # Use the mixin + package MyApp::Model::User; + + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + column name => + type is 'text', + label is 'Name'; + }; + + # Mixins + use MyApp::FavoriteColor; + + sub name_and_color { + my $self = shift; + my $name = $self->name; + my $color = $self->favorite_color; + + return "The favorite color of $name is $color."; + } + +=head1 DESCRIPTION + +By using this package you may provide models that are built from one or more mixins. In fact, your whole table could be defined in the mixins without a single column declared within the model class itself. + +=head2 MODEL MIXINS + +To build a mixin, just create a model that inherits from this package, C. Then, add the schema definitions you want inherited. + + package MyApp::FasterSwallow; + use base qw/ Jifty::DBI::Record::Plugin /; + + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + column swallow_type => + type is 'text', + valid are qw/ african european /, + default is 'african'; + }; + +=head3 register_triggers + +Your mixin may also want to register triggers for the records to which it will be added. You can do this by defining a method named C: + + sub register_triggers { + my $self = shift; + $self->add_trigger( + name => 'before_create', + callback => \&before_create, + abortable => 1, + ); + } + + sub before_create { + # do something... + } + +See L. + +=head2 MODELS USING MIXINS + +To use your model plugin, just use the mixins you want to get columns from. You should still include a schema definition, even if it's empty: + + package MyApp::Model::User; + + use Jifty::DBI::Schema; + use MyApp::Record schema { + }; + + # Mixins + use MyApp::FavoriteColor; + use MyApp::FasterSwallow; + use Jifty::Plugin::User::Mixin::Model::User; + use Jifty::Plugin::Authentication::Password::Mixin::Model::User; + +=cut + +sub import { + my $self = shift; + my $caller = caller; + for ($self->columns) { + $caller->COLUMNS->{$_->name} = $_ ; + $caller->_init_methods_for_column($_); + } + $self->export_to_level(1,undef); + + if (my $triggers = $self->can('register_triggers') ) { + $triggers->($caller) + } +} + +=head1 SEE ALSO + +L, L + +=head1 LICENSE + +Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC. +Jifty is distributed under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/DBIx/Class/JDBICompat/Schema.pm b/lib/DBIx/Class/JDBICompat/Schema.pm new file mode 100644 index 0000000..5286e9f --- /dev/null +++ b/lib/DBIx/Class/JDBICompat/Schema.pm @@ -0,0 +1,650 @@ +use warnings; +use strict; + +package Jifty::DBI::Schema; + +=head1 NAME + +Jifty::DBI::Schema - Use a simple syntax to describe a Jifty table. + +=head1 SYNOPSIS + + package MyApp::Model::Page; + use Jifty::DBI::Schema; + use Jifty::DBI::Record schema { + # ... your columns here ... + }; + +=cut + +=head1 DESCRIPTION + +Each Jifty Application::Model::Class module describes a record class +for a Jifty application. Each C statement sets out the name +and attributes used to describe the column in a backend database, in +user interfaces, and other contexts. For example: + + column content => + type is 'text', + label is 'Content', + render as 'textarea'; + +defines a column called C that is of type C. It will be +rendered with the label C (note the capital) and as a C