use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
use Try::Tiny;
+use List::Util 'first';
+use Scalar::Util qw/weaken isweak/;
+use namespace::clean;
use base qw/DBIx::Class/;
__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
_columns _primaries _unique_constraints name resultset_attributes
- schema from _relationships column_info_from_storage source_info
+ from _relationships column_info_from_storage source_info
source_name sqlt_deploy_callback/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
If a column name beginning with a plus sign ('+col1') is provided, the
attributes provided will be merged with any existing attributes for the
column, with the new attributes taking precedence in the case that an
-attribute already exists. Using this without a hashref
+attribute already exists. Using this without a hashref
(C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
it does the same thing it would do without the plus.
This contains the column type. It is automatically filled if you use the
L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
-L<DBIx::Class::Schema::Loader> module.
+L<DBIx::Class::Schema::Loader> module.
Currently there is no standard set of values for the data_type. Use
whatever your database supports.
my ($self, $column) = @_;
$self->throw_exception("No such column $column")
unless exists $self->_columns->{$column};
- #warn $self->{_columns_info_loaded}, "\n";
+
if ( ! $self->_columns->{$column}{data_type}
- and $self->column_info_from_storage
and ! $self->{_columns_info_loaded}
- and $self->schema and $self->storage )
+ and $self->column_info_from_storage
+ and my $stor = try { $self->storage } )
{
$self->{_columns_info_loaded}++;
- my $info = {};
- my $lc_info = {};
# try for the case of storage without table
try {
- $info = $self->storage->columns_info_for( $self->from );
- for my $realcol ( keys %{$info} ) {
- $lc_info->{lc $realcol} = $info->{$realcol};
- }
+ my $info = $stor->columns_info_for( $self->from );
+ my $lc_info = { map
+ { (lc $_) => $info->{$_} }
+ ( keys %$info )
+ };
+
foreach my $col ( keys %{$self->_columns} ) {
$self->_columns->{$col} = {
%{ $self->_columns->{$col} },
}
};
}
+
return $self->_columns->{$column};
}
return @{$self->{_ordered_columns}||[]};
}
+=head2 columns_info
+
+=over
+
+=item Arguments: \@colnames ?
+
+=item Return value: Hashref of column name/info pairs
+
+=back
+
+ my $columns_info = $source->columns_info;
+
+Like L</column_info> but returns information for the requested columns. If
+the optional column-list arrayref is ommitted it returns info on all columns
+currently defined on the ResultSource via L</add_columns>.
+
+=cut
+
+sub columns_info {
+ my ($self, $columns) = @_;
+
+ my $colinfo = $self->_columns;
+
+ if (
+ first { ! $_->{data_type} } values %$colinfo
+ and
+ ! $self->{_columns_info_loaded}
+ and
+ $self->column_info_from_storage
+ and
+ my $stor = try { $self->storage }
+ ) {
+ $self->{_columns_info_loaded}++;
+
+ # try for the case of storage without table
+ try {
+ my $info = $stor->columns_info_for( $self->from );
+ my $lc_info = { map
+ { (lc $_) => $info->{$_} }
+ ( keys %$info )
+ };
+
+ foreach my $col ( keys %$colinfo ) {
+ $colinfo->{$col} = {
+ %{ $colinfo->{$col} },
+ %{ $info->{$col} || $lc_info->{lc $col} || {} }
+ };
+ }
+ };
+ }
+
+ my %ret;
+
+ if ($columns) {
+ for (@$columns) {
+ if (my $inf = $colinfo->{$_}) {
+ $ret{$_} = $inf;
+ }
+ else {
+ $self->throw_exception( sprintf (
+ "No such column '%s' on source %s",
+ $_,
+ $self->source_name,
+ ));
+ }
+ }
+ }
+ else {
+ %ret = %$colinfo;
+ }
+
+ return \%ret;
+}
+
=head2 remove_columns
=over
Note: you normally do want to define a primary key on your sources
B<even if the underlying database table does not have a primary key>.
See
-L<DBIx::Class::Intro/The Significance and Importance of Primary Keys>
+L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
for more info.
=cut
my @pcols = $self->primary_columns
or $self->throw_exception (sprintf(
"Operation requires a primary key to be declared on '%s' via set_primary_key",
- $self->source_name,
+ # source_name is set only after schema-registration
+ $self->source_name || $self->result_class || $self->name || 'Unknown source...?',
));
return @pcols;
}
+=head2 sequence
+
+Manually define the correct sequence for your table, to avoid the overhead
+associated with looking up the sequence automatically. The supplied sequence
+will be applied to the L</column_info> of each L<primary_key|/set_primary_key>
+
+=over 4
+
+=item Arguments: $sequence_name
+
+=item Return value: undefined
+
+=back
+
+=cut
+
+sub sequence {
+ my ($self,$seq) = @_;
+
+ my @pks = $self->primary_columns
+ or next;
+
+ $_->{sequence} = $seq
+ for values %{ $self->columns_info (\@pks) };
+}
+
+
=head2 add_unique_constraint
=over 4
sub add_unique_constraint {
my $self = shift;
+
+ if (@_ > 2) {
+ $self->throw_exception(
+ 'add_unique_constraint() does not accept multiple constraints, use '
+ . 'add_unique_constraints() instead'
+ );
+ }
+
my $cols = pop @_;
- my $name = shift;
+ if (ref $cols ne 'ARRAY') {
+ $self->throw_exception (
+ 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING')
+ );
+ }
+
+ my $name = shift @_;
$name ||= $self->name_unique_constraint($cols);
$self->_unique_constraints(\%unique_constraints);
}
+=head2 add_unique_constraints
+
+=over 4
+
+=item Arguments: @constraints
+
+=item Return value: undefined
+
+=back
+
+Declare multiple unique constraints on this source.
+
+ __PACKAGE__->add_unique_constraints(
+ constraint_name1 => [ qw/column1 column2/ ],
+ constraint_name2 => [ qw/column2 column3/ ],
+ );
+
+Alternatively, you can specify only the columns:
+
+ __PACKAGE__->add_unique_constraints(
+ [ qw/column1 column2/ ],
+ [ qw/column3 column4/ ]
+ );
+
+This will result in unique constraints named C<table_column1_column2> and
+C<table_column3_column4>, where C<table> is replaced with the table name.
+
+Throws an error if any of the given column names do not yet exist on
+the result source.
+
+See also L</add_unique_constraint>.
+
+=cut
+
+sub add_unique_constraints {
+ my $self = shift;
+ my @constraints = @_;
+
+ if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) {
+ # with constraint name
+ while (my ($name, $constraint) = splice @constraints, 0, 2) {
+ $self->add_unique_constraint($name => $constraint);
+ }
+ }
+ else {
+ # no constraint name
+ foreach my $constraint (@constraints) {
+ $self->add_unique_constraint($constraint);
+ }
+ }
+}
+
=head2 name_unique_constraint
=over 4
-=item Arguments: @colnames
+=item Arguments: \@colnames
=item Return value: Constraint name
=back
$source->table('mytable');
- $source->name_unique_constraint('col1', 'col2');
+ $source->name_unique_constraint(['col1', 'col2']);
# returns
'mytable_col1_col2'
'call it on the schema instead.'
) if scalar @_;
- return $self->resultset_class->new(
+ $self->resultset_class->new(
$self,
{
+ try { %{$self->schema->default_resultset_attributes} },
%{$self->{resultset_attributes}},
- %{$self->schema->default_resultset_attributes}
},
);
}
=over 4
-=item Arguments: None
+=item Arguments: $schema
=item Return value: A schema object
my $schema = $source->schema();
-Returns the L<DBIx::Class::Schema> object that this result source
-belongs to.
+Sets and/or returns the L<DBIx::Class::Schema> object to which this
+result source instance has been attached to.
+
+=cut
+
+sub schema {
+ if (@_ > 1) {
+ $_[0]->{schema} = $_[1];
+ }
+ else {
+ $_[0]->{schema} || do {
+ my $name = $_[0]->{source_name} || '_unnamed_';
+ my $err = 'Unable to perform storage-dependent operations with a detached result source '
+ . "(source '$name' is not associated with a schema).";
+
+ $err .= ' You need to use $schema->thaw() or manually set'
+ . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
+ if $_[0]->{_detached_thaw};
+
+ DBIx::Class::Exception->throw($err);
+ };
+ }
+}
=head2 storage
sub reverse_relationship_info {
my ($self, $rel) = @_;
- my $rel_info = $self->relationship_info($rel);
+
+ my $rel_info = $self->relationship_info($rel)
+ or $self->throw_exception("No such relationship '$rel'");
+
my $ret = {};
return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
- my @cond = keys(%{$rel_info->{cond}});
- my @refkeys = map {/^\w+\.(\w+)$/} @cond;
- my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+ my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
- # Get the related result source for this relationship
- my $othertable = $self->related_source($rel);
+ my $rsrc_schema_moniker = $self->source_name
+ if try { $self->schema };
+
+ # this may be a partial schema or something else equally esoteric
+ my $other_rsrc = try { $self->related_source($rel) }
+ or return $ret;
# Get all the relationships for that source that related to this source
# whose foreign column set are our self columns on $rel and whose self
- # columns are our foreign columns on $rel.
- my @otherrels = $othertable->relationships();
- my $otherrelationship;
- foreach my $otherrel (@otherrels) {
- my $otherrel_info = $othertable->relationship_info($otherrel);
+ # columns are our foreign columns on $rel
+ foreach my $other_rel ($other_rsrc->relationships) {
- my $back = $othertable->related_source($otherrel);
- next unless $back->source_name eq $self->source_name;
+ # only consider stuff that points back to us
+ # "us" here is tricky - if we are in a schema registration, we want
+ # to use the source_names, otherwise we will use the actual classes
- my @othertestconds;
+ # the schema may be partial
+ my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ or next;
- if (ref $otherrel_info->{cond} eq 'HASH') {
- @othertestconds = ($otherrel_info->{cond});
- }
- elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
- @othertestconds = @{$otherrel_info->{cond}};
+ if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+ next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
}
else {
- next;
+ next unless $self->result_class eq $roundtrip_rsrc->result_class;
}
- foreach my $othercond (@othertestconds) {
- my @other_cond = keys(%$othercond);
- my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
- my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
- next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
- !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
- $ret->{$otherrel} = $otherrel_info;
- }
+ my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+ # this can happen when we have a self-referential class
+ next if $other_rel_info eq $rel_info;
+
+ next unless ref $other_rel_info->{cond} eq 'HASH';
+ my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+ $ret->{$other_rel} = $other_rel_info if (
+ $self->_compare_relationship_keys (
+ [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+ )
+ and
+ $self->_compare_relationship_keys (
+ [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+ )
+ );
}
+
return $ret;
}
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+ +{
+ map
+ { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+ keys %{$_[1]}
+ }
+}
+
sub compare_relationship_keys {
carp 'compare_relationship_keys is a private method, stop calling it';
my $self = shift;
# Returns true if both sets of keynames are the same, false otherwise.
sub _compare_relationship_keys {
- my ($self, $keys1, $keys2) = @_;
-
- # Make sure every keys1 is in keys2
- my $found;
- foreach my $key (@$keys1) {
- $found = 0;
- foreach my $prim (@$keys2) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
-
- # Make sure every key2 is in key1
- if ($found) {
- foreach my $prim (@$keys2) {
- $found = 0;
- foreach my $key (@$keys1) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
- }
-
- return $found;
+# my ($self, $keys1, $keys2) = @_;
+ return
+ join ("\x00", sort @{$_[1]})
+ eq
+ join ("\x00", sort @{$_[2]})
+ ;
}
# Returns the {from} structure used to express JOIN conditions
my $rel_src = $self->related_source($join);
return [ { $as => $rel_src->from,
- -source_handle => $rel_src->handle,
+ -rsrc => $rel_src,
-join_type => $parent_force_left
? 'left'
: $rel_info->{attrs}{join_type}
-is_single => (
$rel_info->{attrs}{accessor}
&&
- List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
+ first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
),
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
# in ResultSet->_collapse_result
my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
keys %{$rel_info->{cond}};
- my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
- ? @{$rel_info->{attrs}{order_by}}
-
- : (defined $rel_info->{attrs}{order_by}
- ? ($rel_info->{attrs}{order_by})
- : ()));
- push(@$order, map { "${as}.$_" } (@key, @ord));
+ push @$order, map { "${as}.$_" } @key;
+
+ if (my $rel_order = $rel_info->{attrs}{order_by}) {
+ # this is kludgy and incomplete, I am well aware
+ # but the parent method is going away entirely anyway
+ # so sod it
+ my $sql_maker = $self->storage->sql_maker;
+ my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
+ my $sep = $sql_maker->name_sep;
+
+ # install our own quoter, so we can catch unqualified stuff
+ local $sql_maker->{quote_char} = ["\x00", "\xFF"];
+
+ my $quoted_prefix = "\x00${as}\xFF";
+
+ for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
+ my @bind;
+ ($chunk, @bind) = @$chunk if ref $chunk;
+
+ $chunk = "${quoted_prefix}${sep}${chunk}"
+ unless $chunk =~ /\Q$sep/;
+
+ $chunk =~ s/\x00/$orig_ql/g;
+ $chunk =~ s/\xFF/$orig_qr/g;
+ push @$order, \[$chunk, @bind];
+ }
+ }
}
return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
if( !$self->has_relationship( $rel ) ) {
$self->throw_exception("No such relationship '$rel' on " . $self->source_name);
}
- return $self->schema->source($self->relationship_info($rel)->{source});
+
+ # if we are not registered with a schema - just use the prototype
+ # however if we do have a schema - ask for the source by name (and
+ # throw in the process if all fails)
+ if (my $schema = try { $self->schema }) {
+ $schema->source($self->relationship_info($rel)->{source});
+ }
+ else {
+ my $class = $self->relationship_info($rel)->{class};
+ $self->ensure_class_loaded($class);
+ $class->result_source_instance;
+ }
}
=head2 related_class
=head2 handle
-Obtain a new handle to this source. Returns an instance of a
-L<DBIx::Class::ResultSourceHandle>.
+=over 4
+
+=item Arguments: None
+
+=item Return value: $source_handle
+
+=back
+
+Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
+for this source. Used as a serializable pointer to this resultsource, as it is not
+easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
+relationship definitions.
=cut
sub handle {
- return DBIx::Class::ResultSourceHandle->new({
- schema => $_[0]->schema,
- source_moniker => $_[0]->source_name
- });
+ return DBIx::Class::ResultSourceHandle->new({
+ source_moniker => $_[0]->source_name,
+
+ # so that a detached thaw can be re-frozen
+ $_[0]->{_detached_thaw}
+ ? ( _detached_source => $_[0] )
+ : ( schema => $_[0]->schema )
+ ,
+ });
+}
+
+{
+ my $global_phase_destroy;
+
+ # SpeedyCGI runs END blocks every cycle but keeps object instances
+ # hence we have to disable the globaldestroy hatch, and rely on the
+ # eval trap below (which appears to work, but is risky done so late)
+ END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
+
+ sub DESTROY {
+ return if $global_phase_destroy;
+
+######
+# !!! ACHTUNG !!!!
+######
+#
+# Under no circumstances shall $_[0] be stored anywhere else (like copied to
+# a lexical variable, or shifted, or anything else). Doing so will mess up
+# the refcount of this particular result source, and will allow the $schema
+# we are trying to save to reattach back to the source we are destroying.
+# The relevant code checking refcounts is in ::Schema::DESTROY()
+
+ # if we are not a schema instance holder - we don't matter
+ return if(
+ ! ref $_[0]->{schema}
+ or
+ isweak $_[0]->{schema}
+ );
+
+ # weaken our schema hold forcing the schema to find somewhere else to live
+ # during global destruction (if we have not yet bailed out) this will throw
+ # which will serve as a signal to not try doing anything else
+ local $@;
+ eval {
+ weaken $_[0]->{schema};
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ return;
+ };
+
+
+ # if schema is still there reintroduce ourselves with strong refs back to us
+ if ($_[0]->{schema}) {
+ my $srcregs = $_[0]->{schema}->source_registrations;
+ for (keys %$srcregs) {
+ next unless $srcregs->{$_};
+ $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
+ }
+ }
+ }
+}
+
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $ice) = @_;
+ %$self = %{ (Storable::thaw($ice))->resolve };
}
=head2 throw_exception
sub throw_exception {
my $self = shift;
- if (defined $self->schema) {
- $self->schema->throw_exception(@_);
- }
- else {
- DBIx::Class::Exception->throw(@_);
- }
+ $self->{schema}
+ ? $self->{schema}->throw_exception(@_)
+ : DBIx::Class::Exception->throw(@_)
+ ;
}
=head2 source_info
projects / dbsrgits/DBIx-Class.git / blobdiff