--- /dev/null
+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<DBIx::SearchBuilder>. 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.
+
+<trumpets>
+
+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<column>(), and Mutators are named
+C<set_column>($). 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<Field>($) 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<Field> 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;
--- /dev/null
+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<call_trigger>. Return values will be
+captured in I<list context>.
+
+If add_trigger is called with named parameters and the C<abortable>
+parameter is passed a true value, a false return value from trigger
+code will stop processing of this trigger point and return a C<false>
+value to the calling code.
+
+If C<add_trigger> is called without the C<abortable> flag, return
+values will be captured by call_trigger, but failures will be ignored.
+
+If C<add_trigger> 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<add_trigger>
+method. Each triggers will be passed a copy of the object as the first argument.
+Remaining arguments passed to C<call_trigger> will be passed on to each trigger.
+Triggers are invoked in the same order they were defined.
+
+If there are no C<abortable> triggers or no C<abortable> trigger point returns
+a false value, C<call_trigger> will return the number of triggers processed.
+
+
+If an C<abortable> 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<import>.
+
+ 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<Acknowledgement:> 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<Class::DBI::mysql::FullTextSearch> 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 E<lt>tony@kasei.comE<gt> in Class::DBI.
+
+Code by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Class::DBI>
+
+=cut
+
--- /dev/null
+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<Jifty::DBI::Collection> and a subclass of L<Jifty::DBI::Record> for
+each table that you wish to access. (See the documentation of
+L<Jifty::DBI::Record> for more information on subclassing it.)
+
+Your L<Jifty::DBI::Collection> subclass must override L</new_item>,
+and probably should override at least L</_init> also; at the very
+least, L</_init> should probably call L</_handle> and L</_table> to
+set the database handle (a L<Jifty::DBI::Handle> object) and table
+name for the class -- see the L</SYNOPSIS> 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<Jifty::DBI::Collection> object and immediately calls
+L</_init> with the same parameters that were passed to L</new>. If
+you haven't overridden L<_init> in your subclass, this means that you
+should pass in a L<Jifty::DBI::Handle> (or one of its subclasses) like
+this:
+
+ my $sb = My::Jifty::DBI::Subclass->new( handle => $handle );
+
+However, if your subclass overrides L</_init> you do not need to take
+a handle argument, as long as your subclass takes care of calling the
+L</_handle> method somehow. This is useful if you want all of your
+L<Jifty::DBI> 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<new> with whatever arguments were passed to
+L</new>. By default, it takes a C<Jifty::DBI::Handle> object as a
+C<handle> argument and calls L</_handle> 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</clean_slate> to set up any implicit clauses that the
+collection B<always> has. Defaults to doing nothing. Is passed the
+paramhash passed into L</new>.
+
+=cut
+
+sub implicit_clauses { }
+
+=head2 _handle [DBH]
+
+Get or set this object's L<Jifty::DBI::Handle> 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</next>).
+
+=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<Jifty::DBI::Record> 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</count> and L</count_all>.
+
+=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</order_by_cols>, 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<Jifty::DBI::Collection> usually does searches "lazily". That is, it
+does a C<SELECT COUNT> or a C<SELECT> 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<do_search> before that C<count>.
+
+=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</next> 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</next>, 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</next>, 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<Jifty::DBI::Collection> 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<CLAUSE>.
+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<CLAUSE>.
+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<order_by> 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<alias>, C<column> and C<order>
+or C<function> and C<order>.
+C<alias> defaults to main.
+C<order> defaults to ASC(ending), DES(cending) is also a valid value.
+C<column> and C<function> have no default values.
+
+Use C<function> instead of C<alias> and C<column> 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<alias.column> 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<alias> and C<column> or C<function>.
+C<alias> defaults to main.
+C<column> and C<function> have no default values.
+
+Use C<function> instead of C<alias> and C<column> 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<alias.column> 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<alias1>, C<column1>, C<alias2>
+and C<column2>. C<alias1> and C<alias2> are column aliases obtained from
+$self->new_alias or a $self->limit. C<column1> and C<column2> are the columns
+in C<alias1> and C<alias2> that should be linked, respectively. For this
+type of join, this method has no return value.
+
+Supplying the parameter C<type> => 'left' causes Join to perform a left
+join. in this case, it takes C<alias1>, C<column1>, C<table2> and
+C<column2>. 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<operator> defaults C<=>, but you can specify other
+operators to join with.
+
+Instead of C<alias1>/C<column1>, it's possible to specify expression, to join
+C<alias2>/C<table2> 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<Data::Page> object so that you
+can use its calculations, and sets the L<Jifty::DBI::Collection>
+C<first_row> and C<rows_per_page> 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<column> method once for each column you
+are interested in.
+
+Takes a hash of parameters; the C<column>, C<table> and C<alias> keys means
+the same as in the C<limit> method. A special C<function> key may contain
+one of several possible kinds of expressions:
+
+=over 4
+
+=item C<DISTINCT COUNT>
+
+Same as C<COUNT(DISTINCT ?)>.
+
+=item Expression with C<?> in it
+
+The C<?> is substituted with the column name, then passed verbatim to the
+underlying C<SELECT> statement.
+
+=item Expression with C<(> in it
+
+The expression is passed verbatim to the underlying C<SELECT>.
+
+=item Any other expression
+
+The expression is taken to be a function name. For example, C<SUM> means
+the same thing as C<SUM(?)>.
+
+=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<Jifty::DBI::Collection>,
+you need to provide C<make test> with a test database. For each DBI
+driver that you would like to test, set the environment variables
+C<JDBI_TEST_FOO>, C<JDBI_TEST_FOO_USER>, and C<JDBI_TEST_FOO_PASS> 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<DBD::> module needs to be installed in
+order for the test to work.) Note that the C<SQLite> driver will
+automatically be tested if C<DBD::Sqlite> 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
+
--- /dev/null
+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<Jifty::DBI::Collection>
+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<Jifty::DBI::Collection> 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<Jifty::DBI::Collection::Union> 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<Jifty::DBI::Collection> object I<COLLECTION> 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</next>, 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<Jifty::DBI::Collection/goto_item>, 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<Jifty::DBI>, L<Jifty::DBI::Collection>
+
+=cut
+
+1;
+
+__END__
+
--- /dev/null
+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<SELECT DISTINCT> and ordering in the same
+statement; it drops the C<DISTINCT> requirement. This, of course, means
+that you can get the same row twice, which you might not want. If that's
+the case, use this module as a mix-in, and it will provide you with an
+C<AddRecord> method which ensures that a record will not appear twice in
+the same search.
+
+=head1 AUTHOR
+
+Simon Cozens.
+
+=head1 COPYRIGHT
+
+Copyright 2005 Best Practical Solutions, LLC
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+use warnings;
+use strict;
+
+package Jifty::DBI::Column;
+
+our $VERSION = '0.01';
+use base qw/Class::Accessor::Fast Jifty::DBI::HasFilters/;
+use UNIVERSAL::require;
+use version;
+
+
+
+our @ATTRS = qw/
+name
+ type
+ default
+ readable writable
+ max_length
+ mandatory
+ virtual
+ container
+ distinct
+ sort_order
+ refers_to by
+ alias_for_column
+ aliased_as
+ since till
+
+ label hints render_as
+ valid_values
+ available_values
+ indexed
+ autocompleted
+ _validator
+ _checked_for_validate_sub
+ record_class
+ /;
+
+__PACKAGE__->mk_accessors(@ATTRS);
+
+=head1 NAME
+
+Jifty::DBI::Column
+
+=head1 DESCRIPTION
+
+
+This class encapsulate's a single column in a Jifty::DBI::Record table
+description. It replaces the _accessible method in
+L<Jifty::DBI::Record>.
+
+It has the following accessors: C<name type default validator boolean
+refers_to readable writable length>.
+
+=cut
+
+=head2 is_numeric
+
+Returns true if the column is of some numeric type, otherwise returns false.
+
+=cut
+
+sub is_numeric {
+ my $self = shift;
+ if ( $self->type =~ /INT|NUMERIC|DECIMAL|REAL|DOUBLE|FLOAT/i ) {
+ return 1;
+ }
+ return 0;
+}
+
+
+
+=head2 is_string
+
+Returns true if this column is a text field
+
+=cut
+
+
+sub is_string {
+ my $self = shift;
+ if ( $self->type =~ /CHAR|TEXT/i ){
+ return 1;
+ }
+ return 0;
+}
+
+
+=head2 serialize_metadata
+
+Returns a hash describing this column object with enough detail to
+fully describe it in the database. Intentionally skips C<record_class>,
+all column attributes starting with C<_>, and all column attributes
+which are undefined.
+
+=cut
+
+sub serialize_metadata {
+ my $self = shift;
+ return {map { $_ => $self->$_() } grep { $_ ne 'record_class' && $_ !~ /^_/ && defined $self->$_} @ATTRS};
+
+
+}
+
+=head2 validator
+
+Gets/sets the validator coderef for the column.
+
+=cut
+
+sub validator {
+ my $self = shift;
+
+ if ( @_ ) {
+ $self->_validator( shift );
+ }
+ elsif ( not $self->_checked_for_validate_sub and not $self->_validator ) {
+ my $name = ( $self->aliased_as ? $self->aliased_as : $self->name );
+ my $can = $self->record_class->can( "validate_" . $name );
+
+ $self->_validator( $can ) if $can;
+ $self->_checked_for_validate_sub( 1 );
+ }
+
+ return $self->_validator;
+}
+
+# Aliases for compatibility with searchbuilder code
+*read = \&readable;
+*write = \&writable;
+
+=head2 length
+
+DEPRECATED. Use C<< $column->max_length >> instead.
+
+=head2 until
+
+DEPRECATED. Use C<< $column->till >> instead.
+
+=cut
+
+sub length { Carp::croak('$column->length is no longer supported; use $column->max_length instead') }
+sub until { Carp::croak('$column->until is no longer supported; use $column->till instead') }
+
+=head2 active
+
+Returns the a true value if the column method exists for the current application
+version. The current application version is determined by checking the L<Jifty::DBI::Record/schema_version> of the column's L</record_class>. This method returns a false value if the column is not yet been added or has been dropped.
+
+This method returns a false value under these circumstances:
+
+=over
+
+=item *
+
+Both the C<since> trait and C<schema_version> method are defined and C<schema_version> is less than the version set on C<since>.
+
+=item *
+
+Both the C<till> trait and C<schema_version> method are defined and C<schema_version> is greater than or equal to the version set on C<till>.
+
+=back
+
+Otherwise, this method returns true.
+
+=cut
+
+sub active {
+ my $self = shift;
+
+ return 1 unless $self->record_class->can('schema_version');
+ return 1 unless defined $self->record_class->schema_version;
+
+ my $version = version->new($self->record_class->schema_version);
+
+ # The application hasn't yet started using this column
+ return 0 if defined $self->since
+ and $version < version->new($self->since);
+
+ # The application stopped using this column
+ return 0 if defined $self->till
+ and $version >= version->new($self->till);
+
+ # The application currently uses this column
+ return 1;
+}
+
+1;
--- /dev/null
+use warnings;
+use strict;
+
+package Jifty::DBI::Filter;
+use base 'Class::Accessor::Fast';
+
+__PACKAGE__->mk_accessors(qw(record column value_ref));
+
+=head1 NAME
+
+Jifty::DBI::Filter - base class for Jifty::DBI filters
+
+=head1 SYNOPSIS
+
+ # To implement your own filter
+ package MyApp::Filter::Uppercase;
+ use base qw/ Jifty::DBI::Filter /;
+
+ # Setup for DB storage, store in lowercase
+ sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref; # don't blow up on undef
+
+ $$value_ref = lc $$value_ref;
+ }
+
+ # Setup for Perl code to use, always sees uppercase
+ sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref; # don't blow up on undef
+
+ $$value_ref = uc $$value_ref;
+ }
+
+ # To use a filter
+ use MyApp::Record schema {
+ column filtered =>
+ type is 'text',
+ filters are qw/ MyApp::Filter::Uppercase /;
+ };
+
+
+=head1 DESCRIPTION
+
+A filter allows Jifty::DBI models to tweak data prior to being stored and/or loaded. This is useful for marshalling and unmarshalling complex objects.
+
+=head1 METHODS
+
+=head2 new
+
+Takes two arguments in a parameter hash:
+
+=over
+
+=item value_ref
+
+A reference to the current value you're going to be
+massaging. C<encode> works in place, massaging whatever value_ref
+refers to.
+
+=item column
+
+A L<Jifty::DBI::Column> object, whatever sort of column we're working
+with here.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = (
+ column => undef,
+ value_ref => undef,
+ @_
+ );
+ my $self = {};
+ bless $self, $class;
+
+ for ( keys %args ) {
+ if ( $self->can($_) ) {
+ $self->$_( $args{$_} );
+ }
+
+ }
+
+ return ($self);
+
+}
+
+=head2 encode
+
+C<encode> takes data that users are handing to us and marshals it into
+a form suitable for sticking it in the database. This could be anything
+from flattening a L<DateTime> object into an ISO date to making sure
+that data is utf8 clean.
+
+=cut
+
+sub encode {
+
+}
+
+=head2 decode
+
+C<decode> takes data that the database is handing back to us and gets
+it into a form that's OK to hand back to the user. This could be
+anything from flattening a L<DateTime> object into an ISO date to
+making sure that data is utf8 clean.
+
+=cut
+
+sub decode {
+
+}
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter::Date>, L<Jifty::DBI::Filter::DateTime>, L<Jifty::DBI::Filter:SaltHash>, L<Jifty::DBI::Filter::Storable>, L<Jifty::DBI::Filter::Time>, L<Jifty::DBI::Filter::Truncate>, L<Jifty::DBI::Filter::YAML>, L<Jifty::DBI::Filter::base64>, L<Jifty::DBI::Filter::utf8>
+
+=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;
--- /dev/null
+package Jifty::DBI::Filter::Date;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter::DateTime|;
+
+use constant _time_zone => 'floating';
+use constant _strptime => '%Y-%m-%d';
+
+=head1 NAME
+
+Jifty::DBI::Filter::Date - DateTime object wrapper around date columns
+
+=head1 DESCRIPTION
+
+This filter allow you to work with DateTime objects that represent "Dates",
+store everything in the database in GMT and not hurt yourself badly
+when you pull them out and put them in repeatedly.
+
+=head2 encode
+
+If value is a DateTime object then move it into a "floating" timezone
+and expand it into ISO 8601 format C<YYYY-MM-DD>. By storing it in
+the database as a floating timezone, it doesn't matter if the user's
+desired timezone changes between lookups
+
+Does nothing if value is not defined or is a string.
+
+=cut
+
+=head2 decode
+
+If we're loading something from a column that doesn't specify times, then
+it's loaded into a floating timezone.
+
+If value is defined then converts it into DateTime object otherwise do
+nothing.
+
+=cut
+
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<DateTime>
+
+=cut
+
+1;
--- /dev/null
+package Jifty::DBI::Filter::DateTime;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter|;
+use DateTime ();
+use DateTime::Format::ISO8601 ();
+use DateTime::Format::Strptime ();
+use Carp ();
+
+use constant _time_zone => '';
+use constant _strptime => '%Y-%m-%d %H:%M:%S';
+
+
+=head1 NAME
+
+Jifty::DBI::Filter::DateTime - DateTime object wrapper around date columns
+
+=head1 DESCRIPTION
+
+This filter allow you to work with DateTime objects instead of
+plain text dates. If the column type is "date", then the hour,
+minute, and second information is discarded when encoding.
+
+=head2 encode
+
+If value is DateTime object then converts it into ISO format
+C<YYYY-MM-DD hh:mm:ss>. Does nothing if value is not defined.
+
+Sets the value to undef if the value is a string and doesn't match an ISO date (at least).
+
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+
+ return if !defined $$value_ref;
+
+ if ( ! UNIVERSAL::isa( $$value_ref, 'DateTime' )) {
+ if ( $$value_ref !~ /^\d{4}[ -]?\d{2}[ -]?[\d{2}]/) {
+ $$value_ref = undef;
+ }
+ return undef;
+ }
+
+ return unless $$value_ref;
+ if (my $tz = $self->_time_zone) {
+ $$value_ref = $$value_ref->clone;
+ $$value_ref->time_zone('floating');
+ }
+ $$value_ref = $$value_ref->strftime($self->_strptime);
+ return 1;
+}
+
+=head2 decode
+
+If value is defined then converts it into DateTime object otherwise do
+nothing.
+
+=cut
+
+sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+# XXX: Looks like we should use special modules for parsing DT because
+# different MySQL versions can return DT in different formats(none strict ISO)
+# Pg has also special format that depends on "european" and
+# server time_zone, by default ISO
+# other DBs may have own formats(Interbase for example can be forced to use special format)
+# but we need Jifty::DBI::Handle here to get DB type
+
+ my $str = join('T', split ' ', $$value_ref, 2);
+ my $dt;
+ eval { $dt = DateTime::Format::ISO8601->parse_datetime($str) };
+
+ if ($@) { # if datetime can't decode this, scream loudly with a useful error message
+ Carp::cluck($@);
+ return;
+ }
+
+ if ($dt) {
+ my $tz = $self->_time_zone;
+ $dt->time_zone($tz) if $tz;
+
+ $dt->set_formatter(DateTime::Format::Strptime->new(pattern => $self->_strptime));
+ $$value_ref = $dt;
+ } else {
+ return;
+ }
+}
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<DateTime>
+
+=cut
+
+1;
--- /dev/null
+package Jifty::DBI::Filter::SaltHash;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter|;
+use Digest::MD5 qw(md5_hex);
+
+=head1 NAME
+
+Jifty::DBI::Filter::SaltHash - salts and hashes a value before storing it
+
+=head1 DESCRIPTION
+
+This filter will generate a random 4-byte salt, and then MD5 the given
+value with the salt appended to the value. It will store the hash and
+the salt in the database, and return a data structure that contains
+both on decode. The salt and hash are stored in hexadecimal in the
+database, so that you can put them in a text field.
+
+This filter is intended for storing passwords in a database.
+
+=head2 encode
+
+Generate a random 4-byte salt, MD5 the value with the salt (encoded to
+hexadecimal) appended to it, and store both in the database.
+
+=cut
+
+sub encode {
+ my $self = shift;
+ my $value_ref = $self->value_ref;
+
+ return unless defined $$value_ref;
+
+ my $salt = generate_salt();
+
+ $$value_ref = md5_hex($$value_ref, $salt) . $salt;
+}
+
+=head2 generate_salt
+
+Return a random 4-byte salt value, encoded as an 8-character hex
+string.
+
+=cut
+
+sub generate_salt {
+ my $salt;
+ $salt .= unpack('H2',chr(int rand(255))) for(1..4);
+ return $salt;
+}
+
+=head2 decode
+
+Return an arrayref of (hash, salt), both as hex strings.
+
+To test whether a provided value is the same one originally encoded,
+use
+
+ $hash eq md5_hex($value . $salt);
+
+=cut
+
+sub decode {
+ my $self = shift;
+ my $value_ref = $self->value_ref;
+
+ return unless $$value_ref;
+
+ # This should never happen, but just to be safe
+ unless(length($$value_ref) == (8 + 32)) {
+ $$value_ref = [undef, undef];
+ } else {
+ $$value_ref = [unpack("A32A8", $$value_ref)];
+ }
+
+ return 1;
+}
+
+
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<Digest::MD5>
+
+=cut
+
+1;
--- /dev/null
+package Jifty::DBI::Filter::Storable;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter|;
+use Storable ();
+
+=head1 NAME
+
+Jifty::DBI::Filter::Storable - Encodes arbitrary data using Storable
+
+=head1 DESCRIPTION
+
+This filter allows you to store arbitrary Perl data structures in a
+column of type 'blob', using L<Storable> to serialize them.
+
+=head2 encode
+
+If value is defined, then encodes it using L<Storable/nfreeze>. Does
+nothing if value is not defined.
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ $Storable::Deparse = 1;
+ $$value_ref = Storable::nfreeze($value_ref);
+}
+
+=head2 decode
+
+If value is defined, then decodes it using L<Storable/thaw>, otherwise
+does nothing.
+
+=cut
+
+sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ # Storable doesn't take Unicode strings.
+ Encode::_utf8_off($$value_ref);
+
+ local $@;
+ $Storable::Eval = 1;
+ $$value_ref = eval { ${ Storable::thaw($$value_ref) } };
+}
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<Storable>
+
+=cut
+
+1;
--- /dev/null
+package Jifty::DBI::Filter::Time;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter::DateTime|;
+
+use constant _time_zone => 'floating';
+use constant _strptime => '%H:%M:%S';
+
+=head1 NAME
+
+Jifty::DBI::Filter::Date - DateTime object wrapper around date columns
+
+=head1 DESCRIPTION
+
+This filter allow you to work with DateTime objects that represent "Dates",
+store everything in the database in GMT and not hurt yourself badly
+when you pull them out and put them in repeatedly.
+
+=head2 encode
+
+If value is a DateTime object then move it into a "floating" timezone
+and expand it into ISO 8601 format C<HH-MM-SS>. By storing it in
+the database as a floating timezone, it doesn't matter if the user's
+desired timezone changes between lookups
+
+Does nothing if value is not defined or is a string.
+
+=cut
+
+=head2 decode
+
+If we're loading something from a column that doesn't specify times, then
+it's loaded into a floating timezone.
+
+If value is defined then converts it into DateTime object otherwise do
+nothing.
+
+=cut
+
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<DateTime>
+
+=cut
+
+1;
--- /dev/null
+
+use strict;
+use warnings;
+
+package Jifty::DBI::Filter::Truncate;
+use base qw/Jifty::DBI::Filter/;
+use Encode ();
+
+=head1 NAME
+
+Jifty::DBI::Filter::Truncate - Filter used to enforce max_length column trait
+
+=head1 DESCRIPTION
+
+You do not need to use this filter explicitly. This filter is used internally to enforce the L<Jifty::DBI::Schema/max_length> retrictions on columns:
+
+ column name =>
+ type is 'text',
+ max_length is 10;
+
+In this case, the filter would be automatically added to the column named C<name> and any value put into the column longer than 10 characters would be truncated to 10 characters.
+
+=head1 METHODS
+
+=head2 encode
+
+This method performs the work of performing truncation, when necessary.
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return undef unless ( defined($$value_ref) );
+
+ my $column = $self->column();
+
+ my $truncate_to;
+ if ( $column->max_length && !$column->is_numeric ) {
+ $truncate_to = $column->max_length;
+ } elsif ( $column->type && $column->type =~ /char\((\d+)\)/ ) {
+ $truncate_to = $1;
+ }
+
+ return unless ($truncate_to); # don't need to truncate
+
+ my $utf8 = Encode::is_utf8($$value_ref);
+ {
+ use bytes;
+ $$value_ref = substr( $$value_ref, 0, $truncate_to );
+ }
+ if ($utf8) {
+
+ # return utf8 flag back, but use Encode::FB_QUIET because
+ # we could broke tail char
+ $$value_ref = Encode::decode_utf8( $$value_ref, Encode::FB_QUIET );
+ }
+}
+
+=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;
--- /dev/null
+use strict;
+use warnings;
+
+package Jifty::DBI::Filter::YAML;
+use base qw/ Jifty::DBI::Filter /;
+
+my ($Dump, $Load);
+
+eval "use YAML::Syck ()";
+if ($@) {
+ use YAML ();
+ $Dump = \&YAML::Dump;
+ $Load = \&YAML::Load;
+}
+
+else {
+ $Dump = \&YAML::Syck::Dump;
+ $Load = \&YAML::Syck::Load;
+}
+
+=head1 NAME
+
+Jifty::DBI::Filter::YAML - This filter stores arbitrary Perl via YAML
+
+=head1 SYNOPSIS
+
+ use Jifty::DBI::Record schema {
+ column my_data =>
+ type is 'text',
+ filters are qw/ Jifty::DBI::Filter::YAML /;
+ };
+
+ my $thing = __PACKAGE__->new;
+ $thing->create( my_data => { foo => 'bar', baz => [ 1, 2, 3 ] } );
+
+ my $my_data = $thing->my_data;
+ while (my ($key, $value) = %$my_data) {
+ # do something...
+ }
+
+=head1 DESCRIPTION
+
+This filter provides the ability to store arbitrary data structures into a database column using L<YAML>. This is very similar to the L<Jifty::DBI::Filter::Storable> filter except that the L<YAML> format remains human-readable in the database. You can store virtually any Perl data, scalar, hash, array, or object into the database using this filter.
+
+In addition, YAML (at least the storage of scalars, hashes, and arrays) is compatible with data structures written in other languages, so you may store or read data between applications written in different languages.
+
+=head1 METHODS
+
+=head2 encode
+
+This method is used to encode the Perl data structure into YAML formatted text.
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ $$value_ref = $Dump->($$value_ref);
+}
+
+=head2 decode
+
+This method is used to decode the YAML formatted text from the database into the Perl data structure.
+
+=cut
+
+sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ $$value_ref = $Load->($$value_ref);
+}
+
+=head1 IMPLEMENTATION
+
+This class will attempt to use L<YAML::Syck> if it is available and then fall back upon L<YAML>. This has been done because the Syck library is written in C and is considerably faster.
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<YAML>, L<YAML::Syck>
+
+=head1 AUTHOR
+
+Andrew Sterling Hanenkamp E<lt>hanenkamp@cpan.orgE<gt>
+
+=head1 LICENSE
+
+This program is free software and may be modified or distributed under the same terms as Perl itself.
+
+=cut
+
+1
--- /dev/null
+package Jifty::DBI::Filter::base64;
+
+use warnings;
+use strict;
+
+use base qw|Jifty::DBI::Filter|;
+use MIME::Base64 ();
+
+=head1 NAME
+
+Jifty::DBI::Filter::base64 - Encodes data as base64
+
+=head1 DESCRIPTION
+
+This filter allow you to store arbitrary data in a column of type
+'text'.
+
+=head2 encode
+
+If value is defined, then encodes it using
+L<MIME::Base64/encode_base64>. Does nothing if value is not defined.
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ $$value_ref = MIME::Base64::encode_base64($$value_ref);
+
+ return 1;
+}
+
+=head2 decode
+
+If value is defined, then decodes it using
+L<MIME::Base64/decode_base64>, otherwise do nothing.
+
+=cut
+
+sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return unless defined $$value_ref;
+
+ $$value_ref = MIME::Base64::decode_base64($$value_ref);
+}
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<MIME::Base64>
+
+=cut
+
+1;
--- /dev/null
+
+use strict;
+use warnings;
+
+package Jifty::DBI::Filter::utf8;
+use base qw/Jifty::DBI::Filter/;
+use Encode ();
+
+=head1 NAME
+
+Jifty::DBI::Filter::utf8 - Jifty::DBI UTF-8 data filter
+
+=head1 DESCRIPTION
+
+This filter allow you to check that you operate with
+valid UTF-8 data.
+
+Usage as type specific filter is recommneded.
+
+=head1 METHODS
+
+=head2 encode
+
+Method always unset UTF-8 flag on the value, but
+if value doesn't have flag then method checks
+value for malformed UTF-8 data and stop on
+the first bad code.
+
+=cut
+
+sub encode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return undef unless ( defined($$value_ref) );
+
+ if ( Encode::is_utf8($$value_ref) ) {
+ $$value_ref = Encode::encode_utf8($$value_ref);
+ } else {
+
+ # if value has no utf8 flag but filter on the stack
+ # we do double encoding, and stop on the first bad characters
+ # with FB_QUIET fallback schema. We this schema because we
+ # don't want data grow
+ $$value_ref = Encode::encode_utf8(
+ Encode::decode_utf8( $$value_ref, Encode::FB_QUIET ) );
+ }
+ return 1;
+}
+
+=head2 decode
+
+Checks whether value is correct UTF-8 data or not and
+substitute all malformed data with 0xFFFD code point.
+
+Always set UTF-8 flag on the value.
+
+=cut
+
+sub decode {
+ my $self = shift;
+
+ my $value_ref = $self->value_ref;
+ return undef unless ( defined($$value_ref) );
+
+ unless ( Encode::is_utf8($$value_ref) ) {
+ $$value_ref = Encode::decode_utf8($$value_ref);
+ }
+ return 1;
+}
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+L<Jifty::DBI::Filter>, L<perlunicode>
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle;
+use strict;
+use Carp ();
+use DBI ();
+use Class::ReturnValue ();
+use Encode ();
+
+use base qw/Jifty::DBI::HasFilters/;
+
+use vars qw(%DBIHandle $PrevHandle $DEBUG $TRANSDEPTH);
+
+$TRANSDEPTH = 0;
+
+our $VERSION = '0.01';
+
+if (my $pattern = $ENV{JIFTY_DBQUERY_CALLER}) {
+ require Hook::LexWrap;
+ Hook::LexWrap::wrap('Jifty::DBI::Handle::simple_query', pre => sub {
+ return unless $_[1] =~ m/$pattern/;
+ warn $_[1].' '.join(',', @_[2..$#_])."\n";
+ Carp::cluck;
+ });
+}
+
+=head1 NAME
+
+Jifty::DBI::Handle - Perl extension which is a generic DBI handle
+
+=head1 SYNOPSIS
+
+ use Jifty::DBI::Handle;
+
+ my $handle = Jifty::DBI::Handle->new();
+ $handle->connect( driver => 'mysql',
+ database => 'dbname',
+ host => 'hostname',
+ user => 'dbuser',
+ password => 'dbpassword');
+ # now $handle isa Jifty::DBI::Handle::mysql
+
+=head1 DESCRIPTION
+
+This class provides a wrapper for DBI handles that can also perform a
+number of additional functions.
+
+=cut
+
+=head2 new
+
+Generic constructor
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless( $self, $class );
+
+ @{ $self->{'StatementLog'} } = ();
+ return $self;
+}
+
+=head2 connect PARAMHASH
+
+Takes a paramhash and connects to your DBI datasource, with the keys C<driver>,
+C<database>, C<host>, C<user> and C<password>.
+
+If you created the handle with
+ Jifty::DBI::Handle->new
+and there is a Jifty::DBI::Handle::(Driver) subclass for the driver you have chosen,
+the handle will be automatically "upgraded" into that subclass.
+
+=cut
+
+sub connect {
+ my $self = shift;
+
+ my %args = (
+ driver => undef,
+ database => undef,
+ host => undef,
+ sid => undef,
+ port => undef,
+ user => undef,
+ password => undef,
+ requiressl => undef,
+ @_
+ );
+
+ if ( $args{'driver'}
+ && !$self->isa( 'Jifty::DBI::Handle::' . $args{'driver'} ) )
+ {
+ if ( $self->_upgrade_handle( $args{'driver'} ) ) {
+ return ( $self->connect(%args) );
+ }
+ }
+
+ my $dsn = $self->dsn || '';
+
+# Setting this actually breaks old RT versions in subtle ways. So we need to explicitly call it
+
+ $self->build_dsn(%args);
+
+ # Only connect if we're not connected to this source already
+ if ( ( !$self->dbh ) || ( !$self->dbh->ping ) || ( $self->dsn ne $dsn ) )
+ {
+ my $handle
+ = DBI->connect( $self->dsn, $args{'user'}, $args{'password'} )
+ || Carp::croak "Connect Failed $DBI::errstr\n";
+
+#databases do case conversion on the name of columns returned.
+#actually, some databases just ignore case. this smashes it to something consistent
+ $handle->{FetchHashKeyName} = 'NAME_lc';
+
+ #Set the handle
+ $self->dbh($handle);
+
+ return (1);
+ }
+
+ return (undef);
+
+}
+
+=head2 _upgrade_handle DRIVER
+
+This private internal method turns a plain Jifty::DBI::Handle into one
+of the standard driver-specific subclasses.
+
+=cut
+
+sub _upgrade_handle {
+ my $self = shift;
+
+ my $driver = shift;
+ my $class = 'Jifty::DBI::Handle::' . $driver;
+
+ local $@;
+ eval "require $class";
+ return if $@;
+
+ bless $self, $class;
+ return 1;
+}
+
+=head2 build_dsn PARAMHASH
+
+Builds a dsn suitable for handing to DBI->connect.
+
+Mandatory arguments:
+
+=over
+
+=item driver
+
+=item database
+
+=back
+
+Optional arguments:
+
+=over
+
+=item host
+
+=item port
+
+=item sid
+
+=item requiressl
+
+=item and anything else your DBD lets you pass in
+
+=back
+
+=cut
+
+sub build_dsn {
+ my $self = shift;
+ my %args = (
+ driver => undef,
+ database => undef,
+ host => undef,
+ port => undef,
+ sid => undef,
+ requiressl => undef,
+ @_
+ );
+
+
+ my $driver = delete $args{'driver'};
+ $args{'dbname'} ||= delete $args{'database'};
+
+ $self->{'dsn'} =
+ "dbi:$driver:" . join(';', map { $_ ."=".$args{$_} } grep { defined $args{$_} } keys %args);
+}
+
+=head2 dsn
+
+Returns the dsn for this database connection.
+
+=cut
+
+sub dsn {
+ my $self = shift;
+ return ( $self->{'dsn'} );
+}
+
+=head2 raise_error [MODE]
+
+Turns on the Database Handle's RaiseError attribute.
+
+=cut
+
+sub raise_error {
+ my $self = shift;
+ $self->dbh->{RaiseError} = shift if (@_);
+ return $self->dbh->{RaiseError};
+}
+
+=head2 print_error [MODE]
+
+Turns on the Database Handle's PrintError attribute.
+
+=cut
+
+sub print_error {
+ my $self = shift;
+ $self->dbh->{PrintError} = shift if (@_);
+ return $self->dbh->{PrintError};
+}
+
+=head2 log_sql_statements BOOL
+
+Takes a boolean argument. If the boolean is true, it will log all SQL
+statements, as well as their invocation times and execution times.
+
+Returns whether we're currently logging or not as a boolean
+
+=cut
+
+sub log_sql_statements {
+ my $self = shift;
+ if (@_) {
+ require Time::HiRes;
+ $self->{'_dologsql'} = shift;
+ }
+ return ( $self->{'_dologsql'} );
+}
+
+=head2 _log_sql_statement STATEMENT DURATION
+
+add an SQL statement to our query log
+
+=cut
+
+sub _log_sql_statement {
+ my $self = shift;
+ my $statement = shift;
+ my $duration = shift;
+ my @bind = @_;
+ push @{ $self->{'StatementLog'} },
+ ( [ Time::HiRes::time(), $statement, [@bind], $duration ] );
+
+}
+
+=head2 clear_sql_statement_log
+
+Clears out the SQL statement log.
+
+=cut
+
+sub clear_sql_statement_log {
+ my $self = shift;
+ @{ $self->{'StatementLog'} } = ();
+}
+
+=head2 sql_statement_log
+
+Returns the current SQL statement log as an array of arrays. Each entry is a list of
+
+(Time, Statement, [Bindings], Duration)
+
+=cut
+
+sub sql_statement_log {
+ my $self = shift;
+ return ( @{ $self->{'StatementLog'} } );
+
+}
+
+=head2 auto_commit [MODE]
+
+Turns on the Database Handle's Autocommit attribute.
+
+=cut
+
+sub auto_commit {
+ my $self = shift;
+
+ my $mode = 1;
+ $mode = shift if (@_);
+
+ $self->dbh->{AutoCommit} = $mode;
+}
+
+=head2 disconnect
+
+disconnect from your DBI datasource
+
+=cut
+
+sub disconnect {
+ my $self = shift;
+ if ( $self->dbh ) {
+ return ( $self->dbh->disconnect() );
+ } else {
+ return;
+ }
+}
+
+=head2 dbh [HANDLE]
+
+Return the current DBI handle. If we're handed a parameter, make the database handle that.
+
+=cut
+
+sub dbh {
+ my $self = shift;
+
+ #If we are setting the database handle, set it.
+ $DBIHandle{$self} = $PrevHandle = shift if (@_);
+
+ return ( $DBIHandle{$self} ||= $PrevHandle );
+}
+
+=head2 delete $table_NAME @KEY_VALUE_PAIRS
+
+Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an DELETE statement and performs the delete. Returns the row_id of this row.
+
+=cut
+
+sub delete {
+ my ( $self, $table, @pairs ) = @_;
+
+ my @bind = ();
+ my $where = 'WHERE ';
+ while (my $key = shift @pairs) {
+ $where .= $key . "=?" . " AND ";
+ push( @bind, shift(@pairs) );
+ }
+
+ $where =~ s/AND $//;
+ my $query_string = "DELETE FROM " . $table . ' ' . $where;
+ $self->simple_query( $query_string, @bind );
+}
+
+=head2 insert $table_NAME @KEY_VALUE_PAIRS
+
+Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an INSERT statement and performs the insert. Returns the row_id of this row.
+
+=cut
+
+sub insert {
+ my ( $self, $table, @pairs ) = @_;
+ my ( @cols, @vals, @bind );
+
+#my %seen; #only the *first* value is used - allows drivers to specify default
+ while ( my $key = shift @pairs ) {
+ my $value = shift @pairs;
+
+ # next if $seen{$key}++;
+ push @cols, $key;
+ push @vals, '?';
+ push @bind, $value;
+ }
+
+ my $query_string = "INSERT INTO $table ("
+ . CORE::join( ", ", @cols )
+ . ") VALUES " . "("
+ . CORE::join( ", ", @vals ) . ")";
+
+ my $sth = $self->simple_query( $query_string, @bind );
+ return ($sth);
+}
+
+=head2 update_record_value
+
+Takes a hash with columns: C<table>, C<column>, C<value>, C<primary_keys>, and
+C<is_sql_function>. The first two should be obvious; C<value> is where you
+set the new value you want the column to have. The C<primary_keys> column should
+be the lvalue of Jifty::DBI::Record::PrimaryKeys(). Finally ,
+C<is_sql_function> is set when the Value is a SQL function. For example, you
+might have C<< value => 'PASSWORD(string)' >>, by setting C<is_sql_function> 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<short> 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<SELECT VERSION()>
+
+=cut
+
+sub database_version {
+ my $self = shift;
+ my %args = ( short => 1, @_ );
+
+ unless ( defined $self->{'database_version'} ) {
+
+ # turn off error handling, store old values to restore later
+ my $re = $self->raise_error;
+ $self->raise_error(0);
+ my $pe = $self->print_error;
+ $self->print_error(0);
+
+ my $statement = "SELECT VERSION()";
+ my $sth = $self->simple_query($statement);
+
+ my $ver = '';
+ $ver = ( $sth->fetchrow_arrayref->[0] || '' ) if $sth;
+ $ver =~ /(\d+(?:\.\d+)*(?:-[a-z0-9]+)?)/i;
+ $self->{'database_version'} = $ver;
+ $self->{'database_version_short'} = $1 || $ver;
+
+ $self->raise_error($re);
+ $self->print_error($pe);
+ }
+
+ return $self->{'database_version_short'} if $args{'short'};
+ return $self->{'database_version'};
+}
+
+=head2 case_sensitive
+
+Returns 1 if the current database's searches are case sensitive by default
+Returns undef otherwise
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (1);
+}
+
+=head2 _make_clause_case_insensitive column operator VALUE
+
+Takes a column, operator and value. performs the magic necessary to make
+your database treat this clause as case insensitive.
+
+Returns a column operator value triple.
+
+=cut
+
+sub _case_insensitivity_valid {
+ my $self = shift;
+ my $column = shift;
+ my $operator = shift;
+ my $value = shift;
+
+ return $value ne ''
+ && $value ne "''"
+ && ( $operator !~ /IS/ && $value !~ /^null$/i )
+ # don't downcase integer values
+ && $value !~ /^['"]?\d+['"]?$/;
+}
+
+sub _make_clause_case_insensitive {
+ my $self = shift;
+ my $column = shift;
+ my $operator = shift;
+ my $value = shift;
+
+ if ($self->_case_insensitivity_valid($column, $operator, $value)) {
+ $column = "lower($column)";
+ $value = "lower($value)";
+ }
+ return ( $column, $operator, $value );
+}
+
+=head2 begin_transaction
+
+Tells Jifty::DBI to begin a new SQL transaction. This will
+temporarily suspend Autocommit mode.
+
+Emulates nested transactions, by keeping a transaction stack depth.
+
+=cut
+
+sub begin_transaction {
+ my $self = shift;
+ $TRANSDEPTH++;
+ if ( $TRANSDEPTH > 1 ) {
+ return ($TRANSDEPTH);
+ } else {
+ return ( $self->dbh->begin_work );
+ }
+}
+
+=head2 commit
+
+Tells Jifty::DBI to commit the current SQL transaction.
+This will turn Autocommit mode back on.
+
+=cut
+
+sub commit {
+ my $self = shift;
+ unless ($TRANSDEPTH) {
+ Carp::confess(
+ "Attempted to commit a transaction with none in progress");
+ }
+ $TRANSDEPTH--;
+
+ if ( $TRANSDEPTH == 0 ) {
+ return ( $self->dbh->commit );
+ } else { #we're inside a transaction
+ return ($TRANSDEPTH);
+ }
+}
+
+=head2 rollback [FORCE]
+
+Tells Jifty::DBI to abort the current SQL transaction.
+This will turn Autocommit mode back on.
+
+If this method is passed a true argument, stack depth is blown away and the outermost transaction is rolled back
+
+=cut
+
+sub rollback {
+ my $self = shift;
+ my $force = shift;
+
+ my $dbh = $self->dbh;
+ unless ($dbh) {
+ $TRANSDEPTH = 0;
+ return;
+ }
+
+#unless ($TRANSDEPTH) {Carp::confess("Attempted to rollback a transaction with none in progress")};
+ if ($force) {
+ $TRANSDEPTH = 0;
+ return ( $dbh->rollback );
+ }
+
+ $TRANSDEPTH-- if ( $TRANSDEPTH >= 1 );
+ if ( $TRANSDEPTH == 0 ) {
+ return ( $dbh->rollback );
+ } else { #we're inside a transaction
+ return ($TRANSDEPTH);
+ }
+
+}
+
+=head2 force_rollback
+
+Force the handle to rollback. Whether or not we're deep in nested transactions
+
+=cut
+
+sub force_rollback {
+ my $self = shift;
+ $self->rollback(1);
+}
+
+=head2 transaction_depth
+
+Return the current depth of the faked nested transaction stack.
+
+=cut
+
+sub transaction_depth {
+ my $self = shift;
+ return ($TRANSDEPTH);
+}
+
+=head2 apply_limits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
+
+takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW;
+
+
+=cut
+
+sub apply_limits {
+ my $self = shift;
+ my $statementref = shift;
+ my $per_page = shift;
+ my $first = shift;
+
+ my $limit_clause = '';
+
+ if ($per_page) {
+ $limit_clause = " LIMIT ";
+ if ($first) {
+ $limit_clause .= $first . ", ";
+ }
+ $limit_clause .= $per_page;
+ }
+
+ $$statementref .= $limit_clause;
+
+}
+
+=head2 join { Paramhash }
+
+Takes a paramhash of everything Jifty::DBI::Collection's C<join> method
+takes, plus a parameter called C<collection> that contains a ref to a
+L<Jifty::DBI::Collection> object'.
+
+This performs the join.
+
+
+=cut
+
+sub join {
+
+ my $self = shift;
+ my %args = (
+ collection => undef,
+ type => 'normal',
+ alias1 => 'main',
+ column1 => undef,
+ table2 => undef,
+ alias2 => undef,
+ column2 => undef,
+ expression => undef,
+ operator => '=',
+ @_
+ );
+
+ my $alias;
+
+ #If we're handed in an alias2, we need to go remove it from the
+ # Aliases array. Basically, if anyone generates an alias and then
+ # tries to use it in a join later, we want to be smart about creating
+ # joins, so we need to go rip it out of the old aliases table and drop
+ # it in as an explicit join
+ if ( $args{'alias2'} ) {
+
+ # this code is slow and wasteful, but it's clear.
+ my @aliases = @{ $args{'collection'}->{'aliases'} };
+ my @new_aliases;
+ foreach my $old_alias (@aliases) {
+ if ( $old_alias =~ /^(.*?) (\Q$args{'alias2'}\E)$/ ) {
+ $args{'table2'} = $1;
+ $alias = $2;
+
+ } else {
+ push @new_aliases, $old_alias;
+ }
+ }
+
+# If we found an alias, great. let's just pull out the table and alias for the other item
+ unless ($alias) {
+
+ # if we can't do that, can we reverse the join and have it work?
+ my $a1 = $args{'alias1'};
+ my $f1 = $args{'column1'};
+ $args{'alias1'} = $args{'alias2'};
+ $args{'column1'} = $args{'column2'};
+ $args{'alias2'} = $a1;
+ $args{'column2'} = $f1;
+
+ @aliases = @{ $args{'collection'}->{'aliases'} };
+ @new_aliases = ();
+ foreach my $old_alias (@aliases) {
+ if ( $old_alias =~ /^(.*?) ($args{'alias2'})$/ ) {
+ $args{'table2'} = $1;
+ $alias = $2;
+
+ } else {
+ push @new_aliases, $old_alias;
+ }
+ }
+
+ }
+
+ unless ( $alias ) {
+ return $self->_normal_join(%args);
+ }
+
+ $args{'collection'}->{'aliases'} = \@new_aliases;
+ }
+
+ else {
+ $alias = $args{'collection'}->_get_alias( $args{'table2'} );
+
+ }
+
+ my $meta = $args{'collection'}->{'leftjoins'}{ $alias } ||= {};
+ if ( $args{'type'} =~ /LEFT/i ) {
+ $meta->{'alias_string'} = " LEFT JOIN " . $args{'table2'} . " $alias ";
+ $meta->{'type'} = 'LEFT';
+
+ } else {
+ $meta->{'alias_string'} = " JOIN " . $args{'table2'} . " $alias ";
+ $meta->{'type'} = 'NORMAL';
+ }
+ $meta->{'depends_on'} = $args{'alias1'};
+ $meta->{'entry_aggregator'} = $args{'entry_aggregator'}
+ if $args{'entry_aggregator'};
+
+ my $criterion = $args{'expression'} || "$args{'alias1'}.$args{'column1'}";
+ $meta->{'criteria'}{ 'base_criterion' } = [{
+ column => $criterion,
+ operator => $args{'operator'},
+ value => "$alias.$args{'column2'}",
+ }];
+
+ return ($alias);
+}
+
+sub _normal_join {
+
+ my $self = shift;
+ my %args = (
+ collection => undef,
+ type => 'normal',
+ column1 => undef,
+ alias1 => undef,
+ table2 => undef,
+ column2 => undef,
+ alias2 => undef,
+ operator => '=',
+ @_
+ );
+
+ my $sb = $args{'collection'};
+
+ if ( $args{'type'} =~ /LEFT/i ) {
+ my $alias = $sb->_get_alias( $args{'table2'} );
+ my $meta = $sb->{'leftjoins'}{ $alias } ||= {};
+ $meta->{'alias_string'} = " LEFT JOIN $args{'table2'} $alias ";
+ $meta->{'depends_on'} = $args{'alias1'};
+ $meta->{'type'} = 'LEFT';
+ $meta->{'base_criterion'} = [ {
+ column => "$args{'alias1'}.$args{'column1'}",
+ operator => $args{'operator'},
+ value => "$alias.$args{'column2'}",
+ } ];
+
+ return ($alias);
+ } else {
+ $sb->Jifty::DBI::Collection::limit(
+ entry_aggregator => 'AND',
+ @_,
+ quote_value => 0,
+ alias => $args{'alias1'},
+ column => $args{'column1'},
+ value => $args{'alias2'} . "." . $args{'column2'},
+ );
+ }
+}
+
+# this code is all hacky and evil. but people desperately want _something_ and I'm
+# super tired. refactoring gratefully appreciated.
+
+sub _build_joins {
+ my $self = shift;
+ my $sb = shift;
+
+ $self->_optimize_joins( collection => $sb );
+
+ my $join_clause = CORE::join " CROSS JOIN ", ($sb->table ." main"), @{ $sb->{'aliases'} };
+ my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $sb->{'aliases'} };
+ $processed{'main'} = 1;
+
+ # get a @list of joins that have not been processed yet, but depend on processed join
+ my $joins = $sb->{'leftjoins'};
+ while ( my @list = grep !$processed{ $_ }
+ && $processed{ $joins->{ $_ }{'depends_on'} }, keys %$joins )
+ {
+ foreach my $join ( @list ) {
+ $processed{ $join }++;
+
+ my $meta = $joins->{ $join };
+ my $aggregator = $meta->{'entry_aggregator'} || 'AND';
+
+ $join_clause .= $meta->{'alias_string'} . " ON ";
+ my @tmp = map {
+ ref($_)?
+ $_->{'column'} .' '. $_->{'operator'} .' '. $_->{'value'}:
+ $_
+ }
+ map { ('(', @$_, ')', $aggregator) } values %{ $meta->{'criteria'} };
+ # delete last aggregator
+ pop @tmp;
+ $join_clause .= CORE::join ' ', @tmp;
+ }
+ }
+
+ # here we could check if there is recursion in joins by checking that all joins
+ # are processed
+ if ( my @not_processed = grep !$processed{ $_ }, keys %$joins ) {
+ die "Unsatisfied dependency chain in joins @not_processed";
+ }
+ return $join_clause;
+}
+
+sub _optimize_joins {
+ my $self = shift;
+ my %args = ( collection => undef, @_ );
+ my $joins = $args{'collection'}->{'leftjoins'};
+
+ my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $args{'collection'}->{'aliases'} };
+ $processed{ $_ }++ foreach grep $joins->{ $_ }{'type'} ne 'LEFT', keys %$joins;
+ $processed{'main'}++;
+
+ my @ordered;
+ # get a @list of joins that have not been processed yet, but depend on processed join
+ # if we are talking about forest then we'll get the second level of the forest,
+ # but we should process nodes on this level at the end, so we build FILO ordered list.
+ # finally we'll get ordered list with leafes in the beginning and top most nodes at
+ # the end.
+ while ( my @list = grep !$processed{ $_ }
+ && $processed{ $joins->{ $_ }{'depends_on'} }, keys %$joins )
+ {
+ unshift @ordered, @list;
+ $processed{ $_ }++ foreach @list;
+ }
+
+ foreach my $join ( @ordered ) {
+ next if $self->may_be_null( collection => $args{'collection'}, alias => $join );
+
+ $joins->{ $join }{'alias_string'} =~ s/^\s*LEFT\s+/ /i;
+ $joins->{ $join }{'type'} = 'NORMAL';
+ }
+
+}
+
+=head2 may_be_null
+
+Takes a C<collection> and C<alias> in a hash and returns
+true if restrictions of the query allow NULLs in a table joined with
+the alias, otherwise returns false value which means that you can
+use normal join instead of left for the aliased table.
+
+Works only for queries have been built with L<Jifty::DBI::Collection/join> and
+L<Jifty::DBI::Collection/limit> methods, for other cases return true value to
+avoid fault optimizations.
+
+=cut
+
+sub may_be_null {
+ my $self = shift;
+ my %args = (collection => undef, alias => undef, @_);
+ # if we have at least one subclause that is not generic then we should get out
+ # of here as we can't parse subclauses
+ return 1 if grep $_ ne 'generic_restrictions', keys %{ $args{'collection'}->{'subclauses'} };
+
+ # build full list of generic conditions
+ my @conditions;
+ foreach ( grep @$_, values %{ $args{'collection'}->{'restrictions'} } ) {
+ push @conditions, 'AND' if @conditions;
+ push @conditions, '(', @$_, ')';
+ }
+
+ # find tables that depends on this alias and add their join conditions
+ foreach my $join ( values %{ $args{'collection'}->{'leftjoins'} } ) {
+ # left joins on the left side so later we'll get 1 AND x expression
+ # which equal to x, so we just skip it
+ next if $join->{'type'} eq 'LEFT';
+ next unless $join->{'depends_on'} eq $args{'alias'};
+
+ my @tmp = map { ('(', @$_, ')', $join->{'entry_aggregator'}) } values %{ $join->{'criteria'} };
+ pop @tmp;
+
+ @conditions = ('(', @conditions, ')', 'AND', '(', @tmp ,')');
+
+ }
+ return 1 unless @conditions;
+
+ # replace conditions with boolean result: 1 - allow nulls, 0 - doesn't
+ foreach ( splice @conditions ) {
+ unless ( ref $_ ) {
+ push @conditions, $_;
+ } elsif ( $_->{'column'} =~ /^\Q$args{'alias'}./ ) {
+ # only operator IS allows NULLs in the aliased table
+ push @conditions, lc $_->{'operator'} eq 'is';
+ } elsif ( $_->{'value'} && $_->{'value'} =~ /^\Q$args{'alias'}./ ) {
+ # right operand is our alias, such condition don't allow NULLs
+ push @conditions, 0;
+ } else {
+ # conditions on other aliases
+ push @conditions, 1;
+ }
+ }
+
+ # returns index of closing paren by index of openning paren
+ my $closing_paren = sub {
+ my $i = shift;
+ my $count = 0;
+ for ( ; $i < @conditions; $i++ ) {
+ if ( $conditions[$i] eq '(' ) {
+ $count++;
+ }
+ elsif ( $conditions[$i] eq ')' ) {
+ $count--;
+ }
+ return $i unless $count;
+ }
+ die "lost in parens";
+ };
+
+ # solve boolean expression we have, an answer is our result
+ my @tmp = ();
+ while ( defined ( my $e = shift @conditions ) ) {
+ #warn "@tmp >>>$e<<< @conditions";
+ return $e if !@conditions && !@tmp;
+
+ unless ( $e ) {
+ if ( $conditions[0] eq ')' ) {
+ push @tmp, $e;
+ next;
+ }
+
+ my $aggreg = uc shift @conditions;
+ if ( $aggreg eq 'OR' ) {
+ # 0 OR x == x
+ next;
+ } elsif ( $aggreg eq 'AND' ) {
+ # 0 AND x == 0
+ my $close_p = $closing_paren->(0);
+ splice @conditions, 0, $close_p + 1, (0);
+ } else {
+ die "lost @tmp >>>$e $aggreg<<< @conditions";
+ }
+ } elsif ( $e eq '1' ) {
+ if ( $conditions[0] eq ')' ) {
+ push @tmp, $e;
+ next;
+ }
+
+ my $aggreg = uc shift @conditions;
+ if ( $aggreg eq 'OR' ) {
+ # 1 OR x == 1
+ my $close_p = $closing_paren->(0);
+ splice @conditions, 0, $close_p + 1, (1);
+ } elsif ( $aggreg eq 'AND' ) {
+ # 1 AND x == x
+ next;
+ } else {
+ die "lost @tmp >>>$e $aggreg<<< @conditions";
+ }
+ } elsif ( $e eq '(' ) {
+ if ( $conditions[1] eq ')' ) {
+ splice @conditions, 1, 1;
+ } else {
+ push @tmp, $e;
+ }
+ } elsif ( $e eq ')' ) {
+ unshift @conditions, @tmp, $e;
+ @tmp = ();
+ } else {
+ die "lost: @tmp >>>$e<<< @conditions";
+ }
+ }
+ return 1;
+}
+
+=head2 distinct_query STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
+
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+
+ # Prepend select query for DBs which allow DISTINCT on all column types.
+ $$statementref = "SELECT DISTINCT ".$sb->_preload_columns." FROM $$statementref";
+
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+}
+
+=head2 distinct_count STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
+
+
+=cut
+
+sub distinct_count {
+ my $self = shift;
+ my $statementref = shift;
+
+ # Prepend select query for DBs which allow DISTINCT on all column types.
+ $$statementref = "SELECT COUNT(DISTINCT main.id) FROM $$statementref";
+
+}
+
+=head2 log MESSAGE
+
+Takes a single argument, a message to log.
+
+Currently prints that message to STDERR
+
+=cut
+
+sub log {
+ my $self = shift;
+ my $msg = shift;
+ warn $msg . "\n";
+
+}
+
+=head2 DESTROY
+
+When we get rid of the L<Jifty::DBI::Handle>, we need to disconnect
+from the database
+
+=cut
+
+sub DESTROY {
+ my $self = shift;
+ $self->disconnect;
+ delete $DBIHandle{$self};
+}
+
+1;
+__END__
+
+
+=head1 DIAGNOSIS
+
+Setting C<JIFTY_DBQUERY_CALLER> environment variable will make
+L<Jifty::DBI> dump the caller for the SQL queries matching it. See
+also C<DBI> about setting C<DBI_PROFILE>.
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse@fsck.com
+
+=head1 SEE ALSO
+
+perl(1), L<Jifty::DBI>
+
+=cut
+
--- /dev/null
+# $Header: $
+
+package Jifty::DBI::Handle::Informix;
+use Jifty::DBI::Handle;
+@ISA = qw(Jifty::DBI::Handle);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::Informix - An Informix specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of Jifty::DBI::Handle that
+compensates for some of the idiosyncrasies of Informix.
+
+=head1 METHODS
+
+=cut
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted.
+
+If the insert succeeds, returns the id of the insert, otherwise, returns
+a Class::ReturnValue object with the error reported.
+
+=cut
+
+sub insert {
+ my $self = shift;
+
+ my $sth = $self->SUPER::insert(@_);
+ if ( !$sth ) {
+ print "no sth! (" . $self->dbh->{ix_sqlerrd}[1] . ")\n";
+ return ($sth);
+ }
+
+ $self->{id} = $self->dbh->{ix_sqlerrd}[1];
+ warn "$self no row id returned on row creation" unless ( $self->{'id'} );
+ return ( $self->{'id'} ); #Add Succeded. return the id
+}
+
+=head2 case_sensitive
+
+Returns 1, since Informix's searches are case sensitive by default
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (1);
+}
+
+=head2 apply_limits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
+
+takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW;
+
+
+=cut
+
+sub apply_limits {
+ my $self = shift;
+ my $statementref = shift;
+ my $per_page = shift;
+ my $first = shift;
+
+ # XXX TODO THIS only works on the FIRST page of results. that's a bug
+ if ($per_page) {
+ $$statementref =~ s[^\s*SELECT][SELECT FIRST $per_page]i;
+ }
+}
+
+=head2 disconnect
+
+Disconnects and completely unreferences the handle for Informix.
+
+=cut
+
+sub disconnect {
+ my $self = shift;
+ if ( $self->dbh ) {
+ my $status = $self->dbh->disconnect();
+ $self->dbh(undef);
+ return $status;
+ } else {
+ return;
+ }
+}
+
+=head2 distinct_query STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
+
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+ my $table = $sb->table;
+
+ if ( $sb->_order_clause =~ /(?<!main)\./ ) {
+
+ # Don't know how to do ORDER BY when the DISTINCT is in a subquery
+ warn
+ "Query will contain duplicate rows; don't how how to ORDER BY across DISTINCT";
+ $$statementref = "SELECT main.* FROM $$statementref";
+ } else {
+
+ # Wrapper select query in a subselect as Informix doesn't allow
+ # DISTINCT against CLOB/BLOB column types.
+ $$statementref
+ = "SELECT * FROM $table main WHERE id IN ( SELECT DISTINCT main.id FROM $$statementref )";
+ }
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Oliver Tappe, oliver@akso.de
+
+=head1 SEE ALSO
+
+perl(1), Jifty::DBI
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle::ODBC;
+use Jifty::DBI::Handle;
+@ISA = qw(Jifty::DBI::Handle);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::ODBC - An ODBC specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of L<Jifty::DBI::Handle> that
+compensates for some of the idiosyncrasies of ODBC.
+
+=head1 METHODS
+
+=cut
+
+=head2 case_sensitive
+
+Returns a false value.
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (undef);
+}
+
+=head2 build_dsn
+
+=cut
+
+sub build_dsn {
+ my $self = shift;
+ my %args = (
+ driver => undef,
+ database => undef,
+ host => undef,
+ port => undef,
+ @_
+ );
+
+ $args{dbname} ||= delete $args{database};
+
+ my $dsn = "dbi:$args{driver}:$args{dbname}";
+ $dsn .= ";host=$args{'host'}" if $args{'host'};
+ $dsn .= ";port=$args{'port'}" if $args{'port'};
+
+ $self->{'dsn'} = $dsn;
+}
+
+=head2 apply_limits
+
+=cut
+
+sub apply_limits {
+ my $self = shift;
+ my $statementref = shift;
+ my $per_page = shift or return;
+ my $first = shift;
+
+ my $limit_clause = " TOP $per_page";
+ $limit_clause .= " OFFSET $first" if $first;
+ $$statementref =~ s/SELECT\b/SELECT $limit_clause/;
+}
+
+=head2 distinct_query
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+
+ my $sb = shift;
+
+ $$statementref = "SELECT main.* FROM $$statementref";
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+}
+
+=head2 encoding
+
+=cut
+
+sub encoding {
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Audrey Tang C<cpan@audreyt.org>
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Handle>, L<DBD::ODBC>
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle::Oracle;
+use base qw/Jifty::DBI::Handle/;
+use DBD::Oracle qw(:ora_types ORA_OCI);
+
+use vars qw($VERSION $DBIHandle $DEBUG);
+
+=head1 NAME
+
+ Jifty::DBI::Handle::Oracle - An oracle specific Handle object
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This module provides a subclass of L<Jifty::DBI::Handle> that
+compensates for some of the idiosyncrasies of Oracle.
+
+=head1 METHODS
+
+=head2 connect PARAMHASH: Driver, Database, Host, User, Password
+
+Takes a paramhash and connects to your DBI datasource.
+
+=cut
+
+sub connect {
+ my $self = shift;
+
+ my %args = (
+ driver => undef,
+ database => undef,
+ user => undef,
+ password => undef,
+ sid => undef,
+ host => undef,
+ @_
+ );
+
+ $self->SUPER::connect(%args);
+
+ $self->dbh->{LongTruncOk} = 1;
+ $self->dbh->{LongReadLen} = 8000;
+
+ $self->simple_query(
+ "ALTER SESSION set NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'");
+
+ return ($DBIHandle);
+}
+
+=head2 database_version
+
+Returns value of ORA_OCI constant, see L<DBD::Oracle/Constants>.
+
+=cut
+
+sub database_version {
+ return ''. ORA_OCI;
+}
+
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of
+the arguments are an array of key-value pairs to be inserted.
+
+=cut
+
+sub insert {
+ my $self = shift;
+ my $table = shift;
+ my ($sth);
+
+ # Oracle Hack to replace non-supported mysql_rowid call
+
+ my %attribs = @_;
+ my ( $unique_id, $query_string );
+
+ if ( $attribs{'Id'} || $attribs{'id'} ) {
+ $unique_id = ( $attribs{'Id'} ? $attribs{'Id'} : $attribs{'id'} );
+ } else {
+
+ $query_string = "SELECT " . $table . "_seq.nextval FROM DUAL";
+
+ $sth = $self->simple_query($query_string);
+ if ( !$sth ) {
+ if ($main::debug) {
+ die "Error with $query_string";
+ } else {
+ return (undef);
+ }
+ }
+
+ #needs error checking
+ my @row = $sth->fetchrow_array;
+
+ $unique_id = $row[0];
+
+ }
+
+ #TODO: don't hardcode this to id pull it from somewhere else
+ #call super::insert with the new column id.
+
+ $attribs{'id'} = $unique_id;
+ delete $attribs{'Id'};
+ $sth = $self->SUPER::insert( $table, %attribs );
+
+ unless ($sth) {
+ if ($main::debug) {
+ die "Error with $query_string: " . $self->dbh->errstr;
+ } else {
+ return (undef);
+ }
+ }
+
+ $self->{'id'} = $unique_id;
+ return ( $self->{'id'} ); #Add Succeded. return the id
+}
+
+=head2 build_dsn PARAMHASH
+
+Takes a bunch of parameters:
+
+Required: Driver, Database or Host/SID,
+Optional: Port and RequireSSL
+
+Builds a dsn suitable for an Oracle DBI connection
+
+=cut
+
+sub build_dsn {
+ my $self = shift;
+ my %args = (
+ driver => undef,
+ database => undef,
+ host => undef,
+ port => undef,
+ sid => undef,
+ requiressl => undef,
+ @_
+ );
+
+ my $dsn = "dbi:$args{'driver'}:";
+
+ if ( defined $args{'host'}
+ && $args{'host'}
+ && defined $args{'sid'}
+ && $args{'sid'} )
+ {
+ $dsn .= "host=$args{'host'};sid=$args{'sid'}";
+ } else {
+ $dsn .= "$args{'database'}"
+ if ( defined $args{'database'} && $args{'database'} );
+ }
+ $dsn .= ";port=$args{'port'}"
+ if ( defined $args{'port'} && $args{'port'} );
+ $dsn .= ";requiressl=1"
+ if ( defined $args{'requiressl'} && $args{'requiressl'} );
+
+ $self->{'dsn'} = $dsn;
+}
+
+=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. The current
+Oracle implementation only supports ORA_CLOB types (112).
+
+=cut
+
+sub blob_params {
+ my $self = shift;
+ my $column = shift;
+
+ # Don't assign to key 'value' as it is defined later.
+ return (
+ { ora_column => $column,
+ ora_type => ORA_CLOB,
+ }
+ );
+}
+
+=head2 apply_limits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
+
+takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE
+starting with FIRST_ROW;
+
+=cut
+
+sub apply_limits {
+ my $self = shift;
+ my $statementref = shift;
+ my $per_page = shift;
+ my $first = shift;
+
+ # Transform an SQL query from:
+ #
+ # SELECT main.*
+ # FROM Tickets main
+ # WHERE ((main.EffectiveId = main.id))
+ # AND ((main.Type = 'ticket'))
+ # AND ( ( (main.Status = 'new')OR(main.Status = 'open') )
+ # AND ( (main.Queue = '1') ) )
+ #
+ # to:
+ #
+ # SELECT * FROM (
+ # SELECT limitquery.*,rownum limitrownum FROM (
+ # SELECT main.*
+ # FROM Tickets main
+ # WHERE ((main.EffectiveId = main.id))
+ # AND ((main.Type = 'ticket'))
+ # AND ( ( (main.Status = 'new')OR(main.Status = 'open') )
+ # AND ( (main.Queue = '1') ) )
+ # ) limitquery WHERE rownum <= 50
+ # ) WHERE limitrownum >= 1
+ #
+
+ if ($per_page) {
+
+ # Oracle orders from 1 not zero
+ $first++;
+
+ # Make current query a sub select
+ $$statementref
+ = "SELECT * FROM ( SELECT limitquery.*,rownum limitrownum FROM ( $$statementref ) limitquery WHERE rownum <= "
+ . ( $first + $per_page - 1 )
+ . " ) WHERE limitrownum >= "
+ . $first;
+ }
+}
+
+=head2 distinct_query STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a
+DISTINCT result set.
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+ my $table = $sb->Table;
+
+ # Wrapp select query in a subselect as Oracle doesn't allow
+ # DISTINCT against CLOB/BLOB column types.
+ if ( $sb->_order_clause =~ /(?<!main)\./ ) {
+
+ # If we are ordering by something not in 'main', we need to GROUP
+ # BY and adjust the ORDER_BY accordingly
+ local $sb->{group_by}
+ = [ @{ $sb->{group_by} || [] }, { column => 'id' } ];
+ local $sb->{order_by} = [
+ map {
+ ( $_->{alias} and $_->{alias} ne "main" )
+ ? { %{$_}, column => "min(" . $_->{column} . ")" }
+ : $_
+ } @{ $sb->{order_by} }
+ ];
+ my $group = $sb->_group_clause;
+ my $order = $sb->_order_clause;
+ $$statementref
+ = "SELECT main.* FROM ( SELECT main.id FROM $$statementref $group $order ) distinctquery, $table main WHERE (main.id = distinctquery.id)";
+ } else {
+ $$statementref
+ = "SELECT main.* FROM ( SELECT DISTINCT main.id FROM $$statementref ) distinctquery, $table main WHERE (main.id = distinctquery.id) ";
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+ }
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse@fsck.com
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Handle>, L<DBD::Oracle>
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle::Pg;
+use strict;
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use base qw(Jifty::DBI::Handle);
+
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::Pg - A Postgres specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of L<Jifty::DBI::Handle> that
+compensates for some of the idiosyncrasies of Postgres.
+
+=head1 METHODS
+
+=cut
+
+=head2 connect
+
+connect takes a hashref and passes it off to SUPER::connect; Forces
+the timezone to GMT, returns a database handle.
+
+=cut
+
+sub connect {
+ my $self = shift;
+
+ $self->SUPER::connect(@_);
+ $self->simple_query("SET TIME ZONE 'GMT'");
+ $self->simple_query("SET DATESTYLE TO 'ISO'");
+ $self->auto_commit(1);
+ return ($DBIHandle);
+}
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of
+the arguments are an array of key-value pairs to be inserted.
+
+In case of insert failure, returns a L<Class::ReturnValue> object
+preloaded with error info
+
+=cut
+
+sub insert {
+ my $self = shift;
+ my $table = shift;
+ my %args = (@_);
+ my $sth = $self->SUPER::insert( $table, %args );
+
+ unless ($sth) {
+ return ($sth);
+ }
+
+ if ( $args{'id'} || $args{'Id'} ) {
+ $self->{'id'} = $args{'id'} || $args{'Id'};
+ return ( $self->{'id'} );
+ }
+
+ my $sequence_name = $self->id_sequence_name($table);
+ unless ($sequence_name) { return ($sequence_name) } # Class::ReturnValue
+ my $seqsth = $self->dbh->prepare(
+ qq{SELECT CURRVAL('} . $sequence_name . qq{')} );
+ $seqsth->execute;
+ $self->{'id'} = $seqsth->fetchrow_array();
+
+ return ( $self->{'id'} );
+}
+
+=head2 id_sequence_name TABLE
+
+Takes a TABLE name and returns the name of the sequence of the primary key for that table.
+
+=cut
+
+sub id_sequence_name {
+ my $self = shift;
+ my $table = shift;
+
+ return $self->{'_sequences'}{$table}
+ if ( exists $self->{'_sequences'}{$table} );
+
+ #Lets get the id of that row we just inserted
+ my $seq;
+ my $colinfosth = $self->dbh->column_info( undef, undef, lc($table), '%' );
+ while ( my $foo = $colinfosth->fetchrow_hashref ) {
+
+ # Regexp from DBIx::Class's Pg handle. Thanks to Marcus Ramberg
+ if ( defined $foo->{'COLUMN_DEF'}
+ && $foo->{'COLUMN_DEF'}
+ =~ m!^nextval\(+'"?([^"']+)"?'(::(?:text|regclass)\))+!i )
+ {
+ return $self->{'_sequences'}{$table} = $1;
+ }
+
+ }
+ my $ret = Class::ReturnValue->new();
+ $ret->as_error(
+ errno => '-1',
+ message => "Found no sequence for $table",
+ do_backtrace => undef
+ );
+ return ( $ret->return_value );
+
+}
+
+=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. The current
+Postgres implementation only supports BYTEA types.
+
+=cut
+
+sub blob_params {
+ my $self = shift;
+ my $name = shift;
+ my $type = shift;
+
+ # Don't assign to key 'value' as it is defined later.
+ return ( { pg_type => DBD::Pg::PG_BYTEA() } ) if $type =~ /^(?:blob|bytea)$/;
+ return ( {} );
+}
+
+=head2 apply_limits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
+
+takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE
+starting with FIRST_ROW;
+
+=cut
+
+sub apply_limits {
+ my $self = shift;
+ my $statementref = shift;
+ my $per_page = shift;
+ my $first = shift;
+
+ my $limit_clause = '';
+
+ if ($per_page) {
+ $limit_clause = " LIMIT ";
+ $limit_clause .= $per_page;
+ if ( $first && $first != 0 ) {
+ $limit_clause .= " OFFSET $first";
+ }
+ }
+
+ $$statementref .= $limit_clause;
+
+}
+
+=head2 _make_clause_case_insensitive column operator VALUE
+
+Takes a column, operator and value. performs the magic necessary to make
+your database treat this clause as case insensitive.
+
+Returns a column operator value triple.
+
+=cut
+
+sub _make_clause_case_insensitive {
+ my $self = shift;
+ my $column = shift;
+ my $operator = shift;
+ my $value = shift;
+
+ if ($self->_case_insensitivity_valid($column, $operator, $value)) {
+ if ( $operator =~ /(?:LIKE|=)/i ) {
+ $column = "LOWER($column)";
+ $value = "LOWER($value)";
+ }
+ }
+ return ( $column, $operator, $value );
+}
+
+=head2 distinct_query STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+ my $table = $sb->table;
+
+ if (
+ grep {
+ ( defined $_->{'alias'} and $_->{'alias'} ne 'main' )
+ || defined $_->{'function'}
+ } @{ $sb->order_by }
+ )
+ {
+
+ # If we are ordering by something not in 'main', we need to GROUP
+ # BY and adjust the ORDER_BY accordingly
+ local $sb->{group_by}
+ = [ @{ $sb->{group_by} || [] }, { column => 'id' } ];
+ local $sb->{order_by} = [
+ map {
+ my $alias = $_->{alias} || '';
+ my $column = $_->{column};
+ $alias .= '.' if $alias;
+ #warn "alias $alias => column $column\n";
+ ((!$alias or $alias eq 'main.') and $column eq 'id')
+ ? $_
+ : { %{$_}, alias => '', column => "min($alias$column)" }
+ } @{ $sb->{order_by} }
+ ];
+ my $group = $sb->_group_clause;
+ my $order = $sb->_order_clause;
+ $$statementref
+ = "SELECT ".$sb->_preload_columns." FROM ( SELECT main.id FROM $$statementref $group $order ) distinctquery, $table main WHERE (main.id = distinctquery.id)";
+ }
+ else {
+ $$statementref = "SELECT DISTINCT ".$sb->_preload_columns." FROM $$statementref";
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+ }
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Handle>, L<DBD::Pg>
+
+=cut
+
--- /dev/null
+
+package Jifty::DBI::Handle::SQLite;
+use Jifty::DBI::Handle;
+@ISA = qw(Jifty::DBI::Handle);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::SQLite -- A SQLite specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of Jifty::DBI::Handle that
+compensates for some of the idiosyncrasies of SQLite.
+
+=head1 METHODS
+
+=head2 database_version
+
+Returns the version of the SQLite library which is used, e.g., "2.8.0".
+SQLite can only return short variant.
+
+=cut
+
+sub database_version {
+ my $self = shift;
+ return '' unless $self->dbh;
+ return $self->dbh->{sqlite_version} || '';
+}
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of the arguments
+are an array of key-value pairs to be inserted.
+
+If the insert succeeds, returns the id of the insert, otherwise, returns
+a Class::ReturnValue object with the error reported.
+
+=cut
+
+sub insert {
+ my $self = shift;
+ my $table = shift;
+ my %args = ( id => undef, @_ );
+
+ # We really don't want an empty id
+
+ my $sth = $self->SUPER::insert( $table, %args );
+ return unless $sth;
+
+# If we have set an id, then we want to use that, otherwise, we want to lookup the last _new_ rowid
+ $self->{'id'} = $args{'id'} || $self->dbh->func('last_insert_rowid');
+
+ warn "$self no row id returned on row creation" unless ( $self->{'id'} );
+ return ( $self->{'id'} ); #Add Succeded. return the id
+}
+
+=head2 case_sensitive
+
+Returns 1, since SQLite's searches are case sensitive by default.
+Note, however, SQLite's C<like> operator is case I<in>sensitive.
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (1);
+}
+
+=head2 distinct_count STATEMENTREF
+
+takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result count
+
+
+=cut
+
+sub distinct_count {
+ my $self = shift;
+ my $statementref = shift;
+
+ # Wrapper select query in a subselect as Oracle doesn't allow
+ # DISTINCT against CLOB/BLOB column types.
+ $$statementref
+ = "SELECT count(*) FROM (SELECT DISTINCT main.id FROM $$statementref )";
+
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse@fsck.com
+
+=head1 SEE ALSO
+
+perl(1), Jifty::DBI
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle::Sybase;
+use Jifty::DBI::Handle;
+@ISA = qw(Jifty::DBI::Handle);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::Sybase -- a Sybase specific Handle object
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This module provides a subclass of L<Jifty::DBI::Handle> that
+compensates for some of the idiosyncrasies of Sybase.
+
+=head1 METHODS
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of
+the arguments are an array of key-value pairs to be inserted.
+
+If the insert succeeds, returns the id of the insert, otherwise,
+returns a L<Class::ReturnValue> object with the error reported.
+
+=cut
+
+sub insert {
+ my $self = shift;
+
+ my $table = shift;
+ my %pairs = @_;
+ my $sth = $self->SUPER::insert( $table, %pairs );
+ if ( !$sth ) {
+ return ($sth);
+ }
+
+ # Can't select identity column if we're inserting the id by hand.
+ unless ( $pairs{'id'} ) {
+ my @row = $self->fetch_result('SELECT @@identity');
+
+ # TODO: Propagate Class::ReturnValue up here.
+ unless ( $row[0] ) {
+ return (undef);
+ }
+ $self->{'id'} = $row[0];
+ }
+ return ( $self->{'id'} );
+}
+
+=head2 database_version
+
+return the database version, trimming off any -foo identifier
+
+=cut
+
+sub database_version {
+ my $self = shift;
+ my $v = $self->SUPER::database_version();
+
+ $v =~ s/\-(.*)$//;
+ return ($v);
+
+}
+
+=head2 case_sensitive
+
+Returns undef, since Sybase's searches are not case sensitive by default
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (1);
+}
+
+# sub apply_limits {
+# my $self = shift;
+# my $statementref = shift;
+# my $per_page = shift;
+# my $first = shift;
+#
+# }
+
+=head2 distinct_query STATEMENTREF
+
+Takes an incomplete SQL SELECT statement and massages it to return a
+DISTINCT result set.
+
+=cut
+
+sub distinct_query {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+ my $table = $sb->table;
+
+ if ( $sb->_order_clause =~ /(?<!main)\./ ) {
+
+ # Don't know how to do ORDER BY when the DISTINCT is in a subquery
+ warn
+ "Query will contain duplicate rows; don't how how to ORDER BY across DISTINCT";
+ $$statementref = "SELECT main.* FROM $$statementref";
+ } else {
+
+ # Wrapper select query in a subselect as Sybase doesn't allow
+ # DISTINCT against CLOB/BLOB column types.
+ $$statementref
+ = "SELECT main.* FROM ( SELECT DISTINCT main.id FROM $$statementref ) distinctquery, $table main WHERE (main.id = distinctquery.id) ";
+ }
+ $$statementref .= $sb->_group_clause;
+ $$statementref .= $sb->_order_clause;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse@fsck.com
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Handle>, L<DBD::Sybase>
+
+=cut
--- /dev/null
+package Jifty::DBI::Handle::mysql;
+use Jifty::DBI::Handle;
+@ISA = qw(Jifty::DBI::Handle);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+=head1 NAME
+
+ Jifty::DBI::Handle::mysql - A mysql specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of L<Jifty::DBI::Handle> that
+compensates for some of the idiosyncrasies of MySQL.
+
+=head1 METHODS
+
+=cut
+
+=head2 insert
+
+Takes a table name as the first argument and assumes that the rest of
+the arguments are an array of key-value pairs to be inserted.
+
+If the insert succeeds, returns the id of the insert, otherwise,
+returns a L<Class::ReturnValue> object with the error reported.
+
+=cut
+
+sub insert {
+ my $self = shift;
+
+ my $sth = $self->SUPER::insert(@_);
+ if ( !$sth ) {
+ return ($sth);
+ }
+
+ $self->{'id'} = $self->dbh->{'mysql_insertid'};
+
+ # Yay. we get to work around mysql_insertid being null some of the time :/
+ unless ( $self->{'id'} ) {
+ $self->{'id'} = $self->fetch_result('SELECT LAST_INSERT_ID()');
+ }
+ warn "$self no row id returned on row creation" unless ( $self->{'id'} );
+
+ return ( $self->{'id'} ); #Add Succeded. return the id
+}
+
+=head2 database_version
+
+Returns the mysql version, trimming off any -foo identifier
+
+=cut
+
+sub database_version {
+ my $self = shift;
+ my $v = $self->SUPER::database_version();
+
+ $v =~ s/\-.*$//;
+ return ($v);
+}
+
+=head2 case_sensitive
+
+Returns undef, since mysql's searches are not case sensitive by default
+
+=cut
+
+sub case_sensitive {
+ my $self = shift;
+ return (undef);
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse@fsck.com
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Handle>, L<DBD::mysql>
+
+=cut
+
--- /dev/null
+package Jifty::DBI::Handle::mysqlPP;
+use Jifty::DBI::Handle::mysql;
+@ISA = qw(Jifty::DBI::Handle::mysql);
+
+use vars qw($VERSION @ISA $DBIHandle $DEBUG);
+use strict;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Jifty::DBI::Handle::mysqlPP - A mysql specific Handle object
+
+=head1 DESCRIPTION
+
+A Handle subclass for the "pure perl" mysql database driver.
+
+This is currently identical to the Jifty::DBI::Handle::mysql class.
+
+=head1 AUTHOR
+
+
+
+=head1 SEE ALSO
+
+Jifty::DBI::Handle::mysql
+
+=cut
+
--- /dev/null
+package Jifty::DBI::HasFilters;
+
+use warnings;
+use strict;
+
+use base qw/Class::Accessor::Fast/;
+__PACKAGE__->mk_accessors qw/
+ input_filters
+ output_filters
+ filters
+ /;
+
+=head1 NAME
+
+Jifty::DBI::HasFilters - abstract class for objects that has filters
+
+=head1 SYNOPSYS
+
+ my $record = Jifty::DBI::Record->new(...);
+ $record->input_filters( 'Jifty::DBI::Filter::Truncate',
+ 'Jifty::DBI::Filter::utf8'
+ );
+ my @filters = $record->output_filters;
+
+=head1 DESCRIPTION
+
+This abstract class provide generic interface for setting and getting
+input and output data filters for L<Jifty::DBI> objects.
+You shouldn't use it directly, but L<Jifty::DBI::Handle>, L<Jifty::DBI::Record>
+and L<Jifty::DBI::Column> classes inherit this interface.
+
+
+=head1 METHODS
+
+=head2 input_filters
+
+Returns array of the input filters, if arguments list is not empty
+then set input filter.
+
+=cut
+
+sub input_filters {
+ my $self = shift;
+ if (@_) { # setting
+ my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_;
+ $self->_input_filters_accessor( [@values] );
+ }
+
+ return @{ $self->_input_filters_accessor || [] };
+}
+
+=head2 output_filters
+
+Deals similar with list of output filters, but unless
+you defined own list returns reversed list of the input
+filters. In common situation you don't need to define
+own list of output filters, but use this method to get
+default list based on the input list.
+
+=cut
+
+sub output_filters {
+ my $self = shift;
+ if (@_) { # setting
+ my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_;
+ $self->_output_filters_accessor( [@values] );
+ }
+
+ my @values = @{ $self->_output_filters_accessor || [] };
+ return @values if @values;
+
+ @values = reverse $self->input_filters;
+ return @values;
+}
+
+=head2 filters FILTERS
+
+Sets the input and output filters at the same time. Returns a hash,
+with keys C<input> and C<output>, 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<Jifty::DBI::Filter>
+
+=cut
+
+1;
--- /dev/null
+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<Jifty::DBI>
+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<COLUMN> has a true value for C<ATTRIBUTE>.
+
+Otherwise returns C<COLUMN>'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</_init_methods_for_column> 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<till> and C<since>.
+
+If no implementation is present, the "latest" schema version is assumed, meaning that any column defining a C<till> 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</schema_version>, it will automatically generate methods according to whether the column currently exists for the current application schema version returned by that method. The C<schema_version> method must return a value in the same form used by C<since> and C<till>.
+
+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<Jifty::DBI::Column/active>, L<Jifty::DBI::Schema/since>, L<Jifty::DBI::Schema/till> 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<PRIVATE> method takes a column name and a value for that column.
+
+It returns C<undef> unless C<COLUMN> 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<VALUE>.
+
+=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<class>, C<table>, and C<columns>. C<class> and C<table>
+return simple scalars, but C<columns> returns a hash of C<name => value> pairs
+for all the columns in this model. See C<Jifty::DBI::Column/serialize_metadata> 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<Jifty::DBI::Record> 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-E<gt>some_field>, C<Jifty::DBI::Record>
+provides the following hook
+
+=over
+
+
+
+=item after_I<column_name>
+
+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<Jifty::DBI> provides the following hooks
+
+=over
+
+=item before_set_I<column_name> PARAMHASH
+
+C<Jifty::DBI::Record> 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<column>.
+
+=item is_sql_function
+
+A boolean that, if true, indicates that I<value> is an SQL function,
+not just a value.
+
+=back
+
+If before_set_I<column_name> returns false, the new value isn't set.
+
+=item after_set_I<column_name> 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<column> and C<value> keys. If C<value> was a SQL function,
+it will now contain the actual value that was set.
+
+This hook's return value is ignored.
+
+=item validate_I<column_name> VALUE
+
+This hook is called just before updating the database. It expects the
+actual new value you're trying to set I<column_name> to. It returns
+two values. The first is a boolean with truth indicating success. The
+second is an optional message. Note that validate_I<column_name> may be
+called outside the context of a I<set> 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<load> 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<load_by_cols> 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<create> 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<before_create> 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<Class::ReturnValue>
+
+=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<Class::ReturnValue> 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<My::App::Rhino>, your table name will default
+to C<rhinos>. If your class name is C<My::App::RhinoOctopus>, your
+default table name will be C<rhino_octopuses>. 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<Class::ReturnValue> 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 <jesse@bestpractical.com>, Alex Vandiver <alexmv@bestpractical.com>, David Glasser <glasser@bestpractical.com>, Ruslan Zakirov <ruslan.zakirov@gmail.com>
+
+Based on DBIx::SearchBuilder::Record, whose credits read:
+
+ Jesse Vincent, <jesse@fsck.com>
+ Enhancements by Ivan Kohler, <ivan-rt@420.am>
+ Docs by Matt Knopp <mhat@netlag.com>
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>
+
+=cut
+
+
--- /dev/null
+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<Jifty::DBI::Record> 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<Jifty::DBI::Record> 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<Jifty::DBI::Record> 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 <mhat@netlag.com>
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Record>
+
+=cut
+
+
--- /dev/null
+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<Jifty::DBI::Record> 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<Jifty::DBI::Record> 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<Jifty::DBI::Record> 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<Cache::Memcached> 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 <mhat@netlag.com>
+
+=head1 SEE ALSO
+
+L<Jifty::DBI>, L<Jifty::DBI::Record>
+
+=cut
+
+
--- /dev/null
+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<Jifty::DBI::Record::Plugin>. 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<register_triggers>:
+
+ sub register_triggers {
+ my $self = shift;
+ $self->add_trigger(
+ name => 'before_create',
+ callback => \&before_create,
+ abortable => 1,
+ );
+ }
+
+ sub before_create {
+ # do something...
+ }
+
+See L<Jifty::DBI::Class::Trigger>.
+
+=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<Jifty::DBI::Record>, L<Jifty::DBI::Class::Trigger>
+
+=head1 LICENSE
+
+Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC.
+Jifty is distributed under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+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<column> 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<content> that is of type C<text>. It will be
+rendered with the label C<Content> (note the capital) and as a C<textarea> in
+a HTML form.
+
+Jifty::DBI::Schema builds a L<Jifty::DBI::Column>. That class defines
+other attributes for database structure that are not exposed directly
+here. One example of this is the "refers_to" method used to create
+associations between classes.
+
+It re-exports C<defer> and C<lazy> from L<Scalar::Defer>, for setting
+parameter fields that must be recomputed at request-time:
+
+ column name =>
+ default is defer { Jifty->web->current_user->name };
+
+See L<Scalar::Defer> for more information about C<defer>.
+
+=cut
+
+use Carp qw/croak carp/;
+use Scalar::Defer;
+use base qw(Class::Data::Inheritable);
+__PACKAGE__->mk_classdata('TYPES' => {});
+
+use Object::Declare (
+ mapping => {
+ column => sub { Jifty::DBI::Column->new({@_}) } ,
+ },
+ aliases => {
+ default_value => 'default',
+ available => 'available_values',
+ valid => 'valid_values',
+ render => 'render_as',
+ order => 'sort_order',
+ filters => 'input_filters',
+ },
+ copula => {
+ is => sub { return @_ if $#_;
+ my $typehandler = __PACKAGE__->TYPES->{$_[0]};
+ # XXX: when we have a type name
+ # convention, give a warning when it
+ # looks like a type name but not found
+ return ($_[0] => 1) unless $typehandler;
+ return $typehandler->();
+ },
+ are => '',
+ as => '',
+ ajax => 'ajax_',
+ refers_to => sub { refers_to => @_ },
+ references => sub { refers_to => @_ },
+ },
+);
+use Class::Data::Inheritable;
+use UNIVERSAL::require ();
+
+our @EXPORT = qw( defer lazy column schema by render_as since till literal);
+
+sub by ($) { @_ }
+sub render_as ($) { render as @_ }
+sub since ($) { since is @_ }
+sub till ($) { till is @_ }
+
+sub literal($) {
+ my $value = shift;
+ return \$value;
+}
+
+our $SCHEMA;
+our $SORT_ORDERS = {};
+
+use Exporter::Lite ();
+# TODO - This "sub import" is strictly here to catch the deprecated "length is 40".
+# Once the deprecation cycle is over we should take this away and rever to
+# "use Exporter::Lite" in the line above.
+my $old_sig_die;
+
+sub import {
+ no warnings qw( uninitialized numeric );
+ $old_sig_die ||= $SIG{__DIE__};
+ $SIG{__DIE__} = \&filter_die unless $SIG{__DIE__} and $SIG{__DIE__} == \&filter_die;
+ goto &Exporter::Lite::import;
+}
+
+=head2 filter_die
+
+=cut
+
+sub filter_die {
+ # Calling it by hand means we restore the old sighandler.
+ $SIG{__DIE__} = $old_sig_die;
+ if ($_[0] =~ /near "is (\d+)"/) {
+ carp @_, << ".";
+
+*********************************************************
+
+ Due to an incompatible API change, the "length" field in
+ Jifty::DBI columns has been renamed to "max_length":
+
+ column foo =>
+ length is $1; # NOT VALID
+
+ Please write this instead:
+
+ column foo =>
+ max_length is $1 # VALID
+
+ Sorry for the inconvenience.
+
+**********************************************************
+
+
+.
+ exit 1;
+ }
+ elsif ($_[0] =~ /Undefined subroutine &Jifty::DBI::Schema::column|Can't locate object method "type" via package "(?:is|are)"/) {
+ my $from = (caller)[0];
+ $from =~ s/::Schema$//;
+ my $base = $INC{'Jifty/Record.pm'} ? "Jifty::Record" : "Jifty::DBI::Record";
+
+ no strict 'refs';
+ carp @_, << ".";
+*********************************************************
+
+ Calling 'column' within a schema class is an error:
+
+ package $from\::Schema;
+ column foo => ...; # NOT VALID
+
+ Please write this instead:
+
+ package $from;
+ use Jifty::DBI::Schema;
+ use @{[(${"$from\::ISA"} || [$base])->[0] || $base]} schema {
+ column foo => ...; # VALID
+ };
+
+ Sorry for the inconvenience.
+
+*********************************************************
+.
+ }
+
+ die @_;
+}
+
+
+=head1 FUNCTIONS
+
+All these functions are exported. However, if you use the C<schema> helper function,
+they will be unimported at the end of the block passed to C<schema>.
+
+=head2 schema
+
+Takes a block with schema declarations. Unimports all helper functions after
+executing the code block. Usually used at C<BEGIN> time via this idiom:
+
+ use Jifty::DBI::Record schema { ... };
+
+If your application subclasses C<::Record>, then write this instead:
+
+ use MyApp::Record schema { ... };
+
+=cut
+
+=head2 column
+
+DEPRECATED. This method of defining columns will not work anymore. Please
+use the C<schema {}> method documented above.
+
+=cut
+
+sub schema (&) {
+ my $code = shift;
+ my $from = caller;
+
+ my $new_code = sub {
+ no warnings 'redefine';
+ local *_ = sub { my $args = \@_; defer { _(@$args) } };
+ $from->_init_columns;
+
+ my @columns = &declare($code);
+
+ # Unimport all our symbols from the calling package,
+ # except for "lazy" and "defer".
+ foreach my $sym (@EXPORT) {
+ next if $sym eq 'lazy' or $sym eq 'defer';
+
+ no strict 'refs';
+ undef *{"$from\::$sym"}
+ if \&{"$from\::$sym"} == \&$sym;
+ }
+
+ foreach my $column (@columns) {
+ next if !ref($column);
+ _init_column($column);
+ }
+
+ $from->_init_methods_for_columns;
+ };
+
+ return ('-base' => $new_code);
+}
+
+use Hash::Merge ();
+
+no warnings 'uninitialized';
+use constant MERGE_PARAM_BEHAVIOUR => {
+ SCALAR => {
+ SCALAR => sub { CORE::length($_[1]) ? $_[1] : $_[0] },
+ ARRAY => sub { [ @{$_[1]} ] },
+ HASH => sub { $_[1] } },
+ ARRAY => {
+ SCALAR => sub { CORE::length($_[1]) ? $_[1] : $_[0] },
+ ARRAY => sub { [ @{$_[1]} ] },
+ HASH => sub { $_[1] } },
+ HASH => {
+ SCALAR => sub { CORE::length($_[1]) ? $_[1] : $_[0] },
+ ARRAY => sub { [ @{$_[1]} ] },
+ HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) } }
+};
+
+=head2 merge_params HASHREF HASHREF
+
+Takes two hashrefs. Merges them together and returns the merged hashref.
+
+ - Empty fields in subclasses don't override nonempty fields in superclass anymore.
+ - Arrays don't merge; e.g. if parent class's valid_values is [1,2,3,4], and
+ subclass's valid_values() is [1,2], they don't somehow become [1,2,3,4,1,2].
+
+BUG: This should either be a private routine or factored out into Jifty::Util
+
+
+
+=cut
+
+sub merge_params {
+ my $prev_behaviour = Hash::Merge::get_behavior();
+ Hash::Merge::specify_behavior( MERGE_PARAM_BEHAVIOUR, "merge_params" );
+ my $rv = Hash::Merge::merge(@_);
+ Hash::Merge::set_behavior( $prev_behaviour );
+ return $rv;
+}
+
+
+sub _init_column {
+ my $column = shift;
+ my $name = $column->name;
+
+ my $from = (caller(2))[0];
+ if ($from =~ s/::Schema$// && $from !~ /Script/) {
+ no strict 'refs';
+
+ carp << "." unless $from->{_seen_column_warning}++;
+
+*********************************************************
+
+ Calling 'column' within a schema class is deprecated:
+
+ package $from\::Schema;
+ column $name => ...; # NOT VALID
+
+ Please write this instead:
+
+ package $from;
+ use Jifty::DBI::Schema;
+ use @{[${"$from\::ISA"}[0] || "Jifty::DBI::Record"]} schema {
+ column $name => ...; # VALID
+ };
+
+ Sorry for the inconvenience.
+
+*********************************************************
+.
+ }
+ return _init_column_for($column, $from, @_);
+}
+
+sub _init_column_for {
+ my $column = shift;
+ my $from = shift;
+ my $name = $column->name;
+
+ croak "Base of schema class $from is not a Jifty::DBI::Record"
+ unless UNIVERSAL::isa($from, "Jifty::DBI::Record");
+
+ croak "Illegal column definition for column $name in $from"
+ if grep {not UNIVERSAL::isa($_, "Jifty::DBI::Schema::Trait")} @_;
+
+ $column->readable(!(delete $column->{unreadable}));
+ $column->writable(!(delete $column->{immutable}));
+
+ # XXX: deprecated
+ $column->mandatory(1) if delete $column->{not_null};
+
+ $column->sort_order($SORT_ORDERS->{$from}++);
+
+ $column->input_filters($column->{input_filters} || []);
+ $column->output_filters($column->{output_filters} || []);
+
+ if ( my $refclass = $column->refers_to ) {
+ if (ref($refclass) eq 'ARRAY') {
+ $column->by($refclass->[1]);
+ $column->refers_to($refclass = $refclass->[0]);
+ }
+
+ $refclass->require();
+ $column->type('integer') unless ( $column->type );
+
+ if ( UNIVERSAL::isa( $refclass, 'Jifty::DBI::Record' ) ) {
+ if ( $name =~ /(.*)_id$/ ) {
+ my $aliased_as = $1;
+ my $virtual_column = $from->add_column($aliased_as);
+
+ # Clone ourselves into the virtual column
+ %$virtual_column = %$column;
+
+ $column->refers_to(undef);
+
+ $virtual_column->aliased_as($aliased_as);
+ $virtual_column->alias_for_column($name);
+
+ $from->_init_methods_for_column($virtual_column);
+ }
+ $column->by('id') unless $column->by;
+ $column->type('integer') unless $column->type;
+ } elsif ( UNIVERSAL::isa( $refclass, 'Jifty::DBI::Collection' ) ) {
+ $column->by('id') unless $column->by;
+ $column->virtual('1');
+ } else {
+ warn "Error in $from: $refclass neither Record nor Collection";
+ }
+ } elsif (my $handler = $column->{_init_handler}) {
+ $handler->($column, $from);
+ } else {
+ $column->type('varchar(255)') unless $column->type;
+ }
+
+ $from->COLUMNS->{$name} = $column;
+
+ # Heuristics: If we are called through Jifty::DBI::Schema,
+ # then we know that we are going to initialize methods later
+ # through the &schema wrapper, so we defer initialization here
+ # to not upset column names such as "label" and "type".
+ # (We may not *have* a caller(1) if the user is executing a .pm file.)
+}
+
+=head2 register_types
+
+=cut
+
+sub register_types {
+ my $class = shift;
+ while (my ($type, $sub) = splice(@_, 0, 2)) {
+ $class->TYPES->{$type} = $sub;
+ }
+}
+
+1;
+
+__END__
+
+=head2 references
+
+Indicates that the column references an object or a collection of objects in another
+class. You may refer to either a class that inherits from Jifty::Record by a primary
+key in that class or to a class that inherits from Jifty::Collection.
+
+Correct usage is C<references Application::Model::OtherClass by 'column_name'>, where
+Application::Model::OtherClass is a valid Jifty model and C<'column_name'> is
+a column containing unique values in OtherClass. You can omit C<by 'column_name'> and
+the column name 'id' will be used.
+
+If you are referring to a Jifty::Collection then you must specify C<by 'column_name'>.
+
+When accessing the value in the column the actual object referenced will be returned for
+refernces to Jifty::Records and a reference to a Jifty::Collection will be returned for
+columns referring to Jifty::Collections.
+
+For columns referring to Jifty::Records you can access the actual value of the column
+instead of the object reference by appending '_id' to the column name. As a result,
+you may not end any column name which uses 'references' using '_id'.
+
+=head2 refers_to
+
+Synonym for C<references>.
+
+=cut
+
+=head2 by
+
+Helper for C<references>. Used to specify what column name should be
+used in the referenced model. See the documentation for C<references>e
+
+=head2 type
+
+type passed to our database abstraction layer, which should resolve it
+to a database-specific type. Correct usage is C<type is 'text'>.
+
+Currently type is passed directly to the database. There is no
+intermediary mapping from abstract type names to database specific
+types.
+
+The impact of this is that not all column types are portable between
+databases. For example blobs have different names between
+mysql and postgres.
+
+=head2 default
+
+Give a default value for the column. Correct usage is C<default is
+'foo'>.
+
+=head2 literal
+
+Used for default values, to connote that they should not be quoted
+before being supplied as the default value for the column. Correct
+usage is C<default is literal 'now()'>.
+
+=head2 validator
+
+Defines a subroutine which returns a true value only for valid values
+this column can have. Correct usage is C<validator is \&foo>.
+
+=head2 immutable
+
+States that this column is not writable. This is useful for
+properties that are set at creation time but not modifiable
+thereafter, like 'created by'. Correct usage is C<is immutable>.
+
+=head2 unreadable
+
+States that this column is not directly readable by the application
+using C<< $record->column >>; this is useful for password columns and
+the like. The data is still accessible via C<< $record->_value('') >>.
+Correct usage is C<is unreadable>.
+
+=head2 max_length
+
+Sets a maximum max_length to store in the database; values longer than
+this are truncated before being inserted into the database, using
+L<Jifty::DBI::Filter::Truncate>. Note that this is in B<bytes>, not
+B<characters>. Correct usage is C<max_length is 42>.
+
+
+=head2 mandatory
+
+Mark as a required column. May be used for generating user
+interfaces. Correct usage is C<is mandatory>.
+
+=head2 not_null
+
+Same as L</mandatory>. This is deprecated. Currect usage would be
+C<is not_null>.
+
+=head2 autocompleted
+
+Mark as an autocompleted column. May be used for generating user
+interfaces. Correct usage is C<is autocompleted>.
+
+=head2 distinct
+
+Declares that a column should only have distinct values. This
+currently is implemented via database queries prior to updates
+and creates instead of constraints on the database columns
+themselves. This is because there is no support for distinct
+columns implemented in L<DBIx::DBSchema> at this time.
+Correct usage is C<is distinct>.
+
+=head2 virtual
+
+Declares that a column is not backed by an actual column in the
+database, but is instead computed on-the-fly.
+
+=head2 sort_order
+
+Declares an integer sort value for this column. By default, Jifty will sort
+columns in the order they are defined.
+
+=head2 order
+
+Alias for C<sort_order>.
+
+=head2 input_filters
+
+Sets a list of input filters on the data. Correct usage is
+C<input_filters are 'Jifty::DBI::Filter::DateTime'>. See
+L<Jifty::DBI::Filter>.
+
+=head2 output_filters
+
+Sets a list of output filters on the data. Correct usage is
+C<output_filters are 'Jifty::DBI::Filter::DateTime'>. See
+L<Jifty::DBI::Filter>. You usually don't need to set this, as the
+output filters default to the input filters in reverse order.
+
+=head2 filters
+
+Sets a list of filters on the data. These are applied when reading
+B<and> writing to the database. Correct usage is C<filters are
+'Jifty::DBI::Filter::DateTime'>. See L<Jifty::DBI::Filter>. In
+actuality, this is the exact same as L</input_filters>, since output
+filters default to the input filters, reversed.
+
+=head2 since
+
+What application version this column was last changed. Correct usage
+is C<since '0.1.5'>.
+
+=head2 till
+
+The version after this column was supported. The column is not available in
+the version named, but would have been in the version immediately prior.
+
+Correct usage is C<till '0.2.5'>. This indicates that the column is not available in version C<0.2.5>, but was available in C<0.2.4>. The value specified for L</since> must be less than this version.
+
+=cut
+
+sub till {
+ _list( till => @_ );
+}
+
+=head2 valid_values
+
+A list of valid values for this column. Jifty will use this to
+autoconstruct a validator for you. This list may also be used to
+generate the user interface. Correct usage is C<valid_values are
+qw/foo bar baz/>.
+
+If you want to display different values than are stored in the DB
+you can pass a list of hashrefs, each containing two keys, display
+and value.
+
+ valid_values are
+ { display => 'Blue', value => 'blue' },
+ { display => 'Red', value => 'red' }
+
+=head2 valid
+
+Alias for C<valid_values>.
+
+=head2 label
+
+Designates a human-readable label for the column, for use in user
+interfaces. Correct usage is C<label is 'Your foo value'>.
+
+=head2 hints
+
+A sentence or two to display in long-form user interfaces about what
+might go in this column. Correct usage is C<hints is 'Used by the
+frobnicator to do strange things'>.
+
+=head2 render_as
+
+Used in user interface generation to know how to render the column.
+
+The values for this attribute are the same as the names of the modules under
+L<Jifty::Web::Form::Field>, i.e.
+
+=over
+
+=item * Button
+
+=item * Checkbox
+
+=item * Combobox
+
+=item * Date
+
+=item * Hidden
+
+=item * InlineButton
+
+=item * Password
+
+=item * Radio
+
+=item * Select
+
+=item * Textarea
+
+=item * Upload
+
+=item * Unrendered
+
+=back
+
+You may also use the same names with the initial character in lowercase.
+
+The "Unrendered" may seem counter-intuitive, but is there to allow for
+internal fields that should not actually be displayed.
+
+If these don't meet your needs, you can write your own subclass of
+L<Jifty::Web::Form::Field>. See the documentation for that module.
+
+=head2 render
+
+Alias for C<render_as>.
+
+=head2 indexed
+
+An index will be built on this column
+Correct usage is C<is indexed>
+
+
+=head1 EXAMPLE
+
+=head1 AUTHOR
+
+=head1 BUGS
+
+=head1 SUPPORT
+
+=head1 COPYRIGHT & LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+package Jifty::DBI::SchemaGenerator;
+
+use base qw(Class::Accessor::Fast);
+use DBIx::DBSchema;
+use DBIx::DBSchema::Column;
+use DBIx::DBSchema::Table;
+use Class::ReturnValue;
+use version;
+
+our $VERSION = '0.01';
+
+# Public accessors
+__PACKAGE__->mk_accessors(qw(handle));
+
+# Internal accessors: do not use from outside class
+__PACKAGE__->mk_accessors(qw(_db_schema));
+
+=head1 NAME
+
+Jifty::DBI::SchemaGenerator - Generate table schemas from Jifty::DBI records
+
+=head1 DESCRIPTION
+
+This module turns a Jifty::Record object into an SQL schema for your chosen
+database. At the moment, your choices are MySQL, SQLite, or PostgreSQL.
+Oracle might also work right, though it's untested.
+
+=head1 SYNOPSIS
+
+=head2 The Short Answer
+
+See below for where we get the $handle and $model variables.
+
+ use Jifty::DBI::SchemaGenerator;
+ ...
+ my $s_gen = Jifty::DBI::SchemaGenerator->new( $handle );
+ $s_gen->add_model($model);
+
+ my @statements = $s_gen->create_table_sql_statements;
+ print join("\n", @statements, '');
+ ...
+
+=head2 The Long Version
+
+See L<Jifty::DBI> for details about the first two parts.
+
+=over
+
+=item MyModel
+
+ package MyModel;
+ # lib/MyModel.pm
+
+ use warnings;
+ use strict;
+
+ use base qw(Jifty::DBI::Record);
+ # your custom code goes here.
+ 1;
+
+=item MyModel::Schema
+
+ package MyModel::Schema;
+ # lib/MyModel/Schema.pm
+
+ use warnings;
+ use strict;
+
+ use Jifty::DBI::Schema;
+
+ column foo => type is 'text';
+ column bar => type is 'text';
+
+ 1;
+
+=item myscript.pl
+
+ #!/usr/bin/env perl
+ # myscript.pl
+
+ use strict;
+ use warnings;
+
+ use Jifty::DBI::SchemaGenerator;
+
+ use Jifty::DBI::Handle;
+ use MyModel;
+ use MyModel::Schema;
+
+ my $handle = Jifty::DBI::Handle->new();
+ $handle->connect(
+ driver => 'SQLite',
+ database => 'testdb',
+ );
+
+ my $model = MyModel->new($handle);
+ my $s_gen = Jifty::DBI::SchemaGenerator->new( $handle );
+ $s_gen->add_model($model);
+
+ # here's the basic point of this module:
+ my @statements = $s_gen->create_table_sql_statements;
+ print join("\n", @statements, '');
+
+ # this part is directly from Jifty::Script::Schema::create_all_tables()
+ $handle->begin_transaction;
+ for my $statement (@statements) {
+ my $ret = $handle->simple_query($statement);
+ $ret or die "error creating a table: " . $ret->error_message;
+ }
+ $handle->commit;
+
+=back
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+Requires no configuration files or environment variables.
+
+
+=head1 DEPENDENCIES
+
+Class::Accessor::Fast
+
+DBIx::DBSchema
+
+Class::ReturnValue
+
+=head1 METHODS
+
+=head2 new HANDLE
+
+Creates a new C<Jifty::DBI::SchemaGenerator> object. The single
+required argument is a C<Jifty::DBI::Handle>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $handle = shift;
+ my $self = $class->SUPER::new();
+
+ $self->handle($handle);
+
+ my $schema = DBIx::DBSchema->new();
+ $self->_db_schema($schema);
+
+ return $self;
+}
+
+=head2 add_model MODEL
+
+Adds a new model class to the SchemaGenerator. Model should be an
+object which is an instance of C<Jifty::DBI::Record> or a subclass
+thereof. It may also be a string which is the name of such a
+class/subclass; in the latter case, C<add_model> will instantiate an
+object of the class.
+
+The model must define the instance methods C<schema> and C<table>.
+
+Returns true if the model was added successfully; returns a false
+C<Class::ReturnValue> error otherwise.
+
+=cut
+
+sub add_model {
+ my $self = shift;
+ my $model = shift;
+
+ # $model could either be a (presumably unfilled) object of a subclass of
+ # Jifty::DBI::Record, or it could be the name of such a subclass.
+
+ unless ( ref $model and UNIVERSAL::isa( $model, 'Jifty::DBI::Record' ) ) {
+ my $new_model;
+ eval { $new_model = $model->new; };
+
+ if ($@) {
+ return $self->_error("Error making new object from $model: $@");
+ }
+
+ unless ( UNIVERSAL::isa( $new_model, 'Jifty::DBI::Record' ) ) {
+ return $self->_error(
+ "Didn't get a Jifty::DBI::Record from $model, got $new_model"
+ );
+ }
+ $model = $new_model;
+ }
+
+ my $table_obj = $self->_db_schema_table_from_model($model);
+
+ $self->_db_schema->addtable($table_obj);
+
+ return 1;
+}
+
+=head2 column_definition_sql TABLENAME COLUMNNAME
+
+Given a tablename and a column name, returns the SQL fragment
+describing that column for the current database.
+
+=cut
+
+sub column_definition_sql {
+ my $self = shift;
+ my $table = shift;
+ my $col = shift;
+ my $table_obj = $self->_db_schema->table($table);
+ return $table_obj->column( $col )->line( $self->handle->dbh )
+}
+
+=head2 create_table_sql_statements
+
+Returns a list of SQL statements (as strings) to create tables for all of
+the models added to the SchemaGenerator.
+
+=cut
+
+sub create_table_sql_statements {
+ my $self = shift;
+
+ return $self->_db_schema->sql( $self->handle->dbh );
+}
+
+=head2 create_table_sql_text
+
+Returns a string containing a sequence of SQL statements to create tables for all of
+the models added to the SchemaGenerator.
+
+This is just a trivial wrapper around L</create_Table_sql_statements>.
+
+=cut
+
+sub create_table_sql_text {
+ my $self = shift;
+
+ return join "\n", map {"$_ ;\n"} $self->create_table_sql_statements;
+}
+
+=head2 PRIVATE _db_schema_table_from_model MODEL
+
+Takes an object of a subclass of Jifty::DBI::Record; returns a new
+C<DBIx::DBSchema::Table> object corresponding to the model.
+
+=cut
+
+sub _db_schema_table_from_model {
+ my $self = shift;
+ my $model = shift;
+
+ my $table_name = $model->table;
+ my @columns = $model->columns;
+
+ my @cols;
+ my @indexes;
+
+ for my $column (@columns) {
+
+ # Skip "Virtual" columns - (foreign keys to collections)
+ next if $column->virtual;
+ next if defined $column->alias_for_column;
+
+ # If schema_version is defined, make sure columns are for that version
+ if ($model->can('schema_version') and defined $model->schema_version) {
+
+ # Skip it if the app version is earlier than the column version
+ next if defined $column->since
+ and $model->schema_version < version->new($column->since);
+
+ # Skip it if the app version is the same as or later than the
+ # column version
+ next if defined $column->till
+ and $model->schema_version >= version->new($column->till);
+
+ }
+
+ # Otherwise, assume the latest version and eliminate till columns
+ next if (!$model->can('schema_version') or !defined $model->schema_version)
+ and defined $column->till;
+
+ push @cols,
+ DBIx::DBSchema::Column->new(
+ { name => $column->name,
+ type => $column->type,
+ null => $column->mandatory ? 0 : 1,
+ default => $column->default,
+ }
+ );
+
+ if ($column->indexed) {
+ push @indexes,[$column->name];
+ }
+ }
+
+ my $index_count = 1;
+ my $table = DBIx::DBSchema::Table->new(
+ { name => $table_name,
+ primary_key => "id",
+ columns => \@cols,
+ (@indexes) ? (indices => [map {DBIx::DBSchema::Index->new(name => $table_name.$index_count++, columns => $_) } @indexes]) : ()
+ }
+ );
+
+ return $table;
+}
+
+=head2 PRIVATE _error STRING
+
+Takes in a string and returns it as a Class::ReturnValue error object.
+
+=cut
+
+sub _error {
+ my $self = shift;
+ my $message = shift;
+
+ my $ret = Class::ReturnValue->new;
+ $ret->as_error( errno => 1, message => $message );
+ return $ret->return_value;
+}
+
+1; # Magic true value required at end of module
+
+=head1 INCOMPATIBILITIES
+
+None reported.
+
+=head1 BUGS AND LIMITATIONS
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-E<lt>RT NAMEE<gt>@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+=head1 AUTHOR
+
+David Glasser C<< glasser@bestpractical.com >>
+
+Some pod by Eric Wilhelm <ewilhelm at cpan dot org>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2005, Best Practical Solutions, LLC. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+=cut
+
--- /dev/null
+use Test::More tests => 13;
+
+BEGIN { use_ok("Jifty::DBI::Collection"); }
+BEGIN { use_ok("Jifty::DBI::Handle"); }
+BEGIN { use_ok("Jifty::DBI::Handle::Informix"); }
+BEGIN { use_ok("Jifty::DBI::Handle::mysql"); }
+BEGIN { use_ok("Jifty::DBI::Handle::mysqlPP"); }
+BEGIN { use_ok("Jifty::DBI::Handle::ODBC"); }
+
+BEGIN {
+ SKIP: {
+ skip "DBD::Oracle is not installed", 1
+ unless eval { require DBD::Oracle };
+ use_ok("Jifty::DBI::Handle::Oracle");
+ }
+}
+BEGIN { use_ok("Jifty::DBI::Handle::Pg"); }
+BEGIN { use_ok("Jifty::DBI::Handle::Sybase"); }
+BEGIN { use_ok("Jifty::DBI::Handle::SQLite"); }
+BEGIN { use_ok("Jifty::DBI::Record"); }
+BEGIN { use_ok("Jifty::DBI::Record::Cachable"); }
+
+# Commented out until ruslan sends code.
+BEGIN {
+ SKIP: {
+ skip "Cache::Memcached is not installed", 1
+ unless eval { require Cache::Memcached };
+ use_ok("Jifty::DBI::Record::Memcached");
+ }
+}
--- /dev/null
+#!/usr/bin/env perl -w
+use strict;
+use Test::More qw(no_plan);
+
+# by Eric Wilhelm in response to Randal Schwartz pointing out that
+# CPAN.pm chokes on the VERSION >... construct
+# I dare not mention it here.
+
+use ExtUtils::MakeMaker;
+use ExtUtils::Manifest qw(maniread);
+use_ok('Jifty::DBI');
+
+my $minfo = maniread();
+ok($minfo) or die;
+
+# XXX crossing my fingers against cross-platform and/or chdir issues
+my @files = grep(/\.pm$/, grep(/^lib/, keys(%$minfo)));
+ok(scalar(@files));
+# die join "\n", '', @files, '';
+
+foreach my $file (@files) {
+ # Gah! parse_version complains on stderr!
+ my ($e, @a) = error_catch(sub {MM->parse_version($file)});
+ ok(($e || '') eq '', $file) or warn "$e ";
+}
+
+# runs subroutine reference, looking for error message $look in STDERR
+# and runs tests based on $name
+# ($errs, @ans) = error_catch(sub {$this->test()});
+#
+sub error_catch {
+ my ($sub) = @_;
+ my $TO_ERR;
+ open($TO_ERR, '<&STDERR');
+ close(STDERR);
+ my $catch;
+ open(STDERR, '>', \$catch);
+ my @ans = $sub->();
+ open(STDERR, ">&", $TO_ERR);
+ close($TO_ERR);
+ return($catch, @ans);
+} # end subroutine error_catch definition
+########################################################################
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 4;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ use_ok('Jifty::DBI::Handle::'. $d);
+ my $handle = get_handle( $d );
+ isa_ok($handle, 'Jifty::DBI::Handle');
+ isa_ok($handle, 'Jifty::DBI::Handle::'. $d);
+ can_ok($handle, 'dbh');
+}
+}
+
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 71;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::Address', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::Address', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $rec = TestApp::Address->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+
+# _accessible testings
+ is( $rec->_accessible('id' => 'read'), 1, 'id is accessible for read' );
+ is( $rec->_accessible('id' => 'write'), 0, 'id is not accessible for write' );
+ is( $rec->_accessible('id'), undef, "any column is not accessible in undefined mode" );
+ is( $rec->_accessible('unexpected_column' => 'read'), undef, "column doesn't exist and can't be accessible for read" );
+ is_deeply( [sort($rec->readable_attributes)], [sort qw(address employee_id id name phone)], 'readable attributes' );
+ is_deeply( [sort($rec->writable_attributes)], [sort qw(address employee_id name phone)], 'writable attributes' );
+
+ can_ok($rec,'create');
+
+ # Test create and load as class methods
+
+ my $record2 = TestApp::Address->create( _handle => $handle, name => 'Enoch', phone => '123 456 7890');
+ isa_ok($record2, 'TestApp::Address');
+ ok($record2->id, "Created a record with a class method");
+ is_deeply({ $record2->as_hash }, {
+ id => $record2->id,
+ employee_id => undef,
+ name => 'Enoch',
+ address => '',
+ phone => '123 456 7890',
+ }, 'as_hash works');
+
+ my $clone2 = TestApp::Address->load_by_cols( _handle => $handle, name => 'Enoch');
+ isa_ok($clone2, 'TestApp::Address');
+ is($clone2->phone, '123 456 7890');
+
+ {
+ local *TestApp::Address::_handle = sub { return $handle};
+ my $clone_by_id = TestApp::Address->load($record2->id);
+ isa_ok($clone_by_id, 'TestApp::Address');
+ is($clone_by_id->phone, '123 456 7890');
+ }
+
+ my ($id) = $rec->create( name => 'Jesse', phone => '617 124 567');
+ ok($id,"Created record ". $id);
+ ok($rec->load($id), "Loaded the record");
+
+ is($rec->id, $id, "The record has its id");
+ is ($rec->name, 'Jesse', "The record's name is Jesse");
+
+ my ($val, $msg) = $rec->set_name('Obra');
+ ok($val, $msg) ;
+ is($rec->name, 'Obra', "We did actually change the name");
+
+# Validate immutability of the column id
+ ($val, $msg) = $rec->set_id( $rec->id + 1 );
+ ok(!$val, $msg);
+ is($msg, 'Immutable column', 'id is immutable column');
+ is($rec->id, $id, "The record still has its id");
+
+# Check some non existant column
+ ok( !eval{ $rec->some_unexpected_column }, "The record has no 'some_unexpected_column'");
+ {
+ # test produce DBI warning
+ local $SIG{__WARN__} = sub {return};
+ is( $rec->_value( 'some_unexpected_column' ), undef, "The record has no 'some_unexpected_column'");
+ }
+ ok (!eval { $rec->set_some_unexpected_column( 'foo' )}, "Can't call nonexistent columns");
+ ($val, $msg) = $rec->_set(column =>'some_unexpected_column', value =>'foo');
+ ok(!$val, defined $msg ? $msg : "");
+
+
+# Validate truncation on update
+
+ ($val,$msg) = $rec->set_name('1234567890123456789012345678901234567890');
+ ok($val, $msg);
+ is($rec->name, '12345678901234', "Truncated on update");
+
+
+# make sure we do _not_ truncate things which should not be truncated
+ ($val,$msg) = $rec->set_employee_id('1234567890');
+ ok($val, $msg) ;
+ is($rec->employee_id, '1234567890', "Did not truncate id on create");
+
+ #delete prev record
+ $rec->delete;
+
+# make sure we do truncation on create
+ my $newrec = TestApp::Address->new( handle => $handle );
+ my $newid = $newrec->create( name => '1234567890123456789012345678901234567890',
+ employee_id => '1234567890' );
+
+ $newrec->load($newid);
+
+ ok ($newid, "Created a new record");
+ is($newrec->name, '12345678901234', "Truncated on create");
+ is($newrec->employee_id, '1234567890', "Did not truncate id on create");
+
+# no prefetch feature and _load_from_sql sub checks
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->_load_from_sql('SELECT id FROM addresses WHERE id = ?', $newid);
+ is($val, 1, 'found object');
+ is($newrec->name, '12345678901234', "autoloaded not prefetched column");
+ is($newrec->employee_id, '1234567890', "autoloaded not prefetched column");
+
+# _load_from_sql and missing PK
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->_load_from_sql('SELECT name FROM addresses WHERE name = ?', '12345678901234');
+ is($val, 0, "didn't find object");
+ is($msg, "Missing a primary key?", "reason is missing PK");
+
+# _load_from_sql and not existant row
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->_load_from_sql('SELECT id FROM addresses WHERE id = ?', 0);
+ is($val, 0, "didn't find object");
+ is($msg, "Couldn't find row", "reason is wrong id");
+
+# _load_from_sql and wrong SQL
+ $newrec = TestApp::Address->new( handle => $handle );
+ {
+ local $SIG{__WARN__} = sub{return};
+ ($val, $msg) = $newrec->_load_from_sql('SELECT ...');
+ }
+ is($val, 0, "didn't find object");
+ is($msg, "Couldn't execute query", "reason is bad SQL");
+
+# test load_* methods
+ $newrec = TestApp::Address->new( handle => $handle );
+ $newrec->load();
+ is( $newrec->id, undef, "can't load record with undef id");
+
+ $newrec = TestApp::Address->new( handle => $handle );
+ $newrec->load_by_cols( name => '12345678901234' );
+ is( $newrec->id, $newid, "load record by 'name' column value");
+
+# load_by_col with operator
+ $newrec = TestApp::Address->new( handle => $handle );
+ $newrec->load_by_cols( name => { value => '%45678%',
+ operator => 'LIKE' } );
+ is( $newrec->id, $newid, "load record by 'name' with LIKE");
+
+# load_by_primary_keys
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->load_by_primary_keys( id => $newid );
+ ok( $val, "load record by PK");
+ is( $newrec->id, $newid, "loaded correct record");
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->load_by_primary_keys( {id => $newid} );
+ ok( $val, "load record by PK");
+ is( $newrec->id, $newid, "loaded correct record" );
+ $newrec = TestApp::Address->new( handle => $handle );
+ ($val, $msg) = $newrec->load_by_primary_keys( phone => 'some' );
+ ok( !$val, "couldn't load, missing PK column");
+ is( $msg, "Missing PK column: 'id'", "right error message" );
+
+# Defaults kick in
+ $rec = TestApp::Address->new( handle => $handle );
+ $id = $rec->create( name => 'Chmrr' );
+ ok( $id, "new record");
+ $rec = TestApp::Address->new( handle => $handle );
+ $rec->load_by_cols( name => 'Chmrr' );
+ is( $rec->id, $id, "loaded record by empty value" );
+ is( $rec->address, '', "Got default on create" );
+
+# load_by_cols and empty or NULL values
+ $rec = TestApp::Address->new( handle => $handle );
+ $id = $rec->create( name => 'Obra', phone => undef );
+ ok( $id, "new record");
+ $rec = TestApp::Address->new( handle => $handle );
+ $rec->load_by_cols( name => 'Obra', phone => undef, employee_id => '' );
+ is( $rec->id, $id, "loaded record by empty value" );
+
+# __set error paths
+ $rec = TestApp::Address->new( handle => $handle );
+ $rec->load( $id );
+ $val = $rec->set_name( 'Obra' );
+ isa_ok( $val, 'Class::ReturnValue', "couldn't set same value, error returned");
+ is( ($val->as_array)[1], "That is already the current value", "correct error message" );
+ is( $rec->name, 'Obra', "old value is still there");
+ $val = $rec->set_name( 'invalid' );
+ isa_ok( $val, 'Class::ReturnValue', "couldn't set invalid value, error returned");
+ is( ($val->as_array)[1], 'Illegal value for name', "correct error message" );
+ is( $rec->name, 'Obra', "old value is still there");
+# XXX TODO FIXME: this test cover current implementation that is broken //RUZ
+# fixed, now we can set undef values(NULLs)
+ $val = $rec->set_name( );
+ isa_ok( $val, 'Class::ReturnValue', "set empty/undef/NULL value");
+ is( ($val->as_array)[1], "The new value has been set.", "correct error message" );
+ is( $rec->name, undef, "new value is undef, NULL in DB");
+
+# deletes
+ $newrec = TestApp::Address->new( handle => $handle );
+ $newrec->load( $newid );
+ is( $newrec->delete, 1, 'successfuly delete record');
+ $newrec = TestApp::Address->new( handle => $handle );
+ $newrec->load( $newid );
+ is( $newrec->id, undef, "record doesn't exist any more");
+
+ cleanup_schema( 'TestApp::Address', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp::Address;
+use base qw/Jifty::DBI::Record/;
+
+sub validate_name
+{
+ my ($self, $value) = @_;
+ return 0 if $value && $value =~ /invalid/i;
+ return 1;
+}
+
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY table addresses (
+ id integer AUTO_INCREMENT,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY table addresses (
+ id serial PRIMARY KEY,
+ name varchar,
+ phone varchar,
+ address varchar,
+ employee_id integer
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table addresses (
+ id integer primary key,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8))
+EOF
+
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE addresses_seq",
+ "CREATE TABLE addresses (
+ id integer CONSTRAINT address_key PRIMARY KEY,
+ Name varchar(36),
+ Phone varchar(18),
+ EmployeeId integer
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE addresses_seq",
+ "DROP TABLE addresses",
+] }
+
+1;
+
+BEGIN {
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+
+column name =>
+ till 999,
+ type is 'varchar(14)';
+
+column phone =>
+ type is 'varchar(18)';
+
+column address =>
+ type is 'varchar(50)',
+ default is '';
+
+column employee_id =>
+ type is 'int(8)';
+}
+}
+1;
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 82;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $count_all = init_data( 'TestApp::User', $handle );
+ ok( $count_all, "init users data" );
+
+ my $users_obj = TestApp::UserCollection->new( handle => $handle );
+ isa_ok( $users_obj, 'Jifty::DBI::Collection' );
+ is( $users_obj->_handle, $handle, "same handle as we used in constructor");
+
+# check that new object returns 0 records in any case
+ is( $users_obj->_record_count, 0, '_record_count returns 0 on not limited obj' );
+ is( $users_obj->count, 0, 'count returns 0 on not limited obj' );
+ is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after count' );
+ is( $users_obj->first, undef, 'first returns undef on not limited obj' );
+ is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after first' );
+ is( $users_obj->last, undef, 'last returns undef on not limited obj' );
+ is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after last' );
+ $users_obj->goto_first_item;
+ is( $users_obj->peek, undef, 'peek returns undef on not limited obj' );
+ is( $users_obj->next, undef, 'next returns undef on not limited obj' );
+ is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after next' );
+ # XXX TODO FIXME: may be this methods should be implemented
+ # $users_obj->goto_last_item;
+ # is( $users_obj->prev, undef, 'prev returns undef on not limited obj' );
+ my $items_ref = $users_obj->items_array_ref;
+ isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' );
+ is_deeply( $items_ref, [], 'items_array_ref returns [] on not limited obj' );
+
+# unlimit new object and check
+ $users_obj->unlimit;
+ is( $users_obj->count, $count_all, 'count returns same number of records as was inserted' );
+ isa_ok( $users_obj->first, 'Jifty::DBI::Record', 'first returns record object' );
+ isa_ok( $users_obj->last, 'Jifty::DBI::Record', 'last returns record object' );
+ $users_obj->goto_first_item;
+ isa_ok( $users_obj->peek, 'Jifty::DBI::Record', 'peek returns record object' );
+ isa_ok( $users_obj->next, 'Jifty::DBI::Record', 'next returns record object' );
+ $items_ref = $users_obj->items_array_ref;
+ isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' );
+ is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' );
+ $users_obj->redo_search;
+ $items_ref = $users_obj->items_array_ref;
+ isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' );
+ is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' );
+
+# try to use $users_obj for all tests, after each call to clean_slate it should look like new obj.
+# and test $obj->new syntax
+ my $clean_obj = $users_obj->new( handle => $handle );
+ isa_ok( $clean_obj, 'Jifty::DBI::Collection' );
+
+# basic limits
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'login', value => 'obra' );
+ is( $users_obj->count, 1, 'found one user with login obra' );
+ TODO: {
+ local $TODO = 'require discussion';
+ is( $users_obj->is_last, undef, 'is_last returns undef before we fetch any record' );
+ }
+ my $first_rec = $users_obj->first;
+ isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' );
+ is( $users_obj->is_last, 1, '1 record in the collection then first rec is last');
+ is( $first_rec->login, 'obra', 'login is correct' );
+ my $last_rec = $users_obj->last;
+ is( $last_rec, $first_rec, 'last returns same object as first' );
+ is( $users_obj->is_last, 1, 'is_last always returns 1 after last call');
+ $users_obj->goto_first_item;
+ my $peek_rec = $users_obj->peek;
+ my $next_rec = $users_obj->next;
+ is( $next_rec, $peek_rec, 'peek returns same object as next' );
+ is( $next_rec, $first_rec, 'next returns same object as first' );
+ is( $users_obj->is_last, 1, 'is_last returns 1 after fetch first record with next method');
+ is( $users_obj->peek, undef, 'only one record in the collection' );
+ is( $users_obj->next, undef, 'only one record in the collection' );
+ TODO: {
+ local $TODO = 'require discussion';
+ is( $users_obj->is_last, undef, 'next returns undef, is_last returns undef too');
+ }
+ $items_ref = $users_obj->items_array_ref;
+ isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' );
+ is( scalar @{$items_ref}, 1, 'items_array_ref has only 1 record' );
+
+# similar basic limit, but with different operators and less first/next/last tests
+ # LIKE
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass' );
+ is( $users_obj->count, 1, "found one user with 'Glass' in the name" );
+ $first_rec = $users_obj->first;
+ isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' );
+ is( $first_rec->login, 'glasser', 'login is correct' );
+
+ # STARTSWITH
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', operator => 'STARTSWITH', value => 'Ruslan' );
+ is( $users_obj->count, 1, "found one user who name starts with 'Ruslan'" );
+ $first_rec = $users_obj->first;
+ isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' );
+ is( $first_rec->login, 'cubic', 'login is correct' );
+
+ # ENDSWITH
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', operator => 'ENDSWITH', value => 'Tang' );
+ is( $users_obj->count, 1, "found one user who name ends with 'Tang'" );
+ $first_rec = $users_obj->first;
+ isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' );
+ is( $first_rec->login, 'audreyt', 'login is correct' );
+
+ # IS NULL
+ # XXX TODO FIXME: column => undef should be handled as NULL
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL' );
+ is( $users_obj->count, 2, "found 2 users who has unknown phone number" );
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'address', operator => 'IS', value => 'NULL' );
+ is( $users_obj->count, 0, "found 0 users who has unknown address" );
+
+ # IS NOT NULL
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'phone', operator => 'IS NOT', value => 'NULL', quotevalue => 0 );
+ is( $users_obj->count, $count_all - 2, "found users who have phone number filled" );
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'address', operator => 'IS NOT', value => 'NULL', quotevalue => 0 );
+ is( $users_obj->count, $count_all, "found users who have address filled" );
+
+ # CASE SENSITIVITY, default is limits are not case sensitive
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', value => 'Jesse Vincent' );
+ is( $users_obj->count, 1, "case insensitive, matching case, should find one row");
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', value => 'jesse vincent' );
+ is( $users_obj->count, 1, "case insensitive, non-matched case, should find one row");
+
+ # CASE SENSITIVITY, testing with case_sensitive => 1
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', value => 'Jesse Vincent', case_sensitive => 1 );
+ is( $users_obj->count, 1, "case sensitive search, should find one row");
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'name', value => 'jesse vincent', case_sensitive => 1 );
+ TODO: {
+ local $TODO = "MySQL still needs case sensitive fixes" if ( $d eq 'mysql' || $d eq 'mysqlPP' );
+ is( $users_obj->count, 0, "case sensitive search, should find zero rows");
+ }
+
+ # ORDER BY / GROUP BY
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->unlimit;
+ $users_obj->group_by(column => 'login');
+ $users_obj->order_by(column => 'login', order => 'desc');
+ $users_obj->column(column => 'login');
+ is( $users_obj->count, $count_all, "group by / order by finds right amount");
+ $first_rec = $users_obj->first;
+ isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' );
+ is( $first_rec->login, 'obra', 'login is correct' );
+
+ $users_obj->clean_slate;
+ TODO: {
+ local $TODO = 'we leave order_by after clean slate, fixing this results in many RT failures';
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj = TestApp::UserCollection->new( handle => $handle );
+ }
+
+# Let's play a little with 'entry_aggregator'
+ # EA defaults to OR for the same field
+ $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 );
+ $users_obj->limit( column => 'phone', operator => 'LIKE', value => '%X%' );
+ is( $users_obj->count, 4, "found users who has no phone or it has X char" );
+
+ # set AND for the same field
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'Login', operator => 'NOT LIKE', value => '%c%' );
+ $users_obj->limit(
+ entry_aggregator => 'AND', column => 'Login', operator => 'LIKE', value => '%u%'
+ );
+ is( $users_obj->count, 1, "found users who has no phone or it has X char" );
+
+ # default is AND for different fields
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 );
+ $users_obj->limit( column => 'login', operator => 'LIKE', value => '%r%' );
+ is( $users_obj->count, 2, "found users who has no phone number or login has 'r' char" );
+
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+package TestApp;
+
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer AUTO_INCREMENT,
+ login varchar(18) NOT NULL,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(18),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial PRIMARY KEY,
+ login varchar(18) NOT NULL,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(18)
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ login varchar(18) NOT NULL,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(18))
+EOF
+
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE Users_seq",
+ "CREATE TABLE Users (
+ id integer CONSTRAINT Users_Key PRIMARY KEY,
+ Login varchar(18) NOT NULL,
+ Name varchar(36),
+ Phone varchar(18)
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE Users_seq",
+ "DROP TABLE Users",
+] }
+
+
+1;
+
+package TestApp::User;
+
+use base qw/Jifty::DBI::Record/;
+
+sub _init {
+ my $self = shift;
+ $self->table('users');
+ $self->SUPER::_init(@_);
+}
+
+sub init_data {
+ return (
+ [ 'login', 'name', 'phone', 'address' ],
+ [ 'cubic', 'Ruslan U. Zakirov', '+7-903-264-XX-XX', undef ],
+ [ 'obra', 'Jesse Vincent', undef, undef ],
+ [ 'glasser', 'David Glasser', undef, 'somewhere' ],
+ [ 'audreyt', 'Audrey Tang', '+X-XXX-XXX-XX-XX', 'someplace' ],
+ );
+}
+
+1;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column login => type is 'varchar(18)';
+ column name => type is 'varchar(36)';
+ column phone => type is 'varchar(18)', default is undef;
+ column address => type is 'varchar(18)', default is '';
+ }
+}
+
+1;
+
+package TestApp::UserCollection;
+
+# use TestApp::User;
+use base qw/Jifty::DBI::Collection/;
+
+sub _init {
+ my $self = shift;
+ $self->SUPER::_init(@_);
+ $self->table('users');
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;# import => [qw(isa_ok skip plan)];
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 7;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {{my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+ }
+
+
+ my $emp = TestApp::Employee->new( handle => $handle );
+ my $e_id = $emp->create( name => 'RUZ', employee_num => '123' );
+ ok($e_id, "Got an id for the new employee");
+
+ # Test 'is mandatory'
+ $e_id = $emp->create( employee_num => '456' );
+ ok(!$e_id, "Did not get an id for second new employee, good");
+
+ # Test 'is distinct'
+ $e_id = $emp->create( name => 'Foo', employee_num => '456' );
+ ok($e_id, "Was able to create a second record successfully");
+ my $e_id2 = $emp->create( name => 'Bar', employee_num => '123' );
+ ok(!$e_id2, "is_distinct prevents us from creating another record");
+ my $obj = TestApp::Employee->new( handle => $handle );
+ $obj->load( $e_id );
+ ok(!$obj->set_employee_num('123'), "is_distinct prevents us from modifying a record to a duplicate value");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE table employees (
+ id integer primary key,
+ name varchar(36) NOT NULL,
+ employee_num int(8)
+)
+} ]
+}
+
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY table employees (
+ id integer AUTO_INCREMENT primary key,
+ name varchar(36) NOT NULL,
+ employee_num int(8)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY table employees (
+ id serial PRIMARY KEY,
+ name varchar NOT NULL,
+ employee_num integer
+)
+} ]
+}
+
+
+
+package TestApp::Employee;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+
+ column name => type is 'varchar(18)',
+ is mandatory;
+
+ column employee_num =>
+ type is 'int(8)',
+ is distinct;
+ }
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+
+use constant TESTS_PER_DRIVER => 35;
+
+our (@available_drivers);
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d (@available_drivers) {
+SKIP: {
+ unless ( has_schema( 'TestApp::Address', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless ( should_test($d) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle($d);
+ connect_handle($handle);
+ isa_ok( $handle->dbh, 'DBI::db' );
+
+ {my $ret = init_schema( 'TestApp::Address', $handle );
+ isa_ok( $ret, 'DBI::st',
+ "Inserted the schema. got a statement handle back" );}
+
+ { # simple, load the same thing from cache
+ my $rec = TestApp::Address->new( handle => $handle );
+ isa_ok( $rec, 'Jifty::DBI::Record' );
+
+ my ($id)
+ = $rec->create( Name => 'Jesse', Phone => '617 124 567' );
+ ok( $id, "Created record #$id" );
+
+ ok( $rec->load($id), "Loaded the record" );
+ is( $rec->id, $id, "The record has its id" );
+ is( $rec->name, 'Jesse', "The record's name is Jesse" );
+
+ my $rec_cache = TestApp::Address->new( handle => $handle );
+ my ( $status, $msg ) = $rec_cache->load_by_cols( id => $id );
+ ok( $status, 'loaded record' );
+ is( $rec_cache->id, $id, 'the same record as we created' );
+ is( $msg, 'Fetched from cache', 'we fetched record from cache' );
+ }
+
+ Jifty::DBI::Record::Cachable->flush_cache;
+
+ { # load by name then load by id, check that we fetch from hash
+ my $rec = TestApp::Address->new( handle => $handle );
+ ok( $rec->load_by_cols( Name => 'Jesse' ), "Loaded the record" );
+ is( $rec->name, 'Jesse', "The record's name is Jesse" );
+
+ my $rec_cache = TestApp::Address->new( handle => $handle );
+ my ( $status, $msg ) = $rec_cache->load_by_cols( id => $rec->id );
+ ok( $status, 'loaded record' );
+ is( $rec_cache->id, $rec->id, 'the same record as we created' );
+ is( $msg, 'Fetched from cache', 'we fetched record from cache' );
+ }
+
+ Jifty::DBI::Record::Cachable->flush_cache;
+
+ { # load_by_cols and undef, 0 or '' values
+ my $rec = TestApp::Address->new( handle => $handle );
+ my ($id) = $rec->create( Name => 'EmptyPhone', Phone => '' );
+ ok( $id, "Created record #$id" );
+ ($id) = $rec->create( Name => 'ZeroPhone', Phone => 0 );
+ ok( $id, "Created record #$id" );
+ ($id) = $rec->create( Name => 'UndefPhone', Phone => undef );
+ ok( $id, "Created record #$id" );
+
+ Jifty::DBI::Record::Cachable->flush_cache;
+
+ ok( $rec->load_by_cols( Phone => undef ), "Loaded the record" );
+ is( $rec->name, 'UndefPhone', "UndefPhone record" );
+
+ is( $rec->phone, undef, "Phone number is undefined" );
+
+ ok( $rec->load_by_cols( Phone => '' ), "Loaded the record" );
+ is( $rec->name, 'EmptyPhone', "EmptyPhone record" );
+ is( $rec->phone, '', "Phone number is empty string" );
+
+ ok( $rec->load_by_cols( Phone => 0 ), "Loaded the record" );
+ is( $rec->name, 'ZeroPhone', "ZeroPhone record" );
+ is( $rec->phone, 0, "Phone number is zero" );
+
+ # XXX: next thing fails, looks like operator is mandatory
+ # ok($rec->load_by_cols( Phone => { value => 0 } ), "Loaded the record");
+ ok( $rec->load_by_cols(
+ Phone => { operator => '=', value => 0 }
+ ),
+ "Loaded the record"
+ );
+ is( $rec->name, 'ZeroPhone', "ZeroPhone record" );
+ is( $rec->phone, 0, "Phone number is zero" );
+ }
+
+ Jifty::DBI::Record::Cachable->flush_cache;
+
+ { # case insensetive columns names
+ my $rec = TestApp::Address->new( handle => $handle );
+ ok( $rec->load_by_cols( Name => 'Jesse' ), "Loaded the record" );
+ is( $rec->name, 'Jesse', "loaded record" );
+
+ my $rec_cache = TestApp::Address->new( handle => $handle );
+ my ( $status, $msg )
+ = $rec_cache->load_by_cols( name => 'Jesse' );
+ ok( $status, 'loaded record' );
+ is( $rec_cache->id, $rec->id, 'the same record as we created' );
+ is( $msg, 'Fetched from cache', 'we fetched record from cache' );
+ }
+
+ Jifty::DBI::Record::Cachable->flush_cache;
+
+ cleanup_schema( 'TestApp::Address', $handle );
+ }
+} # SKIP, foreach blocks
+
+1;
+
+package TestApp::Address;
+use base qw/Jifty::DBI::Record::Cachable/;
+
+sub schema_mysql {
+ <<EOF;
+CREATE TEMPORARY table addresses (
+ id integer AUTO_INCREMENT,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+ <<EOF;
+CREATE TEMPORARY table addresses (
+ id serial PRIMARY KEY,
+ name varchar,
+ phone varchar,
+ address varchar,
+ employee_id integer
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+ <<EOF;
+CREATE table addresses (
+ id integer primary key,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8))
+EOF
+
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE addresses_seq",
+ "CREATE TABLE addresses (
+ id integer CONSTRAINT addresses_key PRIMARY KEY,
+ name varchar(36),
+ phone varchar(18),
+ employee_id integer
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE addresses_seq",
+ "DROP TABLE addresses",
+] }
+
+1;
+
+package TestApp::Address;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+ use Jifty::DBI::Record schema {
+ column name => type is 'varchar(14)';
+
+ column phone => type is 'varchar(18)';
+
+ column
+ address => type is 'varchar(50)',
+ default is '';
+
+ column employee_id => type is 'int(8)';
+ }
+}
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 9;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $emp = TestApp::Employee->new( handle => $handle );
+ my $e_id = $emp->create( Name => 'RUZ' );
+ ok($e_id, "Got an id for the new emplyee");
+ my $phone = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone, 'TestApp::Phone', "it's a TestApp::Phone");
+ my $p_id = $phone->create( employee => $e_id, phone => '+7(903)264-03-51');
+ # XXX: test fails if next string is commented
+ is($p_id, 1, "Loaded record $p_id");
+ $phone->load( $p_id );
+
+ my $obj = $phone->employee( handle => $handle );
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->name, 'RUZ');
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE table employees (
+ id integer primary key,
+ name varchar(36)
+)
+}, q{
+CREATE table phones (
+ id integer primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+) }
+]
+}
+
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY table employees (
+ id integer AUTO_INCREMENT primary key,
+ name varchar(36)
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id integer AUTO_INCREMENT primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY table employees (
+ id serial PRIMARY KEY,
+ name varchar
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id serial PRIMARY KEY,
+ employee integer references employees(id),
+ phone varchar
+)
+} ]
+}
+
+
+
+sub schema_oracle { [
+ "CREATE SEQUENCE employees_seq",
+ "CREATE TABLE employees (
+ id integer CONSTRAINT employees_key PRIMARY KEY,
+ Name varchar(36)
+ )",
+ "CREATE SEQUENCE phones_seq",
+ "CREATE TABLE phones (
+ id integer CONSTRAINT phones_key PRIMARY KEY,
+ employee integer NOT NULL,
+ phone varchar(18)
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE employees_seq",
+ "DROP TABLE employees",
+ "DROP SEQUENCE phones_seq",
+ "DROP TABLE phones",
+] }
+
+
+package TestApp::Employee;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column name => type is 'varchar(18)';
+ }
+}
+
+1;
+
+
+
+package TestApp::Phone;
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column employee => references TestApp::Employee;
+ column phone => type is 'varchar(18)';
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+use warnings;
+
+use File::Spec;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 47;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret, 'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $count_users = init_data( 'TestApp::User', $handle );
+ ok( $count_users, "init users data" );
+ my $count_groups = init_data( 'TestApp::Group', $handle );
+ ok( $count_groups, "init groups data" );
+ my $count_us2gs = init_data( 'TestApp::UserToGroup', $handle );
+ ok( $count_us2gs, "init users&groups relations data" );
+
+ my $clean_obj = TestApp::UserCollection->new( handle => $handle );
+ my $users_obj = $clean_obj->clone;
+ is_deeply( $users_obj, $clean_obj, 'after Clone looks the same');
+
+diag "inner JOIN with ->join method" if $ENV{'TEST_VERBOSE'};
+{
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->join(
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id'
+ );
+ ok( $alias, "Join returns alias" );
+ TODO: {
+ local $TODO = "is joined doesn't mean is limited, count returns 0";
+ is( $users_obj->count, 3, "three users are members of the groups" );
+ }
+ # fake limit to check if join actually joins
+ $users_obj->limit( column => 'id', operator => 'IS NOT', value => 'NULL' );
+ is( $users_obj->count, 3, "three users are members of the groups" );
+}
+
+diag "LEFT JOIN with ->join method" if $ENV{'TEST_VERBOSE'};
+{
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->join(
+ type => 'LEFT',
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id'
+ );
+ ok( $alias, "Join returns alias" );
+ $users_obj->limit( alias => $alias, column => 'id', operator => 'IS', value => 'NULL' );
+ ok( $users_obj->build_select_query =~ /LEFT JOIN/, 'LJ is not optimized away');
+ is( $users_obj->count, 1, "user is not member of any group" );
+ is( $users_obj->first->id, 3, "correct user id" );
+}
+
+diag "LEFT JOIN with IS NOT NULL on the right side" if $ENV{'TEST_VERBOSE'};
+{
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->join(
+ type => 'LEFT',
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id'
+ );
+ ok( $alias, "Join returns alias" );
+ $users_obj->limit( alias => $alias, column => 'id', operator => 'IS NOT', value => 'NULL' );
+ ok( $users_obj->build_select_query !~ /LEFT JOIN/, 'LJ is optimized away');
+ is( $users_obj->count, 3, "users whos is memebers of at least one group" );
+}
+
+diag "LEFT JOIN with ->join method and using alias" if $ENV{'TEST_VERBOSE'};
+{
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->new_alias( 'user_to_groups' );
+ ok( $alias, "new alias" );
+ is($users_obj->join(
+ type => 'LEFT',
+ column1 => 'id',
+ alias2 => $alias,
+ column2 => 'user_id' ),
+ $alias, "joined table"
+ );
+ $users_obj->limit( alias => $alias, column => 'id', operator => 'IS', value => 'NULL' );
+ ok( $users_obj->build_select_query =~ /LEFT JOIN/, 'LJ is not optimized away');
+ is( $users_obj->count, 1, "user is not member of any group" );
+}
+
+diag "main <- alias <- join" if $ENV{'TEST_VERBOSE'};
+{
+ # The join depends on the alias, we should build joins with correct order.
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->new_alias( 'user_to_groups' );
+ ok( $alias, "new alias" );
+ ok( $users_obj->_is_joined, "object with aliases is joined");
+ $users_obj->limit( column => 'id', value => "$alias.user_id", quote_value => 0);
+ ok( my $groups_alias = $users_obj->join(
+ alias1 => $alias,
+ column1 => 'group_id',
+ table2 => 'groups',
+ column2 => 'id',
+ ),
+ "joined table"
+ );
+ $users_obj->limit( alias => $groups_alias, column => 'Name', value => 'Developers' );
+ diag $users_obj->build_select_query;
+ is( $users_obj->count, 3, "three members" );
+}
+
+diag "main <- alias <- join into main" if $ENV{'TEST_VERBOSE'};
+{
+ # DBs' parsers don't like: FROM X, Y JOIN C ON C.f = X.f
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+
+ ok( my $groups_alias = $users_obj->new_alias( 'groups' ), "new alias" );
+ ok( my $g2u_alias = $users_obj->join(
+ alias1 => 'main',
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id',
+ ),
+ "joined table"
+ );
+ $users_obj->limit( alias => $g2u_alias, column => 'group_id', value => "$groups_alias.id", quote_value => 0);
+ $users_obj->limit( alias => $groups_alias, column => 'Name', value => 'Developers' );
+ #diag $users_obj->build_select_query;
+ is( $users_obj->count, 3, "three members" );
+}
+
+diag "cascaded LEFT JOIN optimization" if $ENV{'TEST_VERBOSE'};
+{
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->join(
+ type => 'LEFT',
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id'
+ );
+ ok( $alias, "Join returns alias" );
+ $alias = $users_obj->join(
+ type => 'LEFT',
+ alias1 => $alias,
+ column1 => 'group_id',
+ table2 => 'groups',
+ column2 => 'id'
+ );
+ $users_obj->limit( alias => $alias, column => 'id', operator => 'IS NOT', value => 'NULL' );
+ ok( $users_obj->build_select_query !~ /LEFT JOIN/, 'both LJs are optimized away');
+ is( $users_obj->count, 3, "users whos is memebers of at least one group" );
+}
+
+diag "LEFT JOIN optimization and OR clause" if $ENV{'TEST_VERBOSE'};
+{
+ $users_obj->clean_slate;
+ is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object');
+ ok( !$users_obj->_is_joined, "new object isn't joined");
+ my $alias = $users_obj->join(
+ type => 'LEFT',
+ column1 => 'id',
+ table2 => 'user_to_groups',
+ column2 => 'user_id'
+ );
+ $users_obj->open_paren('my_clause');
+ $users_obj->limit(
+ subclause => 'my_clause',
+ alias => $alias,
+ column => 'id',
+ operator => 'IS NOT',
+ value => 'NULL'
+ );
+ $users_obj->limit(
+ subclause => 'my_clause',
+ entry_aggregator => 'OR',
+ column => 'id',
+ value => 3
+ );
+ $users_obj->close_paren('my_clause');
+ ok( $users_obj->build_select_query =~ /LEFT JOIN/, 'LJ is not optimized away');
+ is( $users_obj->count, 4, "all users" );
+}
+
+ cleanup_schema( 'TestApp', $handle );
+
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE table users (
+ id integer primary key,
+ login varchar(36)
+) },
+q{
+CREATE table user_to_groups (
+ id integer primary key,
+ user_id integer,
+ group_id integer
+) },
+q{
+CREATE table groups (
+ id integer primary key,
+ name varchar(36)
+) },
+]
+}
+
+sub schema_mysql {
+[
+q{
+CREATE TEMPORARY table users (
+ id integer primary key AUTO_INCREMENT,
+ login varchar(36)
+) },
+q{
+CREATE TEMPORARY table user_to_groups (
+ id integer primary key AUTO_INCREMENT,
+ user_id integer,
+ group_id integer
+) },
+q{
+CREATE TEMPORARY table groups (
+ id integer primary key AUTO_INCREMENT,
+ name varchar(36)
+) },
+]
+}
+
+sub schema_pg {
+[
+q{
+CREATE TEMPORARY table users (
+ id serial primary key,
+ login varchar(36)
+) },
+q{
+CREATE TEMPORARY table user_to_groups (
+ id serial primary key,
+ user_id integer,
+ group_id integer
+) },
+q{
+CREATE TEMPORARY table groups (
+ id serial primary key,
+ name varchar(36)
+) },
+]
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE users_seq",
+ "CREATE table users (
+ id integer CONSTRAINT users_Key PRIMARY KEY,
+ login varchar(36)
+ )",
+ "CREATE SEQUENCE user_to_groups_seq",
+ "CREATE table user_to_groups (
+ id integer CONSTRAINT user_to_groups_Key PRIMARY KEY,
+ user_id integer,
+ group_id integer
+ )",
+ "CREATE SEQUENCE groups_seq",
+ "CREATE table groups (
+ id integer CONSTRAINT groups_Key PRIMARY KEY,
+ name varchar(36)
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE users_seq",
+ "DROP table users",
+ "DROP SEQUENCE groups_seq",
+ "DROP table groups",
+ "DROP SEQUENCE user_to_groups_seq",
+ "DROP table user_to_groups",
+] }
+
+package TestApp::User;
+
+use base qw/Jifty::DBI::Record/;
+
+BEGIN {
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+ column login => type is 'varchar(36)';
+};
+}
+
+sub _init {
+ my $self = shift;
+ $self->table('users');
+ $self->SUPER::_init( @_ );
+}
+
+sub init_data {
+ return (
+ [ 'login' ],
+
+ [ 'ivan' ],
+ [ 'john' ],
+ [ 'bob' ],
+ [ 'aurelia' ],
+ );
+}
+
+package TestApp::UserCollection;
+
+use base qw/Jifty::DBI::Collection/;
+
+sub _init {
+ my $self = shift;
+ $self->table('users');
+ return $self->SUPER::_init( @_ );
+}
+
+1;
+
+package TestApp::Group;
+
+use base qw/Jifty::DBI::Record/;
+
+BEGIN {
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+ column name => type is 'varchar(36)';
+};
+}
+
+sub _init {
+ my $self = shift;
+ $self->table('groups');
+ return $self->SUPER::_init( @_ );
+}
+
+sub init_data {
+ return (
+ [ 'name' ],
+
+ [ 'Developers' ],
+ [ 'Sales' ],
+ [ 'Support' ],
+ );
+}
+
+package TestApp::GroupCollection;
+
+use base qw/Jifty::DBI::Collection/;
+
+sub _init {
+ my $self = shift;
+ $self->table('groups');
+ return $self->SUPER::_init( @_ );
+}
+
+1;
+
+package TestApp::UserToGroup;
+
+use base qw/Jifty::DBI::Record/;
+
+BEGIN {
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+ column user_id => type is 'int(11)';
+ column group_id => type is 'int(11)';
+};
+}
+
+sub init_data {
+ return (
+ [ 'group_id', 'user_id' ],
+# dev group
+ [ 1, 1 ],
+ [ 1, 2 ],
+ [ 1, 4 ],
+# sales
+# [ 2, 0 ],
+# support
+ [ 3, 1 ],
+ );
+}
+
+package TestApp::UserToGroupCollection;
+use base qw/Jifty::DBI::Collection/;
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+use Jifty::DBI::Handle;
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 4;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = Jifty::DBI::Handle->new;
+ ok($handle, "Made a generic handle");
+
+ is(ref $handle, 'Jifty::DBI::Handle', "It's really generic");
+
+ connect_handle_with_driver( $handle, $d );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ isa_ok($handle, "Jifty::DBI::Handle::$d", "Specialized Handle");
+ disconnect_handle_with_driver( $handle, $d );
+}} # SKIP, foreach blocks
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN { require 't/utils.pl' }
+
+use constant TESTS_PER_DRIVER => 1;
+
+our (@available_drivers);
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+# plan tests => $total;
+
+BEGIN {
+ eval { require Cache::Memcached; Cache::Memcached->import; };
+ plan skip_all => 'Cache::Memcached not available' if $@;
+}
+
+my $memd = Cache::Memcached->new({TestApp::Address->memcached_config});
+
+plan skip_all => 'Memcached apparently not running' unless $memd->set('test_testval', 0, 1);
+
+plan 'no_plan';
+
+for my $d (@available_drivers) {
+ SKIP: {
+ unless ( has_schema( 'TestApp::Address', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless ( should_test($d) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle($d);
+ connect_handle($handle);
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::Address', $handle );
+ isa_ok( $ret, 'DBI::st',
+ "Inserted the schema. got a statement handle back" );}
+
+
+ # Create a record, load from cache
+ my $rec = TestApp::Address->new( handle => $handle );
+
+ my ($id) = $rec->create( Name => 'Jesse', Phone => '617 124 567' );
+ ok( $id, "Created record #$id" );
+
+ ok( $rec->load($id), "Loaded the record" );
+ is( $rec->id, $id, "The record has its id" );
+ is( $rec->name, 'Jesse', "The record's name is Jesse" );
+
+ my $rec_cache = TestApp::Address->new( handle => $handle );
+ my ( $status, $msg ) = $rec_cache->load_by_cols( id => $id );
+ ok( $status, 'loaded record' );
+ is( $rec_cache->id, $id, 'the same record as we created' );
+ is( $msg, 'Fetched from cache', 'we fetched record from cache' );
+ is( $rec_cache->phone, '617 124 567', "Loaded the phone number correctly");
+
+ # Check mutation
+ $rec->set_phone('555 543 6789');
+ is($rec->phone, '555 543 6789');
+
+ $rec = TestApp::Address->new( handle => $handle );
+ $rec->load($id);
+ is($rec->phone, '555 543 6789', "Loaded changed data from cache OK");
+}}
+
+package TestApp::Address;
+use base qw/Jifty::DBI::Record::Memcached/;
+
+# Make this unique per run and database, since otherwise we'll get
+# stale caches when we run for the 2nd and future drivers
+
+sub cache_key_prefix {
+ my $self = shift;
+ my $driver = ref($self->_handle);
+ $driver = lc $1 if $driver =~ /::(\w+)$/;
+ return "jifty-test-$$-$driver";
+}
+
+sub schema_mysql {
+ <<EOF;
+CREATE TEMPORARY table addresses (
+ id integer AUTO_INCREMENT,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+ <<EOF;
+CREATE TEMPORARY table addresses (
+ id serial PRIMARY KEY,
+ name varchar,
+ phone varchar,
+ address varchar,
+ employee_id integer
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+ <<EOF;
+CREATE table addresses (
+ id integer primary key,
+ name varchar(36),
+ phone varchar(18),
+ address varchar(50),
+ employee_id int(8))
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+
+ column name => type is 'varchar(14)';
+
+ column phone => type is 'varchar(18)';
+
+ column
+ address => type is 'varchar(50)',
+ default is '';
+
+ column employee_id => type is 'int(8)';
+ }
+}
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+plan tests => 6;
+# test for Jifty::DBI::Filter class only
+# create new t/06filter_*.t files for specific filters
+
+# DB independat tests
+use_ok('Jifty::DBI::Filter');
+my $filter = new Jifty::DBI::Filter;
+isa_ok( $filter, 'Jifty::DBI::Filter' );
+is( $filter->column, undef, "empty column value" );
+is( $filter->value_ref, undef, "empty value reference" );
+
+$filter->column( 'my column' );
+is( $filter->column, 'my column', "successfuly set column" );
+$filter->value_ref( 'my value_ref' );
+is( $filter->value_ref, 'my value_ref', "successfuly set value_ref" );
+
+# methods do nothing, but just in case
+$filter->decode;
+$filter->encode;
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 18;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+use DateTime ();
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::User', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my $now = time;
+ my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch;
+ my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' );
+ my $dt = DateTime->from_epoch( epoch => $now );
+ my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+ isa_ok($rec->event_on, 'DateTime' );
+ is( $rec->event_on->epoch, $today, "Correct value");
+ isa_ok($rec->event_stops, 'DateTime' );
+ is( $rec->event_stops->minute, $min_of_day->minute, "Correct value");
+ is( $rec->event_stops->hour, $min_of_day->hour, "Correct value");
+
+ # undef/NULL
+ $rec->set_created;
+ is($rec->created, undef, "Set undef value" );
+
+ # Create using default undef
+ my $rec2 = TestApp::User->new( handle => $handle );
+ isa_ok($rec2, 'Jifty::DBI::Record');
+ is($rec2->created, undef, 'Default of undef');
+
+ # from string
+ require POSIX;
+ $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) );
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ created timestamp,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+
+ use Jifty::DBI::Record schema {
+ column created =>
+ type is 'datetime',
+ filters are qw/Jifty::DBI::Filter::DateTime/,
+ default is undef;
+
+ column event_on =>
+ type is 'date',
+ filters are qw/Jifty::DBI::Filter::Date/;
+
+ column event_stops =>
+ type is 'time',
+ filters are qw/Jifty::DBI::Filter::Time/;
+ }
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 9;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+my $complex_data = {
+ foo => 'bar',
+ baz => [ 1, 2, 3 ],
+};
+
+foreach my $d (@available_drivers) {
+SKIP: {
+ unless (has_schema('TestApp::User', $d)) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+
+ unless (should_test($d)) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle($d);
+ connect_handle($handle);
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {
+ my $ret = init_schema('TestApp::User', $handle);
+ isa_ok($ret, 'DBI::st', 'init schema');
+ }
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my ($id) = $rec->create( my_data => $complex_data );
+ ok($id, 'created record');
+ ok($rec->load($id), 'loaded record');
+ is($rec->id, $id, 'record id matches');
+ is(ref $rec->my_data, 'HASH', 'my_data is a HASH');
+ is_deeply($rec->my_data, $complex_data, 'my_data matches initial data');
+
+ # undef/NULL
+ $rec->set_my_data;
+ is($rec->my_data, undef, 'set undef value');
+
+ cleanup_schema('TestApp', $handle);
+ disconnect_handle($handle);
+}
+}
+
+package TestApp::User;
+use base qw/ Jifty::DBI::Record /;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ my_data blob
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ my_data blob
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ my_data bytea
+)
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+ use Jifty::DBI::Record schema {
+ column my_data =>
+ type is 'blob',
+ filters are qw/ Jifty::DBI::Filter::Storable /;
+ }
+}
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 15;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ unless( has_schema( 'TestApp::User', $handle ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER - 1;
+ }
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ # name would be truncated
+ my($id) = $rec->create( login => "obra", name => "Jesse Vincent" );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is($rec->login, 'obra', "Login is not truncated" );
+ is($rec->name, 'Jesse Vinc', "But name is truncated" );
+
+ # UTF-8 string with flag set
+ use Encode ();
+ ($id) = $rec->create( login => "\x{442}\x{435}\x{441}\x{442}", name => "test" );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is(Encode::decode_utf8($rec->login), "\x{442}\x{435}", "Login is truncated to two UTF-8 chars" );
+ is($rec->name, 'test', "Name is not truncated" );
+
+# this test fails on Pg because it doesn't like data that
+# has bytes in unsupported encoding, we should use 'bytea'
+# type for this test, but we don't have coverage for this
+# # scalar with cp1251 octets
+# $str = "\x{442}\x{435}\x{441}\x{442}\x{442}\x{435}\x{441}\x{442}";
+# $str = Encode::encode('cp1251', $str);
+# ($id) = $rec->create( login => $str, name => "test" );
+# ok($id, "Successfuly created ticket");
+# ok($rec->load($id), "Loaded the record");
+# is($rec->id, $id, "The record has its id");
+# is($rec->login, "\xf2\xe5\xf1\xf2\xf2", "Login is truncated to five octets" );
+# is($rec->name, 'test', "Name is not truncated" );
+
+ # check that filter also work for set_* operations
+ $rec->set_login( 'ruz' );
+ $rec->set_name( 'Ruslan Zakirov' );
+ is($rec->login, "ruz", "Login is not truncated" );
+ is($rec->name, 'Ruslan Zak', "Name is truncated" );
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ login char(5),
+ name varchar(10),
+ disabled int(4) default 0
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ login char(5),
+ name varchar(10),
+ disabled int(4) default 0
+)
+EOF
+
+}
+
+sub schema_mysql_4_1 {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ login binary(5),
+ name varbinary(10),
+ disabled int(4) default 0
+)
+EOF
+
+}
+
+# XXX: Pg adds trailing spaces to CHAR columns
+# when other don't, must be fixed for consistency
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ login varchar(5),
+ name varchar(10),
+ disabled integer default 0
+)
+EOF
+
+}
+
+1;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+ use Jifty::DBI::Record schema {
+ # special small lengths to test truncation
+ column login =>
+ type is 'varchar(5)',
+ default is '';
+
+ column name =>
+ type is 'varchar(10)',
+ max_length is 10,
+ default is '';
+
+ column disabled =>
+ type is 'int(4)',
+ max_length is 4,
+ default is 0;
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 24;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+use DateTime ();
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::User', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ $handle->input_filters( 'Jifty::DBI::Filter::utf8' );
+ is( ($handle->input_filters)[0], 'Jifty::DBI::Filter::utf8', 'Filter was added' );
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ # "test" in Russian
+ my $str = "\x{442}\x{435}\x{441}\x{442}";
+
+ my($id) = $rec->create( signature => $str );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ ok( Encode::is_utf8($rec->signature), "Value is UTF-8" );
+ is( $rec->signature, $str, "Value is the same" );
+
+ # correct data with no UTF-8 flag
+ my $nstr = Encode::encode_utf8( $str );
+ ($id) = $rec->create( signature => $nstr );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ ok( Encode::is_utf8($rec->signature), "Value is UTF-8" );
+ is( $rec->signature, $str, "Value is the same" );
+
+ # cut string in the middle of the unicode char
+ # and drop flag, leave only first char and
+ # a half of the second so in result we will
+ # get only one char
+ $nstr = do{ use bytes; substr( $str, 0, 3 ) };
+ ($id) = $rec->create( signature => $nstr );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ ok( Encode::is_utf8($rec->signature), "Value is UTF-8" );
+ is( $rec->signature, "\x{442}", "Value is correct" );
+
+ # UTF-8 string with flag unset and enabeld trancation
+ # truncation should cut third char, but utf8 filter should
+ # replace it with \x{fffd} code point
+ $rec->set_name( Encode::encode_utf8($str) );
+ is($rec->name, "\x{442}\x{435}",
+ "Name was truncated to two UTF-8 chars"
+ );
+
+ # create with undef value, no utf8 or truncate magic
+ ($id) = $rec->create( signature => undef );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is($rec->signature, undef, "successfuly stored and fetched undef");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ name varchar(5),
+ signature varchar(100)
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ name varchar(5),
+ signature varchar(100)
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ name varchar(5),
+ signature varchar(100)
+)
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column name => type is 'varchar(5)';
+ column signature => type is 'varchar(100)';
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 9;
+
+eval "use YAML::Syck ()";
+if ($@) {
+ eval "use YAML ()";
+ if ($@) {
+ plan skip_all => "neither YAML::Syck nor YAML is installed";
+ }
+}
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+my $complex_data = {
+ foo => 'bar',
+ baz => [ 1, 2, 3 ],
+};
+
+foreach my $d (@available_drivers) {
+SKIP: {
+ unless (has_schema('TestApp::User', $d)) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+
+ unless (should_test($d)) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle($d);
+ connect_handle($handle);
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {
+ my $ret = init_schema('TestApp::User', $handle);
+ isa_ok($ret, 'DBI::st', 'init schema');
+ }
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my ($id) = $rec->create( my_data => $complex_data );
+ ok($id, 'created record');
+ ok($rec->load($id), 'loaded record');
+ is($rec->id, $id, 'record id matches');
+ is(ref $rec->my_data, 'HASH', 'my_data is a HASH');
+ is_deeply($rec->my_data, $complex_data, 'my_data matches initial data');
+
+ # undef/NULL
+ $rec->set_my_data;
+ is($rec->my_data, undef, 'set undef value');
+
+ cleanup_schema('TestApp', $handle);
+ disconnect_handle($handle);
+}
+}
+
+package TestApp::User;
+use base qw/ Jifty::DBI::Record /;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ my_data text
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ my_data text
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ my_data text
+)
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+ use Jifty::DBI::Record schema {
+ column my_data =>
+ type is 'text',
+ filters are qw/ Jifty::DBI::Filter::YAML /;
+ }
+}
+
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use version;
+
+use constant TESTS_PER_DRIVER => 48;
+our @available_drivers;
+
+BEGIN {
+ require("t/utils.pl");
+ my $total = 3 + scalar(@available_drivers) * TESTS_PER_DRIVER;
+ if( not eval { require DBIx::DBSchema } ) {
+ plan skip_all => "DBIx::DBSchema not installed";
+ } else {
+ plan tests => $total;
+ }
+}
+
+BEGIN {
+ use_ok("Jifty::DBI::SchemaGenerator");
+ use_ok("Jifty::DBI::Handle");
+}
+
+require_ok("t/testmodels.pl");
+
+foreach my $d ( @available_drivers ) {
+ SKIP: {
+ my $address_schema = has_schema('Sample::Address',$d);
+ my $employee_schema = has_schema('Sample::Employee',$d);
+ unless ($address_schema && $employee_schema) {
+ skip "need to work on $d", TESTS_PER_DRIVER;
+ }
+
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver $d", TESTS_PER_DRIVER;
+ }
+
+ # Test that declarative schema syntax automagically sets validators
+ # correctly.
+ ok( Sample::Address->can('validate_name'), 'found validate_name' );
+ my $validator = Sample::Address->column('name')->validator;
+ ok( $validator, 'found $column->validator' );
+ is( $validator, \&Sample::Address::validate_name, 'validators match' );
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle, "Jifty::DBI::Handle::$d");
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $SG = Jifty::DBI::SchemaGenerator->new($handle);
+
+ isa_ok($SG, 'Jifty::DBI::SchemaGenerator');
+
+ isa_ok($SG->_db_schema, 'DBIx::DBSchema');
+
+ is($SG->create_table_sql_text, '', "no tables means no sql");
+
+ my $ret = $SG->add_model('Sample::This::Does::Not::Exist');
+
+ ok(not ($ret), "couldn't add model from nonexistent class");
+
+ like($ret->error_message, qr/Error making new object from Sample::This::Does::Not::Exist/,
+ "couldn't add model from nonexistent class");
+
+ is($SG->create_table_sql_text, '', "no tables means no sql");
+
+ $ret = $SG->add_model('Sample::Address');
+
+ ok($ret != 0, "added model from real class");
+
+ is_ignoring_space($SG->create_table_sql_text,
+ Sample::Address->$address_schema,
+ "got the right Address schema for $d");
+
+ my $employee = Sample::Employee->new;
+
+ isa_ok($employee, 'Sample::Employee');
+ can_ok($employee, qw( label type dexterity ));
+
+ $ret = $SG->add_model($employee);
+
+ ok($ret != 0, "added model from an instantiated object");
+
+ is_ignoring_space($SG->create_table_sql_text,
+ Sample::Address->$address_schema. Sample::Employee->$employee_schema,
+ "got the right Address+Employee schema for $d");
+
+ my $manually_make_text = join ' ', map { "$_;" } $SG->create_table_sql_statements;
+ is_ignoring_space($SG->create_table_sql_text,
+ $manually_make_text,
+ 'create_table_sql_text is the statements in create_table_sql_statements');
+
+ my $version_024_min = version->new('0.2.4');
+ my $version_024_max = version->new('0.2.8');
+
+ for my $version (qw/ 0.2.0 0.2.4 0.2.6 0.2.8 0.2.9 /) {
+
+ Sample::Address->schema_version($version);
+
+ my $SG = Jifty::DBI::SchemaGenerator->new($handle, $version);
+ $SG->add_model('Sample::Address');
+
+ my $street_added
+ = version->new($version) >= $version_024_min
+ && version->new($version) < $version_024_max;
+
+ ok(Sample::Address->COLUMNS->{id}->active, 'id active');
+ ok(Sample::Address->COLUMNS->{employee_id}->active, 'employee_id active');
+ ok(Sample::Address->COLUMNS->{name}->active, 'name active');
+ ok(Sample::Address->COLUMNS->{phone}->active, 'phone active');
+ if ($street_added) {
+ ok(Sample::Address->COLUMNS->{street}->active, 'street active');
+ }
+
+ else {
+ ok(!Sample::Address->COLUMNS->{street}->active, 'street not active');
+ }
+
+ my $address_version_schema = $street_added ? "${address_schema}_024"
+ : $address_schema;
+
+ is_ignoring_space($SG->create_table_sql_text,
+ Sample::Address->$address_version_schema,
+ "got the right Address schema for $d version $version");
+ }
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+sub is_ignoring_space {
+ my $a = shift;
+ my $b = shift;
+
+ for my $item ( $b, $a ) {
+ $item =~ s/^\s+//;
+ $item =~ s/\s+$//;
+ $item =~ s/\s+/ /g;
+ $item =~ s/\s+;/;/g;
+ $item =~ s/\(\s+(.*?)\s+\)/($1)/g;
+
+ unshift @_, $item;
+ }
+ goto &is;
+}
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 67;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db', "Got handle for $d");
+
+ {my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $emp = TestApp::Employee->new( handle => $handle );
+ my $e_id = $emp->create( Name => 'RUZ' );
+ ok($e_id, "Got an id for the new employee: $e_id");
+ $emp->load($e_id);
+ is($emp->id, $e_id);
+
+ my $phone_collection = $emp->phones;
+ isa_ok($phone_collection, 'TestApp::PhoneCollection');
+
+ {
+ my ($val, $msg);
+ eval { ($val, $msg) = $emp->set_phones(1,2,3); };
+ ok(not($@), 'set does not die') or warn $@;
+ ok($@ !~ /^DBD::.*::st execute failed: /,
+ "no stacktrace emitted"
+ );
+ ok(! $val, $msg) or warn "msg: $msg";
+ ok($msg =~ m/Collection column '.*' not writable/,
+ '"not writable" message'
+ );
+ }
+
+ {
+ my $ph = $phone_collection->next;
+ is($ph, undef, "No phones yet");
+ }
+
+ my $phone = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone, 'TestApp::Phone');
+ my $p_id = $phone->create( employee => $e_id, phone => '+7(903)264-03-51');
+ is($p_id, 1, "Loaded phone $p_id");
+ $phone->load( $p_id );
+
+ my $obj = $phone->employee;
+
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->name, 'RUZ');
+
+ {
+ $phone_collection->redo_search;
+ my $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'found first phone');
+ is($ph->phone, '+7(903)264-03-51');
+ is($phone_collection->next, undef);
+ }
+
+ # tests for no object mapping
+ my $val = $phone->phone;
+ is( $val, '+7(903)264-03-51', 'Non-object things still work');
+
+ my $emp2 = TestApp::Employee->new( handle => $handle );
+ isa_ok($emp2, 'TestApp::Employee');
+ my $e2_id = $emp2->create( name => 'Dave' );
+ ok($e2_id, "Got an id for the new employee: $e2_id");
+ $emp2->load($e2_id);
+ is($emp2->id, $e2_id);
+
+ my $phone2_collection = $emp2->phones;
+ isa_ok($phone2_collection, 'TestApp::PhoneCollection');
+
+ {
+ my $ph = $phone2_collection->next;
+ is($ph, undef, "new emp has no phones");
+ }
+
+ {
+ $phone_collection->redo_search;
+ my $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'first emp still has phone');
+ is($ph->phone, '+7(903)264-03-51');
+ is($phone_collection->next, undef);
+ }
+
+ $phone->set_employee($e2_id);
+
+
+ my $emp3 = $phone->employee;
+ isa_ok($emp3, 'TestApp::Employee');
+ is($emp3->name, 'Dave', 'changed employees by ID');
+ is($emp3->id, $emp2->id);
+
+ {
+ $phone_collection->redo_search;
+ is($phone_collection->next, undef, "first emp lost phone");
+ }
+
+ {
+ $phone2_collection->redo_search;
+ my $ph = $phone2_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'new emp stole the phone');
+ is($ph->phone, '+7(903)264-03-51');
+ is($phone2_collection->next, undef);
+ }
+
+
+ $phone->set_employee($emp);
+
+ my $emp4 = $phone->employee;
+ isa_ok($emp4, 'TestApp::Employee');
+ is($emp4->name, 'RUZ', 'changed employees by obj');
+ is($emp4->id, $emp->id);
+
+ {
+ $phone2_collection->redo_search;
+ is($phone2_collection->next, undef, "second emp lost phone");
+ }
+
+ {
+ $phone_collection->redo_search;
+ my $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'first emp stole the phone');
+ is($ph->phone, '+7(903)264-03-51');
+ is($phone_collection->next, undef);
+ }
+
+ my $phone2 = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone2, 'TestApp::Phone');
+ my $p2_id = $phone2->create( employee => $e_id, phone => '123456');
+ ok($p2_id, "Loaded phone $p2_id");
+ $phone2->load( $p2_id );
+
+ {
+ $phone_collection->redo_search;
+ my $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'still has this phone');
+ is($ph->phone, '+7(903)264-03-51');
+ $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p2_id, 'now has that phone');
+ is($ph->phone, '123456');
+ is($phone_collection->next, undef);
+ }
+
+ # Test Create with obj as argument
+ my $phone3 = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone3, 'TestApp::Phone');
+ my $p3_id = $phone3->create( employee => $emp, phone => '7890');
+ ok($p3_id, "Loaded phone $p3_id");
+ $phone3->load( $p3_id );
+
+ {
+ $phone_collection->redo_search;
+ my $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'still has this phone');
+ is($ph->phone, '+7(903)264-03-51');
+ $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p2_id, 'still has that phone');
+ is($ph->phone, '123456');
+ $ph = $phone_collection->next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p3_id, 'even has this other phone');
+ is($ph->phone, '7890');
+ is($phone_collection->next, undef);
+ }
+
+
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE table employees (
+ id integer primary key,
+ name varchar(36)
+)
+}, q{
+CREATE table phones (
+ id integer primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+) }
+]
+}
+
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY table employees (
+ id integer AUTO_INCREMENT primary key,
+ name varchar(36)
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id integer AUTO_INCREMENT primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY table employees (
+ id serial PRIMARY KEY,
+ name varchar
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id serial PRIMARY KEY,
+ employee integer references employees(id),
+ phone varchar
+)
+} ]
+}
+
+package TestApp::PhoneCollection;
+use base qw/Jifty::DBI::Collection/;
+
+sub table {
+ my $self = shift;
+ my $tab = $self->new_item->table();
+ return $tab;
+}
+
+package TestApp::Employee;
+use base qw/Jifty::DBI::Record/;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column name => type is 'varchar';
+ column phones => references TestApp::PhoneCollection by 'employee';
+ }
+}
+
+sub _value {
+ my $self = shift;
+ my $x = ($self->__value(@_));
+ return $x;
+}
+
+
+package TestApp::Phone;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {;
+ column employee => refers_to TestApp::Employee; # "refers_to" is the old synonym to "references"
+ column phone => type is 'varchar';
+ }
+}
+
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+use constant TESTS_PER_DRIVER => 41;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+#plan tests => $total;
+plan tests => TESTS_PER_DRIVER;
+
+foreach my $d ('SQLite'){ # @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db', "Got handle for $d");
+
+ {my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+
+ my $emp = TestApp::Employee->new( handle => $handle );
+ my $e_id = $emp->create( Name => 'RUZ' );
+ ok($e_id, "Got an id for the new employee: $e_id");
+ $emp->load($e_id);
+ is($emp->id, $e_id);
+
+ my $phone_collection = $emp->phones;
+ isa_ok($phone_collection, 'TestApp::PhoneCollection');
+ {
+ my $phone = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone, 'TestApp::Phone');
+ my $p_id = $phone->create( employee => $e_id, phone => '+7(903)264-03-51');
+ is($p_id, 1, "Loaded phone $p_id");
+ $phone->load( $p_id );
+
+ my $obj = $phone->employee;
+
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->name, 'RUZ');
+ }
+
+ my $emp2 = TestApp::Employee->new( handle => $handle );
+ my $e2_id = $emp2->create( Name => 'JESSE' );
+ my $phone2 = TestApp::Phone->new( handle => $handle );
+ my $p2_id = $phone2->create( employee => $e2_id, phone => '+16173185823');
+
+ for (3..6){
+ my $i = $_;
+ diag("loading phone $i");
+ my $phone = TestApp::Phone->new( handle => $handle );
+ isa_ok( $phone, 'TestApp::Phone');
+ my $p_id = $phone->create( employee => $e_id, phone => "+1 $i");
+ is($p_id, $i, "Loaded phone $p_id");
+ $phone->load( $p_id );
+
+ my $obj = $phone->employee;
+
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->name, 'RUZ');
+
+
+ }
+
+ $handle->log_sql_statements(1);
+
+ my $collection
+ = TestApp::EmployeeCollection->new( handle => $handle );
+ my $phones_alias = $collection->join(
+ alias1 => 'main',
+ column1 => 'id',
+ table2 => 'phones',
+ column2 => 'employee'
+ );
+ $collection->prefetch( $phones_alias => 'phones'); #
+ $collection->limit( column => 'id', value => '1', operator => '>=' );
+ my $user = $collection->next;
+ is( $user->id, 1, "got our user" );
+ my $phones = $user->phones;
+ is( $phones->first->id, 1 );
+ is( $phones->count, 5 );
+
+
+ my $jesse = $collection->next;
+ is ($jesse->name, 'JESSE');
+ my $jphone = $jesse->phones;
+ is ($jphone->count,1);
+
+ my @statements = $handle->sql_statement_log;
+
+ is (scalar @statements, 1, "all that. just one sql statement");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE table employees (
+ id integer primary key,
+ name varchar(36)
+)
+}, q{
+CREATE table phones (
+ id integer primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+) }
+]
+}
+
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY table employees (
+ id integer AUTO_INCREMENT primary key,
+ name varchar(36)
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id integer AUTO_INCREMENT primary key,
+ employee integer NOT NULL,
+ phone varchar(18)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY table employees (
+ id serial PRIMARY KEY,
+ name varchar
+)
+}, q{
+CREATE TEMPORARY table phones (
+ id serial PRIMARY KEY,
+ employee integer references employees(id),
+ phone varchar
+)
+} ]
+}
+
+
+package TestApp::PhoneCollection;
+use base qw/Jifty::DBI::Collection/;
+
+sub table {
+ my $self = shift;
+ my $tab = $self->new_item->table();
+ return $tab;
+}
+
+
+package TestApp::Employee;
+use base qw/Jifty::DBI::Record/;
+
+sub _value {
+ my $self = shift;
+ my $x = ($self->__value(@_));
+ return $x;
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column name => type is 'varchar';
+ column phones => references TestApp::PhoneCollection by 'employee';
+ }
+}
+
+package TestApp::Phone;
+use base qw/Jifty::DBI::Record/;
+
+BEGIN {
+ use Jifty::DBI::Schema;
+ use Jifty::DBI::Record schema {
+ column employee => references TestApp::Employee;
+ column phone => type is 'varchar';
+ }
+}
+
+package TestApp::EmployeeCollection;
+
+use base qw/Jifty::DBI::Collection/;
+
+
+
+1;
--- /dev/null
+# Test methods in Jifty::DBI::Collection.
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+my $package;
+BEGIN {
+ $package = 'Jifty::DBI::Collection';
+ use_ok($package);
+}
+
+#
+# Test the _order_clause method
+#
+
+my $obj = bless {
+ order_by => [
+ {
+ alias => 'main',
+ column => 'name',
+ order => 'desc',
+ },
+ {
+ alias => 'foo',
+ column => 'id',
+ order => 'des',
+ },
+ {
+ alias => 'bar',
+ column => 'msg_session',
+ order => 'DesC',
+ }
+ ],
+}, $package;
+
+is $obj->_order_clause,
+ ' ORDER BY main.name DESC, foo.id DESC, bar.msg_session DESC ',
+ 'desc works';
+
+##
+
+$obj = bless {
+ order_by => [
+ {
+ alias => 'messages',
+ column => 'name',
+ order => 'asc',
+ },
+ {
+ alias => 'QQUsers',
+ column => 'sent',
+ order => 'ASC',
+ },
+ {
+ alias => 'stu_dents',
+ column => 'msg_session',
+ order => 'AsC',
+ }
+ ],
+}, $package;
+
+is $obj->_order_clause,
+ ' ORDER BY messages.name ASC, QQUsers.sent ASC, stu_dents.msg_session ASC ',
+ 'asc works';
+
+##
+
+$obj = bless {
+ order_by => [
+ {
+ alias => '',
+ column => 'name',
+ },
+ {
+ alias => 0,
+ column => 'sent',
+ },
+ {
+ alias => 'ab',
+ column => 'msg_session',
+ }
+ ],
+}, $package;
+
+is $obj->_order_clause,
+ ' ORDER BY name ASC, sent ASC, ab.msg_session ASC ',
+ 'empty and false aliases';
--- /dev/null
+# Test methods in Jifty::DBI::Handle::Pg
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+my $package;
+BEGIN {
+ $package = 'Jifty::DBI::Handle::Pg';
+ use_ok($package);
+}
+use Jifty::DBI::Collection;
+
+package Foo::Bar::Collection;
+our @ISA = 'Jifty::DBI::Collection';
+
+sub _preload_columns { "blah" }
+sub table { "bars" }
+
+package main;
+
+{
+ # Test sub distinct_query
+ my $collection = bless {
+ order_by => [
+ {
+ alias => 'main',
+ column => 'id',
+ order => 'asc',
+ },
+ {
+ alias => 'main',
+ column => 'name',
+ order => 'desc',
+ },
+ {
+ alias => 'foo',
+ column => 'id',
+ order => 'desc',
+ },
+ {
+ alias => 'foo',
+ column => 'name',
+ order => 'desc',
+ },
+ {
+ alias => '',
+ column => 'id',
+ order => 'ASC',
+ },
+ {
+ alias => undef,
+ column => 'blood',
+ order => 'ASC'
+ },
+ {
+ column => 'session_offset',
+ order => 'asc'
+ },
+ ],
+ }, 'Foo::Bar::Collection';
+ my $stmt = 'select * from users';
+ $package->distinct_query(\$stmt, $collection);
+ is $stmt,
+ 'SELECT blah FROM ( SELECT main.id FROM select * from users GROUP BY main.id'
+ . ' ORDER BY main.id ASC, min(main.name) DESC, min(foo.id) DESC, '
+ . 'min(foo.name) DESC, id ASC, min(blood) ASC, min(session_offset) ASC ) '
+ . 'distinctquery, bars main WHERE (main.id = distinctquery.id)',
+ 'distinct_query works';
+}
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 16;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+use DateTime ();
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::User', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my $now = time;
+ my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch;
+ my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' );
+ my $dt = DateTime->from_epoch( epoch => $now );
+ my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+ isa_ok($rec->event_on, 'DateTime' );
+ is( $rec->event_on->epoch, $today, "Correct value");
+ isa_ok($rec->event_stops, 'DateTime' );
+ is( $rec->event_stops->minute, $min_of_day->minute, "Correct value");
+ is( $rec->event_stops->hour, $min_of_day->hour, "Correct value");
+
+ # undef/NULL
+ $rec->set_created;
+ is($rec->created, undef, "Set undef value" );
+
+ # from string
+ require POSIX;
+ $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) );
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ created timestamp,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+BEGIN {
+use Jifty::DBI::Schema;
+Jifty::DBI::Schema->register_types(
+ Date =>
+ sub { type is 'date', input_filters are qw/Jifty::DBI::Filter::Date/ },
+ Time =>
+ sub { type is 'time', input_filters are qw/Jifty::DBI::Filter::Time/ },
+ DateTime => sub {
+ type is 'datetime',
+ input_filters are qw/Jifty::DBI::Filter::DateTime/
+ }
+);
+}
+
+use Jifty::DBI::Record schema {
+ column created => is DateTime;
+ column event_on => is Date;
+ column event_stops => is Time;
+};
+
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 17;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+use DateTime ();
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::CrazyUser', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+ {my $ret = init_schema( 'TestApp::CrazyUser', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+ my $rec = TestApp::CrazyUser->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my $now = time;
+ my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch;
+ my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' );
+ my $dt = DateTime->from_epoch( epoch => $now );
+ my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+ isa_ok($rec->event_on, 'DateTime' );
+ is( $rec->event_on->epoch, $today, "Correct value");
+ isa_ok($rec->event_stops, 'DateTime' );
+ is( $rec->event_stops->minute, $min_of_day->minute, "Correct value");
+ is( $rec->event_stops->hour, $min_of_day->hour, "Correct value");
+
+ # undef/NULL
+ $rec->set_created;
+ is($rec->created, undef, "Set undef value" );
+
+ # from string
+ require POSIX;
+ $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) );
+ isa_ok($rec->created, 'DateTime' );
+ is( $rec->created->epoch, $now, "Correct value");
+
+ cleanup_schema( 'TestApp', $handle );
+ disconnect_handle( $handle );
+}
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ created timestamp,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+BEGIN {
+use Jifty::DBI::Schema;
+Jifty::DBI::Schema->register_types(
+ Date =>
+ sub { type is 'date', input_filters are qw/Jifty::DBI::Filter::Date/ },
+ Time =>
+ sub { type is 'time', input_filters are qw/Jifty::DBI::Filter::Time/ },
+ DateTime => sub {
+ type is 'datetime',
+ input_filters are qw/Jifty::DBI::Filter::DateTime/
+ }
+);
+}
+
+use Jifty::DBI::Record schema {
+ column created => is DateTime;
+ column event_on => is Date;
+ column event_stops => is Time;
+};
+
+package TestApp::CrazyUser;
+BEGIN {
+our @ISA =qw(TestApp::User);
+}
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+ column craziness => type is 'text';
+# column event_on => is mandatory;
+};
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table crazy_users (
+ id integer primary key,
+ craziness varchar(16),
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table crazy_users (
+ id integer auto_increment primary key,
+ created datetime,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table crazy_users (
+ id serial primary key,
+ craziness varchar(16),
+ created timestamp,
+ event_on date,
+ event_stops time
+)
+EOF
+
+}
+
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@available_drivers);
+
+use constant TESTS_PER_DRIVER => 9;
+
+my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @available_drivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::User', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+ diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ {my $ret = init_schema( 'TestApp::User', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );}
+
+ my $rec = TestApp::User->new( handle => $handle );
+ isa_ok($rec, 'Jifty::DBI::Record');
+
+ my ($id) = $rec->create( location_x => 10, location_y => 20 );
+ ok($id, "Successfuly created ticket");
+ ok($rec->load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is($rec->location_x, 10);
+ is($rec->location_y, 20);
+ is_deeply($rec->location, { x => 10, y => 20});
+ }
+}
+
+package TestApp::User;
+use base qw/Jifty::DBI::Record/;
+
+1;
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ location_x double,
+ location_y double
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ location_x double,
+ location_y double
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ location_x double precision,
+ location_y double precision
+)
+EOF
+
+}
+
+
+sub geolocation {
+ my ($column, $from) = @_;
+ my $name = $column->name;
+ $column->virtual(1);
+ use Data::Dumper;
+ for (qw(x y)) {
+ Jifty::DBI::Schema::_init_column_for(
+ Jifty::DBI::Column->new({ type => 'double',
+ name => $name."_$_",
+ writable => $column->writable,
+ readable => $column->readable }),
+ $from);
+ }
+ no strict 'refs';
+ *{$from.'::'.$name} = sub { return { map { my $method = "${name}_$_"; $_ => $_[0]->$method } qw(x y) } };
+ *{$from.'::'.'set_'.$name} = sub { die "not yet" };
+}
+
+BEGIN {
+
+use Jifty::DBI::Schema;
+Jifty::DBI::Schema->register_types(
+ GeoLocation =>
+ sub { _init_handler is \&geolocation },
+);
+}
+
+
+use Jifty::DBI::Record schema {
+ column location => is GeoLocation;
+};
+
+
+1;
+
--- /dev/null
+use Test::More;
+eval "use Test::Pod::Coverage 1.00";
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
+all_pod_coverage_ok( );
+
+# Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that
+# certain "die"s that happen inside evals are not actually inside evals,
+# because caller() is broken if you turn on $^P like Module::Refresh does
+#
+# (I mean, if we've gotten to this line, then clearly the test didn't die, no?)
+Test::Builder->new->{Test_Died} = 0;
+
--- /dev/null
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
--- /dev/null
+package Sample::Employee;
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+
+column dexterity => type is 'integer';
+column name =>
+ type is 'varchar',
+ is indexed;
+column label => type is 'varchar';
+column type => type is 'varchar';
+
+};
+
+sub schema_sqlite {
+ return q{
+ CREATE TABLE employees (
+ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL ,
+ dexterity integer ,
+ name varchar ,
+ label varchar ,
+ type varchar
+ ) ;
+ CREATE INDEX employees1 ON employees (name) ;
+ };
+}
+
+sub schema_pg {
+ return q{
+ CREATE TABLE employees (
+ id serial NOT NULL ,
+ dexterity integer ,
+ name varchar ,
+ label varchar ,
+ type varchar ,
+ PRIMARY KEY (id)
+ ) ;
+ CREATE INDEX employees1 ON employees (name) ;
+ };
+
+}
+
+package Sample::Address;
+use Jifty::DBI::Schema;
+use Jifty::DBI::Record schema {
+
+column employee_id =>
+ references Sample::Employee;
+
+column name =>
+ type is 'varchar',
+ default is 'Frank';
+
+column phone =>
+ type is 'varchar';
+
+column street =>
+ type is 'varchar',
+ since '0.2.4',
+ till '0.2.8';
+
+};
+
+sub validate_name { 1 }
+
+my $schema_version = undef;
+sub schema_version {
+ my $class = shift;
+ my $new_schema_version = shift;
+ $schema_version = $new_schema_version if defined $new_schema_version;
+ return $schema_version;
+}
+
+sub schema_sqlite {
+ return q{
+ CREATE TABLE addresses (
+ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL ,
+ employee_id integer ,
+ name varchar DEFAULT 'Frank' ,
+ phone varchar
+ ) ;
+ }
+}
+
+sub schema_sqlite_024 {
+ return q{
+ CREATE TABLE addresses (
+ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL ,
+ employee_id integer ,
+ name varchar DEFAULT 'Frank' ,
+ phone varchar ,
+ street varchar
+ ) ;
+ }
+}
+
+sub schema_pg {
+ return q{
+ CREATE TABLE addresses (
+ id serial NOT NULL ,
+ employee_id integer ,
+ name varchar DEFAULT 'Frank' ,
+ phone varchar ,
+ PRIMARY KEY (id)
+ ) ;
+ };
+}
+
+sub schema_pg_024 {
+ return q{
+ CREATE TABLE addresses (
+ id serial NOT NULL ,
+ employee_id integer ,
+ name varchar DEFAULT 'Frank' ,
+ phone varchar ,
+ street varchar ,
+ PRIMARY KEY (id)
+ ) ;
+ };
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl -w
+
+use strict;
+use File::Spec ();
+
+=head1 VARIABLES
+
+=head2 @supported_drivers
+
+Array of all supported DBD drivers.
+
+=cut
+
+our @supported_drivers = qw(
+ SQLite
+ Informix
+ mysql
+ mysqlPP
+ ODBC
+ Oracle
+ Pg
+ Sybase
+);
+
+=head2 @available_drivers
+
+Array that lists only drivers from supported list
+that user has installed.
+
+=cut
+
+our @available_drivers = grep { eval "require DBD::". $_ } @supported_drivers;
+
+=head1 functionS
+
+=head2 get_handle
+
+Returns new DB specific handle. Takes one argument DB C<$type>.
+Other arguments uses to construct handle.
+
+=cut
+
+sub get_handle
+{
+ my $type = shift;
+ my $class = 'Jifty::DBI::Handle::'. $type;
+ eval "require $class";
+ die $@ if $@;
+ my $handle;
+ $handle = $class->new( @_ );
+ return $handle;
+}
+
+=head2 handle_to_driver
+
+Returns driver name which gets from C<$handle> object argument.
+
+=cut
+
+sub handle_to_driver
+{
+ my $driver = ref($_[0]);
+ $driver =~ s/^.*:://;
+ return $driver;
+}
+
+=head2 connect_handle
+
+Connects C<$handle> object to DB.
+
+=cut
+
+sub connect_handle
+{
+ my $call = "connect_". lc handle_to_driver( $_[0] );
+ return unless defined &$call;
+ goto &$call;
+}
+
+=head2 connect_handle_with_driver($handle, $driver)
+
+Connects C<$handle> using driver C<$driver>; can use this to test the
+magic that turns a C<Jifty::DBI::Handle> into a C<Jifty::DBI::Handle::Foo>
+on C<Connect>.
+
+=cut
+
+sub connect_handle_with_driver
+{
+ my $call = "connect_". lc $_[1];
+ return unless defined &$call;
+ @_ = $_[0];
+ goto &$call;
+}
+
+sub connect_sqlite
+{
+ my $handle = shift;
+ return $handle->connect(
+ driver => 'SQLite',
+ database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$")
+ );
+}
+
+sub connect_mysql
+{
+ my $handle = shift;
+ return $handle->connect(
+ driver => 'mysql',
+ database => $ENV{'JDBI_TEST_MYSQL'},
+ user => $ENV{'JDBI_TEST_MYSQL_USER'} || 'root',
+ password => $ENV{'JDBI_TEST_MYSQL_PASS'} || '',
+ );
+}
+
+sub connect_pg
+{
+ my $handle = shift;
+ return $handle->connect(
+ driver => 'Pg',
+ database => $ENV{'JDBI_TEST_PG'},
+ user => $ENV{'JDBI_TEST_PG_USER'} || 'postgres',
+ password => $ENV{'JDBI_TEST_PG_PASS'} || '',
+ );
+}
+
+sub connect_oracle
+{
+ my $handle = shift;
+ return $handle->Connect(
+ driver => 'Oracle',
+# database => $ENV{'JDBI_TEST_ORACLE'},
+ user => $ENV{'JDBI_TEST_ORACLE_USER'} || 'test',
+ password => $ENV{'JDBI_TEST_RACLE_PASS'} || 'test',
+ );
+}
+
+=head2 disconnect_handle
+
+Disconnects C<$handle> object.
+
+=cut
+
+sub disconnect_handle
+{
+ my $call = "disconnect_". lc handle_to_driver( $_[0] );
+ return unless defined &$call;
+ goto &$call;
+}
+
+=head2 disconnect_handle_with_driver($handle, $driver)
+
+Disconnects C<$handle> using driver C<$driver>.
+
+=cut
+
+sub disconnect_handle_with_driver
+{
+ my $call = "disconnect_". lc $_[1];
+ return unless defined &$call;
+ @_ = $_[0];
+ goto &$call;
+}
+
+sub disconnect_sqlite
+{
+ my $handle = shift;
+ $handle->disconnect;
+ unlink File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$");
+}
+
+sub disconnect_mysql
+{
+ my $handle = shift;
+ $handle->disconnect;
+
+ # XXX: is there something we should do here?
+}
+
+sub disconnect_pg
+{
+ my $handle = shift;
+ $handle->disconnect;
+
+ # XXX: is there something we should do here?
+}
+
+=head2 should_test $driver
+
+Checks environment for C<JDBI_TEST_*> variables.
+Returns true if specified DB back-end should be tested.
+Takes one argument C<$driver> name.
+
+=cut
+
+sub should_test
+{
+ my $driver = shift;
+ return 1 if lc $driver eq 'sqlite';
+ my $env = 'JDBI_TEST_'. uc $driver;
+ return $ENV{$env};
+}
+
+=head2 has_schema $class { $driver | $handle }
+
+Returns method name if C<$class> has schema for C<$driver> or C<$handle>.
+If second argument is handle object then checks also for DB version
+specific schemas, for example for MySQL 4.1.23 this function will check
+next methods in the C<$class>: C<schema_mysql_4_1_23>, C<schema_mysql_4_1>,
+C<schema_mysql_4> and C<schema_mysql>, but if second argument is C<$driver>
+name then checks only for C<schema_mysql>.
+
+Returns empty value if couldn't find method.
+
+=cut
+
+sub has_schema
+{
+ my ($class, $driver) = @_;
+ unless( UNIVERSAL::isa( $driver, 'Jifty::DBI::Handle' ) ) {
+ my $method = 'schema_'. lc $driver;
+ $method = '' unless UNIVERSAL::can( $class, $method );
+ return $method;
+ } else {
+ my $ver = $driver->database_version;
+ return has_schema( $class, handle_to_driver( $driver ) ) unless $ver;
+
+ my $method = 'schema_'. lc handle_to_driver( $driver );
+ $ver =~ s/-.*$//;
+ my @nums = grep $_, map { int($_) } split /\./, $ver;
+ while( @nums ) {
+ my $m = $method ."_". join '_', @nums;
+ return $m if( UNIVERSAL::can( $class, $m ) );
+ pop @nums;
+ }
+ return has_schema( $class, handle_to_driver( $driver ) );
+ }
+}
+
+=head2 init_schema
+
+Takes C<$class> and C<$handle> or C<$driver> and inits schema
+by calling method C<has_schema> returns of the C<$class>.
+Returns last C<DBI::st> on success or last return value of the
+SimpleQuery method on error.
+
+=cut
+
+sub init_schema
+{
+ my ($class, $handle) = @_;
+ my $call = has_schema( $class, $handle );
+ diag( "using '$class\:\:$call' schema for ". handle_to_driver( $handle ) ) if $ENV{TEST_VERBOSE};
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ my $ret;
+ foreach my $query( @$schema ) {
+ $ret = $handle->simple_query( $query );
+ return $ret unless UNIVERSAL::isa( $ret, 'DBI::st' );
+ }
+ return $ret;
+}
+
+=head2 cleanup_schema
+
+Takes C<$class> and C<$handle> and cleanup schema by calling
+C<cleanup_schema_$driver> method of the C<$class> if method exists.
+Always returns undef.
+
+=cut
+
+sub cleanup_schema
+{
+ my ($class, $handle) = @_;
+ my $call = "cleanup_schema_". lc handle_to_driver( $handle );
+ return unless UNIVERSAL::can( $class, $call );
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ foreach my $query( @$schema ) {
+ eval { $handle->simple_query( $query ) };
+ }
+}
+
+=head2 init_data
+
+=cut
+
+sub init_data
+{
+ my ($class, $handle) = @_;
+ my @data = $class->init_data();
+ my @columns = @{ shift @data };
+ my $count = 0;
+ foreach my $values ( @data ) {
+ my %args;
+ for( my $i = 0; $i < @columns; $i++ ) {
+ $args{ $columns[$i] } = $values->[$i];
+ }
+ my $rec = $class->new( handle => $handle );
+ my $id = $rec->create( %args );
+ die "Couldn't create record" unless $id;
+ $count++;
+ }
+ return $count;
+}
+
+1;
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff