This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
authorNick Ing-Simmons <nik@tiuk.ti.com>
Fri, 7 Dec 2001 15:07:15 +0000 (15:07 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Fri, 7 Dec 2001 15:07:15 +0000 (15:07 +0000)
p4raw-id: //depot/perlio@13514

115 files changed:
Changes
MANIFEST
NetWare/Makefile
README.vms
configure.com
djgpp/config.over
djgpp/configure.bat
djgpp/djgpp.c
djgpp/djgpp.h [new file with mode: 0644]
djgpp/djgppsed.sh
doio.c
doop.c
embed.h
embed.pl
ext/Devel/PPPort/Changes [new file with mode: 0755]
ext/Devel/PPPort/MANIFEST
ext/Devel/PPPort/Makefile.PL
ext/Devel/PPPort/PPPort.pm
ext/Devel/PPPort/PPPort.xs [moved from ext/Devel/PPPort/harness/Harness.xs with 88% similarity]
ext/Devel/PPPort/README
ext/Devel/PPPort/harness/Harness.pm [deleted file]
ext/Devel/PPPort/harness/Makefile.PL [deleted file]
ext/Devel/PPPort/harness/t/test.t [deleted file]
ext/Devel/PPPort/module2.c [moved from ext/Devel/PPPort/harness/module2.c with 60% similarity]
ext/Devel/PPPort/module3.c [moved from ext/Devel/PPPort/harness/module3.c with 53% similarity]
ext/Devel/PPPort/soak
ext/Devel/PPPort/t/test.t [new file with mode: 0644]
ext/Encode/Encode.pm
ext/I18N/Langinfo/Langinfo.t
ext/I18N/Langinfo/Langinfo.xs
ext/List/Util/Makefile.PL
ext/Opcode/Safe.pm
ext/Time/HiRes/HiRes.xs
global.sym
hints/solaris_2.sh
hints/super-ux.sh [new file with mode: 0644]
hv.c
hv.h
lib/AutoSplit.t
lib/Carp.pm
lib/Carp/Heavy.pm
lib/DB.t
lib/Exporter/Heavy.pm
lib/File/Basename.pm
lib/File/Basename.t
lib/File/Spec/VMS.pm
lib/File/Spec/t/Functions.t [moved from lib/File/Spec/Functions.t with 100% similarity, mode: 0644]
lib/File/Spec/t/Spec.t [moved from lib/File/Spec.t with 100% similarity, mode: 0644]
lib/File/Spec/t/rel2abs2rel.t [new file with mode: 0644]
lib/Math/BigFloat.pm
lib/Math/BigInt.pm
lib/Math/BigInt/Calc.pm
lib/Math/BigInt/t/bare_mbi.t [new file with mode: 0644]
lib/Math/BigInt/t/bigfltpm.inc
lib/Math/BigInt/t/bigfltpm.t
lib/Math/BigInt/t/bigintc.t
lib/Math/BigInt/t/bigintpm.inc
lib/Math/BigInt/t/bigintpm.t
lib/Math/BigInt/t/sub_mbf.t
lib/Math/BigInt/t/sub_mbi.t
lib/Net/Ping.pm
lib/Net/t/config.t
lib/Net/t/ftp.t
lib/Net/t/hostname.t
lib/Net/t/netrc.t
lib/Net/t/nntp.t
lib/Net/t/require.t
lib/Net/t/smtp.t
lib/Net/t/time.t
lib/Term/Cap.pm
lib/Unicode/UCD.t
lib/open.pm
lib/open.t
mg.c
op.c
patchlevel.h
pod/buildtoc.PL
pod/perl.pod
pod/perl561delta.pod [new file with mode: 0644]
pod/perldelta.pod
pod/perlnewmod.pod
pod/perlpacktut.pod
pod/perlport.pod
pod/perltoc.pod
pp.c
pp_hot.c
pp_sys.c
proto.h
regexec.c
sv.c
t/TEST
t/base/lex.t
t/base/term.t
t/comp/script.t
t/io/open.t
t/lib/Math/BigFloat/Subclass.pm
t/lib/Math/BigInt/BareCalc.pm [new file with mode: 0644]
t/lib/Math/BigInt/Subclass.pm
t/lib/strict/subs
t/op/exec.t
t/op/inc.t
t/op/magic.t
t/op/re_tests
t/op/ref.t
t/op/tr.t
t/run/kill_perl.t
t/test.pl
utf8.c
util.c
vms/descrip_mms.template
vms/ext/filespec.t
vms/test.com
vms/vms.c
vms/vmsish.h
win32/perlhost.h

diff --git a/Changes b/Changes
index 8c3613c..1a4aed4 100644 (file)
--- a/Changes
+++ b/Changes
@@ -31,6 +31,694 @@ or any other branch.
 Version v5.7.2         Development release working toward v5.8
 --------------
 ____________________________________________________________________________
+[ 13491] By: jhi                                   on 2001/12/06  15:43:22
+        Log: Subject: [PATCH Perl@13462, on top of prev. multiplicity patch] MY_RAND workaround update
+             From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane)
+             Date: Thu, 6 Dec 2001 11:41:25 EST
+             Message-Id: <011206114105.67cab@DUPHY4.Physics.Drexel.Edu>
+     Branch: perl
+          ! vms/vms.c vms/vmsish.h
+____________________________________________________________________________
+[ 13490] By: jhi                                   on 2001/12/06  15:08:40
+        Log: Subject: [PATCH] Re: weirdness in regexps
+             From: Robin Houston <robin@kitsite.com> 
+             Date: Thu, 6 Dec 2001 14:44:01 +0000
+             Message-ID: <20011206144401.A27752@puffinry.freeserve.co.uk>
+     Branch: perl
+          ! op.c t/lib/strict/subs
+____________________________________________________________________________
+[ 13489] By: jhi                                   on 2001/12/06  15:07:18
+        Log: Make the -b -c -S tests count all of the /dev, not just
+             check the first one, as suggested by Benjamin Goldberg.
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13488] By: jhi                                   on 2001/12/06  14:41:02
+        Log: Subject: Re: [PATCH: bleadperl] casefold backref
+             From: "Jeff 'japhy' Pinyan" <jeffp@crusoe.net>
+             Date: Thu, 6 Dec 2001 10:39:45 -0500 (EST) 
+             Message-ID: <Pine.GSO.4.21.0112061038490.14590-100000@crusoe.crusoe.net>
+     Branch: perl
+          ! regexec.c
+____________________________________________________________________________
+[ 13487] By: jhi                                   on 2001/12/06  14:30:45
+        Log: Nits noticed by Philip Newton, and de-tab DB.t.
+     Branch: perl
+          ! lib/DB.t
+____________________________________________________________________________
+[ 13486] By: jhi                                   on 2001/12/06  14:23:06
+        Log: Subject: [PATCH] Re: counting tr thinks it's modifying 
+             From: rgarciasuarez@free.fr (Rafael Garcia-Suarez)
+             Date: 6 Dec 2001 11:06:01 -0000
+             Message-Id: <slrna0ukap.kbt.rgarciasuarez@rafael.kazibao.net>
+     Branch: perl
+          ! op.c t/op/tr.t
+____________________________________________________________________________
+[ 13485] By: jhi                                   on 2001/12/06  14:07:54
+        Log: Subject: [PATCH: bleadperl] casefold backref
+             From: Hugo van der Sanden <hv@crypt.compulink.co.uk> 
+             Date: Wed, 05 Dec 2001 17:27:05 +0000
+             Message-Id: <200112051727.fB5HR5422706@crypt.compulink.co.uk> 
+     Branch: perl
+          ! regexec.c t/op/re_tests
+____________________________________________________________________________
+[ 13484] By: jhi                                   on 2001/12/06  03:04:18
+        Log: Subject: [PATCH Perl@13440] MULTIPLICITY fixups               
+             From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane)
+             Date: Wed, 5 Dec 2001 22:34:53 EST
+             Message-Id: <011205223453.8122e@DUPHY4.Physics.Drexel.Edu>
+     Branch: perl
+          ! mg.c vms/vms.c vms/vmsish.h
+____________________________________________________________________________
+[ 13483] By: jhi                                   on 2001/12/06  02:59:40
+        Log: Subject: [PATCH lib/File/Spec* MANIFEST] Better abs2rel/rel2abs/canonpath tests
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Wed, 5 Dec 2001 19:52:58 -0500
+             Message-ID: <20011205195257.A903@blackrider>
+     Branch: perl
+          + lib/File/Spec/t/Functions.t lib/File/Spec/t/Spec.t
+          + lib/File/Spec/t/rel2abs2rel.t
+          - lib/File/Spec.t lib/File/Spec/Functions.t
+          ! MANIFEST
+____________________________________________________________________________
+[ 13482] By: jhi                                   on 2001/12/06  02:48:27
+        Log: Subject: Re: Silly stat() portability questions                
+             From: Benjamin Goldberg <goldbb2@earthlink.net>
+             Date: Wed, 05 Dec 2001 22:52:35 -0500
+             Message-ID: <3C0EEB83.8CE93CA2@earthlink.net>
+     Branch: perl
+          ! pod/perlport.pod
+____________________________________________________________________________
+[ 13481] By: jhi                                   on 2001/12/06  02:39:43
+        Log: Subject: [PATCH perl@13462]] VMS-only File::Spec->canonpath fix
+             From: "Craig A. Berry" <craigberry@mac.com>
+             Date: Wed, 05 Dec 2001 16:41:59 -0600
+             Message-Id: <5.1.0.14.2.20011205160043.02160e90@exchi01>
+     Branch: perl
+          ! README.vms configure.com lib/File/Spec/VMS.pm
+          ! vms/ext/filespec.t
+____________________________________________________________________________
+[ 13480] By: jhi                                   on 2001/12/05  19:53:05
+        Log: $apply->('club', $glibc_maintainers);
+             
+             (Nick Clark just reported that <langinfo.h> YESSTR
+             is an empty string in Linux 2.4.16-rmk glibc 2.2.4-5)
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.t
+____________________________________________________________________________
+[ 13479] By: jhi                                   on 2001/12/05  19:49:16
+        Log: Admonish against assuming A^HUNIX fs/uid/gid semantics.
+     Branch: perl
+          ! pod/perlport.pod
+____________________________________________________________________________
+[ 13477] By: jhi                                   on 2001/12/05  17:53:13
+        Log: Restore the /dev -b -c -S part of the test.
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13476] By: jhi                                   on 2001/12/05  17:29:36
+        Log: Retract #13475 until Arthur gets back to the mine.
+     Branch: perl
+          ! op.c t/run/kill_perl.t
+____________________________________________________________________________
+[ 13475] By: jhi                                   on 2001/12/05  17:07:00
+        Log: (retracted by #13476)
+             
+             Manually apply #13474; fixes stale reference to dead
+             CvOUTSIDE(); this can happen when anonymous subroutines
+             that aren't closures are returned from an eval""
+             
+             (threads/shared/sv_refs.t is coredump-unhappy about this change)
+     Branch: perl
+          ! op.c t/run/kill_perl.t
+____________________________________________________________________________
+[ 13472] By: jhi                                   on 2001/12/05  13:30:47
+        Log: Subject: Re: [PATCH] File::Basename pod and .t (was: perlpacktut.pod v0.0 (split))
+             From: Wolfgang Laun <Wolfgang.Laun@alcatel.at>
+             Date: Wed, 05 Dec 2001 10:49:20 +0100
+             Message-ID: <3C0DEDA0.C58A8A9E@alcatel.at>
+     Branch: perl
+          ! lib/File/Basename.pm lib/File/Basename.t
+____________________________________________________________________________
+[ 13471] By: jhi                                   on 2001/12/05  13:22:50
+        Log: Subject: [PATCH t/op/magic.t] Removing a TODO
+             From: Michael G Schwern <schwern@pobox.com> 
+             Date: Wed, 5 Dec 2001 02:47:59 -0500
+             Message-ID: <20011205024759.H14333@blackrider>
+     Branch: perl
+          ! t/op/magic.t
+____________________________________________________________________________
+[ 13470] By: jhi                                   on 2001/12/05  13:21:09
+        Log: Subject: [PATCH t/op/stat.t vms/test.com] stat.t portability, the LAST VMS exception!
+             From: Michael G Schwern <schwern@pobox.com>              
+             Date: Wed, 5 Dec 2001 02:22:05 -0500
+             Message-ID: <20011205022205.F14333@blackrider>
+     Branch: perl
+          ! t/op/stat.t vms/test.com
+____________________________________________________________________________
+[ 13469] By: jhi                                   on 2001/12/05  03:44:59
+        Log: Subject: Re: [PATCH t/op/stat.t t/test.pl] stat.t cleanup, first pass
+             From: Michael G Schwern <schwern@pobox.com> 
+             Date: Tue, 4 Dec 2001 23:40:10 -0500
+             Message-ID: <20011204234010.B14333@blackrider>
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13468] By: jhi                                   on 2001/12/05  01:37:04
+        Log: Subject: [PATCH t/op/stat.t t/test.pl] stat.t cleanup, first pass
+             From: Michael G Schwern <schwern@pobox.com> 
+             Date: Tue, 4 Dec 2001 21:09:18 -0500           
+             Message-ID: <20011204210918.D13279@blackrider>
+             
+             t/test.
+     Branch: perl
+          ! t/test.pl
+____________________________________________________________________________
+[ 13467] By: jhi                                   on 2001/12/05  01:36:44
+        Log: (accidentally empty check-in)
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13466] By: jhi                                   on 2001/12/04  22:51:19
+        Log: Subject: [PATCH] $., $%, $=, and $- are IV's now
+             From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+             Date: Tue, 04 Dec 2001 23:40:27 +0100
+             Message-Id: <20011204233412.304B.H.M.BRAND@hccnet.nl>
+     Branch: perl
+          ! mg.c
+____________________________________________________________________________
+[ 13465] By: jhi                                   on 2001/12/04  22:50:26
+        Log: Subject: [PATCH] minor pod fix in Safe.pm
+             From: Rafael Garcia-Suarez <rgarciasuarez@free.fr>
+             Date: Tue, 4 Dec 2001 22:02:34 +0100
+             Message-ID: <20011204220234.A17293@rafael>
+     Branch: perl
+          ! ext/Opcode/Safe.pm
+____________________________________________________________________________
+[ 13464] By: jhi                                   on 2001/12/04  22:47:43
+        Log: CRLF GRRR.
+     Branch: perl
+          ! djgpp/configure.bat
+____________________________________________________________________________
+[ 13463] By: jhi                                   on 2001/12/04  22:46:28
+        Log: DJGPP fixes from Laszlo Molnar.
+     Branch: perl
+          ! djgpp/configure.bat djgpp/djgpp.h
+____________________________________________________________________________
+[ 13462] By: jhi                                   on 2001/12/04  14:56:22
+        Log: Update Changes.
+     Branch: perl
+          ! Changes patchlevel.h
+____________________________________________________________________________
+[ 13461] By: jhi                                   on 2001/12/04  14:49:45
+        Log: Must wipe out the memory of real Socket before starting
+             to use the old one.
+     Branch: perl
+          ! lib/Net/t/config.t
+____________________________________________________________________________
+[ 13460] By: jhi                                   on 2001/12/04  14:40:28
+        Log: LC_ALL might trump LANG.
+     Branch: perl
+          ! lib/open.t
+____________________________________________________________________________
+[ 13459] By: jhi                                   on 2001/12/04  14:39:38
+        Log: Make the eval runtime.
+     Branch: perl
+          ! lib/open.pm
+____________________________________________________________________________
+[ 13458] By: jhi                                   on 2001/12/04  14:08:17
+        Log: Make the Langinfo test both more lenient (allow
+             for any symbol not to exists) and stricter (add
+             more symbols).
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.t
+____________________________________________________________________________
+[ 13457] By: gsar                                  on 2001/12/04  14:07:01
+        Log: integrate change#13453 from maint-5.6
+             
+             tweak change#11399 to use an explicit flag rather than
+             ass_u_ming w32_pseudo_id will only be zero for the real
+             toplevel interpreter; avoids multiple hosts from diddling
+             the environment at the same time
+     Branch: perl
+         !> win32/perlhost.h
+____________________________________________________________________________
+[ 13456] By: jhi                                   on 2001/12/04  13:35:58
+        Log: Subject: [PATCH] VMS update for perldelta.pod
+             From: "Craig A. Berry" <craigberry@mac.com> 
+             Date: Tue, 4 Dec 2001 00:23:12 -0600
+             Message-Id: <a05101002b83218be190d@[172.16.52.1]>
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13455] By: jhi                                   on 2001/12/04  13:23:19
+        Log: NetWare tweak from Ananth Kesari.
+     Branch: perl
+          ! NetWare/Makefile
+____________________________________________________________________________
+[ 13454] By: jhi                                   on 2001/12/04  13:17:38
+        Log: Upgrade to Net::Ping 2.07, from Rob Brown.
+             Not adding the test suite because of its many assumptions.
+     Branch: perl
+          ! lib/Net/Ping.pm
+____________________________________________________________________________
+[ 13452] By: jhi                                   on 2001/12/04  04:28:29
+        Log: Add hints file for SUPER-UX: the UNIX of NEC SX series,
+             from Len Makin.
+     Branch: perl
+          + hints/super-ux.sh
+          ! MANIFEST
+____________________________________________________________________________
+[ 13451] By: jhi                                   on 2001/12/04  01:58:03
+        Log: Add Mac OS X known failures to perldelta.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13450] By: jhi                                   on 2001/12/04  01:26:38
+        Log: I think it's time to call the utf8 code non-test.
+     Branch: perl
+          ! utf8.c
+____________________________________________________________________________
+[ 13449] By: jhi                                   on 2001/12/04  00:59:27
+        Log: Retract #13303, need rethink.
+     Branch: perl
+          ! utf8.c
+____________________________________________________________________________
+[ 13448] By: jhi                                   on 2001/12/03  22:40:22
+        Log: Subject: [PATCH perl@13440] VMS install fix-ups: add libnetcfg and xsubpp as utility commands
+             From: "Craig A. Berry" <craigberry@mac.com>
+             Date: Mon, 03 Dec 2001 16:28:06 -0600
+             Message-Id: <5.1.0.14.2.20011202223303.01c3ab98@exchi01>
+     Branch: perl
+          ! configure.com lib/File/Basename.pm vms/descrip_mms.template
+____________________________________________________________________________
+[ 13447] By: jhi                                   on 2001/12/03  22:37:12
+        Log: Subject: [PATCH] Solaris/longdouble needs /opt/SUNWspro/lib
+             From: Andy Dougherty <doughera@lafayette.edu>
+             Date: Mon, 3 Dec 2001 15:48:26 -0500 (EST)
+             Message-ID: <Pine.SOL.4.10.10112031543520.5207-100000@maxwell.phys.lafayette.edu>
+     Branch: perl
+          ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 13446] By: jhi                                   on 2001/12/03  22:29:58
+        Log: This test is not very robust on 8.3-constrained systems:
+             all the "with truncated name" lines between "Autosplitting ..."
+             and "some names are not unique" lines are unexpected,
+             and the truncation message becomes:
+             testtest.al, testtest.al truncate to testtest 
+     Branch: perl
+          ! lib/AutoSplit.t
+____________________________________________________________________________
+[ 13445] By: jhi                                   on 2001/12/03  22:13:07
+        Log: DOS/DJGPP has nl_langinfo() but nothing much in it.
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.t
+____________________________________________________________________________
+[ 13444] By: jhi                                   on 2001/12/03  22:02:52
+        Log: Test::Morify UCD.t
+     Branch: perl
+          ! lib/Unicode/UCD.t
+____________________________________________________________________________
+[ 13443] By: jhi                                   on 2001/12/03  21:50:13
+        Log: If Socket has not been built (e.g. DJGPP) the libnet
+             tests fall over with (too) much noise.
+     Branch: perl
+          ! lib/Net/t/config.t lib/Net/t/ftp.t lib/Net/t/hostname.t
+          ! lib/Net/t/netrc.t lib/Net/t/nntp.t lib/Net/t/require.t
+          ! lib/Net/t/smtp.t lib/Net/t/time.t
+____________________________________________________________________________
+[ 13442] By: jhi                                   on 2001/12/03  17:22:08
+        Log: Subject: [PATCH] shared hash keys and ++/--
+             From: Nicholas Clark <nick@ccl4.org>
+             Date: Mon, 3 Dec 2001 16:37:16 +0000
+             Message-ID: <20011203163716.C21702@plum.flirble.org>
+     Branch: perl
+          ! pp.c pp_hot.c sv.c t/op/inc.t
+____________________________________________________________________________
+[ 13441] By: jhi                                   on 2001/12/03  17:15:52
+        Log: Subject: [PATCH lib/Term/Cap.pm] was Re: [PATCH] Shared hash keys
+             From: Jonathan Stowe <jns@gellyfish.com>
+             Date: Mon, 3 Dec 2001 15:48:38 +0000 (GMT)
+             Message-ID: <Pine.LNX.4.33.0112031543290.386-100000@orpheus.gellyfish.com>
+     Branch: perl
+          ! lib/Term/Cap.pm
+____________________________________________________________________________
+[ 13440] By: jhi                                   on 2001/12/03  14:26:58
+        Log: Update Changes.
+     Branch: perl
+          ! Changes patchlevel.h
+____________________________________________________________________________
+[ 13439] By: jhi                                   on 2001/12/03  14:22:05
+        Log: perldelta tweaks.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13438] By: jhi                                   on 2001/12/03  14:12:08
+        Log: Subject: [PATCH] perlnewmod.pod: Fixed URL for Ken William's Tutorial
+             From: Sam Tregar <sam@tregar.com> 
+             Date: Mon, 3 Dec 2001 00:04:07 -0500 (EST)
+             Message-ID: <Pine.LNX.4.33.0112030002210.24619-100000@localhost.localdomain>
+     Branch: perl
+          ! pod/perlnewmod.pod
+____________________________________________________________________________
+[ 13437] By: jhi                                   on 2001/12/03  14:08:59
+        Log: microperl casting nit.
+     Branch: perl
+          ! utf8.c
+____________________________________________________________________________
+[ 13436] By: jhi                                   on 2001/12/03  14:03:21
+        Log: Make sharepvn a macro since all it does is a deref.
+     Branch: perl
+          ! embed.h embed.pl global.sym hv.c hv.h proto.h
+____________________________________________________________________________
+[ 13435] By: jhi                                   on 2001/12/03  13:38:14
+        Log: perldelta updates.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13434] By: jhi                                   on 2001/12/03  13:13:02
+        Log: PPPort update from Paul Marquess.
+     Branch: perl
+          + ext/Devel/PPPort/Changes ext/Devel/PPPort/PPPort.xs
+          + ext/Devel/PPPort/module2.c ext/Devel/PPPort/module3.c
+          + ext/Devel/PPPort/t/test.t
+          - ext/Devel/PPPort/harness/Harness.pm
+          - ext/Devel/PPPort/harness/Harness.xs
+          - ext/Devel/PPPort/harness/Makefile.PL
+          - ext/Devel/PPPort/harness/module2.c
+          - ext/Devel/PPPort/harness/module3.c
+          - ext/Devel/PPPort/harness/t/test.t
+          ! MANIFEST ext/Devel/PPPort/MANIFEST
+          ! ext/Devel/PPPort/Makefile.PL ext/Devel/PPPort/PPPort.pm
+          ! ext/Devel/PPPort/README ext/Devel/PPPort/TODO
+          ! ext/Devel/PPPort/soak
+____________________________________________________________________________
+[ 13433] By: jhi                                   on 2001/12/03  12:57:23
+        Log: No use talking about dynamic library search patch
+             unless we are having a dynamic build.
+     Branch: perl
+          ! t/TEST
+____________________________________________________________________________
+[ 13432] By: jhi                                   on 2001/12/02  22:35:04
+        Log: Be more explicit on the List::Util build trick,
+             should also stop unneeded rebuilds on static builds.
+     Branch: perl
+          ! ext/List/Util/Makefile.PL
+____________________________________________________________________________
+[ 13431] By: jhi                                   on 2001/12/02  22:18:45
+        Log: We need to replace the optimize (-O1) with
+             the -h scalar0 -h vector0, not append them
+             to the ccflags.
+     Branch: perl
+          ! hints/unicos.sh hints/unicosmk.sh
+____________________________________________________________________________
+[ 13430] By: jhi                                   on 2001/12/02  20:01:24
+        Log: Subject: [PATCH] Shared hash keys 
+             From: Nicholas Clark <nick@ccl4.org>
+             Date: Sun, 2 Dec 2001 20:52:32 +0000
+             Message-ID: <20011202205232.U21702@plum.flirble.org>
+     Branch: perl
+          ! doop.c t/op/tr.t
+____________________________________________________________________________
+[ 13429] By: jhi                                   on 2001/12/02  19:19:54
+        Log: Better add new files to MANIFEST, too.
+     Branch: perl
+          ! MANIFEST
+____________________________________________________________________________
+[ 13428] By: jhi                                   on 2001/12/02  18:38:18
+        Log: Subject: {PATCH] perlpacktut.pod
+             From: "Wolfgang Laun" <wolfgang.laun@chello.at> 
+             Date: Sun, 02 Dec 2001 19:55:06 +0100
+             Message-ID: <200112021955060600.009C0EF9@smtp.chello.at>
+     Branch: perl
+          ! pod/perlpacktut.pod
+____________________________________________________________________________
+[ 13427] By: jhi                                   on 2001/12/02  17:07:57
+        Log: Various small nits found by DJGPP build.
+     Branch: perl
+          ! doio.c mg.c pp.c util.c
+____________________________________________________________________________
+[ 13426] By: jhi                                   on 2001/12/02  16:55:21
+        Log: Subject: RE: More verbose POD for Carp
+             From: "Benjamin J. Tilly" <ben_tilly@operamail.com>
+             Date: Sun, 2 Dec 2001 11:32:51 -0500
+             Message-ID: <3C0A9748@operamail.com>
+     Branch: perl
+          ! lib/Carp.pm
+____________________________________________________________________________
+[ 13425] By: jhi                                   on 2001/12/02  16:54:06
+        Log: Add a header for DJGPP with the function prototypes.
+     Branch: perl
+          + djgpp/djgpp.h
+          ! MANIFEST djgpp/djgpp.c
+____________________________________________________________________________
+[ 13424] By: jhi                                   on 2001/12/02  01:17:43
+        Log: Subject: [PATCH] chdir() with an empty tainted argument on Win32
+             From: Abe Timmerman <abe@ztreet.demon.nl>
+             Date: Sun, 02 Dec 2001 02:41:25 +0100
+             Message-ID: <j8vi0uorud2fa9vp0q2dpmn7tpr5hqec1d@4ax.com>
+     Branch: perl
+          ! pp_sys.c
+____________________________________________________________________________
+[ 13423] By: jhi                                   on 2001/12/02  01:05:43
+        Log: There isn't PTR2INT(), there's PTR2IV().
+     Branch: perl
+          ! ext/Time/HiRes/HiRes.xs
+____________________________________________________________________________
+[ 13422] By: jhi                                   on 2001/12/02  00:56:05
+        Log: Subject: [ID 20011201.170] Time::HiRes in devel-perl causes segfaults for xs users
+             From: Marc Lehmann <root@schmorp.de>
+             Date: Sun, 02 Dec 2001 02:44:53 +0100
+             Message-Id: <E16ALgb-0006Yw-00.pgcc-forever-2001-12-02-02-44-53@fuji.laendle>
+     Branch: perl
+          ! ext/Time/HiRes/HiRes.xs
+____________________________________________________________________________
+[ 13421] By: jhi                                   on 2001/12/02  00:25:35
+        Log: encode()/decode() examples.
+     Branch: perl
+          ! ext/Encode/Encode.pm
+____________________________________________________________________________
+[ 13420] By: jhi                                   on 2001/12/02  00:14:38
+        Log: DJGPP tweaks from Laszlo Molnar.
+     Branch: perl
+          ! djgpp/config.over djgpp/djgppsed.sh
+____________________________________________________________________________
+[ 13419] By: jhi                                   on 2001/12/01  20:52:19
+        Log: Update Changes.
+     Branch: perl
+          ! Changes patchlevel.h
+____________________________________________________________________________
+[ 13418] By: jhi                                   on 2001/12/01  20:40:03
+        Log: Integrate perlio;
+             
+             Skip socket-ness tests on handles (e.g. PerlIO::Scalar)
+             which do not have file descriptors. Noticed a possibly
+             worse problem in the process ...
+     Branch: perl
+         !> doio.c
+____________________________________________________________________________
+[ 13417] By: jhi                                   on 2001/12/01  20:37:40
+        Log: Non-VMS-fixed and Win32-skipped version of
+             
+             Subject: [PATCH t/op/exec.t] Portabilty fix 
+             From: Michael G Schwern <schwern@pobox.com> 
+             Date: Fri, 30 Nov 2001 16:09:27 -0500
+             Message-ID: <20011130160927.A10406@blackrider>
+     Branch: perl
+          ! t/op/exec.t
+____________________________________________________________________________
+[ 13416] By: jhi                                   on 2001/12/01  20:35:31
+        Log: Subject: Enabling strict on Carp/Heavy, + internal documentation
+             From: "Benjamin J. Tilly" <ben_tilly@operamail.com>                
+             Date: Sat, 1 Dec 2001 07:01:09 -0500
+             Message-ID: <3C0D2E39@operamail.com>
+             
+             Subject: More verbose POD for Carp
+             From: "Benjamin J. Tilly" <ben_tilly@operamail.com>                
+             Date: Sat, 1 Dec 2001 08:04:16 -0500
+             Message-ID: <3C285C2B@operamail.com>
+     Branch: perl
+          ! lib/Carp.pm lib/Carp/Heavy.pm
+____________________________________________________________________________
+[ 13415] By: jhi                                   on 2001/12/01  20:31:06
+        Log: Subject: [PATCH lib/DB.t] Strictures, dual variables 
+             From: chromatic <chromatic@rmci.net>
+             Date: Sat, 01 Dec 2001 12:41:58 -0700
+             Message-ID: <20011201194946.50449.qmail@onion.perl.org>
+     Branch: perl
+          ! lib/DB.t
+____________________________________________________________________________
+[ 13414] By: jhi                                   on 2001/12/01  20:30:17
+        Log: Try to make a missing RADIXCHAR a softer kinder error.
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.t
+____________________________________________________________________________
+[ 13413] By: jhi                                   on 2001/12/01  20:21:27
+        Log: Have a little faith on nl_langinfo() itself.
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.xs
+____________________________________________________________________________
+[ 13412] By: jhi                                   on 2001/12/01  18:47:07
+        Log: Typo (a missing endparen) and thinko (_MAXSTRMSG is
+             the max, not max plus one)
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.xs
+____________________________________________________________________________
+[ 13411] By: jhi                                   on 2001/12/01  18:45:32
+        Log: Make reality agree with the comment.
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.xs
+____________________________________________________________________________
+[ 13410] By: jhi                                   on 2001/12/01  18:43:11
+        Log: Try to protect against wild langinfo() arguments.
+     Branch: perl
+          ! ext/I18N/Langinfo/Langinfo.xs
+____________________________________________________________________________
+[ 13408] By: jhi                                   on 2001/12/01  18:18:34
+        Log: If we are inside an eval, let's be silent about
+             separate symbols and just croak() in the end.
+     Branch: perl
+          ! lib/Exporter/Heavy.pm
+____________________________________________________________________________
+[ 13406] By: jhi                                   on 2001/12/01  16:31:02
+        Log: Subject: Fix for Exporter error reporting behaviour
+             From: "Benjamin J. Tilly" <ben_tilly@operamail.com>                
+             Date: Sat, 1 Dec 2001 06:34:48 -0500
+             Message-ID: <3C0D1B9A@operamail.com>
+     Branch: perl
+          ! lib/Exporter.pm lib/Exporter/Heavy.pm
+____________________________________________________________________________
+[ 13405] By: jhi                                   on 2001/12/01  16:29:27
+        Log: Need to hide behind an eval to avoid a warning
+             about :utf8 on non-perlio configs.
+     Branch: perl
+          ! lib/open.t
+____________________________________________________________________________
+[ 13404] By: jhi                                   on 2001/12/01  15:55:51
+        Log: Subject: [PATCH 20010902.002] parser panics on lvalue methods 
+             From: Rafael Garcia-Suarez <rgarciasuarez@free.fr>
+             Date: Fri, 30 Nov 2001 23:46:58 +0100
+             Message-ID: <20011130234658.A717@rafael>
+     Branch: perl
+          ! op.c t/op/method.t
+____________________________________________________________________________
+[ 13403] By: jhi                                   on 2001/12/01  15:54:23
+        Log: Subject: Re: [ID 20011129.163] B::Xref- $top corrupt
+             From: Rafael Garcia-Suarez <rgarciasuarez@free.fr>
+             Date: Thu, 29 Nov 2001 22:46:12 +0100
+             Message-ID: <20011129224612.A699@rafael>
+     Branch: perl
+          ! ext/B/B/Xref.pm
+____________________________________________________________________________
+[ 13402] By: jhi                                   on 2001/12/01  15:52:13
+        Log: Subject: Re: [PATCH] [ID 20011130.166] "in memory" file handles via scalas not documented in perldoc -f open 
+             From: Tels <perl_dummy@bloodgate.com>
+             Date: Sat, 01 Dec 2001 10:29:11 +0100 (CET)
+             Message-Id: <200112010931.LAA29309@tiku.hut.fi>
+     Branch: perl
+          ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 13401] By: jhi                                   on 2001/12/01  15:48:13
+        Log: Subject: [REPATCH] reference pointer comparison
+             From: Nicholas Clark <nick@ccl4.org>
+             Date: Sat, 1 Dec 2001 13:00:17 +0000
+             Message-ID: <20011201130017.I21702@plum.flirble.org>
+     Branch: perl
+          ! pp.c
+____________________________________________________________________________
+[ 13400] By: jhi                                   on 2001/12/01  15:43:15
+        Log: Upgrade to Storable 1.0.14.
+     Branch: perl
+          ! ext/Storable/ChangeLog ext/Storable/Storable.pm
+____________________________________________________________________________
+[ 13399] By: jhi                                   on 2001/12/01  15:40:13
+        Log: Add simple caches for ::viacode() and ::vianame().
+     Branch: perl
+          ! lib/charnames.pm lib/charnames.t
+____________________________________________________________________________
+[ 13397] By: jhi                                   on 2001/12/01  04:35:39
+        Log: Regen toc and modlib.
+     Branch: perl
+          ! pod/perlmodlib.pod pod/perltoc.pod
+____________________________________________________________________________
+[ 13396] By: jhi                                   on 2001/12/01  04:31:53
+        Log: Upgrade to podlators-1.18.
+     Branch: perl
+          ! lib/Pod/ParseLink.pm lib/Pod/Text/Termcap.pm
+____________________________________________________________________________
+[ 13395] By: jhi                                   on 2001/11/30  23:03:20
+        Log: -h scalar0 -h vector0 seems to help for both
+             UNICOS and UNICOS/mk on the unpack %65c problems.
+             
+             (replaces #13393)
+     Branch: perl
+          ! hints/unicos.sh hints/unicosmk.sh
+____________________________________________________________________________
+[ 13394] By: jhi                                   on 2001/11/30  22:51:17
+        Log: More Socket constants.
+     Branch: perl
+          ! ext/Socket/Makefile.PL ext/Socket/Socket.pm
+____________________________________________________________________________
+[ 13393] By: jhi                                   on 2001/11/30  22:00:04
+        Log: (replaced by #13395)
+     Branch: perl
+          ! hints/unicosmk.sh
+____________________________________________________________________________
+[ 13392] By: jhi                                   on 2001/11/30  20:26:22
+        Log: Subject: Re: -P and Incredible Disappearing $Config{cppstdin} (was Re: perl@13385)
+             From: Andy Dougherty <doughera@lafayette.edu>
+             Date: Fri, 30 Nov 2001 13:49:48 -0500 (EST)
+             Message-ID: <Pine.SOL.4.10.10111301304220.13302-100000@maxwell.phys.lafayette.edu>
+             
+             Simplify the test skippage criterion now that we are
+             no more dependent on sed.
+     Branch: perl
+          ! t/comp/cpp.t t/run/switchPx.t
+____________________________________________________________________________
+[ 13391] By: jhi                                   on 2001/11/30  20:19:37
+        Log: Subject: Re: [ID 20011130.164] Not OK: perl v5.7.2 +DEVEL13363 on i686-linux-2.4.8-26mdk
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Fri, 30 Nov 2001 11:48:44 -0500
+             Message-ID: <20011130114844.C1303@blackrider>
+             
+             (replaces #13381)
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13390] By: jhi                                   on 2001/11/30  18:12:54
+        Log: Let's not assume how much memory has been allocated
+             to PVs.
+     Branch: perl
+          ! ext/Devel/Peek/Peek.t
+____________________________________________________________________________
+[ 13389] By: jhi                                   on 2001/11/30  17:38:37
+        Log: VOS needs to know the modules, including pp_sort.
+     Branch: perl
+          ! vos/perl.bind
+____________________________________________________________________________
+[ 13388] By: jhi                                   on 2001/11/30  15:18:51
+        Log: Unused variables.
+     Branch: perl
+          ! ext/Unicode/Normalize/Normalize.xs
+____________________________________________________________________________
+[ 13387] By: jhi                                   on 2001/11/30  14:57:19
+        Log: Subject: [PATCH] Cygwin failures with lib/ExtUtils/Embed.t
+             From: John Peacock <jpeacock@rowman.com>     
+             Date: Fri, 30 Nov 2001 10:24:00 -0500        
+             Message-ID: <3C07A490.A22A76B0@rowman.com>   
+     Branch: perl
+          ! lib/ExtUtils/Embed.t
+____________________________________________________________________________
+[ 13386] By: jhi                                   on 2001/11/30  14:55:02
+        Log: Tweak for the VOS building script from Paul Green.
+     Branch: perl
+          ! vos/configure_perl.cm
+____________________________________________________________________________
+[ 13385] By: jhi                                   on 2001/11/30  14:11:18
+        Log: Update Changes.
+     Branch: perl
+          ! Changes patchlevel.h
+____________________________________________________________________________
 [ 13384] By: jhi                                   on 2001/11/30  14:00:55
         Log: Cannot test if cppstdin has not yet been installed.
      Branch: perl
index e3bfc12..64e87cf 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -32,6 +32,7 @@ deb.c                 Debugging routines
 djgpp/config.over      DOS/DJGPP port
 djgpp/configure.bat    DOS/DJGPP port
 djgpp/djgpp.c          DOS/DJGPP port
+djgpp/djgpp.h          DOS/DJGPP port
 djgpp/djgppsed.sh      DOS/DJGPP port
 djgpp/fixpmain         DOS/DJGPP port
 doio.c                 I/O operations
@@ -139,17 +140,16 @@ ext/Devel/Peek/Makefile.PL        Data debugging tool, makefile writer
 ext/Devel/Peek/Peek.pm         Data debugging tool, module and pod
 ext/Devel/Peek/Peek.t          See if Devel::Peek works
 ext/Devel/Peek/Peek.xs         Data debugging tool, externals
-ext/Devel/PPPort/harness/Harness.pm    Devel::PPPort test harness
-ext/Devel/PPPort/harness/Harness.xs    Devel::PPPort test harness
-ext/Devel/PPPort/harness/Makefile.PL   Devel::PPPort::harness makefile writer
-ext/Devel/PPPort/harness/module2.c     Devel::PPPort test file
-ext/Devel/PPPort/harness/module3.c     Devel::PPPort test file
-ext/Devel/PPPort/harness/t/test.t      See if Devel::PPPort works
-ext/Devel/PPPort/MANIFEST      Devel::PPPort Manifest
+ext/Devel/PPPort/Changes       Devel::PPPort changes
 ext/Devel/PPPort/Makefile.PL   Devel::PPPort makefile writer
+ext/Devel/PPPort/MANIFEST      Devel::PPPort Manifest
+ext/Devel/PPPort/module2.c     Devel::PPPort test file
+ext/Devel/PPPort/module3.c     Devel::PPPort test file
 ext/Devel/PPPort/PPPort.pm     Devel::PPPort
+ext/Devel/PPPort/PPPort.xs     Devel::PPPort
 ext/Devel/PPPort/README                Devel::PPPort Readme
 ext/Devel/PPPort/soak                  Test Harness to run Devel::PPPort other Perls
+ext/Devel/PPPort/t/test.t      See if Devel::PPPort works
 ext/Devel/PPPort/TODO          Devel::PPPort Todo
 ext/Digest/MD5/Changes         Digest::MD5 extension changes
 ext/Digest/MD5/hints/irix_6.pl Hints for named architecture
@@ -719,6 +719,7 @@ hints/solaris_2.sh          Hints for named architecture
 hints/stellar.sh               Hints for named architecture
 hints/sunos_4_0.sh             Hints for named architecture
 hints/sunos_4_1.sh             Hints for named architecture
+hints/super-ux.sh              Hints for named architecture
 hints/svr4.sh                  Hints for named architecture
 hints/svr5.sh                  Hints for named architecture
 hints/ti1500.sh                        Hints for named architecture
@@ -964,12 +965,13 @@ lib/File/Find/t/taint.t           See if File::Find works with taint
 lib/File/Path.pm               Do things like `mkdir -p' and `rm -r'
 lib/File/Path.t                        See if File::Path works
 lib/File/Spec.pm               portable operations on file names
-lib/File/Spec.t                        See if File::Spec works
 lib/File/Spec/Epoc.pm          portable operations on EPOC file names
 lib/File/Spec/Functions.pm     Function interface to File::Spec object methods
-lib/File/Spec/Functions.t      See if File::Spec::Functions works
 lib/File/Spec/Mac.pm           portable operations on Mac file names
 lib/File/Spec/OS2.pm           portable operations on OS2 file names
+lib/File/Spec/t/Functions.t     See if File::Spec::Functions works
+lib/File/Spec/t/rel2abs2rel.t   See if File::Spec->rel2abs/abs2rel works
+lib/File/Spec/t/Spec.t         See if File::Spec works
 lib/File/Spec/Unix.pm          portable operations on Unix file names
 lib/File/Spec/VMS.pm           portable operations on VMS file names
 lib/File/Spec/Win32.pm         portable operations on Win32 file names
@@ -1055,6 +1057,7 @@ lib/look.pl                       A "look" equivalent
 lib/Math/BigFloat.pm           An arbitrary precision floating-point arithmetic package
 lib/Math/BigInt.pm             An arbitrary precision integer arithmetic package
 lib/Math/BigInt/Calc.pm                Pure Perl module to support Math::BigInt
+lib/Math/BigInt/t/bare_mbi.t   Test Math::BigInt::CareCalc
 lib/Math/BigInt/t/bigfltpm.inc Shared tests for bigfltpm.t and sub_mbf.t
 lib/Math/BigInt/t/bigfltpm.t   See if BigFloat.pm works
 lib/Math/BigInt/t/bigintc.t    See if BigInt/Calc.pm works
@@ -1850,6 +1853,7 @@ pod/Makefile.SH                   generate Makefile whichs makes pods into something else
 pod/perl.pod                   Top level perl documentation
 pod/perl5004delta.pod          Changes from 5.003 to 5.004
 pod/perl5005delta.pod          Changes from 5.004 to 5.005
+pod/perl561delta.pod           Changes from 5.6.0 to 5.6.1
 pod/perl56delta.pod            Changes from 5.005 to 5.6
 pod/perl570delta.pod           Changes from 5.6 to 5.7.0
 pod/perl571delta.pod           Changes from 5.7.0 to 5.7.1
@@ -2093,6 +2097,7 @@ t/lib/h2ph.pht                    Generated output from h2ph.h by h2ph, for comparison
 t/lib/locale/latin1            Part of locale.t in Latin 1
 t/lib/locale/utf8              Part of locale.t in UTF8
 t/lib/Math/BigFloat/Subclass.pm        Empty subclass of BigFloat for test
+t/lib/Math/BigInt/BareCalc.pm  Bigint's simulation of Calc
 t/lib/Math/BigInt/Subclass.pm  Empty subclass of BigInt for test
 t/lib/sample-tests/bailout             Test data for Test::Harness
 t/lib/sample-tests/combined            Test data for Test::Harness
index 921a017..d71cd47 100644 (file)
@@ -1443,7 +1443,7 @@ distclean: clean nwclean
        -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
        -del /f $(LIBDIR)\XSLoader.pm
        -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
-       -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
+       -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm
        -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
        -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
        -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
index 6be5385..8d20758 100644 (file)
@@ -178,8 +178,6 @@ troublesome logicals and symbols are:
     T    "LOGICAL"
     FOO  "LOGICAL"
     EXT  "LOGICAL"
-    SOME_LOGICAL_NAME_NOT_LIKELY "LOGICAL"
-    DOWN_LOGICAL_NAME_NOT_LIKELY "LOGICAL"
     TEST "SYMBOL"
 
 As a handy shortcut, the command:
index d8833d3..98e5867 100644 (file)
@@ -6065,8 +6065,6 @@ $ CALL Bad_environment "LIB"
 $ CALL Bad_environment "T"
 $ CALL Bad_environment "FOO"
 $ CALL Bad_environment "EXT"
-$ CALL Bad_environment "SOME_LOGICAL_NAME_NOT_LIKELY"
-$ CALL Bad_environment "DOWN_LOGICAL_NAME_NOT_LIKELY"
 $ CALL Bad_environment "TEST" "SYMBOL"
 $ IF f$search("config.msg") .eqs. "" THEN echo "OK."
 $!
@@ -6169,9 +6167,11 @@ $     WRITE CONFIG "$ dprofpp     == ""'"+"'Perl' ''vms_prefix':[utils]dprofpp.c
 $   ENDIF 
 $   WRITE CONFIG "$ h2ph     == ""'"+"'Perl' ''vms_prefix':[utils]h2ph.com"""
 $   WRITE CONFIG "$ h2xs     == ""'"+"'Perl' ''vms_prefix':[utils]h2xs.com"""
+$   WRITE CONFIG "$ libnetcfg == ""'"+"'Perl' ''vms_prefix':[utils]libnetcfg.com"""
 $   WRITE CONFIG "$!perlcc   == ""'"+"'Perl' ''vms_prefix':[utils]perlcc.com"""
 $   WRITE CONFIG "$ perlivp  == ""'"+"'Perl' ''vms_prefix':[utils]perlivp.com"""
 $   WRITE CONFIG "$ splain   == ""'"+"'Perl' ''vms_prefix':[utils]splain.com"""
+$   WRITE CONFIG "$ xsubpp   == ""'"+"'Perl' ''vms_prefix':[utils]xsubpp.com"""
 $ ELSE
 $   WRITE CONFIG "$ Perldoc  == ""Perl ''vms_prefix':[lib.pod]Perldoc.com -t"""
 $   WRITE CONFIG "$ pod2text == ""Perl pod2text"""
@@ -6186,9 +6186,11 @@ $     WRITE CONFIG "$ dprofpp     == ""Perl ''vms_prefix':[utils]dprofpp.com"""
 $   ENDIF 
 $   WRITE CONFIG "$ h2ph     == ""Perl ''vms_prefix':[utils]h2ph.com"""
 $   WRITE CONFIG "$ h2xs     == ""Perl ''vms_prefix':[utils]h2xs.com"""
+$   WRITE CONFIG "$ libnetcfg == ""Perl ''vms_prefix':[utils]libnetcfg.com"""
 $   WRITE CONFIG "$!perlcc   == ""Perl ''vms_prefix':[utils]perlcc.com"""
 $   WRITE CONFIG "$ perlivp  == ""Perl ''vms_prefix':[utils]perlivp.com"""
 $   WRITE CONFIG "$ splain   == ""Perl ''vms_prefix':[utils]splain.com"""
+$   WRITE CONFIG "$ xsubpp   == ""Perl ''vms_prefix':[utils]xsubpp.com"""
 $ ENDIF
 $ CLOSE CONFIG
 $!
index 55eef9b..8d6bb3e 100644 (file)
@@ -46,7 +46,7 @@ repair()
      -e 's=cwd=Cwd=' \
      -e 's=perlio/via=PerlIO/Via=' \
      -e 's=xs/typemap=XS/Typemap=' \
-     -e 's=unicode/normalize=Unicode/Normalize=' \
+     -e 's=unicode/normalize?=Unicode/Normalize=' \
      -e 's=i18n/langinfo=I18N/Langinfo='
 }
 static_ext=$(repair "$static_ext")
index e7d41d7..4d73cd1 100644 (file)
@@ -27,7 +27,7 @@ goto end
 
 :shell_ok
 sh -c 'if test ! -d /tmp; then mkdir /tmp; fi'
-cp djgpp.c config.over ..
+cp djgpp.[hc] config.over ..
 cd ..
 echo Running sed...
 sh djgpp/djgppsed.sh
index 73573c3..0e465b0 100644 (file)
@@ -1,20 +1,5 @@
 #define PERLIO_NOT_STDIO 0
-#include <libc/stubs.h>
-#include <io.h>
-#include <errno.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <unistd.h>
-#include <libc/file.h>
-#include <process.h>
-#include <fcntl.h>
-#include <glob.h>
-#include <sys/fsext.h>
-#include <crt0.h>
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
+#include "djgpp.h"
 
 /* hold file pointer, command, mode, and the status of the command */
 struct pipe_list {
@@ -400,7 +385,8 @@ static char *perlprefix;
 
 #define PERL5 "/perl5"
 
-char *djgpp_pathexp (const char *p)
+char *
+djgpp_pathexp (const char *p)
 {
     static char expp[PATH_MAX];
     strcpy (expp,perlprefix);
diff --git a/djgpp/djgpp.h b/djgpp/djgpp.h
new file mode 100644 (file)
index 0000000..a020ae9
--- /dev/null
@@ -0,0 +1,55 @@
+#ifndef PERL_DJGPP_DJGPP_H
+#define PERL_DJGPP_DJGPP_H
+
+#include <libc/stubs.h>
+#include <io.h>
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+#include <libc/file.h>
+#include <process.h>
+#include <fcntl.h>
+#include <glob.h>
+#include <sys/fsext.h>
+#include <crt0.h>
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+FILE *
+djgpp_popen (const char *cm, const char *md);
+
+int
+djgpp_pclose (FILE *pp);
+
+int
+do_aspawn (pTHX_ SV *really,SV **mark,SV **sp);
+
+int
+do_spawn2 (pTHX_ char *cmd,int execf);
+
+int
+do_spawn (pTHX_ char *cmd);
+
+bool
+Perl_do_exec (pTHX_ char *cmd);
+
+void
+Perl_init_os_extras(pTHX);
+
+char
+*djgpp_pathexp (const char *p);
+
+void
+Perl_DJGPP_init (int *argcp,char ***argvp);
+
+int
+djgpp_fflush (FILE *fp);
+
+/* DJGPP utility functions without prototypes? */
+
+int _is_unixy_shell(char *s);
+
+#endif
index bb35eb0..fb140a3 100644 (file)
@@ -17,7 +17,7 @@ SCOR='s=c\\\.c|=c\_c|=g'
 SHSED='s=\.\(hsed\)=_\1=g'
 SDEPTMP='s=\.\(deptmp\)=_\1=g'
 SCPP='s=\.\(cpp\.\)=_\1=g'
-SARGV='s=\.\(argv\)\.=_\1_=g'
+SARGV='s=Io_argv\(.\)\.=i\1_=g'
 SABC='s=\.\([abc][^a]\)=_\1=g'
 SDBMX='s=\.\(dbmx\)=_\1=g'
 SDBHASH='s=dbhash\.tmp=dbhash_tmp=g'
diff --git a/doio.c b/doio.c
index 27582d9..abf9ae5 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -691,11 +691,11 @@ Perl_nextargv(pTHX_ register GV *gv)
                        sv_catpv(sv,PL_inplace);
                    }
 #ifndef FLEXFILENAMES
-                   if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
-                     && PL_statbuf.st_dev == filedev
-                     && PL_statbuf.st_ino == fileino
+                   if ((PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
+                        && PL_statbuf.st_dev == filedev
+                        && PL_statbuf.st_ino == fileino)
 #ifdef DJGPP
-                      || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
+                       || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
 #endif
                       )
                    {
diff --git a/doop.c b/doop.c
index 8600b7c..bc77201 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -599,9 +599,12 @@ Perl_do_trans(pTHX_ SV *sv)
     I32 hasutf = (PL_op->op_private &
                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 
-    if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
-       Perl_croak(aTHX_ PL_no_modify);
-
+    if (SvREADONLY(sv)) {
+        if (SvFAKE(sv))
+            sv_force_normal(sv);
+        if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     (void)SvPV(sv, len);
     if (!len)
        return 0;
diff --git a/embed.h b/embed.h
index ca01a8d..3a82bc7 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define setenv_getix           Perl_setenv_getix
 #endif
 #define setdefout              Perl_setdefout
-#define sharepvn               Perl_sharepvn
 #define share_hek              Perl_share_hek
 #define sighandler             Perl_sighandler
 #define stack_grow             Perl_stack_grow
 #define setenv_getix(a)                Perl_setenv_getix(aTHX_ a)
 #endif
 #define setdefout(a)           Perl_setdefout(aTHX_ a)
-#define sharepvn(a,b,c)                Perl_sharepvn(aTHX_ a,b,c)
 #define share_hek(a,b,c)       Perl_share_hek(aTHX_ a,b,c)
 #define sighandler             Perl_sighandler
 #define stack_grow(a,b,c)      Perl_stack_grow(aTHX_ a,b,c)
index 5e9a8b2..629772a 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1714,7 +1714,6 @@ Ap        |char*  |screaminstr    |SV* bigsv|SV* littlesv|I32 start_shift \
 p      |I32    |setenv_getix   |char* nam
 #endif
 p      |void   |setdefout      |GV* gv
-Ap     |char*  |sharepvn       |const char* sv|I32 len|U32 hash
 p      |HEK*   |share_hek      |const char* sv|I32 len|U32 hash
 np     |Signal_t |sighandler   |int sig
 Ap     |SV**   |stack_grow     |SV** sp|SV**p|int n
diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes
new file mode 100755 (executable)
index 0000000..d29cc71
--- /dev/null
@@ -0,0 +1,18 @@
+
+2.002 - 2nd December 2001
+
+    * More portability issues in Makefile.PL addresed.
+    * Merged the Harness sub-module into Devel::PPPort
+    * More documentation in PPPort.pm
+
+2.001
+
+    * Some portability issues in Makefile.PL addresed.
+
+2.000
+
+    * Initial port to the perl core.
+
+1.007
+
+    * Original version of the module by Kenneth Albanowski.
index df9710c..ce524bc 100644 (file)
@@ -1,12 +1,11 @@
-PPPort.pm
+Changes
 MANIFEST
 Makefile.PL
+PPPort.pm
+PPPort.xs
 README
-soak
 TODO
-harness/Harness.pm
-harness/Harness.xs
-harness/module2.c
-harness/module3.c
-harness/Makefile.PL
-harness/t/test.t
+module2.c
+module3.c
+soak
+t/test.t
index f67a1f0..cd1217e 100644 (file)
@@ -2,11 +2,30 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-       NAME => "Devel::PPPort",
-       DISTNAME => "Devel-PPPort",
-       VERSION_FROM => 'PPPort.pm',
-       
-       #PM => {'PPPort.pm' => '$(INST_LIBDIR)/PPPort.pm'}, 
-       XSPROTOARG => '-noprototypes',
-       'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" }
+    NAME       => "Devel::PPPort",
+    DISTNAME   => "Devel-PPPort",
+    VERSION_FROM=> 'PPPort.pm',
+
+    #PM                => {'PPPort.pm' => '$(INST_LIBDIR)/PPPort.pm'}, 
+    OBJECT     => 'PPPort$(OBJ_EXT) module2$(OBJ_EXT) module3$(OBJ_EXT)',
+    XSPROTOARG => '-noprototypes',
+    'dist'     => { COMPRESS=>"gzip", SUFFIX=>"gz" },
+    'clean'    => { FILES => 'ppport.h'},
 );
+
+sub MY::postamble {
+
+    my $pmfile = 'PPPort.pm' ;
+
+    my $retval = <<"EOM";
+
+ppport.h:      $pmfile
+       \$(PERL) "-I\$(PERL_ARCHLIB)" "-I\$(PERL_LIB)"  -e "require qq{$pmfile}; package Devel::PPPort ; sub bootstrap {} ; WriteFile(qq{ppport.h})"     
+
+PPPort.xs module2.c module3.c : ppport.h
+       \$(TOUCH) \$@
+
+EOM
+    return $retval;
+}
index 5bcabdd..eef2512 100644 (file)
@@ -12,12 +12,36 @@ Perl/Pollution/Portability
 
 =head1 DESCRIPTION
 
-This modules contains a single function, called C<WriteFile>. It is
-used to write a 'C' header file that is used when writing XS modules. The
-file contains a series of macros that allow XS modules to be built using
-older versions of Perl.
-
-This module is primarily used by h2xs to write the file F<ppport.h>. 
+Perl has changed over time, gaining new features, new functions,
+increasing its flexibility, and reducing the impact on the C namespace
+environment (reduced pollution). The header file, typicaly C<ppport.h>,
+written by this module attempts to bring some of the newer Perl
+features to older versions of Perl, so that you can worry less about
+keeping track of old releases, but users can still reap the benefit.
+Why you should use C<ppport.h> in modern code: so that your code will work
+with the widest range of Perl interpreters possible, without significant
+additional work.
+
+Why you should attempt older code to fully use C<ppport.h>: because
+the reduced pollution of newer Perl versions is an important thing, so
+important that the old polluting ways of original Perl modules will not be
+supported very far into the future, and your module will almost certainly
+break! By adapting to it now, you'll gained compatibility and a sense of
+having done the electronic ecology some good.
+
+How to use ppport.h: Don't direct the user to download C<Devel::PPPort>,
+and don't make C<ppport.h> optional. Rather, just take the most recent
+copy of C<ppport.h> that you can find (probably in C<Devel::PPPort>
+on CPAN), copy it into your project, adjust your project to use it,
+and distribute the header along with your module.
+
+C<Devel::PPPort> contains a single function, called C<WriteFile>. It's
+purpose is to write a 'C' header file that is used when writing XS
+modules. The file contains a series of macros that allow XS modules to
+be built using older versions of Perl.
+
+This module is used by h2xs to write the file F<ppport.h>. 
 
 =head2 WriteFile
 
@@ -28,6 +52,61 @@ parameters, it defults to the filename C<./pport.h>.
 The function returns TRUE if the file was written successfully. Otherwise
 it returns FALSE.
 
+=head1 ppport.h
+
+The file written by this module, typically C<ppport.h>, provides access
+to the following Perl API if not already available:
+
+    DEFSV
+    ERRSV
+    INT2PTR(any,d)
+    MY_CXT
+    MY_CXT_INIT
+    NOOP
+    PERL_REVISION
+    PERL_SUBVERSION
+    PERL_UNUSED_DECL
+    PERL_VERSION
+    PL_Sv
+    PL_compiling
+    PL_copline
+    PL_curcop
+    PL_curstash
+    PL_defgv
+    PL_dirty
+    PL_hints
+    PL_na
+    PL_perldb
+    PL_rsfp_filters
+    PL_rsfpv
+    PL_stdingv
+    PL_sv_no
+    PL_sv_undef
+    PL_sv_yes
+    PTR2IV(d)
+    SAVE_DEFSV
+    START_MY_CXT
+    _aMY_CXT
+    _pMY_CXT
+    aMY_CXT
+    aMY_CXT_
+    aTHX
+    aTHX_
+    boolSV(b)
+    dMY_CXT    
+    dMY_CXT_SV
+    dNOOP
+    dTHR
+    gv_stashpvn(str,len,flags)
+    newCONSTSUB(stash,name,sv)
+    newRV_inc(sv)
+    newRV_noinc(sv)
+    newSVpvn(data,len)
+    pMY_CXT
+    pMY_CXT_
+    pTHX
+    pTHX_
+
 =head1 AUTHOR
 
 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
@@ -40,11 +119,25 @@ See L<h2xs>.
 
 =cut
 
+
+package Devel::PPPort;
+
+require Exporter;
+require DynaLoader;
 #use warnings;
 use strict;
-use vars qw( $VERSION $data );
+use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
+
+$VERSION = "2.0002";
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT =  qw();
+# Other items we are prepared to export if requested
+@EXPORT_OK = qw( );
 
-$VERSION = "2.0001";
+bootstrap Devel::PPPort;
+
+package Devel::PPPort;
 
 {
     local $/ = undef;
@@ -70,64 +163,84 @@ sub WriteFile
 1;
 
 __DATA__;
-/* Perl/Pollution/Portability Version __VERSION__ */
-
-/* Automatically Created by __PKG__ on __DATE__ */
-
-/* Do NOT edit this file directly! -- edit PPPort.pm instead. */
-
-
-#ifndef _P_P_PORTABILITY_H_
-#define _P_P_PORTABILITY_H_
-
-/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
-   distributed under the same license as any version of Perl. */
-   
-/* For the latest version of this code, please retreive the Devel::PPPort
-   module from CPAN, contact the author at <kjahds@kjahds.com>, or check
-   with the Perl maintainers. */
-   
-/* If you needed to customize this file for your project, please mention
-   your changes, and visible alter the version number. */
 
+/* ppport.h -- Perl/Pollution/Portability Version __VERSION__ 
+ *
+ * Automatically Created by __PKG__ on __DATE__ 
+ *
+ * Do NOT edit this file directly! -- Edit PPPort.pm instead.
+ *
+ * Version 2.x, Copyright (C) 2001, Paul Marquess.
+ * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+ * This code may be used and distributed under the same license as any
+ * version of Perl.
+ * 
+ * This version of ppport.h is designed to support operation with Perl
+ * installations back to 5.004, and has been tested up to 5.8.0.
+ *
+ * If this version of ppport.h is failing during the compilation of this
+ * module, please check if a newer version of Devel::PPPort is available
+ * on CPAN before sending a bug report.
+ *
+ * If you are using the latest version of Devel::PPPort and it is failing
+ * during compilation of this module, please send a report to perlbug@perl.com
+ *
+ * Include all following information:
+ *
+ *  1. The complete output from running "perl -V"
+ *
+ *  2. This file.
+ *
+ *  3. The name & version of the module you were trying to build.
+ *
+ *  4. A full log of the build that failed.
+ *
+ *  5. Any other information that you think could be relevant.
+ *
+ *
+ * For the latest version of this code, please retreive the Devel::PPPort
+ * module from CPAN.
+ * 
+ */
 
 /*
-   In order for a Perl extension module to be as portable as possible
-   across differing versions of Perl itself, certain steps need to be taken.
-   Including this header is the first major one, then using dTHR is all the
-   appropriate places and using a PL_ prefix to refer to global Perl
-   variables is the second.
-*/
+ * In order for a Perl extension module to be as portable as possible
+ * across differing versions of Perl itself, certain steps need to be taken.
+ * Including this header is the first major one, then using dTHR is all the
+ * appropriate places and using a PL_ prefix to refer to global Perl
+ * variables is the second.
+ *
+ */
 
 
 /* If you use one of a few functions that were not present in earlier
  versions of Perl, please add a define before the inclusion of ppport.h
  for a static include, or use the GLOBAL request in a single module to
  produce a global definition that can be referenced from the other
  modules.
-   
  Function:            Static define:           Extern define:
  newCONSTSUB()        NEED_newCONSTSUB         NEED_newCONSTSUB_GLOBAL
-
-*/
* versions of Perl, please add a define before the inclusion of ppport.h
* for a static include, or use the GLOBAL request in a single module to
* produce a global definition that can be referenced from the other
* modules.
+ * 
* Function:            Static define:           Extern define:
* newCONSTSUB()        NEED_newCONSTSUB         NEED_newCONSTSUB_GLOBAL
+ *
+ */
  
 
 /* To verify whether ppport.h is needed for your module, and whether any
  special defines should be used, ppport.h can be run through Perl to check
  your source code. Simply say:
-   
      perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
-   
  The result will be a list of patches suggesting changes that should at
  least be acceptable, if not necessarily the most efficient solution, or a
  fix for all possible problems. It won't catch where dTHR is needed, and
  doesn't attempt to account for global macro or function definitions,
  nested includes, typemaps, etc.
-   
  In order to test for the need of dTHR, please try your module under a
  recent version of Perl that has threading compiled-in.
-*/ 
* special defines should be used, ppport.h can be run through Perl to check
* your source code. Simply say:
+ * 
*     perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
+ * 
* The result will be a list of patches suggesting changes that should at
* least be acceptable, if not necessarily the most efficient solution, or a
* fix for all possible problems. It won't catch where dTHR is needed, and
* doesn't attempt to account for global macro or function definitions,
* nested includes, typemaps, etc.
+ * 
* In order to test for the need of dTHR, please try your module under a
* recent version of Perl that has threading compiled-in.
+ *
+ */ 
 
 
 /*
@@ -217,6 +330,9 @@ foreach $filename (map(glob($_),@ARGV)) {
 __DATA__
 */
 
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
 #ifndef PERL_REVISION
 #   ifndef __PATCHLEVEL_H_INCLUDED__
 #       include "patchlevel.h"
@@ -233,6 +349,13 @@ __DATA__
 
 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
 
+/* It is very unlikely that anyone will try to use this with Perl 6 
+   (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+#      error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
 #ifndef ERRSV
 #      define ERRSV perl_get_sv("@",FALSE)
 #endif
@@ -388,6 +511,19 @@ SV *sv;
 
 #endif /* newCONSTSUB */
 
+#ifndef NOOP
+#  define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+#  define PERL_UNUSED_DECL __attribute__((unused))
+#else
+#  define PERL_UNUSED_DECL
+#endif    
+
+#ifndef dNOOP
+#  define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
 
 #ifndef START_MY_CXT
 
@@ -418,8 +554,7 @@ SV *sv;
  * case below uses it to declare the data as static. */
 #define START_MY_CXT
 
-#if PERL_REVISION == 5 && \
-    (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
 /* Fetches the SV that keeps the per-interpreter data. */
 #define dMY_CXT_SV \
        SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
@@ -460,19 +595,6 @@ SV *sv;
 
 #else /* single interpreter */
 
-#ifndef NOOP
-#  define NOOP (void)0
-#endif
-
-#ifdef HASATTRIBUTE
-#  define PERL_UNUSED_DECL __attribute__((unused))
-#else
-#  define PERL_UNUSED_DECL
-#endif    
-
-#ifndef dNOOP
-#  define dNOOP extern int Perl___notused PERL_UNUSED_DECL
-#endif
 
 #define START_MY_CXT   static my_cxt_t my_cxt;
 #define dMY_CXT_SV     dNOOP
@@ -491,5 +613,6 @@ SV *sv;
 
 #endif /* START_MY_CXT */
 
-
 #endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
similarity index 88%
rename from ext/Devel/PPPort/harness/Harness.xs
rename to ext/Devel/PPPort/PPPort.xs
index 683475a..b50dab7 100644 (file)
@@ -8,7 +8,7 @@
 
 /* Global Data */
  
-#define MY_CXT_KEY "Devel::PPPort::Harness::_guts" XS_VERSION
+#define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION
  
 typedef struct {
     /* Put Global Data in here */
@@ -19,13 +19,13 @@ START_MY_CXT
 
 void test1(void)
 {
-       newCONSTSUB(gv_stashpv("Devel::PPPort::Harness", FALSE), "test_value_1", newSViv(1));
+       newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
 }
 
 extern void test2(void);
 extern void test3(void);
 
-MODULE = Devel::PPPort::Harness                PACKAGE = Devel::PPPort::Harness
+MODULE = Devel::PPPort         PACKAGE = Devel::PPPort
 
 BOOT:
 {
index 3828773..dc8cb2f 100644 (file)
@@ -1,44 +1,14 @@
 
  Perl/Pollution/Portability Version 1.0005
 
- Copyright (C) 1999, Kenneth Albanowski. This archive may be used and
- distributed under the same license as any version of Perl.
+ Copyright (C) 2001, Paul Marquess. 
+ Copyright (C) 1999, Kenneth Albanowski. 
+ This archive may be used and distributed under the same license as any
+ version of Perl.
 
- This is not an actual Perl module, but rather a distribution containing a
- small header file designed to aid the portability of the XS modules you
- write. The Makefile.PL is provided primarily to aid in testing the code. 
- (Please notify me about any compile warnings or errors, or test failures.)
- Perl has changed over time, gaining new features, new functions, increasing
- its flexibility, and reducing the impact on the C namespace environment
- (reduced pollution). This header attempts to bring some of the newer Perl
- features to older versions of Perl, so that you can worry less about
- keeping track of old releases, but users can still reap the benefit.
- Why you should use ppport.h in modern code: so that your code will work
- with the widest range of Perl interpreters possible, without significant
- additional work.
- Why you should attempt older code to fully use ppport.h: because the
- reduced pollution of newer Perl versions is an important thing, so
- important that the old polluting ways of original Perl modules will not be
- supported very far into the future, and your module will almost certainly
- break! By adapting to it now, you'll gained compatibility and a sense of
- having done the electronic ecology some good.
+This module is used to create a 'C' header file that can be used by XS
+authors. It allows XS module authors to use the latest version of the
+Perl API, but still allow their module to be built with older versions
+of Perl.
 
- How to use ppport.h: Don't direct the user to download Devel::PPPort, and
- don't make ppport.h optional. Rather, just take the most recent copy of
- ppport.h that you can find (probably in Devel::PPPort on CPAN), copy it
- into your project, adjust your project to use it, and distribute the header
- along with your module.
-
- The file may be able to help you make use of itself. It's got some internal
- documentation, and even an automated script to determine how it could be
- used. However, ppport.h is a work in progress, and may not include every
- feature or macro definition. Feel free to add missing parts, just make sure
- to adjust the version mark so that its clear you've branched from the
- original version.
-       - Kenneth Albanowski <kjahds@kjahds.com>,
-         February, 1999
+For more details see PPPort.pm.
diff --git a/ext/Devel/PPPort/harness/Harness.pm b/ext/Devel/PPPort/harness/Harness.pm
deleted file mode 100644 (file)
index 365fdfe..0000000
+++ /dev/null
@@ -1,21 +0,0 @@
-
-package Devel::PPPort::Harness;
-
-require Exporter;
-require DynaLoader;
-use Carp;
-use strict;
-use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
-
-$VERSION = "2.0000";
-
-@ISA = qw(Exporter DynaLoader);
-@EXPORT =  qw();
-# Other items we are prepared to export if requested
-@EXPORT_OK = qw( );
-
-bootstrap Devel::PPPort::Harness;
-
-package Devel::PPPort::Harness;
-
-1;
diff --git a/ext/Devel/PPPort/harness/Makefile.PL b/ext/Devel/PPPort/harness/Makefile.PL
deleted file mode 100644 (file)
index 8b23eb5..0000000
+++ /dev/null
@@ -1,36 +0,0 @@
-
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
-    NAME       => "Devel::PPPort::Harness",
-    VERSION_FROM=> 'Harness.pm',
-    XSPROTOARG => '-noprototypes',
-    OBJECT     => 'Harness$(OBJ_EXT) module2$(OBJ_EXT) module3$(OBJ_EXT)',
-    'dist'     => { COMPRESS=>"gzip", SUFFIX=>"gz" },
-    'clean'    => { FILES => 'ppport.h'},
-
-);
-
-sub MY::postamble {
-
-    my $pmfile;
-
-    if ($^O eq 'VMS') {
-        $pmfile = '[-]PPPort.pm';
-    }
-    else {
-        $pmfile = '../PPPort.pm';
-    }
-
-  my $retval = <<"EOM";
-
-ppport.h:      $pmfile
-       \$(PERL) "-I\$(PERL_ARCHLIB)" "-I\$(PERL_LIB)" -e "require qq{$pmfile}; Devel::PPPort::WriteFile(qq{ppport.h})"     
-
-Harness.xs module2.c module3.c : ppport.h
-       \$(TOUCH) \$@
-
-EOM
-  return $retval;
-}
diff --git a/ext/Devel/PPPort/harness/t/test.t b/ext/Devel/PPPort/harness/t/test.t
deleted file mode 100644 (file)
index 315e611..0000000
+++ /dev/null
@@ -1,99 +0,0 @@
-
-use Devel::PPPort::Harness;
-
-use strict;
-
-print "1..17\n";
-
-BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib' if -d '../lib';
-
-}
-
-my $total = 0;
-my $good = 0;
-
-my $test = 0;   
-sub ok {
-    my ($name, $test_sub) = @_;
-    my $line = (caller)[2];
-    my $value;
-
-    eval { $value = &{ $test_sub }() } ;
-
-    ++ $test ;
-
-    if ($@) {
-        printf "not ok $test # Testing '$name', line $line $@\n";
-    }
-    elsif ($value != 1){
-        printf "not ok $test # Testing '$name', line $line, value != 1 ($value)\n";
-    }
-    else {
-        print "ok $test\n";
-    }
-
-} 
-
-ok "Static newCONSTSUB()", 
-   sub { Devel::PPPort::Harness::test1(); Devel::PPPort::Harness::test_value_1() == 1} ;
-
-ok "Global newCONSTSUB()", 
-   sub { Devel::PPPort::Harness::test2(); Devel::PPPort::Harness::test_value_2() == 2} ;
-
-ok "Extern newCONSTSUB()", 
-   sub { Devel::PPPort::Harness::test3(); Devel::PPPort::Harness::test_value_3() == 3} ;
-
-ok "newRV_inc()", sub { Devel::PPPort::Harness::test4()} ;
-
-ok "newRV_noinc()", sub { Devel::PPPort::Harness::test5()} ;
-
-ok "PL_sv_undef", sub { not defined Devel::PPPort::Harness::test6()} ;
-
-ok "PL_sv_yes", sub { Devel::PPPort::Harness::test7()} ;
-
-ok "PL_sv_no", sub { !Devel::PPPort::Harness::test8()} ;
-
-ok "PL_na", sub { Devel::PPPort::Harness::test9("abcd") == 4} ;
-
-ok "boolSV 1", sub { Devel::PPPort::Harness::test10(1) } ;
-
-ok "boolSV 0", sub { ! Devel::PPPort::Harness::test10(0) } ;
-
-ok "newSVpvn", sub { Devel::PPPort::Harness::test11("abcde", 3) eq "abc" } ;
-
-ok "DEFSV", sub { $_ = "Fred"; Devel::PPPort::Harness::test12() eq "Fred" } ;
-
-ok "ERRSV", sub { eval { 1; }; ! Devel::PPPort::Harness::test13() };
-
-ok "ERRSV", sub { eval { fred() }; Devel::PPPort::Harness::test13() };
-
-ok "CXT 1", sub { Devel::PPPort::Harness::test14()} ;
-
-ok "CXT 2", sub { Devel::PPPort::Harness::test15()} ;
-
-__END__
-# TODO
-
-PERL_VERSION
-PERL_BCDVERSION
-
-PL_stdingv
-PL_hints
-PL_curcop
-PL_curstash
-PL_copline
-PL_Sv
-PL_compiling
-PL_dirty
-
-PTR2IV
-INT2PTR
-
-dTHR
-gv_stashpvn
-NOOP
-SAVE_DEFSV
-PERL_UNUSED_DECL
-dNOOP
similarity index 60%
rename from ext/Devel/PPPort/harness/module2.c
rename to ext/Devel/PPPort/module2.c
index c1907ba..b0778a7 100644 (file)
@@ -8,5 +8,5 @@
 
 void test2(void)
 {
-       newCONSTSUB(gv_stashpv("Devel::PPPort::Harness", FALSE), "test_value_2", newSViv(2));
+       newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_2", newSViv(2));
 }
similarity index 53%
rename from ext/Devel/PPPort/harness/module3.c
rename to ext/Devel/PPPort/module3.c
index ae0be83..bf8fad5 100644 (file)
@@ -7,5 +7,5 @@
 
 void test3(void)
 {
-       newCONSTSUB(gv_stashpv("Devel::PPPort::Harness", FALSE), "test_value_3", newSViv(3));
+       newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_3", newSViv(3));
 }
index 35afd32..5ff5b41 100644 (file)
@@ -1,56 +1,41 @@
 
+# soak: Test Devel::PPPort with multiple versions of Perl.
+#
+# Author:      Paul Marquess
+#
+
+require 5.006001;
 
 use strict ;
+use warnings ;
 use ExtUtils::MakeMaker;
+use Getopt::Long;
+
+my $VERSION = "1.000";
 
 $| = 1 ;
 my $verbose = 0 ;
 
-# TODO -- Get MM->new to output less MakeMaker progress guff
-my $mm = MM->new( { NAME => 'dummy' });
-
 # TODO -- determine what "make" program to run.
 my $MAKE = 'make';
 
+my $result = GetOptions(
+       "verbose"       => \$verbose,
+       "make=s"        => \$MAKE,
+       ) or Usage();
 
-# TODO -- need to decide how far back we go.
+my @GoodPerls = ();
 
-# find all version of Perl that are available
-my @PerlBinaries = qw( 
-       5.004        
-       5.00401      
-       5.00402      
-       5.00403      
-       5.00404      
-       5.00405      
-       5.005                         
-       5.00501                       
-       5.00502      
-       5.00503                     
-       5.6.0        
-       5.6.1 
-       5.7.0
-       5.7.1
-       5.7.2      
-       );
+if (@ARGV)
+  { @GoodPerls = @ARGV }
+else 
+  { @GoodPerls = FindPerls() }
 
-print "Searching for Perl binaries...\n" ;
-my @GoodPerls = ();
 my $maxlen = 0;
-my @path = $mm->path();
-foreach my $perl (@PerlBinaries) {
-    # TODO -- find_perl will send a warning to STDOUT if it can't find 
-    #         the requested perl, so need to temporarily close STDOUT.
-
-    if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) {
-        push @GoodPerls, $abs ;
-        $maxlen = length $abs
-             if length $abs > $maxlen ;
-    }
+foreach (@GoodPerls) {
+    $maxlen = length $_
+        if length $_ > $maxlen ;
 }
-print "\n\nFound ";
-foreach (@GoodPerls) { print "$_\n" }
-print "\n\n";
 $maxlen += 3 ;
 
 # run each through the test harness
@@ -83,7 +68,7 @@ foreach my $perl (@GoodPerls)
 
 }
 
-print "\n\nPassed with $good of $total versions of Perl.\n";
+print "\n\nPassed with $good of $total versions of Perl.\n\n";
 exit $bad ;
 
 
@@ -93,17 +78,102 @@ sub runit
 
     my $cmd = shift ;
     print "\n    Running [$cmd]\n" if $verbose ;
-    my $file = "/tmp/abc.$$" ;
-    unlink $file ;
     my $output = `$cmd 2>&1` ;
+    $output = "\n" unless defined $output;
     $output =~ s/^/      /gm;
-    print "    Output\n$output\n" if $verbose || $? ;
+    print "\n    Output\n$output\n" if $verbose || $? ;
     if ($?)
     {
-        return 0 unless $verbose ;
-        warn "    $cmd failed: $?\n" ;
-        exit ;
+        warn "    Running '$cmd' failed: $?\n" ;
+        return 0 ;
     }
-    unlink $file ;
     return 1 ;
 }                   
+
+sub Usage
+{
+    die <<EOM;
+
+usage: soak [OPT] [perl...]
+
+  OPT
+    -m make    - the name of the make program. Default "make"
+    -v         - verbose
+
+EOM
+
+}
+
+sub FindPerls
+{
+    # TODO -- need to decide how far back we go.
+    # TODO -- get list of user releases prior to 5.004
+
+    # find all version of Perl that are available
+    my @PerlBinaries = qw( 
+       5.000        
+       5.001        
+       5.002        
+       5.003        
+       5.004        
+       5.00401      
+       5.00402      
+       5.00403      
+       5.00404      
+       5.00405      
+       5.005                         
+       5.00501                       
+       5.00502      
+       5.00503                     
+       5.6.0        
+       5.6.1 
+       5.7.0
+       5.7.1
+       5.7.2      
+       );
+
+    print "Searching for Perl binaries...\n" ;
+    my @GoodPerls = ();
+    my $maxlen = 0;
+    my $mm = MM->new( { NAME => 'dummy' });
+    my @path = $mm->path();
+
+    # find_perl will send a warning to STDOUT if it can't find 
+    # the requested perl, so need to temporarily silence STDOUT.
+    tie(*STDOUT, 'NoSTDOUT');
+
+    foreach my $perl (@PerlBinaries) {
+        if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) {
+            push @GoodPerls, $abs ;
+        }
+    }
+    untie *STDOUT;
+    
+    print "\n\nFound\n";
+    foreach (@GoodPerls) { print "    $_\n" }
+    print "\n\n";
+
+    return @GoodPerls;
+}
+
+package NoSTDOUT;
+
+use Tie::Handle;
+our @ISA = qw(Tie::Handle);
+
+sub TIEHANDLE 
+{
+    my ($class) = @_;
+    my $buf = "";
+    bless \$buf, $class;
+}
+sub PRINT 
+{
+    my $self = shift;
+}                
+sub WRITE 
+{
+    my $self = shift;
+}                
diff --git a/ext/Devel/PPPort/t/test.t b/ext/Devel/PPPort/t/test.t
new file mode 100644 (file)
index 0000000..bdac50b
--- /dev/null
@@ -0,0 +1,99 @@
+
+use Devel::PPPort;
+
+use strict;
+
+print "1..17\n";
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib';
+
+}
+
+my $total = 0;
+my $good = 0;
+
+my $test = 0;   
+sub ok {
+    my ($name, $test_sub) = @_;
+    my $line = (caller)[2];
+    my $value;
+
+    eval { $value = &{ $test_sub }() } ;
+
+    ++ $test ;
+
+    if ($@) {
+        printf "not ok $test # Testing '$name', line $line $@\n";
+    }
+    elsif ($value != 1){
+        printf "not ok $test # Testing '$name', line $line, value != 1 ($value)\n";
+    }
+    else {
+        print "ok $test\n";
+    }
+
+} 
+
+ok "Static newCONSTSUB()", 
+   sub { Devel::PPPort::test1(); Devel::PPPort::test_value_1() == 1} ;
+
+ok "Global newCONSTSUB()", 
+   sub { Devel::PPPort::test2(); Devel::PPPort::test_value_2() == 2} ;
+
+ok "Extern newCONSTSUB()", 
+   sub { Devel::PPPort::test3(); Devel::PPPort::test_value_3() == 3} ;
+
+ok "newRV_inc()", sub { Devel::PPPort::test4()} ;
+
+ok "newRV_noinc()", sub { Devel::PPPort::test5()} ;
+
+ok "PL_sv_undef", sub { not defined Devel::PPPort::test6()} ;
+
+ok "PL_sv_yes", sub { Devel::PPPort::test7()} ;
+
+ok "PL_sv_no", sub { !Devel::PPPort::test8()} ;
+
+ok "PL_na", sub { Devel::PPPort::test9("abcd") == 4} ;
+
+ok "boolSV 1", sub { Devel::PPPort::test10(1) } ;
+
+ok "boolSV 0", sub { ! Devel::PPPort::test10(0) } ;
+
+ok "newSVpvn", sub { Devel::PPPort::test11("abcde", 3) eq "abc" } ;
+
+ok "DEFSV", sub { $_ = "Fred"; Devel::PPPort::test12() eq "Fred" } ;
+
+ok "ERRSV", sub { eval { 1; }; ! Devel::PPPort::test13() };
+
+ok "ERRSV", sub { eval { fred() }; Devel::PPPort::test13() };
+
+ok "CXT 1", sub { Devel::PPPort::test14()} ;
+
+ok "CXT 2", sub { Devel::PPPort::test15()} ;
+
+__END__
+# TODO
+
+PERL_VERSION
+PERL_BCDVERSION
+
+PL_stdingv
+PL_hints
+PL_curcop
+PL_curstash
+PL_copline
+PL_Sv
+PL_compiling
+PL_dirty
+
+PTR2IV
+INT2PTR
+
+dTHR
+gv_stashpvn
+NOOP
+SAVE_DEFSV
+PERL_UNUSED_DECL
+dNOOP
index ddde0f2..76257d4 100644 (file)
@@ -700,6 +700,11 @@ Miscellaneous:
 Encodes string from Perl's internal form into I<ENCODING> and returns
 a sequence of octets.  For CHECK see L</"Handling Malformed Data">.
 
+For example to convert (internally UTF-8 encoded) Unicode data
+to octets:
+
+       $octets = encode("utf8", $unicode);
+
 =item *
 
         $string = decode(ENCODING, $bytes[, CHECK])
@@ -708,6 +713,10 @@ Decode sequence of octets assumed to be in I<ENCODING> into Perl's
 internal form and returns the resulting string.  For CHECK see
 L</"Handling Malformed Data">.
 
+For example to convert ISO 8859-1 data to UTF-8:
+
+       $utf8 = decode("latin1", $latin1);
+
 =item *
 
        from_to($string, FROM_ENCODING, TO_ENCODING[, CHECK])
index b2e97f9..2f5172d 100644 (file)
@@ -11,41 +11,43 @@ BEGIN {
        exit 0;
     }
 }
-
-use I18N::Langinfo qw(langinfo ABDAY_1 DAY_1 ABMON_1 MON_1 RADIXCHAR);
+    
+use I18N::Langinfo qw(langinfo);
 use POSIX qw(setlocale LC_ALL);
-use Config;
-
-setlocale(LC_ALL, "C");
-
-print "1..5\n";
-
-print "not " unless langinfo(ABDAY_1)   eq "Sun";
-print "ok 1\n";
-
-print "not " unless langinfo(DAY_1)     eq "Sunday";
-print "ok 2\n";
-
-print "not " unless langinfo(ABMON_1)   eq "Jan";
-print "ok 3\n";
-
-print "not " unless langinfo(MON_1)     eq "January";
-print "ok 4\n";
 
-unless (eval { langinfo(RADIXCHAR) } eq ".") {
-    print "not ok 5 - RADIXCHAR undefined\n";
-    if ($Config{d_gnulibc} || $Config{cppsymbols} =~ /__GNU_LIBRARY_/) {
-       print <<EOM;
-#
-# You are probably using GNU libc. The RADIXCHAR not getting defined
-# by I18N::Langinfo is a known problem in some older versions of the
-# GNU libc (caused by the combination of using only enums, not cpp
-# definitions, and of hiding the definitions behind rather obscure
-# feature tests).  Upgrading your libc is strongly suggested. 
-#
-EOM
+setlocale(LC_ALL, $ENV{LC_ALL} = $ENV{LANG} = "C");
+
+my %want =
+    (
+     ABDAY_1   => "Sun",
+     DAY_1     => "Sunday",
+     ABMON_1   => "Jan",
+     MON_1     => "January",
+     RADIXCHAR => ".",
+     AM_STR    => qr{^(?:am|a\.m\.)$}i,
+     THOUSEP   => "",
+     D_T_FMT   => qr{^%a %b %[de] %H:%M:%S %Y$},
+     D_FMT     => qr{^%m/%d/%y$},
+     T_FMT     => qr{^%H:%M:%S$},
+     );
+
+    
+my @want = sort keys %want;
+
+print "1..", scalar @want, "\n";
+    
+for my $i (1..@want) {
+    my $try = $want[$i-1];
+    eval { I18N::Langinfo->import($try) };
+    unless ($@) {
+       my $got = langinfo(&$try);
+       if (ref $want{$try} && $got =~ $want{$try} || $got eq $want{$try}) {
+           print qq[ok $i - $try is "$got"\n];
+       } else {
+           print qq[not ok $i - $try is "$got" not "$want{$try}"\n];
+       }
+    } else {
+       print qq[ok $i - Skip: $try not defined\n];
     }
-} else {
-    print "ok 5\n";
 }
 
index d335eec..f1a0a17 100644 (file)
@@ -19,8 +19,14 @@ langinfo(code)
        int     code
   CODE:
 #ifdef HAS_NL_LANGINFO
-       char *s = nl_langinfo(code);
-       RETVAL = newSVpvn(s, strlen(s));
+       {
+         char *s;
+
+         if ((s = nl_langinfo(code)))
+             RETVAL = newSVpvn(s, strlen(s));
+         else
+             RETVAL = &PL_sv_undef;
+       }
 #else
        croak("nl_langinfo() not implemented on this architecture");
 #endif
index 93f1d4f..eed19f9 100644 (file)
@@ -8,6 +8,15 @@ WriteMakefile(
 
 package MY;
 
+# We go through the ListUtil.c trickery to foil platforms
+# that have the feature combination of
+# (1) static builds
+# (2) allowing only one object by the same name in the static library
+# (3) the object name matching being case-blind
+# This means that we can't have the top-level util.o
+# and the extension-level Util.o in the same build.
+# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
+
 BEGIN {
     use Config;
     unless (defined $Config{usedl}) {
@@ -16,41 +25,19 @@ sub xs_c {
     my($self) = shift;
     return '' unless $self->needs_linking();
 '
-.xs.c:
-       $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > List$*.xsc && $(MV) List$*.xsc List$*.c
-';
-}
-
-sub c_o {
-    my($self) = shift;
-    return '' unless $self->needs_linking();
-'
-.c$(OBJ_EXT):
-       $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) List$*.c
-       $(MV) List$*$(OBJ_EXT) $*$(OBJ_EXT)
+ListUtil.c:    Util.xs
+       $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > ListUtil.xsc && $(MV) ListUtil.xsc ListUtil.c
 ';
 }
 
-sub xs_o {     # many makes are too dumb to use xs_c then c_o
+sub xs_o {
     my($self) = shift;
     return '' unless $self->needs_linking();
 '
-.xs$(OBJ_EXT):
-       $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > List$*.xsc && $(MV) List$*.xsc List$*.c
-       $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) List$*.c
-       $(MV) List$*$(OBJ_EXT) $*$(OBJ_EXT)
-';
-}
-
-sub top_targets {      # many makes are too dumb to use xs_c then c_o
-    my($self) = shift;
-    my $out = $self->SUPER::top_targets(@_);
-    $out .
-'
-
-ListUtil.c: Util.c
-       @$(NOOP)
 
+Util$(OBJ_EXT):        ListUtil.c
+       $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) ListUtil.c
+       $(MV) ListUtil$(OBJ_EXT) Util$(OBJ_EXT)
 ';
 }
 
index 5a5e220..22ba03f 100644 (file)
@@ -380,7 +380,7 @@ respectfully.
 =item share (NAME, ...)
 
 This shares the variable(s) in the argument list with the compartment.
-This is almost identical to exporting variables using the L<Exporter(3)>
+This is almost identical to exporting variables using the L<Exporter>
 module.
 
 Each NAME must be the B<name> of a variable, typically with the leading
index e1e13e1..4981741 100644 (file)
@@ -560,7 +560,7 @@ BOOT:
 #ifdef HAS_GETTIMEOFDAY
 {
   UV auv[2];
-  hv_store(PL_modglobal, "Time::NVtime", 12, newSViv((IV) myNVtime()), 0);
+  hv_store(PL_modglobal, "Time::NVtime", 12, newSViv(PTR2IV(myNVtime)), 0);
   if (myU2time(auv) == 0)
     hv_store(PL_modglobal, "Time::U2time", 12, newSViv((IV) auv[0]), 0);
 }
index 802dd25..b2a9225 100644 (file)
@@ -174,6 +174,7 @@ Perl_is_uni_xdigit
 Perl_to_uni_upper
 Perl_to_uni_title
 Perl_to_uni_lower
+Perl_to_uni_fold
 Perl_is_uni_alnum_lc
 Perl_is_uni_alnumc_lc
 Perl_is_uni_idfirst_lc
@@ -387,7 +388,6 @@ Perl_scan_hex
 Perl_scan_num
 Perl_scan_oct
 Perl_screaminstr
-Perl_sharepvn
 Perl_stack_grow
 Perl_start_subparse
 Perl_sv_2bool
index 86a375b..01a0d10 100644 (file)
@@ -519,6 +519,9 @@ cat > UU/uselongdouble.cbu <<'EOCBU'
 case "$uselongdouble" in
 "$define"|true|[yY]*)
        if test -f /opt/SUNWspro/lib/libsunmath.so; then
+               # Unfortunately libpth has already been set and
+               # searched, so we need to add in everything manually.
+               libpth="$libpth /opt/SUNWspro/lib"
                libs="$libs -lsunmath"
                ldflags="$ldflags -L/opt/SUNWspro/lib -R/opt/SUNWspro/lib"
                d_sqrtl=define
diff --git a/hints/super-ux.sh b/hints/super-ux.sh
new file mode 100644 (file)
index 0000000..8f9592b
--- /dev/null
@@ -0,0 +1,20 @@
+# Len Makin <len@hpc.CSIRO.AU>
+
+# No dynamically loaded libraries
+so='none'
+
+case "$optimize" in
+# No compile option -O
+'') optimize='-h2' ;;
+esac
+
+# size_t is 32 bits. Next version of compiler will have -hsize_t64
+# enabling size_t to be 64 bits.
+# Current cc version 4.80 allows -hsubscript64 for 64 bit array subscripts.
+ccflags="$ccflags -hxint -hmath vector -hsubscript64"
+
+case "$usemymalloc" in
+'') # The perl malloc.c SHOULD work
+    usemymalloc='y'
+    ;;
+esac
diff --git a/hv.c b/hv.c
index 11992f4..5d7b49f 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1640,12 +1640,16 @@ Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
 }
 
+#if 0 /* use the macro from hv.h instead */
+
 char*  
 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
 {
     return HEK_KEY(share_hek(sv, len, hash));
 }
 
+#endif
+
 /* possibly free a shared string if no one has access to it
  * len and hash must both be valid for str.
  */
diff --git a/hv.h b/hv.h
index 9d6be7f..3475c87 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -197,3 +197,7 @@ C<SV*>.
                         ? (size) * sizeof(HE*)                         \
                         : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD)
 #endif
+
+/* available as a function in hv.c */
+#define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash))
+#define sharepvn(sv, len, hash)             Perl_sharepvn(sv, len, hash)
index 8d764c1..e5466a4 100644 (file)
@@ -7,6 +7,10 @@ my $incdir;
 my $lib = '"-I../lib"'; # ok on unix, nt, The extra \" are for VMS
 BEGIN {
     chdir 't' if -d 't';
+    if ($^O eq 'dos') {
+       print "1..0 # This test is not 8.3-aware.\n";
+           exit 0;
+    }
     if ($^O eq 'MacOS') {
        $incdir = ":auto-$$";
         $lib = '-x -I::lib:'; # -x overcomes MPW $Config{startperl} anomaly
index cd2cfdb..5dbae29 100644 (file)
@@ -1,6 +1,6 @@
 package Carp;
 
-our $VERSION = '1.00';
+our $VERSION = '1.01';
 
 =head1 NAME
 
@@ -13,6 +13,10 @@ croak   - die of errors (from perspective of caller)
 
 confess - die of errors with stack backtrace
 
+shortmess - return the message that carp and croak produce
+
+longmess - return the message that cluck and confess produce
+
 =head1 SYNOPSIS
 
     use Carp;
@@ -27,16 +31,54 @@ confess - die of errors with stack backtrace
 =head1 DESCRIPTION
 
 The Carp routines are useful in your own modules because
-they act like die() or warn(), but report where the error
-was in the code they were called from.  Thus if you have a 
-routine Foo() that has a carp() in it, then the carp() 
-will report the error as occurring where Foo() was called, 
-not where carp() was called.
+they act like die() or warn(), but with a message which is more
+likely to be useful to a user of your module.  In the case of
+cluck, confess, and longmess that context is a summary of every
+call in the call-stack.  For a shorter message you can use carp,
+croak or shortmess which report the error as being from where
+your module was called.  There is no guarantee that that is where
+the error was, but it is a good educated guess.
+
+Here is a more complete description of how shortmess works.  What
+it does is search the call-stack for a function call stack where
+it hasn't been told that there shouldn't be an error.  If every
+call is marked safe, it then gives up and gives a full stack
+backtrace instead.  In other words it presumes that the first likely
+looking potential suspect is guilty.  Its rules for telling whether
+a call shouldn't generate errors work as follows:
+
+=over 4
+
+=item 1.
+
+Any call from a package to itself is safe. 
+
+=item 2.
+
+Packages claim that there won't be errors on calls to or from
+packages explicitly marked as safe by inclusion in @CARP_NOT, or
+(if that array is empty) @ISA.  The ability to override what
+@ISA says is new in 5.8.
+
+=item 3.
 
-The routine shortmess() can be used to generate the string that
-carp/croak would have produced.   The routine longmess() can be
-used to generate the backtrace that cluck/confess would have
-produced.
+The trust in item 2 is transitive.  If A trusts B, and B
+trusts C, then A trusts C.  So if you do not override @ISA
+with @CARP_NOT, then this trust relationship is identical to,
+"inherits from".
+
+=item 4.
+
+Any call from an internal Perl module is safe.  (Nothing keeps
+user modules from marking themselves as internal to Perl, but
+this practice is discouraged.)
+
+=item 5.
+
+Any call to Carp is safe.  (This rule is what keeps it from
+reporting the error where you call carp/croak/shortmess.)
+
+=back
 
 =head2 Forcing a Stack Trace
 
@@ -67,19 +109,25 @@ call die() or warn(), as appropriate.
 # _almost_ complete understanding of the package.  Corrections and
 # comments are welcome.
 
-# The $CarpLevel variable can be set to "strip off" extra caller levels for
-# those times when Carp calls are buried inside other functions.  The
+# The members of %Internal are packages that are internal to perl.
+# Carp will not report errors from within these packages if it
+# can.  The members of %CarpInternal are internal to Perl's warning
+# system.  Carp will not report errors from within these packages
+# either, and will not report calls *to* these packages for carp and
+# croak.  They replace $CarpLevel, which is deprecated.    The
 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
 # text and function arguments should be formatted when printed.
 
+$CarpInternal{Carp}++;
 $CarpLevel = 0;                # How many extra package levels to skip on carp.
+                        # How many calls to skip on confess.
+                        # Reconciling these notions is hard, use
+                        # %Internal and %CarpInternal instead.
 $MaxEvalLen = 0;       # How much eval '...text...' to show. 0 = all.
 $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
 $Verbose = 0;          # If true then make shortmess call longmess instead
 
-$CarpInternal{Carp}++;
-
 require Exporter;
 @ISA = ('Exporter');
 @EXPORT = qw(confess croak carp);
@@ -107,7 +155,15 @@ sub export_fail {
 
 sub longmess {
     { local $@; require Carp::Heavy; } # XXX fix require to not clear $@?
-    goto &longmess_heavy;
+    # Icky backwards compatibility wrapper. :-(
+    my $call_pack = caller();
+    if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
+      return longmess_heavy(@_);
+    }
+    else {
+      local $CarpLevel = $CarpLevel + 1;
+      return longmess_heavy(@_);
+    }
 }
 
 
@@ -119,7 +175,10 @@ sub longmess {
 
 sub shortmess {        # Short-circuit &longmess if called via multiple packages
     { local $@; require Carp::Heavy; } # XXX fix require to not clear $@?
-    goto &shortmess_heavy;
+    # Icky backwards compatibility wrapper. :-(
+    my $call_pack = caller();
+    local @CARP_NOT = caller();
+    shortmess_heavy(@_);
 }
 
 
index 06d57b5..5228b9b 100644 (file)
@@ -28,7 +28,7 @@ sub caller_info {
 
   my $sub_name = Carp::get_subname(\%call_info);
   if ($call_info{has_args}) {
-    my @args = map {Carp::format_arg($_)} @args;
+    my @args = map {Carp::format_arg($_)} @DB::args;
     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
       $#args = $MaxArgNums;
       push @args, '...';
@@ -236,7 +236,10 @@ sub trusts {
 # Takes a package and gives a list of those trusted directly
 sub trusts_directly {
     my $class = shift;
-    return @{"$class\::ISA"};
+    no strict 'refs';
+    return @{"$class\::CARP_NOT"}
+      ? @{"$class\::CARP_NOT"}
+      : @{"$class\::ISA"};
 }
 
 1;
index 0b4548c..d5237a9 100644 (file)
--- a/lib/DB.t
+++ b/lib/DB.t
@@ -1,73 +1,81 @@
-#!./perl
+#!./perl -w
 
 BEGIN {
-       chdir 't' if -d 't';
-       @INC = '../lib';
+        chdir 't' if -d 't';
+        @INC = '../lib';
 }
 
+# symbolic references used later
+use strict qw( vars subs );
+
+# @DB::dbline values have both integer and string components (Benjamin Goldberg)
+use Scalar::Util qw( dualvar );
+my $dualfalse = dualvar(0, 'false');
+my $dualtrue = dualvar(1, 'true');
+
 use Test::More tests => 106;
 
 # must happen at compile time for DB:: package variable localizations to work
 BEGIN {
-       use_ok( 'DB' );
+        use_ok( 'DB' );
 }
 
 # test DB::sub()
 {
-       my $callflag = 0;
-       local $DB::sub = sub {
-               $callflag += shift || 1;
-               my @vals = (1, 4, 9);
-               return @vals;
-       };
-       my $ret = DB::sub;
-       is( $ret, 3, 'DB::sub() should handle scalar context' );
-       is( $callflag, 1, '... should call $DB::sub contents' );
-       $ret = join(' ', DB::sub(2));
-       is( $ret, '1 4 9', '... should handle scalar context' );
-       is( $callflag, 3, '... should pass along arguments to the sub' );
-       ok( defined($DB::ret),'$DB::ret should be defined after successful return');
-       DB::sub;
-       ok( !defined($DB::ret), '... should respect void context' );
-       $DB::sub = '::DESTROY';
-       ok( !defined($DB::ret), '... should return undef for DESTROY()' );
+        my $callflag = 0;
+        local $DB::sub = sub {
+                $callflag += shift || 1;
+                my @vals = (1, 4, 9);
+                return @vals;
+        };
+        my $ret = DB::sub;
+        is( $ret, 3, 'DB::sub() should handle scalar context' );
+        is( $callflag, 1, '... should call $DB::sub contents' );
+        $ret = join(' ', DB::sub(2));
+        is( $ret, '1 4 9', '... should handle scalar context' );
+        is( $callflag, 3, '... should pass along arguments to the sub' );
+        ok( defined($DB::ret),'$DB::ret should be defined after successful return');
+        DB::sub;
+        ok( !defined($DB::ret), '... should respect void context' );
+        $DB::sub = '::DESTROY';
+        ok( !defined($DB::ret), '... should return undef for DESTROY()' );
 }
 
 # test DB::DB()
 { 
-       ok( ! defined DB::DB(), 
-               'DB::DB() should return undef if $DB::ready is false');
-       is( DB::catch(), 1, 'DB::catch() should work' );
-       is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' );
+        ok( ! defined DB::DB(), 
+                'DB::DB() should return undef if $DB::ready is false');
+        is( DB::catch(), 1, 'DB::catch() should work' );
+        is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' );
 
-       # change packages to mess with caller()
-       package foo;
-       ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
+        # change packages to mess with caller()
+        package foo;
+        ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
 
-       package main;
-       is( $DB::filename, $0, '... should set $DB::filename' );
-       is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
+        package main;
+        is( $DB::filename, $0, '... should set $DB::filename' );
+        is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
 
-       DB::DB();
-       # stops at line 94
+        DB::DB();
+        # stops at line 94
 }
 
 # test DB::save()
 {
        no warnings 'uninitialized';
 
-       # assigning a number to $! seems to produce an error message, when read
-       local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
-       DB::save();
-       is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
+        # assigning a number to $! seems to produce an error message, when read
+        local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
+        DB::save();
+        is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
 }
 
 # test DB::catch()
 {
-       local $DB::signal;
-       DB::catch();
-       ok( $DB::signal, 'DB::catch() should set $DB::signal' );
-       # add clients and test to see if they are awakened
+        local $DB::signal;
+        DB::catch();
+        ok( $DB::signal, 'DB::catch() should set $DB::signal' );
+        # add clients and test to see if they are awakened
 }
 
 # test DB::_clientname()
@@ -76,61 +84,61 @@ is( DB::_clientname('bar'), '','DB::_clientname should not return non refname');
 
 # test DB::next() and DB::step()
 {
-       local $DB::single;
-       DB->next();
-       is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
-       DB->step();
-       is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
+        local $DB::single;
+        DB->next();
+        is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
+        DB->step();
+        is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
 }
 
 # test DB::cont()
 {
-       # cannot test @stack
+        # cannot test @stack
 
-       local $DB::single = 1;
-       my $fdb = FakeDB->new();
-       DB::cont($fdb, 2);
-       is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
-       is( $DB::single, 0, '... should set $DB::single to 0' );
+        local $DB::single = 1;
+        my $fdb = FakeDB->new();
+        DB::cont($fdb, 2);
+        is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
+        is( $DB::single, 0, '... should set $DB::single to 0' );
 }
 
 # test DB::ret()
 {
-       # cannot test @stack
+        # cannot test @stack
 
-       local $DB::single = 1;
-       DB::ret();
-       is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
+        local $DB::single = 1;
+        DB::ret();
+        is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
 }
 
 # test DB::backtrace()
 {
-       local (@DB::args, $DB::signal);
-
-       my $line = __LINE__ + 1;
-       my @ret = eval { DB->backtrace() };
-       like( $ret[0], qr/file.+\Q$0\Q/, 'DB::backtrace() should report current file');
-       like( $ret[0], qr/line $line/, '... should report calling line number' );
-       like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
-
-       @ret = eval "one(2)";
-       is( scalar @ret, 1, '... should report from provided stack frame number' );
-       like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
-               '... should find eval STRING construct');
-       $ret[0] = check_context(1);
-       like( $ret[0], qr/\$ = &main::check_context/, 
-               '... should respect context of calling construct');
-       
-       $DB::signal = 1;
-       @DB::args = (1, 7);
-       @ret = three(1);
-       is( scalar @ret, 1, '... should end loop if $DB::signal is true' );
-
-       # does not check 'require' or @DB::args mangling
+        local (@DB::args, $DB::signal);
+
+        my $line = __LINE__ + 1;
+        my @ret = eval { DB->backtrace() };
+        like( $ret[0], qr/file.+\Q$0\E/, 'DB::backtrace() should report current file');
+        like( $ret[0], qr/line $line/, '... should report calling line number' );
+        like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
+
+        @ret = eval "one(2)";
+        is( scalar @ret, 1, '... should report from provided stack frame number' );
+        like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
+                '... should find eval STRING construct');
+        $ret[0] = check_context(1);
+        like( $ret[0], qr/\$ = &main::check_context/, 
+                '... should respect context of calling construct');
+        
+        $DB::signal = 1;
+        @DB::args = (1, 7);
+        @ret = three(1);
+        is( scalar @ret, 1, '... should end loop if $DB::signal is true' );
+
+        # does not check 'require' or @DB::args mangling
 }
 
 sub check_context {
-       return (eval "one($_[0])")[-1];
+        return (eval "one($_[0])")[-1];
 }
 sub one { DB->backtrace(@_) }
 sub two { one(@_) }
@@ -138,330 +146,334 @@ sub three { two(@_) }
 
 # test DB::trace_toggle
 {
-       local $DB::trace = 0;
-       DB->trace_toggle;
-       ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' );
-       DB->trace_toggle;
-       ok( !$DB::trace, '... should toggle $DB::trace (back)' );
+        local $DB::trace = 0;
+        DB->trace_toggle;
+        ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' );
+        DB->trace_toggle;
+        ok( !$DB::trace, '... should toggle $DB::trace (back)' );
 }
 
 # test DB::subs()
 {
-       local %DB::sub;
-       my $subs = DB->subs;
-       is( $subs, 0, 'DB::subs() should return keys of %DB::subs' );
-       %DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' );
-       $subs = DB->subs;
-       is( $subs, 2, '... same song, different key' );
-       my @subs = DB->subs( 'foo', 'boo', 'bar' );
-       is( scalar @subs, 2, '... should report only for requested subs' );
-       my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] );
-       ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' );
+        local %DB::sub;
+        my $subs = DB->subs;
+        is( $subs, 0, 'DB::subs() should return keys of %DB::subs' );
+        %DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' );
+        $subs = DB->subs;
+        is( $subs, 2, '... same song, different key' );
+        my @subs = DB->subs( 'foo', 'boo', 'bar' );
+        is( scalar @subs, 2, '... should report only for requested subs' );
+        my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] );
+        ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' );
 }
 
 # test DB::filesubs()
 {
-       local ($DB::filename, %DB::sub);
-       $DB::filename = 'baz';
-       %DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz );
-       my @ret = DB->filesubs();
-       is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args');
-       @ret = grep { /^baz/ } @ret;    
-       is( scalar @ret, 2, '... should pick up subs in proper file' );
-       @ret = DB->filesubs('boo');
-       is( scalar @ret, 3, '... should use argument to find subs' );
-       @ret = grep { /^boo/ } @ret;    
-       is( scalar @ret, 3, '... should pick up subs in proper file with argument');
+        local ($DB::filename, %DB::sub);
+        $DB::filename = 'baz';
+        %DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz );
+        my @ret = DB->filesubs();
+        is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args');
+        @ret = grep { /^baz/ } @ret;    
+        is( scalar @ret, 2, '... should pick up subs in proper file' );
+        @ret = DB->filesubs('boo');
+        is( scalar @ret, 3, '... should use argument to find subs' );
+        @ret = grep { /^boo/ } @ret;    
+        is( scalar @ret, 3, '... should pick up subs in proper file with argument');
 }
 
 # test DB::files()
 {
-       my $dbf = () = DB::files();
-       my $main = () = grep ( m!^_<!, keys %main:: );
-       is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
+        my $dbf = () = DB::files();
+        my $main = () = grep ( m!^_<!, keys %main:: );
+        is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
 }
 
 # test DB::lines()
 {
-       local @DB::dbline = ( 'foo' );
-       is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
+        local @DB::dbline = ( 'foo' );
+        is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
 }
 
 # test DB::loadfile()
 SKIP: {
-       local (*DB::dbline, $DB::filename);
-       ok( ! defined DB->loadfile('notafile'),
-               'DB::loadfile() should not find unloaded file' );
-       my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0];
-       skip('cannot find loaded file', 3) unless $file;
-       $file =~ s/^_<..//;
-
-       my $db = DB->loadfile($file);
-       like( $db, qr!$file\z!, '... should find loaded file from partial name');
-       is( *DB::dbline, *{ "_<$db" } , 
-               '... should set *DB::dbline to associated glob');
-       is( $DB::filename, $db, '... should set $DB::filename to file name' );
-
-       # test clients
+        local (*DB::dbline, $DB::filename);
+        ok( ! defined DB->loadfile('notafile'),
+                'DB::loadfile() should not find unloaded file' );
+        my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0];
+        skip('cannot find loaded file', 3) unless $file;
+        $file =~ s/^_<..//;
+
+        my $db = DB->loadfile($file);
+        like( $db, qr!$file\z!, '... should find loaded file from partial name');
+
+        is( *DB::dbline, *{ "_<$db" } , 
+                '... should set *DB::dbline to associated glob');
+        is( $DB::filename, $db, '... should set $DB::filename to file name' );
+
+        # test clients
 }
 
 # test DB::lineevents()
 {
-       local $DB::filename = 'baz';
-       local *baz = *{ "main::_<baz" };
-       @baz = ( 1 .. 5 );
-       %baz = (
-               1 => "foo\0bar",
-               3 => "boo\0far",
-               4 => "fazbaz",
-       );
-       my %ret = DB->lineevents();
-       is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' );
-
-       # array access in DB::lineevents() starts at element 1, not 0
-       is( join(' ', @{ $ret{1} }), '2 foo bar', '... should stash data in hash');
+        use vars qw( *baz );
+
+        local $DB::filename = 'baz';
+        local *baz = *{ "main::_<baz" };
+        
+        @baz = map { dualvar(1, $_) } qw( one two three four five );
+        %baz = (
+                1 => "foo\0bar",
+                3 => "boo\0far",
+                4 => "fazbaz",
+        );
+        my %ret = DB->lineevents();
+        is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' );
+
+        # array access in DB::lineevents() starts at element 1, not 0
+        is( join(' ', @{ $ret{1} }), 'two foo bar', '... should stash data in hash');
 }
 
 # test DB::set_break()
 {
-       local ($DB::lineno, *DB::dbline, $DB::package);
-
-       %DB::dbline = (
-               1 => "\0",
-               2 => undef,
-               3 => "123\0\0\0abc",
-               4 => "\0abc",
-       );
-
-       *DB::dbline = [ 0, 1, 0, 0, 1 ];
-
-       local %DB::sub = (
-               'main::foo'     => 'foo:1-4',
-       );
-        
-       DB->set_break(1, 'foo');
-       is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' );
-
-       $DB::lineno = 1;
-       DB->set_break(undef, 'bar');
-       is( $DB::dbline{1}, "bar\0", 
-               '... should use $DB::lineno without specified line' );
-
-       DB->set_break(4);
-       is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed');
-
-       local %DB::sub = (
-               'main::foo'     => 'foo:1-4',
-       );
-       DB->set_break('foo', 'baz');
-       is( $DB::dbline{4}, "baz\0abc", 
-               '... should use _find_subline() to resolve subname' );
-
-       my $db = FakeDB->new();
-       DB::set_break($db, 2);
-       like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
-
-       DB::set_break($db, 'nonfoo');
-       like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
+        local ($DB::lineno, *DB::dbline, $DB::package);
+
+        %DB::dbline = (
+                1 => "\0",
+                2 => undef,
+                3 => "123\0\0\0abc",
+                4 => "\0abc",
+        );
+
+        *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
+
+        local %DB::sub = (
+                'main::foo'     => 'foo:1-4',
+        );
+         
+        DB->set_break(1, 'foo');
+        is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' );
+
+        $DB::lineno = 1;
+        DB->set_break(undef, 'bar');
+        is( $DB::dbline{1}, "bar\0", 
+                '... should use $DB::lineno without specified line' );
+
+        DB->set_break(4);
+        is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed');
+
+        local %DB::sub = (
+                'main::foo'     => 'foo:1-4',
+        );
+        DB->set_break('foo', 'baz');
+        is( $DB::dbline{4}, "baz\0abc", 
+                '... should use _find_subline() to resolve subname' );
+
+        my $db = FakeDB->new();
+        DB::set_break($db, 2);
+        like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
+
+        DB::set_break($db, 'nonfoo');
+        like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
 }
 
 # test DB::set_tbreak()
 {
-       local ($DB::lineno, *DB::dbline, $DB::package);
-       *DB::dbline = [ 0, 1, 0, 0, 1 ];
+        local ($DB::lineno, *DB::dbline, $DB::package);
+        *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
 
-       DB->set_tbreak(1);
-       is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
+        DB->set_tbreak(1);
+        is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
 
-       local %DB::sub = (
-               'main::foo'     => 'foo:1-4',
-       );
-       DB->set_tbreak('foo', 'baz');
-       is( $DB::dbline{4}, ';9', 
-               '... should use _find_subline() to resolve subname' );
+        local %DB::sub = (
+                'main::foo'     => 'foo:1-4',
+        );
+        DB->set_tbreak('foo', 'baz');
+        is( $DB::dbline{4}, ';9', 
+                '... should use _find_subline() to resolve subname' );
 
-       my $db = FakeDB->new();
-       DB::set_tbreak($db, 2);
-       like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
+        my $db = FakeDB->new();
+        DB::set_tbreak($db, 2);
+        like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
 
-       DB::set_break($db, 'nonfoo');
-       like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
+        DB::set_break($db, 'nonfoo');
+        like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
 }
 
 # test DB::_find_subline()
 {
-       my @foo;
-       local *{ "::_<foo" } = \@foo;
-
-       local $DB::package;
-       local %DB::sub = (
-               'TEST::foo'     => 'foo:10-15',
-               'main::foo'     => 'foo:11-12',
-               'bar::bar'      => 'foo:10-16',
-       );
-
-       $foo[11] = 1;
-
-       is( DB::_find_subline('TEST::foo'), 11, 
-               'DB::_find_subline() should find fully qualified sub' );
-       is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep');
-       is( DB::_find_subline('foo'), 11, 
-               '... should resolve unqualified package name to main::' );
-
-       $DB::package = 'bar';
-       is( DB::_find_subline('bar'), 11, 
-               '... should resolve unqualified name with $DB::package, if defined' );
-       
-       $foo[11] = 0;
-
-       is( DB::_find_subline('TEST::foo'), 15, 
-               '... should increment past lines with no events' );
-               
-       ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'),
-               '... should not find nonexistant sub' );
+        my @foo;
+        local *{ "::_<foo" } = \@foo;
+
+        local $DB::package;
+        local %DB::sub = (
+                'TEST::foo'     => 'foo:10-15',
+                'main::foo'     => 'foo:11-12',
+                'bar::bar'      => 'foo:10-16',
+        );
+
+        $foo[11] = $dualtrue;
+
+        is( DB::_find_subline('TEST::foo'), 11, 
+                'DB::_find_subline() should find fully qualified sub' );
+        is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep');
+        is( DB::_find_subline('foo'), 11, 
+                '... should resolve unqualified package name to main::' );
+
+        $DB::package = 'bar';
+        is( DB::_find_subline('bar'), 11, 
+                '... should resolve unqualified name with $DB::package, if defined' );
+        
+        $foo[11] = $dualfalse;
+
+        is( DB::_find_subline('TEST::foo'), 15, 
+                '... should increment past lines with no events' );
+                
+        ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'),
+                '... should not find nonexistant sub' );
 }
 
 # test DB::clr_breaks()
 {
-       local *DB::dbline;
-       my %lines = (
-               1 => "\0",
-               2 => undef,
-               3 => "123\0\0\0abc",
-               4 => "\0\0\0abc",
-       );
-
-       %DB::dbline = %lines;
-       DB->clr_breaks(1 .. 4);
-       is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' );
-       ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
-       is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
-       is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
-
-       local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
-
-       local $DB::package;
-       local %DB::sub = (
-               'main::foo'     => 'foo:1-3',
-       );
-
-       %DB::dbline = %lines;
-       DB->clr_breaks('foo');
-
-       is( $DB::dbline{3}, "\0\0\0abc", 
-               '... should find lines via _find_subline()' );
-       
-       my $db = FakeDB->new();
-       DB::clr_breaks($db, 'abadsubname');
-       is( $db->{output}, "Subroutine not found.\n", 
-               '... should output warning if sub cannot be found');
-
-       @DB::dbline = (1 .. 4);
-       %DB::dbline = (%lines, 5 => "\0" );
-
-       DB::clr_breaks();
-
-       is( scalar keys %DB::dbline, 4, 
-               'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' );
-       ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
-       is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
-       is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
-       ok( exists($DB::dbline{5}), 
-               '... should only go to last index of @DB::dbline' );
+        local *DB::dbline;
+        my %lines = (
+                1 => "\0",
+                2 => undef,
+                3 => "123\0\0\0abc",
+                4 => "\0\0\0abc",
+        );
+
+        %DB::dbline = %lines;
+        DB->clr_breaks(1 .. 4);
+        is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' );
+        ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
+        is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
+        is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
+
+        local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
+
+        local $DB::package;
+        local %DB::sub = (
+                'main::foo'     => 'foo:1-3',
+        );
+
+        %DB::dbline = %lines;
+        DB->clr_breaks('foo');
+
+        is( $DB::dbline{3}, "\0\0\0abc", 
+                '... should find lines via _find_subline()' );
+        
+        my $db = FakeDB->new();
+        DB::clr_breaks($db, 'abadsubname');
+        is( $db->{output}, "Subroutine not found.\n", 
+                '... should output warning if sub cannot be found');
+
+        @DB::dbline = (1 .. 4);
+        %DB::dbline = (%lines, 5 => "\0" );
+
+        DB::clr_breaks();
+
+        is( scalar keys %DB::dbline, 4, 
+                'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' );
+        ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
+        is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
+        is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
+        ok( exists($DB::dbline{5}), 
+                '... should only go to last index of @DB::dbline' );
 }
 
 # test DB::set_action()
 {
-       local *DB::dbline;
+        local *DB::dbline;
 
-       %DB::dbline = (
-               2 => "\0abc",
-       );
+        %DB::dbline = (
+                2 => "\0abc",
+        );
 
-       *DB::dbline = [ 0, 0, 1, 1 ];
+        *DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ];
 
-       DB->set_action(2, 'def');
-       is( $DB::dbline{2}, "\0def", 
-               'DB::set_action() should replace existing action' );
-       DB->set_action(3, '');
-       is( $DB::dbline{3}, "\0", '... should set new action' );
+        DB->set_action(2, 'def');
+        is( $DB::dbline{2}, "\0def", 
+                'DB::set_action() should replace existing action' );
+        DB->set_action(3, '');
+        is( $DB::dbline{3}, "\0", '... should set new action' );
 
-       my $db = FakeDB->new();
-       DB::set_action($db, 'abadsubname');
-       is( $db->{output}, "Subroutine not found.\n", 
-               '... should output warning if sub cannot be found');
+        my $db = FakeDB->new();
+        DB::set_action($db, 'abadsubname');
+        is( $db->{output}, "Subroutine not found.\n", 
+                '... should output warning if sub cannot be found');
 
-       DB::set_action($db, 1);
-       like( $db->{output}, qr/1 not action/, 
-               '... should warn if line cannot be actionivated' );
+        DB::set_action($db, 1);
+        like( $db->{output}, qr/1 not action/, 
+                '... should warn if line cannot be actionivated' );
 }
 
 # test DB::clr_actions()
 {
-       local *DB::dbline;
-       my %lines = (
-               1 => "\0",
-               2 => undef,
-               3 => "123\0abc",
-               4 => "abc\0",
-       );
-
-       %DB::dbline = %lines;
-       *DB::dbline = [ 1, 1, 1, 1 ];
-
-       DB->clr_actions(1 .. 4);
-
-       is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' );
-       ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
-       is( $DB::dbline{3}, "123", '... should remove action, leaving break');
-       is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
-
-       local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
-
-       local $DB::package;
-       local %DB::sub = (
-               'main::foo'     => 'foo:1-3',
-       );
-
-       %DB::dbline = %lines;
-       DB->clr_actions('foo');
-
-       is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' );
-       
-       my $db = FakeDB->new();
-       DB::clr_actions($db, 'abadsubname');
-       is( $db->{output}, "Subroutine not found.\n", 
-               '... should output warning if sub cannot be found');
-
-       @DB::dbline = (1 .. 4);
-       %DB::dbline = (%lines, 5 => "\0" );
-
-       DB::clr_actions();
-
-       is( scalar keys %DB::dbline, 4, 
-               'Relying on @DB::dbline in DB::clr_actions() should clear actions' );
-       ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
-       is( $DB::dbline{3}, "123", '... should remove action, leaving break');
-       is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
-       ok( exists($DB::dbline{5}), 
-               '... should only go to last index of @DB::dbline' );
+        local *DB::dbline;
+        my %lines = (
+                1 => "\0",
+                2 => undef,
+                3 => "123\0abc",
+                4 => "abc\0",
+        );
+
+        %DB::dbline = %lines;
+        *DB::dbline = [ ($dualtrue) x 4 ];
+
+        DB->clr_actions(1 .. 4);
+
+        is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' );
+        ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
+        is( $DB::dbline{3}, "123", '... should remove action, leaving break');
+        is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
+
+        local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
+
+        local $DB::package;
+        local %DB::sub = (
+                'main::foo'     => 'foo:1-3',
+        );
+
+        %DB::dbline = %lines;
+        DB->clr_actions('foo');
+
+        is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' );
+        
+        my $db = FakeDB->new();
+        DB::clr_actions($db, 'abadsubname');
+        is( $db->{output}, "Subroutine not found.\n", 
+                '... should output warning if sub cannot be found');
+
+        @DB::dbline = (1 .. 4);
+        %DB::dbline = (%lines, 5 => "\0" );
+
+        DB::clr_actions();
+
+        is( scalar keys %DB::dbline, 4, 
+                'Relying on @DB::dbline in DB::clr_actions() should clear actions' );
+        ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
+        is( $DB::dbline{3}, "123", '... should remove action, leaving break');
+        is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
+        ok( exists($DB::dbline{5}), 
+                '... should only go to last index of @DB::dbline' );
 }
 
 # test DB::prestop()
 ok( ! defined DB::prestop('test'),
-       'DB::prestop() should return undef for undef value' );
+        'DB::prestop() should return undef for undef value' );
 DB::prestop('test', 897);
 is( DB::prestop('test'), 897, '... should return value when set' );
 
 # test DB::poststop(), not exactly parallel
 ok( ! defined DB::poststop('tset'), 
-       'DB::prestop() should return undef for undef value' );
+        'DB::prestop() should return undef for undef value' );
 DB::poststop('tset', 987);
 is( DB::poststop('tset'), 987, '... should return value when set' );
 
 # test DB::evalcode()
 ok( ! defined DB::evalcode('foo'),
-       'DB::evalcode() should return undef for undef value' );
+        'DB::evalcode() should return undef for undef value' );
 
 DB::evalcode('foo', 'bar');
 is( DB::evalcode('foo'), 'bar', '... should return value when set' );
@@ -472,11 +484,11 @@ DB::register( FakeDB->new() ) for ( 1 .. 2);
 
 DB::_outputall(1, 2, 3);
 is( $FakeDB::output, '123123123', 
-       'DB::_outputall() should call output(@_) on all clients' );
+        'DB::_outputall() should call output(@_) on all clients' );
 
 # test virtual methods
 for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) {
-       ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
+        ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
 }
 
 # DB::skippkg() uses lexical
@@ -487,19 +499,19 @@ package FakeDB;
 use vars qw( $output );
 
 sub new {
-       bless({}, $_[0]);
+        bless({}, $_[0]);
 }
 
 sub set_tbreak {
-       my ($self, $val) = @_;
-       $self->{tbreak} = $val;
+        my ($self, $val) = @_;
+        $self->{tbreak} = $val;
 }
 
 sub output {
-       my $self = shift;
-       if (ref $self) {
-               $self->{output} = join('', @_);
-       } else {
-               $output .= join('', @_);
-       }
+        my $self = shift;
+        if (ref $self) {
+                $self->{output} = join('', @_);
+        } else {
+                $output .= join('', @_);
+        }
 }
index abdae6c..76a5bad 100644 (file)
@@ -126,8 +126,13 @@ sub heavy_export {
                        last;
                    }
                } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
-                    require Carp;
-                   Carp::carp(qq["$sym" is not exported by the $pkg module]);
+                   unless ($^S) {
+                       # If we are trying to trap import of non-existent
+                       # symbols using eval, let's be silent for now and
+                       # just croak in the end.
+                       require Carp;
+                       Carp::carp(qq["$sym" is not exported by the $pkg module]);
+                   }
                    $oops++;
                }
            }
index c765788..035c597 100644 (file)
@@ -17,9 +17,9 @@ dirname - extract just the directory from a path
     $basename = basename($fullname,@suffixlist);
     $dirname = dirname($fullname);
 
-    ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm");
+    ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",qr{\.pm});
     fileparse_set_fstype("VMS");
-    $basename = basename("lib/File/Basename.pm",".pm");
+    $basename = basename("lib/File/Basename.pm",qr{\.pm});
     $dirname = dirname("lib/File/Basename.pm");
 
 =head1 DESCRIPTION
@@ -60,7 +60,8 @@ B<path> contains everything up to and including the last directory
 separator in the input file specification.  The remainder of the input
 file specification is then divided into B<name> and B<suffix> based on
 the optional patterns you specify in C<@suffixlist>.  Each element of
-this list is interpreted as a regular expression, and is matched
+this list can be a qr-quoted pattern (or a string which is interpreted
+as a regular expression), and is matched
 against the end of B<name>.  If this succeeds, the matching portion of
 B<name> is removed and prepended to B<suffix>.  By proper use of
 C<@suffixlist>, you can remove file types or versions for examination.
@@ -76,7 +77,7 @@ file as the input file specification.
 Using Unix file syntax:
 
     ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
-                                   '\.book\d+');
+                                   qr{\.book\d+});
 
 would yield
 
@@ -87,7 +88,7 @@ would yield
 Similarly, using VMS syntax:
 
     ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh',
-                                  '\..*');
+                                  qr{\..*});
 
 would yield
 
@@ -197,6 +198,7 @@ sub fileparse {
       my $devspec  = $1;
       my $remainder = $3;
       ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
+      $dirpath ||= '';  # should always be defined
       $dirpath = $devspec.$dirpath;
     }
     $dirpath = './' unless $dirpath;
index 9bee1bf..32d9bfb 100755 (executable)
@@ -18,7 +18,7 @@ print +(length(File::Basename::fileparse_set_fstype('unix')) ?
         '' : 'not '),"ok 2\n";
 
 # Unix syntax tests
-($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+');
+($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',qr'\.book\d+');
 if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') {
   print "ok 3\n";
 }
@@ -37,7 +37,7 @@ print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ?
         '' : 'not '),"ok 8\n";
 
 # VMS syntax tests
-($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+');
+($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',qr{\.book\d+});
 if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') {
   print "ok 9\n";
 }
index 325af08..f21ff5e 100644 (file)
@@ -157,7 +157,7 @@ sub canonpath {
     }
     else {
       $path =~ s/([\[<])000000\./$1/g;                  # [000000.foo     ==> [foo
-      $path =~ s/([^-]+)\.000000([\]\>])/$1$2/g;        # foo.000000]     ==> foo]
+      $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g;  # foo.000000] ==> foo]
       $path =~ s-\]\[--g;  $path =~ s/><//g;            # foo.][bar       ==> foo.bar
       1 while $path =~ s{([\[<-])\.-}{$1-};             # [.-.-           ==> [--
       $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/;            # bar.foo.-]      ==> bar]
old mode 100755 (executable)
new mode 100644 (file)
similarity index 100%
rename from lib/File/Spec/Functions.t
rename to lib/File/Spec/t/Functions.t
old mode 100755 (executable)
new mode 100644 (file)
similarity index 100%
rename from lib/File/Spec.t
rename to lib/File/Spec/t/Spec.t
diff --git a/lib/File/Spec/t/rel2abs2rel.t b/lib/File/Spec/t/rel2abs2rel.t
new file mode 100644 (file)
index 0000000..69232d9
--- /dev/null
@@ -0,0 +1,27 @@
+#!./perl -w
+
+# Herein we apply abs2rel, rel2abs and canonpath against various real
+# world files and make sure it all actually works.
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+}
+
+use Test::More tests => 5;
+use File::Spec;
+
+# Here we make sure File::Spec can properly deal with executables.
+# VMS has some trouble with these.
+my $perl = File::Spec->rel2abs($^X);
+is( `$^X   -le "print 'ok'"`, "ok\n",   '`` works' );
+is( `$perl -le "print 'ok'"`, "ok\n",   'rel2abs($^X)' );
+
+$perl = File::Spec->canonpath($perl);
+is( `$perl -le "print 'ok'"`, "ok\n",   'canonpath on abs executable' );
+
+$perl = File::Spec->abs2rel($perl);
+is( `$perl -le "print 'ok'"`, "ok\n",   'abs2rel()' );
+
+$perl = File::Spec->canonpath($^X);
+is( `$perl -le "print 'ok'"`, "ok\n",   'canonpath on rel executable' );
index a490e62..a258777 100644 (file)
@@ -7,27 +7,24 @@
 #   _a: accuracy
 #   _p: precision
 #   _f: flags, used to signal MBI not to touch our private parts
-# _cow: Copy-On-Write (NRY)
 
 package Math::BigFloat;
 
-$VERSION = '1.25';
+$VERSION = '1.26';
 require 5.005;
 use Exporter;
 use Math::BigInt qw/objectify/;
 @ISA =       qw( Exporter Math::BigInt);
-# can not export bneg/babs since the are only in MBI
-@EXPORT_OK = qw( 
-                bcmp 
-                badd bmul bdiv bmod bnorm bsub
-               bgcd blcm bround bfround
-               bpow bnan bzero bfloor bceil 
-               bacmp bstr binc bdec binf
-               is_odd is_even is_nan is_inf is_positive is_negative
-               is_zero is_one sign
-               ); 
-
-#@EXPORT = qw( );
+#@EXPORT_OK = qw( 
+#                bcmp 
+#                badd bmul bdiv bmod bnorm bsub
+#              bgcd blcm bround bfround
+#              bpow bnan bzero bfloor bceil 
+#              bacmp bstr binc bdec binf
+#              is_odd is_even is_nan is_inf is_positive is_negative
+#              is_zero is_one sign
+#               ); 
+
 use strict;
 use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode/;
 my $class = "Math::BigFloat";
@@ -74,13 +71,13 @@ BEGIN { tie $rnd_mode, 'Math::BigFloat'; }
   # valid method aliases for AUTOLOAD
   my %methods = map { $_ => 1 }  
    qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm
-        fneg fint facmp fcmp fzero fnan finf finc fdec
-       fceil ffloor
+        fint facmp fcmp fzero fnan finf finc fdec
+       fceil ffloor frsft flsft fone
       /;
   # valid method's that need to be hand-ed up (for AUTOLOAD)
   my %hand_ups = map { $_ => 1 }  
    qw / is_nan is_inf is_negative is_positive
-        accuracy precision div_scale round_mode fabs babs
+        accuracy precision div_scale round_mode fneg fabs babs fnot
       /;
 
   sub method_alias { return exists $methods{$_[0]||''}; } 
@@ -162,6 +159,7 @@ sub bnan
   $self->{_m} = Math::BigInt->bzero();
   $self->{_e} = Math::BigInt->bzero();
   $self->{sign} = $nan;
+  ($self->{_a},$self->{_p}) = @_ if @_ > 0;
   return $self;
   }
 
@@ -179,6 +177,7 @@ sub binf
   $self->{_m} = Math::BigInt->bzero();
   $self->{_e} = Math::BigInt->bzero();
   $self->{sign} = $sign.'inf';
+  ($self->{_a},$self->{_p}) = @_ if @_ > 0;
   return $self;
   }
 
@@ -196,6 +195,7 @@ sub bone
   $self->{_m} = Math::BigInt->bone();
   $self->{_e} = Math::BigInt->bzero();
   $self->{sign} = $sign;
+  ($self->{_a},$self->{_p}) = @_ if @_ > 0;
   return $self;
   }
 
@@ -211,6 +211,7 @@ sub bzero
   $self->{_m} = Math::BigInt->bzero();
   $self->{_e} = Math::BigInt->bone();
   $self->{sign} = '+';
+  ($self->{_a},$self->{_p}) = @_ if @_ > 0;
   return $self;
   }
 
@@ -321,16 +322,6 @@ sub numify
 ##############################################################################
 # public stuff (usually prefixed with "b")
 
-# really? Just for exporting them is not what I had in mind
-#sub babs
-#  {
-#  $class->SUPER::babs($class,@_);
-#  }
-#sub bneg
-#  {
-#  $class->SUPER::bneg($class,@_);
-#  }
-
 # tels 2001-08-04 
 # todo: this must be overwritten and return NaN for non-integer values
 # band(), bior(), bxor(), too
@@ -424,12 +415,12 @@ sub bacmp
   my $lx = $lxm + $x->{_e};
   my $ly = $lym + $y->{_e};
   # print "x $x y $y lx $lx ly $ly\n";
-  my $l = $lx - $ly; # $l = -$l if $x->{sign} eq '-';
+  my $l = $lx - $ly;
   # print "$l $x->{sign}\n";
   return $l <=> 0 if $l != 0;
   
   # lengths (corrected by exponent) are equal
-  # so make mantissa euqal length by padding with zero (shift left)
+  # so make mantissa equal-length by padding with zero (shift left)
   my $diff = $lxm - $lym;
   my $xm = $x->{_m};           # not yet copy it
   my $ym = $y->{_m};
@@ -442,22 +433,7 @@ sub bacmp
     $xm = $x->{_m}->copy()->blsft(-$diff,10);
     }
   my $rc = $xm->bcmp($ym);
-  # $rc = -$rc if $x->{sign} eq '-';           # -124 < -123
   return $rc <=> 0;
-
-#  # signs are ignored, so check length
-#  # length(x) is length(m)+e aka length of non-fraction part
-#  # the longer one is bigger
-#  my $l = $x->length() - $y->length();
-#  #print "$l\n";
-#  return $l if $l != 0;
-#  #print "equal lengths\n";
-#
-#  # if both are equal long, make full compare
-#  # first compare only the mantissa
-#  # if mantissa are equal, compare fractions
-#  
-#  return $x->{_m} <=> $y->{_m} || $x->{_e} <=> $y->{_e};
   }
 
 sub badd 
@@ -703,15 +679,11 @@ sub bmul
     }
 
   # aEb * cEd = (a*c)E(b+d)
-  $x->{_m} = $x->{_m} * $y->{_m};
-  #print "m: $x->{_m}\n";
-  $x->{_e} = $x->{_e} + $y->{_e};
-  #print "e: $x->{_m}\n";
+  $x->{_m}->bmul($y->{_m});
+  $x->{_e}->badd($y->{_e});
   # adjust sign:
   $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
-  #print "s: $x->{sign}\n";
-  $x->bnorm();
-  return $x->round($a,$p,$r,$y);
+  return $x->bnorm()->round($a,$p,$r,$y);
   }
 
 sub bdiv 
@@ -735,18 +707,12 @@ sub bdiv
    ? ($x->binf($x->{sign}),$self->bnan()) : $x->binf($x->{sign})
    if ($x->{sign} =~ /^[+-]$/ && $y->is_zero());
 
-  # promote BigInts and it's subclasses (except when already a BigFloat)
-  $y = $self->new($y) unless $y->isa('Math::BigFloat'); 
-
-  # old, broken way
-  # $y = $class->new($y) if ref($y) ne $self;          # promote bigints
+  # x== 0 or y == 1 or y == -1
+  return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
 
-  # print "mbf bdiv $x ",ref($x)," ",$y," ",ref($y),"\n"; 
   # we need to limit the accuracy to protect against overflow
-
   my $fallback = 0;
   my $scale = 0;
-#  print "s=$scale a=",$a||'undef'," p=",$p||'undef'," r=",$r||'undef',"\n";
   my @params = $x->_find_round_parameters($a,$p,$r,$y);
 
   # no rounding at all, so must use fallback
@@ -764,40 +730,29 @@ sub bdiv
     # enough...
     $scale = abs($params[1] || $params[2]) + 4;        # take whatever is defined
     }
- # print "s=$scale a=",$params[1]||'undef'," p=",$params[2]||'undef'," f=$fallback\n";
   my $lx = $x->{_m}->length(); my $ly = $y->{_m}->length();
   $scale = $lx if $lx > $scale;
   $scale = $ly if $ly > $scale;
-#  print "scale $scale $lx $ly\n";
   my $diff = $ly - $lx;
   $scale += $diff if $diff > 0;                # if lx << ly, but not if ly << lx!
 
-  return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
-
   $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+'; 
 
   # check for / +-1 ( +/- 1E0)
-  if ($y->is_one())
+  if (!$y->is_one())
     {
-    return wantarray ? ($x,$self->bzero()) : $x;
+    # 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)
+    $x->{_m}->blsft($scale,10);
+    $x->{_m}->bdiv( $y->{_m} );        # a/c
+    $x->{_e}->bsub( $y->{_e} );        # b-d
+    $x->{_e}->bsub($scale);    # correct for 10**scale
+    $x->bnorm();               # remove trailing 0's
     }
 
-  # calculate the result to $scale digits and then round it
-  # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
-  #$scale = 82;
-  #print "self: $self x: $x ref(x) ", ref($x)," m: $x->{_m}\n";
-  $x->{_m}->blsft($scale,10);
-  #print "m: $x->{_m} $y->{_m}\n";
-  $x->{_m}->bdiv( $y->{_m} );  # a/c
-  #print "m: $x->{_m}\n";
-  #print "e: $x->{_e} $y->{_e} ",$scale,"\n";
-  $x->{_e}->bsub($y->{_e});    # b-d
-  #print "e: $x->{_e}\n";
-  $x->{_e}->bsub($scale);      # correct for 10**scale
-  #print "after div: m: $x->{_m} e: $x->{_e}\n";
-  $x->bnorm();                 # remove trailing 0's
-  #print "after norm: m: $x->{_m} e: $x->{_e}\n";
-
   # shortcut to not run trough _find_round_parameters again
   if (defined $params[1])
     {
@@ -815,8 +770,16 @@ sub bdiv
   
   if (wantarray)
     {
-    my $rem = $x->copy();
-    $rem->bmod($y,$params[1],$params[2],$params[3]);
+    my $rem;
+    if (!$y->is_one())
+      {
+      $rem = $x->copy();
+      $rem->bmod($y,$params[1],$params[2],$params[3]);
+      }
+    else
+      {
+      $rem = $self->bzero();
+      }
     if ($fallback)
       {
       # clear a/p after round, since user did not request it
@@ -847,7 +810,7 @@ sub bsqrt
 
   return $x->bnan() if $x->{sign} eq 'NaN' || $x->{sign} =~ /^-/; # <0, NaN
   return $x if $x->{sign} eq '+inf';                             # +inf
-  return $x if $x->is_zero() || $x == 1;
+  return $x if $x->is_zero() || $x->is_one();
 
   # we need to limit the accuracy to protect against overflow (ignore $p)
   my ($scale) = $x->_scale_a($self->accuracy(),$self->round_mode,$a,$r); 
@@ -859,43 +822,53 @@ sub bsqrt
     $a = $self->div_scale();           # and round to it
     $fallback = 1;                     # to clear a/p afterwards
     }
+  my $xas = $x->as_number();
+  my $gs = $xas->copy()->bsqrt();      # some guess
+  if (($x->{_e}->{sign} ne '-')                # guess can't be accurate if there are
+                                       # digits after the dot
+   && ($xas->bcmp($gs * $gs) == 0))    # guess hit the nail on the head?
+    {
+    # exact result
+    $x->{_m} = $gs;
+    # leave alone if _e is already right
+    $x->{_e} = Math::BigInt->bzero();
+    return $x->bnorm()->round($a,$p,$r)
+    }
+  $gs = $self->new( $gs );
+
   my $lx = $x->{_m}->length();
   $scale = $lx if $scale < $lx;
-  my $e = Math::BigFloat->new("1E-$scale");    # make test variable
+  my $e = $self->new("1E-$scale");     # make test variable
   return $x->bnan() if $e->sign() eq 'NaN';
 
   # start with some reasonable guess
-  #$x *= 10 ** ($len - $org->{_e}); $x /= 2;   # !?!?
-  $lx = $lx+$x->{_e};
-  $lx = 1 if $lx < 1;
-  my $gs = Math::BigFloat->new('1'. ('0' x $lx));      
-  
-#   print "first guess: $gs (x $x) scale $scale\n";
+# $lx = $lx+$x->{_e};
+#  $lx = $lx / 2;
+#  $lx = 1 if $lx < 1;
+ # my $gs = Math::BigFloat->new("1E$lx");      
+
+#  print "first guess: $gs (x $x) scale $scale\n";
+#  # use BigInt:sqrt as reasonabe guess
+#  print "second guess: $gs (x $x) scale $scale\n";
+
   my $diff = $e;
   my $y = $x->copy();
-  my $two = Math::BigFloat->new(2);
+  my $two = $self->new(2);
   # promote BigInts and it's subclasses (except when already a BigFloat)
   $y = $self->new($y) unless $y->isa('Math::BigFloat'); 
-  # old, broken way
-  # $x = Math::BigFloat->new($x) if ref($x) ne $class; # promote BigInts
   my $rem;
-  # $scale = 2;
+#  my $steps = 0;
   while ($diff >= $e)
     {
-    return $x->bnan() if $gs->is_zero();
-    $rem = $y->copy(); $rem->bdiv($gs,$scale); 
-    #print "y $y gs $gs ($gs->{_a}) rem (y/gs)\n $rem\n";
-    $x = ($rem + $gs);
-    #print "x $x rem $rem gs $gs gsa: $gs->{_a}\n";
-    $x->bdiv($two,$scale);
-    #print "x $x (/2)\n";
+    # return $x->bnan() if $gs->is_zero();
+
+    $x = $y->copy()->bdiv($gs,$scale)->badd($gs)->bdiv($two,$scale);
     $diff = $x->copy()->bsub($gs)->babs();
     $gs = $x->copy();
+#    $steps++;
     }
-#  print "before $x $x->{_a} ",$a||'a undef'," ",$p||'p undef',"\n";
+#  print "steps $steps\n";
   $x->round($a,$p,$r);
-#  print "after $x $x->{_a} ",$a||'a undef'," ",$p||'p undef',"\n";
   if ($fallback)
     {
     # clear a/p after round, since user did not request it
@@ -917,7 +890,8 @@ sub bpow
   return $x->bone() if $y->is_zero();
   return $x         if $x->is_one() || $y->is_one();
   my $y1 = $y->as_number();            # make bigint (trunc)
-  if ($x == -1)
+  # if ($x == -1)
+  if ($x->{sign} eq '-' && $x->{_m}->is_one() && $x->{_e}->is_zero())
     {
     # if $x == -1 and odd/even y => +1/-1  because +-1 ^ (+-1) => +-1
     return $y1->is_odd() ? $x : $x->babs(1);
@@ -1123,6 +1097,30 @@ sub bceil
   return $x->round($a,$p,$r);
   }
 
+sub brsft
+  {
+  # shift right by $y (divide by power of 2)
+  my ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+
+  return $x if $x->modify('brsft');
+  return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+  $n = 2 if !defined $n; $n = Math::BigFloat->new($n);
+  $x->bdiv($n ** $y,$a,$p,$r,$y);
+  }
+
+sub blsft
+  {
+  # shift right by $y (divide by power of 2)
+  my ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+
+  return $x if $x->modify('brsft');
+  return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+  $n = 2 if !defined $n; $n = Math::BigFloat->new($n);
+  $x->bmul($n ** $y,$a,$p,$r,$y);
+  }
+
 ###############################################################################
 
 sub DESTROY
@@ -1147,7 +1145,6 @@ sub AUTOLOAD
       require Carp;
       Carp::croak ("Can't call a method without name");
       }
-    # try one level up, but subst. bxxx() for fxxx() since MBI only got bxxx()
     if (!method_hand_up($name))
       {
       # delayed load of Carp and avoid recursion       
@@ -1250,7 +1247,7 @@ sub bnorm
   # 'forget' that mantissa was rounded via MBI::bround() in MBF's bfround()
   $x->{_m}->{_a} = undef; $x->{_e}->{_a} = undef;
   $x->{_m}->{_p} = undef; $x->{_e}->{_p} = undef;
-  return $x;                                   # MBI bnorm is no-op
+  return $x;                           # MBI bnorm is no-op, so dont call it
   }
  
 ##############################################################################
@@ -1258,8 +1255,8 @@ sub bnorm
 
 sub as_number
   {
-  # return a bigint representation of this BigFloat number
-  my $x = shift; my $class = ref($x) || $x; $x = $class->new(shift) unless ref($x);
+  # return copy as a bigint representation of this BigFloat number
+  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
 
   my $z;
   if ($x->{_e}->is_zero())
index a1b7b8f..354bc71 100644 (file)
@@ -1,9 +1,5 @@
 #!/usr/bin/perl -w
 
-# Qs: what exactly happens on numify of HUGE numbers? overflow?
-#     $a = -$a is much slower (making copy of $a) than $a->bneg(), hm!?
-#     (copy_on_write will help there, but that is not yet implemented)
-
 # The following hash values are used:
 #   value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
 #   sign : +,-,NaN,+inf,-inf
@@ -18,18 +14,21 @@ package Math::BigInt;
 my $class = "Math::BigInt";
 require 5.005;
 
-$VERSION = '1.47';
+$VERSION = '1.48';
 use Exporter;
 @ISA =       qw( Exporter );
-@EXPORT_OK = qw( bneg babs bcmp badd bmul bdiv bmod bnorm bsub
-                 bgcd blcm bround 
-                 blsft brsft band bior bxor bnot bpow bnan bzero 
-                 bacmp bstr bsstr binc bdec binf bfloor bceil
-                 is_odd is_even is_zero is_one is_nan is_inf sign
-                is_positive is_negative
-                length as_number objectify _swap
+# no longer export stuff (it doesn't work with subclasses anyway)
+# bneg babs bcmp badd bmul bdiv bmod bnorm bsub
+#                 bgcd blcm bround 
+#                 blsft brsft band bior bxor bnot bpow bnan bzero 
+#                 bacmp bstr bsstr binc bdec binf bfloor bceil
+#                 is_odd is_even is_zero is_one is_nan is_inf sign
+#               is_positive is_negative
+#               length as_number
+@EXPORT_OK = qw(
+                objectify _swap
+                bgcd blcm
                ); 
-#@EXPORT = qw( );
 use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode/;
 use strict;
 
@@ -291,21 +290,26 @@ sub copy
   return unless ref($x); # only for objects
 
   my $self = {}; bless $self,$c;
+  my $r;
   foreach my $k (keys %$x)
     {
     if ($k eq 'value')
       {
-      $self->{value} = $CALC->_copy($x->{value});
+      $self->{value} = $CALC->_copy($x->{value}); next;
+      }
+    if (!($r = ref($x->{$k})))
+      {
+      $self->{$k} = $x->{$k}; next;
       }
-    elsif (ref($x->{$k}) eq 'SCALAR')
+    if ($r eq 'SCALAR')
       {
       $self->{$k} = \${$x->{$k}};
       }
-    elsif (ref($x->{$k}) eq 'ARRAY')
+    elsif ($r eq 'ARRAY')
       {
       $self->{$k} = [ @{$x->{$k}} ];
       }
-    elsif (ref($x->{$k}) eq 'HASH')
+    elsif ($r eq 'HASH')
       {
       # only one level deep!
       foreach my $h (keys %{$x->{$k}})
@@ -313,14 +317,17 @@ sub copy
         $self->{$k}->{$h} = $x->{$k}->{$h};
         }
       }
-    elsif (ref($x->{$k}))
+    else # normal ref
       {
-      my $c = ref($x->{$k});
-      $self->{$k} = $c->new($x->{$k}); # no copy() due to deep rec
-      }
-    else
-      {
-      $self->{$k} = $x->{$k};
+      my $xk = $x->{$k};       
+      if ($xk->can('copy'))
+        {
+       $self->{$k} = $xk->copy();
+        }
+      else
+       {
+       $self->{$k} = $xk->new($xk);
+       }
       }
     }
   $self;
@@ -425,6 +432,7 @@ sub bnan
   return if $self->modify('bnan');
   $self->{value} = $CALC->_zero();
   $self->{sign} = $nan;
+  delete $self->{_a}; delete $self->{_p};      # rounding NaN is silly
   return $self;
   }
 
@@ -442,6 +450,7 @@ sub binf
   return if $self->modify('binf');
   $self->{value} = $CALC->_zero();
   $self->{sign} = $sign.'inf';
+  ($self->{_a},$self->{_p}) = @_;              # take over requested rounding
   return $self;
   }
 
@@ -458,6 +467,7 @@ sub bzero
   return if $self->modify('bzero');
   $self->{value} = $CALC->_zero();
   $self->{sign} = '+';
+  ($self->{_a},$self->{_p}) = @_;              # take over requested rounding
   return $self;
   }
 
@@ -468,7 +478,7 @@ sub bone
   my $self = shift;
   my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
   $self = $class if !defined $self;
+  
   if (!ref($self))
     {
     my $c = $self; $self = {}; bless $self, $c;
@@ -476,6 +486,7 @@ sub bone
   return if $self->modify('bone');
   $self->{value} = $CALC->_one();
   $self->{sign} = $sign;
+  ($self->{_a},$self->{_p}) = @_;              # take over requested rounding
   return $self;
   }
 
@@ -519,7 +530,7 @@ sub bstr
 
 sub numify 
   {
-  # Make a number from a BigInt object
+  # Make a "normal" scalar from a BigInt object
   my $x = shift; $x = $class->new($x) unless ref $x;
   return $x->{sign} if $x->{sign} !~ /^[+-]$/;
   my $num = $CALC->_num($x->{value});
@@ -548,19 +559,19 @@ sub _find_round_parameters
   # A and P settings.
   # This does not yet handle $x with A, and $y with P (which should be an
   # error).
-  my $self = shift;
-  my $a    = shift;    # accuracy, if given by caller
-  my $p    = shift;    # precision, if given by caller
-  my $r    = shift;    # round_mode, if given by caller
-  my @args = @_;       # all 'other' arguments (0 for unary, 1 for binary ops)
+  my ($self,$a,$p,$r,@args) = @_;
+  # $a accuracy, if given by caller
+  # $p precision, if given by caller
+  # $r round_mode, if given by caller
+  # @args all 'other' arguments (0 for unary, 1 for binary ops)
 
-  $self = new($self) unless ref($self);        # if not object, make one
-  my $c = ref($self);                          # find out class of argument(s)
-  unshift @args,$self;                         # add 'first' argument
+  # $self = new($self) unless ref($self);      # if not object, make one
         
   # leave bigfloat parts alone
   return ($self) if exists $self->{_f} && $self->{_f} & MB_NEVER_ROUND != 0;
 
+  unshift @args,$self;                         # add 'first' argument
+  my $c = ref($self);                          # find out class of argument(s)
   no strict 'refs';
 
   # now pick $a or $p, but only if we have got "arguments"
@@ -651,7 +662,7 @@ sub bneg
   return $x if $x->modify('bneg');
   # for +0 dont negate (to have always normalized)
   return $x if $x->is_zero();
-  $x->{sign} =~ tr/+\-/-+/; # does nothing for NaN
+  $x->{sign} =~ tr/+-/-+/;     # does nothing for NaN
   $x;
   }
 
@@ -955,7 +966,7 @@ sub is_one
   $sign = '' if !defined $sign; $sign = '+' if $sign ne '-';
  
   return 0 if $x->{sign} ne $sign;     # -1 != +1, NaN, +-inf aren't either
-  return $CALC->_is_one($x->{value});
+  $CALC->_is_one($x->{value});
   }
 
 sub is_odd
@@ -965,7 +976,7 @@ sub is_odd
   my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
 
   return 0 if $x->{sign} !~ /^[+-]$/;                  # NaN & +-inf aren't
-  return $CALC->_is_odd($x->{value});
+  $CALC->_is_odd($x->{value});
   }
 
 sub is_even
@@ -975,7 +986,7 @@ sub is_even
   my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
 
   return 0 if $x->{sign} !~ /^[+-]$/;                  # NaN & +-inf aren't
-  return $CALC->_is_even($x->{value});
+  $CALC->_is_even($x->{value});
   }
 
 sub is_positive
@@ -985,7 +996,7 @@ sub is_positive
   my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
   
   return 1 if $x->{sign} =~ /^\+/;
-  return 0;
+  0;
   }
 
 sub is_negative
@@ -995,7 +1006,7 @@ sub is_negative
   my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
   
   return 1 if ($x->{sign} =~ /^-/);
-  return 0;
+  0;
   }
 
 ###############################################################################
@@ -1114,20 +1125,18 @@ sub bdiv
   my $xsign = $x->{sign};                              # keep
   $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+'); 
   # check for / +-1 (cant use $y->is_one due to '-'
-  if (($y == 1) || ($y == -1))                         # slow!
+  if ($CALC->_is_one($y->{value}))
     {
     return wantarray ? ($x,$self->bzero()) : $x; 
     }
 
-  # call div here 
-  my $rem = $self->bzero(); 
-  ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
-  # do not leave result "-0";
-  $x->{sign} = '+' if $CALC->_is_zero($x->{value});
-  $x->round($a,$p,$r,$y); 
-
+  my $rem;
   if (wantarray)
     {
+    my $rem = $self->bzero(); 
+    ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
+    $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+    $x->round($a,$p,$r,$y); 
     if (! $CALC->_is_zero($rem->{value}))
       {
       $rem->{sign} = $y->{sign};
@@ -1140,7 +1149,10 @@ sub bdiv
     $rem->round($a,$p,$r,$x,$y);
     return ($x,$rem);
     }
-  return $x; 
+
+  $x->{value} = $CALC->_div($x->{value},$y->{value});
+  $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+  $x->round($a,$p,$r,$y); 
   }
 
 sub bmod 
@@ -1175,7 +1187,7 @@ sub bmod
     {
     $x = (&bdiv($self,$x,$y))[1];              # slow way
     }
-  $x->bround($a,$p,$r);
+  $x->round($a,$p,$r);
   }
 
 sub bpow 
@@ -1191,7 +1203,6 @@ sub bpow
   return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
   return $x->__one() if $y->is_zero();
   return $x         if $x->is_one() || $y->is_one();
-  #if ($x->{sign} eq '-' && @{$x->{value}} == 1 && $x->{value}->[0] == 1)
   if ($x->{sign} eq '-' && $CALC->_is_one($x->{value}))
     {
     # if $x == -1 and odd/even y => +1/-1
@@ -1288,7 +1299,7 @@ sub band
   return $x if $x->modify('band');
 
   return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
-  return $x->bzero() if $y->is_zero();
+  return $x->bzero() if $y->is_zero() || $x->is_zero();
 
   my $sign = 0;                                        # sign of result
   $sign = 1 if ($x->{sign} eq '-') && ($y->{sign} eq '-');
@@ -1301,7 +1312,7 @@ sub band
     return $x->round($a,$p,$r);
     }
 
-  my $m = new Math::BigInt 1; my ($xr,$yr);
+  my $m = Math::BigInt->bone(); my ($xr,$yr);
   my $x10000 = new Math::BigInt (0x1000);
   my $y1 = copy(ref($x),$y);                   # make copy
   $y1->babs();                                 # and positive
@@ -1344,8 +1355,8 @@ sub bior
     return $x->round($a,$p,$r);
     }
 
-  my $m = new Math::BigInt 1; my ($xr,$yr);
-  my $x10000 = new Math::BigInt (0x10000);
+  my $m = Math::BigInt->bone(); my ($xr,$yr);
+  my $x10000 = Math::BigInt->new(0x10000);
   my $y1 = copy(ref($x),$y);                   # make copy
   $y1->babs();                                 # and positive
   my $x1 = $x->copy()->babs(); $x->bzero();    # modify x in place!
@@ -1374,7 +1385,6 @@ sub bxor
 
   return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
   return $x if $y->is_zero();
-  return $x->bzero() if $x == $y; # shortcut
   
   my $sign = 0;                                        # sign of result
   $sign = 1 if $x->{sign} ne $y->{sign};
@@ -1388,8 +1398,8 @@ sub bxor
     return $x->round($a,$p,$r);
     }
 
-  my $m = new Math::BigInt 1; my ($xr,$yr);
-  my $x10000 = new Math::BigInt (0x10000);
+  my $m = $self->bone(); my ($xr,$yr);
+  my $x10000 = Math::BigInt->new(0x10000);
   my $y1 = copy(ref($x),$y);                   # make copy
   $y1->babs();                                 # and positive
   my $x1 = $x->copy()->babs(); $x->bzero();    # modify x in place!
@@ -1444,29 +1454,36 @@ sub _trailing_zeros
 
 sub bsqrt
   {
-  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+  my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
 
-  return $x->bnan() if $x->{sign} =~ /\-|$nan/;        # -x or NaN => NaN
-  return $x->bzero() if $x->is_zero();         # 0 => 0
-  return $x if $x == 1;                                # 1 => 1
+  return $x->bnan() if $x->{sign} ne '+';      # -x or inf or NaN => NaN
+  return $x->bzero($a,$p) if $x->is_zero();                    # 0 => 0
+  return $x->round($a,$p,$r) if $x->is_one();                  # 1 => 1
+  return $x->bone($a,$p) if $x < 4;                            # 2,3 => 1
 
-  my $y = $x->copy();                          # give us one more digit accur.
+  if ($CALC->can('_sqrt'))
+    {
+    $x->{value} = $CALC->_sqrt($x->{value});
+    return $x->round($a,$p,$r);
+    }
+
+  my $y = $x->copy();
   my $l = int($x->length()/2);
   
-  $x->bzero(); 
-  $x->binc();          # keep ref($x), but modify it
-  $x *= 10 ** $l;
-
-  # print "x: $y guess $x\n";
+  $x->bone();                                  # keep ref($x), but modify it
+  $x->blsft($l,10);
 
   my $last = $self->bzero();
-  while ($last != $x)
+  my $two = $self->new(2);
+  my $lastlast = $x+$two;
+  while ($last != $x && $lastlast != $x)
     {
-    $last = $x; 
+    $lastlast = $last; $last = $x; 
     $x += $y / $x; 
-    $x /= 2;
+    $x /= $two;
     }
-  return $x;
+  $x-- if $x * $x > $y;                                # overshot?
+  return $x->round($a,$p,$r);
   }
 
 sub exponent
@@ -1725,13 +1742,13 @@ sub _swap
   # args, hence the copy().
   # You can override this method in a subclass, the overload section will call
   # $object->_swap() to make sure it arrives at the proper subclass, with some
-  # exceptions like '+' and '-'.
+  # exceptions like '+' and '-'. To make '+' and '-' work, you also need to
+  # specify your own overload for them.
 
   # object, (object|scalar) => preserve first and make copy
   # scalar, object         => swapped, re-swap and create new from first
   #                            (using class of second object, not $class!!)
   my $self = shift;                    # for override in subclass
-  #print "swap $self 0:$_[0] 1:$_[1] 2:$_[2]\n";
   if ($_[2])
     {
     my $c = ref ($_[0]) || $class;     # fallback $class should not happen
@@ -1900,6 +1917,11 @@ sub __from_hex
   my $hs = shift;
 
   my $x = Math::BigInt->bzero();
+  
+  # strip underscores
+  $$hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;        
+  $$hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;        
+  
   return $x->bnan() if $$hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/;
 
   my $sign = '+'; $sign = '-' if ($$hs =~ /^-/);
@@ -1938,6 +1960,9 @@ sub __from_bin
   my $bs = shift;
 
   my $x = Math::BigInt->bzero();
+  # strip underscores
+  $$bs =~ s/([01])_([01])/$1$2/g;      
+  $$bs =~ s/([01])_([01])/$1$2/g;      
   return $x->bnan() if $$bs !~ /^[+-]?0b[01]+$/;
 
   my $mul = Math::BigInt->bzero(); $mul++;
@@ -1959,9 +1984,9 @@ sub __from_bin
       $val = substr($$bs,$i,8);
       $val =~ s/^[+-]?0b// if $len == 0;       # for last part only
       #$val = oct('0b'.$val);  # does not work on Perl prior to 5.6.0
-      $val = ('0' x (8-CORE::length($val))).$val if CORE::length($val) < 8;
-      $val = ord(pack('B8',$val));
-      # print "$val ",substr($$bs,$i,16),"\n";
+      # slower:
+      # $val = ('0' x (8-CORE::length($val))).$val if CORE::length($val) < 8;
+      $val = ord(pack('B8',substr('00000000'.$val,-8,8)));
       $i -= 8; $len --;
       $x += $mul * $val if $val != 0;
       $mul *= $x256 if $len >= 0;              # skip last mul
@@ -1994,11 +2019,12 @@ sub _split
   # invalid starting char?
   return if $$x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/;
 
-  $$x =~ s/(\d)_(\d)/$1$2/g;           # strip underscores between digits
-  $$x =~ s/(\d)_(\d)/$1$2/g;           # do twice for 1_2_3
-  
   return __from_hex($x) if $$x =~ /^[\-\+]?0x/;        # hex string
   return __from_bin($x) if $$x =~ /^[\-\+]?0b/;        # binary string
+  
+  # strip underscores between digits
+  $$x =~ s/(\d)_(\d)/$1$2/g;
+  $$x =~ s/(\d)_(\d)/$1$2/g;           # do twice for 1_2_3
 
   # some possible inputs: 
   # 2.1234 # 0.12        # 1         # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2 
@@ -2685,13 +2711,12 @@ numerical sense, e.g. $m might get minimized.
 
 =head1 EXAMPLES
  
-  use Math::BigInt qw(bstr);
+  use Math::BigInt;
 
   sub bint { Math::BigInt->new(shift); }
 
-  $x = bstr("1234")                    # string "1234"
+  $x = Math::BigInt->bstr("1234")              # string "1234"
   $x = "$x";                           # same as bstr()
-  $x = bneg("1234")                    # Bigint "-1234"
   $x = Math::BigInt->bneg("1234");     # Bigint "-1234"
   $x = Math::BigInt->babs("-12345");   # Bigint "12345"
   $x = Math::BigInt->bnorm("-0 00");   # BigInt "0"
@@ -2701,10 +2726,9 @@ numerical sense, e.g. $m might get minimized.
   $x = $x + 5 / 2;                     # BigInt "3"
   $x = $x ** 3;                        # BigInt "27"
   $x *= 2;                             # BigInt "54"
-  $x = new Math::BigInt;               # BigInt "0"
+  $x = Math::BigInt->new(0);           # BigInt "0"
   $x--;                                # BigInt "-1"
   $x = Math::BigInt->badd(4,5)         # BigInt "9"
-  $x = Math::BigInt::badd(4,5)         # BigInt "9"
   print $x->bsstr();                   # 9e+0
 
 Examples for rounding:
@@ -2714,22 +2738,22 @@ Examples for rounding:
 
   $x = Math::BigFloat->new(123.4567);
   $y = Math::BigFloat->new(123.456789);
-  $Math::BigFloat::accuracy = 4;       # no more A than 4
+  Math::BigFloat->accuracy(4);         # no more A than 4
 
   ok ($x->copy()->fround(),123.4);     # even rounding
   print $x->copy()->fround(),"\n";     # 123.4
   Math::BigFloat->round_mode('odd');   # round to odd
   print $x->copy()->fround(),"\n";     # 123.5
-  $Math::BigFloat::accuracy = 5;       # no more A than 5
+  Math::BigFloat->accuracy(5);         # no more A than 5
   Math::BigFloat->round_mode('odd');   # round to odd
   print $x->copy()->fround(),"\n";     # 123.46
   $y = $x->copy()->fround(4),"\n";     # A = 4: 123.4
   print "$y, ",$y->accuracy(),"\n";    # 123.4, 4
 
-  $Math::BigFloat::accuracy = undef;    # A not important
-  $Math::BigFloat::precision = 2;       # P important
-  print $x->copy()->bnorm(),"\n";       # 123.46
-  print $x->copy()->fround(),"\n";      # 123.46
+  Math::BigFloat->accuracy(undef);     # A not important now
+  Math::BigFloat->precision(2);        # P important
+  print $x->copy()->bnorm(),"\n";      # 123.46
+  print $x->copy()->fround(),"\n";     # 123.46
 
 Examples for converting:
 
@@ -2760,7 +2784,15 @@ so that
                + '123456789123456789';
 
 do not work. You need an explicit Math::BigInt->new() around one of the
-operands.
+operands. You should also quote large constants to protect loss of precision:
+
+       use Math::Bigint;
+
+       $x = Math::BigInt->new('1234567889123456789123456789123456789');
+
+Without the quotes Perl would convert the large number to a floating point
+constant at compile time and then hand the result to BigInt, which results in
+an truncated result or a NaN.
 
 =head1 PERFORMANCE
 
@@ -2772,12 +2804,20 @@ $x += $y is MUCH faster than $x = $x + $y since making the copy of $x takes
 more time then the actual addition.
 
 With a technique called copy-on-write, the cost of copying with overload could
-be minimized or even completely avoided. This is currently not implemented.
+be minimized or even completely avoided. A test implementation of COW did show
+performance gains for overloaded math, but introduced a performance loss due
+to a constant overhead for all other operatons.
+
+The rewritten version of this module is slower on certain operations, like
+new(), bstr() and numify(). The reason are that it does now more work and
+handles more cases. The time spent in these operations is usually gained in
+the other operations so that programs on the average should get faster. If
+they don't, please contect the author.
 
-The new version of this module is slower on new(), bstr() and numify(). Some
-operations may be slower for small numbers, but are significantly faster for
-big numbers. Other operations are now constant (O(1), like bneg(), babs()
-etc), instead of O(N) and thus nearly always take much less time.
+Some operations may be slower for small numbers, but are significantly faster
+for big numbers. Other operations are now constant (O(1), like bneg(), babs()
+etc), instead of O(N) and thus nearly always take much less time. These
+optimizations were done on purpose.
 
 If you find the Calc module to slow, try to install any of the replacement
 modules and see if they help you. 
@@ -2788,20 +2828,9 @@ You can use an alternative library to drive Math::BigInt via:
 
        use Math::BigInt lib => 'Module';
 
-The default is called Math::BigInt::Calc and is a pure-perl implementation
-that consists mainly of the standard routine present in earlier versions of
-Math::BigInt.
-
-There are also Math::BigInt::Scalar (primarily for testing) and
-Math::BigInt::BitVect; as well as Math::BigInt::Pari and likely others.
-All these can be found via L<http://search.cpan.org/>:
-
-       use Math::BigInt lib => 'BitVect';
-
-       my $x = Math::BigInt->new(2);
-       print $x ** (1024*1024);
+See L<MATH LIBRARY> for more information.
 
-For more benchmark results see http://bloodgate.com/perl/benchmarks.html
+For more benchmark results see L<http://bloodgate.com/perl/benchmarks.html>.
 
 =head1 BUGS
 
@@ -2879,8 +2908,9 @@ as 1e+308. If in doubt, convert both arguments to Math::BigInt before doing eq:
        $y = Math::BigInt->new($y);
        ok ($x,$y);                     # okay
 
-There is not yet a way to get a number automatically represented in exactly
-the way Perl represents it.
+Alternatively, simple use <=> for comparisations, that will get it always
+right. There is not yet a way to get a number automatically represented as
+a string that matches exactly the way Perl represents it.
 
 =item int()
 
@@ -3053,7 +3083,8 @@ since overload calls C<sub($x,0,1);> instead of C<neg($x)>. The first variant
 needs to preserve $x since it does not know that it later will get overwritten.
 This makes a copy of $x and takes O(N), but $x->bneg() is O(1).
 
-With Copy-On-Write, this issue will be gone. Stay tuned...
+With Copy-On-Write, this issue would be gone, but C-o-W is not implemented
+since it is slower for all other things.
 
 =item Mixing different object types
 
@@ -3080,7 +3111,7 @@ With overloaded math, only the first two variants will result in a BigFloat:
        $integer = $mbi2 / $mbf;        # $mbi2->bdiv()
 
 This is because math with overloaded operators follows the first (dominating)
-operand, this one's operation is called and returns thus the result. So,
+operand, and the operation of that is called and returns thus the result. So,
 Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether
 the result should be a Math::BigFloat or the second operant is one.
 
@@ -3114,18 +3145,18 @@ This section also applies to other overloaded math packages, like Math::String.
 
 =item bsqrt()
 
-C<bsqrt()> works only good if the result is an big integer, e.g. the square
+C<bsqrt()> works only good if the result is a big integer, e.g. the square
 root of 144 is 12, but from 12 the square root is 3, regardless of rounding
 mode.
 
 If you want a better approximation of the square root, then use:
 
        $x = Math::BigFloat->new(12);
-       $Math::BigFloat::precision = 0;
+       Math::BigFloat->precision(0);
        Math::BigFloat->round_mode('even');
        print $x->copy->bsqrt(),"\n";           # 4
 
-       $Math::BigFloat::precision = 2;
+       Math::BigFloat->precision(2);
        print $x->bsqrt(),"\n";                 # 3.46
        print $x->bsqrt(3),"\n";                # 3.464
 
index ba7483f..9424143 100644 (file)
@@ -8,7 +8,7 @@ require Exporter;
 use vars qw/@ISA $VERSION/;
 @ISA = qw(Exporter);
 
-$VERSION = '0.16';
+$VERSION = '0.17';
 
 # Package to store unsigned big integers in decimal and do math with them
 
@@ -30,35 +30,55 @@ $VERSION = '0.16';
  
 # constants for easier life
 my $nan = 'NaN';
-my ($BASE,$RBASE,$BASE_LEN,$MAX_VAL);
+my ($BASE,$RBASE,$BASE_LEN,$MAX_VAL,$BASE_LEN2);
+my ($AND_BITS,$XOR_BITS,$OR_BITS);
+my ($AND_MASK,$XOR_MASK,$OR_MASK);
 
 sub _base_len 
   {
   # set/get the BASE_LEN and assorted other, connected values
   # used only be the testsuite, set is used only by the BEGIN block below
+  shift;
+
   my $b = shift;
   if (defined $b)
     {
-    $b = 8 if $b > 8;                  # cap, for VMS, OS/390 and other 64 bit
-    $BASE_LEN = $b;
+    $b = 5 if $^O =~ /^uts/;   # UTS needs 5, because 6 and 7 break
+    $BASE_LEN = $b+1;
+    my $caught;
+    while (--$BASE_LEN > 5)
+      {
+      $BASE = int("1e".$BASE_LEN);
+      $RBASE = abs('1e-'.$BASE_LEN);                   # see USE_MUL
+      $caught = 0;
+      $caught += 1 if (int($BASE * $RBASE) != 1);      # should be 1
+      $caught += 2 if (int($BASE / $BASE) != 1);       # should be 1
+      # print "caught $caught\n";
+      last if $caught != 3;
+      }
     $BASE = int("1e".$BASE_LEN);
-    $RBASE = abs('1e-'.$BASE_LEN);     # see USE_MUL
+    $RBASE = abs('1e-'.$BASE_LEN);                     # see USE_MUL
     $MAX_VAL = $BASE-1;
-    # print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL\n";
-    # print "int: ",int($BASE * $RBASE),"\n";
-    if (int($BASE * $RBASE) == 0)              # should be 1
+    $BASE_LEN2 = int($BASE_LEN / 2);                   # for mul shortcut
+    # print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL BASE: $BASE RBASE: $RBASE\n";
+    
+    if ($caught & 1 != 0)
       {
       # must USE_MUL
       *{_mul} = \&_mul_use_mul;
       *{_div} = \&_div_use_mul;
       }
-    else
+    else               # $caught must be 2, since it can't be 1 nor 3
       {
       # can USE_DIV instead
       *{_mul} = \&_mul_use_div;
       *{_div} = \&_div_use_div;
       }
     }
+  if (wantarray)
+    {
+    return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS);
+    }
   $BASE_LEN;
   }
 
@@ -71,11 +91,50 @@ BEGIN
   do 
     {
     $num = ('9' x ++$e) + 0;
-    $num *= $num + 1;
+    $num *= $num + 1.0;
     # print "$num $e\n";
-    } while ("$num" =~ /9{$e}0{$e}/);          # must be a certain pattern
-  # last test failed, so retract one step:
-  _base_len($e-1);
+    } while ("$num" =~ /9{$e}0{$e}/);  # must be a certain pattern
+  $e--;                                # last test failed, so retract one step
+  # the limits below brush the problems with the test above under the rug:
+  # the test should be able to find the proper $e automatically
+  $e = 5 if $^O =~ /^uts/;     # UTS get's some special treatment
+  $e = 5 if $^O =~ /^unicos/;  # unicos is also problematic (6 seems to work
+                               # there, but we play safe)
+  $e = 8 if $e > 8;            # cap, for VMS, OS/390 and other 64 bit systems
+
+  __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.
+  use integer;
+  local $^W = 0;       # don't warn about 'nonportable number'
+  $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS  = 15;
+
+  # find max bits, we will not go higher than numberofbits that fit into $BASE
+  # to make _and etc simpler (and faster for smaller, slower for large numbers)
+  my $max = 16;
+  while (2 ** $max < $BASE) { $max++; }
+  my ($x,$y,$z);
+  do {
+    $AND_BITS++;
+    $x = oct('0b' . '1' x $AND_BITS); $y = $x & $x;
+    $z = (2 ** $AND_BITS) - 1;
+    } while ($AND_BITS < $max && $x == $z && $y == $x);
+  $AND_BITS --;                                                # retreat one step
+  do {
+    $XOR_BITS++;
+    $x = oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0;
+    $z = (2 ** $XOR_BITS) - 1;
+    } while ($XOR_BITS < $max && $x == $z && $y == $x);
+  $XOR_BITS --;                                                # retreat one step
+  do {
+    $OR_BITS++;
+    $x = oct('0b' . '1' x $OR_BITS); $y = $x | $x;
+    $z = (2 ** $OR_BITS) - 1;
+    } while ($OR_BITS < $max && $x == $z && $y == $x);
+  $OR_BITS --;                                         # retreat one step
+  
+  # print "AND $AND_BITS XOR $XOR_BITS OR $OR_BITS\n";
   }
 
 ##############################################################################
@@ -83,7 +142,7 @@ BEGIN
 
 sub _new
   {
-  # (string) return ref to num_array
+  # (ref to string) return ref to num_array
   # Convert a number from string format to internal base 100000 format.
   # Assumes normalized value as input.
   my $d = $_[1];
@@ -92,6 +151,13 @@ sub _new
   return [ reverse(unpack("a" . ($il % $BASE_LEN+1) 
     . ("a$BASE_LEN" x ($il / $BASE_LEN)), $$d)) ];
   }                                                                             
+  
+BEGIN
+  {
+  $AND_MASK = __PACKAGE__->_new( \( 2 ** $AND_BITS ));
+  $XOR_MASK = __PACKAGE__->_new( \( 2 ** $XOR_BITS ));
+  $OR_MASK = __PACKAGE__->_new( \( 2 ** $OR_BITS ));
+  }
 
 sub _zero
   {
@@ -241,23 +307,18 @@ sub _sub
       $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
       }
     # might leave leading zeros, so fix that
-    __strip_zeros($sx);
-    return $sx;                                                                 
+    return __strip_zeros($sx);
     }
-  else
+  #print "case 1 (swap)\n";
+  for $i (@$sx)
     {
-    #print "case 1 (swap)\n";
-    for $i (@$sx)
-      {
-      last unless defined $sy->[$j] || $car;
-      $sy->[$j] += $BASE
-       if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
-      $j++;
-      }
-    # might leave leading zeros, so fix that
-    __strip_zeros($sy);
-    return $sy;
+    last unless defined $sy->[$j] || $car;
+    $sy->[$j] += $BASE
+     if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
+    $j++;
     }
+  # might leave leading zeros, so fix that
+  __strip_zeros($sy);
   }                                                                             
 
 sub _mul_use_mul
@@ -267,6 +328,16 @@ sub _mul_use_mul
   # modifies first arg, second need not be different from first
   my ($c,$xv,$yv) = @_;
 
+  # shortcut for two very short numbers
+  # +0 since part maybe string '00001' from new()
+  if ((@$xv == 1) && (@$yv == 1)
+   && (length($xv->[0]+0) <= $BASE_LEN2)
+   && (length($yv->[0]+0) <= $BASE_LEN2))
+   {
+   $xv->[0] *= $yv->[0];
+   return $xv;
+   }
+  
   my @prod = (); my ($prod,$car,$cty,$xi,$yi);
   # since multiplying $x with $x fails, make copy in this case
   $yv = [@$xv] if "$xv" eq "$yv";      # same references?
@@ -300,8 +371,6 @@ sub _mul_use_mul
     }
   push @$xv, @prod;
   __strip_zeros($xv);
-  # normalize (handled last to save check for $y->is_zero()
-  return $xv;
   }                                                                             
 
 sub _mul_use_div
@@ -311,6 +380,16 @@ sub _mul_use_div
   # modifies first arg, second need not be different from first
   my ($c,$xv,$yv) = @_;
  
+  # shortcut for two very short numbers
+  # +0 since part maybe string '00001' from new()
+  if ((@$xv == 1) && (@$yv == 1)
+   && (length($xv->[0]+0) <= $BASE_LEN2)
+   && (length($yv->[0]+0) <= $BASE_LEN2))
+   {
+   $xv->[0] *= $yv->[0];
+   return $xv;
+   }
+  
   my @prod = (); my ($prod,$car,$cty,$xi,$yi);
   # since multiplying $x with $x fails, make copy in this case
   $yv = [@$xv] if "$xv" eq "$yv";      # same references?
@@ -330,15 +409,12 @@ sub _mul_use_div
     }
   push @$xv, @prod;
   __strip_zeros($xv);
-  # normalize (handled last to save check for $y->is_zero()
-  return $xv;
   }                                                                             
 
 sub _div_use_mul
   {
   # ref to array, ref to array, modify first array and return remainder if 
   # in list context
-  # no longer handles sign
   my ($c,$x,$yorg) = @_;
   my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1);
 
@@ -417,18 +493,19 @@ sub _div_use_mul
     @$x = @q;
     __strip_zeros($x); 
     __strip_zeros(\@d);
+    _check('',$x);
+    _check('',\@d);
     return ($x,\@d);
     }
   @$x = @q;
   __strip_zeros($x); 
-  return $x;
+    _check('',$x);
   }
 
 sub _div_use_div
   {
   # ref to array, ref to array, modify first array and return remainder if 
   # in list context
-  # no longer handles sign
   my ($c,$x,$yorg) = @_;
   my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1);
 
@@ -511,9 +588,193 @@ sub _div_use_div
     }
   @$x = @q;
   __strip_zeros($x); 
-  return $x;
   }
 
+##############################################################################
+# testing
+
+sub _acmp
+  {
+  # internal absolute post-normalized compare (ignore signs)
+  # ref to array, ref to array, return <0, 0, >0
+  # arrays must have at least one entry; this is not checked for
+
+  my ($c,$cx,$cy) = @_;
+
+  # fat comp based on array elements
+  my $lxy = scalar @$cx - scalar @$cy;
+  return -1 if $lxy < 0;                               # already differs, ret
+  return 1 if $lxy > 0;                                        # ditto
+  
+  # now calculate length based on digits, not parts
+  $lxy = _len($c,$cx) - _len($c,$cy);                  # difference
+  return -1 if $lxy < 0;
+  return 1 if $lxy > 0;
+
+  # hm, same lengths,  but same contents?
+  my $i = 0; my $a;
+  # first way takes 5.49 sec instead of 4.87, but has the early out advantage
+  # so grep is slightly faster, but more inflexible. hm. $_ instead of $k
+  # yields 5.6 instead of 5.5 sec huh?
+  # manual way (abort if unequal, good for early ne)
+  my $j = scalar @$cx - 1;
+  while ($j >= 0)
+   {
+   last if ($a = $cx->[$j] - $cy->[$j]); $j--;
+   }
+  return 1 if $a > 0;
+  return -1 if $a < 0;
+  return 0;                                    # equal
+  # while it early aborts, it is even slower than the manual variant
+  #grep { return $a if ($a = $_ - $cy->[$i++]); } @$cx;
+  # grep way, go trough all (bad for early ne)
+  #grep { $a = $_ - $cy->[$i++]; } @$cx;
+  #return $a;
+  }
+
+sub _len
+  {
+  # compute number of digits in bigint, minus the sign
+
+  # int() because add/sub sometimes leaves strings (like '00005') instead of
+  # '5' in this place, thus causing length() to report wrong length
+  my $cx = $_[1];
+
+  return (@$cx-1)*$BASE_LEN+length(int($cx->[-1]));
+  }
+
+sub _digit
+  {
+  # return the nth digit, negative values count backward
+  # zero is rightmost, so _digit(123,0) will give 3
+  my ($c,$x,$n) = @_;
+
+  my $len = _len('',$x);
+
+  $n = $len+$n if $n < 0;              # -1 last, -2 second-to-last
+  $n = abs($n);                                # if negative was too big
+  $len--; $n = $len if $n > $len;      # n to big?
+  
+  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
+  return substr($elem,-$digit-1,1);
+  }
+
+sub _zeros
+  {
+  # return amount of trailing zeros in decimal
+  # check each array elem in _m for having 0 at end as long as elem == 0
+  # Upon finding a elem != 0, stop
+  my $x = $_[1];
+  my $zeros = 0; my $elem;
+  foreach my $e (@$x)
+    {
+    if ($e != 0)
+      {
+      $elem = "$e";                            # preserve x
+      $elem =~ s/.*?(0*$)/$1/;                 # strip anything not zero
+      $zeros *= $BASE_LEN;                     # elems * 5
+      $zeros += CORE::length($elem);           # count trailing zeros
+      last;                                    # early out
+      }
+    $zeros ++;                                 # real else branch: 50% slower!
+    }
+  return $zeros;
+  }
+
+##############################################################################
+# _is_* routines
+
+sub _is_zero
+  {
+  # return true if arg (BINT or num_str) is zero (array '+', '0')
+  my $x = $_[1];
+  return (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0;
+  }
+
+sub _is_even
+  {
+  # return true if arg (BINT or num_str) is even
+  my $x = $_[1];
+  return (!($x->[0] & 1)) <=> 0; 
+  }
+
+sub _is_odd
+  {
+  # return true if arg (BINT or num_str) is even
+  my $x = $_[1];
+  return (($x->[0] & 1)) <=> 0; 
+  }
+
+sub _is_one
+  {
+  # return true if arg (BINT or num_str) is one (array '+', '1')
+  my $x = $_[1];
+  return (scalar @$x == 1) && ($x->[0] == 1) <=> 0; 
+  }
+
+sub __strip_zeros
+  {
+  # internal normalization function that strips leading zeros from the array
+  # args: ref to array
+  my $s = shift;
+  my $cnt = scalar @$s; # get count of parts
+  my $i = $cnt-1;
+  push @$s,0 if $i < 0;                # div might return empty results, so fix it
+
+  #print "strip: cnt $cnt i $i\n";
+  # '0', '3', '4', '0', '0',
+  #  0    1    2    3    4
+  # cnt = 5, i = 4
+  # i = 4
+  # i = 3
+  # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
+  # >= 1: skip first part (this can be zero)
+  while ($i > 0) { last if $s->[$i] != 0; $i--; }
+  $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
+  $s;                                                                    
+  }                                                                             
+
+###############################################################################
+# check routine to test internal state of corruptions
+
+sub _check
+  {
+  # used by the test suite
+  my $x = $_[1];
+
+  return "$x is not a reference" if !ref($x);
+
+  # are all parts are valid?
+  my $i = 0; my $j = scalar @$x; my ($e,$try);
+  while ($i < $j)
+    {
+    $e = $x->[$i]; $e = 'undef' unless defined $e;
+    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
+    last if $e !~ /^[+]?[0-9]+$/;
+    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)";
+    last if "$e" !~ /^[+]?[0-9]+$/;
+    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)";
+    last if '' . "$e" !~ /^[+]?[0-9]+$/;
+    $try = ' < 0 || >= $BASE; '."($x, $e)";
+    last if $e <0 || $e >= $BASE;
+    # this test is disabled, since new/bnorm and certain ops (like early out
+    # in add/sub) are allowed/expected to leave '00000' in some elements
+    #$try = '=~ /^00+/; '."($x, $e)";
+    #last if $e =~ /^00+/;
+    $i++;
+    }
+  return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
+  return 0;
+  }
+
+
+###############################################################################
+###############################################################################
+# some optional routines to make BigInt faster
+
 sub _mod
   {
   # if possible, use mod shortcut
@@ -672,179 +933,204 @@ sub _pow
   return $cx;
   }
 
-##############################################################################
-# testing
-
-sub _acmp
+sub _sqrt
   {
-  # internal absolute post-normalized compare (ignore signs)
-  # ref to array, ref to array, return <0, 0, >0
-  # arrays must have at least one entry; this is not checked for
+  # square-root of $x
+  # ref to array, return ref to array
+  my ($c,$x) = @_;
 
-  my ($c,$cx, $cy) = @_;
+  if (scalar @$x == 1)
+    {
+    # fit's into one Perl scalar
+    $x->[0] = int(sqrt($x->[0]));
+    return $x;
+    } 
+  my $y = _copy($c,$x);
+  my $l = [ _len($c,$x) / 2 ];
 
-  my ($i,$a,$x,$y,$k);
-  # calculate length based on digits, not parts
-  $x = _len('',$cx); $y = _len('',$cy);
-  my $lxy = $x - $y;                           # if different in length
-  return -1 if $lxy < 0;
-  return 1 if $lxy > 0;
-  $i = 0; $a = 0;
-  # first way takes 5.49 sec instead of 4.87, but has the early out advantage
-  # so grep is slightly faster, but more inflexible. hm. $_ instead of $k
-  # yields 5.6 instead of 5.5 sec huh?
-  # manual way (abort if unequal, good for early ne)
-  my $j = scalar @$cx - 1;
-  while ($j >= 0)
-   {
-   # print "$cx->[$j] $cy->[$j] $a",$cx->[$j]-$cy->[$j],"\n";
-   last if ($a = $cx->[$j] - $cy->[$j]); $j--;
-   }
-  return 1 if $a > 0;
-  return -1 if $a < 0;
-  return 0;                                    # equal
-  # while it early aborts, it is even slower than the manual variant
-  #grep { return $a if ($a = $_ - $cy->[$i++]); } @$cx;
-  # grep way, go trough all (bad for early ne)
-  #grep { $a = $_ - $cy->[$i++]; } @$cx;
-  #return $a;
-  }
+  splice @$x,0; $x->[0] = 1;   # keep ref($x), but modify it
 
-sub _len
-  {
-  # compute number of digits in bigint, minus the sign
-  # int() because add/sub sometimes leaves strings (like '00005') instead of
-  # int ('5') in this place, thus causing length() to report wrong length
-  my $cx = $_[1];
+  _lsft($c,$x,$l,10);
 
-  return (@$cx-1)*$BASE_LEN+length(int($cx->[-1]));
+  my $two = _two();
+  my $last = _zero();
+  my $lastlast = _zero();
+  while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0)
+    {
+    $lastlast = _copy($c,$last);
+    $last = _copy($c,$x);
+    _add($c,$x, _div($c,_copy($c,$y),$x));
+    _div($c,$x, $two );
+    }
+  _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0;    # overshot? 
+  $x;
   }
 
-sub _digit
-  {
-  # return the nth digit, negative values count backward
-  # zero is rightmost, so _digit(123,0) will give 3
-  my ($c,$x,$n) = @_;
+##############################################################################
+# binary stuff
 
-  my $len = _len('',$x);
+sub _and
+  {
+  my ($c,$x,$y) = @_;
 
-  $n = $len+$n if $n < 0;              # -1 last, -2 second-to-last
-  $n = abs($n);                                # if negative was too big
-  $len--; $n = $len if $n > $len;      # n to big?
+  # the shortcut makes equal, large numbers _really_ fast, and makes only a
+  # very small performance drop for small numbers (e.g. something with less
+  # than 32 bit) Since we optimize for large numbers, this is enabled.
+  return $x if _acmp($c,$x,$y) == 0;           # shortcut
   
-  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
-  return substr($elem,-$digit-1,1);
+  my $m = _one(); my ($xr,$yr);
+  my $mask = $AND_MASK;
+
+  my $x1 = $x;
+  my $y1 = _copy($c,$y);                       # make copy
+  $x = _zero();
+  my ($b,$xrr,$yrr);
+  use integer;
+  while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+    {
+    ($x1, $xr) = _div($c,$x1,$mask);
+    ($y1, $yr) = _div($c,$y1,$mask);
+
+    # make ints() from $xr, $yr
+    # this is when the AND_BITS are greater tahn $BASE and is slower for
+    # small (<256 bits) numbers, but faster for large numbers. Disabled
+    # due to KISS principle
+
+#    $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+#    $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+#    _add($c,$x, _mul($c, _new( $c, \($xrr & $yrr) ), $m) );
+    
+    _add($c,$x, _mul($c, [ $xr->[0] & $yr->[0] ], $m) );
+    _mul($c,$m,$mask);
+    }
+  $x;
   }
 
-sub _zeros
+sub _xor
   {
-  # return amount of trailing zeros in decimal
-  # check each array elem in _m for having 0 at end as long as elem == 0
-  # Upon finding a elem != 0, stop
-  my $x = $_[1];
-  my $zeros = 0; my $elem;
-  foreach my $e (@$x)
+  my ($c,$x,$y) = @_;
+
+  return _zero() if _acmp($c,$x,$y) == 0;      # shortcut (see -and)
+
+  my $m = _one(); my ($xr,$yr);
+  my $mask = $XOR_MASK;
+
+  my $x1 = $x;
+  my $y1 = _copy($c,$y);                       # make copy
+  $x = _zero();
+  my ($b,$xrr,$yrr);
+  use integer;
+  while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
     {
-    if ($e != 0)
-      {
-      $elem = "$e";                            # preserve x
-      $elem =~ s/.*?(0*$)/$1/;                 # strip anything not zero
-      $zeros *= $BASE_LEN;                     # elems * 5
-      $zeros += CORE::length($elem);           # count trailing zeros
-      last;                                    # early out
-      }
-    $zeros ++;                                 # real else branch: 50% slower!
+    ($x1, $xr) = _div($c,$x1,$mask);
+    ($y1, $yr) = _div($c,$y1,$mask);
+    # make ints() from $xr, $yr (see _and())
+    #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+    #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+    #_add($c,$x, _mul($c, _new( $c, \($xrr ^ $yrr) ), $m) );
+    
+    _add($c,$x, _mul($c, [ $xr->[0] ^ $yr->[0] ], $m) );
+    _mul($c,$m,$mask);
     }
-  return $zeros;
+  # the loop stops when the shorter of the two numbers is exhausted
+  # the remainder of the longer one will survive bit-by-bit, so we simple
+  # multiply-add it in
+  _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+  _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+  
+  $x;
   }
 
-##############################################################################
-# _is_* routines
-
-sub _is_zero
+sub _or
   {
-  # return true if arg (BINT or num_str) is zero (array '+', '0')
-  my $x = $_[1];
-  return (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0;
-  }
+  my ($c,$x,$y) = @_;
 
-sub _is_even
-  {
-  # return true if arg (BINT or num_str) is even
-  my $x = $_[1];
-  return (!($x->[0] & 1)) <=> 0; 
-  }
+  return $x if _acmp($c,$x,$y) == 0;           # shortcut (see _and)
 
-sub _is_odd
-  {
-  # return true if arg (BINT or num_str) is even
-  my $x = $_[1];
-  return (($x->[0] & 1)) <=> 0; 
-  }
+  my $m = _one(); my ($xr,$yr);
+  my $mask = $OR_MASK;
 
-sub _is_one
-  {
-  # return true if arg (BINT or num_str) is one (array '+', '1')
-  my $x = $_[1];
-  return (scalar @$x == 1) && ($x->[0] == 1) <=> 0; 
+  my $x1 = $x;
+  my $y1 = _copy($c,$y);                       # make copy
+  $x = _zero();
+  my ($b,$xrr,$yrr);
+  use integer;
+  while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+    {
+    ($x1, $xr) = _div($c,$x1,$mask);
+    ($y1, $yr) = _div($c,$y1,$mask);
+    # make ints() from $xr, $yr (see _and())
+#    $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+#    $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+#    _add($c,$x, _mul($c, _new( $c, \($xrr | $yrr) ), $m) );
+    
+    _add($c,$x, _mul($c, [ $xr->[0] | $yr->[0] ], $m) );
+    _mul($c,$m,$mask);
+    }
+  # the loop stops when the shorter of the two numbers is exhausted
+  # the remainder of the longer one will survive bit-by-bit, so we simple
+  # multiply-add it in
+  _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+  _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+  
+  $x;
   }
 
-sub __strip_zeros
+sub _from_hex
   {
-  # internal normalization function that strips leading zeros from the array
-  # args: ref to array
-  my $s = shift;
-  my $cnt = scalar @$s; # get count of parts
-  my $i = $cnt-1;
-  #print "strip: cnt $cnt i $i\n";
-  # '0', '3', '4', '0', '0',
-  #  0    1    2    3    4
-  # cnt = 5, i = 4
-  # i = 4
-  # i = 3
-  # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
-  # >= 1: skip first part (this can be zero)
-  while ($i > 0) { last if $s->[$i] != 0; $i--; }
-  $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
-  return $s;                                                                    
-  }                                                                             
+  # convert a hex number to decimal (ref to string, return ref to array)
+  my ($c,$hs) = @_;
 
-###############################################################################
-# check routine to test internal state of corruptions
+  my $mul = _one();
+  my $m = [ 0x10000 ];                         # 16 bit at a time
+  my $x = _zero();
 
-sub _check
+  my $len = CORE::length($$hs)-2;
+  $len = int($len/4);                          # 4-digit parts, w/o '0x'
+  my $val; my $i = -4;
+  while ($len >= 0)
+    {
+    $val = substr($$hs,$i,4);
+    $val =~ s/^[+-]?0x// if $len == 0;         # for last part only because
+    $val = hex($val);                          # hex does not like wrong chars
+    $i -= 4; $len --;
+    _add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0;
+    _mul ($c, $mul, $m ) if $len >= 0;                 # skip last mul
+    }
+  $x;
+  }
+
+sub _from_bin
   {
-  # used by the test suite
-  my $x = $_[1];
+  # convert a hex number to decimal (ref to string, return ref to array)
+  my ($c,$bs) = @_;
 
-  return "$x is not a reference" if !ref($x);
+  my $mul = _one();
+  my $m = [ 0x100 ];                           # 8 bit at a time
+  my $x = _zero();
 
-  # are all parts are valid?
-  my $i = 0; my $j = scalar @$x; my ($e,$try);
-  while ($i < $j)
+  my $len = CORE::length($$bs)-2;
+  $len = int($len/8);                          # 4-digit parts, w/o '0x'
+  my $val; my $i = -8;
+  while ($len >= 0)
     {
-    $e = $x->[$i]; $e = 'undef' unless defined $e;
-    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
-    last if $e !~ /^[+]?[0-9]+$/;
-    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)";
-    last if "$e" !~ /^[+]?[0-9]+$/;
-    $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)";
-    last if '' . "$e" !~ /^[+]?[0-9]+$/;
-    $try = ' < 0 || >= $BASE; '."($x, $e)";
-    last if $e <0 || $e >= $BASE;
-    # this test is disabled, since new/bnorm and certain ops (like early out
-    # in add/sub) are allowed/expected to leave '00000' in some elements
-    #$try = '=~ /^00+/; '."($x, $e)";
-    #last if $e =~ /^00+/;
-    $i++;
+    $val = substr($$bs,$i,8);
+    $val =~ s/^[+-]?0b// if $len == 0;         # for last part only
+
+    #$val = oct('0b'.$val);   # does not work on Perl prior to 5.6.0
+    # $val = ('0' x (8-CORE::length($val))).$val if CORE::length($val) < 8;
+    $val = ord(pack('B8',substr('00000000'.$val,-8,8))); 
+
+    $i -= 8; $len --;
+    _add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0;
+    _mul ($c, $mul, $m ) if $len >= 0;                 # skip last mul
     }
-  return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
-  return 0;
+  $x;
   }
 
+##############################################################################
+##############################################################################
+
 1;
 __END__
 
@@ -939,7 +1225,7 @@ slow) fallback routines to emulate these:
        _or(obj1,obj2)  OR (bit-wise) object 1 with object 2
 
        _mod(obj,obj)   Return remainder of div of the 1st by the 2nd object
-       _sqrt(obj)      return the square root of object
+       _sqrt(obj)      return the square root of object (truncate to int)
        _pow(obj,obj)   return object 1 to the power of object 2
        _gcd(obj,obj)   return Greatest Common Divisor of two objects
        
diff --git a/lib/Math/BigInt/t/bare_mbi.t b/lib/Math/BigInt/t/bare_mbi.t
new file mode 100644 (file)
index 0000000..03aed46
--- /dev/null
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -w
+
+use Test;
+use strict;
+
+BEGIN
+  {
+  $| = 1;
+  # to locate the testing files
+  my $location = $0; $location =~ s/bare_mbi.t//i;
+  print "loc $location\n";
+  if ($ENV{PERL_CORE})
+    {
+    # testing with the core distribution
+    @INC = qw(../t/lib);
+    }
+  unshift @INC, qw(../lib);    # to locate the modules
+  if (-d 't')
+    {
+    chdir 't';
+    require File::Spec;
+    unshift @INC, File::Spec->catdir(File::Spec->updir, $location);
+    }
+  else
+    {
+    unshift @INC, $location;
+    }
+  print "# INC = @INC\n";
+
+  plan tests => 1865;
+  }
+
+use Math::BigInt lib => 'BareCalc';
+
+use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL);
+$class = "Math::BigInt";
+$CL = "Math::BigInt::BareCalc";
+
+my $version = '1.48';   # for $VERSION tests, match current release (by hand!)
+
+require 'bigintpm.inc';        # perform same tests as bigintpm
+
index 7844e72..b61af2a 100644 (file)
@@ -54,7 +54,7 @@ while (<DATA>)
         $try .= "\$x->length();";
       # some unary ops (test the bxxx form, since that is done by AUTOLOAD)
       } elsif ($f =~ /^f(nan|sstr|neg|floor|ceil|abs)$/) {
-        $try .= "\$x->b$1();";
+        $try .= "\$x->f$1();";
       # some is_xxx test function      
       } elsif ($f =~ /^is_(zero|one|negative|positive|odd|even|nan)$/) {
         $try .= "\$x->$f();";
@@ -88,6 +88,10 @@ while (<DATA>)
         $try .= '$x * $y;';
       } elsif ($f eq "fdiv") {
         $try .= "$setup; \$x / \$y;";
+      } elsif ($f eq "frsft") {
+        $try .= '$x >> $y;';
+      } elsif ($f eq "flsft") {
+        $try .= '$x << $y;';
       } elsif ($f eq "fmod") {
         $try .= '$x % $y;';
       } else { warn "Unknown op '$f'"; }
@@ -128,7 +132,8 @@ while (<DATA>)
     }
   } # end while
 
-# check whether new() for BigInts destroys them ($y == 12 in this case)
+# check whether $class->new( Math::BigInt->new()) destroys it 
+# ($y == 12 in this case)
 $x = Math::BigInt->new(1200); $y = $class->new($x);
 ok ($y,1200); ok ($x,1200);
 
@@ -141,7 +146,12 @@ ok ($x,'NaN'); ok ($y,'NaN');
 $x = $class->bzero(); ($x,$y) = $x->fdiv(1);
 ok ($x,0); ok ($y,0);
 
-# all done
+$x = $class->new(2); $x->fzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->finf();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->fone();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->fnan();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+
+1; # all done
 
 ###############################################################################
 # Perl 5.005 does not like ok ($x,undef)
@@ -155,6 +165,21 @@ sub ok_undef
   }
 
 __DATA__
+&frsft
+#NaNfrsft:NaN
+0:2:0
+1:1:0.5
+2:1:1
+4:1:2
+123:1:61.5
+32:3:4
+&flsft
+#NaNflsft:NaN
+2:1:4
+4:3:32
+5:3:40
+1:2:4
+0:5:0
 &fnorm
 1:1
 -0:0
@@ -867,6 +892,7 @@ abc:+1:abc:NaN
 +106500000:+339:314159.2920353982300884955752212389380531
 +1000000000:+3:333333333.3333333333333333333333333333333
 2:25.024996000799840031993601279744051189762:0.07992009269196593320152084692285869265447
+123456:1:123456
 $div_scale = 20
 +1000000000:+9:111111111.11111111111
 +2000000000:+9:222222222.22222222222
@@ -883,6 +909,7 @@ $div_scale = 20
 1:10000:0.0001
 1:504:0.001984126984126984127
 2:1.987654321:1.0062111801179738436
+123456789.123456789123456789123456789:1:123456789.12345678912
 # the next two cases are the "old" behaviour, but are now (>v0.01) different
 #+35500000:+113:314159.292035398230088
 #+71000000:+226:314159.292035398230088
@@ -893,6 +920,7 @@ $div_scale = 20
 $div_scale = 1
 # round to accuracy 1 after bdiv
 +124:+3:40
+123456789.1234:1:100000000
 # reset scale for further tests
 $div_scale = 40
 &fmod
@@ -913,14 +941,18 @@ $div_scale = 40
 nanfsqrt:NaN
 +inf:inf
 -inf:NaN
-+1:1
-+2:1.41421356237309504880168872420969807857
-+4:2
-+16:4
-+100:10
-+123.456:11.11107555549866648462149404118219234119
-+15241.38393:123.4559999756998444766131352122991626468
-+1.44:1.2
+1:1
+2:1.41421356237309504880168872420969807857
+4:2
+9:3
+16:4
+100:10
+123.456:11.11107555549866648462149404118219234119
+15241.38393:123.4559999756998444766131352122991626468
+1.44:1.2
+# sqrt(1.44) = 1.2, sqrt(e10) = e5 => 12e4
+1.44E10:120000
+2e10:141421.356237309504880168872420969807857
 &is_nan
 123:0
 abc:1
index 5fe1917..c31d7f1 100755 (executable)
@@ -31,7 +31,7 @@ BEGIN
 #  unshift @INC, $location; # to locate the testing files
 #  # chdir 't' if -d 't';
 
-  plan tests => 1325;
+  plan tests => 1367;
   }
 
 use Math::BigInt;
index 87006b0..05b5fcc 100644 (file)
@@ -8,7 +8,7 @@ BEGIN
   $| = 1;
   chdir 't' if -d 't';
   unshift @INC, '../lib'; # for running manually
-  plan tests => 56;
+  plan tests => 63;
   }
 
 # testing of Math::BigInt::Calc, primarily for interface/api and not for the
@@ -128,6 +128,24 @@ $x = $C->_new(\$x); $C->_dec($x); ok (${$C->_str($x)},$z);
 # should not happen:
 # $x = $C->_new(\"-2"); $y = $C->_new(\"4"); ok ($C->_acmp($x,$y),-1);
 
+# _mod
+$x = $C->_new(\"1000"); $y = $C->_new(\"3");
+ok (${$C->_str(scalar $C->_mod($x,$y))},1);
+$x = $C->_new(\"1000"); $y = $C->_new(\"2");
+ok (${$C->_str(scalar $C->_mod($x,$y))},0);
+
+# _and, _or, _xor
+$x = $C->_new(\"5"); $y = $C->_new(\"2");
+ok (${$C->_str(scalar $C->_xor($x,$y))},7);
+$x = $C->_new(\"5"); $y = $C->_new(\"2");
+ok (${$C->_str(scalar $C->_or($x,$y))},7);
+$x = $C->_new(\"5"); $y = $C->_new(\"3");
+ok (${$C->_str(scalar $C->_and($x,$y))},1);
+
+# _from_hex, _from_bin
+ok (${$C->_str(scalar $C->_from_hex(\"0xFf"))},255);
+ok (${$C->_str(scalar $C->_from_bin(\"0b10101011"))},160+11);
+
 # _check
 $x = $C->_new(\"123456789");
 ok ($C->_check($x),0);
index e85c5c3..ad55d68 100644 (file)
@@ -35,7 +35,7 @@ sub _swap
 ##############################################################################
 package main;
 
-my $CALC = $class->_core_lib(); ok ($CALC,'Math::BigInt::Calc');
+my $CALC = $class->_core_lib(); ok ($CALC,$CL);
 
 my ($f,$z,$a,$exp,@a,$m,$e,$round_mode);
 
@@ -165,9 +165,16 @@ while (<DATA>)
         $try = "\$x = $class->new(\"$args[0]\"); \$x->digit($args[1]);";
       } else { warn "Unknown op '$f'"; }
     }
-    # print "trying $try\n";
+    print "trying $try\n";
     $ans1 = eval $try;
-    $ans =~ s/^[+]([0-9])/$1/;                 # remove leading '+' 
+    # remove leading '+' from target
+    $ans =~ s/^[+]([0-9])/$1/;                 
+    # convert hex/binary targets to decimal    
+    if ($ans =~ /^(0x0x|0b0b)/)
+      {
+      $ans =~ s/^0[xb]//;
+      $ans = Math::BigInt->new($ans)->bstr();
+      }
     if ($ans eq "")
       {
       ok_undef ($ans1); 
@@ -399,14 +406,14 @@ $x = $class->new('+inf'); ok ($x,'inf');
 
 ###############################################################################
 ###############################################################################
-# the followin tests only make sense with Math::BigInt::Calc
+# the followin tests only make sense with Math::BigInt::Calc or BareCalc
 
-exit if $CALC ne 'Math::BigInt::Calc'; # for Pari et al.
+exit if $CALC !~ /^Math::BigInt::(Calc|BareCalc)$/; # for Pari et al.
 
 ###############################################################################
 # check proper length of internal arrays
 
-my $bl = Math::BigInt::Calc::_base_len();
+my $bl = $CL->_base_len();
 my $BASE = '9' x $bl;
 my $MAX = $BASE;
 $BASE++;
@@ -428,18 +435,19 @@ ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1));
 ###############################################################################
 # test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1
 
-$x = Math::BigInt->new(99998); $x++; $x++; $x++; $x++;
-if ($x > 100000) { ok (1,1) } else { ok ("$x < 100000","$x > 100000"); }
+$x = $class->new($BASE-2); $x++; $x++; $x++; $x++;
+if ($x > $BASE) { ok (1,1) } else { ok ("$x < $BASE","$x > $BASE"); }
+
+$x = $class->new($BASE+3); $x++;
+if ($x > $BASE) { ok (1,1) } else { ok ("$x > $BASE","$x < $BASE"); }
 
-$x = Math::BigInt->new(100003); $x++;
-$y = Math::BigInt->new(1000000);
-if ($x < 1000000) { ok (1,1) } else { ok ("$x > 1000000","$x < 1000000"); }
+# test for +0 instead of int(): 
+$x = $class->new($MAX); ok ($x->length(), length($MAX));
 
 ###############################################################################
 # bug in sub where number with at least 6 trailing zeros after any op failed
 
-$x = Math::BigInt->new(123456); $z = Math::BigInt->new(10000); $z *= 10;
-$x -= $z;
+$x = $class->new(123456); $z = $class->new(10000); $z *= 10; $x -= $z;
 ok ($z, 100000);
 ok ($x, 23456);
 
@@ -449,7 +457,7 @@ ok ($x, 23456);
 # construct a number with a zero-hole of BASE_LEN
 $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl;
 $y = '1' x (2*$bl);
-$x = Math::BigInt->new($x)->bmul($y);
+$x = $class->new($x)->bmul($y);
 # result is 123..$bl .  $bl x (3*bl-1) . $bl...321 . '0' x $bl
 $y = ''; my $d = '';
 for (my $i = 1; $i <= $bl; $i++)
@@ -460,13 +468,34 @@ $y .= $bl x (3*$bl-1) . $d . '0' x $bl;
 ok ($x,$y);
 
 ###############################################################################
+# see if mul shortcut for small numbers works
+
+$x = '9' x $bl;
+$x = $class->new($x); 
+# 999 * 999 => 998 . 001, 9999*9999 => 9998 . 0001
+ok ($x*$x, '9' x ($bl-1) . '8' . '0' x ($bl-1) . '1');
+
+###############################################################################
 # bug with rest "-0" in div, causing further div()s to fail
 
-$x = Math::BigInt->new('-322056000'); ($x,$y) = $x->bdiv('-12882240');
+$x = $class->new('-322056000'); ($x,$y) = $x->bdiv('-12882240');
 
 ok ($y,'0','not -0');  # not '-0'
 is_valid($y);
 
+###############################################################################
+# test whether bone/bzero take additional A & P, or reset it etc
+
+$x = $class->new(2); $x->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->binf();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->bone();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->bnan();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
+
+$x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan();
+ok_undef ($x->{_a}); ok_undef ($x->{_p});
+$x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf();
+ok_undef ($x->{_a}); ok_undef ($x->{_p});
+
 ### all tests done ############################################################
 
 1;
@@ -610,6 +639,7 @@ NaN:-inf:
 0b1000000000000000000000000000000:1073741824
 0b_101:NaN
 0b1_0_1:5
+0b0_0_0_1:1
 # hex input
 -0x0:0
 0xabcdefgh:NaN
@@ -619,6 +649,7 @@ NaN:-inf:
 -0x1234:-4660
 0x12345678:305419896
 0x1_2_3_4_56_78:305419896
+0xa_b_c_d_e_f:11259375
 0x_123:NaN
 # inf input
 inf:inf
@@ -1218,6 +1249,23 @@ abc:0:NaN
 -7:-4:-8
 -7:4:0
 -4:7:4
+# equal arguments are treated special, so also do some test with unequal ones
+0xFFFF:0xFFFF:0x0xFFFF
+0xFFFFFF:0xFFFFFF:0x0xFFFFFF
+0xFFFFFFFF:0xFFFFFFFF:0x0xFFFFFFFF
+0xFFFFFFFFFF:0xFFFFFFFFFF:0x0xFFFFFFFFFF
+0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF
+0xF0F0:0xF0F0:0x0xF0F0
+0x0F0F:0x0F0F:0x0x0F0F
+0xF0F0F0:0xF0F0F0:0x0xF0F0F0
+0x0F0F0F:0x0F0F0F:0x0x0F0F0F
+0xF0F0F0F0:0xF0F0F0F0:0x0xF0F0F0F0
+0x0F0F0F0F:0x0F0F0F0F:0x0x0F0F0F0F
+0xF0F0F0F0F0:0xF0F0F0F0F0:0x0xF0F0F0F0F0
+0x0F0F0F0F0F:0x0F0F0F0F0F:0x0x0F0F0F0F0F
+0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0x0xF0F0F0F0F0F0
+0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0x0x0F0F0F0F0F0F
+0x1F0F0F0F0F0F:0x3F0F0F0F0F0F:0x0x1F0F0F0F0F0F
 &bior
 abc:abc:NaN
 abc:0:NaN
@@ -1232,6 +1280,38 @@ abc:0:NaN
 -6:-6:-6
 -7:4:-3
 -4:7:-1
+# equal arguments are treated special, so also do some test with unequal ones
+0xFFFF:0xFFFF:0x0xFFFF
+0xFFFFFF:0xFFFFFF:0x0xFFFFFF
+0xFFFFFFFF:0xFFFFFFFF:0x0xFFFFFFFF
+0xFFFFFFFFFF:0xFFFFFFFFFF:0x0xFFFFFFFFFF
+0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF
+0:0xFFFF:0x0xFFFF
+0:0xFFFFFF:0x0xFFFFFF
+0:0xFFFFFFFF:0x0xFFFFFFFF
+0:0xFFFFFFFFFF:0x0xFFFFFFFFFF
+0:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF
+0xFFFF:0:0x0xFFFF
+0xFFFFFF:0:0x0xFFFFFF
+0xFFFFFFFF:0:0x0xFFFFFFFF
+0xFFFFFFFFFF:0:0x0xFFFFFFFFFF
+0xFFFFFFFFFFFF:0:0x0xFFFFFFFFFFFF
+0xF0F0:0xF0F0:0x0xF0F0
+0x0F0F:0x0F0F:0x0x0F0F
+0xF0F0:0x0F0F:0x0xFFFF
+0xF0F0F0:0xF0F0F0:0x0xF0F0F0
+0x0F0F0F:0x0F0F0F:0x0x0F0F0F
+0x0F0F0F:0xF0F0F0:0x0xFFFFFF
+0xF0F0F0F0:0xF0F0F0F0:0x0xF0F0F0F0
+0x0F0F0F0F:0x0F0F0F0F:0x0x0F0F0F0F
+0x0F0F0F0F:0xF0F0F0F0:0x0xFFFFFFFF
+0xF0F0F0F0F0:0xF0F0F0F0F0:0x0xF0F0F0F0F0
+0x0F0F0F0F0F:0x0F0F0F0F0F:0x0x0F0F0F0F0F
+0x0F0F0F0F0F:0xF0F0F0F0F0:0x0xFFFFFFFFFF
+0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0x0xF0F0F0F0F0F0
+0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0x0x0F0F0F0F0F0F
+0x0F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF
+0x1F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF
 &bxor
 abc:abc:NaN
 abc:0:NaN
@@ -1248,6 +1328,37 @@ abc:0:NaN
 -4:7:-5
 4:-7:-3
 -4:-7:5
+# equal arguments are treated special, so also do some test with unequal ones
+0xFFFF:0xFFFF:0
+0xFFFFFF:0xFFFFFF:0
+0xFFFFFFFF:0xFFFFFFFF:0
+0xFFFFFFFFFF:0xFFFFFFFFFF:0
+0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0
+0:0xFFFF:0x0xFFFF
+0:0xFFFFFF:0x0xFFFFFF
+0:0xFFFFFFFF:0x0xFFFFFFFF
+0:0xFFFFFFFFFF:0x0xFFFFFFFFFF
+0:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF
+0xFFFF:0:0x0xFFFF
+0xFFFFFF:0:0x0xFFFFFF
+0xFFFFFFFF:0:0x0xFFFFFFFF
+0xFFFFFFFFFF:0:0x0xFFFFFFFFFF
+0xFFFFFFFFFFFF:0:0x0xFFFFFFFFFFFF
+0xF0F0:0xF0F0:0
+0x0F0F:0x0F0F:0
+0xF0F0:0x0F0F:0x0xFFFF
+0xF0F0F0:0xF0F0F0:0
+0x0F0F0F:0x0F0F0F:0
+0x0F0F0F:0xF0F0F0:0x0xFFFFFF
+0xF0F0F0F0:0xF0F0F0F0:0
+0x0F0F0F0F:0x0F0F0F0F:0
+0x0F0F0F0F:0xF0F0F0F0:0x0xFFFFFFFF
+0xF0F0F0F0F0:0xF0F0F0F0F0:0
+0x0F0F0F0F0F:0x0F0F0F0F0F:0
+0x0F0F0F0F0F:0xF0F0F0F0F0:0x0xFFFFFFFFFF
+0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0
+0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0
+0x0F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF
 &bnot
 abc:NaN
 +0:-1
@@ -1367,18 +1478,30 @@ abc:12:NaN
 -123:3
 215960156869840440586892398248:30
 &bsqrt
+145:12
 144:12
+143:11
 16:4
+170:13
+169:13
+168:12
 4:2
+3:1
 2:1
+9:3
 12:3
 256:16
 100000000:10000
 4000000000000:2000000
+152399026:12345
+152399025:12345
+152399024:12344
 1:1
 0:0
 -2:NaN
+-123:NaN
 Nan:NaN
++inf:NaN
 &bround
 $round_mode('trunc')
 0:12:0
index 70dc726..d1fac73 100755 (executable)
@@ -10,12 +10,13 @@ BEGIN
   my $location = $0; $location =~ s/bigintpm.t//;
   unshift @INC, $location; # to locate the testing files
   chdir 't' if -d 't';
-  plan tests => 1669;
+  plan tests => 1865;
   }
 
 use Math::BigInt;
 
-use vars qw ($scale $class $try $x $y $f @args $ans $ans1 $ans1_str $setup);
+use vars qw ($scale $class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL);
 $class = "Math::BigInt";
+$CL = "Math::BigInt::Calc";
 
 require 'bigintpm.inc';        # all tests here for sharing
index e903ac2..937a9c6 100755 (executable)
@@ -26,7 +26,7 @@ BEGIN
     }
   print "# INC = @INC\n"; 
   
-  plan tests => 1325 + 4;      # + 4 own tests
+  plan tests => 1367 + 4;      # + 4 own tests
   }
 
 use Math::BigFloat::Subclass;
index e387f89..779416c 100755 (executable)
@@ -26,17 +26,19 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 1669 + 4;      # +4 own tests
+  plan tests => 1865
+    + 4;       # +4 own tests
   }
 
 use Math::BigInt::Subclass;
 
-use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup);
+use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL);
 $class = "Math::BigInt::Subclass";
+$CL = "Math::BigInt::Calc";
 
-my $version = '0.01';   # for $VERSION tests, match current release (by hand!)
+my $version = '0.02';   # for $VERSION tests, match current release (by hand!)
 
-require 'bigintpm.inc';        # perform same tests as bigfltpm
+require 'bigintpm.inc';        # perform same tests as bigintpm
 
 # Now do custom tests for Subclass itself
 my $ms = $class->new(23);
index c963a07..d78a14f 100644 (file)
@@ -1,36 +1,29 @@
 package Net::Ping;
 
-# Current maintainer: colinm@cpan.org (Colin McMillen)
-#              stream protocol: bronson@trestle.com (Scott Bronson)
-#
-# Original author:   mose@ccsn.edu (Russell Mosemann)
-#
-# Authors of the original pingecho():
-#           karrer@bernina.ethz.ch (Andreas Karrer)
-#           Paul.Marquess@btinternet.com (Paul Marquess)
-#
-# Copyright (c) 2001, Colin McMillen.  All rights reserved.  This
-# program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-use 5.006_001;
+# $Id: Ping.pm,v 1.11 2001/12/04 02:41:51 rob Exp $
+
+require 5.002;
 require Exporter;
 
 use strict;
-our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize);
+use vars qw(@ISA @EXPORT $VERSION
+            $def_timeout $def_proto $max_datasize $pingstring);
 use FileHandle;
 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
-               inet_aton inet_ntoa sockaddr_in );
+               inet_aton sockaddr_in );
 use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(pingecho);
-$VERSION = 2.04;
+$VERSION = 2.07;
 
 # Constants
 
 $def_timeout = 5;           # Default timeout to wait for a reply
 $def_proto = "udp";         # Default protocol to use for pinging
 $max_datasize = 1024;       # Maximum data bytes in a packet
+# The data we exchange with the server for the stream protocol
+$pingstring = "pingschwingping!\n";
 
 # Description:  The pingecho() subroutine is provided for backward
 # compatibility with the original Net::Ping.  It accepts a host
@@ -130,7 +123,7 @@ sub new
 
 # Description: Ping a host name or IP number with an optional timeout.
 # First lookup the host, and return undef if it is not found.  Otherwise
-# perform the specific ping method based on the protocol.  Return the 
+# perform the specific ping method based on the protocol.  Return the
 # result of the ping.
 
 sub ping
@@ -167,8 +160,8 @@ sub ping_external {
       $timeout            # Seconds after which ping times out
      ) = @_;
 
-  eval { require Net::Ping::External; };
-  croak('Protocol "external" not supported on your system: Net::Ping::External not found') if $@;
+  eval { require Net::Ping::External; }
+    or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
   return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
 }
 
@@ -285,204 +278,187 @@ sub checksum
     return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
 }
 
-# Warning: this method may generate false positives.
-# It is meant to be a private method and should only
-# be invoked by ping_tcp() if $^O =~ /win32/i.
 
-sub _ping_tcp_win
+# Description:  Perform a tcp echo ping.  Since a tcp connection is
+# host specific, we have to open and close each connection here.  We
+# can't just leave a socket open.  Because of the robust nature of
+# tcp, it will take a while before it gives up trying to establish a
+# connection.  Therefore, we use select() on a non-blocking socket to
+# check against our timeout.  No data bytes are actually
+# sent since the successful establishment of a connection is proof
+# enough of the reachability of the remote host.  Also, tcp is
+# expensive and doesn't need our help to add to the overhead.
+
+sub ping_tcp
 {
     my ($self,
         $ip,                # Packed IP number of the host
+        $timeout            # Seconds after which ping times out
         ) = @_;
-    my ($saddr,             # sockaddr_in with port and ip
-        $ret                # The return value
+    my ($ret                # The return value
         );
 
-    socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
-        croak("tcp socket error - $!");
-
-    $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
-    $ret = 0;               # Default to unreachable
-
-    eval { $ret = connect($self->{"fh"}, $saddr) };
-
-    # If the remote host exists but returns "Connection refused",
-    # the call to connect() sets $! to "Unknown error". So, we
-    # assume that an "Unknown error" actually means the host is
-    # alive. This assumption may occassionally give false positives.
-    $ret = 1 if $! =~ /Unknown error/i;
-
+    $@ = "";
+    $ret = $self -> tcp_connect( $ip, $timeout);
+    $ret = 1 if $@ =~ /(Connection Refused|Unknown Error)/i;
     $self->{"fh"}->close();
-    return $ret;
+    return($ret);
 }
 
-# Buggy Winsock API doesn't allow us to use non-blocking connect()
-# calls. Hence, if our OS is Windows, we need to create a new process
-# to run a blocking connect attempt, and kill it after the timeout has
-# passed.  Unfortunately, this won't work with the stream protocol.
-
-sub ping_tcp_win32
+sub tcp_connect
 {
     my ($self,
         $ip,                # Packed IP number of the host
-        $timeout            # Seconds after which open times out
+        $timeout            # Seconds after which connect times out
         ) = @_;
+    my ($saddr);            # Packed IP and Port
 
-    socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
-      croak("tcp socket error - $!");
-
-    my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
-       my ($child, $ret, $pid, $time);
-       my $host = inet_ntoa($ip);
-
-       # The code we will be executing in our new process.
-       my $code = '"use Net::Ping; $p = Net::Ping->new(\'tcp\'); ';
-       $code .= 'exit($p->_ping_tcp_win(' . $host . '))"';
-
-       # Call the process.
-       $pid = system(1, "perl", "-e", $code);
-
-       # Import the POSIX version of <sys/wait.h>
-       require POSIX;
-       import POSIX qw(:sys_wait_h);
-
-       # Get the current time; will be used to tell if we've timed out.
-       $time = time;
+    $saddr = sockaddr_in($self->{"port_num"}, $ip);
 
-       # Wait for the child to return or for the timeout to expire.
-       do {
-               $child = waitpid($pid, &WNOHANG());
-               $ret = $?;
-       } until time > ($time + $timeout) or $child;
+    my $ret = 0;            # Default to unreachable
 
-       # Return an appropriate value; 0 if the child didn't return,
-       # the return value of the child otherwise.
-       return $ret >> 8 if $child;
+    my $do_socket = sub {
+      socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
+        croak("tcp socket error - $!");
+    };
+    my $do_connect = sub {
+      eval {
+        die $! unless connect($self->{"fh"}, $saddr);
+        $self->{"ip"} = $ip;
+        $ret = 1;
+      };
+      $ret;
+    };
+
+    if ($^O =~ /Win32/i) {
+
+      # Buggy Winsock API doesn't allow us to use alarm() calls.
+      # Hence, if our OS is Windows, we need to create a separate
+      # process to do the blocking connect attempt.
+
+      $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
+      my $pid = fork;
+      if (!$pid) {
+        if (!defined $pid) {
+          # Fork did not work
+          warn "Win32 Fork error: $!";
+          return 0;
+        }
+        &{ $do_socket }();
+
+        # Try a slow blocking connect() call
+        # and report the status to the pipe.
+        if ( &{ $do_connect }() ) {
+          $self->{"fh"}->close();
+          # No error
+          exit 0;
+        } else {
+          # Pass the error status to the parent
+          exit $!;
+        }
+      }
+
+      &{ $do_socket }();
+
+      my $patience = time + $timeout;
+
+      require POSIX;
+      my ($child);
+      $? = 0;
+      # Wait up to the timeout
+      # And clean off the zombie
+      do {
+        $child = waitpid($pid, &POSIX::WNOHANG);
+        $! = $? >> 8;
+        $@ = $!;
+        sleep 1;
+      } while time < $patience && $child != $pid;
+
+      if ($child == $pid) {
+        # Since she finished within the timeout,
+        # it is probably safe for me to try it too
+        &{ $do_connect }();
+      } else {
+        # Time must have run out.
+        $@ = "Timed out!";
+        # Put that choking client out of its misery
+        kill "KILL", $pid;
+        # Clean off the zombie
+        waitpid($pid, 0);
+        $ret = 0;
+      }
+    } else { # Win32
+      # Otherwise don't waste the resources to fork
+
+      &{ $do_socket }();
+
+      $SIG{'ALRM'} = sub { die "Timed out!"; };
+      alarm($timeout);        # Interrupt connect() if we have to
+
+      &{ $do_connect }();
+      alarm(0);
+    }
 
-       kill $pid;
-       return 0;
+    return $ret;
 }
 
 # This writes the given string to the socket and then reads it
 # back.  It returns 1 on success, 0 on failure.
 sub tcp_echo
 {
-       my $self = shift;
-       my $timeout = shift;
-       my $pingstring = shift;
+    my $self = shift;
+    my $timeout = shift;
+    my $pingstring = shift;
 
-       my $ret = undef;
-       my $time = time;
-       my $wrstr = $pingstring;
-       my $rdstr = "";
+    my $ret = undef;
+    my $time = time;
+    my $wrstr = $pingstring;
+    my $rdstr = "";
 
     eval <<'EOM';
-       do {
-               my $rin = "";
-               vec($rin, $self->{"fh"}->fileno(), 1) = 1;
-
-               my $rout = undef;
-               if($wrstr) {
-                       $rout = "";
-                       vec($rout, $self->{"fh"}->fileno(), 1) = 1;
-               }
-
-               if(select($rin, $rout, undef, ($time + $timeout) - time())) {
-
-                       if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
-                               my $num = syswrite($self->{"fh"}, $wrstr);
-                               if($num) {
-                                       # If it was a partial write, update and try again.
-                                       $wrstr = substr($wrstr,$num);
-                               } else {
-                                       # There was an error.
-                                       $ret = 0;
-                               }
-                       }
-
-                       if(vec($rin,$self->{"fh"}->fileno(),1)) {
-                               my $reply;
-                               if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
-                                       $rdstr .= $reply;
-                                       $ret = 1 if $rdstr eq $pingstring;
-                               } else {
-                                       # There was an error.
-                                       $ret = 0;
-                               }
-                       }
-
-               }
-       } until time() > ($time + $timeout) || defined($ret);
+        do {
+                my $rin = "";
+                vec($rin, $self->{"fh"}->fileno(), 1) = 1;
+
+                my $rout = undef;
+                if($wrstr) {
+                        $rout = "";
+                        vec($rout, $self->{"fh"}->fileno(), 1) = 1;
+                }
+
+                if(select($rin, $rout, undef, ($time + $timeout) - time())) {
+
+                        if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
+                                my $num = syswrite($self->{"fh"}, $wrstr);
+                                if($num) {
+                                        # If it was a partial write, update and try again.
+                                        $wrstr = substr($wrstr,$num);
+                                } else {
+                                        # There was an error.
+                                        $ret = 0;
+                                }
+                        }
+
+                        if(vec($rin,$self->{"fh"}->fileno(),1)) {
+                                my $reply;
+                                if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
+                                        $rdstr .= $reply;
+                                        $ret = 1 if $rdstr eq $pingstring;
+                                } else {
+                                        # There was an error.
+                                        $ret = 0;
+                                }
+                        }
+
+                }
+        } until time() > ($time + $timeout) || defined($ret);
 EOM
 
-       return $ret;
-}
-
-sub tcp_connect
-{
-    my ($self,
-        $ip,                # Packed IP number of the host
-        $timeout            # Seconds after which open times out
-        ) = @_;
-
-       # Should we go back to using blocking IO and alarms to implement
-       # the stream protocol on win32?
-    croak "no nonblocking io -- can't stream ping on win32"
-               if ($^O =~ /win32/i);
-
-       $self->{"ip"} = $ip;
-
-    socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
-      croak("tcp socket error - $!");
-
-    my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-    my $ret = 0;
-
-       # Try a non-blocking TCP connect to the remote echo port.
-       # Our call to select() below will stop after the timeout has
-       # passed or set the return value to true if the connection
-       # succeeds in time.
-       $self->{"fh"}->blocking(0);
-       connect($self->{"fh"}, $saddr);
-
-       # This replaces the breakage where we were listening on a
-       # socket that would never produce any data.  This works, but
-       # it's now quite a bit heavier than the old Net::Ping.  I'd
-       # like to see it reverted.
-       return $self->tcp_echo($timeout, "ping!\n");
+    return $ret;
 }
 
-# Description:  Perform a tcp echo ping.  Since a tcp connection is
-# host specific, we have to open and close each connection here.  We
-# can't just leave a socket open.  Because of the robust nature of
-# tcp, it will take a while before it gives up trying to establish a
-# connection.  Therefore, we use select() on a non-blocking socket to
-# check against our timeout. No data bytes are actually
-# sent since the successful establishment of a connection is proof
-# enough of the reachability of the remote host.  Also, tcp is
-# expensive and doesn't need our help to add to the overhead.
-
-sub ping_tcp
-{
-    my ($self,
-        $ip,                # Packed IP number of the host
-        $timeout            # Seconds after which ping times out
-       ) = @_;
 
-       my $ret;
 
-       # tcp_connect won't work on win32, so special-case it if need be.
-    if ($^O =~ /win32/i) {
-               $ret = $self->ping_tcp_win32($ip, $timeout);
-       } else {
-       $ret = $self->tcp_connect($ip, $timeout);
-       $self->{"fh"}->close();
-       }
-
-    return $ret;
-}
 
 # Description: Perform a stream ping.  If the tcp connection isn't
 # already open, it opens it.  It then sends some data and waits for
@@ -495,8 +471,6 @@ sub ping_stream
         $timeout            # Seconds after which ping times out
         ) = @_;
 
-    my $pingstring = "ping!\n";   # The data we exchange with the server
-
     # Open the stream if it's not already open
     if(!defined $self->{"fh"}->fileno()) {
         $self->tcp_connect($ip, $timeout) or return 0;
@@ -505,7 +479,7 @@ sub ping_stream
     croak "tried to switch servers while stream pinging"
        if $self->{"ip"} ne $ip;
 
-    return $self->tcp_echo($timeout, "pingschwingping!\n");
+    return $self->tcp_echo($timeout, $pingstring);
 }
 
 # Description: opens the stream.  You would do this if you want to
@@ -513,22 +487,25 @@ sub ping_stream
 
 sub open
 {
-   my ($self,
-       $ip,                # Packed IP number of the host
+    my ($self,
+        $host,              # Host or IP address
         $timeout            # Seconds after which open times out
-       ) = @_;
+        ) = @_;
 
-   $timeout = $self->{"timeout"} unless $timeout;
+    my ($ip);               # Packed IP number of the host
+    $ip = inet_aton($host);
+    $timeout = $self->{"timeout"} unless $timeout;
 
-   if($self->{"proto"} eq "stream") {
-       if(defined($self->{"fh"}->fileno())) {
-           croak("socket is already open");
-       } else {
-           $self->tcp_connect($ip, $timeout);
-       }
-   }
+    if($self->{"proto"} eq "stream") {
+      if(defined($self->{"fh"}->fileno())) {
+        croak("socket is already open");
+      } else {
+        $self->tcp_connect($ip, $timeout);
+      }
+    }
 }
 
+
 # Description:  Perform a udp echo ping.  Construct a message of
 # at least the one-byte sequence number and any additional data bytes.
 # Send the message out and wait for a message to come back.  If we
@@ -598,7 +575,7 @@ sub ping_udp
         }
     }
     return($ret);
-}   
+}
 
 # Description:  Close the connection unless we are using the tcp
 # protocol, since it will already be closed.
@@ -618,6 +595,8 @@ __END__
 
 Net::Ping - check a remote host for reachability
 
+$Id: Ping.pm,v 1.11 2001/12/04 02:41:51 rob Exp $
+
 =head1 SYNOPSIS
 
     use Net::Ping;
@@ -635,8 +614,10 @@ Net::Ping - check a remote host for reachability
         sleep(1);
     }
     $p->close();
-    
+
     $p = Net::Ping->new("tcp", 2);
+    # Try connecting to the www port instead of the echo port
+    $p->{port_num} = getservbyname("http", "tcp");
     while ($stop_time > time())
     {
         print "$host not reachable ", scalar(localtime()), "\n"
@@ -644,7 +625,7 @@ Net::Ping - check a remote host for reachability
         sleep(300);
     }
     undef($p);
-    
+
     # For backward compatibility
     print "$host is alive.\n" if pingecho($host);
 
@@ -655,64 +636,38 @@ hosts on a network.  A ping object is first created with optional
 parameters, a variable number of hosts may be pinged multiple
 times and then the connection is closed.
 
-Ping supports five ping protocols, each with its own strengths
-and weaknesses.  The "udp" protocol is the default.  A host
-may be configured to respond to only a few of these protocols,
-or even none at all.  For example, www.microsoft.com is generally
-alive but not pingable.
+You may choose one of four different protocols to use for the
+ping. The "udp" protocol is the default. Note that a live remote host
+may still fail to be pingable by one or more of these protocols. For
+example, www.microsoft.com is generally alive but not pingable.
 
-=over 4
-
-=item icmp
-
-The C<ping()> method sends an icmp echo message to the remote host
-(this is what the UNIX ping program does).
-If the echoed message is received from the remote host and
-the echoed information is correct, the remote host is considered
-reachable.  Specifying this protocol requires that the program
-be run as root or that the program be setuid to root.
-
-=item udp
+With the "tcp" protocol the ping() method attempts to establish a
+connection to the remote host's echo port.  If the connection is
+successfully established, the remote host is considered reachable.  No
+data is actually echoed.  This protocol does not require any special
+privileges but has higher overhead than the other two protocols.
 
-The C<ping()> method sends a udp
+Specifying the "udp" protocol causes the ping() method to send a udp
 packet to the remote host's echo port.  If the echoed packet is
 received from the remote host and the received packet contains the
 same data as the packet that was sent, the remote host is considered
 reachable.  This protocol does not require any special privileges.
-
-It should be borne in mind that, for both udp and tcp ping, a host
+It should be borne in mind that, for a udp ping, a host
 will be reported as unreachable if it is not running the
-appropriate echo service.  For Unix-like systems see L<inetd(8)> for
-more information.
+appropriate echo service.  For Unix-like systems see L<inetd(8)>
+for more information.
 
-=item tcp
+If the "icmp" protocol is specified, the ping() method sends an icmp
+echo message to the remote host, which is what the UNIX ping program
+does.  If the echoed message is received from the remote host and
+the echoed information is correct, the remote host is considered
+reachable.  Specifying the "icmp" protocol requires that the program
+be run as root or that the program be setuid to root.
 
-The C<ping()> method attempts to establish a
-connection to the remote host's echo port.  If the connection is
-successfully established, the remote host is considered reachable.
-Once the connection is made, it is torn down immediately -- no data
-is actually echoed.  This protocol does not require any special
-privileges but has highest overhead of the protocols.
-
-=item stream
-
-This is just like the tcp protocol, except that once it establishes
-the tcp connection, it keeps it up.  Each subsequent ping
-request re-uses the existing connection.  stream
-provides better performance than tcp since the connection
-doesn't need to be created and torn down with every ping.  It is
-also the only protocol that will recognize that the original host is
-gone, even if it is immediately replaced by an
-identical host responding in exactly the same way.  The drawback
-is that you can only ping one host per Ping instance.  You will get
-an error if you neglect to call C<close()> before trying to ping
-a different network device.
-
-=item external
-
-The ping() method attempts to use the C<Net::Ping::External> module to ping
-the remote host.  C<Net::Ping::External> interfaces with your system's default
-L<ping(8)> utility to perform the ping, and generally produces relatively
+If the "external" protocol is specified, the ping() method attempts to
+use the C<Net::Ping::External> module to ping the remote host.
+C<Net::Ping::External> interfaces with your system's default C<ping>
+utility to perform the ping, and generally produces relatively
 accurate results. If C<Net::Ping::External> if not installed on your
 system, specifying the "external" protocol will result in an error.
 
@@ -754,7 +709,18 @@ tcp socket.  It's only necessary to do this if you want to
 provide a different timeout when creating the connection, or
 remove the overhead of establishing the connection from the
 first ping.  If you don't call C<open()>, the connection is
-automatically openeed the first time C<ping()> is called.
+automatically opened the first time C<ping()> is called.
+This call simply does nothing if you are using any protocol other
+than stream.
+
+=item $p->open($host);
+
+When you are using the stream protocol, this call pre-opens the
+tcp socket.  It's only necessary to do this if you want to
+provide a different timeout when creating the connection, or
+remove the overhead of establishing the connection from the
+first ping.  If you don't call C<open()>, the connection is
+automatically opened the first time C<ping()> is called.
 This call simply does nothing if you are using any protocol other
 than stream.
 
@@ -776,6 +742,13 @@ version of Net::Ping.
 
 =back
 
+=head1 WARNING
+
+pingecho() or a ping object with the tcp protocol use alarm() to
+implement the timeout.  So, don't use alarm() in your program while
+you are using pingecho() or a ping object with the tcp protocol.  The
+udp and icmp protocols do not use alarm() to implement the timeout.
+
 =head1 NOTES
 
 There will be less network overhead (and some efficiency in your
@@ -805,4 +778,30 @@ routines to pack and unpack ICMP packets.  It would be better for a
 separate module to be written which understands all of the different
 kinds of ICMP packets.
 
+=head1 AUTHOR(S)
+
+  Current maintainer Net::Ping base code:
+    colinm@cpan.org (Colin McMillen)
+
+  Stream protocol:
+    bronson@trestle.com (Scott Bronson)
+
+  Original pingecho():
+    karrer@bernina.ethz.ch (Andreas Karrer)
+    pmarquess@bfsec.bt.co.uk (Paul Marquess)
+
+  Original Net::Ping author:
+    mose@ns.ccsn.edu (Russell Mosemann)
+
+  Compatibility porting:
+    bbb@cpan.org (Rob Brown)
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001, Colin McMillen.  All rights reserved.
+Copyright (c) 2001, Rob Brown.  All rights reserved.
+
+This program is free software; you may redistribute it and/or
+modify it under the same terms as Perl itself.
+
 =cut
index 560addb..08df82b 100644 (file)
@@ -5,6 +5,11 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
+    undef *{Socket::inet_aton};
+    undef *{Socket::inet_ntoa};
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index be62458..32d750e 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index 2569722..e085591 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index e87388f..c7bbc04 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index ffeb123..7fb99de 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index 95dea87..163c8bd 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index eb52f7c..ac2df6c 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index fb169c2..a8d416e 100644 (file)
@@ -5,6 +5,9 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    if (!eval "require Socket") {
+       print "1..0 # no Socket\n"; exit 0;
+    }
     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
        print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
     }
index 69a2f5e..a44601a 100644 (file)
@@ -1,10 +1,12 @@
 package Term::Cap;
 
 use Carp;
+use strict;
 
 use vars qw($VERSION);
+use vars qw($termpat $state $first $entry);
 
-$VERSION = '1.03';
+$VERSION = '1.05';
 
 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
 # Version 1.00:  Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
@@ -19,6 +21,9 @@ $VERSION = '1.03';
 #       VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
 # Version 1.04:  Thu Nov 29 16:22:03 GMT 2001
 #       Fixed warnings in test
+# Version 1.05:  Mon Dec  3 15:33:49 GMT 2001
+#       Don't try to fall back on infocmp if it's not there. From chromatic.
+#
 
 # TODO:
 # support Berkeley DB termcaps
@@ -189,17 +194,17 @@ sub Tgetent { ## public -- static method
        # last resort--fake up a termcap from terminfo 
        local $ENV{TERM} = $term;
 
-         if ( $^O eq 'VMS' ) {
-            chomp(my @entry = <DATA>);
-            $entry = join '', @entry;
-         }
-         else {
-            eval
-            {
-                $entry = `infocmp -C 2>/dev/null`;
-            }
-        }
-
+        if ( $^O eq 'VMS' ) {
+          chomp(my @entry = <DATA>);
+          $entry = join '', @entry;
+        }
+        else {
+           eval
+           {
+            $entry = `infocmp -C 2>/dev/null`
+                    if grep { -x "$_/infocmp" } split /:/, $ENV{PATH};
+           }
+        }
     }
 
     croak "Can't find a valid termcap file" unless @termcap_path || $entry;
index 1bed138..5b1f36e 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
 
 use strict;
 use Unicode::UCD;
-use Test;
+use Test::More;
 
 BEGIN { plan tests => 162 };
 
@@ -19,223 +19,223 @@ my $charinfo;
 
 $charinfo = charinfo(0x41);
 
-ok($charinfo->{code},           '0041');
-ok($charinfo->{name},           'LATIN CAPITAL LETTER A');
-ok($charinfo->{category},       'Lu');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'L');
-ok($charinfo->{decomposition},  '');
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      '');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '0061');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Basic Latin');
-ok($charinfo->{script},         'Latin');
+is($charinfo->{code},           '0041', 'LATIN CAPITAL LETTER A');
+is($charinfo->{name},           'LATIN CAPITAL LETTER A');
+is($charinfo->{category},       'Lu');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'L');
+is($charinfo->{decomposition},  '');
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      '');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '0061');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Basic Latin');
+is($charinfo->{script},         'Latin');
 
 $charinfo = charinfo(0x100);
 
-ok($charinfo->{code},           '0100');
-ok($charinfo->{name},           'LATIN CAPITAL LETTER A WITH MACRON');
-ok($charinfo->{category},       'Lu');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'L');
-ok($charinfo->{decomposition},  '0041 0304');
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      'LATIN CAPITAL LETTER A MACRON');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '0101');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Latin Extended-A');
-ok($charinfo->{script},         'Latin');
+is($charinfo->{code},           '0100', 'LATIN CAPITAL LETTER A WITH MACRON');
+is($charinfo->{name},           'LATIN CAPITAL LETTER A WITH MACRON');
+is($charinfo->{category},       'Lu');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'L');
+is($charinfo->{decomposition},  '0041 0304');
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      'LATIN CAPITAL LETTER A MACRON');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '0101');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Latin Extended-A');
+is($charinfo->{script},         'Latin');
 
 # 0x0590 is in the Hebrew block but unused.
 
 $charinfo = charinfo(0x590);
 
-ok($charinfo->{code},          undef);
-ok($charinfo->{name},          undef);
-ok($charinfo->{category},      undef);
-ok($charinfo->{combining},     undef);
-ok($charinfo->{bidi},          undef);
-ok($charinfo->{decomposition}, undef);
-ok($charinfo->{decimal},       undef);
-ok($charinfo->{digit},         undef);
-ok($charinfo->{numeric},       undef);
-ok($charinfo->{mirrored},      undef);
-ok($charinfo->{unicode10},     undef);
-ok($charinfo->{comment},       undef);
-ok($charinfo->{upper},         undef);
-ok($charinfo->{lower},         undef);
-ok($charinfo->{title},         undef);
-ok($charinfo->{block},         undef);
-ok($charinfo->{script},        undef);
+is($charinfo->{code},          undef,  '0x0590 - unused Hebrew');
+is($charinfo->{name},          undef);
+is($charinfo->{category},      undef);
+is($charinfo->{combining},     undef);
+is($charinfo->{bidi},          undef);
+is($charinfo->{decomposition}, undef);
+is($charinfo->{decimal},       undef);
+is($charinfo->{digit},         undef);
+is($charinfo->{numeric},       undef);
+is($charinfo->{mirrored},      undef);
+is($charinfo->{unicode10},     undef);
+is($charinfo->{comment},       undef);
+is($charinfo->{upper},         undef);
+is($charinfo->{lower},         undef);
+is($charinfo->{title},         undef);
+is($charinfo->{block},         undef);
+is($charinfo->{script},        undef);
 
 # 0x05d0 is in the Hebrew block and used.
 
 $charinfo = charinfo(0x5d0);
 
-ok($charinfo->{code},           '05D0');
-ok($charinfo->{name},           'HEBREW LETTER ALEF');
-ok($charinfo->{category},       'Lo');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'R');
-ok($charinfo->{decomposition},  '');
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      '');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Hebrew');
-ok($charinfo->{script},         'Hebrew');
+is($charinfo->{code},           '05D0', '05D0 - used Hebrew');
+is($charinfo->{name},           'HEBREW LETTER ALEF');
+is($charinfo->{category},       'Lo');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'R');
+is($charinfo->{decomposition},  '');
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      '');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Hebrew');
+is($charinfo->{script},         'Hebrew');
 
 # An open syllable in Hangul.
 
 $charinfo = charinfo(0xAC00);
 
-ok($charinfo->{code},           'AC00');
-ok($charinfo->{name},           'HANGUL SYLLABLE-AC00');
-ok($charinfo->{category},       'Lo');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'L');
-ok($charinfo->{decomposition},  undef);
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      '');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Hangul Syllables');
-ok($charinfo->{script},         'Hangul');
+is($charinfo->{code},           'AC00', 'HANGUL SYLLABLE-AC00');
+is($charinfo->{name},           'HANGUL SYLLABLE-AC00');
+is($charinfo->{category},       'Lo');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'L');
+is($charinfo->{decomposition},  undef);
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      '');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Hangul Syllables');
+is($charinfo->{script},         'Hangul');
 
 # A closed syllable in Hangul.
 
 $charinfo = charinfo(0xAE00);
 
-ok($charinfo->{code},           'AE00');
-ok($charinfo->{name},           'HANGUL SYLLABLE-AE00');
-ok($charinfo->{category},       'Lo');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'L');
-ok($charinfo->{decomposition},  undef);
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      '');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Hangul Syllables');
-ok($charinfo->{script},         'Hangul');
+is($charinfo->{code},           'AE00', 'HANGUL SYLLABLE-AE00');
+is($charinfo->{name},           'HANGUL SYLLABLE-AE00');
+is($charinfo->{category},       'Lo');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'L');
+is($charinfo->{decomposition},  undef);
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      '');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Hangul Syllables');
+is($charinfo->{script},         'Hangul');
 
 $charinfo = charinfo(0x1D400);
 
-ok($charinfo->{code},           '1D400');
-ok($charinfo->{name},           'MATHEMATICAL BOLD CAPITAL A');
-ok($charinfo->{category},       'Lu');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'L');
-ok($charinfo->{decomposition},  '<font> 0041');
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      '');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Mathematical Alphanumeric Symbols');
-ok($charinfo->{script},         undef);
+is($charinfo->{code},           '1D400', 'MATHEMATICAL BOLD CAPITAL A');
+is($charinfo->{name},           'MATHEMATICAL BOLD CAPITAL A');
+is($charinfo->{category},       'Lu');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'L');
+is($charinfo->{decomposition},  '<font> 0041');
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      '');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Mathematical Alphanumeric Symbols');
+is($charinfo->{script},         undef);
 
 use Unicode::UCD qw(charblock charscript);
 
 # 0x0590 is in the Hebrew block but unused.
 
-ok(charblock(0x590),          'Hebrew');
-ok(charscript(0x590),         undef);
+is(charblock(0x590),          'Hebrew', '0x0590 - Hebrew unused charblock');
+is(charscript(0x590),         undef,    '0x0590 - Hebrew unused charscript');
 
 $charinfo = charinfo(0xbe);
 
-ok($charinfo->{code},           '00BE');
-ok($charinfo->{name},           'VULGAR FRACTION THREE QUARTERS');
-ok($charinfo->{category},       'No');
-ok($charinfo->{combining},      '0');
-ok($charinfo->{bidi},           'ON');
-ok($charinfo->{decomposition},  '<fraction> 0033 2044 0034');
-ok($charinfo->{decimal},        '');
-ok($charinfo->{digit},          '');
-ok($charinfo->{numeric},        '3/4');
-ok($charinfo->{mirrored},       'N');
-ok($charinfo->{unicode10},      'FRACTION THREE QUARTERS');
-ok($charinfo->{comment},        '');
-ok($charinfo->{upper},          '');
-ok($charinfo->{lower},          '');
-ok($charinfo->{title},          '');
-ok($charinfo->{block},          'Latin-1 Supplement');
-ok($charinfo->{script},         undef);
+is($charinfo->{code},           '00BE', 'VULGAR FRACTION THREE QUARTERS');
+is($charinfo->{name},           'VULGAR FRACTION THREE QUARTERS');
+is($charinfo->{category},       'No');
+is($charinfo->{combining},      '0');
+is($charinfo->{bidi},           'ON');
+is($charinfo->{decomposition},  '<fraction> 0033 2044 0034');
+is($charinfo->{decimal},        '');
+is($charinfo->{digit},          '');
+is($charinfo->{numeric},        '3/4');
+is($charinfo->{mirrored},       'N');
+is($charinfo->{unicode10},      'FRACTION THREE QUARTERS');
+is($charinfo->{comment},        '');
+is($charinfo->{upper},          '');
+is($charinfo->{lower},          '');
+is($charinfo->{title},          '');
+is($charinfo->{block},          'Latin-1 Supplement');
+is($charinfo->{script},         undef);
 
 use Unicode::UCD qw(charblocks charscripts);
 
 my $charblocks = charblocks();
 
-ok(exists $charblocks->{Thai});
-ok($charblocks->{Thai}->[0]->[0], hex('0e00'));
-ok(!exists $charblocks->{PigLatin});
+ok(exists $charblocks->{Thai}, 'Thai charblock exists');
+is($charblocks->{Thai}->[0]->[0], hex('0e00'));
+ok(!exists $charblocks->{PigLatin}, 'PigLatin charblock does not exist');
 
 my $charscripts = charscripts();
 
-ok(exists $charscripts->{Armenian});
-ok($charscripts->{Armenian}->[0]->[0], hex('0531'));
-ok(!exists $charscripts->{PigLatin});
+ok(exists $charscripts->{Armenian}, 'Armenian charscript exists');
+is($charscripts->{Armenian}->[0]->[0], hex('0531'));
+ok(!exists $charscripts->{PigLatin}, 'PigLatin charscript does not exist');
 
 my $charscript;
 
 $charscript = charscript("12ab");
-ok($charscript, 'Ethiopic');
+is($charscript, 'Ethiopic', 'Ethiopic charscript');
 
 $charscript = charscript("0x12ab");
-ok($charscript, 'Ethiopic');
+is($charscript, 'Ethiopic');
 
 $charscript = charscript("U+12ab");
-ok($charscript, 'Ethiopic');
+is($charscript, 'Ethiopic');
 
 my $ranges;
 
 $ranges = charscript('Ogham');
-ok($ranges->[0]->[0], hex('1681'));
-ok($ranges->[0]->[1], hex('169a'));
+is($ranges->[0]->[0], hex('1681'), 'Ogham charscript');
+is($ranges->[0]->[1], hex('169a'));
 
 use Unicode::UCD qw(charinrange);
 
 $ranges = charscript('Cherokee');
-ok(!charinrange($ranges, "139f"));
+ok(!charinrange($ranges, "139f"), 'Cherokee charscript');
 ok( charinrange($ranges, "13a0"));
 ok( charinrange($ranges, "13f4"));
 ok(!charinrange($ranges, "13f5"));
 
-ok(Unicode::UCD::UnicodeVersion, '3.1.1');
+is(Unicode::UCD::UnicodeVersion, '3.1.1', 'UnicodeVersion');
 
 use Unicode::UCD qw(compexcl);
 
-ok(!compexcl(0x0100));
+ok(!compexcl(0x0100), 'compexcl');
 ok( compexcl(0x0958));
 
 use Unicode::UCD qw(casefold);
@@ -246,13 +246,13 @@ $casefold = casefold(0x41);
 
 ok($casefold->{code} eq '0041' &&
    $casefold->{status} eq 'C'  &&
-   $casefold->{mapping} eq '0061');
+   $casefold->{mapping} eq '0061', 'casefold 0x41');
 
 $casefold = casefold(0xdf);
 
 ok($casefold->{code} eq '00DF' &&
    $casefold->{status} eq 'F'  &&
-   $casefold->{mapping} eq '0073 0073');
+   $casefold->{mapping} eq '0073 0073', 'casefold 0xDF');
 
 ok(!casefold(0x20));
 
@@ -268,7 +268,7 @@ ok($casespec->{code} eq '00DF' &&
    $casespec->{lower} eq '00DF'  &&
    $casespec->{title} eq '0053 0073'  &&
    $casespec->{upper} eq '0053 0053' &&
-   $casespec->{condition} eq undef);
+   $casespec->{condition} eq undef, 'casespec 0xDF');
 
 $casespec = casespec(0x307);
 
@@ -276,4 +276,5 @@ ok($casespec->{az}->{code} eq '0307' &&
    $casespec->{az}->{lower} eq ''  &&
    $casespec->{az}->{title} eq '0307'  &&
    $casespec->{az}->{upper} eq '0307' &&
-   $casespec->{az}->{condition} eq 'az AFTER_i NOT_MORE_ABOVE');
+   $casespec->{az}->{condition} eq 'az AFTER_i NOT_MORE_ABOVE',
+   'casespec 0x307');
index 5140f6b..79cd61b 100644 (file)
@@ -10,11 +10,8 @@ sub in_locale { $^H & $locale::hint_bits }
 
 sub _get_locale_encoding {
     unless (defined $locale_encoding) {
-       eval {
-           # I18N::Langinfo isn't available everywhere
-           require I18N::Langinfo;
-           I18N::Langinfo->import('langinfo', 'CODESET');
-       };
+       # I18N::Langinfo isn't available everywhere
+       eval "use I18N::Langinfo qw(langinfo CODESET)";
        unless ($@) {
            $locale_encoding = langinfo(CODESET());
        }
index 3a42ce5..15a38bc 100644 (file)
@@ -183,7 +183,7 @@ eval { open::_get_locale_encoding() };
 like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
 %%%
 # the special :locale layer
-$ENV{LANG} = 'ru_RU.KOI8-R';
+$ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
 # the :locale will probe the locale environment variables like LANG
 use open OUT => ':locale';
 open(O, ">koi8");
diff --git a/mg.c b/mg.c
index 2a80760..4369e4a 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -869,7 +869,6 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
     register char *s;
     char *ptr;
     STRLEN len, klen;
-    I32 i;
 
     s = SvPV(sv,len);
     ptr = MgPV(mg,klen);
@@ -922,6 +921,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
            while (s < strend) {
                char tmpbuf[256];
                struct stat st;
+               I32 i;
                s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
                             s, strend, ':', &i);
                s++;
@@ -1102,6 +1102,7 @@ Perl_csighandler_init(void)
 
     for (sig = 1; sig < SIG_SIZE; sig++) {
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
+        dTHX;
         sig_defaulting[sig] = 1;
         (void) rsignal(sig, &Perl_csighandler);
 #endif
@@ -1948,7 +1949,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                SAVESPTR(PL_last_in_gv);
        }
        else if (SvOK(sv) && GvIO(PL_last_in_gv))
-           IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
+           IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
        break;
     case '^':
        Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
@@ -1961,15 +1962,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
        break;
     case '=':
-       IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+       IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
        break;
     case '-':
-       IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+       IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
        if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
            IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
        break;
     case '%':
-       IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+       IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
        break;
     case '|':
        {
diff --git a/op.c b/op.c
index 8125b30..d633b47 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2053,6 +2053,13 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
              desc, sample, sample);
     }
 
+    if (right->op_type == OP_CONST &&
+       cSVOPx(right)->op_private & OPpCONST_BARE &&
+       cSVOPx(right)->op_private & OPpCONST_STRICT)
+    {
+       no_bareword_allowed(right);
+    }
+
     if (!(right->op_flags & OPf_STACKED) &&
        (right->op_type == OP_MATCH ||
        right->op_type == OP_SUBST ||
@@ -2936,6 +2943,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            if (!squash)
                o->op_private |= OPpTRANS_IDENTICAL;
        }
+       else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
+           o->op_private |= OPpTRANS_IDENTICAL;
+       }
        for (i = 0; i < 256; i++)
            tbl[i] = -1;
        for (i = 0, j = 0; i < tlen; i++,j++) {
index 20c3602..640501c 100644 (file)
@@ -70,7 +70,7 @@
 #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
 static char    *local_patches[] = {
         NULL
-       ,"DEVEL13384"
+       ,"DEVEL13491"
        ,NULL
 };
 
index 0655887..47972b7 100644 (file)
@@ -192,6 +192,7 @@ if (-d "pod") {
     perl572delta         
     perl571delta         
     perl570delta         
+    perl561delta         
     perl56delta         
     perl5005delta       
     perl5004delta       
index 6a03ee7..2cac3f8 100644 (file)
@@ -131,6 +131,7 @@ For ease of access, the Perl manual has been split up into several sections.
     perl572delta       Perl changes in version 5.7.2
     perl571delta       Perl changes in version 5.7.1
     perl570delta       Perl changes in version 5.7.0
+    perl561delta       Perl changes in version 5.6.1
     perl56delta                Perl changes in version 5.6
     perl5005delta      Perl changes in version 5.005
     perl5004delta      Perl changes in version 5.004
diff --git a/pod/perl561delta.pod b/pod/perl561delta.pod
new file mode 100644 (file)
index 0000000..86235f0
--- /dev/null
@@ -0,0 +1,3646 @@
+=head1 NAME
+
+perldelta - what's new for perl v5.6.x
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.005 release and the 5.6.1
+release.
+
+=head1 Summary of changes between 5.6.0 and 5.6.1
+
+This section contains a summary of the changes between the 5.6.0 release
+and the 5.6.1 release.  More details about the changes mentioned here
+may be found in the F<Changes> files that accompany the Perl source
+distribution.  See L<perlhack> for pointers to online resources where you
+can inspect the individual patches described by these changes.
+
+=head2 Security Issues
+
+suidperl will not run /bin/mail anymore, because some platforms have
+a /bin/mail that is vulnerable to buffer overflow attacks.
+
+Note that suidperl is neither built nor installed by default in
+any recent version of perl.  Use of suidperl is highly discouraged.
+If you think you need it, try alternatives such as sudo first.
+See http://www.courtesan.com/sudo/.
+
+=head2 Core bug fixes
+
+This is not an exhaustive list.  It is intended to cover only the
+significant user-visible changes.
+
+=over
+
+=item C<UNIVERSAL::isa()>
+
+A bug in the caching mechanism used by C<UNIVERSAL::isa()> that affected
+base.pm has been fixed.  The bug has existed since the 5.005 releases,
+but wasn't tickled by base.pm in those releases.
+
+=item Memory leaks
+
+Various cases of memory leaks and attempts to access uninitialized memory
+have been cured.  See L</"Known Problems"> below for further issues.
+
+=item Numeric conversions
+
+Numeric conversions did not recognize changes in the string value
+properly in certain circumstances.
+
+In other situations, large unsigned numbers (those above 2**31) could
+sometimes lose their unsignedness, causing bogus results in arithmetic
+operations.
+
+Integer modulus on large unsigned integers sometimes returned
+incorrect values.
+
+Perl 5.6.0 generated "not a number" warnings on certain conversions where
+previous versions didn't.
+
+These problems have all been rectified.
+
+Infinity is now recognized as a number.
+
+=item qw(a\\b)
+
+In Perl 5.6.0, qw(a\\b) produced a string with two backslashes instead
+of one, in a departure from the behavior in previous versions.  The
+older behavior has been reinstated.  
+
+=item caller()
+
+caller() could cause core dumps in certain situations.  Carp was sometimes
+affected by this problem.
+
+=item Bugs in regular expressions
+
+Pattern matches on overloaded values are now handled correctly.
+
+Perl 5.6.0 parsed m/\x{ab}/ incorrectly, leading to spurious warnings.
+This has been corrected.
+
+The RE engine found in Perl 5.6.0 accidentally pessimised certain kinds
+of simple pattern matches.  These are now handled better.
+
+Regular expression debug output (whether through C<use re 'debug'>
+or via C<-Dr>) now looks better.
+
+Multi-line matches like C<"a\nxb\n" =~ /(?!\A)x/m> were flawed.  The
+bug has been fixed.
+
+Use of $& could trigger a core dump under some situations.  This
+is now avoided.
+
+Match variables $1 et al., weren't being unset when a pattern match
+was backtracking, and the anomaly showed up inside C</...(?{ ... }).../>
+etc.  These variables are now tracked correctly.
+
+pos() did not return the correct value within s///ge in earlier
+versions.  This is now handled correctly.
+
+=item "slurp" mode
+
+readline() on files opened in "slurp" mode could return an extra "" at
+the end in certain situations.  This has been corrected.
+
+=item Autovivification of symbolic references to special variables
+
+Autovivification of symbolic references of special variables described
+in L<perlvar> (as in C<${$num}>) was accidentally disabled.  This works
+again now.
+
+=item Lexical warnings 
+
+Lexical warnings now propagate correctly into C<eval "...">.
+
+C<use warnings qw(FATAL all)> did not work as intended.  This has been
+corrected.
+
+Lexical warnings could leak into other scopes in some situations.
+This is now fixed.
+
+warnings::enabled() now reports the state of $^W correctly if the caller
+isn't using lexical warnings.
+
+=item Spurious warnings and errors
+
+Perl 5.6.0 could emit spurious warnings about redefinition of dl_error()
+when statically building extensions into perl.  This has been corrected.
+
+"our" variables could result in bogus "Variable will not stay shared"
+warnings.  This is now fixed.
+
+"our" variables of the same name declared in two sibling blocks
+resulted in bogus warnings about "redeclaration" of the variables.
+The problem has been corrected.
+
+=item glob()
+
+Compatibility of the builtin glob() with old csh-based glob has been
+improved with the addition of GLOB_ALPHASORT option.  See C<File::Glob>.
+
+File::Glob::glob() has been renamed to File::Glob::bsd_glob()
+because the name clashes with the builtin glob().  The older
+name is still available for compatibility, but is deprecated.
+
+Spurious syntax errors generated in certain situations, when glob()
+caused File::Glob to be loaded for the first time, have been fixed.
+
+=item Tainting
+
+Some cases of inconsistent taint propagation (such as within hash
+values) have been fixed.
+
+The tainting behavior of sprintf() has been rationalized.  It does
+not taint the result of floating point formats anymore, making the
+behavior consistent with that of string interpolation.
+
+=item sort()
+
+Arguments to sort() weren't being provided the right wantarray() context.
+The comparison block is now run in scalar context, and the arguments to
+be sorted are always provided list context.
+
+sort() is also fully reentrant, in the sense that the sort function
+can itself call sort().  This did not work reliably in previous releases.
+
+=item #line directives
+
+#line directives now work correctly when they appear at the very
+beginning of C<eval "...">.
+
+=item Subroutine prototypes
+
+The (\&) prototype now works properly.
+
+=item map()
+
+map() could get pathologically slow when the result list it generates
+is larger than the source list.  The performance has been improved for
+common scenarios.
+
+=item Debugger
+
+Debugger exit code now reflects the script exit code.
+
+Condition C<"0"> in breakpoints is now treated correctly.
+
+The C<d> command now checks the line number.
+
+C<$.> is no longer corrupted by the debugger.
+
+All debugger output now correctly goes to the socket if RemotePort
+is set.
+
+=item PERL5OPT
+
+PERL5OPT can be set to more than one switch group.  Previously,
+it used to be limited to one group of options only.
+
+=item chop()
+
+chop(@list) in list context returned the characters chopped in reverse
+order.  This has been reversed to be in the right order.
+
+=item Unicode support
+
+Unicode support has seen a large number of incremental improvements,
+but continues to be highly experimental.  It is not expected to be
+fully supported in the 5.6.x maintenance releases.
+
+substr(), join(), repeat(), reverse(), quotemeta() and string
+concatenation were all handling Unicode strings incorrectly in
+Perl 5.6.0.  This has been corrected.
+
+Support for C<tr///CU> and C<tr///UC> etc., have been removed since
+we realized the interface is broken.  For similar functionality,
+see L<perlfunc/pack>.
+
+The Unicode Character Database has been updated to version 3.0.1
+with additions made available to the public as of August 30, 2000.
+
+The Unicode character classes \p{Blank} and \p{SpacePerl} have been
+added.  "Blank" is like C isblank(), that is, it contains only
+"horizontal whitespace" (the space character is, the newline isn't),
+and the "SpacePerl" is the Unicode equivalent of C<\s> (\p{Space}
+isn't, since that includes the vertical tabulator character, whereas
+C<\s> doesn't.)
+
+If you are experimenting with Unicode support in perl, the development
+versions of Perl may have more to offer.  In particular, I/O layers
+are now available in the development track, but not in the maintenance
+track, primarily to do backward compatibility issues.  Unicode support
+is also evolving rapidly on a daily basis in the development track--the
+maintenance track only reflects the most conservative of these changes.
+
+=item 64-bit support
+
+Support for 64-bit platforms has been improved, but continues to be
+experimental.  The level of support varies greatly among platforms.
+
+=item Compiler
+
+The B Compiler and its various backends have had many incremental
+improvements, but they continue to remain highly experimental.  Use in
+production environments is discouraged.
+
+The perlcc tool has been rewritten so that the user interface is much
+more like that of a C compiler.
+
+The perlbc tools has been removed.  Use C<perlcc -B> instead.
+
+=item Lvalue subroutines
+
+There have been various bugfixes to support lvalue subroutines better.
+However, the feature still remains experimental.
+
+=item IO::Socket
+
+IO::Socket::INET failed to open the specified port if the service
+name was not known.  It now correctly uses the supplied port number
+as is.
+
+=item File::Find
+
+File::Find now chdir()s correctly when chasing symbolic links.
+
+=item xsubpp
+
+xsubpp now tolerates embedded POD sections.
+
+=item C<no Module;>
+
+C<no Module;> does not produce an error even if Module does not have an
+unimport() method.  This parallels the behavior of C<use> vis-a-vis
+C<import>.
+
+=item Tests
+
+A large number of tests have been added.
+
+=back
+
+=head2 Core features
+
+untie() will now call an UNTIE() hook if it exists.  See L<perltie>
+for details.
+
+The C<-DT> command line switch outputs copious tokenizing information.
+See L<perlrun>.
+
+Arrays are now always interpolated in double-quotish strings.  Previously,
+C<"foo@bar.com"> used to be a fatal error at compile time, if an array
+C<@bar> was not used or declared.  This transitional behavior was
+intended to help migrate perl4 code, and is deemed to be no longer useful.
+See L</"Arrays now always interpolate into double-quoted strings">.
+
+keys(), each(), pop(), push(), shift(), splice() and unshift()
+can all be overridden now.
+
+C<my __PACKAGE__ $obj> now does the expected thing.
+
+=head2 Configuration issues
+
+On some systems (IRIX and Solaris among them) the system malloc is demonstrably
+better.  While the defaults haven't been changed in order to retain binary
+compatibility with earlier releases, you may be better off building perl
+with C<Configure -Uusemymalloc ...> as discussed in the F<INSTALL> file.
+
+C<Configure> has been enhanced in various ways:
+
+=over
+
+=item *
+
+Minimizes use of temporary files.
+
+=item *
+
+By default, does not link perl with libraries not used by it, such as
+the various dbm libraries.  SunOS 4.x hints preserve behavior on that
+platform.
+
+=item *
+
+Support for pdp11-style memory models has been removed due to obsolescence.
+
+=item *
+
+Building outside the source tree is supported on systems that have
+symbolic links. This is done by running
+
+    sh /path/to/source/Configure -Dmksymlinks ...
+    make all test install
+
+in a directory other than the perl source directory.  See F<INSTALL>.
+
+=item *
+
+C<Configure -S> can be run non-interactively.
+
+=back
+
+=head2 Documentation
+
+README.aix, README.solaris and README.macos have been added.  README.posix-bc
+has been renamed to README.bs2000.  These are installed as L<perlaix>,
+L<perlsolaris>, L<perlmacos>, and L<perlbs2000> respectively.
+
+The following pod documents are brand new:
+
+    perlclib   Internal replacements for standard C library functions
+    perldebtut Perl debugging tutorial
+    perlebcdic Considerations for running Perl on EBCDIC platforms
+    perlnewmod Perl modules: preparing a new module for distribution
+    perlrequick        Perl regular expressions quick start
+    perlretut  Perl regular expressions tutorial
+    perlutil   utilities packaged with the Perl distribution
+
+The F<INSTALL> file has been expanded to cover various issues, such as
+64-bit support.
+
+A longer list of contributors has been added to the source distribution.
+See the file C<AUTHORS>.
+
+Numerous other changes have been made to the included documentation and FAQs.
+
+=head2 Bundled modules
+
+The following modules have been added.
+
+=over
+
+=item B::Concise
+
+Walks Perl syntax tree, printing concise info about ops.  See L<B::Concise>.
+
+=item File::Temp
+
+Returns name and handle of a temporary file safely.  See L<File::Temp>.
+
+=item Pod::LaTeX
+
+Converts Pod data to formatted LaTeX.  See L<Pod::LaTeX>.
+
+=item Pod::Text::Overstrike
+
+Converts POD data to formatted overstrike text.  See L<Pod::Text::Overstrike>.
+
+=back
+
+The following modules have been upgraded.
+
+=over
+
+=item CGI
+
+CGI v2.752 is now included.
+
+=item CPAN
+
+CPAN v1.59_54 is now included.
+
+=item Class::Struct
+
+Various bugfixes have been added.
+
+=item DB_File
+
+DB_File v1.75 supports newer Berkeley DB versions, among other
+improvements.
+
+=item Devel::Peek
+
+Devel::Peek has been enhanced to support dumping of memory statistics,
+when perl is built with the included malloc().
+
+=item File::Find
+
+File::Find now supports pre and post-processing of the files in order
+to sort() them, etc.
+
+=item Getopt::Long
+
+Getopt::Long v2.25 is included.
+
+=item IO::Poll
+
+Various bug fixes have been included.
+
+=item IPC::Open3
+
+IPC::Open3 allows use of numeric file descriptors.
+
+=item Math::BigFloat
+
+The fmod() function supports modulus operations.  Various bug fixes
+have also been included.
+
+=item Math::Complex
+
+Math::Complex handles inf, NaN etc., better.
+
+=item Net::Ping
+
+ping() could fail on odd number of data bytes, and when the echo service
+isn't running.  This has been corrected.
+
+=item Opcode
+
+A memory leak has been fixed.
+
+=item Pod::Parser
+
+Version 1.13 of the Pod::Parser suite is included.
+
+=item Pod::Text
+
+Pod::Text and related modules have been upgraded to the versions
+in podlators suite v2.08.
+
+=item SDBM_File
+
+On dosish platforms, some keys went missing because of lack of support for
+files with "holes".  A workaround for the problem has been added.
+
+=item Sys::Syslog
+
+Various bug fixes have been included.
+
+=item Tie::RefHash
+
+Now supports Tie::RefHash::Nestable to automagically tie hashref values.
+
+=item Tie::SubstrHash
+
+Various bug fixes have been included.
+
+=back
+
+=head2 Platform-specific improvements
+
+The following new ports are now available.
+
+=over
+
+=item NCR MP-RAS
+
+=item NonStop-UX
+
+=back
+
+Perl now builds under Amdahl UTS.
+
+Perl has also been verified to build under Amiga OS.
+
+Support for EPOC has been much improved.  See README.epoc.
+
+Building perl with -Duseithreads or -Duse5005threads now works
+under HP-UX 10.20 (previously it only worked under 10.30 or later).
+You will need a thread library package installed.  See README.hpux.
+
+Long doubles should now work under Linux.
+
+MacOS Classic is now supported in the mainstream source package.
+See README.macos.
+
+Support for MPE/iX has been updated.  See README.mpeix.
+
+Support for OS/2 has been improved.  See C<os2/Changes> and README.os2.
+
+Dynamic loading on z/OS (formerly OS/390) has been improved.  See
+README.os390.
+
+Support for VMS has seen many incremental improvements, including
+better support for operators like backticks and system(), and better
+%ENV handling.  See C<README.vms> and L<perlvms>.
+
+Support for Stratus VOS has been improved.  See C<vos/Changes> and README.vos.
+
+Support for Windows has been improved.
+
+=over
+
+=item *
+
+fork() emulation has been improved in various ways, but still continues
+to be experimental.  See L<perlfork> for known bugs and caveats.
+
+=item *
+
+%SIG has been enabled under USE_ITHREADS, but its use is completely
+unsupported under all configurations.
+
+=item *
+
+Borland C++ v5.5 is now a supported compiler that can build Perl.
+However, the generated binaries continue to be incompatible with those
+generated by the other supported compilers (GCC and Visual C++).
+
+=item *
+
+Non-blocking waits for child processes (or pseudo-processes) are
+supported via C<waitpid($pid, &POSIX::WNOHANG)>.
+
+=item *
+
+A memory leak in accept() has been fixed.
+
+=item *
+
+wait(), waitpid() and backticks now return the correct exit status under
+Windows 9x.
+
+=item *