ext/Cwd/Makefile.PL Cwd extension makefile maker
ext/Cwd/t/cwd.t See if Cwd works
ext/Cwd/t/taint.t See if Cwd works with taint
+ext/Cwd/t/win32.t See if Cwd works on Win32
ext/Data/Dumper/Changes Data pretty printer, changelog
ext/Data/Dumper/Dumper.pm Data pretty printer, module
ext/Data/Dumper/Dumper.xs Data pretty printer, externals
Revision history for Perl extension Cwd.
+2.20 Thu Jul 22 08:23:53 CDT 2004
+
+ - On some implementations of perl on Win32, a memory leak (or worse?)
+ occurred when calling getdcwd(). This has been fixed. [PodMaster]
+
+ - Added tests for getdcwd() on Win32.
+
+ - Fixed a problem in the pure-perl implementation _perl_abs_path()
+ that caused a fatal error when run on plain files. [Nicholas Clark]
+ To exercise the appropriate test code on platforms that wouldn't
+ otherwise use _perl_abs_path(), run the tests with $ENV{PERL_CORE}
+ or $ENV{TEST_PERL_CWD_CODE} set.
+
2.19 Thu Jul 15 08:32:18 CDT 2004
- The abs_path($arg) fix from 2.18 didn't work for VMS, now it's
else
croak("Usage: getdcwd(DRIVE)");
- /* Pass a NULL pointer as the second argument to have space allocated. */
- if (dir = _getdcwd(drive, NULL, MAXPATHLEN)) {
+ New(0,dir,MAXPATHLEN,char);
+ if (_getdcwd(drive, dir, MAXPATHLEN)) {
sv_setpvn(TARG, dir, strlen(dir));
- free(dir);
+ Safefree(dir);
SvPOK_only(TARG);
}
else
use File::Spec;
use File::Path;
-use Test::More tests => 24;
+use Test::More;
+
+my $tests = 24;
+my $EXTRA_ABSPATH_TESTS = $ENV{PERL_CORE} || $ENV{TEST_PERL_CWD_CODE};
+$tests += 3 if $EXTRA_ABSPATH_TESTS;
+plan tests => $tests;
my $IsVMS = $^O eq 'VMS';
my $IsMacOS = $^O eq 'MacOS';
}
SKIP: {
- skip "no symlinks on this platform", 2 unless $Config{d_symlink};
+ skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink};
mkpath([$Test_Dir], 0, 0777);
symlink $Test_Dir, "linktest";
like($abs_path, qr|$want$|);
like($fast_abs_path, qr|$want$|);
+ like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS;
rmtree($test_dirs[0], 0, 0);
unlink "linktest";
my $path = 'cwd.t';
path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
+path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
+ if $EXTRA_ABSPATH_TESTS;
$path = File::Spec->catfile(File::Spec->updir, 't', $path);
path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
+path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
+ if $EXTRA_ABSPATH_TESTS;
#############################################
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($ENV{PERL_CORE}) {
+ @INC = '../lib';
+ }
+}
+
+use Test::More;
+if( $^O eq 'MSWin32' ) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'this is not win32';
+}
+
+use Cwd;
+ok 1;
+
+my $cdir = getdcwd('C:');
+like $cdir, qr{^C:};
+
+my $ddir = getdcwd('D:');
+if (defined $ddir) {
+ like $ddir, qr{^D:};
+} else {
+ # May not have a D: drive mounted
+ ok 1;
+}
+1.810 7th August 2004
+
+ * Fixed db-hash.t for Cygwin
+
+ * Added substr tests to db-hast.t
+
1.809 20th June 2004
* Merged core patch 22258
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmqs@cpan.org)
-# last modified 20th June 2004
-# version 1.809
+# last modified 7th August 2004
+# version 1.810
#
# Copyright (c) 1995-2004 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
use Carp;
-$VERSION = "1.809" ;
+$VERSION = "1.810" ;
{
local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess <pmqs@cpan.org>
- last modified 20th June 2004
- version 1.809
+ last modified 7th August 2004
+ version 1.810
All comments/suggestions/problems are welcome
1.807 - no change
1.808 - leak fixed in ParseOpenInfo
1.809 - no change
+ 1.810 - no change
*/
#define OutputValue(arg, name) \
{ if (RETVAL == 0) { \
+ SvGETMAGIC(arg) ; \
my_sv_setpvn(arg, name.data, name.size) ; \
- TAINT; \
+ TAINT; \
SvTAINTED_on(arg); \
SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
+ SvGETMAGIC(arg) ; \
if (db->type != DB_RECNO) { \
my_sv_setpvn(arg, name.data, name.size); \
} \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
- TAINT; \
+ TAINT; \
SvTAINTED_on(arg); \
SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
use DB_File;
use Fcntl;
-print "1..161\n";
+print "1..166\n";
unlink glob "__db.*";
#
# ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
# {
-# local ($^W) = 0; #no warnings;
+# no warnings;
# untie %hash;
# }
# unlink $Dfile;
#}
-#ok(127,1);
-#ok(128,1);
+#ok(127, 1);
+#ok(128, 1);
{
# Check that two hash's don't interact
tie %hash1, 'DB_File',$Dfile, undef;
ok(133, $warn_count == 0);
$warn_count = 0;
+ untie %hash1;
unlink $Dfile;
tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
ok(134, $warn_count == 0);
+ untie %hash1;
unlink $Dfile;
tie %hash1, 'DB_File',$Dfile, undef, undef;
ok(135, $warn_count == 0);
my %bad = () ;
$key = '';
- for ($status = $db->seq($key, $value, R_FIRST ) ;
+ for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
$status == 0 ;
- $status = $db->seq($key, $value, R_NEXT ) ) {
+ $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {
#print "# key [$key] value [$value]\n" ;
if (defined $remember{$key} && defined $value &&
ok 157, keys %bad == 0 ;
ok 158, keys %remember == 0 ;
- print "# missing -- $key $value\n" while ($key, $value) = each %remember;
- print "# bad -- $key $value\n" while ($key, $value) = each %bad;
+ print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key=>$value\n" while ($key, $value) = each %bad;
# Make sure this fix does not break code to handle an undef key
- # Berkeley DB undef key is bron between versions 2.3.16 and
+ # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
my $value = 'fred';
$warned = '';
$db->put(undef, $value) ;
unlink $Dfile;
}
+{
+ # Check filter + substr
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+ {
+ $db->filter_fetch_key (sub { lc $_ } );
+ $db->filter_store_key (sub { uc $_ } );
+ $db->filter_fetch_value (sub { lc $_ } );
+ $db->filter_store_value (sub { uc $_ } );
+ }
+
+ $_ = 'fred';
+
+ # db-put with substr of key
+ my %remember = () ;
+ my $status = 0 ;
+ for my $ix ( 1 .. 2 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $status += $db->put(substr($key,0), substr($value,0)) ;
+ }
+
+ ok 163, $status == 0 or print "# Status $status\n" ;
+
+ if (1)
+ {
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+ }
+
+ my %bad = () ;
+ my $key = '';
+ my $value = '';
+ for ($status = $db->seq($key, $value, R_FIRST ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT ) ) {
+
+ #print "# key [$key] value [$value]\n" ;
+ if (defined $remember{$key} && defined $value &&
+ $remember{$key} eq $value) {
+ delete $remember{$key} ;
+ }
+ else {
+ $bad{$key} = $value ;
+ }
+ }
+
+ ok 164, $_ eq 'fred';
+ ok 165, keys %bad == 0 ;
+ ok 166, keys %remember == 0 ;
+
+ print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key $value\n" while ($key, $value) = each %bad;
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
exit ;
package Cwd;
-$VERSION = $VERSION = '2.19';
+$VERSION = $VERSION = '2.20';
=head1 NAME
my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
or return cwd() . '/' . $start;
- if (-l _) {
+ # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+ if (-l $start) {
my $link_target = readlink($start);
die "Can't resolve link $start: $!" unless defined $link_target;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '0.87';
+$VERSION = '0.88';
+$VERSION = eval $VERSION;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
Concatenate two or more directory names to form a complete path ending
with a directory. But remove the trailing slash from the resulting
string, because it doesn't look good, isn't necessary and confuses
-OS2. Of course, if this is the root directory, don't cut off the
+OS/2. Of course, if this is the root directory, don't cut off the
trailing slash :-)
$path = File::Spec->catdir( @directories );
Returns a string representation of the first writable directory from a
list of possible temporary directories. Returns the current directory
if no writable temporary directories are found. The list of directories
-checked depends on the platform; e.g. File::Spec::Unix checks $ENV{TMPDIR}
-(unless taint is on) and /tmp.
+checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
+(unless taint is on) and F</tmp>.
$tmpdir = File::Spec->tmpdir();
=item case_tolerant
Returns a true or false value indicating, respectively, that alphabetic
-is not or is significant when comparing file specifications.
+case is not or is significant when comparing file specifications.
$is_case_tolerant = File::Spec->case_tolerant();
=item file_name_is_absolute
-Takes as argument a path and returns true if it is an absolute path.
+Takes as its argument a path, and returns true if it is an absolute path.
$is_absolute = File::Spec->file_name_is_absolute( $path );
=item path
-Takes no argument, returns the environment variable PATH (or the local
+Takes no argument. Returns the environment variable C<PATH> (or the local
platform's equivalent) as a list.
@PATH = File::Spec->path();
($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
For systems with no syntax differentiating filenames from directories,
-assumes that the last file is a path unless $no_file is true or a
-trailing separator or /. or /.. is present. On Unix this means that $no_file
+assumes that the last file is a path unless C<$no_file> is true or a
+trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
true makes this return ( '', $path, '' ).
The directory portion may or may not be returned with a trailing '/'.
@dirs = File::Spec->splitdir( $directories );
-$directories must be only the directory portion of the path on systems
+C<$directories> must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
Unlike just splitting the directories on the separator, empty
directory names (C<''>) can be returned, because these are significant
-on some OSs.
+on some OSes.
=item catpath()
Takes volume, directory and file portions and returns an entire path. Under
-Unix, $volume is ignored, and directory and file are concatenated. A '/' is
-inserted if need be. On other OSs, $volume is significant.
+Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
+inserted if need be. On other OSes, C<$volume> is significant.
$full_path = File::Spec->catpath( $volume, $directory, $file );
$rel_path = File::Spec->abs2rel( $path ) ;
$rel_path = File::Spec->abs2rel( $path, $base ) ;
-If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
+If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is
relative, then it is converted to absolute form using
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
-On systems with the concept of volume, if $path and $base appear to be
+On systems with the concept of volume, if C<$path> and C<$base> appear to be
on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return $path. Note that previous
-versions of this module ignored the volume of $base, which resulted in
+paths, and we will instead simply return C<$path>. Note that previous
+versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
-$base filename as well. Otherwise all path components are assumed to be
+C<$base> filename as well. Otherwise all path components are assumed to be
directories.
-If $path is relative, it is converted to absolute form using L</rel2abs()>.
+If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
This means that it is taken to be relative to L<cwd()|Cwd>.
No checks against the filesystem are made. On VMS, there is
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
-If $base is not present or '', then L<cwd()|Cwd> is used. If $base is relative,
+If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is relative,
then it is converted to absolute form using L</rel2abs()>. This means that it
is taken to be relative to L<cwd()|Cwd>.
-On systems with the concept of volume, if $path and $base appear to be
+On systems with the concept of volume, if C<$path> and C<$base> appear to be
on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return $path. Note that previous
-versions of this module ignored the volume of $base, which resulted in
+paths, and we will instead simply return C<$path>. Note that previous
+versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
-$base filename as well. Otherwise all path components are assumed to be
+C<$base> filename as well. Otherwise all path components are assumed to be
directories.
-If $path is absolute, it is cleaned up and returned using L</canonpath()>.
+If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>.
No checks against the filesystem are made. On VMS, there is
interaction with the working environment, as logicals and
L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
L<ExtUtils::MakeMaker>
-=head1 AUTHORS
-
-Kenneth Albanowski <kjahds@kjahds.com>, Andy Dougherty
-<doughera@lafayette.edu>, Andreas KE<ouml>nig
-<A.Koenig@franz.ww.TU-Berlin.DE>, Tim Bunce <Tim.Bunce@ig.co.uk.
-VMS support by Charles Bailey <bailey@newman.upenn.edu>.
-OS/2 support by Ilya Zakharevich <ilya@math.ohio-state.edu>.
-Mac support by Paul Schinder <schinder@pobox.com>, and Thomas Wegner
-<wegner_thomas@yahoo.com>. abs2rel() and rel2abs() written by Shigio
-Yamaguchi <shigio@tamacom.com>, modified by Barrie Slaymaker
-<barries@slaysys.com>. splitpath(), splitdir(), catpath() and
-catdir() by Barrie Slaymaker.
+=head1 AUTHOR
+
+Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
+
+The vast majority of the code was written by
+Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
+Andy Dougherty C<< <doughera@lafayette.edu> >>,
+Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
+Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
+VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
+OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
+Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
+Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
+abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
+modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
+splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
=cut
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '1.4';
+$VERSION = '1.5';
@ISA = qw(File::Spec::Unix);
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
)?
)
- ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
+ ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
(.*)
}xs;
$volume = $1;
if ( ! $self->file_name_is_absolute( $path ) ) {
if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd() ;
+ require Cwd ;
+ $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
+ $base = $self->_cwd() unless defined $base ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
require File::Spec::Unix ;
require File::Spec::Win32 ;
+require Cwd;
eval {
require VMS::Filespec ;
[ "Win32->canonpath('/..\\')", '\\' ],
[ "Win32->can('_cwd')", '/CODE/' ],
-# FakeWin32 subclass (see below) just sets CWD to C:\one\two
+# FakeWin32 subclass (see below) just sets CWD to C:\one\two and getdcwd('D') to D:\alpha\beta
[ "FakeWin32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ],
[ "FakeWin32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ],
[ "FakeWin32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ],
[ "FakeWin32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ],
[ "FakeWin32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ],
-[ "FakeWin32->abs2rel('../t4','/t1/t2/t3')", '..\\..\\..\\one\\t4' ],
+[ "FakeWin32->abs2rel('../t4','/t1/t2/t3')", '..\\..\\..\\one\\t4' ], # Uses _cwd()
[ "FakeWin32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ],
[ "FakeWin32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ],
[ "FakeWin32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..' ],
) ;
+if ($^O eq 'MSWin32') {
+ push @tests, [ "FakeWin32->rel2abs('D:foo.txt')", 'D:\\alpha\\beta\\foo.txt' ];
+}
+
+
plan tests => scalar @tests;
{
- @File::Spec::FakeWin32::ISA = qw(File::Spec::Win32);
- sub File::Spec::FakeWin32::_cwd { 'C:\\one\\two' }
+ package File::Spec::FakeWin32;
+ use vars qw(@ISA);
+ @ISA = qw(File::Spec::Win32);
+
+ sub _cwd { 'C:\\one\\two' }
+
+ # Some funky stuff to override Cwd::getdcwd() for testing purposes,
+ # in the limited scope of the rel2abs() method.
+ if ($Cwd::VERSION gt '2.17') {
+ local $^W;
+ *rel2abs = sub {
+ my $self = shift;
+ local $^W;
+ local *Cwd::getdcwd = sub {
+ return 'D:\alpha\beta' if $_[0] eq 'D:';
+ return 'C:\one\two' if $_[0] eq 'C:';
+ return;
+ };
+ *Cwd::getdcwd = *Cwd::getdcwd; # Avoid a 'used only once' warning
+ return $self->SUPER::rel2abs(@_);
+ };
+ *rel2abs = *rel2abs; # Avoid a 'used only once' warning
+ }
}
# _a : accuracy
# _p : precision
-$VERSION = '1.44';
+$VERSION = '1.45';
require 5.005;
require Exporter;
@ISA = qw(Exporter Math::BigInt);
use strict;
-# $_trap_inf and $_trap_nan are internal and should never be accessed from the outside
+# $_trap_inf/$_trap_nan are internal and should never be accessed from outside
use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode
$upgrade $downgrade $_trap_nan $_trap_inf/;
my $class = "Math::BigFloat";
$x->bnorm()->round($a,$p,$r,$y);
}
-sub bsub
- {
- # (BigFloat or num_str, BigFloat or num_str) return BigFloat
- # subtract second arg from first, modify first
-
- # set up parameters
- my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
- # objectify is costly, so avoid it
- if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
- {
- ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
- }
-
- if ($y->is_zero()) # still round for not adding zero
- {
- return $x->round($a,$p,$r);
- }
-
- # $x - $y = -$x + $y
- $y->{sign} =~ tr/+-/-+/; # does nothing for NaN
- $x->badd($y,$a,$p,$r); # badd does not leave internal zeros
- $y->{sign} =~ tr/+-/-+/; # refix $y (does nothing for NaN)
- $x; # already rounded by badd()
- }
+# sub bsub is inherited from Math::BigInt!
sub binc
{
# enough...
$scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
}
+
+ my $rem; $rem = $self->bzero() if wantarray;
+
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
my $lx = $MBI->_len($x->{_m}); my $ly = $MBI->_len($y->{_m});
$scale = $lx if $lx > $scale;
$scale = $ly if $ly > $scale;
my $diff = $ly - $lx;
$scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx!
-
- # make copy of $x in case of list context for later reminder calculation
- my $rem;
- if (wantarray && !$y->is_one())
+
+ # cases like $x /= $x (but not $x /= $y!) were wrong due to modifying $x
+ # twice below)
+ require Scalar::Util;
+ if (Scalar::Util::refaddr($x) == Scalar::Util::refaddr($y))
{
- $rem = $x->copy();
+ $x->bone(); # x/x => 1, rem 0
}
-
- $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+';
-
- # check for / +-1 ( +/- 1E0)
- if (!$y->is_one())
+ else
{
- # promote BigInts and it's subclasses (except when already a BigFloat)
- $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ # make copy of $x in case of list context for later reminder calculation
+ if (wantarray && !$y->is_one())
+ {
+ $rem = $x->copy();
+ }
- # calculate the result to $scale digits and then round it
- # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
- $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
- $MBI->_div ($x->{_m},$y->{_m} ); # a/c
+ $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+';
- ($x->{_e},$x->{_es}) =
- _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
- # correct for 10**scale
- ($x->{_e},$x->{_es}) =
- _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
- $x->bnorm(); # remove trailing 0's
- }
+ # check for / +-1 ( +/- 1E0)
+ if (!$y->is_one())
+ {
+ # promote BigInts and it's subclasses (except when already a BigFloat)
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ # calculate the result to $scale digits and then round it
+ # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
+ $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
+ $MBI->_div ($x->{_m},$y->{_m}); # a/c
+
+ # correct exponent of $x
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+ # correct for 10**scale
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
+ $x->bnorm(); # remove trailing 0's
+ }
+ } # ende else $x != $y
# shortcut to not run through _find_round_parameters again
if (defined $params[0])
# clear a/p after round, since user did not request it
delete $x->{_a}; delete $x->{_p};
}
-
+
if (wantarray)
{
if (!$y->is_one())
{
$rem->bmod($y,@params); # copy already done
}
- else
- {
- $rem = $self->bzero();
- }
if ($fallback)
{
# clear a/p after round, since user did not request it
$below = $v->copy();
$over = $u->copy();
-
+
$limit = $self->new("1E-". ($scale-1));
#my $steps = 0;
while (3 < 5)
return $x if $x->{sign} =~ /^[+-]inf$/;
return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
- return $x->bone() if $y->is_zero();
+
+ # cache the result of is_zero
+ my $y_is_zero = $y->is_zero();
+ return $x->bone() if $y_is_zero;
return $x if $x->is_one() || $y->is_one();
- return $x->_pow($y,$a,$p,$r) if !$y->is_int(); # non-integer power
+ my $x_is_zero = $x->is_zero();
+ return $x->_pow($y,$a,$p,$r) if !$x_is_zero && !$y->is_int(); # non-integer power
- my $y1 = $y->as_number()->{value}; # make CALC
+ my $y1 = $y->as_number()->{value}; # make MBI part
# if ($x == -1)
if ($x->{sign} eq '-' && $MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
# if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1
return $MBI->_is_odd($y1) ? $x : $x->babs(1);
}
- if ($x->is_zero())
+ if ($x_is_zero)
{
- return $x->bone() if $y->is_zero();
+ return $x->bone() if $y_is_zero;
return $x if $y->{sign} eq '+'; # 0**y => 0 (if not y <= 0)
# 0 ** -y => 1 / (0 ** y) => 1 / 0! (1 / 0 => +inf)
return $x->binf();
}
my $new_sign = '+';
- $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+');
+ $new_sign = $MBI->_is_odd($y1) ? '-' : '+' if $x->{sign} ne '+';
# calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster)
$x->{_m} = $MBI->_pow( $x->{_m}, $y1);
- $MBI->_mul ($x->{_e}, $y1);
+ $x->{_e} = $MBI->_mul ($x->{_e}, $y1);
$x->{sign} = $new_sign;
$x->bnorm();
if ($y->{sign} eq '-')
{
# modify $x in place!
- my $z = $x->copy(); $x->bzero()->binc();
+ my $z = $x->copy(); $x->bone();
return $x->bdiv($z,$a,$p,$r); # round in one go (might ignore y's A!)
}
$x->round($a,$p,$r,$y);
}
}
# pass sign to bround for rounding modes '+inf' and '-inf'
- my $m = Math::BigInt->new( $x->{sign} . $MBI->_str($x->{_m}));
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
$m->bround($scale,$mode);
$x->{_m} = $m->{value}; # get our mantissa back
$x->bnorm();
}
# pass sign to bround for '+inf' and '-inf' rounding modes
- my $m = Math::BigInt->new( $x->{sign} . $MBI->_str($x->{_m}));
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
$m->bround($scale,$mode); # round mantissa
$x->{_m} = $m->{value}; # get our mantissa back
my $class = "Math::BigInt";
require 5.005;
-$VERSION = '1.70';
+$VERSION = '1.71';
use Exporter;
@ISA = qw( Exporter );
@EXPORT_OK = qw( objectify bgcd blcm);
return $x;
}
+ require Scalar::Util;
+ if (Scalar::Util::refaddr($x) == Scalar::Util::refaddr($y))
+ {
+ # if we get the same variable twice, the result must be zero (the code
+ # below fails in that case)
+ return $x->bzero(@r) if $x->{sign} =~ /^[+-]$/;
+ return $x->bnan(); # NaN, -inf, +inf
+ }
$y->{sign} =~ tr/+\-/-+/; # does nothing for NaN
$x->badd($y,@r); # badd does not leave internal zeros
$y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN)
sub _scan_for_nonzero
{
- # internal, used by bround()
- my ($x,$pad,$xs) = @_;
+ # internal, used by bround() to scan for non-zeros after a '5'
+ my ($x,$pad,$xs,$len) = @_;
- my $len = $x->length();
- return 0 if $len == 1; # '5' is trailed by invisible zeros
+ return 0 if $len == 1; # "5" is trailed by invisible zeros
my $follow = $pad - 1;
return 0 if $follow > $len || $follow < 1;
- # since we do not know underlying represention of $x, use decimal string
- my $r = substr ("$x",-$follow);
- $r =~ /[^0]/ ? 1 : 0;
+ # use the string form to check whether only '0's follow or not
+ substr ($xs,-$follow) =~ /[^0]/ ? 1 : 0;
}
sub fround
$pad = $len - $scale;
$pad = abs($scale-1) if $scale < 0;
- # do not use digit(), it is costly for binary => decimal
-
+ # do not use digit(), it is very costly for binary => decimal
+ # getting the entire string is also costly, but we need to do it only once
my $xs = $CALC->_str($x->{value});
my $pl = -$pad-1;
($digit_after =~ /[01234]/) || # round down anyway,
# 6789 => round up
($digit_after eq '5') && # not 5000...0000
- ($x->_scan_for_nonzero($pad,$xs) == 0) &&
+ ($x->_scan_for_nonzero($pad,$xs,$len) == 0) &&
(
($mode eq 'even') && ($digit_round =~ /[24680]/) ||
($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
if (($pad > 0) && ($pad <= $len))
{
- substr($xs,-$pad,$pad) = '0' x $pad;
- $put_back = 1;
+ substr($xs,-$pad,$pad) = '0' x $pad; # replace with '00...'
+ $put_back = 1; # need to put back
}
elsif ($pad > $len)
{
if ($round_up) # what gave test above?
{
- $put_back = 1;
+ $put_back = 1; # need to put back
$pad = $len, $xs = '0' x $pad if $scale < 0; # tlr: whack 0.51=>1.0
# we modify directly the string variant instead of creating a number and
$xs = '1'.$xs if $c == 0;
}
- $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back in if needed
+ $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back, if needed
$x->{_a} = $scale if $scale >= 0;
if ($scale < 0)
use vars qw/$VERSION/;
-$VERSION = '0.40';
+$VERSION = '0.41';
# Package to store unsigned big integers in decimal and do math with them
return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL);
}
+sub _new
+ {
+ # (ref to string) return ref to num_array
+ # Convert a number from string format (without sign) to internal base
+ # 1ex format. Assumes normalized value as input.
+ my $il = length($_[1])-1;
+
+ # < BASE_LEN due len-1 above
+ return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers
+
+ # this leaves '00000' instead of int 0 and will be corrected after any op
+ [ reverse(unpack("a" . ($il % $BASE_LEN+1)
+ . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
+ }
+
BEGIN
{
# from Daniel Pfeiffer: determine largest group of digits that is precisely
use integer;
- ############################################################################
- # the next block is no longer important
-
- ## this below detects 15 on a 64 bit system, because after that it becomes
- ## 1e16 and not 1000000 :/ I can make it detect 18, but then I get a lot of
- ## test failures. Ugh! (Tomake detect 18: uncomment lines marked with *)
-
- #my $bi = 5; # approx. 16 bit
- #$num = int('9' x $bi);
- ## $num = 99999; # *
- ## while ( ($num+$num+1) eq '1' . '9' x $bi) # *
- #while ( int($num+$num+1) eq '1' . '9' x $bi)
- # {
- # $bi++; $num = int('9' x $bi);
- # # $bi++; $num *= 10; $num += 9; # *
- # }
- #$bi--; # back off one step
- # by setting them equal, we ignore the findings and use the default
- # one-size-fits-all approach from former versions
- my $bi = $e; # XXX, this should work always
-
- __PACKAGE__->_base_len($e,$bi); # set and store
+ __PACKAGE__->_base_len($e); # set and store
# find out how many bits _and, _or and _xor can take (old default = 16)
# I don't think anybody has yet 128 bit scalars, so let's play safe.
} while ($OR_BITS < $max && $x == $z && $y == $x);
$OR_BITS --; # retreat one step
- }
-
-###############################################################################
-
-sub _new
- {
- # (ref to string) return ref to num_array
- # Convert a number from string format (without sign) to internal base
- # 1ex format. Assumes normalized value as input.
- my $il = length($_[1])-1;
-
- # < BASE_LEN due len-1 above
- return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers
-
- # this leaves '00000' instead of int 0 and will be corrected after any op
- [ reverse(unpack("a" . ($il % $BASE_LEN+1)
- . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
- }
-
-BEGIN
- {
$AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
$XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
$OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
}
+###############################################################################
+
sub _zero
{
# create a zero
return $x if (($i += 1) < $BASE); # early out
$i = 0; # overflow, next
}
- push @$x,1 if ($x->[-1] == 0); # last overflowed, so extend
+ push @$x,1 if (($x->[-1] || 0) == 0); # last overflowed, so extend
$x;
}
my $elem = int($n / $BASE_LEN); # which array element
my $digit = $n % $BASE_LEN; # which digit in this element
- $elem = '0000'.@$x[$elem]; # get element padded with 0's
+ $elem = '0000000'.@$x[$elem]; # get element padded with 0's
substr($elem,-$digit-1,1);
}
my ($c,$x) = @_;
# fit's into one element (handle also 0x0 case)
- if (@$x == 1)
- {
- my $t = sprintf("0x%x",$x->[0]);
- return $t;
- }
+ return sprintf("0x%x",$x->[0]) if @$x == 1;
my $x1 = _copy($c,$x);
{
$x10000 = [ 0x1000 ]; $h = 'h3';
}
- # while (! _is_zero($c,$x1))
while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
{
($x1, $xr) = _div($c,$x1,$x10000);
}
$es = reverse $es;
$es =~ s/^[0]+//; # strip leading zeros
- $es = '0x' . $es;
- $es;
+ '0x' . $es; # return result prepended with 0x
}
sub _as_bin
{
$x10000 = [ 0x1000 ]; $b = 'b12';
}
- # while (! _is_zero($c,$x1))
while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero()
{
($x1, $xr) = _div($c,$x1,$x10000);
}
$es = reverse $es;
$es =~ s/^[0]+//; # strip leading zeros
- $es = '0b' . $es;
- $es;
+ '0b' . $es; # return result prepended with 0b
}
sub _from_hex
# convert a hex number to decimal (ref to string, return ref to array)
my ($c,$hs) = @_;
+ my $m = [ 0x10000000 ]; # 28 bit at a time (<32 bit!)
+ my $d = 7; # 7 digits at a time
+ if ($] <= 5.006)
+ {
+ # for older Perls, play safe
+ $m = [ 0x10000 ]; # 16 bit at a time (<32 bit!)
+ $d = 4; # 4 digits at a time
+ }
+
my $mul = _one();
- my $m = [ 0x10000 ]; # 16 bit at a time
my $x = _zero();
- my $len = length($hs)-2;
- $len = int($len/4); # 4-digit parts, w/o '0x'
- my $val; my $i = -4;
+ my $len = int( (length($hs)-2)/$d ); # $d digit parts, w/o the '0x'
+ my $val; my $i = -$d;
while ($len >= 0)
{
- $val = substr($hs,$i,4);
+ $val = substr($hs,$i,$d); # get hex digits
$val =~ s/^[+-]?0x// if $len == 0; # for last part only because
$val = hex($val); # hex does not like wrong chars
- $i -= 4; $len --;
+ $i -= $d; $len --;
_add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0;
_mul ($c, $mul, $m ) if $len >= 0; # skip last mul
}
$hs =~ s/^[+-]?0b//; # remove sign and 0b
my $l = length($hs); # bits
$hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
- my $h = unpack('H*', pack ('B*', $hs)); # repack as hex
+ my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
- $c->_from_hex('0x'.$h);
+ $c->_from_hex($h);
}
##############################################################################
# if the gcd is not 1, then return NaN
return (undef,undef) unless _is_one($c,$a);
- $sign = $sign == 1 ? '+' : '-';
- ($u1,$sign);
+ ($u1, $sign == 1 ? '+' : '-');
}
sub _modpow
}
print "# INC = @INC\n";
- plan tests => 1815;
+ plan tests => 1837;
}
use Math::BigFloat lib => 'BareCalc';
}
print "# INC = @INC\n";
- plan tests => 2832;
+ plan tests => 2848;
}
use Math::BigInt lib => 'BareCalc';
ok ($class->new(1)->fdiv('0.5')->bsstr(),'2e+0');
+###############################################################################
+# [perl #30609] bug with $x -= $x not beeing 0, but 2*$x
+
+$x = $class->new(3); $x -= $x; ok ($x, 0);
+$x = $class->new(-3); $x -= $x; ok ($x, 0);
+$x = $class->new(3); $x += $x; ok ($x, 6);
+$x = $class->new(-3); $x += $x; ok ($x, -6);
+
+$x = $class->new('NaN'); $x -= $x; ok ($x->is_nan(), 1);
+$x = $class->new('inf'); $x -= $x; ok ($x->is_nan(), 1);
+$x = $class->new('-inf'); $x -= $x; ok ($x->is_nan(), 1);
+
+$x = $class->new('NaN'); $x += $x; ok ($x->is_nan(), 1);
+$x = $class->new('inf'); $x += $x; ok ($x->is_inf(), 1);
+$x = $class->new('-inf'); $x += $x; ok ($x->is_inf('-'), 1);
+
+$x = $class->new('3.14'); $x -= $x; ok ($x, 0);
+$x = $class->new('-3.14'); $x -= $x; ok ($x, 0);
+$x = $class->new('3.14'); $x += $x; ok ($x, '6.28');
+$x = $class->new('-3.14'); $x += $x; ok ($x, '-6.28');
+
+$x = $class->new('3.14'); $x *= $x; ok ($x, '9.8596');
+$x = $class->new('-3.14'); $x *= $x; ok ($x, '9.8596');
+$x = $class->new('3.14'); $x /= $x; ok ($x, '1');
+$x = $class->new('-3.14'); $x /= $x; ok ($x, '1');
+$x = $class->new('3.14'); $x %= $x; ok ($x, '0');
+$x = $class->new('-3.14'); $x %= $x; ok ($x, '0');
+
+###############################################################################
+# the following two were reported by "kenny" via hotmail.com:
+
+#perl -MMath::BigFloat -wle 'print Math::BigFloat->new(0)->bpow(".1")'
+#Use of uninitialized value in numeric le (<=) at BigFloat.pm line 1851.
+
+$x = $class->new(0); $y = $class->new('0.1');
+ok ($x ** $y, 0, 'no warnings and zero result');
+
+#perl -MMath::BigFloat -lwe 'print Math::BigFloat->new(".222222222222222222222222222222222222222222")->bceil()'
+#Use of uninitialized value in numeric le (<=) at BigFloat.pm line 1851.
+
+$x = $class->new(".222222222222222222222222222222222222222222");
+ok ($x->bceil(), 1, 'no warnings and one as result');
+
1; # all done
###############################################################################
}
print "# INC = @INC\n";
- plan tests => 1815
+ plan tests => 1837
+ 2; # own tests
}
ok ($class->new(-1)->is_one(),0);
###############################################################################
+# [perl #30609] bug with $x -= $x not beeing 0, but 2*$x
+
+$x = $class->new(3); $x -= $x; ok ($x, 0);
+$x = $class->new(-3); $x -= $x; ok ($x, 0);
+$x = $class->new('NaN'); $x -= $x; ok ($x->is_nan(), 1);
+$x = $class->new('inf'); $x -= $x; ok ($x->is_nan(), 1);
+$x = $class->new('-inf'); $x -= $x; ok ($x->is_nan(), 1);
+
+$x = $class->new('NaN'); $x += $x; ok ($x->is_nan(), 1);
+$x = $class->new('inf'); $x += $x; ok ($x->is_inf(), 1);
+$x = $class->new('-inf'); $x += $x; ok ($x->is_inf('-'), 1);
+$x = $class->new(3); $x += $x; ok ($x, 6);
+$x = $class->new(-3); $x += $x; ok ($x, -6);
+
+$x = $class->new(3); $x *= $x; ok ($x, 9);
+$x = $class->new(-3); $x *= $x; ok ($x, 9);
+$x = $class->new(3); $x /= $x; ok ($x, 1);
+$x = $class->new(-3); $x /= $x; ok ($x, 1);
+$x = $class->new(3); $x %= $x; ok ($x, 0);
+$x = $class->new(-3); $x %= $x; ok ($x, 0);
+
+###############################################################################
# all tests done
1;
my $location = $0; $location =~ s/bigintpm.t//;
unshift @INC, $location; # to locate the testing files
chdir 't' if -d 't';
- plan tests => 2832;
+ plan tests => 2848;
}
use Math::BigInt;
}
print "# INC = @INC\n";
- plan tests => 1815
+ plan tests => 1837
+ 6; # + our own tests
}
}
print "# INC = @INC\n";
- plan tests => 2832
+ plan tests => 2848
+ 5; # +5 own tests
}
}
print "# INC = @INC\n";
- plan tests => 1815
+ plan tests => 1837
+ 1;
}
https://perl5.git.perl.org / perl5.git / commitdiff