diff options
| -rw-r--r-- | dist/Math-BigInt/lib/Math/BigInt.pm | 209 | ||||
| -rwxr-xr-x | dist/Math-BigInt/t/rt-16221.t | 77 |
2 files changed, 199 insertions, 87 deletions
diff --git a/dist/Math-BigInt/lib/Math/BigInt.pm b/dist/Math-BigInt/lib/Math/BigInt.pm index 796b75aba1..4757db1026 100644 --- a/dist/Math-BigInt/lib/Math/BigInt.pm +++ b/dist/Math-BigInt/lib/Math/BigInt.pm @@ -2589,102 +2589,137 @@ sub as_oct ############################################################################## # private stuff (internal use only) -sub objectify - { - # check for strings, if yes, return objects instead - - # the first argument is number of args objectify() should look at it will - # return $count+1 elements, the first will be a classname. This is because - # overloaded '""' calls bstr($object,undef,undef) and this would result in - # useless objects being created and thrown away. So we cannot simple loop - # over @_. If the given count is 0, all arguments will be used. - - # If the second arg is a ref, use it as class. - # If not, try to use it as classname, unless undef, then use $class - # (aka Math::BigInt). The latter shouldn't happen,though. - - # caller: gives us: - # $x->badd(1); => ref x, scalar y - # Class->badd(1,2); => classname x (scalar), scalar x, scalar y - # Class->badd( Class->(1),2); => classname x (scalar), ref x, scalar y - # Math::BigInt::badd(1,2); => scalar x, scalar y - # In the last case we check number of arguments to turn it silently into - # $class,1,2. (We can not take '1' as class ;o) - # badd($class,1) is not supported (it should, eventually, try to add undef) - # currently it tries 'Math::BigInt' + 1, which will not work. - - # some shortcut for the common cases - # $x->unary_op(); - return (ref($_[1]),$_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]); - - my $count = abs(shift || 0); - - my (@a,$k,$d); # resulting array, temp, and downgrade - if (ref $_[0]) - { - # okay, got object as first - $a[0] = ref $_[0]; +sub objectify { + # Convert strings and "foreign objects" to the objects we want. + + # The first argument, $count, is the number of following arguments that + # objectify() looks at and converts to objects. The first is a classname. + # If the given count is 0, all arguments will be used. + + # After the count is read, objectify obtains the name of the class to which + # the following arguments are converted. If the second argument is a + # reference, use the reference type as the class name. Otherwise, if it is + # a string that looks like a class name, use that. Otherwise, use $class. + + # Caller: Gives us: + # + # $x->badd(1); => ref x, scalar y + # Class->badd(1,2); => classname x (scalar), scalar x, scalar y + # Class->badd(Class->(1),2); => classname x (scalar), ref x, scalar y + # Math::BigInt::badd(1,2); => scalar x, scalar y + + # A shortcut for the common case $x->unary_op(): + + return (ref($_[1]), $_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]); + + # Check the context. + + unless (wantarray) { + require Carp; + Carp::croak ("${class}::objectify() needs list context"); } - else + + # Get the number of arguments to objectify. + + my $count = shift; + $count ||= @_; + + # Initialize the output array. + + my @a = @_; + + # If the first argument is a reference, use that reference type as our + # class name. Otherwise, if the first argument looks like a class name, + # then use that as our class name. Otherwise, use the default class name. + { - # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported) - $a[0] = $class; - $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first? + if (ref($a[0])) { # reference? + unshift @a, ref($a[0]); + last; + } + if ($a[0] =~ /^[A-Z].*::/) { # string with class name? + last; + } + unshift @a, $class; # default class name } - no strict 'refs'; - # disable downgrading, because Math::BigFLoat->foo('1.0','2.0') needs floats - if (defined ${"$a[0]::downgrade"}) - { - $d = ${"$a[0]::downgrade"}; - ${"$a[0]::downgrade"} = undef; + no strict 'refs'; + + # What we upgrade to, if anything. + + my $up = ${"$a[0]::upgrade"}; + + # Disable downgrading, because Math::BigFloat -> foo('1.0','2.0') needs + # floats. + + my $down; + if (defined ${"$a[0]::downgrade"}) { + $down = ${"$a[0]::downgrade"}; + ${"$a[0]::downgrade"} = undef; } - my $up = ${"$a[0]::upgrade"}; - # print STDERR "# Now in objectify, my class is today $a[0], count = $count\n"; - if ($count == 0) - { - while (@_) - { - $k = shift; - if (!ref($k)) - { - $k = $a[0]->new($k); + for my $i (1 .. $count) { + my $ref = ref $a[$i]; + + # If it is an object of the right class, all is fine. + + if ($ref eq $a[0]) { + next; } - elsif (!defined $up && ref($k) ne $a[0]) - { - # foreign object, try to convert to integer - $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k); - } - push @a,$k; - } - } - else - { - while ($count > 0) - { - $count--; - $k = shift; - if (!ref($k)) - { - $k = $a[0]->new($k); + + # Don't do anything with undefs. + + unless (defined($a[$i])) { + next; } - elsif (ref($k) ne $a[0] and !defined $up || ref $k ne $up) - { - # foreign object, try to convert to integer - $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k); - } - push @a,$k; - } - push @a,@_; # return other params, too - } - if (! wantarray) - { - require Carp; Carp::croak ("$class objectify needs list context"); + + # Perl scalars are fed to the appropriate constructor. + + unless ($ref) { + $a[$i] = $a[0] -> new($a[$i]); + next; + } + + # Upgrading is OK, so skip further tests if the argument is upgraded. + + if (defined $up && $ref eq $up) { + next; + } + + # If we want a Math::BigInt, see if the object can become one. + # Support the old misnomer as_number(). + + if ($a[0] eq 'Math::BigInt') { + if ($a[$i] -> can('as_int')) { + $a[$i] = $a[$i] -> as_int(); + next; + } + if ($a[$i] -> can('as_number')) { + $a[$i] = $a[$i] -> as_number(); + next; + } + } + + # If we want a Math::BigFloat, see if the object can become one. + + if ($a[0] eq 'Math::BigFloat') { + if ($a[$i] -> can('as_float')) { + $a[$i] = $a[$i] -> as_float(); + next; + } + } + + # Last resort. + + $a[$i] = $a[0] -> new($a[$i]); } - ${"$a[0]::downgrade"} = $d; - @a; - } + + # Reset the downgrading. + + ${"$a[0]::downgrade"} = $down; + + return @a; +} sub _register_callback { diff --git a/dist/Math-BigInt/t/rt-16221.t b/dist/Math-BigInt/t/rt-16221.t new file mode 100755 index 0000000000..a1dc2c6a3a --- /dev/null +++ b/dist/Math-BigInt/t/rt-16221.t @@ -0,0 +1,77 @@ +#!/usr/bin/perl +# +# Verify that +# - Math::BigInt::objectify() calls as_int() (or as_number(), as a fallback) +# if the target object class is Math::BigInt. +# - Math::BigInt::objectify() calls as_float() if the target object class is +# Math::BigFloat. +# +# See RT #16221 and RT #52124. + +use strict; +use warnings; + +package main; + +use Test::More tests => 2; +use Math::BigInt; +use Math::BigFloat; + +############################################################################ + +my $int = Math::BigInt->new(10); +my $int_percent = My::Percent::Float->new(100); + +is($int * $int_percent, 10); + +############################################################################ + +my $float = Math::BigFloat->new(10); +my $float_percent = My::Percent::Float->new(100); + +is($float * $float_percent, 10); + +############################################################################ + +package My::Percent::Int; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_number { + my $self = shift; + return Math::BigInt->new($$self / 100); +} + +sub as_string { + my $self = shift; + return $$self; +} + +############################################################################ + +package My::Percent::Float; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_int { + my $self = shift; + return Math::BigInt->new($$self / 100); +} + +sub as_float { + my $self = shift; + return Math::BigFloat->new($$self / 100); +} + +sub as_string { + my $self = shift; + return $$self; +} |