From: Peter Rabbitson Date: Fri, 30 Sep 2016 13:15:36 +0000 (+0200) Subject: Audit and annotate all context-sensitive spots in ::Ordered X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7474ed3b192693baa28d2f52de502f0ec3e8ac4e;p=dbsrgits%2FDBIx-Class.git Audit and annotate all context-sensitive spots in ::Ordered Ensure an upcoming commit will not disturb the established (silly but still) API of the resultset-returning methods. Review, annotate and tighten up spots that have to do with wantarray-like behavior Not using the ASSERT_NO_INTERNAL_WANTARRAY macro as it is about to be retired in a subsequent commit. Instead adjust the INDIRECT guard to correctly interpret eval frames Zero functional changes --- diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index bf7f954..2ac0a07 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -3,6 +3,9 @@ use strict; use warnings; use base qw( DBIx::Class ); +use DBIx::Class::_Util qw( bag_eq fail_on_internal_call ); +use namespace::clean; + =head1 NAME DBIx::Class::Ordered - Modify the position of objects in an ordered list. @@ -143,13 +146,28 @@ __PACKAGE__->mk_classaccessor( 'null_position_value' => 0 ); Returns an B resultset of all other objects in the same group excluding the one you called it on. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + The ordering is a backwards-compatibility artifact - if you need a resultset with no ordering applied use C<_siblings> =cut + sub siblings { - my $self = shift; - return $self->_siblings->search ({}, { order_by => $self->position_column } ); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } ); } =head2 previous_siblings @@ -160,15 +178,29 @@ sub siblings { Returns a resultset of all objects in the same group positioned before the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub previous_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '<', $position } }) : $self->_siblings - ); + ; } =head2 next_siblings @@ -179,15 +211,29 @@ sub previous_siblings { Returns a resultset of all objects in the same group positioned after the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub next_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '>', $position } }) : $self->_siblings - ); + ; } =head2 previous_sibling @@ -208,7 +254,7 @@ sub previous_sibling { { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $psib ? $psib : 0; + return defined( $psib ) ? $psib : 0; } =head2 first_sibling @@ -229,7 +275,7 @@ sub first_sibling { { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $fsib ? $fsib : 0; + return defined( $fsib ) ? $fsib : 0; } =head2 next_sibling @@ -249,7 +295,7 @@ sub next_sibling { { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $nsib ? $nsib : 0; + return defined( $nsib ) ? $nsib : 0; } =head2 last_sibling @@ -269,7 +315,7 @@ sub last_sibling { { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $lsib ? $lsib : 0; + return defined( $lsib ) ? $lsib : 0; } # an optimized method to get the last sibling position value without inflating a result object @@ -282,8 +328,7 @@ sub _last_sibling_posval { { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, )->cursor; - my ($pos) = $cursor->next; - return $pos; + ($cursor->next)[0]; } =head2 move_previous @@ -762,8 +807,18 @@ sub _shift_siblings { # This method returns a resultset containing all members of the row # group (including the row itself). sub _group_rs { - my $self = shift; - return $self->result_source->resultset->search({$self->_grouping_clause()}); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() }); } # Returns an unordered resultset of all objects in the same group @@ -772,7 +827,17 @@ sub _siblings { my $self = shift; my $position_column = $self->position_column; my $pos; - return defined ($pos = $self->get_column($position_column)) + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $pos = $self->get_column($position_column) ) ? $self->_group_rs->search( { $position_column => { '!=' => $pos } }, ) @@ -815,17 +880,26 @@ sub _is_in_group { my ($self, $other) = @_; my $current = {$self->_grouping_clause}; - no warnings qw/uninitialized/; - - return 0 if ( - join ("\x00", sort keys %$current) - ne - join ("\x00", sort keys %$other) - ); - for my $key (keys %$current) { - return 0 if $current->{$key} ne $other->{$key}; - } - return 1; + ( + bag_eq( + [ keys %$current ], + [ keys %$other ], + ) + and + ! grep { + ( + defined( $current->{$_} ) + xor + defined( $other->{$_} ) + ) + or + ( + defined $current->{$_} + and + $current->{$_} ne $other->{$_} + ) + } keys %$other + ) ? 1 : 0; } # This is a short-circuited method, that is used internally by this @@ -841,9 +915,8 @@ sub _is_in_group { # you are doing use this method which bypasses any hooks introduced by # this module. sub _ordered_internal_update { - my $self = shift; - local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; - return $self->update (@_); + local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; + shift->update (@_); } 1; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 2d2caaa..147614f 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1126,38 +1126,7 @@ sub mkdir_p ($) { } sub fail_on_internal_call { - my ($fr, $argdesc); - { - package DB; - $fr = [ CORE::caller(1) ]; - - # screwing with $DB::args is rather volatile - be extra careful - no warnings 'uninitialized'; - - $argdesc = - ( not defined $DB::args[0] ) ? 'UNAVAILABLE' - : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) - : $DB::args[0] . '' - ; - }; - - my @fr2; - # need to make allowance for a proxy-yet-direct call - my $check_fr = ( - $fr->[0] eq 'DBIx::Class::ResultSourceProxy' - and - @fr2 = (CORE::caller(2)) - and - ( - ( $fr->[3] =~ /([^:])+$/ )[0] - eq - ( $fr2[3] =~ /([^:])+$/ )[0] - ) - ) - ? \@fr2 - : $fr - ; - + my $fr = [ CORE::caller(1) ]; die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( @@ -1194,12 +1163,36 @@ sub fail_on_internal_call { ); + my @fr2; + # need to make allowance for a proxy-yet-direct call + # or for an exception wrapper + $fr = \@fr2 if ( + ( + $fr->[3] eq '(eval)' + and + @fr2 = (CORE::caller(2)) + ) + or + ( + $fr->[0] eq 'DBIx::Class::ResultSourceProxy' + and + @fr2 = (CORE::caller(2)) + and + ( + ( $fr->[3] =~ /([^:])+$/ )[0] + eq + ( $fr2[3] =~ /([^:])+$/ )[0] + ) + ) + ); + + if ( defined $fr->[0] and - $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ + $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and - $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there and # one step higher @fr2 = CORE::caller(@fr2 ? 3 : 2) @@ -1212,6 +1205,24 @@ sub fail_on_internal_call { attributes::get( \&{ $fr2[3] }) } ) { + + my $argdesc; + + { + package DB; + + my @throwaway = caller( @fr2 ? 2 : 1 ); + + # screwing with $DB::args is rather volatile - be extra careful + no warnings 'uninitialized'; + + $argdesc = + ( not defined $DB::args[0] ) ? 'UNAVAILABLE' + : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) + : $DB::args[0] . '' + ; + }; + DBIx::Class::Exception->throw( sprintf ( "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {