1;
-Create a class the represent artists, who have many
-CDs, in DB/Main/Artist.pm:
+Create a class that represent artists, who have many CDs, in DB/Main/Artist.pm:
package DB::Main::Artist;
use base qw/DBIx::Class/;
1;
-A class to represent a CD, which belongs to an
-artist, in DB/Main/CD.pm:
+A class to represent a CD, which belongs to an artist, in DB/Main/CD.pm:
package DB::Main::CD;
use base qw/DBIx::Class/;
my $all_artists_rs = $ds->resultset('Artist');
# Create a result set to search for artists.
- # This does not query the DB, yet.
+ # This does not query the DB.
my $johns_rs = $ds->resultset('Artist')->search(
# Build your WHERE using an SQL::Abstract structure:
{ 'name' => { 'like', 'John%' } }
);
- # Now the query is executed.
+ # This executes a joined query to get the cds
my @all_john_cds = $johns_rs->search_related('cds')->all;
# Queries but only fetches one row so far.
{ order_by => 'title' }
);
- my $millenium_cds_rs = $ds->resultset('CD')->search(
+ my $millennium_cds_rs = $ds->resultset('CD')->search(
{ year => 2000 },
{ prefetch => 'artist' }
);
- my $cd = $millenium_cds_rs->next; # SELECT ... FROM cds JOIN artists ...
+ my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ...
my $cd_artist_name = $cd->artist->name; # Already has the data so no query
my $new_cd = $ds->resultset('CD')->new({ title => 'Spoon' });
$ds->txn_do(sub { $new_cd->update }); # Runs the update in a transaction
- $millenium_cds_rs->update({ year => 2002 }); # Single-query bulk update
+ $millennium_cds_rs->update({ year => 2002 }); # Single-query bulk update
=head1 DESCRIPTION
DBIx::Class can handle multi-column primary and foreign keys, complex
queries and database-level paging, and does its best to only query the
-database when it actually needs to in order to return something the user's
+database when it actually needs to in order to return something you've directly
asked for. If a resultset is used as an iterator it only fetches rows off
the statement handle as requested in order to minimise memory usage. It
has auto-increment support for SQLite, MySQL, PostgreSQL, Oracle, SQL
test cases are *always* welcome and point releases are put out rapidly as
bugs are found and fixed.
-Even so, we do your best to maintain full backwards compatibility for published
+Even so, we do our best to maintain full backwards compatibility for published
APIs since DBIx::Class is used in production in a number of organisations;
the test suite is now fairly substantial and several developer releases are
-generally made to CPAN before the -current branch is merged back to trunk.
+generally made to CPAN before the -current branch is merged back to trunk for
+a major release.
The community can be found via -
=head1 AUTHOR
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
=head1 CONTRIBUTORS
-Alexander Hartmaier <alex_hartmaier@hotmail.com>
+abraxxa: Alexander Hartmaier <alex_hartmaier@hotmail.com>
-Andy Grundman <andy@hybridized.org>
+andyg: Andy Grundman <andy@hybridized.org>
-Andres Kievsky
+ank: Andres Kievsky
-Brandon Black
+blblack: Brandon Black
-Brian Cassidy <bricas@cpan.org>
+LTJake: Brian Cassidy <bricas@cpan.org>
-Christopher H. Laco
+claco: Christopher H. Laco
-CL Kao
+clkao: CL Kao
-Daisuke Murase <typester@cpan.org>
+typester: Daisuke Murase <typester@cpan.org>
-Dan Kubb <dan.kubb-cpan@onautopilot.com>
+dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
-Dan Sully <daniel@cpan.org>
+Numa: Dan Sully <daniel@cpan.org>
-Daniel Westermann-Clark <danieltwc@cpan.org>
+dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
-David Kamholz <dkamholz@cpan.org>
+ningu: David Kamholz <dkamholz@cpan.org>
-Jesper Krogh
+jesper: Jesper Krogh
-Jess Robinson
+castaway: Jess Robinson
-Jules Bean
+quicksilver: Jules Bean
-Justin Guenther <guentherj@agr.gc.ca>
+jguenther: Justin Guenther <guentherj@agr.gc.ca>
-Marcus Ramberg <mramberg@cpan.org>
+draven: Marcus Ramberg <mramberg@cpan.org>
-Nigel Metheringham <nigelm@cpan.org>
+nigel: Nigel Metheringham <nigelm@cpan.org>
-Paul Makepeace
+paulm: Paul Makepeace
-Robert Sedlacek <phaylon@dunkelheit.at>
+phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
-sc_ of irc.perl.org#dbix-class
+sc_: Just Another Perl Hacker
-Scott McWhirter (konobi)
+konobi: Scott McWhirter
-Scotty Allen <scotty@scottyallen.com>
+scotty: Scotty Allen <scotty@scottyallen.com>
Todd Lipcon
-Will Hawes
+wdh: Will Hawes
=head1 LICENSE
=head2 mk_group_accessors
-Creates a set of accessors in a given group.
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
-=head3 Arguments: $group, @fieldspec
+Creates a set of accessors in a given group.
$group is the name of the accessor group for the generated accessors; they
will call get_$group($field) on get and set_$group($field, $value) on set.
this is used as both field and accessor name, if a listref it is expected to
be of the form [ $accessor, $field ].
-=head3 Return value: none
-
=cut
sub mk_group_accessors {
=head2 mk_group_ro_accessors
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
+
Creates a set of read only accessors in a given group. Identical to
<L:/mk_group_accessors> but accessors will throw an error if passed a value
rather than setting the value.
-=head3 Arguments: $group, @fieldspec
-
-=head3 Return value: none
-
=cut
sub mk_group_ro_accessors {
=head2 mk_group_wo_accessors
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
+
Creates a set of write only accessors in a given group. Identical to
<L:/mk_group_accessors> but accessors will throw an error if not passed a
value rather than getting the value.
-=head3 Arguments: $group, @fieldspec
-
-=head3 Return value: none
-
=cut
sub mk_group_wo_accessors {
=head2 make_group_accessor
-Returns a single accessor in a given group; called by mk_group_accessors
-for each entry in @fieldspec.
+=over 4
+
+=item Arguments: $group, $field
-=head3 Arguments: $group, $field
+Returns: $sub (\CODE)
-=head3 Return value: $sub (\CODE)
+=back
+
+Returns a single accessor in a given group; called by mk_group_accessors
+for each entry in @fieldspec.
=cut
=head2 make_group_ro_accessor
-Returns a single read-only accessor in a given group; called by
-mk_group_ro_accessors for each entry in @fieldspec.
+=over 4
+
+=item Arguments: $group, $field
-=head3 Arguments: $group, $field
+Returns: $sub (\CODE)
-=head3 Return value: $sub (\CODE)
+=back
+
+Returns a single read-only accessor in a given group; called by
+mk_group_ro_accessors for each entry in @fieldspec.
=cut
=head2 make_group_wo_accessor
-Returns a single write-only accessor in a given group; called by
-mk_group_wo_accessors for each entry in @fieldspec.
+=over 4
+
+=item Arguments: $group, $field
+
+Returns: $sub (\CODE)
-=head3 Arguments: $group, $field
+=back
-=head3 Return value: $sub (\CODE)
+Returns a single write-only accessor in a given group; called by
+mk_group_wo_accessors for each entry in @fieldspec.
=cut
=head2 get_simple
-Simple getter for hash-based objects which returns the value for the field
-name passed as an argument.
+=over 4
-=head3 Arguments: $field
+=item Arguments: $field
-=head3 Return value: $value
+Returns: $value
+
+=back
+
+Simple getter for hash-based objects which returns the value for the field
+name passed as an argument.
=cut
=head2 set_simple
-Simple setter for hash-based objects which sets and then returns the value
-for the field name passed as an argument.
+=over 4
+
+=item Arguments: $field, $new_value
-=head3 Arguments: $field, $new_value
+Returns: $new_value
-=head3 Return value: $new_value
+=back
+
+Simple setter for hash-based objects which sets and then returns the value
+for the field name passed as an argument.
=cut
=head2 get_component_class
+=over 4
+
+=item Arguments: $name
+
+Returns: $component_class
+
+=back
+
Returns the class name for a component; returns an object key if called on
an object, or attempts to return classdata referenced by _$name if called
on a class.
-=head3 Arguments: $name
-
-=head3 Return value: $component_class
-
=cut
sub get_component_class {
=head2 set_component_class
+=over 4
+
+=item Arguments: $name, $new_component_class
+
+Returns: $new_component_class
+
+=back
+
Sets a component class name; attempts to require the class before setting
but does not error if unable to do so. Sets an object key of the given name
if called or an object or classdata called _$name if called on a class.
-=head3 Arguments: $name, $new_component_class
-
-=head3 Return value: $new_component_class
-
=cut
sub set_component_class {
return $self->{$set} = $val;
} else {
$set = "_$set";
- return $self->can($set) ? $self->$set($val) : $self->mk_classdata($set => $val);
+ return $self->can($set) ?
+ $self->$set($val) :
+ $self->mk_classdata($set => $val);
}
}
=head1 NAME
-DBIx::Class::CDBICompat - Class::DBI Compatability layer.
+DBIx::Class::CDBICompat - Class::DBI Compatibility layer.
=head1 SYNOPSIS
=head1 DESCRIPTION
-DBIx::Class features a fully featured compability layer with L<Class::DBI>
+DBIx::Class features a fully featured compatibility layer with L<Class::DBI>
to ease transition for existing CDBI users. In fact, this class is just a
receipe containing all the features emulated. If you like, you can choose
which features to emulate by building your own class and loading it like
=item LiveObjectIndex
The live object index tries to ensure there is only one version of a object
-in the perl interprenter.
+in the perl interpreter.
=item MightHave
package # hide from PAUSE
DBIx::Class::CDBICompat::AttributeAPI;
+use strict;
+use warnings;
+
sub _attrs {
my ($self, @atts) = @_;
return @{$self->{_column_data}}{@atts};
package # hide from PAUSE
DBIx::Class::CDBICompat::GetSet;
+use strict;
+use warnings;
+
#use base qw/Class::Accessor/;
sub get {
package # hide from PAUSE
DBIx::Class::ClassResolver::PassThrough;
+use strict;
+use warnings;
+
sub class {
shift;
return shift;
package # hide from PAUSE
DBIx::Class::Componentised;
+use strict;
+use warnings;
+
use Class::C3;
sub inject_base {
package DBIx::Class::DB;
+use strict;
+use warnings;
+
use base qw/DBIx::Class/;
use DBIx::Class::Schema;
use DBIx::Class::Storage::DBI;
__PACKAGE__->load_components(qw/ResultSetProxy/);
-*dbi_commit = \&txn_commit;
-*dbi_rollback = \&txn_rollback;
+{
+ no warnings 'once';
+ *dbi_commit = \&txn_commit;
+ *dbi_rollback = \&txn_rollback;
+}
sub storage { shift->schema_instance(@_)->storage; }
If you're using the CDBI Compat layer, we suggest reading the L<Class::DBI>
documentation. It should behave the same way.
+=head2 L<DBIx::Class::Manual::Component>
+
+Listing of existing components, and documentation and example on how to
+develop new ones.
+
=cut
--- /dev/null
+
+=head1 NAME
+
+DBIx::Class::Manual::Component - Existing components and how to develop new ones.
+
+=head1 USING
+
+Components are loaded using the load_components() method within your
+DBIx::Class classes.
+
+ package My::Thing;
+ use base qw( DBIx::Class );
+ __PACKAGE__->load_components(qw( PK::Auto Core ));
+
+Generally you do not want to specify the full package name
+of a component, instead take off the DBIx::Class:: part of
+it and just include the rest. If you do want to load a
+component outside of the normal namespace you can do so
+by prepending the component name with a +.
+
+ __PACKAGE__->load_components(qw( +My::Component ));
+
+Once a component is loaded all of it's methods, or otherwise,
+that it provides will be available in your class.
+
+The order in which is you load the components may be
+very important, depending on the component. The general
+rule of thumb is to first load extra components and then
+load core ones last. If you are not sure, then read the
+docs for the components you are using and see if they
+mention anything about the order in which you should load
+them.
+
+=head1 EXISTING COMPONENTS
+
+=head2 Extra
+
+These components provide extra functionality beyond
+basic functionality that you can't live without.
+
+L<DBIx::Class::CDBICompat> - Class::DBI Compatibility layer.
+
+L<DBIx::Class::FormTools> - Build forms with multiple interconnected objects.
+
+L<DBIx::Class::HTMLWidget> - Like FromForm but with DBIx::Class and HTML::Widget.
+
+L<DBIx::Class::PK::Auto> - Retrieve automatically created primary keys upon insert.
+
+L<DBIx::Class::QueriesTime> - Display the amount of time it takes to run queries.
+
+L<DBIx::Class::RandomStringColumns> - Declare virtual columns that return random strings.
+
+L<DBIx::Class::UTF8Columns> - Force UTF8 (Unicode) flag on columns.
+
+L<DBIx::Class::UUIDColumns> - Implicit UUID columns.
+
+L<DBIx::Class::WebForm> - CRUD methods.
+
+=head2 Experimental
+
+These components are under development, there interfaces may
+change, they may not work, etc. So, use them if you want, but
+be warned.
+
+L<DBIx::Class::Serialize> - Hooks for Storable freeze/thaw.
+
+L<DBIx::Class::Serialize::Storable> - Hooks for Storable freeze/thaw.
+
+L<DBIx::Class::Validation> - Validate all data before submitting to your database.
+
+=head2 Core
+
+These are the components that all, or nearly all, people will use
+without even knowing it. These components provide most of
+DBIx::Class' functionality.
+
+L<DBIx::Class::AccessorGroup> - Lets you build groups of accessors.
+
+L<DBIx::Class::Core> - Loads various components that "most people" would want.
+
+L<DBIx::Class::DB> - Non-recommended classdata schema component.
+
+L<DBIx::Class::InflateColumn> - Automatically create objects from column data.
+
+L<DBIx::Class::PK> - This class contains methods for handling primary keys and methods depending on them.
+
+L<DBIx::Class::Relationship> - Inter-table relationships.
+
+L<DBIx::Class::ResultSourceProxy::Table> - Provides a classdata table object and method proxies.
+
+L<DBIx::Class::Row> - Basic row methods.
+
+=head1 CREATEING COMPONENTS
+
+Making your own component is very easy.
+
+ package DBIx::Class::MyComp;
+ use base qw(DBIx::Class);
+ # Create methods, accessors, load other components, etc.
+ 1;
+
+When a component is loaded it is included in the calling
+class' inheritance chain using L<Class::C3>. As well as
+providing custom utility methods, a component may also
+override methods provided by other core components, like
+L<DBIx::Class::Row> and others. For example, you
+could override the insert and delete methods.
+
+ sub insert {
+ my $self = shift;
+ # Do stuff with $self, like set default values.
+ return $self->nest::method( @_ );
+ }
+
+ sub delete {
+ my $self = shift;
+ # Do stuff with $self.
+ return $self->nest::method( @_ );
+ }
+
+Now, the order that a component is loaded is very important. Components
+that are loaded first are the first ones in the inheritance stack. So, if
+you override insert() but the DBIx::Class::Row component is loaded first
+then your insert() will never be called, since the DBIx::Class::Row insert()
+will be called first. If you are unsure as to why a given method is not
+being called try printing out the Class::C3 inheritance stack.
+
+ print join ', ' => Class::C3::calculateMRO('YourClass::Name');
+
+Check out the L<Class::C3> docs for more information about inheritance.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Manual::Cookbook>
+
+L<DBIx::Class::Manual::FAQ>
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@cpan.org>
+
$genus->add_to_species({ name => 'troglodyte' });
$genus->wings(2);
$genus->update;
- $schema->txn_do($code, $genus); # Can have a nested transation
+ $schema->txn_do($code, $genus); # Can have a nested transaction
return $genus->species;
};
print $output;
You could use L<Module::Find> to search for all subclasses in the MyDB::*
-namespace, which is currently left as an excercise for the reader.
+namespace, which is currently left as an exercise for the reader.
=head2 Schema versioning
__PACKAGE__->storage->sql_maker->quote_char('"');
-is enough. If the left qoute differs form the right quote, the first
+is enough. If the left quote differs form the right quote, the first
notation should be used. name_sep needs to be set to allow the
SQL generator to put the quotes the correct place.
=head1 DESCRIPTION
-This tutorial will guide you through the proeccess of setting up and
+This tutorial will guide you through the process of setting up and
testing a very basic CD database using SQLite, with DBIx::Class::Schema
as the database frontend.
With these scripts we're relying on @INC looking in the current
working directory. You may want to add the MyDatabase namespaces to
-@INC in a different way when it comes to deployemnt.
+@INC in a different way when it comes to deployment.
The testdb.pl script is an excellent start for testing your database
model.
=head1 NAME
-DBIx::Class::Manual::Glossary - Deconfusion of terms used
+DBIx::Class::Manual::Glossary - Clarification of terms used.
=head1 INTRODUCTION
my $other_schema = My::Schema->connect( $dsn, $user, $password, $attrs );
-Note that L<DBIx::Class::Schema> does not cache connnections for you. If you
+Note that L<DBIx::Class::Schema> does not cache connections for you. If you
use multiple connections, you need to do this manually.
To execute some sql statements on every connect you can pass them to your schema after the connect:
=head2 might_have
- My::DBIC::Schema::Author->might_have(psuedonym => 'Psuedonyms');
- my $pname = $obj->psuedonym; # to get the Psuedonym object
+ My::DBIC::Schema::Author->might_have(pseudonym => 'Pseudonyms');
+ my $pname = $obj->pseudonym; # to get the Pseudonym object
Creates an optional one-to-one relationship with a class, where the foreign
class stores our primary key in one of its columns. Defaults to the primary
=head2 add_relationship
-=head3 Arguments: ('relname', 'Foreign::Class', $cond, $attrs)
+=over 4
+
+=item Arguments: ('relname', 'Foreign::Class', $cond, $attrs)
+
+=back
__PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
The condition needs to be an SQL::Abstract-style representation of the
join between the tables. When resolving the condition for use in a JOIN,
-keys using the psuedo-table I<foreign> are resolved to mean "the Table on the
-other side of the relationship", and values using the psuedo-table I<self>
+keys using the pseudo-table I<foreign> are resolved to mean "the Table on the
+other side of the relationship", and values using the pseudo-table I<self>
are resolved to mean "the Table this class is representing". Other
restrictions, such as by value, sub-select and other tables, may also be
used. Please check your database for JOIN parameter support.
An arrayref containing a list of accessors in the foreign class to create in
the main class. If, for example, you do the following:
- MyDB::Schema::CD->might_have(liner_notes => 'MyDB::Schema::LinerNotes', undef, {
- proxy => [ qw/notes/ ],
- });
+ MyDB::Schema::CD->might_have(liner_notes => 'MyDB::Schema::LinerNotes',
+ undef, {
+ proxy => [ qw/notes/ ],
+ });
Then, assuming MyDB::Schema::LinerNotes has an accessor named notes, you can do:
=head2 register_relationship
-=head3 Arguments: ($relname, $rel_info)
+=over 4
+
+=item Arguments: ($relname, $rel_info)
+
+=back
Registers a relationship on the class. This is called internally by
L<DBIx::Class::ResultSourceProxy> to set up Accessors and Proxies.
sub register_relationship { }
-=head2 related_resultset($name)
+=head2 related_resultset
+
+=over 4
+
+=item Arguments: ($relationship_name)
+
+=item Returns: $related_resultset
+
+=back
- $rs = $obj->related_resultset('related_table');
+ $rs = $cd->related_resultset('artist');
-Returns a L<DBIx::Class::ResultSet> for the relationship named $name.
+Returns a L<DBIx::Class::ResultSet> for the relationship named
+$relationship_name.
=cut
Returns the count of all the items in the related resultset, restricted by the
current item or where conditions. Can be called on a
-L<DBIx::Classl::Manual::Glossary/"ResultSet"> or a
+L<DBIx::Class::Manual::Glossary/"ResultSet"> or a
L<DBIx::Class::Manual::Glossary/"Row"> object.
=cut
my $new_obj = $obj->new_related('relname', \%col_data);
Create a new item of the related foreign class. If called on a
-L<DBIx::Class::Manual::Glossary/"Row"> object, it will magically
-set any primary key values into foreign key columns for you. The newly
-created item will not be saved into your storage until you call C<insert>
+L<DBIx::Class::Manual::Glossary/"Row"> object, it will magically set any
+primary key values into foreign key columns for you. The newly created item
+will not be saved into your storage until you call L<DBIx::Class::Row/insert>
on it.
=cut
my $found_item = $obj->find_related('relname', @pri_vals | \%pri_vals);
Attempt to find a related object using its primary key or unique constraints.
-See C<find> in L<DBIx::Class::ResultSet> for details.
+See L<DBIx::Class::ResultSet/find> for details.
=cut
my $new_obj = $obj->find_or_create_related('relname', \%col_data);
-Find or create an item of a related class. See C<find_or_create> in
-L<DBIx::Class::ResultSet> for details.
+Find or create an item of a related class. See
+L<DBIx::Class::ResultSet/"find_or_create"> for details.
=cut
example, to set the correct author for a book, find the Author object, then
call set_from_related on the book.
-The columns are only set in the local copy of the object, call C<update> to set
-them in the storage.
+The columns are only set in the local copy of the object, call L</update> to
+set them in the storage.
=cut
$book->update_from_related('author', $author_obj);
-As C<set_from_related>, but the changes are immediately updated onto your
-storage.
+The same as L</"set_from_related">, but the changes are immediately updated
+in storage.
=cut
package # hide from PAUSE
DBIx::Class::Relationship::CascadeActions;
+use strict;
+use warnings;
+
sub delete {
my ($self, @rest) = @_;
return $self->next::method(@rest) unless ref $self;
=head2 new
-=head3 Arguments: ($source, \%$attrs)
+=over 4
+
+=item Arguments: ($source, \%$attrs)
+
+=back
The resultset constructor. Takes a source object (usually a
-L<DBIx::Class::ResultSourceProxy::Table>) and an attribute hash (see L</ATTRIBUTES>
-below). Does not perform any queries -- these are executed as needed by the
-other methods.
+L<DBIx::Class::ResultSourceProxy::Table>) and an attribute hash (see
+L</ATTRIBUTES> below). Does not perform any queries -- these are
+executed as needed by the other methods.
Generally you won't need to construct a resultset manually. You'll
automatically get one from e.g. a L</search> called in scalar context:
$attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols};
delete $attrs->{as} if $attrs->{columns};
$attrs->{columns} ||= [ $source->columns ] unless $attrs->{select};
- $attrs->{select} = [ map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}} ]
- if $attrs->{columns};
- $attrs->{as} ||= [ map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} ];
+ $attrs->{select} = [
+ map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}}
+ ] if $attrs->{columns};
+ $attrs->{as} ||= [
+ map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}}
+ ];
if (my $include = delete $attrs->{include_columns}) {
push(@{$attrs->{select}}, @$include);
push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include);
$seen{$j} = 1;
}
}
- push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}, $attrs->{seen_join}));
+ push(@{$attrs->{from}}, $source->resolve_join(
+ $join, $attrs->{alias}, $attrs->{seen_join})
+ );
}
$attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
- $attrs->{order_by} = [ $attrs->{order_by} ] if $attrs->{order_by} and !ref($attrs->{order_by});
+ $attrs->{order_by} = [ $attrs->{order_by} ] if
+ $attrs->{order_by} and !ref($attrs->{order_by});
$attrs->{order_by} ||= [];
my $collapse = $attrs->{collapse} || {};
=head2 find
-=head3 Arguments: (@colvalues) | (\%cols, \%attrs?)
+=over 4
+
+=item Arguments: (@colvalues) | (\%cols, \%attrs?)
+
+=back
Finds a row based on its primary key or unique constraint. For example:
my @cols = $self->result_source->primary_columns;
if (exists $attrs->{key}) {
my %uniq = $self->result_source->unique_constraints;
- $self->throw_exception( "Unknown key $attrs->{key} on '" . $self->result_source->name . "'" )
- unless exists $uniq{$attrs->{key}};
+ $self->throw_exception(
+ "Unknown key $attrs->{key} on '" . $self->result_source->name . "'"
+ ) unless exists $uniq{$attrs->{key}};
@cols = @{ $uniq{$attrs->{key}} };
}
#use Data::Dumper; warn Dumper($attrs, @vals, @cols);
- $self->throw_exception( "Can't find unless a primary key or unique constraint is defined" )
- unless @cols;
+ $self->throw_exception(
+ "Can't find unless a primary key or unique constraint is defined"
+ ) unless @cols;
my $query;
if (ref $vals[0] eq 'HASH') {
my $rs = $self->search($query,$attrs);
return keys %{$rs->{collapse}} ? $rs->next : $rs->single;
} else {
- return keys %{$self->{collapse}} ? $self->search($query)->next : $self->single($query);
+ return keys %{$self->{collapse}} ?
+ $self->search($query)->next :
+ $self->single($query);
}
}
=head2 slice
-=head3 Arguments: ($first, $last)
+=over 4
+
+=item Arguments: ($first, $last)
+
+=back
Returns a subset of elements from the resultset.
$self->{all_cache_position} = 1;
return ($self->all)[0];
}
- my @row = (exists $self->{stashed_row}
- ? @{delete $self->{stashed_row}}
- : $self->cursor->next);
+ my @row = (exists $self->{stashed_row} ?
+ @{delete $self->{stashed_row}} :
+ $self->cursor->next
+ );
# warn Dumper(\@row); use Data::Dumper;
return unless (@row);
return $self->_construct_object(@row);
}
}
- my @collapse = (defined($prefix)
- ? (map { (m/^\Q${prefix}.\E(.+)$/ ? ($1) : ()); }
- keys %{$self->{collapse}})
- : keys %{$self->{collapse}});
+ my @collapse;
+ if (defined $prefix) {
+ @collapse = map {
+ m/^\Q${prefix}.\E(.+)$/ ? ($1) : ()
+ } keys %{$self->{collapse}}
+ } else {
+ @collapse = keys %{$self->{collapse}};
+ };
+
if (@collapse) {
my ($c) = sort { length $a <=> length $b } @collapse;
my $target = $info;
my $tree = $self->_collapse_result($as, $row, $c_prefix);
my (@final, @raw);
while ( !(grep {
- !defined($tree->[0]->{$_})
- || $co_check{$_} ne $tree->[0]->{$_}
+ !defined($tree->[0]->{$_}) ||
+ $co_check{$_} ne $tree->[0]->{$_}
} @co_key) ) {
push(@final, $tree);
last unless (@raw = $self->cursor->next);
=head2 all
-Returns all elements in the resultset. Called implictly if the resultset
+Returns all elements in the resultset. Called implicitly if the resultset
is returned in list context.
=cut
=head2 update
-=head3 Arguments: (\%values)
+=over 4
+
+=item Arguments: (\%values)
+
+=back
Sets the specified columns in the resultset to the supplied values.
sub update {
my ($self, $values) = @_;
- $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH';
+ $self->throw_exception("Values for update must be a hash")
+ unless ref $values eq 'HASH';
return $self->result_source->storage->update(
- $self->result_source->from, $values, $self->{cond});
+ $self->result_source->from, $values, $self->{cond}
+ );
}
=head2 update_all
-=head3 Arguments: (\%values)
+=over 4
+
+=item Arguments: (\%values)
+
+=back
Fetches all objects and updates them one at a time. Note that C<update_all>
will run cascade triggers while L</update> will not.
sub update_all {
my ($self, $values) = @_;
- $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH';
+ $self->throw_exception("Values for update must be a hash")
+ unless ref $values eq 'HASH';
foreach my $obj ($self->all) {
$obj->set_columns($values)->update;
}
$del->{$1} = $self->{cond}{$key};
}
}
+
} else {
$self->throw_exception(
- "Can't delete on resultset with condition unless hash or array");
+ "Can't delete on resultset with condition unless hash or array"
+ );
}
$self->result_source->storage->delete($self->result_source->from, $del);
sub pager {
my ($self) = @_;
my $attrs = $self->{attrs};
- $self->throw_exception("Can't create pager for non-paged rs") unless $self->{page};
+ $self->throw_exception("Can't create pager for non-paged rs")
+ unless $self->{page};
$attrs->{rows} ||= 10;
return $self->{pager} ||= Data::Page->new(
$self->_count, $attrs->{rows}, $self->{page});
=head2 page
-=head3 Arguments: ($page_num)
+=over 4
+
+=item Arguments: ($page_num)
+
+=back
Returns a new resultset for the specified page.
=head2 new_result
-=head3 Arguments: (\%vals)
+=over 4
+
+=item Arguments: (\%vals)
+
+=back
Creates a result in the resultset's result class.
my ($self, $values) = @_;
$self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- $self->throw_exception( "Can't abstract implicit construct, condition not a hash" )
- if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
+ $self->throw_exception(
+ "Can't abstract implicit construct, condition not a hash"
+ ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
my %new = %$values;
my $alias = $self->{attrs}{alias};
foreach my $key (keys %{$self->{cond}||{}}) {
=head2 create
-=head3 Arguments: (\%vals)
+=over 4
+
+=item Arguments: (\%vals)
+
+=back
Inserts a record into the resultset and returns the object.
sub create {
my ($self, $attrs) = @_;
- $self->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
+ $self->throw_exception( "create needs a hashref" )
+ unless ref $attrs eq 'HASH';
return $self->new_result($attrs)->insert;
}
=head2 find_or_create
-=head3 Arguments: (\%vals, \%attrs?)
+=over 4
+
+=item Arguments: (\%vals, \%attrs?)
+
+=back
$class->find_or_create({ key => $val, ... });
=head2 set_cache
-Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset.
+Sets the contents of the cache for the resultset. Expects an arrayref
+of objects of the same class as those produced by the resultset.
=cut
if ref $data ne 'ARRAY';
my $result_class = $self->result_class;
foreach( @$data ) {
- $self->throw_exception("cannot cache object of type '$_', expected '$result_class'")
- if ref $_ ne $result_class;
+ $self->throw_exception(
+ "cannot cache object of type '$_', expected '$result_class'"
+ ) if ref $_ ne $result_class;
}
$self->{all_cache} = $data;
}
=head1 ATTRIBUTES
+XXX: FIXME: Attributes docs need clearing up
+
The resultset takes various attributes that modify its behavior. Here's an
overview of them:
=head2 columns
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@columns)
+
+=back
Shortcut to request a particular set of columns to be retrieved. Adds
C<me.> onto the start of any column without a C<.> in it and sets C<select>
=head2 include_columns
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@columns)
+
+=back
Shortcut to include additional columns in the returned results - for example
=head2 select
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@columns)
+
+=back
Indicates which columns should be selected from the storage. You can use
column names, or in the case of RDBMS back ends, function or stored procedure
=head2 as
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@names)
+
+=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
=head2 prefetch
-=head3 Arguments: arrayref/hashref
+=over 4
+
+=item Arguments: (\@relationships)
+
+=back
Contains one or more relationships that should be fetched along with the main
query (when they are accessed afterwards they will have already been
=head2 from
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@array)
+
+=back
The C<from> attribute gives you manual control over the C<FROM> clause of SQL
statements generated by L<DBIx::Class>, allowing you to express custom C<JOIN>
=head2 page
+=over 4
+
+=item Arguments: ($page)
+
+=back
+
For a paged resultset, specifies which page to retrieve. Leave unset
for an unpaged resultset.
=head2 rows
-For a paged resultset, how many rows per page:
+=over 4
+
+=item Arguments: ($rows)
+
+=back
+
+For a paged resultset, specifies how many rows are in each page:
rows => 10
=head2 group_by
-=head3 Arguments: (arrayref)
+=over 4
+
+=item Arguments: (\@columns)
+
+=back
A arrayref of columns to group by. Can include columns of joined tables.
package DBIx::Class::ResultSetManager;
use strict;
+use warnings;
use base 'DBIx::Class';
use Class::Inspector;
package # hide from PAUSE
DBIx::Class::ResultSetProxy;
+use strict;
+use warnings;
+
use base qw/DBIx::Class/;
sub search { shift->resultset_instance->search(@_); }
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/AccessorGroup/);
-__PACKAGE__->mk_group_accessors('simple' =>
- qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes schema from _relationships/);
-__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/);
+__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
+ _columns _primaries _unique_constraints name resultset_attributes
+ schema from _relationships/);
+
+__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
+ result_class/);
=head1 NAME
sub columns {
my $self = shift;
- $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
+ $self->throw_exception(
+ "columns() is a read-only accessor, did you mean add_columns()?"
+ ) if (@_ > 1);
return @{$self->{_ordered_columns}||[]};
}
=head2 set_primary_key
-=head3 Arguments: (@cols)
+=over 4
+
+=item Arguments: (@cols)
+
+=back
Defines one or more columns as primary key for this source. Should be
called after C<add_columns>.
constraint. Unique constraints are used when you call C<find> on a
L<DBIx::Class::ResultSet>, only columns in the constraint are searched,
- # For e.g. UNIQUE (column1, column2)
- __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
+e.g.,
+
+ # For UNIQUE (column1, column2)
+ __PACKAGE__->add_unique_constraint(
+ constraint_name => [ qw/column1 column2/ ],
+ );
=cut
sub add_relationship {
my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
- $self->throw_exception("Can't create relationship without join condition") unless $cond;
+ $self->throw_exception("Can't create relationship without join condition")
+ unless $cond;
$attrs ||= {};
my %rels = %{ $self->_relationships };
=head2 relationship_info
-=head3 Arguments: ($relname)
+=over 4
+
+=item Arguments: ($relname)
+
+=back
Returns the relationship information for the specified relationship name
=head2 has_relationship
-=head3 Arguments: ($rel)
+=over 4
+
+=item Arguments: ($rel)
+
+=back
Returns 1 if the source has a relationship of this name, 0 otherwise.
=head2 resolve_join
-=head3 Arguments: ($relation)
+=over 4
+
+=item Arguments: ($relation)
+
+=back
Returns the join structure required for the related result source
=head2 resolve_condition
-=head3 Arguments: ($cond, $as, $alias|$object)
+=over 4
+
+=item Arguments: ($cond, $as, $alias|$object)
+
+=back
Resolves the passed condition to a concrete query fragment. If given an alias,
returns a join condition; if given an object, inverts that object to produce
my %ret;
while (my ($k, $v) = each %{$cond}) {
# XXX should probably check these are valid columns
- $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
- $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
+ $k =~ s/^foreign\.// ||
+ $self->throw_exception("Invalid rel cond key ${k}");
+ $v =~ s/^self\.// ||
+ $self->throw_exception("Invalid rel cond val ${v}");
if (ref $for) { # Object
#warn "$self $k $for $v";
$ret{$k} = $for->get_column($v);
=head2 resolve_prefetch
-=head3 Arguments: (hashref/arrayref/scalar)
+=over 4
+
+=item Arguments: (hashref/arrayref/scalar)
+
+=back
Accepts one or more relationships for the current source and returns an
array of column names for each of those relationships. Column names are
=head2 related_source
-=head3 Arguments: ($relname)
+=over 4
+
+=item Arguments: ($relname)
+
+=back
Returns the result source object for the given relationship
=head2 related_class
-=head3 Arguments: ($relname)
+=over 4
+
+=item Arguments: ($relname)
+
+=back
Returns the class object for the given relationship
sub resultset {
my $self = shift;
- $self->throw_exception('resultset does not take any arguments. If you want another resultset, call it on the schema instead.') if scalar @_;
- return $self->{_resultset} if ref $self->{_resultset} eq $self->resultset_class;
- return $self->{_resultset} = $self->resultset_class->new($self, $self->{resultset_attributes});
+ $self->throw_exception(
+ 'resultset does not take any arguments. If you want another resultset, '.
+ 'call it on the schema instead.'
+ ) if scalar @_;
+ return $self->{_resultset}
+ if ref $self->{_resultset} eq $self->resultset_class;
+ return $self->{_resultset} = $self->resultset_class->new(
+ $self, $self->{resultset_attributes}
+ );
}
=head2 throw_exception
$class = ref $class if ref $class;
my $new = bless { _column_data => {} }, $class;
if ($attrs) {
- $new->throw_exception("attrs must be a hashref") unless ref($attrs) eq 'HASH';
+ $new->throw_exception("attrs must be a hashref")
+ unless ref($attrs) eq 'HASH';
while (my ($k, $v) = each %$attrs) {
- $new->throw_exception("No such column $k on $class") unless $class->has_column($k);
+ $new->throw_exception("No such column $k on $class")
+ unless $class->has_column($k);
$new->store_column($k => $v);
}
}
$obj->delete
-Deletes the object from the database. The object is still perfectly usable
-accessor-wise etc. but ->in_storage will now return 0 and the object must
-be re ->insert'ed before it can be ->update'ed
+Deletes the object from the database. The object is still perfectly usable,
+but ->in_storage() will now return 0 and the object must re inserted using
+->insert() before ->update() can be used on it.
=cut
=head2 register_column
-=head3 Arguments: ($column, $column_info)
+=over 4
+
+=item Arguments: ($column, $column_info)
+
+=back
Registers a column on the class. If the column_info has an 'accessor' key,
creates an accessor named after the value if defined; if there is no such
=head2 register_class
-=head3 Arguments: <moniker> <component_class>
+=over 4
-Registers a class which isa ResultSourceProxy; equivalent to calling
+=item Arguments: ($moniker, $component_class)
+
+=back
+
+Registers a class which isa L<DBIx::Class::ResultSourceProxy>. Equivalent to
+calling
$schema->register_source($moniker, $component_class->result_source_instance);
=head2 register_source
-=head3 Arguments: <moniker> <result source>
+=over 4
+
+=item Arguments: ($moniker, $result_source)
-Registers the result source in the schema with the given moniker
+=back
+
+Registers the L<DBIx::Class::ResultSource> in the schema with the given
+moniker.
=cut
=head2 class
- my $class = $schema->class('CD');
+=over 4
+
+=item Arguments: ($moniker)
+
+=item Returns: $classname
+
+=back
+
+Retrieves the result class name for the given moniker.
-Retrieves the result class name for a given result source
+e.g.,
+
+ my $class = $schema->class('CD');
=cut
=head2 source
+=over 4
+
+=item Arguments: ($moniker)
+
+=item Returns: $result_source
+
+=back
+
my $source = $schema->source('Book');
-Returns the result source object for the registered name
+Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
=cut
=head2 sources
- my @source_monikers = $schema->sources;
+=over 4
+
+=item Returns: @source_monikers
-Returns the source monikers of all source registrations on this schema
+=back
+
+Returns the source monikers of all source registrations on this schema.
+
+e.g.,
+
+ my @source_monikers = $schema->sources;
=cut
=head2 resultset
+=over 4
+
+=item Arguments: ($moniker)
+
+=item Returns: $result_set
+
+=back
+
my $rs = $schema->resultset('DVD');
-Returns the resultset for the registered moniker
+Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
=cut
=head2 load_classes
-=head3 Arguments: @classes?, { $namespace => [ $class+ ] }+
+=over 4
-Uses L<Module::Find> to find all classes under the database class' namespace,
-or uses the classes you select. Then it loads the component (using L<use>),
-and registers them (using B<register_class>);
+=item Arguments: @classes?, { $namespace => [ @classes ] }+
+
+=back
+
+With no arguments, this method uses L<Module::Find> to find all classes under
+the schema's namespace. Otherwise, this method loads the classes you specify
+(using L<use>), and registers them (using L</"register_class">).
It is possible to comment out classes with a leading '#', but note that perl
will think it's a mistake (trying to use a comment in a qw list) so you'll
need to add "no warnings 'qw';" before your load_classes call.
+e.g.,
+
+ My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
+ # etc. (anything under the My::Schema namespace)
+
+ # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
+ # not Other::Namespace::LinerNotes nor My::Schema::Track
+ My::Schema->load_classes(qw/ CD Artist #Track /, {
+ Other::Namespace => [qw/ Producer #LinerNotes /],
+ });
+
=cut
sub load_classes {
=head2 compose_connection
-=head3 Arguments: $target_ns, @db_info
+=over 4
+
+=item Arguments: ($target_namespace, @db_info)
+
+=item Returns: $new_schema
+
+=back
-=head3 Return value: $new_schema
+Calls L<DBIx::Class::schema/"compose_namespace"> to the target namespace,
+calls L<DBIx::Class::Schema/connection>(@db_info) on the new schema, then
+injects the L<DBix::Class::ResultSetProxy> component and a resultset_instance
+classdata entry on all the new classes in order to support
+$target_namespaces::$class->search(...) method calls.
-Calls compose_namespace to the $target_ns, calls ->connection(@db_info) on
-the new schema, then injects the ResultSetProxy component and a
-resultset_instance classdata entry on all the new classes in order to support
-$target_ns::Class->search(...) method calls. Primarily useful when you have
-a specific need for classmethod access to a connection - in normal usage
-->connect is preferred.
+This is primarily useful when you have a specific need for class method access
+to a connection. In normal usage it is preferred to call
+L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
+on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
+more information.
=cut
=head2 compose_namespace
-=head3 Arguments: $target_ns, $additional_base_class?
+=over 4
-=head3 Return value: $new_schema
+=item Arguments: $target_namespace, $additional_base_class?
-For each result source in the schema, creates a class in the target
-namespace (e.g. $target_ns::CD, $target_ns::Artist) inheriting from the
-corresponding classes attached to the current schema and a result source
-to match attached to the new $schema object. If an additional base class is
-given, injects this immediately behind the corresponding classes from the
-current schema in the created classes' @ISA.
+=item Returns: $new_schema
+
+=back
+
+For each L<DBIx::Class::ResultSource> in the schema, this method creates a
+class in the target namespace (e.g. $target_namespace::CD,
+$target_namespace::Artist) that inherits from the corresponding classes
+attached to the current schema.
+
+It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
+new $schema object. If C<$additional_base_class> is given, the new composed
+classes will inherit from first the corresponding classe from the current
+schema then the base class.
+
+e.g. (for a schema with My::Schema::CD and My::Schema::Artist classes),
+
+ $schema->compose_namespace('My::DB', 'Base::Class');
+ print join (', ', @My::DB::CD::ISA) . "\n";
+ print join (', ', @My::DB::Artist::ISA) ."\n";
+
+Will produce the output
+
+ My::Schema::CD, Base::Class
+ My::Schema::Artist, Base::Class
=cut
=head2 setup_connection_class
-=head3 Arguments: <$target> <@info>
+=over 4
+
+=item Arguments: ($target, @info)
+
+=back
-Sets up a database connection class to inject between the schema
-and the subclasses the schema creates.
+Sets up a database connection class to inject between the schema and the
+subclasses that the schema creates.
=cut
=head2 connection
-=head3 Arguments: (@args)
+=over 4
-Instantiates a new Storage object of type storage_type and passes the
-arguments to $storage->connect_info. Sets the connection in-place on
-the schema.
+=item Arguments: (@args)
+
+=item Returns: $new_schema
+
+=back
+
+Instantiates a new Storage object of type
+L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
+$storage->connect_info. Sets the connection in-place on the schema. See
+L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
=cut
=head2 connect
-=head3 Arguments: (@info)
+=over 4
+
+=item Arguments: (@info)
-Conveneience method, equivalent to $schema->clone->connection(@info)
+=item Returns: $new_schema
+
+=back
+
+This is a convenience method. It is equivalent to calling
+$schema->clone->connection(@info). See L</connection> and L</clone> for more
+information.
=cut
=head2 txn_begin
-Begins a transaction (does nothing if AutoCommit is off).
+Begins a transaction (does nothing if AutoCommit is off). Equivalent to
+calling $schema->storage->txn_begin. See
+L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
=cut
=head2 txn_commit
-Commits the current transaction.
+Commits the current transaction. Equivalent to calling
+$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+for more information.
=cut
=head2 txn_rollback
-Rolls back the current transaction.
+Rolls back the current transaction. Equivalent to calling
+$schema->storage->txn_rollback. See
+L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
=cut
=head2 txn_do
-=head3 Arguments: $coderef, @coderef_args?
+=over 4
+
+=item Arguments: (C<$coderef>, @coderef_args?)
+
+=item Returns: The return value of $coderef
-Executes C<$coderef> with (optional) arguments C<@coderef_args>
-transactionally, returning its result (if any). If an exception is
-caught, a rollback is issued and the exception is rethrown. If the
-rollback fails, (i.e. throws an exception) an exception is thrown that
-includes a "Rollback failed" message.
+=back
+
+Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
+returning its result (if any). If an exception is caught, a rollback is issued
+and the exception is rethrown. If the rollback fails, (i.e. throws an
+exception) an exception is thrown that includes a "Rollback failed" message.
For example,
}
}
-Nested transactions work as expected (i.e. only the outermost
-transaction will issue a txn_commit on the Schema's storage), and
-txn_do() can be called in void, scalar and list context and it will
-behave as expected.
+In a nested transaction (calling txn_do() from within a txn_do() coderef) only
+the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
+the Schema's storage, and txn_do() can be called in void, scalar and list
+context and it will behave as expected.
=cut
my $wantarray = wantarray; # Need to save this since the context
# inside the eval{} block is independent
# of the context that called txn_do()
-
eval {
+
# Need to differentiate between scalar/list context to allow for
# returning a list in scalar context to get the size of the list
-
if ($wantarray) {
# list context
@return_values = $coderef->(@args);
=head2 clone
+=over 4
+
+=item Returns: $new_schema
+
+=back
+
Clones the schema and its associated result_source objects and returns the
copy.
=head2 populate
-=head3 Arguments: ($moniker, \@data);
+=over 4
+
+=item Arguments: ($moniker, \@data);
+
+=back
Populates the source registered with the given moniker with the supplied data.
-@data should be a list of listrefs, the first containing column names, the
-second matching values - i.e.
+@data should be a list of listrefs -- the first containing column names, the
+second matching values.
+
+i.e.,
$schema->populate('Artist', [
[ qw/artistid name/ ],
=head2 throw_exception
-Defaults to using Carp::Clan to report errors from user perspective.
+=over 4
+
+=item Arguments: ($message)
+
+=back
+
+Throws an exception. Defaults to using L<Carp::Clan> to report errors from
+user's perspective.
=cut
=head2 deploy (EXPERIMENTAL)
-Attempts to deploy the schema to the current storage using SQL::Translator.
+=over 4
+
+=item Arguments: ($sqlt_args)
+
+=back
+
+Attempts to deploy the schema to the current storage using L<SQL::Translator>.
Note that this feature is currently EXPERIMENTAL and may not work correctly
across all databases, or fully handle complex relationships.
package DBIx::Class::Serialize::Storable;
use strict;
+use warnings;
use Storable;
sub STORABLE_freeze {
=cut
use strict;
+use warnings;
use base qw/DBIx::Class/;
package DBIx::Class::UUIDColumns;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class/;
__PACKAGE__->mk_classdata( 'uuid_auto_columns' => [] );
if (eval{require Data::UUID}) {
return '::Data::UUID';
} elsif ($^O ne 'openbsd' && eval{require APR::UUID}) {
- # APR::UUID on openbsd causes some as yet unfound nastyness for XS
+ # APR::UUID on openbsd causes some as yet unfound nastiness for XS
return '::APR::UUID';
} elsif (eval{require UUID}) {
return '::UUID';
package DBIx::Class::UUIDMaker;
+use strict;
+use warnings;
+
sub new {
return bless {}, shift;
};
sub as_string {
my $uuid;
- ...magic encantations...
+ ...magic incantations...
return $uuid;
};
package DBIx::Class::UUIDMaker::APR::UUID;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use APR::UUID ();
package DBIx::Class::UUIDMaker::Data::UUID;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use Data::UUID ();
package DBIx::Class::UUIDMaker::Data::Uniqid;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use Data::Uniqid ();
package DBIx::Class::UUIDMaker::UUID;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use UUID ();
package DBIx::Class::UUIDMaker::Win32::Guidgen;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use Win32::Guidgen ();
package DBIx::Class::UUIDMaker::Win32API::GUID;
+
+use strict;
+use warnings;
+
use base qw/DBIx::Class::UUIDMaker/;
use Win32API::GUID ();
# -------------------------------------------------------------------
# parse($tr, $data)
#
-# Note that $data, in the case of this parser, is unuseful.
+# Note that $data, in the case of this parser, is not useful.
# We're working with DBIx::Class Schemas, not data streams.
# -------------------------------------------------------------------
sub parse {
next if(!exists $rel_info->{attrs}{accessor} ||
$rel_info->{attrs}{accessor} eq 'multi');
# Going by the accessor type isn't such a good idea (yes, I know
- # I suggested it). I think the best way to tell if something's a
+ # I suggested it). I think the best way to tell if something is a
# foreign key constraint is to assume if it doesn't include our
# primaries then it is (dumb but it'll do). Ignore any rel cond
# that isn't a straight hash, but get both sets of keys in full
--- /dev/null
+#!/bin/sh
+
+cd maint;
+rm svn-log.perl;
+wget https://thirdlobe.com/svn/repo-tools/trunk/svn-log.perl;
--- /dev/null
+#!/usr/bin/env perl
+# $Id$
+
+# This program is Copyright 2005 by Rocco Caputo. All rights are
+# reserved. This program is free software. It may be modified, used,
+# and redistributed under the same terms as Perl itself.
+
+# Generate a nice looking change log from the subversion logs for a
+# Perl project. The log is also easy for machines to parse.
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Text::Wrap qw(wrap fill $columns $huge);
+use POSIX qw(strftime);
+use XML::Parser;
+
+my %month = qw(
+ Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
+ Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
+);
+
+$Text::Wrap::huge = "wrap";
+$Text::Wrap::columns = 74;
+
+my $days_back = 365; # Go back a year by default.
+my $send_help = 0; # Display help and exit.
+my $svn_repo; # Where to log from.
+
+use constant LOG_REV => 0;
+use constant LOG_DATE => 1;
+use constant LOG_WHO => 2;
+use constant LOG_MESSAGE => 3;
+use constant LOG_PATHS => 4;
+
+use constant PATH_PATH => 0;
+use constant PATH_ACTION => 1;
+use constant PATH_CPF_PATH => 2;
+use constant PATH_CPF_REV => 3;
+
+use constant TAG_REV => 0;
+use constant TAG_TAG => 1;
+use constant TAG_LOG => 2;
+
+use constant MAX_TIMESTAMP => "9999-99-99 99:99:99";
+
+GetOptions(
+ "age=s" => \$days_back,
+ "repo=s" => \$svn_repo,
+ "help" => \$send_help,
+) or exit;
+
+# Find the trunk for the current repository if one isn't specified.
+unless (defined $svn_repo) {
+ $svn_repo = `svn info . | grep '^URL: '`;
+ if (length $svn_repo) {
+ chomp $svn_repo;
+ $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
+ }
+ else {
+ $send_help = 1;
+ }
+}
+
+die(
+ "$0 usage:\n",
+ " --repo REPOSITORY\n",
+ " [--age DAYS]\n",
+ "\n",
+ "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
+ "release tags are kept.\n",
+) if $send_help;
+
+my $earliest_date = strftime "%F", gmtime(time() - $days_back * 86400);
+
+### 1. Gather a list of tags for the repository, their revisions and
+### dates.
+
+my %tag;
+
+open(TAG, "svn -v list $svn_repo/tags|") or die $!;
+while (<TAG>) {
+ # The date is unused, however.
+ next unless (
+ my ($rev, $date, $tag) = m{
+ (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
+ }x
+ );
+
+ my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
+ die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
+
+ my $timestamp = $tag_log[0][LOG_DATE];
+ $tag{$timestamp} = [
+ $rev, # TAG_REV
+ $tag, # TAG_TAG
+ [ ], # TAG_LOG
+ ];
+}
+close TAG;
+
+# Fictitious "HEAD" tag for revisions that came after the last tag.
+
+$tag{+MAX_TIMESTAMP} = [
+ "HEAD", # TAG_REV
+ "(untagged)", # TAG_TAG
+ undef, # TAG_LOG
+];
+
+### 2. Gather the log for the trunk. Place log entries under their
+### proper tags.
+
+my @tag_dates = sort keys %tag;
+while (my $date = pop(@tag_dates)) {
+
+ # We're done if this date's before our earliest date.
+ if ($date lt $earliest_date) {
+ delete $tag{$date};
+ next;
+ }
+
+ my $tag = $tag{$date}[TAG_TAG];
+ #warn "Gathering information for tag $tag...\n";
+
+ my $this_rev = $tag{$date}[TAG_REV];
+ my $prev_rev;
+ if (@tag_dates) {
+ $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
+ }
+ else {
+ $prev_rev = 0;
+ }
+
+ my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
+
+ $tag{$date}[TAG_LOG] = \@log;
+}
+
+### 3. PROFIT! No, wait... generate the nice log file.
+
+foreach my $timestamp (sort { $b cmp $a } keys %tag) {
+ my $tag_rec = $tag{$timestamp};
+
+ # Skip this tag if there are no log entries.
+ next unless @{$tag_rec->[TAG_LOG]};
+
+ my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
+ my $tag_bar = "=" x length($tag_line);
+ print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
+
+ foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
+
+ my @paths = @{$log_rec->[LOG_PATHS]};
+ if (@paths > 1) {
+ @paths = grep {
+ $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
+ } @paths;
+ }
+
+ my $time_line = wrap(
+ " ", " ",
+ join(
+ "; ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+
+ if ($time_line =~ /\n/) {
+ $time_line = wrap(
+ " ", " ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
+ ) .
+ wrap(
+ " ", " ",
+ join(
+ "; ",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+ }
+
+ print $time_line, "\n\n";
+
+ # Blank lines should have the indent level of whitespace. This
+ # makes it easier for other utilities to parse them.
+
+ my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
+ foreach my $paragraph (@paragraphs) {
+
+ # Trim off identical leading space from every line.
+ my ($whitespace) = $paragraph =~ /^(\s*)/;
+ if (length $whitespace) {
+ $paragraph =~ s/^$whitespace//mg;
+ }
+
+ # Re-flow the paragraph if it isn't indented from the norm.
+ # This should preserve indented quoted text, wiki-style.
+ unless ($paragraph =~ /^\s/) {
+ $paragraph = fill(" ", " ", $paragraph);
+ }
+ }
+
+ print join("\n \n", @paragraphs), "\n\n";
+ }
+}
+
+print(
+ "==============\n",
+ "End of Excerpt\n",
+ "==============\n",
+);
+
+### Z. Helper functions.
+
+sub gather_log {
+ my ($url, @flags) = @_;
+
+ my (@log, @stack);
+
+ my $parser = XML::Parser->new(
+ Handlers => {
+ Start => sub {
+ my ($self, $tag, %att) = @_;
+ push @stack, [ $tag, \%att ];
+ if ($tag eq "logentry") {
+ push @log, [ ];
+ $log[-1][LOG_WHO] = "(nobody)";
+ }
+ },
+ Char => sub {
+ my ($self, $text) = @_;
+ $stack[-1][1]{0} .= $text;
+ },
+ End => sub {
+ my ($self, $tag) = @_;
+ die "close $tag w/out open" unless @stack;
+ my ($pop_tag, $att) = @{pop @stack};
+
+ die "$tag ne $pop_tag" if $tag ne $pop_tag;
+
+ if ($tag eq "date") {
+ my $timestamp = $att->{0};
+ my ($date, $time) = split /[T.]/, $timestamp;
+ $log[-1][LOG_DATE] = "$date $time";
+ return;
+ }
+
+ if ($tag eq "logentry") {
+ $log[-1][LOG_REV] = $att->{revision};
+ return;
+ }
+
+ if ($tag eq "msg") {
+ $log[-1][LOG_MESSAGE] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "author") {
+ $log[-1][LOG_WHO] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "path") {
+ my $path = $att->{0};
+ $path =~ s{^/trunk/}{};
+ push(
+ @{$log[-1][LOG_PATHS]}, [
+ $path, # PATH_PATH
+ $att->{action}, # PATH_ACTION
+ ]
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
+ exists $att->{"copyfrom-path"}
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
+ exists $att->{"copyfrom-rev"}
+ );
+ return;
+ }
+
+ }
+ }
+ );
+
+ my $cmd = "svn -v --xml @flags log $url";
+ #warn "Command: $cmd\n";
+
+ open(LOG, "$cmd|") or die $!;
+ $parser->parse(*LOG);
+ close LOG;
+
+ return @log;
+}
DBICTest::Schema::CD->add_relationship(
tags => 'DBICTest::Schema::Tag',
{ 'foreign.cd' => 'self.cdid' },
- { join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1, accessor => 'multi' }
+ { join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1, accessor => 'multi', order_by => 'tag' }
);
#DBICTest::Schema::CD->might_have(liner_notes => 'DBICTest::Schema::LinerNotes' => qw/notes/);
DBICTest::Schema::CD->add_relationship(
projects / dbsrgits/DBIx-Class.git / commitdiff