X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=71653e03a11a9a23643abbeb5947046bd85c318f;hb=a697fa319ce0072206b76f64fed38d92d5f59644;hp=e2f6e13bfe39977cc7283d875d11c88181defa49;hpb=7f505c17e411db792a53172d3b8681c59cf5a7b0;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index e2f6e13..71653e0 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -10,13 +10,15 @@ use DBIx::Class::Exception; use Carp::Clan qw/^DBIx::Class/; use Try::Tiny; use List::Util 'first'; +use Scalar::Util qw/weaken isweak/; +use Storable qw/nfreeze thaw/; 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 @@ -361,22 +363,22 @@ sub column_info { 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} }, @@ -385,6 +387,7 @@ sub column_info { } }; } + return $self->_columns->{$column}; } @@ -412,6 +415,80 @@ sub columns { 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 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. + +=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 @@ -537,6 +614,33 @@ sub _pri_cols { 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 of each L + +=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 @@ -909,11 +1013,11 @@ sub resultset { '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} }, ); } @@ -960,7 +1064,7 @@ clause contents. =over 4 -=item Arguments: None +=item Arguments: $schema =item Return value: A schema object @@ -968,8 +1072,29 @@ clause contents. my $schema = $source->schema(); -Returns the L object that this result source -belongs to. +Sets and/or returns the L 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 @@ -1220,11 +1345,14 @@ sub reverse_relationship_info { my @otherrels = $othertable->relationships(); my $otherrelationship; foreach my $otherrel (@otherrels) { - my $otherrel_info = $othertable->relationship_info($otherrel); + # this may be a partial schema with the related source not being + # available at all + my $back = try { $othertable->related_source($otherrel) } or next; - my $back = $othertable->related_source($otherrel); + # did we get back to ourselves? next unless $back->source_name eq $self->source_name; + my $otherrel_info = $othertable->relationship_info($otherrel); my @othertestconds; if (ref $otherrel_info->{cond} eq 'HASH') { @@ -1351,7 +1479,7 @@ sub _resolve_join { 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} @@ -1365,7 +1493,7 @@ sub _resolve_join { -alias => $as, -relation_chain_depth => $seen->{-relation_chain_depth} || 0, }, - $self->_resolve_condition($rel_info->{cond}, $as, $alias) ]; + $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) ]; } } @@ -1420,11 +1548,23 @@ sub resolve_condition { # 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 # a related conditional from that object. -our $UNRESOLVABLE_CONDITION = \'1 = 0'; +our $UNRESOLVABLE_CONDITION = \ '1 = 0'; sub _resolve_condition { - my ($self, $cond, $as, $for) = @_; - if (ref $cond eq 'HASH') { + my ($self, $cond, $as, $for, $rel) = @_; + if (ref $cond eq 'CODE') { + + my $obj_rel = !!ref $for; + + return $cond->({ + self_alias => $obj_rel ? $as : $for, + foreign_alias => $obj_rel ? 'me' : $as, + self_resultsource => $self, + foreign_relname => $rel || ($obj_rel ? $as : $for), + self_rowobj => $obj_rel ? $for : undef + }); + + } elsif (ref $cond eq 'HASH') { my %ret; foreach my $k (keys %{$cond}) { my $v = $cond->{$k}; @@ -1461,14 +1601,14 @@ sub _resolve_condition { } elsif (!defined $as) { # undef, i.e. "no reverse object" $ret{$v} = undef; } else { - $ret{"${as}.${k}"} = "${for}.${v}"; + $ret{"${as}.${k}"} = { -ident => "${for}.${v}" }; } } return \%ret; } elsif (ref $cond eq 'ARRAY') { return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ]; } else { - die("Can't handle condition $cond yet :("); + $self->throw_exception ("Can't handle condition $cond yet :("); } } @@ -1525,6 +1665,7 @@ sub _resolve_prefetch { "Can't prefetch has_many ${pre} (join cond too complex)") unless ref($rel_info->{cond}) eq 'HASH'; my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}" + if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots } keys %{$collapse}) { my ($last) = ($fail =~ /([^\.]+)$/); @@ -1538,6 +1679,7 @@ sub _resolve_prefetch { . 'Use at your own risk.' ); } + #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); } # values %{$rel_info->{cond}}; $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ]; @@ -1545,13 +1687,33 @@ sub _resolve_prefetch { # 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}} + 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; - : (defined $rel_info->{attrs}{order_by} - ? ($rel_info->{attrs}{order_by}) - : ())); - push(@$order, map { "${as}.$_" } (@key, @ord)); + $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}.$_", ] } @@ -1605,16 +1767,76 @@ sub related_class { =head2 handle -Obtain a new handle to this source. Returns an instance of a -L. +=over 4 + +=item Arguments: None + +=item Return value: $source_handle + +=back + +Obtain a new L +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; + + END { $global_phase_destroy++ } + + 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 + weaken $_[0]->{schema}; + + # if schema is still there reintroduce ourselves with strong refs back + if ($_[0]->{schema}) { + my $srcregs = $_[0]->{schema}->source_registrations; + for (keys %$srcregs) { + $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; + } + } + } +} + +sub STORABLE_freeze { nfreeze($_[0]->handle) } + +sub STORABLE_thaw { + my ($self, $cloning, $ice) = @_; + %$self = %{ (thaw $ice)->resolve }; } =head2 throw_exception @@ -1626,12 +1848,10 @@ See L. 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