Revision history for DBIx::Class
+ - Added Oracle/WhereJoins.pm for Oracle >= 8 to support
+ Oracle <= 9i, and provide Oracle with a better join method for
+ later versions. (I use the term better loosely.)
+ - select et al weren't properly detecing when the server connection
+ had timed out when not in a transaction
+ - The SQL::T parser class now respects a relationship attribute of
+ is_foreign_key_constrain to allow explicit control over wether or
+ not a foreign constraint is needed
+ - resultset_class/result_class now (again) auto loads the specified
+ class; requires Class::Accessor::Grouped 0.05001+
+
+0.07006 2007-04-17 23:18:00
+ - Lots of documentation updates
+ - deploy now takes an optional 'source_names' parameter (dec)
+ - Quoting for for columns_info_for
+ - RT#25683 fixed (multiple open sths on DBD::Sybase)
+ - CDBI compat infers has_many from has_a (Schwern)
+ - Fix ddl_filename transformation (Carl Vincent)
+
+0.07999_02 2007-01-25 20:11:00
- add support for binding BYTEA and similar parameters (w/Pg impl)
- add support to Ordered for multiple ordering columns
- mark DB.pm and compose_connection as deprecated
- Changed row and rs objects to not have direct handle to a source,
instead a (schema,source_name) tuple of type ResultSourceHandle
+0.07005 2007-01-10 18:36:00
+ - fixup changes file
+ - remove erroneous .orig files - oops
+
+0.07004 2007-01-09 21:52:00
+ - fix find_related-based queries to correctly grep the unique key
+ - fix InflateColumn to inflate/deflate all refs but scalar refs
+
+0.07003 2006-11-16 11:52:00
+ - fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl")
+ - Tweaks to resultset to allow inflate_result to return an array
+ - Fix UTF8Columns to work under Perl <= 5.8.0
+ - Fix up new_result in ResultSet to avoid alias-related bugs
+ - Made new/update/find handle 'single' rel accessor correctly
+ - Fix NoBindVars to be safer and handle non-true bind values
+ - Don't blow up if columns_info_for returns useless results
+ - Documentation updates
+
0.07999_01 2006-10-05 21:00:00
- add connect_info option "disable_statement_caching"
- create insert_bulk using execute_array, populate uses it
You can make it work like before via
__PACKAGE__->column_info_from_storage(1) for now
- Replaced DBIx::Class::AccessorGroup and Class::Data::Accessor with
- Class::Accessor::Grouped. Only user noticible change is to
- table_class on ResultSourceProxy::Table (i.e. table objects in
- schemas) and, resultset_class and result_class in ResultSource.
+ Class::Accessor::Grouped. Only user noticible change is to
+ table_class on ResultSourceProxy::Table (i.e. table objects in
+ schemas) and, resultset_class and result_class in ResultSource.
These accessors no longer automatically require the classes when
set.
-0.07004
- - fix find_related-based queries to correctly grep the unique key
-
-0.07003 2006-11-16 11:52:00
- - fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl")
- - Tweaks to resultset to allow inflate_result to return an array
- - Fix UTF8Columns to work under Perl <= 5.8.0
- - Fix up new_result in ResultSet to avoid alias-related bugs
- - Made new/update/find handle 'single' rel accessor correctly
- - Fix NoBindVars to be safer and handle non-true bind values
- - Don't blow up if columns_info_for returns useless results
- - Documentation updates
-
0.07002 2006-09-14 21:17:32
- fix quote tests for recent versions of SQLite
- added reference implementation of Manual::Example
- fixes to pass test suite on Windows
- rewrote and cleaned up SQL::Translator tests
- changed relationship helpers to only call ensure_class_loaded when the
- join condition is inferred
+ join condition is inferred
- rewrote many_to_many implementation, now provides helpers for adding
and deleting objects without dealing with the link table
- reworked InflateColumn implementation to lazily deflate where
- changed join merging to not create a rel_2 alias when adding a join
that already exists in a parent resultset
- Storage::DBI::deployment_statements now calls ensure_connected
- if it isn't passed a type
+ if it isn't passed a type
- fixed Componentized::ensure_class_loaded
- InflateColumn::DateTime supports date as well as datetime
- split Storage::DBI::MSSQL into MSSQL and Sybase::MSSQL
- - fixed wrong debugging hook call in Storage::DBI
- - set connect_info properly before setting any ->sql_maker things
+ - fixed wrong debugging hook call in Storage::DBI
+ - set connect_info properly before setting any ->sql_maker things
0.06999_02 2006-06-09 23:58:33
- Fixed up POD::Coverage tests, filled in some POD holes
0.05002 2006-02-06 12:12:03
- Added recommends for Class::Inspector
- - Added skip_all to t/40resultsetmanager.t if no Class::Inspector available
+ - Added skip_all to t/40resultsetmanager.t if no Class::Inspector
+ available
0.05001 2006-02-05 15:28:10
- debug output now prints NULL for undef params
0.04999_04 2006-01-24 21:48:21
- more documentation improvements
- - add columns_info_for for vendor-specific column info (Zbigniew Lukasiak)
- - add SQL::Translator::Producer for DBIx::Class table classes (Jess Robinson)
+ - add columns_info_for for vendor-specific column info (Zbigniew
+ Lukasiak)
+ - add SQL::Translator::Producer for DBIx::Class table classes (Jess
+ Robinson)
- add unique constraint declaration (Daniel Westermann-Clark)
- add new update_or_create method (Daniel Westermann-Clark)
- rename ResultSetInstance class to ResultSetProxy, ResultSourceInstance
0.04999_03 2006-01-20 06:05:27
- imported Jess Robinson's SQL::Translator::Parser::DBIx::Class
- - lots of internals cleanup to eliminate result_source_instance requirement
+ - lots of internals cleanup to eliminate result_source_instance
+ requirement
- added register_column and register_relationship class APIs
- made Storage::DBI use prepare_cached safely (thanks to Tim Bunce)
- many documentation improvements (thanks guys!)
- - added ->connection, ->connect, ->register_source and ->clone schema methods
+ - added ->connection, ->connect, ->register_source and ->clone schema
+ methods
- Use croak instead of die for user errors.
0.04999_02 2006-01-14 07:17:35
0.01 2005-08-08 17:10:00
- initial release
+
# Skip maint stuff
^maint/
+# Avoid copies to .orig
+\.orig$
+
# Dont use Module::Build anymore
# Build.PL
requires 'DBI' => 1.40;
requires 'Module::Find' => 0;
requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.03;
+requires 'Class::Accessor::Grouped' => 0.05001;
+requires 'JSON' => 1.00;
# Perl 5.8.0 doesn't have utf8::is_utf8()
requires 'Encode' => 0 if ($] <= 5.008000);
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.07999_01';
+$VERSION = '0.07999_02';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
clkao: CL Kao
+da5id: David Jack Olrik <djo@cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
+dnm: Justin Wheeler <jwheeler@datademons.com>
+
draven: Marcus Ramberg <mramberg@cpan.org>
dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
jguenther: Justin Guenther <jguenther@cpan.org>
+jshirley: J. Shirley <jshirley@gmail.com>
+
konobi: Scott McWhirter
LTJake: Brian Cassidy <bricas@cpan.org>
$args->{cascade_delete} = 0;
}
+ if( !$f_key and !@f_method ) {
+ my $f_source = $f_class->result_source_instance;
+ ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
+ $f_source->relationships;
+ }
+
$class->next::method($rel, $f_class, $f_key, $args);
if (@f_method) {
# it on the basis of the comments in Class::C3, the author was on #dbix-class
# while I was implementing this.
- my $table = { Class::C3::_dump_MRO_table };
- eval "package $target; import Class::C3;" unless exists $table->{$target};
+ eval "package $target; import Class::C3;" unless exists $Class::C3::MRO{$target};
}
sub load_components {
=head2 next
-Virtual method. Advances the cursor to the next row.
+Virtual method. Advances the cursor to the next row. Returns an array of
+column values (the result of L<DBI/fetchrow_array> method).
=cut
columns to be of the datetime, timestamp or date datatype.
package Event;
- __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+ __PACKAGE__->load_components(qw/Core InflateColumn::DateTime/);
__PACKAGE__->add_columns(
starts_when => { data_type => 'datetime' }
);
that this feature is new as of 0.07, so it may not be perfect yet - bug
reports to the list very much welcome).
-For more help with components, see L<DBIx::Class::Manual::Component>.
+For more help with using components, see L<DBIx::Class::Manual::Component/USING>.
=cut
-package DBIx::Class::FileColumn;
+package DBIx::Class::InflateColumn::File;
use strict;
use warnings;
use File::Copy;
use IO::File;
-sub inflate_result {
- my $self = shift;
- my $ret = $self->next::method(@_);
-
- $self->_inflate_file_column($ret);
- return $ret;
-}
+__PACKAGE__->load_components(qw/InflateColumn/);
-sub insert {
- my ( $self, @rest ) = @_;
- my ( $file, @column_names ) = $self->_load_file_column_information;
- my $ret = $self->next::method(@rest);
- $self->_save_file_column( $file, $ret, @column_names );
- return $ret;
+sub register_column {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ return unless defined($info->{is_file_column});
+ $self->inflate_column(
+ $column =>
+ {
+ inflate => sub {
+ my ($value, $obj) = @_;
+ #$self->_inflate_file_column;
+ },
+ deflate => sub {
+ my ($value, $obj) = @_;
+ #my ( $file, @column_names ) = $self->_load_file_column_information;
+ #$self->_save_file_column( $file, $self, @column_names );
+ },
+ }
+ );
}
-sub update {
- my ($self, @rest ) = @_;
-
- my ( $file, @column_names ) = $self->_load_file_column_information;
- my $ret = $self->next::method(@rest);
- $self->_save_file_column( $file, $ret, @column_names );
- return $ret;
-}
sub delete {
my ( $self, @rest ) = @_;
sub _inflate_file_column {
my $self = shift;
- my $ret = shift;
my @column_names = $self->columns;
for(@column_names) {
- if ( $ret->column_info($_)->{is_file_column} ) {
+ if ( $self->column_info($_)->{is_file_column} ) {
# make sure everything checks out
- unless (defined $ret->$_) {
+ unless (defined $self->$_) {
# if something is wrong set it to undef
- $ret->$_(undef);
+ $self->$_(undef);
next;
}
my $fs_file =
- File::Spec->catfile( $ret->column_info($_)->{file_column_path},
- $ret->id, $ret->$_ );
- $ret->$_({handle => new IO::File($fs_file, "r"), filename => $ret->$_});
+ File::Spec->catfile( $self->column_info($_)->{file_column_path},
+ $self->id, $self->$_ );
+ $self->$_({handle => new IO::File($fs_file, "r"), filename => $self->$_});
}
}
}
=head1 NAME
-DBIx::Class::FileColumn - FileColumn map files from the Database to the filesystem.
+DBIx::Class::InflateColumn::File - map files from the Database to the filesystem.
=head1 DESCRIPTION
-FileColumn
+InflateColumn::File
=head1 SYNOPSIS
In your L<DBIx::Class> table class:
- __PACKAGE__->load_components( "PK::Auto", "FileColumn", "Core" );
+ __PACKAGE__->load_components( "PK::Auto", "InflateColumn::File", "Core" );
# define your columns
__PACKAGE__->add_columns(
=head1 SECTIONS
+=head2 L<DBIx::Class::Manual::FAQ>
+
+Short answers and doc pointers to questions.
+
=head2 L<DBIx::Class::Manual::Intro>
Beginner guide to using DBIx::Class.
An example of slightly more complex usage.
+=head2 L<DBIx::Class::Manual::Joining>
+
+How to translate known SQL JOINs into DBIx-Class-ish.
+
=head2 L<DBIx::Class::Manual::Cookbook>
Convenient recipes for DBIC usage.
);
# Equivalent SQL:
- # SELECT name name, LENGTH( name ) name_length
+ # SELECT name name, LENGTH( name )
# FROM artist
-If your alias exists as a column in your base class (i.e. it was added
-with C<add_columns>), you just access it as normal. Our C<Artist>
-class has a C<name> column, so we just use the C<name> accessor:
+Note that the C< as > attribute has absolutely nothing to with the sql
+syntax C< SELECT foo AS bar > (see the documentation in
+L<DBIx::Class::ResultSet/ATTRIBUTES>). If your alias exists as a
+column in your base class (i.e. it was added with C<add_columns>), you
+just access it as normal. Our C<Artist> class has a C<name> column, so
+we just use the C<name> accessor:
my $artist = $rs->first();
my $name = $artist->name();
select => [
{ distinct => [ $source->columns ] }
],
- as => [ $source->columns ]
+ as => [ $source->columns ] # remember 'as' is not the same as SQL AS :-)
}
);
# LEFT JOIN cd cds ON ( cds.artist = me.artistid )
# GROUP BY name
+Please see L<DBIx::Class::ResultSet/ATTRIBUTES> documentation if you
+are in any way unsure about the use of the attributes above (C< join
+>, C< select >, C< as > and C< group_by >).
+
=head3 Predefined searches
You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
{},
{
select => [ { sum => 'Cost' } ],
- as => [ 'total_cost' ],
+ as => [ 'total_cost' ], # remember this 'as' is for DBIx::Class::ResultSet not SQL
}
);
my $tc = $rs->first->get_column('total_cost');
=head2 Many-to-many relationships
-This is straightforward using L<DBIx::Class::Relationship::ManyToMany>:
+This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
package My::DB;
# ... set up connection ...
$attrs->{foo} = 'bar' unless defined $attrs->{foo};
- $class->next::method($attrs);
+ my $new = $class->next::method($attrs);
+
+ return $new;
}
For more information about C<next::method>, look in the L<Class::C3>
To make an object stringify itself as a single column, use something
like this (replace C<foo> with the column/method of your choice):
- use overload '""' => 'foo', fallback => 1;
+ use overload '""' => sub { shift->name}, fallback => 1;
For more complex stringification, you can use an anonymous subroutine:
Wasn't that easy?
+=head2 Get raw data for blindingly fast results
+
+If the C<inflate_result> solution above is not fast enough for you, you
+can use a DBIx::Class to return values exactly as they come out of the
+data base with none of the convenience methods wrapped round them.
+
+This is used like so:-
+
+ my $cursor = $rs->cursor
+ while (my @vals = $cursor->next) {
+ # use $val[0..n] here
+ }
+
+You will need to map the array offsets to particular columns (you can
+use the I<select> attribute of C<search()> to force ordering).
+
=head2 Want to know if find_or_create found or created a row?
Just use C<find_or_new> instead, then check C<in_storage>:
# do whatever else you wanted if it was a new row
}
+=head3 Wrapping/overloading a column accessor
+
+Problem: Say you have a table "Camera" and want to associate a description
+with each camera. For most cameras, you'll be able to generate the description from
+the other columns. However, in a few special cases you may want to associate a
+custom description with a camera.
+
+Solution:
+
+In your database schema, define a description field in the "Camera" table that
+can contain text and null values.
+
+In DBIC, we'll overload the column accessor to provide a sane default if no
+custom description is defined. The accessor will either return or generate the
+description, depending on whether the field is null or not.
+
+First, in your "Camera" schema class, define the description field as follows:
+
+ __PACKAGE__->add_columns(description => { accessor => '_description' });
+
+Next, we'll define the accessor-wrapper subroutine:
+
+ sub description {
+ my $self = shift;
+
+ # If there is an update to the column, we'll let the original accessor
+ # deal with it.
+ return $self->_description(@_) if @_;
+
+ # Fetch the column value.
+ my $description = $self->_description;
+
+ # If there's something in the description field, then just return that.
+ return $description if defined $description && length $descripton;
+
+ # Otherwise, generate a description.
+ return $self->generate_description;
+ }
+
=cut
L<DBIx::Class::ResultSetColumn>, see it's documentation and the
L<Cookbook|DBIx::Class::Manual::Cookbook> for details.
+=item .. fetch a formatted column?
+
+In your table schema class, create a "private" column accessor with:
+
+ __PACKAGE__->add_columns(my_common => { accessor => '_hidden_my_column' });
+
+Then, in the same class, implement a subroutine called "my_column" that
+fetches the real value and does the formatting you want.
+
+See the Cookbook for more details.
+
+=item .. fetch a single (or topmost) row?
+
+Sometimes you many only want a single record back from a search. A quick
+way to get that single row is to first run your search as usual:
+
+ ->search->(undef, { order_by => "id DESC" })
+
+Then call L<DBIx::Class::ResultSet/slice> and ask it only to return 1 row:
+
+ ->slice(0,1)
+
+These two calls can be combined into a single statement:
+
+ ->search->(undef, { order_by => "id DESC" })->slice(0,1)
+
+Why slice instead of L<DBIx::Class::ResultSet/first> or L<DBIx::Class::ResultSet/single>?
+If supported by the database, slice will use LIMIT/OFFSET to hint to the database that we
+really only need one row. This can result in a significant speed improvement.
+
=back
=head2 Inserting and updating data
->update({ somecolumn => \'othercolumn' })
+=item .. store JSON/YAML in a column and have it deflate/inflate automatically?
+
+You can use L<DBIx::Class::InflateColumn> to accomplish YAML/JSON storage transparently.
+
+If you want to use JSON, then in your table schema class, do the following:
+
+ use JSON;
+
+ __PACKAGE__->add_columns(qw/ ... my_column ../)
+ __PACKAGE__->inflate_column('my_column', {
+ inflate => sub { jsonToObj(shift) },
+ deflate => sub { objToJson(shift) },
+ });
+
+For YAML, in your table schema class, do the following:
+
+ use YAML;
+
+ __PACKAGE__->add_columns(qw/ ... my_column ../)
+ __PACKAGE__->inflate_column('my_column', {
+ inflate => sub { YAML::Load(shift) },
+ deflate => sub { YAML::Dump(shift) },
+ });
+
+This technique is an easy way to store supplemental unstructured data in a table. Be
+careful not to overuse this capability, however. If you find yourself depending more
+and more on some data within the inflated column, then it may be time to factor that
+data out.
+
=back
=head2 Misc
my $rs = $schema->resultset('Album')->search({
artist => { '!=', 'Janis Joplin' },
year => { '<' => 1980 },
- albumid => [ 1, 14, 15, 65, 43 ]
+ albumid => { '-in' => [ 1, 14, 15, 65, 43 ] }
});
This results in something like the following C<WHERE> clause:
--- /dev/null
+=head1 NAME
+
+DBIx::Class::Manual::Joining - Manual on joining tables with DBIx::Class
+
+=head1 DESCRIPTION
+
+This document should help you to use L<DBIx::Class> if you are trying
+to convert your normal SQL queries into DBIx::Class based queries, if
+you use joins extensively (and also probably if you don't).
+
+=head1 WHAT ARE JOINS
+
+If you ended up here and you don't actually know what joins are yet,
+then you should likely try the L<DBIx::Class::Manual::Intro>
+instead. Skip this part if you know what joins are..
+
+But I'll explain anyway. Assuming you have created your database in a
+more or less sensible way, you will end up with several tables that
+contain C<related> information. For example, you may have a table
+containing information about C<CDs>, containing the CD title and it's
+year of publication, and another table containing all the C<Track>s
+for the CDs, one track per row.
+
+When you wish to extract information about a particular CD and all
+it's tracks, You can either fetch the CD row, then make another query
+to fetch the tracks, or you can use a join. Compare:
+
+ SELECT ID, Title, Year FROM CD WHERE Title = 'Funky CD';
+ # .. Extract the ID, which is 10
+ SELECT Name, Artist FROM Tracks WHERE CDID = 10;
+
+ SELECT cd.ID, cd.Title, cd.Year, tracks.Name, tracks.Artist FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD';
+
+So, joins are a way of extending simple select statements to include
+fields from other, related, tables. There are various types of joins,
+depending on which combination of the data you wish to retrieve, see
+L<MySQL's doc on JOINs|http://dev.mysql.com/doc/refman/5.0/en/join.html>.
+
+=head1 DEFINING JOINS AND RELATIONSHIPS
+
+In L<DBIx::Class> each relationship between two tables needs to first
+be defined in the L<ResultSource|DBIx::Class::Manual::Glossary/ResultSource> for the
+table. If the relationship needs to be accessed in both directions
+(i.e. Fetch all tracks of a CD, and fetch the CD data for a Track),
+then it needs to be defined in both tables.
+
+For the CDs/Tracks example, that means writing, in C<MySchema::CD>:
+
+ MySchema::CD->has_many('tracks', 'MySchema::Tracks');
+
+And in C<MySchema::Tracks>:
+
+ MySchema::Tracks->belongs_to('cd', 'MySchema::CD', 'CDID');
+
+There are several other types of relationships, they are more
+comprehensively described in L<DBIx::Class::Relationship>.
+
+=head1 USING JOINS
+
+Once you have defined all your relationships, using them in actual
+joins is fairly simple. The type of relationship that you chose
+e.g. C<has_many>, already indicates what sort of join will be
+performed. C<has_many> produces a C<LEFT JOIN> for example, which will
+fetch all the rows on the left side, whether there are matching rows
+on the right (table being joined to), or not. You can force other
+types of joins in your relationship, see the
+L<DBIx::Class::Relationship> docs.
+
+When performing either a L<search|DBIx::Class::ResultSet/search> or a
+L<find|DBIx::Class::ResultSet/find> operation, you can specify which
+C<relations> to also fetch data from (or sort by), using the
+L<join|DBIx::Class::ResultSet/join> attribute, like this:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => 'tracks',
+ '+select' => [ 'tracks.Name', 'tracks.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+If you don't recognise most of this syntax, you should probably go
+read L<DBIx::Class::ResultSet/search> and
+L<DBIx::Class::ResultSet/ATTRIBUTES>, but here's a quick break down:
+
+The first argument to search is a hashref of the WHERE attributes, in
+this case a simple restriction on the Title column. The second
+argument is a hashref of attributes to the search, '+select' adds
+extra columns to the select (from the joined table(s) or from
+calculations), and '+as' gives aliases to those fields.
+
+'join' specifies which C<relationships> to include in the query. The
+distinction between C<relationships> and C<tables> is important here,
+only the C<relationship> names are valid.
+
+This example should magically produce SQL like the second select in
+L</WHAT ARE JOINS> above.
+
+=head1 COMPLEX JOINS AND STUFF
+
+=head2 Across multiple relations
+
+For simplicity in the example above, the C<Artist> was shown as a
+simple text firld in the C<Tracks> table, in reality, you'll want to
+have the artists in their own table as well, thus to fetch the
+complete set of data we'll need to join to the Artist table too.
+
+In C<MySchema::Tracks>:
+
+ MySchema::Tracks->belongs_to('artist', 'MySchema::Artist', 'ArtistID');
+
+The search:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => { 'tracks' => 'artist' },
+ '+select' => [ 'tracks.Name', 'artist.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+Which is:
+
+ SELECT me.ID, me.Title, me.Year, tracks.Name, artist.Artist FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD';
+
+To perform joins using relations of the tables you are joining to, use
+a hashref to indicate the join depth. This can theoretically go as
+deep as you like (warning, contrived examples!):
+
+ join => { room => { table => 'leg' } }
+
+To join two relations at the same level, use an arrayref instead:
+
+ join => { room => [ 'chair', 'table' ] }
+
+Or combine the two:
+
+ join => { room => [ 'chair', { table => 'leg' } ]
+
+=head2 Table aliases
+
+As an aside to all the discussion on joins, note that L<DBIx::Class>
+uses the C<relation names> as table aliases. This is important when
+you need to add grouping or ordering to your queries:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => { 'tracks' => 'artist' },
+ order_by => [ 'tracks.Name', 'artist.Artist' ],
+ '+select' => [ 'tracks.Name', 'artist.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+ SELECT me.ID, me.Title, me.Year, tracks.Name, artist.Artist FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD' ORDER BY tracks.Name, artist.Artist;
+
+This is essential if any of your tables have columns with the same names.
+
+Note that the table of the resultsource the search was performed on, is always aliased to C<me>.
+
+=head2 Joining to the same table twice
+
+There is no magic to this, just do it. The table aliases will
+automatically be numbered:
+
+ join => [ 'room', 'room' ]
+
+The aliases are: C<room_1> and C<room_2>.
+
+=cut
+
L<DBI> version 1.50 and L<DBD::Pg> 1.43 are known to work.
+=head2 ... Can't locate object method "source_name" via package ...
+
+There's likely a syntax error in the table class referred to elsewhere
+in this error message. In particular make sure that the package
+declaration is correct, so for a schema C< MySchema > you need to
+specify a fully qualified namespace: C< package MySchema::MyTable; >
+for example.
+
=cut
other_group_id INTEGER NOT NULL
);
-In your Schema or DB class add Ordered to the top
+In your Schema or DB class add "Ordered" to the top
of the component list.
__PACKAGE__->load_components(qw( Ordered ... ));
__PACKAGE__->grouping_column(['group_id', 'other_group_id']);
-Thats it, now you can change the position of your objects.
+That's it, now you can change the position of your objects.
#!/use/bin/perl
use My::Item;
__PACKAGE__->position_column('position');
Sets and retrieves the name of the column that stores the
-positional value of each record. Default to "position".
+positional value of each record. Defaults to "position".
=cut
__PACKAGE__->grouping_column('group_id');
-This method specified a column to limit all queries in
+This method specifies a column to limit all queries in
this module by. This effectively allows you to have multiple
ordered lists within the same table.
my $rs = $item->siblings();
my @siblings = $item->siblings();
-Returns either a result set or an array of all other objects
+Returns either a resultset or an array of all other objects
excluding the one you called it on.
=cut
my $sibling = $item->first_sibling();
Returns the first sibling object, or 0 if the first sibling
-is this sibliing.
+is this sibling.
=cut
my $sibling = $item->last_sibling();
-Return the last sibling, or 0 if the last sibling is this
+Returns the last sibling, or 0 if the last sibling is this
sibling.
=cut
my $sibling = $item->previous_sibling();
-Returns the sibling that resides one position back. Undef
-is returned if the current object is the first one.
+Returns the sibling that resides one position back. Returns undef
+if the current object is the first one.
=cut
my $sibling = $item->next_sibling();
-Returns the sibling that resides one position foward. Undef
-is returned if the current object is the last one.
+Returns the sibling that resides one position forward. Returns undef
+if the current object is the last one.
=cut
$item->move_previous();
-Swaps position with the sibling on position previous in the list.
-1 is returned on success, and 0 is returned if the objects is already
-the first one.
+Swaps position with the sibling in the position previous in
+the list. Returns 1 on success, and 0 if the object is
+already the first one.
=cut
$item->move_next();
-Swaps position with the sibling in the next position. 1 is returned on
-success, and 0 is returned if the object is already the last in the list.
+Swaps position with the sibling in the next position in the
+list. Returns 1 on success, and 0 if the object is already
+the last in the list.
=cut
$item->move_first();
-Moves the object to the first position. 1 is returned on
-success, and 0 is returned if the object is already the first.
+Moves the object to the first position in the list. Returns 1
+on success, and 0 if the object is already the first.
=cut
$item->move_last();
-Moves the object to the very last position. 1 is returned on
-success, and 0 is returned if the object is already the last one.
+Moves the object to the last position in the list. Returns 1
+on success, and 0 if the object is already the last one.
=cut
$item->move_to( $position );
-Moves the object to the specified position. 1 is returned on
-success, and 0 is returned if the object is already at the
-specified position.
+Moves the object to the specified position. Returns 1 on
+success, and 0 if the object is already at the specified
+position.
=cut
If a position is not specified for an insert than a position
will be chosen based on COUNT(*)+1. But, it first selects the
-count then inserts the record. The space of time between select
+count, and then inserts the record. The space of time between select
and insert introduces a race condition. To fix this we need the
ability to lock tables in DBIC. I've added an entry in the TODO
about this.
My::DBIC::Schema::Role->many_to_many( actors => 'actor_roles', 'actor' );
+To add a role for your actor, and fill in the year of the role in the
+actor_roles table:
+
+ $actor->add_to_roles($role, { year => 1995 });
+
Many_to_many is not strictly a relationship in its own right. Instead, it is
a bridge between two resultsets which provide the same kind of convenience
accessors as true relationships provide. Although the accessor will return a
a column accessor). For C<multi> accessors, an add_to_* method is also
created, which calls C<create_related> for the relationship.
+=item is_foreign_key_constraint
+
+If you are using L<SQL::Translator> to create SQL for you and you find that it
+is creating constraints where it shouldn't, or not creating them where it
+should, set this attribute to a true or false value to override the detection
+of when to create constraints.
+
=back
=head2 register_relationship
columns => [qw/name artistid/],
});
-For a list of attributes that can be passed to C<search>, see L</ATTRIBUTES>. For more examples of using this function, see L<Searching|DBIx::Class::Manual::Cookbook/Searching>.
+For a list of attributes that can be passed to C<search>, see
+L</ATTRIBUTES>. For more examples of using this function, see
+L<Searching|DBIx::Class::Manual::Cookbook/Searching>. For a complete
+documentation for the first argument, see L<SQL::Abstract>.
=cut
my %new = (
%{ $self->_remove_alias($values, $alias) },
%{ $self->_remove_alias($collapsed_cond, $alias) },
+ -source_handle => $self->_source_handle
);
- return $self->result_class->new(\%new,$self->_source_handle);
+ return $self->result_class->new(\%new);
}
# _collapse_cond
});
would return all CDs and include a 'name' column to the information
-passed to object inflation
+passed to object inflation. Note that the 'artist' is the name of the
+column (or relationship) accessor, and 'name' is the name of the column
+accessor in the related table.
=head2 select
=back
-Indicates column names for object inflation. This is used in conjunction with
-C<select>, usually when C<select> contains one or more function or stored
+Indicates column names for object inflation. That is, c< as >
+indicates the name that the column can be accessed as via the
+C<get_column> method (or via the object accessor, B<if one already
+exists>). It has nothing to do with the SQL code C< SELECT foo AS bar
+>.
+
+The C< as > attribute is used in conjunction with C<select>,
+usually when C<select> contains one or more function or stored
procedure names:
$rs = $schema->resultset('Employee')->search(undef, {
_columns _primaries _unique_constraints name resultset_attributes
schema from _relationships column_info_from_storage source_info/);
-__PACKAGE__->mk_group_accessors('inherited' => qw/resultset_class
+__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
result_class/);
__PACKAGE__->mk_group_ro_accessors('simple' => qw/source_name/);
$source->resultset_attributes({ order_by => [ 'id' ] });
-Specify here any attributes you wish to pass to your specialised resultset.
+Specify here any attributes you wish to pass to your specialised
+resultset. For a full list of these, please see
+L<DBIx::Class::ResultSet/ATTRIBUTES>.
=cut
=cut
sub new {
- my ($class, $attrs, $source) = @_;
+ my ($class, $attrs) = @_;
$class = ref $class if ref $class;
my $new = { _column_data => {} };
bless $new, $class;
- $new->_source_handle($source) if $source;
+ if (my $handle = delete $attrs->{-source_handle}) {
+ $new->_source_handle($handle);
+ }
+ if (my $source = delete $attrs->{-result_source}) {
+ $new->result_source($source);
+ }
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless $class->has_column($key);
$new->store_column($key => $attrs->{$key});
}
- if (my $source = delete $attrs->{-result_source}) {
- $new->result_source($source);
- }
$new->{_relationship_data} = $related if $related;
$new->{_inflated_column} = $inflated if $inflated;
=head2 update
- $obj->update;
+ $obj->update \%columns?;
Must be run on an object that is already in the database; issues an SQL
UPDATE query to commit any changes to the object to the database if
required.
+Also takes an options hashref of C<< column_name => value> pairs >> to update
+first. But be aware that this hashref might be edited in place, so dont rely on
+it being the same after a call to C<update>.
+
=cut
sub update {
sub compose_namespace {
my ($self, $target, $base) = @_;
- my %reg = %{ $self->source_registrations };
- my %target;
- my %map;
my $schema = $self->clone;
{
no warnings qw/redefine/;
my ($self, $type, $dir, $version, $pversion) = @_;
my $filename = ref($self);
- $filename =~ s/::/-/;
+ $filename =~ s/::/-/g;
$filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
$filename =~ s/$version/$pversion-$version/ if($pversion);
the outermost transaction will issue a L</txn_commit>, and txn_do() can be
called in void, scalar and list context and it will behave as expected.
+Please note that all of the code in your coderef, including non-DBIx::Class
+code, is part of a transaction. This transaction may fail out halfway, or
+it may get partially double-executed (in the case that our DB connection
+failed halfway through the transaction, in which case we reconnect and
+restart the txn). Therefore it is best that any side-effects in your coderef
+are idempotent (that is, can be re-executed multiple times and get the
+same result), and that you check up on your side-effects in the case of
+transaction failure.
+
=cut
sub txn_do {
use base 'DBIx::Class::Storage';
-use strict;
+use strict;
use warnings;
use DBI;
use SQL::Abstract::Limit;
The arrayref can either contain the same set of arguments one would
normally pass to L<DBI/connect>, or a lone code reference which returns
-a connected database handle.
+a connected database handle. Please note that the L<DBI> docs
+recommend that you always explicitly set C<AutoCommit> to either
+C<0> or C<1>. L<DBIx::Class> further recommends that it be set
+to C<1>, and that you perform transactions via our L</txn_do>
+method. L<DBIx::Class> will emit a warning if you fail to explicitly
+set C<AutoCommit> one way or the other. See below for more details.
In either case, if the final argument in your connect_info happens
to be a hashref, C<connect_info> will look there for several
force this setting for you anyways. Setting HandleError to anything
other than simple exception object wrapper might cause problems too.
+Another Important Note:
+
+DBIC can do some wonderful magic with handling exceptions,
+disconnections, and transactions when you use C<AutoCommit => 1>
+combined with C<txn_do> for transaction support.
+
+If you set C<AutoCommit => 0> in your connect info, then you are always
+in an assumed transaction between commits, and you're telling us you'd
+like to manage that manually. A lot of DBIC's magic protections
+go away. We can't protect you from exceptions due to database
+disconnects because we don't know anything about how to restart your
+transactions. You're on your own for handling all sorts of exceptional
+cases if you choose the C<AutoCommit => 0> path, just as you would
+be with raw DBI.
+
Examples:
# Simple SQLite connection
'dbi:Pg:dbname=foo',
'postgres',
'my_pg_password',
- { AutoCommit => 0 },
+ { AutoCommit => 1 },
{ quote_char => q{"}, name_sep => q{.} },
]
);
'dbi:Pg:dbname=foo',
'postgres',
'my_pg_password',
- { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
+ { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
]
);
pop(@$info) if !keys %$last_info;
}
+ # Now check the (possibly new) final argument for AutoCommit,
+ # but not in the coderef case, obviously.
+ if(ref $info->[0] ne 'CODE') {
+ $last_info = $info->[3];
+
+ warn "You *really* should explicitly set AutoCommit "
+ . "(preferably to 1) in your db connect info"
+ if !$last_info
+ || ref $last_info ne 'HASH'
+ || !defined $last_info->{AutoCommit};
+ }
+
$self->_connect_info($info);
}
ref $coderef eq 'CODE' or $self->throw_exception
('$coderef must be a CODE reference');
- return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
+ return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
+ || $self->{transaction_depth};
+
local $self->{_in_dbh_do} = 1;
my @result;
my @info = @{$self->_connect_info || []};
$self->_dbh($self->_connect(@info));
+ # Always set the transaction depth on connect, since
+ # there is no transaction in progress by definition
+ $self->{transaction_depth} = $self->_dbh->{AutoCommit} ? 0 : 1;
+
if(ref $self eq 'DBIx::Class::Storage::DBI') {
my $driver = $self->_dbh->{Driver}->{Name};
if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
$dbh;
}
-sub _dbh_txn_begin {
- my ($self, $dbh) = @_;
- if ($dbh->{AutoCommit}) {
- $self->debugobj->txn_begin()
- if ($self->debug);
- $dbh->begin_work;
- }
-}
sub txn_begin {
my $self = shift;
- $self->dbh_do($self->can('_dbh_txn_begin'))
- if $self->{transaction_depth}++ == 0;
-}
-
-sub _dbh_txn_commit {
- my ($self, $dbh) = @_;
- if ($self->{transaction_depth} == 0) {
- unless ($dbh->{AutoCommit}) {
- $self->debugobj->txn_commit()
- if ($self->debug);
- $dbh->commit;
- }
- }
- else {
- if (--$self->{transaction_depth} == 0) {
- $self->debugobj->txn_commit()
- if ($self->debug);
- $dbh->commit;
- }
+ if($self->{transaction_depth}++ == 0) {
+ $self->debugobj->txn_begin()
+ if $self->debug;
+ # this isn't ->_dbh-> because
+ # we should reconnect on begin_work
+ # for AutoCommit users
+ $self->dbh->begin_work;
}
}
sub txn_commit {
my $self = shift;
- $self->dbh_do($self->can('_dbh_txn_commit'));
+ if ($self->{transaction_depth} == 1) {
+ my $dbh = $self->_dbh;
+ $self->debugobj->txn_commit()
+ if ($self->debug);
+ $dbh->commit;
+ $self->{transaction_depth} = 0
+ if $dbh->{AutoCommit};
+ }
+ elsif($self->{transaction_depth} > 1) {
+ $self->{transaction_depth}--
+ }
}
-sub _dbh_txn_rollback {
- my ($self, $dbh) = @_;
- if ($self->{transaction_depth} == 0) {
- unless ($dbh->{AutoCommit}) {
+sub txn_rollback {
+ my $self = shift;
+ my $dbh = $self->_dbh;
+ my $autocommit;
+ eval {
+ $autocommit = $dbh->{AutoCommit};
+ if ($self->{transaction_depth} == 1) {
$self->debugobj->txn_rollback()
if ($self->debug);
$dbh->rollback;
+ $self->{transaction_depth} = 0
+ if $autocommit;
}
- }
- else {
- if (--$self->{transaction_depth} == 0) {
- $self->debugobj->txn_rollback()
- if ($self->debug);
- $dbh->rollback;
+ elsif($self->{transaction_depth} > 1) {
+ $self->{transaction_depth}--;
}
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
}
- }
-}
-
-sub txn_rollback {
- my $self = shift;
-
- eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
+ };
if ($@) {
my $error = $@;
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
$error =~ /$exception_class/ and $self->throw_exception($error);
- $self->{transaction_depth} = 0; # ensure that a failed rollback
- $self->throw_exception($error); # resets the transaction depth
+ # ensure that a failed rollback resets the transaction depth
+ $self->{transaction_depth} = $autocommit ? 0 : 1;
+ $self->throw_exception($error);
}
}
sub _execute {
my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
- if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") )
- {
+ if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
$ident = $ident->from();
}
map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
$self->debugobj->query_start($sql, @debug_bind);
}
- my $sth = eval { $self->sth($sql,$op) };
- if (!$sth || $@) {
- $self->throw_exception(
- 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
- );
- }
+ my ($rv, $sth);
+ RETRY: while (1) {
+ $sth = eval { $self->sth($sql,$op) };
- my $rv;
- if ($sth) {
- my $time = time();
-
- $rv = eval {
-
- my $placeholder_index = 1;
+ if (!$sth || $@) {
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
+ );
+ }
- foreach my $bound (@bind) {
+ if ($sth) {
+ my $time = time();
+ $rv = eval {
+ my $placeholder_index = 1;
- my $attributes = {};
- my($column_name, @data) = @$bound;
+ foreach my $bound (@bind) {
- if( $bind_attributes ) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
- }
+ my $attributes = {};
+ my($column_name, @data) = @$bound;
+
+ if( $bind_attributes ) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
+ }
- foreach my $data (@data)
- {
- $data = ref $data ? ''.$data : $data; # stringify args
+ foreach my $data (@data)
+ {
+ $data = ref $data ? ''.$data : $data; # stringify args
- $sth->bind_param($placeholder_index, $data, $attributes);
- $placeholder_index++;
- }
+ $sth->bind_param($placeholder_index, $data, $attributes);
+ $placeholder_index++;
+ }
+ }
+ $sth->execute();
+ };
+
+ if ($@ || !$rv) {
+ $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr))
+ if $self->connected;
+ $self->_populate_dbh;
+ } else {
+ last RETRY;
}
- $sth->execute();
- };
-
- if ($@ || !$rv) {
- $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
+ } else {
+ $self->throw_exception("'$sql' did not generate a statement.");
}
- } else {
- $self->throw_exception("'$sql' did not generate a statement.");
- }
+ } # While(1) to retry if disconencted
+
if ($self->debug) {
my @debug_bind =
map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
##use Data::Dumper;
##print STDERR Dumper( $data, $sql, [@bind] );
-
+
if ($sth) {
my $time = time();
-
- #$rv = eval {
- #
- # $sth->execute_array({
-
- # ArrayTupleFetch => sub {
-
- # my $values = shift @$data;
- # return if !$values;
- # return [ @{$values}[@bind] ];
- # },
-
- # ArrayTupleStatus => $tuple_status,
- # })
- #};
-
- ## Get the bind_attributes, if any exist
+
+ ## Get the bind_attributes, if any exist
my $bind_attributes = $self->source_bind_attributes($source);
- ## Bind the values and execute
- $rv = eval {
-
+ ## Bind the values and execute
+ $rv = eval {
+
my $placeholder_index = 1;
foreach my $bound (@bind) {
$attributes = $bind_attributes->{$column_name}
if defined $bind_attributes->{$column_name};
}
-
- my @data = map { $_->[$data_index] } @$data;
+
+ my @data = map { $_->[$data_index] } @$data;
$sth->bind_param_array( $placeholder_index, [@data], $attributes );
$placeholder_index++;
}
- $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
+ $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
- };
+ };
if ($@ || !defined $rv) {
my $errors = '';
- foreach my $tuple (@$tuple_status)
- {
+ foreach my $tuple (@$tuple_status) {
$errors .= "\n" . $tuple->[1] if(ref $tuple);
}
$self->throw_exception("Error executing '$sql': ".($@ || $errors));
my $data_type = $source->column_info($column)->{data_type} || '';
$bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
- if $data_type;
+ if $data_type;
}
return $bind_attributes;
}
my %result;
- my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
+ my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
$sth->execute;
my @columns = @{$sth->{NAME_lc}};
for my $i ( 0 .. $#columns ){
my %column_info;
- my $type_num = $sth->{TYPE}->[$i];
- my $type_name;
- if(defined $type_num && $dbh->can('type_info')) {
- my $type_info = $dbh->type_info($type_num);
- $type_name = $type_info->{TYPE_NAME} if $type_info;
- }
- $column_info{data_type} = $type_name ? $type_name : $type_num;
+ $column_info{data_type} = $sth->{TYPE}->[$i];
$column_info{size} = $sth->{PRECISION}->[$i];
$column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
$result{$columns[$i]} = \%column_info;
}
+ $sth->finish;
+
+ foreach my $col (keys %result) {
+ my $colinfo = $result{$col};
+ my $type_num = $colinfo->{data_type};
+ my $type_name;
+ if(defined $type_num && $dbh->can('type_info')) {
+ my $type_info = $dbh->type_info($type_num);
+ $type_name = $type_info->{TYPE_NAME} if $type_info;
+ $colinfo->{data_type} = $type_name if $type_name;
+ }
+ }
return \%result;
}
=back
-Advances the cursor to the next row and returns an arrayref of column values.
+Advances the cursor to the next row and returns an array of column
+values (the result of L<DBI/fetchrow_array> method).
=cut
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use base qw/DBIx::Class::Storage::DBI/;
-use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+sub _rebless {
+ my ($self) = @_;
-# __PACKAGE__->load_components(qw/PK::Auto/);
+ my $version = eval { $self->_dbh->get_info(18); };
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
- my $sql = 'SELECT ' . $seq . '.currval FROM DUAL';
- my ($id) = $dbh->selectrow_array($sql);
- return $id;
-}
-
-sub _dbh_get_autoinc_seq {
- my ($self, $dbh, $source, $col) = @_;
-
- # look up the correct sequence automatically
- my $sql = q{
- SELECT trigger_body FROM ALL_TRIGGERS t
- WHERE t.table_name = ?
- AND t.triggering_event = 'INSERT'
- AND t.status = 'ENABLED'
- };
-
- # trigger_body is a LONG
- $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
-
- my $sth = $dbh->prepare($sql);
- $sth->execute( uc($source->name) );
- while (my ($insert_trigger) = $sth->fetchrow_array) {
- return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
- }
- croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'.";
-}
+ if ( !$@ ) {
+ my ($major, $minor, $patchlevel) = split(/\./, $version);
-sub get_autoinc_seq {
- my ($self, $source, $col) = @_;
-
- $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $source, $col);
-}
+ # Default driver
+ my $class = $major >= 8
+ ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
+ : 'DBIx::Class::Storage::DBI::Oracle::Generic';
-sub columns_info_for {
- my ($self, $table) = @_;
+ # Load and rebless
+ eval "require $class";
- $self->next::method(uc($table));
+ bless $self, $class unless $@;
+ }
}
=head1 NAME
-DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+DBIx::Class::Storage::DBI::Oracle - Base class for Oracle driver
=head1 SYNOPSIS
# In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
- __PACKAGE__->set_primary_key('id');
- __PACKAGE__->sequence('mysequence');
+ __PACKAGE__->load_components(qw/Core/);
=head1 DESCRIPTION
-This class implements autoincrements for Oracle.
+This class simply provides a mechanism for discovering and loading a sub-class
+for a specific version Oracle backend. It should be transparent to the user.
-=head1 AUTHORS
-Andy Grundman <andy@hybridized.org>
+=head1 AUTHORS
-Scott Connelly <scottsweep@yahoo.com>
+David Jack Olrik C<< <djo@cpan.org> >>
=head1 LICENSE
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle::Generic;
+# -*- mode: cperl; cperl-indent-level: 2 -*-
+
+use strict;
+use warnings;
+
+use Carp::Clan qw/^DBIx::Class/;
+
+use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
+ my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ my $sql = 'SELECT ' . $seq . '.currval FROM DUAL';
+ my ($id) = $dbh->selectrow_array($sql);
+ return $id;
+}
+
+sub _dbh_get_autoinc_seq {
+ my ($self, $dbh, $source, $col) = @_;
+
+ # look up the correct sequence automatically
+ my $sql = q{
+ SELECT trigger_body FROM ALL_TRIGGERS t
+ WHERE t.table_name = ?
+ AND t.triggering_event = 'INSERT'
+ AND t.status = 'ENABLED'
+ };
+
+ # trigger_body is a LONG
+ $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
+
+ my $sth = $dbh->prepare($sql);
+ $sth->execute( uc($source->name) );
+ while (my ($insert_trigger) = $sth->fetchrow_array) {
+ return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
+ }
+ croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'.";
+}
+
+sub get_autoinc_seq {
+ my ($self, $source, $col) = @_;
+
+ $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $source, $col);
+}
+
+sub columns_info_for {
+ my ($self, $table) = @_;
+
+ $self->next::method(uc($table));
+}
+
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->sequence('mysequence');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Oracle.
+
+=head1 AUTHORS
+
+Andy Grundman <andy@hybridized.org>
+
+Scott Connelly <scottsweep@yahoo.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+
+use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
+
+use strict;
+use warnings;
+
+BEGIN {
+ package DBIC::SQL::Abstract::Oracle;
+
+ use base qw( DBIC::SQL::Abstract );
+
+ sub select {
+ my ($self, $table, $fields, $where, $order, @rest) = @_;
+
+ $self->_oracle_joins($where, @{ $table });
+
+ return $self->SUPER::select($table, $fields, $where, $order, @rest);
+ }
+
+ sub _recurse_from {
+ my ($self, $from, @join) = @_;
+
+ my @sqlf = $self->_make_as($from);
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ push (@sqlf, $self->_recurse_from(@{ $to }));
+ }
+ else {
+ push (@sqlf, $self->_make_as($to));
+ }
+ }
+
+ return join q{, }, @sqlf;
+ }
+
+ sub _oracle_joins {
+ my ($self, $where, $from, @join) = @_;
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ $self->_oracle_joins($where, @{ $to });
+ }
+
+ my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $left_join = q{};
+ my $right_join = q{};
+
+ if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
+ #TODO: Support full outer joins -- this would happen much earlier in
+ #the sequence since oracle 8's full outer join syntax is best
+ #described as INSANE.
+ die "Can't handle full outer joins in Oracle 8 yet!\n"
+ if $to_jt->{-join_type} =~ /full/i;
+
+ $left_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
+ && $to_jt->{-join_type} !~ /inner/i;
+
+ $right_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
+ && $to_jt->{-join_type} !~ /inner/i;
+ }
+
+ foreach my $lhs (keys %{ $on }) {
+ $where->{$lhs . $left_join} = \" = $on->{ $lhs }$right_join";
+ }
+ }
+ }
+}
+
+sub sql_maker {
+ my ($self) = @_;
+
+ unless ($self->_sql_maker) {
+ $self->_sql_maker(
+ new DBIC::SQL::Abstract::Oracle( $self->_sql_maker_args )
+ );
+ }
+
+ return $self->_sql_maker;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle::WhereJoins - Oracle joins in WHERE syntax
+support (instead of ANSI).
+
+=head1 PURPOSE
+
+This module was originally written to support Oracle < 9i where ANSI joins
+weren't supported at all, but became the module for Oracle >= 8 because
+Oracle's optimising of ANSI joins is horrible. (See:
+http://scsys.co.uk:8001/7495)
+
+=head1 SYNOPSIS
+
+DBIx::Class should automagically detect Oracle and use this module with no
+work from you.
+
+=head1 DESCRIPTION
+
+This class implements Oracle's WhereJoin support. Instead of:
+
+ SELECT x FROM y JOIN z ON y.id = z.id
+
+It will write:
+
+ SELECT x FROM y, z WHERE y.id = z.id
+
+It should properly support left joins, and right joins. Full outer joins are
+not possible due to the fact that Oracle requires the entire query be written
+to union the results of a left and right join, and by the time this module is
+called to create the where query and table definition part of the sql query,
+it's already too late.
+
+=head1 METHODS
+
+This module replaces a subroutine contained in DBIC::SQL::Abstract:
+
+=over
+
+=item sql_maker
+
+=back
+
+It also creates a new module in its BEGIN { } block called
+DBIC::SQL::Abstract::Oracle which has the following methods:
+
+=over
+
+=item select ($\@$;$$@)
+
+Replaces DBIC::SQL::Abstract's select() method, which calls _oracle_joins()
+to modify the column and table list before calling SUPER::select().
+
+=item _recurse_from ($$\@)
+
+Recursive subroutine that builds the table list.
+
+=item _oracle_joins ($$$@)
+
+Creates the left/right relationship in the where query.
+
+=back
+
+=head1 BUGS
+
+Does not support full outer joins.
+Probably lots more.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<DBIC::SQL::Abstract>
+
+=item L<DBIx::Class::Storage::DBI::Oracle::Generic>
+
+=item L<DBIx::Class>
+
+=back
+
+=head1 AUTHOR
+
+Justin Wheeler C<< <jwheeler@datademons.com> >>
+
+=head1 CONTRIBUTORS
+
+David Jack Olrik C<< <djo@cpan.org> >>
+
+=head1 LICENSE
+
+This module is licensed under the same terms as Perl itself.
+
+=cut
my ($self,$data_type) = @_;
my $bind_attributes = {
- bytea => { pg_type => DBD::Pg::PG_BYTEA },
+ bytea => { pg_type => DBD::Pg::PG_BYTEA },
};
if( defined $bind_attributes->{$data_type} ) {
return $backupfile;
}
+
1;
=head1 NAME
#Decide if this is a foreign key based on whether the self
#items are our primary columns.
+ $DB::single = 1 if $moniker eq 'Tests::MBTI::Result';
# If the sets are different, then we assume it's a foreign key from
# us to another table.
- # OR: If is_foreign_key attr is explicity set on one the local columns
- if ( ! exists $created_FK_rels{$rel_table}->{$key_test}
- &&
- ( !$source->compare_relationship_keys(\@keys, \@primary) ||
- grep { $source->column_info($_)->{is_foreign_key} } @keys
- )
- ) {
+ # OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
+ if ( ! exists $created_FK_rels{$rel_table}->{$key_test} &&
+ ( exists $rel_info->{attrs}{is_foreign_key_constraint} &&
+ $rel_info->{attrs}{is_foreign_key_constraint} ||
+ !$source->compare_relationship_keys(\@keys, \@primary)
+ )
+ )
+ {
$created_FK_rels{$rel_table}->{$key_test} = 1;
$table->add_constraint(
type => 'foreign_key',
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
my $dsn = $schema->storage->connect_info->[0];
-$schema->connection($dsn, { quote_char => '`', name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1 },
+ { quote_char => '`', name_sep => '.' },
+);
my $sql = '';
$schema->storage->debugcb(sub { $sql = $_[1] });
eval { $rs->first };
like($sql, qr/ORDER BY \Q${order}\E/, 'did not quote ORDER BY with scalarref');
-$schema->connection($dsn, { quote_char => [qw/[ ]/], name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1, quote_char => [qw/[ ]/], name_sep => '.' }
+);
$schema->storage->debugcb(sub { $sql = $_[1] });
$schema->storage->debug(1);
order => '12'
);
-$schema->connection($dsn, { quote_char => '`', name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1, quote_char => '`', name_sep => '.' }
+);
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
[ { father => 'person' }, { 'father.person_id' => { '!=', '42' } }, ],
[ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
);
-$match = qr/^\QHASH reference arguments are not supported in JOINS - try using \"..." instead\E/;
+$match = qr/^HASH reference arguments are not supported in JOINS - try using "\.\.\." instead/;
eval { $sa->_recurse_from(@j6) };
like( $@, $match, 'join 6 (HASH reference for ON statement dies) ok' );
my $prefetch_result = make_hash_struc($art_rs_pr);
my $nonpre_result = make_hash_struc($art_rs);
+TODO: {
+ local $TODO = 'fixing collapse in -current';
is_deeply( $prefetch_result, $nonpre_result,
'Compare 2 level prefetch result to non-prefetch result' );
+}
+
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use DBICTest::ExplodingStorage;
-plan tests => 1;
+plan tests => 3;
my $schema = DBICTest->init_schema();
is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
+
+my $storage = $schema->storage;
+$storage->ensure_connected;
+
+bless $storage, "DBICTest::ExplodingStorage";
+$schema->storage($storage);
+
+eval {
+ $schema->resultset('Artist')->create({ name => "Exploding Sheep" })
+};
+
+is($@, "", "Exploding \$sth->execute was caught");
+
+is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
+ "And the STH was retired");
+
+
1;
use strict;
use warnings;
use Test::More;
+use File::Spec;
BEGIN {
eval "use DBD::SQLite; use SQL::Translator;";
mkdir("t/var") unless -d "t/var";
unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
-my $schema_orig = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
+my $schema_orig = DBICVersion::Schema->connect(
+ "dbi:SQLite:$db_file",
+ undef,
+ undef,
+ { AutoCommit => 1 },
+);
# $schema->storage->ensure_connected();
-is($schema_orig->ddl_filename('SQLite', 't/var', '1.0'), 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Filename creation working');
+is($schema_orig->ddl_filename('SQLite', 't/var', '1.0'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-SQLite.sql'), 'Filename creation working');
$schema_orig->create_ddl_dir('SQLite', undef, 't/var');
ok(-f 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Created DDL file');
is($schema_orig->exists($tvrs), 1, 'Created schema from DDL file');
eval "use DBICVersionNew";
-my $schema_new = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
+my $schema_new = DBICVersion::Schema->connect(
+ "dbi:SQLite:$db_file",
+ undef,
+ undef,
+ { AutoCommit => 1 },
+);
unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
ok(-f 't/var/DBICVersion-Schema-1.0-2.0-SQLite.sql', 'Created DDL upgrade file');
## create new to pick up filedata for upgrade files we just made (on_connect)
-my $schema_upgrade = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
+my $schema_upgrade = DBICVersion::Schema->connect(
+ "dbi:SQLite:$db_file",
+ undef,
+ undef,
+ { AutoCommit => 1 },
+);
## do this here or let Versioned.pm do it?
$schema_upgrade->upgrade();
my $schema = DBICTest->init_schema();
-plan tests => 2;
+plan tests => 1;
-
-eval { $schema->resultset('FileColumn')->create({file=>'wrong set'}) };
-ok($@, 'FileColumn checking for checks against bad sets');
-my $fh = new IO::File('t/96file_column.pm','r');
-eval { $schema->resultset('FileColumn')->create({file => {handle => $fh, filename =>'96file_column.pm'}})};
+my $fh = new IO::File('t/96file_column.t','r');
+eval { $schema->resultset('FileColumn')->create({file => {handle => $fh, filename =>'96file_column.t'}})};
ok(!$@,'FileColumn checking if file handled properly.');
my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-$dsn = 'dbi:Pg:dbname=postgres;host=localhost' unless $dsn;
-$dbuser = 'postgres' unless $dbuser;
-$dbpass = 'postgres' unless $dbpass;
-
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
unless ($dsn && $dbuser);
plan tests => 3;
-DBICTest::Schema->compose_connection('PGTest' => $dsn, $dbuser, $dbpass);
+my $schema = DBICTest::Schema->connection($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
-my $dbh = PGTest->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
$dbh->do(qq[
],{ RaiseError => 1, PrintError => 1 });
-PGTest::Artist->load_components(qw/
+$schema->class('Artist')->load_components(qw/
PK::Auto
Core
/);
-PGTest::Artist->add_columns(
+$schema->class('Artist')->add_columns(
"media", {
# test primary key handling
my $big_long_string = 'abcd' x 250000;
-my $new = PGTest::Artist->create({ media => $big_long_string });
+my $new = $schema->resultset('Artist')->create({ media => $big_long_string });
ok($new->artistid, "Created a blob row");
is($new->media, $big_long_string, "Set the blob correctly.");
-my $rs = PGTest::Artist->find({artistid=>$new->artistid});
+my $rs = $schema->resultset('Artist')->find({artistid=>$new->artistid});
is($rs->get_column('media'), $big_long_string, "Created the blob correctly.");
eval "use DBIx::Class::CDBICompat;";
plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 30);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 31);
}
use lib 't/testlib';
use Film;
use Actor;
-Film->has_many(actors => Actor => 'Film', { order_by => 'name' });
Actor->has_a(Film => 'Film');
+Film->has_many(actors => 'Actor', { order_by => 'name' });
is(Actor->primary_column, 'id', "Actor primary OK");
ok(Actor->can('Salary'), "Actor table set-up OK");
is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");
+
+# Test infering of the foreign key of a has_many from an existing has_a
+{
+ use Thing;
+ use OtherThing;
+
+ Thing->has_a(that_thing => "OtherThing");
+ OtherThing->has_many(things => "Thing");
+
+ my $other_thing = OtherThing->create({ id => 1 });
+ Thing->create({ id => 1, that_thing => $other_thing });
+ Thing->create({ id => 2, that_thing => $other_thing });
+
+ is_deeply [sort map { $_->id } $other_thing->things], [1,2];
+}
: 'compose_namespace');
my $schema = DBICTest::Schema->$compose_method('DBICTest')
- ->connect($dsn, $dbuser, $dbpass);
+ ->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
$schema->storage->on_connect_do(['PRAGMA synchronous = OFF']);
if ( !$args{no_deploy} ) {
__PACKAGE__->deploy_schema( $schema );
--- /dev/null
+package DBICTest::ExplodingStorage::Sth;
+
+sub execute {
+ die "Kablammo!";
+}
+
+sub bind_param {}
+
+package DBICTest::ExplodingStorage;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Storage::DBI::SQLite';
+
+my $count = 0;
+sub sth {
+ my ($self, $sql) = @_;
+ return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++;
+ return $self->next::method($sql);
+}
+
+sub connected {
+ return 0 if $count == 1;
+ return shift->next::method(@_);
+}
+
+1;
my $dsn = "dbi:SQLite:${db_file}";
__PACKAGE__->load_classes("Test");
-my $schema = __PACKAGE__->compose_connection(__PACKAGE__, $dsn);
+my $schema = __PACKAGE__->compose_connection(
+ __PACKAGE__,
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1 }
+);
my $dbh = DBI->connect($dsn);
use warnings;
use base qw/DBIx::Class::Core/;
-__PACKAGE__->load_components(qw/FileColumn/);
+__PACKAGE__->load_components(qw/InflateColumn::File/);
__PACKAGE__->table('file_columns');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use Class::Inspector ();
+
+unshift(@INC, './t/lib');
+use lib 't/lib';
+plan tests => 5;
+
+use DBICTest;
+
+is(DBICTest::Schema->source('Artist')->resultset_class, 'DBIx::Class::ResultSet', 'default resultset class');
+ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded');
+DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A');
+ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded automatically');
+is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
+
+my $schema = DBICTest->init_schema;
+my $resultset = $schema->resultset('Artist')->search;
+isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
--- /dev/null
+package OtherThing;
+use base 'DBIx::Class::Test::SQLite';
+
+OtherThing->set_table("other_thing");
+OtherThing->columns(All => qw(id));
+
+sub create_sql {
+ return qq{
+ id INTEGER
+ };
+}
--- /dev/null
+package Thing;
+use base 'DBIx::Class::Test::SQLite';
+
+Thing->set_table("thing");
+Thing->columns(All => qw(id that_thing));
+
+sub create_sql {
+ return qq{
+ id INTEGER,
+ that_thing INTEGER
+ };
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff