This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate changes#7205..7210,7212,7214..7219,7222,7223,7225,7226,
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 18 Dec 2000 00:03:38 +0000 (00:03 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 18 Dec 2000 00:03:38 +0000 (00:03 +0000)
7228,7230..7241,7243,7346,7347,7350..7354,7356,7358..7360,7362,
7363,7365..7368,7370..7374,7376..7386,7391,7393..7399,7404..7408,
7410..7413 from mainline

Introduce the man[24-8] variables, from Andy Dougherty.

Upgrade to CPAN 1.58, from Andreas König.

An updated EBCDIC tr patch.
Subject: Re: [PATCH: perl@7181] op/tr tests on OS/390

Subject:  [PATCH] 5.6.0 & 5.7.1,  VMS fixes

Two thirds of
Subject: Proposed patches, Install.pm getopts.pl termcap.pl
The Install.pm changes will be submitted separately because
they need some work and discussion still.

The Install.pm third of
Subject: Proposed patches, Install.pm getopts.pl termcap.pl

Subject: [PATCH: perl@7181] was: Re: off to a bad start on fixing regression tests

Subject: [PATCH 5.7.0] IVs in mtats

Subject: [PATCH 5.7.0] Perl API for mstats

Ilya implemented the memory profiling API.

In Amdahl UTS "struct sv" is defined by a system header,
<ksync.h>.

Slight tweak of the code to appease Amdahl UTS cc.

Amdahl UTS doesn't seem to do dynaloading.

Use UTF8SKIP(), from Simon Cozens.

Thinko in #7222.

op/sprintf.t patch for OS/390 (and any other host with limited
floating-point exponent length)
Subject: Re: [ID 20001006.014] Not OK: perl v5.7.0 +DEVEL7158 on os390 05.00  (UNINSTALLED) [PATCH bleadperl]

Tweak #7225.
Subject: Re: [ID 20001006.014] Not OK: perl v5.7.0 +DEVEL7158 on os390 05.00 (UNINSTALLED) [PATCH bleadperl]

Subject: RFC: a (temporary?) way around utf8.pm for EBCDIC

Needs to be conditional on SunOS 4.
Subject: [Pach 5.7.0@7229] Removing -ldb from the core build

Test cases for bug id 20000323.056 (the bug seems to be fixed).

Add test for bug id 20000427.003 (which seems to have
been fixed) (also duplicate as 20000427.004, though
with a higher severity).  Move one utf8 from op/append
to pragma/utf8, tag the tests with bug ids.

Document FNCASE=y as discussed in the bug 20000902.009.

split() utf8 fixes.  Should fix both 20001014.001 and 20000426.003.
The problem was that rx->minlen was in chars while pp_split()
thought it would be in bytes.

Make ~(chr(a).chr(b)) eq chr(~a).chr(~b) on utf8.
Subject: [PATCH] Re: [ID 20000918.005] ~ on wide chars

Fix few quad issues, which for example broke chr(~chr(~0)) for UTF8.

Fix a couple of compiler-noted nits in #7235.

Tweak the test of #7235.

One more ~utf8 tweak.

-w cleanup.
Subject: Re: Problems with bleadperl

Subject: small pod patch

Subject: [PATCH perlguts.pod] Document offset hack

Add Charles Lane.

Add the capability to include/exclude branches.

Subject: [ID 20001016.012] [PATCHes Included]OK: perl v5.7.0 on dos-djgpp djgpp

Detect early whether the std streams have gone bad.
Subject: PATCH (was Re: [ID 20001016.007] Not OK: perl v5.7.0 +DEVEL7228 on i586-linux 2.2.16 (UNINSTALLED))

More IoTYPE sprinkling.

Workaround for a sfio bug where the stream error indicator
is not cleared as documented.
Subject: PATCH (was Re: [ID 20001016.007] Not OK: perl v5.7.0 +DEVEL7228 on i586-linux 2.2.16 (UNINSTALLED))

Clarify documentation on 'use bytes'.
Subject: Re: What does 'use bytes' "mean" ?

Show the failed remote port, instead of the failing line number.
Subject: [PATCH 5.6.1 Debugger] More diagnostics

Make Cwd more bulletproof in chrooted environments.
Subject: [ID 20001018.001] Fix for Cwd.pm (chroot)

Subject: Pod patch for Devel::Peek

Subject: Re: [ID 20001013.008] perl 5.6.0 on AIX 4.3.2 w/GCC 2.95.2

Borland C fstat() never saw the fd as writable.
Subject: fix for Borland's weak "stat" (perl@7211)

Missing change from #7362.

Subject: [PATCH 5.7.0] Re: [ID 20001018.008] flip-flop bug when there's no <FH>

Add the test case for the bug id 20000730.004 which seems
to have been fixed by now.

Fix of sorts for bug id 20000901.092.  There seems to be no trace
of a 'pmshort' anywhere in the B, so the offending line was simply
removed.

Subject: Re: [ID 20001013.008] perl 5.6.0 on AIX w/GCC

Subject: PATCH do_print has 2 PerlIO_error()s

NonStop-UX patches from Tom Bates <tom.bates@compaq.com>

Typo noted by Mark Lutz.

Subject: PATCH CR+LF should be "\cM\cJ" in perlop

In the latest compiler builds cccdlflags must not become -fpic,
from Wilfredo Sánchez.

Subject:  [PATCH] Perl 5.6.0/5.7.0, vms/gen_shrfls.pl update

Subject:  [PATCH] Perl 5.6.0/5.7.0 enable DProf test for VMS

SOCKS function redefinitions need prototypes, too, otherwise
for example 32 bit versus 64 bit differences cause a lot of
problems.  Part of
Subject: [ID 20001016.017] [jens: 5.7.0 Solaris 8, 64 Bit, Workshop 6.0 Compiler]

Portability tweak on #7377.
Subject:  Re: [nick@cow.org.uk: [ID 20001020.004] Not OK: perl v5.7.0 +DEVEL7368 on i386-freebsd-64all 4.1-stable (UNINSTALLED)]

Don't write double values through long double pointers,
based on a part of
Subject: [ID 20001016.017] [jens: 5.7.0 Solaris 8, 64 Bit, Workshop 6.0 Compiler]

Reëntrancy fix.
Subject: [PATCH perl@7229] Rentrant parser and yylex()

Make scan_num() reëntrant, as suggested in
Subject: [PATCH perl@7229] Rentrant parser and yylex()

Fix for ID 20001020.006, concatenating an unset submatch
with utf8 resulted in "Modification of a read-only value".

Fix for ID 20000915.011, IO::Select warning for an undefined fd.

The #7383 was right only in the context of the original bug report,
not in more general case.

Update Changes.

Testcases for a #7383,#7385 related bug.
Subject: PATCH Re: [ID 20001020.006] "$2$utf8" == modification of read-only-variable

Subject: [PATCH@blead Tie/Array.pm] Re: [ID 20001020.002] Tie::Array SPLICE method is buggy

Tweak the Is* definitions of Unicode character classes
to better match the official categorizations; embrace
the official categorizations; add the combining marks
as alpha (and -numeric); fix DCinital (a typo and edito)
to be DCmedial.

Hints tweak from Anton Berezin.

Subject: installman go-faster stripes
Subject: Re: installman go-faster stripes

Subject: [ID 20001021.003] updated hints/openbsd.sh

Subject: [PATCH bleadperl] -MO=C falls over on package <none>

Subject: PATCH $Config::Config{ldlibpthname} in ext/DynaLoader/DynaLoader_pm.PL

Subject: [PATCH] Re: [ID 20000121.007] XXX documentation in man ExtUtils::MakeMaker

Doc patch.
Subject: [ID 19991128.002] \&{'foo'} not caught by strict refs

Retract #7404 with a patch from Robin Barker, via Andy Dougherty.

Subject: Re: [ID 20001021.005] SEGV with regex match

Subject: Re: [20000731.007] potential syntax error not detected [PATCH]

The change #7187 was not so good on VMS.
Subject: [PATCH perl@7369] VMS perldoc.PL fix for double quoted temp filename

Subject: [PATCH: perl@7386] miscellaneous typos in 3 pods

Miscellaneous MacOS Classic library updates from Matthias Neeracher.

Document PERL_INSTALL_ROOT of #7210.

p4raw-link: @7219 on //depot/perl: d67493ed56a1a4cbcbfc722e3d9ed0c4f29c3963
p4raw-link: @7214 on //depot/perl: 880b20b67e23950959b9017ea50a2f9fe4e915a4
p4raw-link: @7212 on //depot/perl: 2f2d036aac7a6d378d15faf96ae8ed621bef910c
p4raw-link: @7210 on //depot/perl: a9d83807f0f0b611a2eea3bda7bb80eac9d5b104
p4raw-link: @7205 on //depot/perl: 6f748670132fcfd6aa343cd6dd2a0b18fc867c63on //depot/metaconfig: a1829424efc881dd6263214c1b17e46de8ac69c8
p4raw-link: @7187 on //depot/perl: a79ff10558a3b8e128b0898794bddcf07255f408

p4raw-id: //depot/maint-5.6/perl@8159
p4raw-branched: from //depot/perl@8156 'branch in'
lib/unicode/Is/DCmedial.pl t/lib/tie-splice.t
p4raw-deleted: from //depot/perl@8156 'delete in'
lib/unicode/Is/DCinital.pl (@6930..)
p4raw-integrated: from //depot/perl@8156 'copy in' t/op/flip.t (@536..)
t/lib/dprof/V.pm (@3710..) lib/getopts.pl lib/termcap.pl
(@3759..) perly.y (@5009..) hints/darwin.sh (@5266..) dosish.h
(@5628..) lib/ExtUtils/Mksymlists.pm (@5769..)
vms/ext/Stdio/Stdio.pm (@5823..) lib/strict.pm (@5843..) Todo
(@5897..) t/op/oct.t (@6044..) perly.c (@6194..)
ext/IO/lib/IO/Select.pm (@6586..) hints/freebsd.sh (@6894..)
lib/unicode/Is/Alnum.pl lib/unicode/Is/Alpha.pl
lib/unicode/Is/Graph.pl lib/unicode/Is/Print.pl
lib/unicode/Is/Punct.pl lib/unicode/Is/Space.pl
lib/unicode/Is/Word.pl (@6930..) t/pod/find.t (@6978..)
t/pod/testp2pt.pl (@7048..) t/op/64bitint.t (@7057..)
myconfig.SH (@7060..) pod/perlmod.pod (@7097..) t/op/append.t
(@7100..) hints/openbsd.sh (@7122..) ext/B/B/Debug.pm (@7134..)
installman (@7140..) lib/Tie/Array.pm (@7151..)
utils/perldoc.PL (@7187..) pod/perlebcdic.pod (@7191..)
t/op/tr.t (@7193..) lib/ExtUtils/Install.pm (@7210..)
ext/Devel/Peek/Peek.pm (@7215..) t/lib/dprof.t (@7377..)
p4raw-integrated: from //depot/perl@7412 'copy in' lib/Term/ReadLine.pm
(@3601..) lib/File/Basename.pm (@5296..) lib/File/Path.pm
(@5592..) lib/perl5db.pl (@7356..)
p4raw-integrated: from //depot/perl@7408 'copy in' lib/vars.pm
(@5948..)
p4raw-integrated: from //depot/perl@7407 'copy in' t/op/pat.t (@6874..)
regexec.c (@7115..)
p4raw-integrated: from //depot/perl@7406 'copy in'
lib/ExtUtils/MakeMaker.pm (@7404..)
p4raw-integrated: from //depot/perl@7399 'copy in'
ext/DynaLoader/DynaLoader_pm.PL (@6359..)
p4raw-integrated: from //depot/perl@7398 'copy in' ext/B/B/C.pm
(@5593..) ext/B/B.pm (@6763..)
p4raw-integrated: from //depot/perl@7396 'copy in' pod/pod2man.PL
(@7047..)
p4raw-integrated: from //depot/perl@7394 'copy in'
lib/unicode/mktables.PL (@7030..) 'edit in' MANIFEST (@7393..)
p4raw-integrated: from //depot/perl@7391 'copy in' t/pragma/utf8.t
(@7383..)
p4raw-integrated: from //depot/perl@7385 'edit in' pp_hot.c (@7383..)
p4raw-integrated: from //depot/perl@7382 'edit in' embed.h embed.pl
proto.h toke.c (@7381..) 'ignore' objXSUB.h (@7096..) 'merge
in' perlapi.c (@7096..)
p4raw-integrated: from //depot/perl@7381 'ignore' perl.h (@7380..)
p4raw-integrated: from //depot/perl@7380 'edit in' pp.c (@7364..)
p4raw-integrated: from //depot/perl@7378 'edit in' doio.c (@7370..)
'merge in' pp_sys.c (@7213..)
p4raw-integrated: from //depot/perl@7377 'copy in' vms/test.com
(@7053..) configure.com (@7376..)
p4raw-integrated: from //depot/perl@7376 'copy in' vms/gen_shrfls.pl
(@7208..)
p4raw-integrated: from //depot/perl@7373 'copy in' pod/perlop.pod
(@7121..)
p4raw-branched: from //depot/perl@7371 'branch in' hints/nonstopux.sh
p4raw-integrated: from //depot/perl@7371 'edit in' Configure (@7230..)
'ignore' config_h.SH (@7205..)
p4raw-integrated: from //depot/perl@7368 'copy in' hints/aix.sh
(@6982..)
p4raw-integrated: from //depot/perl@7365 'copy in' t/pragma/warn/pp_hot
(@6531..) 'merge in' pp_ctl.c (@7165..)
p4raw-integrated: from //depot/perl@7363 'copy in' win32/perlhost.h
(@6662..)
p4raw-integrated: from //depot/perl@7362 'copy in' win32/win32.c
(@7173..)
p4raw-integrated: from //depot/perl@7361 'copy in' pod/buildtoc.PL
(@6844..) pod/perl.pod (@6894..) pod/perlport.pod (@7176..)
p4raw-branched: from //depot/perl@7360 'branch in' README.aix
p4raw-integrated: from //depot/perl@7358 'copy in' lib/Cwd.pm (@7124..)
p4raw-integrated: from //depot/perl@7354 'copy in' lib/bytes.pm
(@5629..)
p4raw-integrated: from //depot/perl@7351 'copy in' t/op/misc.t
(@6874..)
p4raw-integrated: from //depot/perl@7350 'copy in' djgpp/djgpp.c
(@5288..) t/io/open.t (@6874..)
p4raw-integrated: from //depot/perl@7347 'copy in' Porting/genlog
(@4604..)
p4raw-integrated: from //depot/perl@7346 'copy in' AUTHORS (@6961..)
p4raw-integrated: from //depot/perl@7243 'merge in' pod/perlguts.pod
(@7001..)
p4raw-integrated: from //depot/perl@7241 'copy in' pod/perlfaq7.pod
(@6344..)
p4raw-integrated: from //depot/perl@7240 'merge in' t/pragma/overload.t
(@7104..)
p4raw-integrated: from //depot/perl@7239 'copy in' t/op/bop.t (@7238..)
p4raw-integrated: from //depot/perl@7235 'copy in' utf8.h (@7154..)
p4raw-integrated: from //depot/perl@7233 'copy in' README.dos (@5505..)
p4raw-integrated: from //depot/perl@7228 'copy in' lib/utf8.pm
(@6593..)
p4raw-integrated: from //depot/perl@7226 'copy in' t/op/sprintf.t
(@7225..)
p4raw-integrated: from //depot/perl@7223 'edit in' utf8.c (@7222..)
p4raw-integrated: from //depot/perl@7219 'copy in' hints/uts.sh
(@1575..)
p4raw-integrated: from //depot/perl@7217 'copy in' sv.h (@7156..)
p4raw-integrated: from //depot/perl@7215 'copy in'
ext/Devel/Peek/Peek.xs (@7081..)
p4raw-integrated: from //depot/perl@7214 'copy in' malloc.c (@7081..)
p4raw-integrated: from //depot/perl@7208 'copy in' lib/File/Temp.pm
(@6964..)
p4raw-integrated: from //depot/perl@7206 'copy in' lib/CPAN.pm
lib/CPAN/FirstTime.pm (@7046..)
p4raw-integrated: from //depot/perl@7205 'copy in' vos/config.pl
(@6816..) vos/config.h vos/config_h.SH_orig (@6982..)
Porting/config_H (@7195..) Porting/Glossary Porting/config.sh
epoc/config.sh vos/config.def win32/config.bc win32/config.gc
win32/config.vc (@7196..)

111 files changed:
AUTHORS
Configure
MANIFEST
Porting/config.sh
Porting/config_H
Porting/genlog
README.aix [new file with mode: 0644]
README.dos
Todo
configure.com
djgpp/djgpp.c
doio.c
dosish.h
embed.h
embed.pl
epoc/config.sh
ext/B/B.pm
ext/B/B/C.pm
ext/B/B/Debug.pm
ext/Devel/Peek/Peek.pm
ext/Devel/Peek/Peek.xs
ext/DynaLoader/DynaLoader_pm.PL
ext/IO/lib/IO/Select.pm
hints/aix.sh
hints/darwin.sh
hints/freebsd.sh
hints/nonstopux.sh [new file with mode: 0644]
hints/openbsd.sh
hints/uts.sh
installman
lib/CPAN.pm
lib/CPAN/FirstTime.pm
lib/Cwd.pm
lib/ExtUtils/Install.pm
lib/ExtUtils/MakeMaker.pm
lib/ExtUtils/Mksymlists.pm
lib/File/Basename.pm
lib/File/Path.pm
lib/File/Temp.pm
lib/Term/ReadLine.pm
lib/Tie/Array.pm
lib/bytes.pm
lib/getopts.pl
lib/perl5db.pl
lib/strict.pm
lib/termcap.pl
lib/unicode/Is/Alnum.pl
lib/unicode/Is/Alpha.pl
lib/unicode/Is/DCmedial.pl [moved from lib/unicode/Is/DCinital.pl with 100% similarity]
lib/unicode/Is/Graph.pl
lib/unicode/Is/Print.pl
lib/unicode/Is/Punct.pl
lib/unicode/Is/Space.pl
lib/unicode/Is/Word.pl
lib/unicode/mktables.PL
lib/utf8.pm
lib/vars.pm
malloc.c
myconfig.SH
perl.h
perlapi.c
perly.c
perly.y
pod/buildtoc.PL
pod/perl.pod
pod/perlebcdic.pod
pod/perlfaq7.pod
pod/perlguts.pod
pod/perlmod.pod
pod/perlop.pod
pod/perlport.pod
pod/pod2man.PL
pp.c
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regexec.c
sv.h
t/io/open.t
t/lib/dprof.t
t/lib/dprof/V.pm
t/lib/tie-splice.t [new file with mode: 0644]
t/op/64bitint.t
t/op/append.t
t/op/bop.t
t/op/flip.t
t/op/misc.t
t/op/oct.t
t/op/pat.t
t/op/sprintf.t
t/op/tr.t
t/pod/find.t
t/pod/testp2pt.pl
t/pragma/overload.t
t/pragma/utf8.t
t/pragma/warn/pp_hot
toke.c
utf8.c
utf8.h
utils/perldoc.PL
vms/ext/Stdio/Stdio.pm
vms/gen_shrfls.pl
vms/test.com
vos/config.h
vos/config_h.SH_orig
win32/config.bc
win32/config.gc
win32/config.vc
win32/perlhost.h
win32/win32.c

diff --git a/AUTHORS b/AUTHORS
index ba0a2de..b3d240c 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -35,6 +35,7 @@ k             Andreas K
 kjahds         Kenneth Albanowski      kjahds@kjahds.com
 krishna                Krishna Sethuraman      krishna@sgi.com
 kstar          Kurt D. Starsinic       kstar@chapin.edu
+lane           Charles Lane            lane@DUPHY4.Physics.Drexel.Edu
 lstein         Lincoln D. Stein        lstein@genome.wi.mit.edu
 lutherh                Luther Huffman          lutherh@stratcom.com
 lutz           Mark P. Lutz            mark.p.lutz@boeing.com
index 0961c33..d6bea1a 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -20,7 +20,7 @@
 
 # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
 #
-# Generated on Wed Oct 11 00:32:36 EET DST 2000 [metaconfig 3.0 PL70]
+# Generated on Thu Oct 19 22:28:50 EET DST 2000 [metaconfig 3.0 PL70]
 # (with additional metaconfig patches by perlbug@perl.org)
 
 cat >/tmp/c1$$ <<EOF
@@ -2426,6 +2426,7 @@ EOM
                        esac
                        ;;
                next*) osname=next ;;
+               NonStop-UX) osname=nonstopux ;;
                POSIX-BC | posix-bc ) osname=posix-bc
                        osvers="$3"
                        ;;
@@ -6371,13 +6372,13 @@ EOM
                        hpux)   dflt='+z' ;;
                        next)   dflt='none' ;;
                        irix*)  dflt='-KPIC' ;;
-                       svr4*|esix*|solaris) dflt='-KPIC' ;;
+                       svr4*|esix*|solaris|nonstopux) dflt='-KPIC' ;;
                        sunos)  dflt='-pic' ;;
                        *)      dflt='none' ;;
                    esac
                        ;;
                *)  case "$osname" in
-                       svr4*|esix*|solaris) dflt='-fPIC' ;;
+                       svr4*|esix*|solaris|nonstopux) dflt='-fPIC' ;;
                        *)      dflt='-fpic' ;;
                    esac ;;
            esac ;;
@@ -6453,7 +6454,7 @@ EOM
                        next)  dflt='none' ;;
                        solaris) dflt='-G' ;;
                        sunos) dflt='-assert nodefinitions' ;;
-                       svr4*|esix*) dflt="-G $ldflags" ;;
+                       svr4*|esix*|nonstopux) dflt="-G $ldflags" ;;
                *)     dflt='none' ;;
                        esac
                        ;;
@@ -6528,7 +6529,7 @@ $undef)
        ;;
 *)     case "$useshrplib" in
        '')     case "$osname" in
-               svr4*|dgux|dynixptx|esix|powerux|beos|cygwin*)
+               svr4*|nonstopux|dgux|dynixptx|esix|powerux|beos|cygwin*)
                        dflt=y
                        also='Building a shared libperl is required for dynamic loading to work on your system.'
                        ;;
@@ -14476,7 +14477,7 @@ mert MiNT mips MIPS_FPSET MIPS_ISA MIPS_SIM MIPS_SZINT
 MIPS_SZLONG MIPS_SZPTR MIPSEB MIPSEL MODERN_C motorola
 mpeix MSDOS MTXINU MULTIMAX mvs MVS n16 ncl_el ncl_mr
 NetBSD news1500 news1700 news1800 news1900 news3700
-news700 news800 news900 NeXT NLS ns16000 ns32000
+news700 news800 news900 NeXT NLS nonstopux ns16000 ns32000
 ns32016 ns32332 ns32k nsc32000
 OCS88 OEMVS OpenBSD os OS2 OS390 osf OSF1 OSF_SOURCE
 pa_risc PA_RISC1_1 PA_RISC2_0 PARAGON parisc
@@ -15167,14 +15168,21 @@ extensions="$*"
 
 : Remove libraries needed only for extensions
 : The appropriate ext/Foo/Makefile.PL will add them back in, if necessary.
-case "$usedl" in
-$define|true|[yY]*)
-       set X `echo " $libs " | sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` 
-       shift
-       perllibs="$*"
-       ;;
-*)     perllibs="$libs"
-       ;;
+: The exception is SunOS 4.x, which needs them.
+case "${osname}X${osvers}" in
+sunos*X4*)
+    perllibs="$libs"
+    ;;
+*) case "$usedl" in
+    $define|true|[yY]*)
+           set X `echo " $libs " | sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` 
+           shift
+           perllibs="$*"
+           ;;
+    *) perllibs="$libs"
+           ;;
+    esac
+    ;;
 esac
 
 : Remove build directory name from cppstdin so it can be used from
index cbccf3f..4c6dd45 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -32,6 +32,7 @@ Porting/patchls               Flexible patch file listing utility
 Porting/pumpkin.pod    Guidelines and hints for Perl maintainers
 README                 The Instructions
 README.Y2K             Notes about Year 2000 concerns
+README.aix             Notes about AIX port
 README.amiga           Notes about AmigaOS port
 README.apollo          Notes about Apollo DomainOS port
 README.beos            Notes about BeOS port
@@ -480,6 +481,7 @@ hints/newsos4.sh    Hints for named architecture
 hints/next_3.sh                Hints for named architecture
 hints/next_3_0.sh      Hints for named architecture
 hints/next_4.sh                Hints for named architecture
+hints/nonstopux.sh     Hints for named architecture
 hints/openbsd.sh       Hints for named architecture
 hints/opus.sh          Hints for named architecture
 hints/os2.sh           Hints for named architecture
@@ -872,9 +874,9 @@ lib/unicode/Is/DCcompat.pl                  Unicode character database
 lib/unicode/Is/DCfinal.pl                      Unicode character database
 lib/unicode/Is/DCfont.pl                       Unicode character database
 lib/unicode/Is/DCfraction.pl                   Unicode character database
-lib/unicode/Is/DCinital.pl                     Unicode character database
 lib/unicode/Is/DCinitial.pl                    Unicode character database
 lib/unicode/Is/DCisolated.pl                   Unicode character database
+lib/unicode/Is/DCmedial.pl                     Unicode character database
 lib/unicode/Is/DCnarrow.pl                     Unicode character database
 lib/unicode/Is/DCnoBreak.pl                    Unicode character database
 lib/unicode/Is/DCsmall.pl                      Unicode character database
@@ -1384,6 +1386,7 @@ t/lib/texttabs.t  See if Text::Tabs works
 t/lib/textwrap.t       See if Text::Wrap::wrap works
 t/lib/thr5005.t                Test 5.005-style threading (skipped if no use5005threads) 
 t/lib/tie-push.t       Test for Tie::Array
+t/lib/tie-splice.t     Test for Tie::Array::SPLICE
 t/lib/tie-stdarray.t   Test for Tie::StdArray
 t/lib/tie-stdhandle.t  Test for Tie::StdHandle
 t/lib/tie-stdpush.t    Test for Tie::StdArray
index bd63468..632c469 100644 (file)
@@ -8,7 +8,7 @@
 
 # Package name      : perl5
 # Source directory  : /m/fs/work/work/permanent/perl/pp4/perl
-# Configuration time: Wed Oct 11 00:34:23 EET DST 2000
+# Configuration time: Fri Oct 13 02:12:22 EET DST 2000
 # Configured by     : jhi
 # Target system     : osf1 alpha.hut.fi v4.0 878 alpha 
 
@@ -62,7 +62,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_
 ccversion='V5.6-082'
 cf_by='jhi'
 cf_email='yourname@yourhost.yourplace.com'
-cf_time='Wed Oct 11 00:34:23 EET DST 2000'
+cf_time='Fri Oct 13 02:12:22 EET DST 2000'
 charsize='1'
 chgrp=''
 chmod=''
index a8f9456..149760c 100644 (file)
@@ -17,7 +17,7 @@
 /*
  * Package name      : perl5
  * Source directory  : /m/fs/work/work/permanent/perl/pp4/perl
- * Configuration time: Wed Oct 11 00:01:55 EET DST 2000
+ * Configuration time: Fri Oct 13 02:12:22 EET DST 2000
  * Configured by     : jhi
  * Target system     : osf1 alpha.hut.fi v4.0 878 alpha 
  */
index efb7ef8..218da41 100755 (executable)
@@ -20,7 +20,7 @@ use Text::Wrap;
 $0 =~ s|^.*/||;
 unless (@ARGV) {
     die <<USAGE;
-        $0 [-p \$P4PORT] <change numbers or from..to>
+        $0 [-p \$P4PORT] [-bi branch_include] [-be branch_exclude] <change numbers or from..to>
 USAGE
 }
 
@@ -32,6 +32,11 @@ my %editkind;
 
 my $p4port = $ENV{P4PORT} || 'localhost:1666';
 
+my @branch_include;
+my @branch_exclude;
+my %branch_include;
+my %branch_exclude;
+
 while (@ARGV) {
     $_ = shift;
     if (/^(\d+)\.\.(\d+)$/) {
@@ -43,6 +48,12 @@ while (@ARGV) {
     elsif (/^-p(.*)$/) {
         $p4port = $1 || shift;
     }
+    elsif (/^-bi(.*)$/) {
+        push @branch_include, $1 || shift;
+    }
+    elsif (/^-be(.*)$/) {
+        push @branch_exclude, $1 || shift;
+    }
     else {
         warn "Arguments must be change numbers, ignoring `$_'\n";
     }
@@ -50,6 +61,9 @@ while (@ARGV) {
 
 @changes = sort { $b <=> $a } @changes;
 
+@branch_include{@branch_include} = @branch_include if @branch_include;
+@branch_exclude{@branch_exclude} = @branch_exclude if @branch_exclude;
+
 my @desc = `p4 -p $p4port describe -s @changes`;
 if ($?) {
     die "$0: `p4 -p $p4port describe -s @changes` failed, status[$?]\n";
@@ -58,6 +72,7 @@ else {
     chomp @desc;
     while (@desc) {
        my ($change,$who,$date,$time,@log,$branch,$file,$type,%files);
+       my $skip = 0;
        $_ = shift @desc;
        if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) {
            ($change, $who, $date, $time) = ($1,$2,$3,$4);
@@ -73,6 +88,11 @@ else {
                    last unless /^\.\.\./;
                    if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) {
                        ($branch,$file,$type) = ($1,$2,$3);
+                       if (exists $branch_exclude{$branch} or
+                           @branch_include and
+                           not exists $branch_include{$branch}) {
+                           $skip++;
+                       }
                        $files{$branch} = {} unless exists $files{$branch};
                        $files{$branch}{$type} = [] unless exists $files{$branch}{$type};
                        push @{$files{$branch}{$type}}, $file;
@@ -83,7 +103,7 @@ else {
                }
            }
        }
-       next unless $change;
+       next if not $change or $skip;
        print "_" x 76, "\n";
        printf <<EOT, $change, $who, $date, $time;
 [%6s] By: %-25s             on %9s %9s
diff --git a/README.aix b/README.aix
new file mode 100644 (file)
index 0000000..6346a18
--- /dev/null
@@ -0,0 +1,100 @@
+If you read this file _as_is_, just ignore the funny characters you see.
+It is written in the POD format (see pod/perlpod.pod) which is specially
+designed to be readable as is.
+
+=head1 NAME
+
+README.aix - Perl version 5 on IBM Unix (AIX) systems
+
+=head1 DESCRIPTION
+
+This document describes various features of IBM's Unix operating system
+(AIX) that will affect how Perl version 5 (hereafter just Perl) is
+compiled and/or runs.
+
+=head2 Compiling Perl 5 on AIX
+
+When compiling Perl, you must use an ANSI C compiler. AIX does not shif
+an ANSI compliant C-compiler with AIX by default, but binary builds of
+gcc for AIX are widely available.
+
+At the moment of writing, AIX supports two different native C compilers,
+for which you have to pay: B<xlc> and B<VAC>. If you decide to use eiter
+of these two (which is quite a lot easier than using gcc), be sure to
+upgrade to the latest available patch level. Currently:
+
+    xlC.C     3.1.4.0
+    vac.C     4.4.0.3  (5.0 is already available)
+
+Perl can be compiled with either IBM's ANSI C compiler or with gcc.  The
+former is recommended, as not only can it compile Perl with no
+difficulty, but also can take advantage of features listed later that
+require the use of IBM compiler-specific command-line flags.
+
+If you decide to use gcc, make sure your installation is recent and
+complete, and be sure to read the Perl README file for more gcc-specific
+details.
+
+=head2 OS level
+
+Before installing the patches to the IBM C-compiler you need to know the
+level of patching for the Operating System. IBM's command 'oslevel' will
+show the base, but is not allways complete:
+
+    # oslevel
+    4.3.0.0
+    # lslpp -l | grep 'bos.rte '
+    bos.rte      4.3.2.1  COMMITTED  Base Operating System Runtime
+    bos.rte      4.3.2.0  COMMITTED  Base Operating System Runtime
+    #
+
+=head2 Building Dynamic Extensions on AIX
+
+AIX supports dynamically loadable libraries (shared libraries).
+Shared libraries end with the suffix .a, which is a bit misleading,
+cause *all* libraries are shared ;-).
+
+=head2 The IBM ANSI C Compiler
+
+All defaults for Configure can be used.
+
+If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions
+will turn up nasty later on.
+
+=head2 Using GNU's gcc for building perl
+
+... ?
+
+Wait, I'll have to scan perlbug ...
+
+=head2 Using Large Files with Perl
+
+... ?
+
+=head2 Threaded Perl
+
+... ?
+
+=head2 64-bit Perl
+
+... ?
+
+=head2 GDBM and Threads
+
+... ?
+
+=head2 NFS filesystems and utime(2)
+
+... ?
+
+=head1 AUTHOR
+
+H.Merijn Brand <h.m.brand@hccnet.nl>
+
+Structure copied from README.hpux
+
+=head1 DATE
+
+Version 0.0.1: 16-10-2000
+
+=cut
index 9c3240e..51cd1d6 100644 (file)
@@ -100,9 +100,11 @@ sockets
 =item *
 
 Unpack the source package F<perl5.6*.tar.gz> with djtarx. If you want
-to use long file names under w95, don't forget to use
+to use long file names under w95 and also to get Perl to pass all its
+tests, don't forget to use
 
         set LFN=y
+       set FNCASE=y
 
 before unpacking the archive.
 
diff --git a/Todo b/Todo
index ba01d33..eb13f65 100644 (file)
--- a/Todo
+++ b/Todo
@@ -47,10 +47,6 @@ Would be nice to have
             to be used in re-entrant (=multithreaded) code
             Icky things: the _r API is not standardized and
             the _r-forms require per-thread data to store their state
-       memory profiler: turn malloc.c:Perl_get_mstats() into
-           an extension (Devel::MProf?) that would return the malloc
-           stats in a nice Perl datastructure (also a simple interface
-           to return just the grand total would be good)
        cross-compilation support
            host vs target: compile in the host, get the executable to
            the target, get the possible input files to the target,
index 28ce5e8..f4b607a 100644 (file)
@@ -2733,7 +2733,8 @@ $ ELSE d_mymalloc="undef"
 $ ENDIF
 $!
 $ usedl="define"
-$ startperl="""$ perl 'f$env(\""procedure\"")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8'  !\n$ exit++ + ++$status != 0 and $exit = $status = undef;"""
+$ startperl="""$ perl 'f$env(\""procedure\"")' \""'"+"'p1'\"" \""'"+"'p2'\"" \""'"+"'p3'\"" \""'"+"'p4'\"" \""'"+"'p5'\"" \""'"+"'p6'\"" \""'"+"'p7'\"" \""'"+"'p8'\""!\n"
+$ startperl=startperl + "$ exit++ + ++$status!=0 and $exit=$status=undef; while($ARGV[$#ARGV] eq '"+"'){pop @ARGV;}"""
 $!
 $ IF ((Use_Threads) .AND. (vms_ver .LES. "6.2"))
 $ THEN
@@ -4995,6 +4996,7 @@ $ WC "drand01='" + drand01 + "'"
 $ WC "dynamic_ext='" + extensions + "'"
 $ WC "eagain=' '"
 $ WC "ebcdic='undef'"
+$ WC "embedmymalloc='" + mymalloc + "'"
 $ WC "eunicefix=':'"
 $ WC "exe_ext='" + exe_ext + "'"
 $ WC "extensions='" + extensions + "'"
@@ -5238,6 +5240,7 @@ $ WC "uquadtype='" + uquadtype + "'"
 $ WC "use5005threads='" + use5005threads + "'"
 $ WC "use64bitall='" + use64bitall + "'"
 $ WC "use64bitint='" + use64bitint + "'"
+$ WC "usedebugging_perl='" + use_debugging_perl + "'"
 $ WC "usedl='" + usedl + "'"
 $ WC "useithreads='" + useithreads + "'"
 $ WC "uselargefiles='" + uselargefiles + "'"
index c928851..80a627e 100644 (file)
@@ -433,3 +433,22 @@ Perl_DJGPP_init (int *argcp,char ***argvp)
         strcpy (perlprefix,"..");
 }
 
+int
+djgpp_fflush (FILE *fp)
+{
+    int res;
+
+    if ((res = fflush(fp)) == 0 && fp) {
+       Stat_t s;
+       if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
+           res = fsync(fileno(fp));
+    }
+/*
+ * If the flush succeeded but set end-of-file, we need to clear
+ * the error because our caller may check ferror().  BTW, this
+ * probably means we just flushed an empty file.
+ */
+    if (res == 0 && fp && ferror(fp) == EOF) clearerr(fp);
+
+    return res;
+}
diff --git a/doio.c b/doio.c
index de613f4..a97bcc5 100644 (file)
--- a/doio.c
+++ b/doio.c
 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
 # include <sys/socket.h>
 # if defined(USE_SOCKS) && defined(I_SOCKS)
+#   if !defined(INCLUDE_PROTOTYPES)
+#       define INCLUDE_PROTOTYPES /* for <socks.h> */
+#       define PERL_SOCKS_NEED_PROTOTYPES
+#   endif
 #   include <socks.h>
+#   ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
+#       undef INCLUDE_PROTOTYPES
+#       undef PERL_SOCKS_NEED_PROTOTYPES
+#   endif 
 # endif 
 # ifdef I_NETBSD
 #  include <netdb.h>
@@ -87,7 +95,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     register IO *io = GvIOn(gv);
     PerlIO *saveifp = Nullfp;
     PerlIO *saveofp = Nullfp;
-    char savetype = ' ';
+    char savetype = IoTYPE_CLOSED;
     int writing = 0;
     PerlIO *fp;
     int fd;
@@ -216,14 +224,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        }
        mode[0] = mode[1] = mode[2] = mode[3] = '\0';
        IoTYPE(io) = *type;
-       if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
+       if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */
            mode[1] = *type++;
            --tlen;
            writing = 1;
        }
 
-       if (*type == '|') {
-           if (num_svs && (tlen != 2 || type[1] != '-')) {
+       if (*type == IoTYPE_PIPE) {
+           if (num_svs && (tlen != 2 || type[1] != IoTYPE_STD)) {
              unknown_desr:
                Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
            }
@@ -261,10 +269,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
            writing = 1;
        }
-       else if (*type == '>') {
+       else if (*type == IoTYPE_WRONLY) {
            TAINT_PROPER("open");
            type++;
-           if (*type == '>') {
+           if (*type == IoTYPE_WRONLY) {
+               /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
                mode[0] = IoTYPE(io) = IoTYPE_APPEND;
                type++;
                tlen--;
@@ -313,7 +322,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                             * be optimized away on most platforms;
                             * only Solaris and Linux seem to flush
                             * on that. --jhi */
-                           PerlIO_seek(fp, 0, SEEK_CUR);
+#ifdef USE_SFIO
+                           /* sfio fails to clear error on next
+                              sfwrite, contrary to documentation.
+                              -- Nick Clark */
+                           if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
+                               PerlIO_clearerr(fp);
+#endif
                            /* On the other hand, do all platforms
                             * take gracefully to flushing a read-only
                             * filehandle?  Perhaps we should do
@@ -348,7 +363,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            else {
                /*SUPPRESS 530*/
                for (; isSPACE(*type); type++) ;
-               if (strEQ(type,"-")) {
+               if (*type == IoTYPE_STD && !type[1]) {
                    fp = PerlIO_stdout();
                    IoTYPE(io) = IoTYPE_STD;
                }
@@ -357,7 +372,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                }
            }
        }
-       else if (*type == '<') {
+       else if (*type == IoTYPE_RDONLY) {
            if (num_svs && tlen != 1)
                goto unknown_desr;
            /*SUPPRESS 530*/
@@ -372,16 +387,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                name = type;
                goto duplicity;
            }
-           if (strEQ(type,"-")) {
+           if (*type == IoTYPE_STD && !type[1]) {
                fp = PerlIO_stdin();
                IoTYPE(io) = IoTYPE_STD;
            }
            else
                fp = PerlIO_open((num_svs ? name : type), mode);
        }
-       else if (tlen > 1 && type[tlen-1] == '|') {
+       else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) {
            if (num_svs) {
-               if (tlen != 2 || type[0] != '-')
+               if (tlen != 2 || type[0] != IoTYPE_STD)
                    goto unknown_desr;
            }
            else {
@@ -1188,7 +1203,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
      * but only until the system hard limit/the filesystem limit,
      * at which we would get EPERM.  Note that when using buffered
      * io the write failure can be delayed until the flush/close. --jhi */
-    if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
+    if (len && (PerlIO_write(fp,tmps,len) == 0))
        return FALSE;
     return !PerlIO_error(fp);
 }
index 08b48fa..5f12b9d 100644 (file)
--- a/dosish.h
+++ b/dosish.h
 #define fwrite1 fwrite
 
 #define Fstat(fd,bufptr)   fstat((fd),(bufptr))
-#define Fflush(fp)         fflush(fp)
+#ifdef DJGPP
+#   define Fflush(fp)      djgpp_fflush(fp)
+#else
+#   define Fflush(fp)      fflush(fp)
+#endif
 #define Mkdir(path,mode)   mkdir((path),(mode))
 
 #ifndef WIN32
diff --git a/embed.h b/embed.h
index e99743f..1837b3f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #else
 #define yylex                  Perl_yylex
 #endif
+#define syylex                 S_syylex
 #define yyparse                        Perl_yyparse
 #define yywarn                 Perl_yywarn
 #if defined(MYMALLOC)
 #define scalarvoid(a)          Perl_scalarvoid(aTHX_ a)
 #define scan_bin(a,b,c)                Perl_scan_bin(aTHX_ a,b,c)
 #define scan_hex(a,b,c)                Perl_scan_hex(aTHX_ a,b,c)
-#define scan_num(a)            Perl_scan_num(aTHX_ a)
+#define scan_num(a,b)          Perl_scan_num(aTHX_ a,b)
 #define scan_oct(a,b,c)                Perl_scan_oct(aTHX_ a,b,c)
 #define scope(a)               Perl_scope(aTHX_ a)
 #define screaminstr(a,b,c,d,e,f)       Perl_screaminstr(aTHX_ a,b,c,d,e,f)
 #else
 #define yylex()                        Perl_yylex(aTHX)
 #endif
+#define syylex()               S_syylex(aTHX)
 #define yyparse()              Perl_yyparse(aTHX)
 #define yywarn(a)              Perl_yywarn(aTHX_ a)
 #if defined(MYMALLOC)
 #define Perl_yylex             CPerlObj::Perl_yylex
 #define yylex                  Perl_yylex
 #endif
+#define S_syylex               CPerlObj::S_syylex
+#define syylex                 S_syylex
 #define Perl_yyparse           CPerlObj::Perl_yyparse
 #define yyparse                        Perl_yyparse
 #define Perl_yywarn            CPerlObj::Perl_yywarn
index bce4243..7af1b17 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1942,7 +1942,7 @@ p |OP*    |scalarseq      |OP* o
 p      |OP*    |scalarvoid     |OP* o
 Ap     |NV     |scan_bin       |char* start|I32 len|I32* retlen
 Ap     |NV     |scan_hex       |char* start|I32 len|I32* retlen
-Ap     |char*  |scan_num       |char* s
+Ap     |char*  |scan_num       |char* s|YYSTYPE *lvalp
 Ap     |NV     |scan_oct       |char* start|I32 len|I32* retlen
 p      |OP*    |scope          |OP* o
 Ap     |char*  |screaminstr    |SV* bigsv|SV* littlesv|I32 start_shift \
@@ -2093,6 +2093,7 @@ p |int    |yylex          |YYSTYPE *lvalp|int *lcharp
 #else
 p      |int    |yylex
 #endif
+sp     |int    |syylex
 p      |int    |yyparse
 p      |int    |yywarn         |char* s
 #if defined(MYMALLOC)
index 2687a77..ee65ee3 100644 (file)
@@ -533,12 +533,26 @@ make_set_make='#'
 mallocobj=''
 mallocsrc=''
 malloctype='void *'
+man1='man1'
 man1dir=''
 man1direxp=''
 man1ext=''
+man2='man2'
+man2ext='2'
+man3='man3'
 man3dir=''
 man3direxp=''
 man3ext=''
+man4='man4'
+man4ext='4'
+man5='man5'
+man5ext='5'
+man6='man6'
+man6ext='6'
+man7='man7'
+man7ext='7'
+man8='man8'
+man8ext='8'
 mips=''
 mips_type=''
 mkdir='mkdir'
index 50364fa..dc4c4f7 100644 (file)
@@ -185,7 +185,7 @@ sub walksymtable {
        *glob = "*main::".$prefix.$sym;
        if ($sym =~ /::$/) {
            $sym = $prefix . $sym;
-           if ($sym ne "main::" && &$recurse($sym)) {
+           if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
                walksymtable(\%glob, $method, $recurse, $sym);
            }
        } else {
index d0c8159..f8b2ac5 100644 (file)
@@ -1368,7 +1368,7 @@ sub walkpackages
    if ($sym =~ /::$/) 
     {
      $sym = $prefix . $sym;
-     if ($sym ne "main::" && &$recurse($sym)) 
+     if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) 
       {
        walkpackages(\%glob, $recurse, $sym);
       }
index 3e212e2..1327591 100644 (file)
@@ -53,7 +53,6 @@ sub B::PMOP::debug {
     printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
     printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
     printf "\top_pmflags\t0x%x\n", $op->pmflags;
-    $op->pmshort->debug;
     $op->pmreplroot->debug;
 }
 
index 101adcd..0850172 100644 (file)
@@ -10,7 +10,8 @@ require Exporter;
 use XSLoader ();
 
 @ISA = qw(Exporter);
-@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg);
+@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg
+            fill_mstats mstats_fillhash mstats2hash);
 @EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
 %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
 
@@ -58,8 +59,7 @@ C<CV>.  Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and
 C<SvREFCNT_dec()> which can query, increment, and decrement reference
 counts on SVs.  This document will take a passive, and safe, approach
 to data debugging and for that it will describe only the C<Dump()>
-function.  For more information on the format of output of mstat() see
-L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>.
+function.
 
 Function C<DumpArray()> allows dumping of multiple values (useful when you
 need to analyze returns of functions).
@@ -68,6 +68,67 @@ The global variable $Devel::Peek::pv_limit can be set to limit the
 number of character printed in various string values.  Setting it to 0
 means no limit.
 
+=head2 Memory footprint debugging
+
+When perl is compiled with support for memory footprint debugging
+(default with Perl's malloc()), Devel::Peek provides an access to this API.
+
+Use mstat() function to emit a memory state statistic to the terminal.
+For more information on the format of output of mstat() see
+L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>.
+
+Three additional functions allow access to this statistic from Perl.
+First, use C<mstats_fillhash(%hash)> to get the information contained
+in the output of mstat() into %hash. The field of this hash are
+
+  minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack
+  topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree
+
+Two additional fields C<free>, C<used> contain array references which
+provide per-bucket count of free and used chunks.  Two other fields
+C<mem_size>, C<available_size> contain array references which provide
+the information about the allocated size and usable size of chunks in
+each bucket.  Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>
+for details.
+
+Keep in mind that only the first several "odd-numbered" buckets are
+used, so the information on size of the "odd-numbered" buckets which are
+not used is probably meaningless.
+
+The information in
+
+ mem_size available_size minbucket nbuckets
+
+is the property of a particular build of perl, and does not depend on
+the current process.  If you do not provide the optional argument to
+the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then
+the information in fields C<mem_size>, C<available_size> is not
+updated.
+
+C<fill_mstats($buf)> is a much cheaper call (both speedwise and
+memory-wise) which collects the statistic into $buf in
+machine-readable form.  At a later moment you may need to call
+C<mstats2hash($buf, %hash)> to use this information to fill %hash.
+
+All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and
+C<mstats2hash($buf, %hash)> are designed to allocate no memory if used
+I<the second time> on the same $buf and/or %hash.
+
+So, if you want to collect memory info in a cycle, you may call
+
+  $#buf = 999;
+  fill_mstats($_) for @buf;
+  mstats_fillhash(%report, 1);         # Static info too
+
+  foreach (@buf) {
+    # Do something...
+    fill_mstats $_;                    # Collect statistic
+  }
+  foreach (@buf) {
+    mstats2hash($_, %report);          # Preserve static info
+    # Do something with %report
+  }
+
 =head1 EXAMPLES
 
 The following examples don't attempt to show everything as that would be a
@@ -403,8 +464,9 @@ it has no prototype (C<PROTOTYPE> field is missing).
 =head1 EXPORTS
 
 C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and
-C<DumpProg> by default. Additionally available C<SvREFCNT>,
-C<SvREFCNT_inc> and C<SvREFCNT_dec>.
+C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by
+default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and
+C<SvREFCNT_dec>.
 
 =head1 BUGS
 
index dea57b1..e5fc8ae 100644 (file)
@@ -125,6 +125,180 @@ DeadCode(pTHX)
        PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
 #endif
 
+#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \
+       || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
+
+/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */
+#  define _NBUCKETS (2*8*IVSIZE+1)
+
+struct mstats_buffer 
+{
+    perl_mstats_t buffer;
+    UV buf[_NBUCKETS*4];
+};
+
+void
+_fill_mstats(struct mstats_buffer *b, int level)
+{
+    b->buffer.nfree  = b->buf;
+    b->buffer.ntotal = b->buf + _NBUCKETS;
+    b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS;
+    b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS;
+    Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long);
+    get_mstats(&(b->buffer), _NBUCKETS, level);
+}
+
+void
+fill_mstats(SV *sv, int level)
+{
+    int nbuckets;
+    struct mstats_buffer buf;
+
+    if (SvREADONLY(sv))
+       croak("Cannot modify a readonly value");
+    SvGROW(sv, sizeof(struct mstats_buffer)+1);
+    _fill_mstats((struct mstats_buffer*)SvPVX(sv),level);
+    SvCUR_set(sv, sizeof(struct mstats_buffer));
+    *SvEND(sv) = '\0';
+    SvPOK_only(sv);
+}
+
+void
+_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level)
+{
+    SV **svp;
+    int type;
+
+    svp = hv_fetch(hv, "topbucket", 9, 1);
+    sv_setiv(*svp, b->buffer.topbucket);
+
+    svp = hv_fetch(hv, "topbucket_ev", 12, 1);
+    sv_setiv(*svp, b->buffer.topbucket_ev);
+
+    svp = hv_fetch(hv, "topbucket_odd", 13, 1);
+    sv_setiv(*svp, b->buffer.topbucket_odd);
+
+    svp = hv_fetch(hv, "totfree", 7, 1);
+    sv_setiv(*svp, b->buffer.totfree);
+
+    svp = hv_fetch(hv, "total", 5, 1);
+    sv_setiv(*svp, b->buffer.total);
+
+    svp = hv_fetch(hv, "total_chain", 11, 1);
+    sv_setiv(*svp, b->buffer.total_chain);
+
+    svp = hv_fetch(hv, "total_sbrk", 10, 1);
+    sv_setiv(*svp, b->buffer.total_sbrk);
+
+    svp = hv_fetch(hv, "sbrks", 5, 1);
+    sv_setiv(*svp, b->buffer.sbrks);
+
+    svp = hv_fetch(hv, "sbrk_good", 9, 1);
+    sv_setiv(*svp, b->buffer.sbrk_good);
+
+    svp = hv_fetch(hv, "sbrk_slack", 10, 1);
+    sv_setiv(*svp, b->buffer.sbrk_slack);
+
+    svp = hv_fetch(hv, "start_slack", 11, 1);
+    sv_setiv(*svp, b->buffer.start_slack);
+
+    svp = hv_fetch(hv, "sbrked_remains", 14, 1);
+    sv_setiv(*svp, b->buffer.sbrked_remains);
+    
+    svp = hv_fetch(hv, "minbucket", 9, 1);
+    sv_setiv(*svp, b->buffer.minbucket);
+    
+    svp = hv_fetch(hv, "nbuckets", 8, 1);
+    sv_setiv(*svp, b->buffer.nbuckets);
+
+    if (_NBUCKETS < b->buffer.nbuckets) 
+       warn("FIXME: internal mstats buffer too short");
+    
+    for (type = 0; type < (level ? 4 : 2); type++) {
+       UV *p, *p1;
+       AV *av;
+       int i;
+       static const char *types[4] = { 
+           "free", "used", "mem_size", "available_size"    
+       };
+
+       svp = hv_fetch(hv, types[type], strlen(types[type]), 1);
+
+       if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV))
+           croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
+       if (!SvOK(*svp)) {
+           av = newAV();
+           SvUPGRADE(*svp, SVt_RV);
+           SvRV(*svp) = (SV*)av;
+           SvROK_on(*svp);
+       } else
+           av = (AV*)SvRV(*svp);
+
+       av_extend(av, b->buffer.nbuckets - 1);
+       /* XXXX What is the official way to reduce the size of the array? */
+       switch (type) {
+       case 0:
+           p = b->buffer.nfree;
+           break;
+       case 1:
+           p = b->buffer.ntotal;
+           p1 = b->buffer.nfree;
+           break;
+       case 2:
+           p = b->buffer.bucket_mem_size;
+           break;
+       case 3:
+           p = b->buffer.bucket_available_size;
+           break;
+       }
+       for (i = 0; i < b->buffer.nbuckets; i++) {
+           svp = av_fetch(av, i, 1);
+           if (type == 1)
+               sv_setiv(*svp, p[i]-p1[i]);
+           else
+               sv_setuv(*svp, p[i]);
+       }
+    }
+}
+void
+mstats_fillhash(SV *sv, int level)
+{
+    struct mstats_buffer buf;
+
+    if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
+       croak("Not a hash reference");
+    _fill_mstats(&buf, level);
+    _mstats_to_hv((HV *)SvRV(sv), &buf, level);
+}
+void
+mstats2hash(SV *sv, SV *rv, int level)
+{
+    if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV))
+       croak("Not a hash reference");
+    if (!SvPOK(sv))
+       croak("Undefined value when expecting mstats buffer");
+    if (SvCUR(sv) != sizeof(struct mstats_buffer))
+       croak("Wrong size for a value with a mstats buffer");
+    _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level);
+}
+#else  /* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ 
+void
+fill_mstats(SV *sv, int level)
+{
+    croak("Cannot report mstats without Perl malloc");
+}
+void
+mstats_fillhash(SV *sv, int level)
+{
+    croak("Cannot report mstats without Perl malloc");
+}
+void
+mstats2hash(SV *sv, SV *rv, int level)
+{
+    croak("Cannot report mstats without Perl malloc");
+}
+#endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ 
+
 #define _CvGV(cv)                                      \
        (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)      \
         ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
@@ -136,6 +310,17 @@ mstat(str="Devel::Peek::mstat: ")
 char *str
 
 void
+fill_mstats(SV *sv, int level = 0)
+
+void
+mstats_fillhash(SV *sv, int level = 0)
+    PROTOTYPE: \%;$
+
+void
+mstats2hash(SV *sv, SV *rv, int level = 0)
+    PROTOTYPE: $\%;$
+
+void
 Dump(sv,lim=4)
 SV *   sv
 I32    lim
index b7b45d8..0d4e8cd 100644 (file)
@@ -100,17 +100,35 @@ if ($Is_MacOS) {
     push(@dl_library_path, split(/,/, $ENV{LD_LIBRARY_PATH}))
        if exists $ENV{LD_LIBRARY_PATH};
 } else {
-    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
-       if exists      $Config::Config{ldlibpthname}        &&
-                       $Config::Config{ldlibpthname}  ne '' &&
-                exists $ENV{$Config::Config{ldlibpthname}}       ;;
-    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
-       if exists      $Config::Config{ldlibpthname}        &&
-                       $Config::Config{ldlibpthname}  ne '' &&
-                exists $ENV{$Config::Config{ldlibpthname}}       ;;
+    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
+#      if exists      $Config::Config{ldlibpthname}        &&
+                       $Config::Config{ldlibpthname}  ne '' &&
+                exists $ENV{$Config::Config{ldlibpthname}}       ;;
+    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
+#      if exists      $Config::Config{ldlibpthname}        &&
+                       $Config::Config{ldlibpthname}  ne '' &&
+                exists $ENV{$Config::Config{ldlibpthname}}       ;;
 # E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
-push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH}))
-    if exists $ENV{LD_LIBRARY_PATH};
+# push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH}))
+#     if exists $ENV{LD_LIBRARY_PATH};
+EOT
+
+# Make a list of paths to print.
+# HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH,
+# but for other OSes no point pushing 'LD_LIBRARY_PATH' twice.
+my @ldlibpthname = 'LD_LIBRARY_PATH';
+if (exists $Config::Config{ldlibpthname}
+    and length $Config::Config{ldlibpthname}
+    and $Config::Config{ldlibpthname} ne 'LD_LIBRARY_PATH') {
+    unshift @ldlibpthname, $Config::Config{ldlibpthname};
+}
+
+foreach (@ldlibpthname) {
+    print OUT "    push(\@dl_library_path, split(/:/, \$ENV{", to_string($_),
+                 "}))\n\tif exists \$ENV{", to_string($_), "};\n";
+}
+
+print OUT <<'EOT';
 }
 
 # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
index e84b54f..1a3a26f 100644 (file)
@@ -56,6 +56,7 @@ sub exists
 sub _fileno
 {
  my($self, $f) = @_;
+ return unless defined $f;
  $f = $f->[0] if ref($f) eq 'ARRAY';
  ($f =~ /^\d+$/) ? $f : fileno($f);
 }
index cf1270d..cf7e43c 100644 (file)
@@ -380,7 +380,10 @@ cat > UU/uselongdouble.cbu <<'EOCBU'
 # after it has prompted the user for whether to use long doubles.
 case "$uselongdouble" in
 $define|true|[yY]*)
-       ccflags="$ccflags -qlongdouble"
+        case "$cc" in
+        *gcc*) ;;
+        *) ccflags="$ccflags -qlongdouble" ;;
+        esac
        # The explicit cc128, xlc128, xlC128 are not needed,
        # the -qlongdouble should do the trick. --jhi
        d_Gconvert='sprintf((b),"%.*llg",(n),(x))'
index fd61e42..8625798 100644 (file)
@@ -47,7 +47,7 @@ ld='cc';
 so='dylib';
 dlext='bundle';
 dlsrc='dl_dyld.xs'; usedl='define';
-cccdlflags='';
+cccdlflags=' '; # space, not empty, because otherwise we get -fpic
 lddlflags="${ldflags} -bundle -undefined suppress";
 ldlibpthname='DYLD_LIBRARY_PATH';
 useshrplib='true';
index 0ba6b61..cc48351 100644 (file)
@@ -86,13 +86,6 @@ case "$osvers" in
        d_setegid='undef'
        d_seteuid='undef'
        ;;
-3.*)
-       usevfork='true'         
-       usemymalloc='n'
-       libswanted=`echo $libswanted | sed 's/ malloc / /'`     
-       ;;
-#
-# Guesses at what will be needed after 3.*
 *)     usevfork='true'
        usemymalloc='n'
        libswanted=`echo $libswanted | sed 's/ malloc / /'`
diff --git a/hints/nonstopux.sh b/hints/nonstopux.sh
new file mode 100644 (file)
index 0000000..f93c312
--- /dev/null
@@ -0,0 +1,17 @@
+# tom_bates@att.net
+# mips-compaq-nonstopux
+
+. $src/hints/svr4.sh
+
+case "$cc" in
+        *gcc*)
+                ccflags='-fno-strict-aliasing'
+                lddlflags='-shared'
+                ldflags=''
+               ;;
+        '')
+                cc="cc -Xa -Olimit 4096"
+                malloctype="void *"
+               ;;
+esac
+
index 5b79709..2e7a433 100644 (file)
@@ -43,7 +43,7 @@ OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax)
                ;;
        *) # from 2.8 onwards
                ld=${cc:-cc}
-               lddlflags="-shared $lddlflags"
+               lddlflags="-shared -fPIC $lddlflags"
                ;;
        esac
        ;;
@@ -95,6 +95,9 @@ case "$openbsd_distribution" in
        sysman='/usr/share/man/man1'
        libpth='/usr/lib'
        glibpth='/usr/lib'
+       # Local things, however, do go in /usr/local
+       siteprefix='/usr/local'
+       siteprefixexp='/usr/local'
        # Ports installs non-std libs in /usr/local/lib so look there too
        locincpth='/usr/local/include'
        loclibpth='/usr/local/lib'
index 9ad72d7..74698db 100644 (file)
@@ -1,2 +1,4 @@
 ccflags="$ccflags -DCRIPPLED_CC"
-d_lstat=define
+d_lstat='define'
+usedl='undef'
+
index 72c76fd..06f68f5 100755 (executable)
@@ -23,19 +23,21 @@ die "Patchlevel of perl ($patchlevel)",
 my $usage =
 "Usage:  installman --man1dir=/usr/wherever --man1ext=1
                    --man3dir=/usr/wherever --man3ext=3
+                  --batchlimit=40
                   --notify --verbose --silent --help
        Defaults are:
        man1dir = $Config{'installman1dir'};
        man1ext = $Config{'man1ext'};
        man3dir = $Config{'installman3dir'};
        man3ext = $Config{'man3ext'};
+        batchlimit is maximum number of pod files per invocation of pod2man
        --notify  (or -n) just lists commands that would be executed.
         --verbose (or -V) report all progress.
         --silent  (or -S) be silent. Only report errors.\n";
 
 my %opts;
 GetOptions( \%opts,
-            qw( man1dir=s man1ext=s man3dir=s man3ext=s
+            qw( man1dir=s man1ext=s man3dir=s man3ext=s batchlimit=i
                 notify n help silent S verbose V)) 
        || die $usage;
 die $usage if $opts{help};
@@ -48,6 +50,7 @@ $opts{man3dir} = $Config{'installman3dir'}
     unless defined($opts{man3dir}); 
 $opts{man3ext} = $Config{'man3ext'}
     unless defined($opts{man3ext}); 
+$opts{batchlimit} ||= 40;
 $opts{silent} ||= $opts{S};
 $opts{notify} ||= $opts{n};
 $opts{verbose} ||= $opts{V} || $opts{notify};
@@ -71,24 +74,12 @@ runpod2man('pod', $opts{man1dir}, $opts{man1ext});
 runpod2man('lib', $opts{man3dir}, $opts{man3ext});
 
 # Install the pods embedded in the installed scripts
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2ph');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2xs');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlcc');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perldoc');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlbug');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pl2pm');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'splain');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'dprofpp');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'a2p.pod');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'find2perl');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2html');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2text');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2usage');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podchecker');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podselect');
+runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph', 'h2ph', 'h2xs',
+          'perlcc', 'perldoc', 'perlbug', 'pl2pm', 'splain', 'dprofpp');
+runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p', 'a2p.pod',
+          'find2perl');
+runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man', 'pod2html',
+          'pod2text', 'pod2usage', 'podchecker', 'podselect');
 
 # It would probably be better to have this page linked
 # to the c2ph man page.  Or, this one could say ".so man1/c2ph.1",
@@ -98,9 +89,9 @@ runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct');
 runpod2man('lib/ExtUtils', $opts{man1dir}, $opts{man1ext}, 'xsubpp');
 
 sub runpod2man {
-    # $script is script name if we are installing a manpage embedded 
-    # in a script, undef otherwise
-    my($poddir, $mandir, $manext, $script) = @_;
+    # @script is scripts names if we are installing manpages embedded 
+    # in scripts, () otherwise
+    my($poddir, $mandir, $manext, @script) = @_;
 
     my($downdir); # can't just use .. when installing xsubpp manpage
 
@@ -109,8 +100,12 @@ sub runpod2man {
     my($builddir) = Cwd::getcwd();
 
     if ($mandir eq ' ' or $mandir eq '') {
-       warn "Skipping installation of ",
-           ($script ? "$poddir/$script man page" : "$poddir man pages"), ".\n";
+       if (@script) {
+           warn "Skipping installation of $poddir/$_ man page.\n"
+               foreach @script;
+       } else {
+           warn "Skipping installation of $poddir man pages.\n";
+       }
        return;
     }
 
@@ -134,13 +129,14 @@ sub runpod2man {
     # Make a list of all the .pm and .pod files in the directory.  We will
     # always run pod2man from the lib directory and feed it the full pathname
     # of the pod.  This might be useful for pod2man someday.
-    if ($script) {
-       @modpods = ($script);
+    if (@script) {
+       @modpods = @script;
     }
     else {
        @modpods = ();
        File::Find::find(\&lsmodpods, '.');
     }
+    my @to_process;
     foreach my $mod (@modpods) {
        my $manpage = $mod;
        my $tmp;
@@ -159,15 +155,25 @@ sub runpod2man {
        }
        $tmp = "${mandir}/${manpage}.tmp";
        $manpage = "${mandir}/${manpage}.${manext}";
-       if (&cmd("$pod2man $mod > $tmp") == 0 && !$opts{notify} && -s $tmp) {
-           if (rename($tmp, $manpage)) {
-               $packlist->{$manpage} = { type => 'file' };
-               next;
+       push @to_process, [$mod, $tmp, $manpage];
+    }
+    # Don't do all pods in same command to avoid busting command line limits
+    while (my @this_batch = splice @to_process, 0, $opts{batchlimit}) {
+       my $cmd = join " ", $pod2man, map "$$_[0] $$_[1]", @this_batch;
+       if (&cmd($cmd) == 0 && !$opts{notify}) {
+           foreach (@this_batch) {
+               my (undef, $tmp, $manpage) = @$_;
+               if (-s $tmp) {
+                   if (rename($tmp, $manpage)) {
+                       $packlist->{$manpage} = { type => 'file' };
+                       next;
+                   }
+               }
+               unless ($opts{notify}) {
+                   unlink($tmp);
+               }
            }
        }
-       unless ($opts{notify}) {
-           unlink($tmp);
-       }
     }
     chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n";
     print "  chdir $builddir\n" if $opts{verbose};
index f8b4ba6..aeb6a57 100644 (file)
@@ -1,12 +1,12 @@
 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 package CPAN;
-$VERSION = '1.57_65';
+$VERSION = '1.57_68RC';
 
-# $Id: CPAN.pm,v 1.351 2000/09/10 08:02:42 k Exp $
+# $Id: CPAN.pm,v 1.354 2000/10/08 14:20:57 k Exp $
 
 # only used during development:
 $Revision = "";
-# $Revision = "[".substr(q$Revision: 1.351 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.354 $, 10)."]";
 
 use Carp ();
 use Config ();
@@ -57,7 +57,7 @@ use strict qw(vars);
 
 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
             $Revision $Signal $Cwd $End $Suppress_readline $Frontend
-            $Defaultsite );
+            $Defaultsite $Have_warned);
 
 @CPAN::ISA = qw(CPAN::Debug Exporter);
 
@@ -685,8 +685,8 @@ sub has_inst {
   if you just type
       install Bundle::libnet
 
-});
-       sleep 2;
+}) unless $Have_warned->{"Net::FTP"}++;
+       sleep 3;
     } elsif ($mod eq "MD5"){
        $CPAN::Frontend->myprint(qq{
   CPAN: MD5 security checks disabled because MD5 not installed.
@@ -1156,13 +1156,12 @@ sub missing_config_data {
     my(@miss);
     for (
          "cpan_home", "keep_source_where", "build_dir", "build_cache",
-         "scan_cache", "index_expire", "gzip", "tar", "unzip", "make", "pager",
+         "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
+         "pager",
          "makepl_arg", "make_arg", "make_install_arg", "urllist",
          "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
          "prerequisites_policy",
-
-         # "cache_metadata" # not yet stable enough
-
+         "cache_metadata",
         ) {
        push @miss, $_ unless defined $CPAN::Config->{$_};
     }
@@ -2016,32 +2015,6 @@ sub ftp_get {
  # >       my $p;
 
 
-# this is quite optimistic and returns one on several occasions where
-# inappropriate. But this does no harm. It would do harm if we were
-# too pessimistic (as I was before the http_proxy
-sub is_reachable {
-    my($self,$url) = @_;
-    return 1; # we can't simply roll our own, firewalls may break ping
-    return 0 unless $url;
-    return 1 if substr($url,0,4) eq "file";
-    return 1 unless $url =~ m|^(\w+)://([^/]+)|;
-    my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
-    my $host = $2;
-    return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
-    require Net::Ping;
-    return 1 unless $Net::Ping::VERSION >= 2;
-    my $p;
-    # 1.3101 had it different: only if the first eval raised an
-    # exception we tried it with TCP. Now we are happy if icmp wins
-    # the order and return, we don't even check for $@. Thanks to
-    # thayer@uis.edu for the suggestion.
-    eval {$p = Net::Ping->new("icmp");};
-    return 1 if $p && ref($p) && $p->ping($host, 10);
-    eval {$p = Net::Ping->new("tcp");};
-    $CPAN::Frontend->mydie($@) if $@;
-    return $p->ping($host, 10);
-}
-
 #-> sub CPAN::FTP::localize ;
 sub localize {
     my($self,$file,$aslocal,$force) = @_;
@@ -2180,11 +2153,6 @@ sub hosteasy {
     my($i);
   HOSTEASY: for $i (@$host_seq) {
         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
-       unless ($self->is_reachable($url)) {
-           $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
-           sleep 2;
-           next;
-       }
        $url .= "/" unless substr($url,-1) eq "/";
        $url .= $file;
        $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
@@ -2305,10 +2273,6 @@ sub hosthard {
   File::Path::mkpath($aslocal_dir);
   HOSTHARD: for $i (@$host_seq) {
        my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
-       unless ($self->is_reachable($url)) {
-         $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
-         next;
-       }
        $url .= "/" unless substr($url,-1) eq "/";
        $url .= $file;
        my($proto,$host,$dir,$getfile);
@@ -2322,6 +2286,8 @@ sub hosthard {
        } else {
          next HOSTHARD; # who said, we could ftp anything except ftp?
        }
+        next HOSTHARD if $proto eq "file"; # file URLs would have had
+                                           # success above. Likely a bogus URL
 
        $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
        my($f,$funkyftp);
@@ -2357,8 +2323,7 @@ Trying with "$funkyftp$src_switch" to get
          if (($wstatus = system($system)) == 0
              &&
              ($f eq "lynx" ?
-              -s $asl_ungz   # lynx returns 0 on my
-                                          # system even if it fails
+              -s $asl_ungz # lynx returns 0 when it fails somewhere
               : 1
              )
             ) {
@@ -2366,12 +2331,11 @@ Trying with "$funkyftp$src_switch" to get
              # Looks good
            } elsif ($asl_ungz ne $aslocal) {
              # test gzip integrity
-             if (
-                 CPAN::Tarzip->gtest($asl_ungz)
-                ) {
-               rename $asl_ungz, $aslocal;
+             if (CPAN::Tarzip->gtest($asl_ungz)) {
+                  # e.g. foo.tar is gzipped --> foo.tar.gz
+                  rename $asl_ungz, $aslocal;
              } else {
-               CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
+                  CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
              }
            }
            $Thesite = $i;
@@ -2395,9 +2359,10 @@ Trying with "$funkyftp$src_switch" to get
               ) {
              # test gzip integrity
              if (CPAN::Tarzip->gtest($asl_gz)) {
-               CPAN::Tarzip->gunzip($asl_gz,$aslocal);
+                  CPAN::Tarzip->gunzip($asl_gz,$aslocal);
              } else {
-               rename $asl_ungz, $aslocal;
+                  # somebody uncompressed file for us?
+                  rename $asl_ungz, $aslocal;
              }
              $Thesite = $i;
              return $aslocal;
@@ -2431,10 +2396,6 @@ sub hosthardest {
            last HOSTHARDEST;
        }
        my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
-       unless ($self->is_reachable($url)) {
-           $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
-           next;
-       }
        $url .= "/" unless substr($url,-1) eq "/";
        $url .= $file;
        $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
@@ -3368,12 +3329,12 @@ sub get {
     }
     my($local_file);
     my($local_wanted) =
-        MM->catfile(
-                       $CPAN::Config->{keep_source_where},
-                       "authors",
-                       "id",
-                       split("/",$self->{ID})
-                      );
+        MM->catfile(
+                    $CPAN::Config->{keep_source_where},
+                    "authors",
+                    "id",
+                    split("/",$self->id)
+                   );
 
     $self->debug("Doing localize") if $CPAN::DEBUG;
     $local_file =
@@ -3403,10 +3364,12 @@ sub get {
     if (! $local_file) {
        Carp::croak "bad download, can't do anything :-(\n";
     } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
+        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
        $self->untar_me($local_file);
     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
        $self->unzip_me($local_file);
     } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
+        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
        $self->pm2dir_me($local_file);
     } else {
        $self->{archived} = "NO";
@@ -3431,16 +3394,21 @@ sub get {
         rename($distdir,$packagedir) or
             Carp::confess("Couldn't rename $distdir to $packagedir: $!");
       } else {
-        my $pragmatic_dir = $self->cpan_userid . '000';
-        $pragmatic_dir =~ s/\W_//g;
-        $pragmatic_dir++ while -d "../$pragmatic_dir";
-        $packagedir = MM->catdir($builddir,$pragmatic_dir);
-        File::Path::mkpath($packagedir);
-        my($f);
-        for $f (@readdir) { # is already without "." and ".."
-          my $to = MM->catdir($packagedir,$f);
-          rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
-        }
+          my $userid = $self->cpan_userid;
+          unless ($userid) {
+              CPAN->debug("no userid? self[$self]");
+              $userid = "anon";
+          }
+          my $pragmatic_dir = $userid . '000';
+          $pragmatic_dir =~ s/\W_//g;
+          $pragmatic_dir++ while -d "../$pragmatic_dir";
+          $packagedir = MM->catdir($builddir,$pragmatic_dir);
+          File::Path::mkpath($packagedir);
+          my($f);
+          for $f (@readdir) { # is already without "." and ".."
+              my $to = MM->catdir($packagedir,$f);
+              rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+          }
       }
       $self->{'build_dir'} = $packagedir;
       $cwd = File::Spec->updir;
@@ -3467,9 +3435,18 @@ We\'ll try to build it with that Makefile then.
           $self->{writemakefile} = "YES";
           sleep 2;
         } else {
+          my $cf = $self->called_for || "unknown";
+          if ($cf =~ m|/|) {
+              $cf =~ s|.*/||;
+              $cf =~ s|\W.*||;
+          }
+          $cf =~ s|[/\\:]||g; # risk of filesystem damage
+          $cf = "unknown" unless length($cf);
+          $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
+  Writing one on our own (calling it $cf)\n});
+          $self->{had_no_makefile_pl}++;
           my $fh = FileHandle->new(">$makefilepl")
               or Carp::croak("Could not open >$makefilepl");
-          my $cf = $self->called_for || "unknown";
           $fh->print(
 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
 # because there was no Makefile.PL supplied.
@@ -3479,8 +3456,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(NAME => q[$cf]);
 
 });
-          $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
-  Writing one on our own (calling it $cf)\n});
+          $fh->close;
         }
       }
     }
@@ -3760,12 +3736,15 @@ retry.};
     } else {
        $self->{MD5_STATUS} ||= "";
        if ($self->{MD5_STATUS} eq "NIL") {
-           $CPAN::Frontend->myprint(qq{
-No md5 checksum for $basename in local $chk_file.
-Removing $chk_file
+           $CPAN::Frontend->mywarn(qq{
+Warning: No md5 checksum for $basename in $chk_file.
+
+The cause for this may be that the file is very new and the checksum
+has not yet been calculated, but it may also be that something is
+going awry right now.
 });
-           unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
-           sleep 1;
+            my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
+            $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
        }
        $self->{MD5_STATUS} = "NIL";
        return;
@@ -4982,7 +4961,7 @@ sub gzip {
     $fhw->close;
     return 1;
   } else {
-    system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
+    system("$CPAN::Config->{gzip} -c $read > $write")==0;
   }
 }
 
@@ -5004,7 +4983,7 @@ sub gunzip {
     $fhw->close;
     return 1;
   } else {
-    system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
+    system("$CPAN::Config->{gzip} -dc $read > $write")==0;
   }
 }
 
@@ -5012,18 +4991,30 @@ sub gunzip {
 # CPAN::Tarzip::gtest
 sub gtest {
   my($class,$read) = @_;
-  if ($CPAN::META->has_inst("Compress::Zlib")) {
-    my($buffer);
+  # After I had reread the documentation in zlib.h, I discovered that
+  # uncompressed files do not lead to an gzerror (anymore?).
+  if ( $CPAN::META->has_inst("Compress::Zlib") ) {
+    my($buffer,$len);
+    $len = 0;
     my $gz = Compress::Zlib::gzopen($read, "rb")
-       or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
-    1 while $gz->gzread($buffer) > 0 ;
+       or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+                                          $read,
+                                          $Compress::Zlib::gzerrno));
+    while ($gz->gzread($buffer) > 0 ){
+        $len += length($buffer);
+        $buffer = "";
+    }
     my $err = $gz->gzerror;
     my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
+    if ($len == -s $read){
+        $success = 0;
+        CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
+    }
     $gz->gzclose();
-    $class->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+    CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
     return $success;
   } else {
-    return system("$CPAN::Config->{'gzip'} -dt $read")==0;
+      return system("$CPAN::Config->{gzip} -dt $read")==0;
   }
 }
 
@@ -5038,7 +5029,7 @@ sub TIEHANDLE {
        die "Could not gzopen $file";
     $ret = bless {GZ => $gz}, $class;
   } else {
-    my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
+    my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
     my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
     binmode $fh;
     $ret = bless {FH => $fh}, $class;
@@ -5080,15 +5071,16 @@ sub READ {
 
 # CPAN::Tarzip::DESTROY
 sub DESTROY {
-  my($self) = @_;
-  if (exists $self->{GZ}) {
-    my $gz = $self->{GZ};
-    $gz->gzclose();
-  } else {
-    my $fh = $self->{FH};
-    $fh->close if defined $fh;
-  }
-  undef $self;
+    my($self) = @_;
+    if (exists $self->{GZ}) {
+        my $gz = $self->{GZ};
+        $gz->gzclose() if defined $gz; # hard to say if it is allowed
+                                       # to be undef ever. AK, 2000-09
+    } else {
+        my $fh = $self->{FH};
+        $fh->close if defined $fh;
+    }
+    undef $self;
 }
 
 
@@ -5096,48 +5088,56 @@ sub DESTROY {
 sub untar {
   my($class,$file) = @_;
   if (0) { # makes changing order easier
-  } elsif (MM->maybe_command($CPAN::Config->{'gzip'})
+  } elsif (MM->maybe_command($CPAN::Config->{gzip})
       &&
       MM->maybe_command($CPAN::Config->{'tar'})) {
-    my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
-      "< $file | $CPAN::Config->{tar} xvf -";
+    my($system);
+    my $is_compressed = $class->gtest($file);
+    if ($is_compressed) {
+        $system = "$CPAN::Config->{gzip} --decompress --stdout " .
+            "< $file | $CPAN::Config->{tar} xvf -";
+    } else {
+        $system = "$CPAN::Config->{tar} xvf $file";
+    }
     if (system($system) != 0) {
-      # people find the most curious tar binaries that cannot handle
-      # pipes
-      my $system = "$CPAN::Config->{'gzip'} --decompress $file";
-      if (system($system)==0) {
-       $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
-      } else {
-       $CPAN::Frontend->mydie(
-                              qq{Couldn\'t uncompress $file\n}
-                             );
-      }
-      $file =~ s/\.gz(?!\n)\Z//;
-      $system = "$CPAN::Config->{tar} xvf $file";
-      $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
-      if (system($system)==0) {
-       $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
-      } else {
-       $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
-      }
-      return 1;
+        # people find the most curious tar binaries that cannot handle
+        # pipes
+        if ($is_compressed) {
+            (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
+            if (CPAN::Tarzip->gunzip($file, $ungzf)) {
+                $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
+            } else {
+                $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
+            }
+            $file = $ungzf;
+        }
+        $system = "$CPAN::Config->{tar} xvf $file";
+        $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
+        if (system($system)==0) {
+            $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
+        } else {
+            $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
+        }
+        return 1;
     } else {
-      return 1;
+        return 1;
     }
   } elsif ($CPAN::META->has_inst("Archive::Tar")
       &&
       $CPAN::META->has_inst("Compress::Zlib") ) {
     my $tar = Archive::Tar->new($file,1);
     my $af; # archive file
+    my @af;
     for $af ($tar->list_files) {
         if ($af =~ m!^(/|\.\./)!) {
             $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                    "illegal member [$af]");
         }
         $CPAN::Frontend->myprint("$af\n");
-        $tar->extract($af);
+        push @af, $af;
         return if $CPAN::Signal;
     }
+    $tar->extract(@af);
 
     ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
         if ($^O eq 'MacOS');
@@ -5933,8 +5933,8 @@ Your milage may vary...
 
 =over
 
-=item I installed a new version of module X but CPAN keeps saying, I
-      have the old version installed
+=item 1) I installed a new version of module X but CPAN keeps saying,
+      have the old version installed
 
 Most probably you B<do> have the old version installed. This can
 happen if a module installs itself into a different directory in the
@@ -5946,13 +5946,13 @@ many people add this argument permanently by configuring
 
   o conf make_install_arg UNINST=1
 
-=item So why is UNINST=1 not the default?
+=item 2) So why is UNINST=1 not the default?
 
 Because there are people who have their precise expectations about who
 may install where in the @INC path and who uses which @INC array. In
 fine tuned environments C<UNINST=1> can cause damage.
 
-=item When I install bundles or multiple modules with one command
+=item 3) When I install bundles or multiple modules with one command
       there is too much output to keep track of
 
 You may want to configure something like
@@ -5963,7 +5963,8 @@ You may want to configure something like
 so that STDOUT is captured in a file for later inspection.
 
 
-=item I am not root, how can I install a module in a personal directory?
+=item 4) I am not root, how can I install a module in a personal
+      directory?
 
 You will most probably like something like this:
 
@@ -5986,13 +5987,14 @@ or setting the PERL5LIB environment variable.
 Another thing you should bear in mind is that the UNINST parameter
 should never be set if you are not root.
 
-=item How to get a package, unwrap it, and make a change before building it?
+=item 5) How to get a package, unwrap it, and make a change before
+      building it?
 
   look Sybase::Sybperl
 
-=item I installed a Bundle and had a couple of fails. When I retried,
-      everything resolved nicely. Can this be fixed to work on first
-      try?
+=item 6) I installed a Bundle and had a couple of fails. When I
+      retried, everything resolved nicely. Can this be fixed to work
+      on first try?
 
 The reason for this is that CPAN does not know the dependencies of all
 modules when it starts out. To decide about the additional items to
@@ -6001,11 +6003,19 @@ undetected missing piece breaks the process. But it may well be that
 your Bundle installs some prerequisite later than some depending item
 and thus your second try is able to resolve everything. Please note,
 CPAN.pm does not know the dependency tree in advance and cannot sort
-the queue of things to install in a topologically correct order.
-For bundles which you need to install often, it is recommended to do
-the sorting manually. It is planned to improve the metadata situation
-for dependencies on CPAN in general, but this will still take some
-time.
+the queue of things to install in a topologically correct order. It
+resolves perfectly well IFF all modules declare the prerequisites
+correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
+fail and you need to install often, it is recommended sort the Bundle
+definition file manually. It is planned to improve the metadata
+situation for dependencies on CPAN in general, but this will still
+take some time.
+
+=item 7) In our intranet we have many modules for internal use. How
+      can I integrate these modules with CPAN.pm but without uploading
+      the modules to CPAN?
+
+Have a look at the CPAN::Site module.
 
 =back
 
index 099183e..9f8366e 100644 (file)
@@ -16,7 +16,7 @@ use FileHandle ();
 use File::Basename ();
 use File::Path ();
 use vars qw($VERSION);
-$VERSION = substr q$Revision: 1.44 $, 10;
+$VERSION = substr q$Revision: 1.46 $, 10;
 
 =head1 NAME
 
@@ -176,14 +176,13 @@ disable the cache scanning with 'never'.
 
     print qq{
 
-To speed up the initial CPAN shell startup, it is possible to use
-Storable to create an cache of metadata. If Storable is not available,
-the normal index mechanism will be used. This feature is still
-considered experimental and not recommended for production use.
+To considerably speed up the initial CPAN shell startup, it is
+possible to use Storable to create a cache of metadata. If Storable
+is not available, the normal index mechanism will be used.
 
 };
 
-    defined($default = $CPAN::Config->{cache_metadata}) or $default = 0;
+    defined($default = $CPAN::Config->{cache_metadata}) or $default = 1;
     do {
         $ans = prompt("Cache metadata (yes/no)?", ($default ? 'yes' : 'no'));
     } while ($ans !~ /^\s*[yn]/i);
index dbeae69..7279591 100644 (file)
@@ -89,7 +89,15 @@ sub _backtick_pwd {
 # Since some ports may predefine cwd internally (e.g., NT)
 # we take care not to override an existing definition for cwd().
 
-*cwd = \&_backtick_pwd unless defined &cwd;
+unless(defined &cwd) {
+    # The pwd command is not available in some chroot(2)'ed environments
+    if(grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
+       *cwd = \&_backtick_pwd;
+    }
+    else {
+       *cwd = \&getcwd;
+    }
+}
 
 
 # By Brandon S. Allbery
index 36c7221..4a148a6 100644 (file)
@@ -16,6 +16,28 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
 my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
 my $Inc_uninstall_warn_handler;
 
+# install relative to here
+
+my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
+
+use File::Spec;
+
+sub install_rooted_file {
+    if (defined $INSTALL_ROOT) {
+       MY->catfile($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
+sub install_rooted_dir {
+    if (defined $INSTALL_ROOT) {
+       MY->catdir($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
 #our(@EXPORT, @ISA, $Is_VMS);
 #use strict;
 
@@ -55,8 +77,9 @@ sub install {
        opendir DIR, $source_dir_or_file or next;
        for (readdir DIR) {
            next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
-           if (-w $hash{$source_dir_or_file} ||
-               mkpath($hash{$source_dir_or_file})) {
+               my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
+           if (-w $targetdir ||
+               mkpath($targetdir)) {
                last;
            } else {
                warn "Warning: You do not have permissions to " .
@@ -66,7 +89,8 @@ sub install {
        }
        closedir DIR;
     }
-    $packlist->read($pack{"read"}) if (-f $pack{"read"});
+    my $tmpfile = install_rooted_file($pack{"read"});
+    $packlist->read($tmpfile) if (-f $tmpfile);
     my $cwd = cwd();
 
     my($source);
@@ -80,11 +104,13 @@ sub install {
        #October 1997: we want to install .pm files into archlib if
        #there are any files in arch. So we depend on having ./blib/arch
        #hardcoded here.
-       my $targetroot = $hash{$source};
+
+       my $targetroot = install_rooted_dir($hash{$source});
+
        if ($source eq "blib/lib" and
            exists $hash{"blib/arch"} and
            directory_not_empty("blib/arch")) {
-           $targetroot = $hash{"blib/arch"};
+           $targetroot = install_rooted_dir($hash{"blib/arch"});
             print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
        }
        chdir($source) or next;
@@ -93,8 +119,9 @@ sub install {
                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
            return unless -f _;
            return if $_ eq ".exists";
-           my $targetdir = MY->catdir($targetroot,$File::Find::dir);
-           my $targetfile = MY->catfile($targetdir,$_);
+           my $targetdir  = MY->catdir($targetroot, $File::Find::dir);
+           my $origfile   = $_;
+           my $targetfile = MY->catfile($targetdir, $_);
 
            my $diff = 0;
            if ( -f $targetfile && -s _ == $size) {
@@ -129,16 +156,16 @@ sub install {
            } else {
                inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
            }
-           $packlist->{$targetfile}++;
+           $packlist->{$origfile}++;
 
        }, ".");
        chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
     }
     if ($pack{'write'}) {
-       $dir = dirname($pack{'write'});
+       $dir = install_rooted_dir(dirname($pack{'write'}));
        mkpath($dir,0,0755);
        print "Writing $pack{'write'}\n";
-       $packlist->write($pack{'write'});
+       $packlist->write(install_rooted_file($pack{'write'}));
     }
 }
 
@@ -289,18 +316,20 @@ sub add {
 }
 
 sub DESTROY {
-    my $self = shift;
-    my($file,$i,$plural);
-    foreach $file (sort keys %$self) {
-       $plural = @{$self->{$file}} > 1 ? "s" : "";
-       print "## Differing version$plural of $file found. You might like to\n";
-       for (0..$#{$self->{$file}}) {
-           print "rm ", $self->{$file}[$_], "\n";
-           $i++;
+       unless(defined $INSTALL_ROOT) {
+               my $self = shift;
+               my($file,$i,$plural);
+               foreach $file (sort keys %$self) {
+               $plural = @{$self->{$file}} > 1 ? "s" : "";
+               print "## Differing version$plural of $file found. You might like to\n";
+               for (0..$#{$self->{$file}}) {
+                       print "rm ", $self->{$file}[$_], "\n";
+                       $i++;
+               }
+               }
+               $plural = $i>1 ? "all those files" : "this file";
+               print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
        }
-    }
-    $plural = $i>1 ? "all those files" : "this file";
-    print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 }
 
 1;
@@ -365,4 +394,7 @@ of the hash to the corresponding values efficiently. Filenames with
 the extension pm are autosplit. Second argument is the autosplit
 directory.
 
+You can have an environment variable PERL_INSTALL_ROOT set which will
+be prepended as a directory to each installed file (and directory).
+
 =cut
index bef12b5..64f6986 100644 (file)
@@ -982,23 +982,39 @@ be
     perl Makefile.PL LIB=~/lib
 
 This will install the module's architecture-independent files into
-~/lib, the architecture-dependent files into ~/lib/$archname/auto.
+~/lib, the architecture-dependent files into ~/lib/$archname.
 
 Another way to specify many INSTALL directories with a single
 parameter is PREFIX.
 
     perl Makefile.PL PREFIX=~
 
-This will replace the string specified by $Config{prefix} in all
-$Config{install*} values.
+This will replace the string specified by C<$Config{prefix}> in all
+C<$Config{install*}> values.
 
 Note, that in both cases the tilde expansion is done by MakeMaker, not
-by perl by default, nor by make. Conflicts between parameters LIB,
-PREFIX and the various INSTALL* arguments are resolved so that 
-XXX
+by perl by default, nor by make.
+
+Conflicts between parameters LIB,
+PREFIX and the various INSTALL* arguments are resolved so that:
+
+=over 4
+
+=item *
+
+setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
+INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);
+
+=item *
+
+without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
+part of those INSTALL* arguments, even if the latter are explicitly
+set (but are set to still start with C<$Config{prefix}>).
+
+=back
 
 If the user has superuser privileges, and is not working on AFS
-(Andrew File System) or relatives, then the defaults for
+or relatives, then the defaults for
 INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate,
 and this incantation will be the best:
 
@@ -1145,11 +1161,6 @@ or as NAME=VALUE pairs on the command line:
 
 =over 2
 
-=item AUTHOR
-
-String containing name (and email address) of package author(s). Is used
-in PPD (Perl Package Description) files for PPM (Perl Package Manager).
-
 =item ABSTRACT
 
 One line description of the module. Will be included in PPD file.
@@ -1160,6 +1171,11 @@ Name of the file that contains the package description. MakeMaker looks
 for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
 the first line in the "=head1 NAME" section. $2 becomes the abstract.
 
+=item AUTHOR
+
+String containing name (and email address) of package author(s). Is used
+in PPD (Perl Package Description) files for PPM (Perl Package Manager).
+
 =item BINARY_LOCATION
 
 Used when creating PPD files for binary packages.  It can be set to a
@@ -1409,11 +1425,6 @@ to INSTALLBIN during 'make install'
 Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you
 need to use it.
 
-=item INST_LIB
-
-Directory where we put library files of this extension while building
-it.
-
 =item INST_HTMLLIBDIR
 
 Directory to hold the man pages in HTML format at 'make' time
@@ -1422,6 +1433,11 @@ Directory to hold the man pages in HTML format at 'make' time
 
 Directory to hold the man pages in HTML format at 'make' time
 
+=item INST_LIB
+
+Directory where we put library files of this extension while building
+it.
+
 =item INST_MAN1DIR
 
 Directory to hold the man pages at 'make' time
@@ -1437,34 +1453,6 @@ Directory, where executable files should be installed during
 testing. make install will copy the files in INST_SCRIPT to
 INSTALLSCRIPT.
 
-=item PERL_MALLOC_OK
-
-defaults to 0.  Should be set to TRUE if the extension can work with
-the memory allocation routines substituted by the Perl malloc() subsystem.
-This should be applicable to most extensions with exceptions of those
-
-=over
-
-=item *
-
-with bugs in memory allocations which are caught by Perl's malloc();
-
-=item *
-
-which interact with the memory allocator in other ways than via
-malloc(), realloc(), free(), calloc(), sbrk() and brk();
-
-=item *
-
-which rely on special alignment which is not provided by Perl's malloc().
-
-=back
-
-B<NOTE.>  Negligence to set this flag in I<any one> of loaded extension
-nullifies many advantages of Perl's malloc(), such as better usage of
-system resources, error detection, memory usage reporting, catchable failure
-of memory allocations, etc.
-
 =item LDFROM
 
 defaults to "$(OBJECT)" and is used in the ld command to specify
@@ -1473,8 +1461,12 @@ specify ld flags)
 
 =item LIB
 
-LIB can only be set at C<perl Makefile.PL> time. It has the effect of
+LIB should only be set at C<perl Makefile.PL> time but is allowed as a
+MakeMaker argument. It has the effect of
 setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any
+explicit setting of those arguments (or of PREFIX).  
+INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding 
+architecture subdirectory.
 
 =item LIBPERL_A
 
@@ -1578,6 +1570,8 @@ List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
 string containing all object files, e.g. "tkpBind.o
 tkpButton.o tkpCanvas.o"
 
+(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)
+
 =item OPTIMIZE
 
 Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
@@ -1594,12 +1588,40 @@ to $(CC).
 
 =item PERL_ARCHLIB
 
-Same as above for architecture dependent files.
+Same as below, but for architecture dependent files.
 
 =item PERL_LIB
 
 Directory containing the Perl library to use.
 
+=item PERL_MALLOC_OK
+
+defaults to 0.  Should be set to TRUE if the extension can work with
+the memory allocation routines substituted by the Perl malloc() subsystem.
+This should be applicable to most extensions with exceptions of those
+
+=over 4
+
+=item *
+
+with bugs in memory allocations which are caught by Perl's malloc();
+
+=item *
+
+which interact with the memory allocator in other ways than via
+malloc(), realloc(), free(), calloc(), sbrk() and brk();
+
+=item *
+
+which rely on special alignment which is not provided by Perl's malloc().
+
+=back
+
+B<NOTE.>  Negligence to set this flag in I<any one> of loaded extension
+nullifies many advantages of Perl's malloc(), such as better usage of
+system resources, error detection, memory usage reporting, catchable failure
+of memory allocations, etc.
+
 =item PERL_SRC
 
 Directory containing the Perl source code (use of this should be
@@ -1648,6 +1670,8 @@ they contain will be installed in the corresponding location in the
 library.  A libscan() method can be used to alter the behaviour.
 Defining PM in the Makefile.PL will override PMLIBDIRS.
 
+(Where BASEEXT is the last component of NAME.)
+
 =item POLLUTE
 
 Release 5.005 grandfathered old global symbol names by providing preprocessor
@@ -1725,6 +1749,7 @@ MakeMaker object. The following lines will be parsed o.k.:
     ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/;
     $FOO::VERSION = '1.10';
     *FOO::VERSION = \'1.11';
+    our $VERSION = 1.2.3;      # new for perl5.6.0 
 
 but these will fail:
 
@@ -1732,6 +1757,8 @@ but these will fail:
     local $VERSION = '1.02';
     local $FOO::VERSION = '1.30';
 
+(Putting C<my> or C<local> on the preceding line will work o.k.)
+
 The file named in VERSION_FROM is not added as a dependency to
 Makefile. This is not really correct, but it would be a major pain
 during development to have to rewrite the Makefile for any smallish
@@ -1786,6 +1813,8 @@ part of the Makefile.
 
   {ANY_TARGET => ANY_DEPENDECY, ...}
 
+(ANY_TARGET must not be given a double-colon rule by MakeMaker.)
+
 =item dist
 
   {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
index c8f41c7..c06b393 100644 (file)
@@ -49,6 +49,7 @@ sub Mksymlists {
     }
 
     if    ($osname eq 'aix') { _write_aix(\%spec); }
+    elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
     elsif ($osname eq 'VMS') { _write_vms(\%spec) }
     elsif ($osname eq 'os2') { _write_os2(\%spec) }
     elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
index 4581e7e..2795036 100644 (file)
@@ -236,7 +236,14 @@ sub dirname {
         if ($_[0] =~ m#/#) { $fstype = '' }
         else { return $dirname || $ENV{DEFAULT} }
     }
-    if ($fstype =~ /MacOS/i) { return $dirname }
+    if ($fstype =~ /MacOS/i) {
+       $dirname =~ s/([^:]):\z/$1/s;
+       unless( length($basename) ) {
+           local($File::Basename::Fileparse_fstype) = $fstype;
+           ($basename,$dirname) = fileparse $dirname;
+           $dirname =~ s/([^:]):\z/$1/s;
+       }
+    }
     elsif ($fstype =~ /MSDOS/i) { 
         $dirname =~ s/([^:])[\\\/]*\z/$1/;
         unless( length($basename) ) {
index 46f360a..daa2eae 100644 (file)
@@ -105,8 +105,8 @@ my $Is_VMS = $^O eq 'VMS';
 
 # These OSes complain if you want to remove a file that you have no
 # write permission to:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
-                      || $^O eq 'amigaos');
+my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
+                      $^O eq 'amigaos' || $^O eq 'MacOS');
 
 sub mkpath {
     my($paths, $verbose, $mode) = @_;
index 2dec72c..a351044 100644 (file)
@@ -340,6 +340,7 @@ sub _gettemp {
 
       if ($^O eq 'VMS') {  # need volume to avoid relative dir spec
         $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
+        $parent = 'sys$disk:[]' if $parent eq '';
       } else {
 
        # Put it back together without the last one
@@ -1107,7 +1108,7 @@ sub tempdir  {
       # Prepend the supplied directory or temp dir
       if ($options{"DIR"}) {
 
-       $template = File::Spec->catfile($options{"DIR"}, $template);
+        $template = File::Spec->catdir($options{"DIR"}, $template);
 
       } elsif ($options{TMPDIR}) {
 
index 8bb8205..fc78d7b 100644 (file)
@@ -169,12 +169,14 @@ sub ReadLine {'Term::ReadLine::Stub'}
 sub readline {
   my $self = shift;
   my ($in,$out,$str) = @$self;
-  print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2]; 
+  my $prompt = shift;
+  print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; 
   $self->register_Tk 
      if not $Term::ReadLine::registered and $Term::ReadLine::toloop
        and defined &Tk::DoOneEvent;
   #$str = scalar <$in>;
   $str = $self->get_line;
+  $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
   print $out $rl_term_set[3]; 
   # bug in 5.000: chomping empty string creats length -1:
   chomp $str if defined $str;
@@ -185,7 +187,9 @@ sub addhistory {}
 sub findConsole {
     my $console;
 
-    if (-e "/dev/tty") {
+    if ($^O eq 'MacOS') {
+        $console = "Dev:Console";
+    } elsif (-e "/dev/tty") {
        $console = "/dev/tty";
     } elsif (-e "con" or $^O eq 'MSWin32') {
        $console = "con";
index e3b85d4..f4c6193 100644 (file)
@@ -34,47 +34,43 @@ sub POP
  $val;
 }
 
-sub SPLICE
-{
- my $obj = shift;
- my $sz  = $obj->FETCHSIZE;
- my $off = (@_) ? shift : 0;
- $off += $sz if ($off < 0);
- my $len = (@_) ? shift : $sz - $off;
- my @result;
- for (my $i = 0; $i < $len; $i++)
-  {
-   push(@result,$obj->FETCH($off+$i));
-  }
- if (@_ > $len)
-  {
-   # Move items up to make room
-   my $d = @_ - $len;
-   my $e = $off+$len;
-   $obj->EXTEND($sz+$d);
-   for (my $i=$sz-1; $i >= $e; $i--)
-    {
-     my $val = $obj->FETCH($i);
-     $obj->STORE($i+$d,$val);
+sub SPLICE {
+    my $obj = shift;
+    my $sz  = $obj->FETCHSIZE;
+    my $off = (@_) ? shift : 0;
+    $off += $sz if ($off < 0);
+    my $len = (@_) ? shift : $sz - $off;
+    $len += $sz - $off if $len < 0;
+    my @result;
+    for (my $i = 0; $i < $len; $i++) {
+        push(@result,$obj->FETCH($off+$i));
     }
-  }
- elsif (@_ < $len)
-  {
-   # Move items down to close the gap
-   my $d = $len - @_;
-   my $e = $off+$len;
-   for (my $i=$off+$len; $i < $sz; $i++)
-    {
-     my $val = $obj->FETCH($i);
-     $obj->STORE($i-$d,$val);
+    $off = $sz if $off > $sz;
+    $len -= $off + $len - $sz if $off + $len > $sz;
+    if (@_ > $len) {
+        # Move items up to make room
+        my $d = @_ - $len;
+        my $e = $off+$len;
+        $obj->EXTEND($sz+$d);
+        for (my $i=$sz-1; $i >= $e; $i--) {
+            my $val = $obj->FETCH($i);
+            $obj->STORE($i+$d,$val);
+        }
     }
-   $obj->STORESIZE($sz-$d);
-  }
- for (my $i=0; $i < @_; $i++)
-  {
-   $obj->STORE($off+$i,$_[$i]);
-  }
- return @result;
+    elsif (@_ < $len) {
+        # Move items down to close the gap
+        my $d = $len - @_;
+        my $e = $off+$len;
+        for (my $i=$off+$len; $i < $sz; $i++) {
+            my $val = $obj->FETCH($i);
+            $obj->STORE($i-$d,$val);
+        }
+        $obj->STORESIZE($sz-$d);
+    }
+    for (my $i=0; $i < @_; $i++) {
+        $obj->STORE($off+$i,$_[$i]);
+    }
+    return @result;
 }
 
 sub EXISTS {
index f93d615..f2f7e01 100644 (file)
@@ -38,11 +38,28 @@ The C<use bytes> pragma disables character semantics for the rest of the
 lexical scope in which it appears.  C<no bytes> can be used to reverse
 the effect of C<use bytes> within the current lexical scope.
 
-Perl normally assumes character semantics in the presence of
-character data (i.e. data that has come from a source that has
-been marked as being of a particular character encoding).
-
-To understand the implications and differences between character
+Perl normally assumes character semantics in the presence of character
+data (i.e. data that has come from a source that has been marked as
+being of a particular character encoding). When C<use bytes> is in
+effect, the encoding is temporarily ignored, and each string is treated
+as a series of bytes. 
+
+As an example, when Perl sees C<$x = chr(400)>, it encodes the character
+in UTF8 and stores it in $x. Then it is marked as character data, so,
+for instance, C<length $x> returns C<1>. However, in the scope of the
+C<bytes> pragma, $x is treated as a series of bytes - the bytes that make
+up the UTF8 encoding - and C<length $x> returns C<2>:
+
+    $x = chr(400);
+    print "Length is ", length $x, "\n";     # "Length is 1"
+    printf "Contents are %vd\n", $x;         # "Contents are 400"
+    { 
+        use bytes;
+        print "Length is ", length $x, "\n"; # "Length is 2"
+        printf "Contents are %vd\n", $x;     # "Contents are 198.144"
+    }
+
+For more on the implications and differences between character
 semantics and byte semantics, see L<perlunicode>.
 
 =head1 SEE ALSO
index 2595819..4a50b8f 100644 (file)
@@ -16,41 +16,50 @@ sub Getopts {
     local($argumentative) = @_;
     local(@args,$_,$first,$rest);
     local($errs) = 0;
+    local($[) = 0;
 
     @args = split( / */, $argumentative );
     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
-       ($first,$rest) = ($1,$2);
-       $pos = index($argumentative,$first);
-       if($pos >= 0) {
-           if($pos < $#args && $args[$pos+1] eq ':') {
-               shift(@ARGV);
-               if($rest eq '') {
-                   ++$errs unless @ARGV;
-                   $rest = shift(@ARGV);
-               }
-               ${"opt_$first"} = $rest;
-           }
-           else {
-               ${"opt_$first"} = 1;
-               if($rest eq '') {
-                   shift(@ARGV);
+               ($first,$rest) = ($1,$2);
+               $pos = index($argumentative,$first);
+               if($pos >= $[) {
+                       if($args[$pos+1] eq ':') {
+                               shift(@ARGV);
+                               if($rest eq '') {
+                                       ++$errs unless(@ARGV);
+                                       $rest = shift(@ARGV);
+                               }
+                               eval "
+                               push(\@opt_$first, \$rest);
+                               if(\$opt_$first eq '') {
+                                       \$opt_$first = \$rest;
+                               }
+                               else {
+                                       \$opt_$first .= ' ' . \$rest;
+                               }
+                               ";
+                       }
+                       else {
+                               eval "\$opt_$first = 1";
+                               if($rest eq '') {
+                                       shift(@ARGV);
+                               }
+                               else {
+                                       $ARGV[0] = "-$rest";
+                               }
+                       }
                }
                else {
-                   $ARGV[0] = "-$rest";
+                       print STDERR "Unknown option: $first\n";
+                       ++$errs;
+                       if($rest ne '') {
+                               $ARGV[0] = "-$rest";
+                       }
+                       else {
+                               shift(@ARGV);
+                       }
                }
-           }
-       }
-       else {
-           print STDERR "Unknown option: $first\n";
-           ++$errs;
-           if($rest ne '') {
-               $ARGV[0] = "-$rest";
-           }
-           else {
-               shift(@ARGV);
-           }
        }
-    }
     $errs == 0;
 }
 
index 5418b57..836e559 100644 (file)
@@ -401,6 +401,12 @@ if ($notty) {
     $console = "/dev/tty";
   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
     $console = "con";
+  } elsif ($^O eq 'MacOS') {
+    if ($MacPerl::Version !~ /MPW/) {
+      $console = "Dev:Console:Perl Debug"; # Separate window for application
+    } else {
+      $console = "Dev:Console";
+    }
   } else {
     $console = "sys\$command";
   }
@@ -426,7 +432,7 @@ if ($notty) {
                                  PeerAddr => $remoteport,
                                  Proto    => 'tcp',
                                );
-    if (!$OUT) { die "Could not create socket to connect to remote host."; }
+    if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
     $IN = $OUT;
   }
   else {
index 042227f..8afb9a3 100644 (file)
@@ -37,6 +37,14 @@ use symbolic references (see L<perlref>).
     $file = "STDOUT";
     print $file "Hi!"; # error; note: no comma after $file
 
+There is one exception to this rule:
+
+    $bar = \&{'foo'};
+    &$bar;
+
+is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
+
+
 =item C<strict vars>
 
 This generates a compile-time error if you access a variable that wasn't
index 06da956..f295a2d 100644 (file)
@@ -22,7 +22,7 @@ sub Tgetent {
     local($TERM) = @_;
     local($TERMCAP,$_,$entry,$loop,$field);
 
-    warn "Tgetent: no ospeed set" unless $ospeed;
+    warn "Tgetent: no ospeed set" unless $ospeed;
     foreach $key (keys %TC) {
        delete $TC{$key};
     }
index 94f9a5c..a0aac62 100644 (file)
@@ -6,13 +6,23 @@ return <<'END';
 0041   005a
 0061   007a
 00aa   
+00b2   00b3
 00b5   
-00ba   
+00b9   00ba
+00bc   00be
 00c0   00d6
 00d8   00f6
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -21,38 +31,57 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
+0640   0655
 0660   0669
-0671   06d3
-06d5   
+0670   06d3
+06d5   06e8
+06ea   06ed
 06f0   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
 0966   096f
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09e6   09f1
+09f4   09f9
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -60,10 +89,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a66   0a6f
-0a72   0a74
+0a66   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -71,20 +104,27 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
 0ae6   0aef
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
 0b66   0b6f
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -95,36 +135,60 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
-0be7   0bef
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0be7   0bf2
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
 0c66   0c6f
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
 0ce6   0cef
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
 0d66   0d6f
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e50   0e59
 0e81   0e82
 0e84   
@@ -137,22 +201,33 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0ed0   0ed9
 0edc   0edd
 0f00   
-0f20   0f29
-0f40   0f47
+0f18   0f19
+0f20   0f33
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
+102c   1032
+1036   1039
 1040   1049
-1050   1055
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -183,18 +258,18 @@ return <<'END';
 1318   131e
 1320   1346
 1348   135a
-1369   1371
+1369   137c
 13a0   13f4
 1401   166c
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
+16ee   16f0
+1780   17d3
 17e0   17e9
 1810   1819
-1820   1842
-1844   1877
-1880   18a8
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -216,7 +291,10 @@ return <<'END';
 1fe0   1fec
 1ff2   1ff4
 1ff6   1ffc
-207f   
+2070   
+2074   2079
+207f   2089
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -228,12 +306,25 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+2153   2183
+2460   249b
+24ea   
+2776   2793
+3005   3007
+3021   302f
+3031   3035
+3038   303a
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
+3192   3195
 31a0   31b7
+3220   3229
+3280   3289
 3400   4db5
 4e00   9fa5
 a000   a48c
@@ -241,8 +332,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -253,15 +343,14 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff10   ff19
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
index de5046f..13dc003 100644 (file)
@@ -12,6 +12,14 @@ return <<'END';
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -20,36 +28,54 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
-0671   06d3
-06d5   
+0640   0655
+0670   06d3
+06d5   06e8
+06ea   06ed
 06fa   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09f0   09f1
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -57,9 +83,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a72   0a74
+0a70   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -67,18 +98,25 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -89,32 +127,56 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e81   0e82
 0e84   
 0e87   0e88
@@ -126,19 +188,30 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0edc   0edd
 0f00   
-0f40   0f47
+0f18   0f19
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
-1050   1055
+102c   1032
+1036   1039
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -174,10 +247,9 @@ return <<'END';
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
-1820   1842
-1844   1877
-1880   18a8
+1780   17d3
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -200,6 +272,7 @@ return <<'END';
 1ff2   1ff4
 1ff6   1ffc
 207f   
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -211,9 +284,14 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+3005   3006
+302a   302f
+3031   3035
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
 31a0   31b7
@@ -224,8 +302,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -236,14 +313,13 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
index 40d3506..238cc56 100644 (file)
@@ -3,7 +3,7 @@
 # Any changes made here will be lost!
 return <<'END';
 0021   007e
-00a0   021f
+00a1   021f
 0222   0233
 0250   02ad
 02b0   02ee
@@ -239,7 +239,7 @@ return <<'END';
 1361   137c
 13a0   13f4
 1401   1676
-1680   169c
+1681   169c
 16a0   16f0
 1780   17dc
 17e0   17e9
@@ -265,10 +265,8 @@ return <<'END';
 1fdd   1fef
 1ff2   1ff4
 1ff6   1ffe
-2000   2008
-200b   
-2010   2029
-202f   2046
+2010   2027
+2030   2046
 2048   204d
 2070   
 2074   208e
@@ -304,7 +302,7 @@ return <<'END';
 2e9b   2ef3
 2f00   2fd5
 2ff0   2ffb
-3000   303a
+3001   303a
 303e   303f
 3041   3094
 3099   309e
@@ -330,6 +328,7 @@ a4b5        a4c0
 a4c2   a4c4
 a4c6   
 ac00   d7a3
+e000   f8ff
 f900   fa2d
 fb00   fb06
 fb13   fb17
@@ -360,4 +359,6 @@ ffda        ffdc
 ffe0   ffe6
 ffe8   ffee
 fffc   fffd
+f0000  ffffd
+100000 10fffd
 END
index c3adba6..1229a28 100644 (file)
@@ -266,7 +266,7 @@ return <<'END';
 1ff2   1ff4
 1ff6   1ffe
 2000   200b
-2010   2029
+2010   2027
 202f   2046
 2048   204d
 2070   
@@ -329,6 +329,7 @@ a4b5        a4c0
 a4c2   a4c4
 a4c6   
 ac00   d7a3
+e000   f8ff
 f900   fa2d
 fb00   fb06
 fb13   fb17
@@ -359,4 +360,6 @@ ffda        ffdc
 ffe0   ffe6
 ffe8   ffee
 fffc   fffd
+f0000  ffffd
+100000 10fffd
 END
index 9e088ba..97330ec 100644 (file)
@@ -8,45 +8,45 @@ return <<'END';
 003a   003b
 003f   0040
 005b   005d
-005f
-007b
-007d
-00a1
-00ab
-00ad
-00b7
-00bb
-00bf
-037e
-0387
+005f   
+007b   
+007d   
+00a1   
+00ab   
+00ad   
+00b7   
+00bb   
+00bf   
+037e   
+0387   
 055a   055f
 0589   058a
-05be
-05c0
-05c3
+05be   
+05c0   
+05c3   
 05f3   05f4
-060c
-061b
-061f
+060c   
+061b   
+061f   
 066a   066d
-06d4
+06d4   
 0700   070d
 0964   0965
-0970
-0df4
-0e4f
+0970   
+0df4   
+0e4f   
 0e5a   0e5b
 0f04   0f12
 0f3a   0f3d
-0f85
+0f85   
 104a   104f
-10fb
+10fb   
 1361   1368
 166d   166e
 169b   169c
 16eb   16ed
 17d4   17da
-17dc
+17dc   
 1800   180a
 2010   2027
 2030   2043
@@ -58,14 +58,14 @@ return <<'END';
 3001   3003
 3008   3011
 3014   301f
-3030
-30fb
+3030   
+30fb   
 fd3e   fd3f
 fe30   fe44
 fe49   fe52
 fe54   fe61
-fe63
-fe68
+fe63   
+fe68   
 fe6a   fe6b
 ff01   ff03
 ff05   ff0a
@@ -73,8 +73,8 @@ ff0c  ff0f
 ff1a   ff1b
 ff1f   ff20
 ff3b   ff3d
-ff3f
-ff5b
-ff5d
+ff3f   
+ff5b   
+ff5d   
 ff61   ff65
 END
index 1625dce..9971082 100644 (file)
@@ -3,12 +3,11 @@
 # Any changes made here will be lost!
 return <<'END';
 0009   000d
-0020
-0085
-00a0
-1680
+0020   
+00a0   
+1680   
 2000   200b
 2028   2029
-202f
-3000
+202f   
+3000   
 END
index 1c76c60..6ea32e6 100644 (file)
@@ -7,13 +7,23 @@ return <<'END';
 005f   
 0061   007a
 00aa   
+00b2   00b3
 00b5   
-00ba   
+00b9   00ba
+00bc   00be
 00c0   00d6
 00d8   00f6
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -22,38 +32,57 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
+0640   0655
 0660   0669
-0671   06d3
-06d5   
+0670   06d3
+06d5   06e8
+06ea   06ed
 06f0   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
 0966   096f
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09e6   09f1
+09f4   09f9
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -61,10 +90,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a66   0a6f
-0a72   0a74
+0a66   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -72,20 +105,27 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
 0ae6   0aef
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
 0b66   0b6f
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -96,36 +136,60 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
-0be7   0bef
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0be7   0bf2
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
 0c66   0c6f
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
 0ce6   0cef
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
 0d66   0d6f
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e50   0e59
 0e81   0e82
 0e84   
@@ -138,22 +202,33 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0ed0   0ed9
 0edc   0edd
 0f00   
-0f20   0f29
-0f40   0f47
+0f18   0f19
+0f20   0f33
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
+102c   1032
+1036   1039
 1040   1049
-1050   1055
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -184,18 +259,18 @@ return <<'END';
 1318   131e
 1320   1346
 1348   135a
-1369   1371
+1369   137c
 13a0   13f4
 1401   166c
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
+16ee   16f0
+1780   17d3
 17e0   17e9
 1810   1819
-1820   1842
-1844   1877
-1880   18a8
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -217,7 +292,10 @@ return <<'END';
 1fe0   1fec
 1ff2   1ff4
 1ff6   1ffc
-207f   
+2070   
+2074   2079
+207f   2089
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -229,12 +307,25 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+2153   2183
+2460   249b
+24ea   
+2776   2793
+3005   3007
+3021   302f
+3031   3035
+3038   303a
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
+3192   3195
 31a0   31b7
+3220   3229
+3280   3289
 3400   4db5
 4e00   9fa5
 a000   a48c
@@ -242,8 +333,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -254,15 +344,14 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff10   ff19
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
index 37b6e84..d8b57b6 100755 (executable)
@@ -16,18 +16,26 @@ mkdir "To", 0755;
 @todo = (
 # typical
 
-    ['IsWord',  '$cat =~ /^L[ulot]|^Nd/ or $code eq "005F"',   ''],
-    ['IsAlnum', '$cat =~ /^L[ulot]|^Nd/',      ''],
-    ['IsAlpha',  '$cat =~ /^L[ulot]/', ''],
-    ['IsSpace',  'White space',        $PropData],
+    # 005F: SPACING UNDERSCROE
+    ['IsWord',   '$cat =~ /^[LMN]/ or $code eq "005F"',        ''],
+    ['IsAlnum',  '$cat =~ /^[LMN]/',   ''],
+    ['IsAlpha',  '$cat =~ /^[LM]/',    ''],
+    # 0009: HORIZONTAL TABULATION
+    # 000A: LINE FEED
+    # 000B: VERTICAL TABULATION
+    # 000C: FORM FEED
+    # 000D: CARRIAGE RETURN
+    ['IsSpace',  '$cat  =~ /^Z/ ||
+                  $code =~ /^(0009|000A|000B|000C|000D)$/',    ''],
     ['IsDigit',  '$cat =~ /^Nd$/',     ''],
     ['IsUpper',  '$cat =~ /^L[ut]$/',  ''],
     ['IsLower',  '$cat =~ /^Ll$/',     ''],
-    ['IsASCII',  'hex $code <= 127',   ''],
+    ['IsASCII',  '$code le "007f"',    ''],
     ['IsCntrl',  '$cat =~ /^C/',       ''],
-    ['IsGraph',  '$cat =~ /^[^C]/ and ($cat !~ /^Z/ and $code ne "0020" or chr(hex $code) !~ /^\s/)',  ''],
-    ['IsPrint',  '$cat =~ /^[^C]/',    ''],
-    ['IsPunct',  'Punctuation',        $PropData],
+    ['IsGraph',  '$cat =~ /^([LMNPS]|Co)/',    ''],
+    ['IsPrint',  '$cat =~ /^([LMNPS]|Co|Zs)/', ''],
+    ['IsPunct',  '$cat =~ /^P/',       ''],
+    # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f
     ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/',  ''],
     ['ToUpper',  '$up',                        '$up'],
     ['ToLower',  '$down',              '$down'],
@@ -145,7 +153,7 @@ mkdir "To", 0755;
     ['IsDCfont',       '$decomp =~ /^<font>/',         ''],
     ['IsDCnoBreak',    '$decomp =~ /^<noBreak>/',      ''],
     ['IsDCinitial',    '$decomp =~ /^<initial>/',      ''],
-    ['IsDCinital',     '$decomp =~ /^<medial>/',       ''],
+    ['IsDCmedial',     '$decomp =~ /^<medial>/',       ''],
     ['IsDCfinal',      '$decomp =~ /^<final>/',        ''],
     ['IsDCisolated',   '$decomp =~ /^<isolated>/',     ''],
     ['IsDCcircle',     '$decomp =~ /^<circle>/',       ''],
index 35be28c..6d6c0eb 100644 (file)
@@ -1,5 +1,7 @@
 package utf8;
 
+if (ord('A') != 193) { # make things more pragmatic for EBCDIC folk
+
 $utf8::hint_bits = 0x00800000;
 
 sub import {
@@ -17,6 +19,8 @@ sub AUTOLOAD {
     Carp::croak("Undefined subroutine $AUTOLOAD called");
 }
 
+}
+
 1;
 __END__
 
@@ -45,7 +49,9 @@ in future we would like to standardize on the UTF-8 encoding for
 source text.  Until UTF-8 becomes the default format for source
 text, this pragma should be used to recognize UTF-8 in the source.
 When UTF-8 becomes the standard source format, this pragma will
-effectively become a no-op.
+effectively become a no-op.  This pragma already is a no-op on
+EBCDIC platforms (where it is alright to code perl in EBCDIC 
+rather than UTF-8).
 
 Enabling the C<utf8> pragma has the following effects:
 
index 0ace551..39a15bd 100644 (file)
@@ -10,6 +10,7 @@ require 5.002;
 require Carp if $] < 5.00450;
 
 use warnings::register;
+require strict;
 
 sub import {
     my $callpack = caller;
@@ -26,6 +27,8 @@ sub import {
                Carp::croak("Can't declare individual elements of hash or array");
            } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
                warnings::warn("No need to declare built-in vars");
+            } elsif  ( $^H &= strict::bits('vars') ) {
+              Carp::croak("'$ch$sym' is not a valid variable name under strict vars");
            }
        }
         *{"${callpack}::$sym"} =
index 2db2a6a..7584000 100644 (file)
--- a/malloc.c
+++ b/malloc.c
@@ -1889,6 +1889,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
        buf->start_slack = start_slack;
        buf->sbrked_remains = sbrked_remains;
        MALLOC_UNLOCK;
+       buf->nbuckets = NBUCKETS;
        if (level) {
            for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
                if (i >= buflen)
@@ -1911,12 +1912,10 @@ void
 Perl_dump_mstats(pTHX_ char *s)
 {
 #ifdef DEBUGGING_MSTATS
-       register int i, j;
-       register union overhead *p;
+       register int i;
        perl_mstats_t buffer;
-       unsigned long nf[NBUCKETS];
-       unsigned long nt[NBUCKETS];
-       struct chunk_chain_s* nextchain;
+       UV nf[NBUCKETS];
+       UV nt[NBUCKETS];
 
        buffer.nfree  = nf;
        buffer.ntotal = nt;
@@ -1924,18 +1923,18 @@ Perl_dump_mstats(pTHX_ char *s)
 
        if (s)
            PerlIO_printf(Perl_error_log,
-                         "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
+                         "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n",
                          s, 
-                         (long)BUCKET_SIZE_REAL(MIN_BUCKET), 
-                         (long)BUCKET_SIZE(MIN_BUCKET),
-                         (long)BUCKET_SIZE_REAL(buffer.topbucket), 
-                         (long)BUCKET_SIZE(buffer.topbucket));
-       PerlIO_printf(Perl_error_log, "%8ld free:", buffer.totfree);
+                         (IV)BUCKET_SIZE_REAL(MIN_BUCKET), 
+                         (IV)BUCKET_SIZE(MIN_BUCKET),
+                         (IV)BUCKET_SIZE_REAL(buffer.topbucket), 
+                         (IV)BUCKET_SIZE(buffer.topbucket));
+       PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree);
        for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
-                              ? " %5d" 
-                              : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+                              ? " %5"UVuf 
+                              : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)),
                              buffer.nfree[i]);
        }
 #ifdef BUCKETS_ROOT2
@@ -1943,17 +1942,17 @@ Perl_dump_mstats(pTHX_ char *s)
        for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
-                              ? " %5d" 
-                              : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+                              ? " %5"UVuf 
+                              : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)),
                              buffer.nfree[i]);
        }
 #endif 
-       PerlIO_printf(Perl_error_log, "\n%8ld used:", buffer.total - buffer.totfree);
+       PerlIO_printf(Perl_error_log, "\n%8"IVdf" used:", buffer.total - buffer.totfree);
        for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
-                              ? " %5d" 
-                              : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), 
+                              ? " %5"IVdf
+                              : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), 
                              buffer.ntotal[i] - buffer.nfree[i]);
        }
 #ifdef BUCKETS_ROOT2
@@ -1961,12 +1960,12 @@ Perl_dump_mstats(pTHX_ char *s)
        for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
-                              ? " %5d" 
-                              : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+                              ? " %5"IVdf 
+                              : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)),
                              buffer.ntotal[i] - buffer.nfree[i]);
        }
 #endif 
-       PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %ld/%ld:%ld. Odd ends: pad+heads+chain+tail: %ld+%ld+%ld+%ld.\n",
+       PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\n",
                      buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
                      buffer.sbrk_slack, buffer.start_slack,
                      buffer.total_chain, buffer.sbrked_remains);
index 1ab8bdc..e80dfb5 100644 (file)
@@ -49,6 +49,7 @@ Summary of my $package (revision $baserev version $PERL_VERSION subversion $PERL
     ld='$ld', ldflags ='$ldflags'
     libpth=$libpth
     libs=$libs
+    perllibs=$perllibs
     libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
   Dynamic Linking:
     dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
diff --git a/perl.h b/perl.h
index 9b963e1..c0f41c3 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -540,17 +540,6 @@ Free_t   Perl_mfree (Malloc_t where);
 
 typedef struct perl_mstats perl_mstats_t;
 
-struct perl_mstats {
-    unsigned long *nfree;
-    unsigned long *ntotal;
-    long topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
-    long total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
-    long minbucket;
-    /* Level 1 info */
-    unsigned long *bucket_mem_size;
-    unsigned long *bucket_available_size;
-};
-
 #  define safemalloc  Perl_malloc
 #  define safecalloc  Perl_calloc
 #  define saferealloc Perl_realloc
@@ -1071,6 +1060,9 @@ typedef UVTYPE UV;
 #endif
   
 #ifdef USE_LONG_DOUBLE
+#  if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE
+#      define LONG_DOUBLE_EQUALS_DOUBLE
+#  endif
 #  if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE))
 #     undef USE_LONG_DOUBLE /* Ouch! */
 #  endif
@@ -1180,13 +1172,9 @@ typedef NVTYPE NV;
 /* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */
 #   ifdef HAS_MODFL
 #       define Perl_modf(x,y) modfl(x,y)
-#   else
-#       define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y)))
 #   endif
 #   ifdef HAS_FREXPL
 #       define Perl_frexp(x,y) frexpl(x,y)
-#   else
-#       define Perl_frexp(x,y) ((long double)frexp((double)(x),y))
 #   endif
 #   ifdef HAS_ISNANL
 #       define Perl_isnan(x) isnanl(x)
@@ -1425,6 +1413,18 @@ typedef NVTYPE NV;
 
 #endif
 
+struct perl_mstats {
+    UV *nfree;
+    UV *ntotal;
+    IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
+    IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
+    IV minbucket;
+    /* Level 1 info */
+    UV *bucket_mem_size;
+    UV *bucket_available_size;
+    UV nbuckets;
+};
+
 typedef MEM_SIZE STRLEN;
 
 typedef struct op OP;
@@ -1440,7 +1440,12 @@ typedef struct pvop PVOP;
 typedef struct loop LOOP;
 
 typedef struct interpreter PerlInterpreter;
-typedef struct sv SV;
+#ifdef UTS
+#   define STRUCT_SV perl_sv /* Amdahl's <ksync.h> has struct sv */
+#else
+#   define STRUCT_SV sv
+#endif
+typedef struct STRUCT_SV SV;
 typedef struct av AV;
 typedef struct hv HV;
 typedef struct cv CV;
index 87f9f74..b4f5057 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -2645,9 +2645,9 @@ Perl_scan_hex(pTHXo_ char* start, I32 len, I32* retlen)
 
 #undef  Perl_scan_num
 char*
-Perl_scan_num(pTHXo_ char* s)
+Perl_scan_num(pTHXo_ char* s, YYSTYPE *lvalp)
 {
-    return ((CPerlObj*)pPerl)->Perl_scan_num(s);
+    return ((CPerlObj*)pPerl)->Perl_scan_num(s, lvalp);
 }
 
 #undef  Perl_scan_oct
diff --git a/perly.c b/perly.c
index d03d3de..2b5108f 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -1747,7 +1747,7 @@ case 35:
 break;
 case 37:
 #line 269 "perly.y"
-{ (void)scan_num("1"); yyval.opval = yylval.opval; }
+{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
 break;
 case 39:
 #line 274 "perly.y"
diff --git a/perly.y b/perly.y
index 5170b36..af0159e 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -266,7 +266,7 @@ nexpr       :       /* NULL */
        ;
 
 texpr  :       /* NULL means true */
-                       { (void)scan_num("1"); $$ = yylval.opval; }
+                       { (void)scan_num("1", &yylval); $$ = yylval.opval; }
        |       expr
        ;
 
index 55e3925..3819308 100644 (file)
@@ -150,6 +150,7 @@ if (-d "pod") {
     perl5005delta       
     perl5004delta       
 
+    perlaix
     perlamiga          
     perlcygwin          
     perldos             
@@ -163,6 +164,7 @@ if (-d "pod") {
          );
 
 @ARCHPODS = qw(
+    perlaix    
     perlamiga          
     perlcygwin          
     perldos             
index fc40d3b..946d6f2 100644 (file)
@@ -104,6 +104,7 @@ For ease of access, the Perl manual has been split up into several sections:
     perl5005delta      Perl changes in version 5.005
     perl5004delta      Perl changes in version 5.004
 
+    perlaix            Perl notes for AIX
     perlamiga          Perl notes for Amiga
     perlcygwin         Perl notes for Cygwin
     perldos            Perl notes for DOS
index 4ef5eca..12ea2f3 100644 (file)
@@ -501,7 +501,8 @@ provide easy to use ASCII to EBCDIC operations that are also easily
 reversed.
 
 For example, to convert ASCII to code page 037 take the output of the second 
-column from the output of recipe 0 and use it in tr/// like so:
+column from the output of recipe 0 (modified to add \\ characters) and use 
+it in tr/// like so:
 
     $cp_037 = 
     '\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017' .
@@ -524,15 +525,19 @@ column from the output of recipe 0 and use it in tr/// like so:
     my $ebcdic_string = $ascii_string;
     eval '$ebcdic_string =~ tr/\000-\377/' . $cp_037 . '/';
 
-To convert from EBCDIC to ASCII just reverse the order of the tr/// 
+To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// 
 arguments like so:
 
     my $ascii_string = $ebcdic_string;
-    eval '$ascii_string = tr/' . $code_page_chrs . '/\000-\037/';
+    eval '$ascii_string = tr/' . $cp_037 . '/\000-\377/';
+
+Similarly one could take the output of the third column from recipe 0 to
+obtain a C<$cp_1047> table.  The fourth column of the output from recipe
+0 could provide a C<$cp_posix_bc> table suitable for transcoding as well.
 
 =head2 iconv
 
-XPG4 operability often implies the presence of an I<iconv> utility
+XPG operability often implies the presence of an I<iconv> utility
 available from the shell or from the C library.  Consult your system's
 documentation for information on iconv.
 
index 1ca7893..0d4876f 100644 (file)
@@ -196,6 +196,10 @@ own module.  Make sure to change the names appropriately.
     }
     our @EXPORT_OK;
 
+    # exported package globals go here
+    our $Var1;
+    our %Hashit;
+
     # non-exported package globals go here
     our @more;
     our $stuff;
index da67c89..f525a07 100644 (file)
@@ -210,6 +210,39 @@ line and all will be well.
 To free an SV that you've created, call C<SvREFCNT_dec(SV*)>.  Normally this
 call is not necessary (see L<Reference Counts and Mortality>).
 
+=head2 Offsets
+
+Perl provides the function C<sv_chop> to efficiently remove characters
+from the beginning of a string; you give it an SV and a pointer to
+somewhere inside the the PV, and it discards everything before the
+pointer. The efficiency comes by means of a little hack: instead of
+actually removing the characters, C<sv_chop> sets the flag C<OOK>
+(offset OK) to signal to other functions that the offset hack is in
+effect, and it puts the number of bytes chopped off into the IV field
+of the SV. It then moves the PV pointer (called C<SvPVX>) forward that
+many bytes, and adjusts C<SvCUR> and C<SvLEN>. 
+
+Hence, at this point, the start of the buffer that we allocated lives
+at C<SvPVX(sv) - SvIV(sv)> in memory and the PV pointer is pointing
+into the middle of this allocated storage.
+
+This is best demonstrated by example:
+
+  % ./perl -Ilib -MDevel::Peek -le '$a="12345"; $a=~s/.//; Dump($a)'
+  SV = PVIV(0x8128450) at 0x81340f0
+    REFCNT = 1
+    FLAGS = (POK,OOK,pPOK)
+    IV = 1  (OFFSET)
+    PV = 0x8135781 ( "1" . ) "2345"\0
+    CUR = 4
+    LEN = 5
+
+Here the number of bytes chopped off (1) is put into IV, and
+C<Devel::Peek::Dump> helpfully reminds us that this is an offset. The
+portion of the string between the "real" and the "fake" beginnings is
+shown in parentheses, and the values of C<SvCUR> and C<SvLEN> reflect
+the fake beginning, not the real one.
+
 =head2 What's Really Stored in an SV?
 
 Recall that the usual method of determining the type of scalar you have is
index a9a8756..6f98cf6 100644 (file)
@@ -310,6 +310,10 @@ create a file called F<Some/Module.pm> and start with this template:
     }
     our @EXPORT_OK;
 
+    # exported package globals go here
+    our $Var1;
+    our %Hashit;
+
     # non-exported package globals go here
     our @more;
     our $stuff;
index 32eaa3c..e97a25b 100644 (file)
@@ -710,7 +710,7 @@ on a Mac, these are reversed, and on systems without line terminator,
 printing C<"\n"> may emit no actual data.  In general, use C<"\n"> when
 you mean a "newline" for your system, but use the literal ASCII when you
 need an exact character.  For example, most networking protocols expect
-and prefer a CR+LF (C<"\012\015"> or C<"\cJ\cM">) for line terminators,
+and prefer a CR+LF (C<"\015\012"> or C<"\cM\cJ">) for line terminators,
 and although they often accept just C<"\012">, they seldom tolerate just
 C<"\015">.  If you get in the habit of using C<"\n"> for networking,
 you may be burned some day.
index 25e1371..0c35546 100644 (file)
@@ -1995,8 +1995,9 @@ http://www.perl.com/CPAN/ports/index.html for binary distributions.
 
 =head1 SEE ALSO
 
-L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlhpux>, L<perlos2>,
-L<perlos390>, L<perlwin32>, L<perlvms>, and L<Win32>.
+L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlebcdic>,
+L<perlhpux>, L<perlos2>, L<perlos390>, L<perlposix-bc>, L<perlwin32>,
+L<perlvms>, and L<Win32>.
 
 =head1 AUTHORS / CONTRIBUTORS
 
index 4c5831b..dd5bb63 100644 (file)
@@ -72,9 +72,14 @@ if ($options{official} && !defined $options{center}) {
     $options{center} = 'Perl Programmers Reference Guide';
 }
 
-# Initialize and run the formatter.
+# Initialize and run the formatter, pulling a pair of input and output off
+# at a time.
 my $parser = Pod::Man->new (%options);
-$parser->parse_from_file (@ARGV);
+my @files;
+do {
+    @files = splice (@ARGV, 0, 2);
+    $parser->parse_from_file (@files);
+} while (@ARGV);
 
 __END__
 
@@ -88,7 +93,7 @@ pod2man [B<--section>=I<manext>] [B<--release>=I<version>]
 [B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>]
 [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
 [B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>]
-[B<--quotes>=I<quotes>] [I<input> [I<output>]]
+[B<--quotes>=I<quotes>] [I<input> [I<output>] ...]
 
 pod2man B<--help>
 
@@ -101,7 +106,10 @@ terminal using nroff(1), normally via man(1), or printing using troff(1).
 I<input> is the file to read for POD source (the POD can be embedded in
 code).  If I<input> isn't given, it defaults to STDIN.  I<output>, if given,
 is the file to which to write the formatted output.  If I<output> isn't
-given, the formatted output is written to STDOUT.
+given, the formatted output is written to STDOUT.  Several POD files can be
+processed in the same B<pod2man> invocation (saving module load and compile
+times) by providing multiple pairs of I<input> and I<output> files on the
+command line.
 
 B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be
 used to set the headers and footers to use; if not given, Pod::Man will
diff --git a/pp.c b/pp.c
index 24b2b99..8c9526e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1061,7 +1061,7 @@ PP(pp_repeat)
 {
   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
   {
-    register I32 count = POPi;
+    register IV count = POPi;
     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
        dMARK;
        I32 items = SP - MARK;
@@ -1461,21 +1461,53 @@ PP(pp_complement)
        }
       }
       else {
-       register char *tmps;
-       register long *tmpl;
+       register U8 *tmps;
        register I32 anum;
        STRLEN len;
 
        SvSetSV(TARG, sv);
-       tmps = SvPV_force(TARG, len);
+       tmps = (U8*)SvPV_force(TARG, len);
        anum = len;
+       if (SvUTF8(TARG)) {
+         /* Calculate exact length, let's not estimate */
+         STRLEN targlen = 0;
+         U8 *result;
+         U8 *send;
+         I32 l;
+
+         send = tmps + len;
+         while (tmps < send) {
+           UV c = utf8_to_uv(tmps, &l);
+           tmps += UTF8SKIP(tmps);
+           targlen += UTF8LEN(~c);
+         }
+
+         /* Now rewind strings and write them. */
+         tmps -= len;
+         Newz(0, result, targlen + 1, U8);
+         while (tmps < send) {
+           UV c = utf8_to_uv(tmps, &l);
+           tmps += UTF8SKIP(tmps);
+           result = uv_to_utf8(result,(UV)~c);
+         }
+         *result = '\0';
+         result -= targlen;
+         sv_setpvn(TARG, (char*)result, targlen);
+         SvUTF8_on(TARG);
+         Safefree(result);
+         SETs(TARG);
+         RETURN;
+       }
 #ifdef LIBERAL
-       for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
-           *tmps = ~*tmps;
-       tmpl = (long*)tmps;
-       for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
-           *tmpl = ~*tmpl;
-       tmps = (char*)tmpl;
+       {
+           register long *tmpl;
+           for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
+               *tmps = ~*tmps;
+           tmpl = (long*)tmps;
+           for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+               *tmpl = ~*tmpl;
+           tmps = (U8*)tmpl;
+       }
 #endif
        for ( ; anum > 0; anum--, tmps++)
            *tmps = ~*tmps;
@@ -1850,11 +1882,24 @@ PP(pp_int)
        SETi(iv);
       }
       else {
-       if (value >= 0.0)
-         (void)Perl_modf(value, &value);
+         if (value >= 0.0) {
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+             (void)Perl_modf(value, &value);
+#else
+             double tmp = (double)value;
+             (void)Perl_modf(tmp, &tmp);
+             value = (NV)tmp;
+#endif
+         }
        else {
-         (void)Perl_modf(-value, &value);
-         value = -value;
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+           (void)Perl_modf(-value, &value);
+           value = -value;
+#else
+           double tmp = (double)value;
+           (void)Perl_modf(-tmp, &tmp);
+           value = -(NV)tmp;
+#endif
        }
        iv = I_V(value);
        if (iv == value)
@@ -2065,8 +2110,8 @@ PP(pp_substr)
 PP(pp_vec)
 {
     djSP; dTARGET;
-    register I32 size = POPi;
-    register I32 offset = POPi;
+    register IV size   = POPi;
+    register IV offset = POPi;
     register SV *src = POPs;
     I32 lvalue = PL_op->op_flags & OPf_MOD;
 
@@ -2199,7 +2244,7 @@ PP(pp_chr)
 {
     djSP; dTARGET;
     char *tmps;
-    U32 value = POPu;
+    UV value = POPu;
 
     (void)SvUPGRADE(TARG,SVt_PV);
 
@@ -4805,8 +4850,9 @@ PP(pp_pack)
                    do {
                        double next = floor(adouble / 128);
                        *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
-                       if (--in < buf)  /* this cannot happen ;-) */
+                       if (in <= buf)  /* this cannot happen ;-) */
                            DIE(aTHX_ "Cannot compress integer");
+                       in--;
                        adouble = next;
                    } while (adouble > 0);
                    buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
@@ -4965,9 +5011,9 @@ PP(pp_split)
 {
     djSP; dTARG;
     AV *ary;
-    register I32 limit = POPi;                 /* note, negative is forever */
+    register IV limit = POPi;                  /* note, negative is forever */
     SV *sv = POPs;
-    bool isutf = DO_UTF8(sv);
+    bool doutf8 = DO_UTF8(sv);
     STRLEN len;
     register char *s = SvPV(sv, len);
     char *strend = s + len;
@@ -5070,7 +5116,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (isutf)
+           if (doutf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
 
@@ -5092,7 +5138,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (isutf)
+           if (doutf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
            s = m;
@@ -5103,11 +5149,11 @@ PP(pp_split)
             && !(rx->reganch & ROPT_ANCH)) {
        int tail = (rx->reganch & RE_INTUIT_TAIL);
        SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
-       char c;
 
        len = rx->minlen;
        if (len == 1 && !tail) {
-           c = *SvPV(csv,len);
+           STRLEN n_a;
+           char c = *SvPV(csv, n_a);
            while (--limit) {
                /*SUPPRESS 530*/
                for (m = s; m < strend && *m != c; m++) ;
@@ -5117,10 +5163,12 @@ PP(pp_split)
                sv_setpvn(dstr, s, m-s);
                if (make_mortal)
                    sv_2mortal(dstr);
-               if (isutf)
+               if (doutf8)
                    (void)SvUTF8_on(dstr);
                XPUSHs(dstr);
-               s = m + 1;
+               /* The rx->minlen is in characters but we want to step
+                * s ahead by bytes. */
+               s = m + (doutf8 ? SvCUR(csv) : len);
            }
        }
        else {
@@ -5134,10 +5182,12 @@ PP(pp_split)
                sv_setpvn(dstr, s, m-s);
                if (make_mortal)
                    sv_2mortal(dstr);
-               if (isutf)
+               if (doutf8)
                    (void)SvUTF8_on(dstr);
                XPUSHs(dstr);
-               s = m + len;            /* Fake \n at the end */
+               /* The rx->minlen is in characters but we want to step
+                * s ahead by bytes. */
+               s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
            }
        }
     }
@@ -5163,7 +5213,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (isutf)
+           if (doutf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
            if (rx->nparens) {
@@ -5178,7 +5228,7 @@ PP(pp_split)
                        dstr = NEWSV(33, 0);
                    if (make_mortal)
                        sv_2mortal(dstr);
-                   if (isutf)
+                   if (doutf8)
                        (void)SvUTF8_on(dstr);
                    XPUSHs(dstr);
                }
@@ -5194,11 +5244,12 @@ PP(pp_split)
 
     /* keep field after final delim? */
     if (s < strend || (iters && origlimit)) {
-       dstr = NEWSV(34, strend-s);
-       sv_setpvn(dstr, s, strend-s);
+        STRLEN l = strend - s;
+       dstr = NEWSV(34, l);
+       sv_setpvn(dstr, s, l);
        if (make_mortal)
            sv_2mortal(dstr);
-       if (isutf)
+       if (doutf8)
            (void)SvUTF8_on(dstr);
        XPUSHs(dstr);
        iters++;
index b72c422..23b8b79 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1005,10 +1005,17 @@ PP(pp_flip)
     else {
        dTOPss;
        SV *targ = PAD_SV(PL_op->op_targ);
-
-       if ((PL_op->op_private & OPpFLIP_LINENUM)
-         ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
-         : SvTRUE(sv) ) {
+       int flip;
+
+       if (PL_op->op_private & OPpFLIP_LINENUM) {
+           struct io *gp_io;
+           flip = PL_last_in_gv
+               && (gp_io = GvIOp(PL_last_in_gv))
+               && SvIV(sv) == (IV)IoLINES(gp_io);
+       } else {
+           flip = SvTRUE(sv);
+       }
+       if (flip) {
            sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
            if (PL_op->op_flags & OPf_SPECIAL) {
                sv_setiv(targ, 1);
index c7a0b80..ea77e1d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -172,8 +172,12 @@ PP(pp_concat)
                /* Take a copy since we're about to overwrite TARG */
                olds = s = (U8*)savepvn((char*)s, len);
            }
-           if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG)
-               sv_setpv(left, "");     /* Suppress warning. */
+           if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
+               if (SvREADONLY(left))
+                   left = sv_2mortal(newSVsv(left));
+               else
+                   sv_setpv(left, ""); /* Suppress warning. */
+           }
             l = (U8*)SvPV(left, targlen);
            left_utf |= DO_UTF8(left);
             if (TARG != left)
@@ -1339,7 +1343,7 @@ Perl_do_readline(pTHX)
                        }
                        else {
                           PerlIO_rewind(tmpfp);
-                          IoTYPE(io) = '<';
+                          IoTYPE(io) = IoTYPE_RDONLY;
                           IoIFP(io) = fp = tmpfp;
                           IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
                        }
@@ -1393,7 +1397,7 @@ Perl_do_readline(pTHX)
        else if (type == OP_GLOB)
            SP--;
        else if (ckWARN(WARN_IO)        /* stdout/stderr or other write fh */
-                && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
+                && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
                     || fp == PerlIO_stderr()))
        {
            /* integrate with report_evil_fh()? */
@@ -1412,7 +1416,8 @@ Perl_do_readline(pTHX)
        }
     }
     if (!fp) {
-       if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
+       if (ckWARN2(WARN_GLOB, WARN_CLOSED)
+               && (!io || !(IoFLAGS(io) & IOf_START))) {
            if (type == OP_GLOB)
                Perl_warner(aTHX_ WARN_GLOB,
                            "glob failed (can't start child: %s)",
@@ -2777,7 +2782,7 @@ PP(pp_aelem)
 {
     djSP;
     SV** svp;
-    I32 elem = POPi;
+    IV elem = POPi;
     AV* av = (AV*)POPs;
     U32 lval = PL_op->op_flags & OPf_MOD;
     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
index c898394..1b56290 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -57,7 +57,15 @@ extern "C" int syscall(unsigned long,...);
 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
 # include <sys/socket.h>
 # if defined(USE_SOCKS) && defined(I_SOCKS)
+#   if !defined(INCLUDE_PROTOTYPES)
+#       define INCLUDE_PROTOTYPES /* for <socks.h> */
+#       define PERL_SOCKS_NEED_PROTOTYPES
+#   endif
 #   include <socks.h>
+#   ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
+#       undef INCLUDE_PROTOTYPES
+#       undef PERL_SOCKS_NEED_PROTOTYPES
+#   endif 
 # endif
 # ifdef I_NETDB
 #  include <netdb.h>
diff --git a/proto.h b/proto.h
index 2435b75..da71f1e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -678,7 +678,7 @@ PERL_CALLCONV OP*   Perl_scalarseq(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_scalarvoid(pTHX_ OP* o);
 PERL_CALLCONV NV       Perl_scan_bin(pTHX_ char* start, I32 len, I32* retlen);
 PERL_CALLCONV NV       Perl_scan_hex(pTHX_ char* start, I32 len, I32* retlen);
-PERL_CALLCONV char*    Perl_scan_num(pTHX_ char* s);
+PERL_CALLCONV char*    Perl_scan_num(pTHX_ char* s, YYSTYPE *lvalp);
 PERL_CALLCONV NV       Perl_scan_oct(pTHX_ char* start, I32 len, I32* retlen);
 PERL_CALLCONV OP*      Perl_scope(pTHX_ OP* o);
 PERL_CALLCONV char*    Perl_screaminstr(pTHX_ SV* bigsv, SV* littlesv, I32 start_shift, I32 end_shift, I32 *state, I32 last);
@@ -836,6 +836,7 @@ PERL_CALLCONV int   Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp);
 #else
 PERL_CALLCONV int      Perl_yylex(pTHX);
 #endif
+STATIC int     S_syylex(pTHX);
 PERL_CALLCONV int      Perl_yyparse(pTHX);
 PERL_CALLCONV int      Perl_yywarn(pTHX_ char* s);
 #if defined(MYMALLOC)
index d3f2065..6e046f3 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -325,6 +325,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     register I32 end_shift;
     register char *s;
     register SV *check;
+    char *strbeg;
     char *t;
     I32 ml_anch;
     char *tmp;
@@ -351,6 +352,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
        goto fail;
     }
+    strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
     check = prog->check_substr;
     if (prog->reganch & ROPT_ANCH) {   /* Match at beg-of-str or after \n */
        ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
@@ -361,7 +363,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
          if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
               /* SvCUR is not set on references: SvRV and SvPVX overlap */
               && sv && !SvROK(sv)
-              && (strpos + SvCUR(sv) != strend)) {
+              && (strpos != strbeg)) {
              DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
              goto fail;
          }
@@ -428,7 +430,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     /* Find a possible match in the region s..strend by looking for
        the "check" substring in the region corrected by start/end_shift. */
     if (flags & REXEC_SCREAM) {
-       char *strbeg = SvPVX(sv);       /* XXXX Assume PV_force() on SCREAM! */
        I32 p = -1;                     /* Internal iterator of scream. */
        I32 *pp = data ? data->scream_pos : &p;
 
@@ -670,7 +671,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        /* Even in this situation we may use MBOL flag if strpos is offset
           wrt the start of the string. */
        if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
-           && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n'
+           && (strpos != strbeg) && strpos[-1] != '\n'
            /* May be due to an implicit anchor of m{.*foo}  */
            && !(prog->reganch & ROPT_IMPLICIT))
        {
@@ -721,7 +722,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                ? s + (prog->minlen? cl_l : 0)
                : (prog->float_substr ? check_at - start_shift + cl_l
                                      : strend) ;
-       char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s;
+       char *startpos = strbeg;
 
        t = s;
        if (prog->reganch & ROPT_UTF8) {        
diff --git a/sv.h b/sv.h
index fa73a86..425acc3 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -61,7 +61,7 @@ typedef enum {
 
 /* Using C's structural equivalence to help emulate C++ inheritance here... */
 
-struct sv {
+struct STRUCT_SV {
     void*      sv_any;         /* pointer to something */
     U32                sv_refcnt;      /* how many references to us */
     U32                sv_flags;       /* what we are */
index b224cce..0190281 100755 (executable)
@@ -268,13 +268,13 @@ ok;
 {
     local *F;
     for (1..2) {
-        open(F, "echo #foo|") or print "not ";
+        open(F, "echo \\#foo|") or print "not ";
        print <F>;
        close F;
     }
     ok;
     for (1..2) {
-       open(F, "-|", "echo #foo") or print "not ";
+       open(F, "-|", "echo \\#foo") or print "not ";
        print <F>;
        close F;
     }
index 10c9b0f..be711f1 100755 (executable)
@@ -11,7 +11,8 @@ BEGIN {
 }
 
 END {
-    unlink 'tmon.out', 'err';
+    while(-e 'tmon.out' && unlink 'tmon.out') {}
+    while(-e 'err' && unlink 'err') {}
 }
 
 use Benchmark qw( timediff timestr );
@@ -22,7 +23,7 @@ getopts('vI:p:');
 # -I   Add to @INC
 # -p   Name of perl binary
 
-@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>;  # glob-sort, for OS/2
+@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>);  # glob-sort, for OS/2
 
 $path_sep = $Config{path_sep} || ':';
 $perl5lib = $opt_I || join( $path_sep, @INC );
@@ -46,7 +47,7 @@ sub profile {
        my $opt_d = '-d:DProf';
 
        my $t_start = new Benchmark;
-       open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n";
+        open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
        @results = <R>;
        close R;
        my $t_total = timediff( new Benchmark, $t_start );
@@ -56,15 +57,17 @@ sub profile {
                print @results
        }
 
-       print timestr( $t_total, 'nop' ), "\n";
+        print '# ',timestr( $t_total, 'nop' ), "\n";
 }
 
 
 sub verify {
        my $test = shift;
 
-       system $perl, '-I../lib', '-I./lib/dprof', $test,
-               $opt_v?'-v':'', '-p', $perl;
+       my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test;
+       $command .= ' -v' if $opt_v;
+       $command .= ' -p '. $perl;
+       system $command;
 }
 
 
@@ -72,6 +75,7 @@ $| = 1;
 print "1..18\n";
 while( @tests ){
        $test = shift @tests;
+        $test =~ s/\.$// if $^O eq 'VMS';
        if( $test =~ /_t$/i ){
                print "# $test" . '.' x (20 - length $test);
                profile $test;
index 7e34da5..cbdeca4 100644 (file)
@@ -13,6 +13,7 @@ $num = 0;
 $results = $expected = '';
 $perl = $opt_p || $^X;
 $dpp = $opt_d || '../utils/dprofpp';
+$dpp .= '.com' if $^O eq 'VMS';
 
 print "\nperl: $perl\n" if $opt_v;
 if( ! -f $perl ){ die "Where's Perl?" }
@@ -21,7 +22,7 @@ if( ! -f $dpp ){ die "Where's dprofpp?" }
 sub dprofpp {
        my $switches = shift;
 
-       open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n";
+        open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n";
        @results = <D>;
        close D;
 
diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t
new file mode 100644 (file)
index 0000000..d7ea6cc
--- /dev/null
@@ -0,0 +1,17 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}
+
+# bug id 20001020.002
+# -dlc 20001021
+
+use Tie::Array;
+tie @a,Tie::StdArray;
+undef *Tie::StdArray::SPLICE;
+require "op/splice.t"
+
+# Pre-fix, this failed tests 6-9
index 344b8be..88fbc55 100644 (file)
@@ -220,7 +220,7 @@ if ($^O ne 'unicos') {
     # especially if operating near the UV/IV limits the low-order bits
     # become mangled even by simple arithmetic operations.
     for (23..37) {
-       print "ok #_ # skipped: too imprecise numbers\n";
+       print "ok $_ # skipped: too imprecise numbers\n";
     }
 }
 
index 972d321..afaf6a1 100755 (executable)
@@ -2,7 +2,7 @@
 
 # $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $
 
-print "1..14\n";
+print "1..13\n";
 
 $a = 'ab' . 'c';       # compile time
 $b = 'def';
@@ -54,11 +54,3 @@ if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";}
     my $t8 = $u; $t8 = $ub . $t8;
     print $t8 =~ /b/ ? "ok 13\n" : "not ok 13\t# $t8\n";
 }
-
-# test that undef left and right of utf8 results in a valid string
-{
-    my $a;
-    $a .= "\x{1ff}";
-    print $a eq "\x{1ff}" ? "ok 14\n" :
-       "not ok 14\t# (undef.0x1ff) ne (0x1ff)\n";
-}
index 92baa67..fd080e6 100755 (executable)
@@ -9,7 +9,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..35\n";
+print "1..38\n";
 
 # numerics
 print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n");
@@ -82,9 +82,9 @@ print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801';
 print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095';
 print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095';
 #
-print "ok 31\n" if sprintf("%vd", v120.v300 & v200.400) eq '72.256';
-print "ok 32\n" if sprintf("%vd", v120.v300 | v200.400) eq '248.444';
-print "ok 33\n" if sprintf("%vd", v120.v300 ^ v200.400) eq '176.188';
+print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256';
+print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444';
+print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188';
 #
 my $a = v120.300;
 my $b = v200.400;
@@ -94,3 +94,40 @@ my $a = v120.300;
 my $b = v200.400;
 $a |= $b;
 print "ok 35\n" if sprintf("%vd", $a) eq '248.444';
+
+#
+# UTF8 ~ behaviour
+#
+
+my @not36;
+
+for (0x100...0xFFF) {
+  $a = ~(chr $_);
+  push @not36, sprintf("%#03X", $_)
+      if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_);
+}
+if (@not36) {
+    print "# test 36 failed: @not36\n";
+    print "not ";
+}
+print "ok 36\n";
+
+my @not37;
+
+for my $i (0xEEE...0xF00) {
+  for my $j (0x0..0x120) {
+    $a = ~(chr ($i) . chr $j);
+    push @not37, sprintf("%#03X %#03X", $i, $j)
+       if $a ne chr(~$i).chr(~$j) or
+          length($a) != 2 or 
+          ~$a ne chr($i).chr($j);
+  }
+}
+if (@not37) {
+    print "# test 37 failed: @not37\n";
+    print "not ";
+}
+print "ok 37\n";
+
+print "not " unless ~chr(~0) eq "\0";
+print "ok 38\n";
index 20167f3..f66af27 100755 (executable)
@@ -2,7 +2,7 @@
 
 # $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $
 
-print "1..9\n";
+print "1..10\n";
 
 @a = (1,2,3,4,5,6,7,8,9,10,11,12);
 
@@ -27,3 +27,10 @@ if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";}
 
 $x = 3.14;
 if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";}
+
+{
+    # coredump reported in bug 20001018.008
+    readline(UNKNOWN);
+    $. = 1;
+    print "ok 10\n" unless 1 .. 10;
+}
index f0d7f54..f442494 100755 (executable)
@@ -371,8 +371,8 @@ argv <e>
 # fdopen from a system descriptor to a system descriptor used to close
 # the former.
 open STDERR, '>&=STDOUT' or die $!;
-select STDOUT; $| = 1; print fileno STDOUT;
-select STDERR; $| = 1; print fileno STDERR;
+select STDOUT; $| = 1; print fileno STDOUT or die $!;
+select STDERR; $| = 1; print fileno STDERR or die $!;
 EXPECT
 1
 2
index 3a487d8..896f875 100755 (executable)
@@ -57,11 +57,23 @@ print length eq 5                      ? "ok" : "not ok", " 37\n";
 print $_ eq "\0"."_"."7"."_"."7"       ? "ok" : "not ok", " 38\n";
 chop, chop, chop, chop;
 print $_ eq "\0"                       ? "ok" : "not ok", " 39\n";
-print "\077_" eq "?_"                  ? "ok" : "not ok", " 40\n";
+if (ord("\t") != 9) {
+    # question mark is 111 in 1047, 037, && POSIX-BC
+    print "\157_" eq "?_"                  ? "ok" : "not ok", " 40\n";
+}
+else {
+    print "\077_" eq "?_"                  ? "ok" : "not ok", " 40\n";
+}
 
 $_ = "\x_7_7";
 print length eq 5                      ? "ok" : "not ok", " 41\n";
 print $_ eq "\0"."_"."7"."_"."7"       ? "ok" : "not ok", " 42\n";
 chop, chop, chop, chop;
 print $_ eq "\0"                       ? "ok" : "not ok", " 43\n";
-print "\x2F_" eq "/_"                  ? "ok" : "not ok", " 44\n";
+if (ord("\t") != 9) {
+    # / is 97 in 1047, 037, && POSIX-BC
+    print "\x61_" eq "/_"                  ? "ok" : "not ok", " 44\n";
+}
+else {
+    print "\x2F_" eq "/_"                  ? "ok" : "not ok", " 44\n";
+}
index f009086..f0cb7dc 100755 (executable)
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..223\n";
+print "1..224\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -1084,3 +1084,7 @@ print "not " unless "@space2" eq "spc tab";
 print "ok $test\n";
 $test++;
  
+# bugid 20001021.005 - this caused a SEGV
+print "not " unless undef =~ /^([^\/]*)(.*)$/;
+print "ok $test\n";
+$test++;
index 1fda31e..2f6cd27 100755 (executable)
@@ -56,8 +56,17 @@ for ($i = 1; @tests; $i++) {
     }
     elsif ($y eq ">$result<")  # Some C libraries always give
     {                          # three-digit exponent
-       print("ok $i >$result< $x # three-digit exponent accepted\n");
+               print("ok $i # >$result< $x three-digit exponent accepted\n");
     }
+       elsif ($result =~ /[-+]\d{3}$/ &&
+                  # Suppress tests with modulo of exponent >= 100 on platforms
+                  # which can't handle such magnitudes (or where we can't tell).
+                  ((!eval {require POSIX}) || # Costly: only do this if we must!
+                       (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3))
+       {
+               print("ok $i # >$template< >$data< >$result<",
+                         " Suppressed: exponent out of range?\n") 
+       }
     else {
        $y = ($x eq $y ? "" : " => $y");
        print("not ok $i >$template< >$data< >$result< $x$y",
index 6b74753..a7b041e 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..19\n";
+print "1..29\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -66,70 +66,118 @@ else {
     print "not " if $x ne 256.65.258 or length $x != 3;
 }
 print "ok 8\n";
+# EBCDIC variants of the above tests
+($x = 256.193.258) =~ tr/a/b/;
+print "not " if $x ne 256.193.258 or length $x != 3;
+print "ok 9\n";
+$x =~ tr/A/B/;
+if (ord("\t") == 9) { # ASCII
+    print "not " if $x ne 256.193.258 or length $x != 3;
+}
+else {
+    print "not " if $x ne 256.194.258 or length $x != 3;
+}
+print "ok 10\n";
 
 {
 if (ord("\t") == 9) { # ASCII
     use utf8;
 }
-
-# 9 - changing UTF8 characters in a UTF8 string, same length.
+# 11 - changing UTF8 characters in a UTF8 string, same length.
 $l = chr(300); $r = chr(400);
 $x = 200.300.400;
 $x =~ tr/\x{12c}/\x{190}/;
 printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
-print "ok 9\n";
+print "ok 11\n";
 
-# 10 - changing UTF8 characters in UTF8 string, more bytes.
+# 12 - changing UTF8 characters in UTF8 string, more bytes.
 $x = 200.300.400;
 $x =~ tr/\x{12c}/\x{be8}/;
 printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
-print "ok 10\n";
+print "ok 12\n";
 
-# 11 - introducing UTF8 characters to non-UTF8 string.
+# 13 - introducing UTF8 characters to non-UTF8 string.
 $x = 100.125.60;
 $x =~ tr/\x{64}/\x{190}/;
 printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
-print "ok 11\n";
+print "ok 13\n";
 
-# 12 - removing UTF8 characters from UTF8 string
+# 14 - removing UTF8 characters from UTF8 string
 $x = 400.125.60;
 $x =~ tr/\x{190}/\x{64}/;
 printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
-print "ok 12\n";
+print "ok 14\n";
 
-# 13 - counting UTF8 chars in UTF8 string
+# 15 - counting UTF8 chars in UTF8 string
 $x = 400.125.60.400;
 $y = $x =~ tr/\x{190}/\x{190}/;
 print "not " if $y != 2;
-print "ok 13\n";
+print "ok 15\n";
 
-# 14 - counting non-UTF8 chars in UTF8 string
+# 16 - counting non-UTF8 chars in UTF8 string
 $x = 60.400.125.60.400;
 $y = $x =~ tr/\x{3c}/\x{3c}/;
 print "not " if $y != 2;
-print "ok 14\n";
+print "ok 16\n";
 
-# 15 - counting UTF8 chars in non-UTF8 string
+# 17 - counting UTF8 chars in non-UTF8 string
 $x = 200.125.60;
 $y = $x =~ tr/\x{190}/\x{190}/;
 print "not " if $y != 0;
-print "ok 15\n";
+print "ok 17\n";
 }
 
-# 16: test cannot update if read-only
+# 18: test brokenness with tr/a-z-9//;
+$_ = "abcdefghijklmnopqrstuvwxyz";
+eval "tr/a-z-9/ /";
+print (($@ =~ /^Ambiguous range in transliteration operator/) 
+       ? '' : 'not ', "ok 18\n");
+
+# 19-21: Make sure leading and trailing hyphens still work
+$_ = "car-rot9";
+tr/-a-m/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
+
+$_ = "car-rot9";
+tr/a-m-/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
+
+$_ = "car-rot9";
+tr/-a-m-/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
+
+$_ = "abcdefghijklmnop";
+tr/ae-hn/./;
+print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
+
+$_ = "abcdefghijklmnop";
+tr/a-cf-kn-p/./;
+print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
+
+$_ = "abcdefghijklmnop";
+tr/a-ceg-ikm-o/./;
+print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
+
+# 25: Test reversed range check
+# 20000705 MJD
+eval "tr/m-d/ /";
+print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/) 
+       ? '' : 'not ', "ok 25\n");
+
+# 26: test cannot update if read-only
 eval '$1 =~ tr/x/y/';
 print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
-       "ok 16\n");
+       "ok 26\n");
 
-# 17: test can count read-only
+# 27: test can count read-only
 'abcdef' =~ /(bcd)/;
-print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 17\n");
+print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
 
-# 18: test lhs OK if not updating
-print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 18\n");
+# 28: test lhs OK if not updating
+print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
 
-# 19: test lhs bad if updating
+# 29: test lhs bad if updating
 eval '"123" =~ tr/1/1/';
 print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
-       ? '' : 'not ', "ok 19\n");
+       ? '' : 'not ', "ok 29\n");
 
index e0ab63e..f5d4c52 100644 (file)
@@ -24,7 +24,7 @@ if ($^O eq 'VMS') {
 }
 print "### searching $lib_dir\n";
 my %pods = pod_find("$lib_dir");
-my $result = join(',', sort values %pods);
+my $result = join("\n### ", sort values %pods);
 print "### found $result\n";
 my $compare = join(',', qw(
     Pod::Checker
@@ -39,7 +39,10 @@ my $compare = join(',', qw(
 if ($^O eq 'VMS') {
     $compare = lc($compare);
     $result = join(',', sort grep(/pod::/, values %pods));
-    $result =~ s/$Qlib_dir/pod::/g;
+    my $undollared = $Qlib_dir;
+    $undollared =~ s/\$/\\\$/g;
+    $undollared =~ s/\-/\\\-/g;
+    $result =~ s/$undollared/pod::/g;
     my $count = 0;
     my @result = split(/,/,$result);
     my @compare = split(/,/,$compare);
index 91a20ee..8cfdbb9 100644 (file)
@@ -42,8 +42,11 @@ BEGIN {
 sub catfile(@) { File::Spec->catfile(@_); }
 
 my $INSTDIR = abs_path(dirname $0);
-$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS';
-$INSTDIR =~ s#/$## if $^O eq 'VMS';
+if ($^O eq 'VMS') { # clean up directory spec
+    $INSTDIR = VMS::Filespec::unixpath($INSTDIR);
+    $INSTDIR =~ s#/$##;
+    $INSTDIR =~ s#/000000/#/#;
+}
 $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod');
 $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't');
 my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'),
@@ -51,6 +54,7 @@ my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'),
                    catfile($INSTDIR, 'pod'),
                    catfile($INSTDIR, 't', 'pod')
                  );
+print "PODINCDIRS = ",join(', ',@PODINCDIRS),"\n";
 
 ## Find the path to the file to =include
 sub findinclude {
index aa6f3c1..a3007ef 100755 (executable)
@@ -939,7 +939,7 @@ unless ($aaa) {
 {
     # check the Odd number of arguments for overload::constant warning
     my $a = "" ;
-    local $SIG{__WARN__} = sub {$a = @_[0]} ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
     $x = eval ' overload::constant "integer" ; ' ;
     test($a eq "") ; # 210
     use warnings 'overload' ;
@@ -950,7 +950,7 @@ unless ($aaa) {
 {
     # check the `$_[0]' is not an overloadable type warning
     my $a = "" ;
-    local $SIG{__WARN__} = sub {$a = @_[0]} ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
     $x = eval ' overload::constant "fred" => sub {} ; ' ;
     test($a eq "") ; # 212
     use warnings 'overload' ;
@@ -961,7 +961,7 @@ unless ($aaa) {
 {
     # check the `$_[1]' is not a code reference warning
     my $a = "" ;
-    local $SIG{__WARN__} = sub {$a = @_[0]} ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
     $x = eval ' overload::constant "integer" => 1; ' ;
     test($a eq "") ; # 214
     use warnings 'overload' ;
index 2b208cc..7224a74 100755 (executable)
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..75\n";
+print "1..103\n";
 
 my $test = 1;
 
@@ -324,14 +324,18 @@ sub nok_bytes {
 }
 
 {
-  my($a,$b);
-  { use bytes; $a = "\xc3\xa4"; }  
-  { use utf8;  $b = "\xe4"; }
-  { use bytes; ok_bytes $a, $b; $test++; } # 69
-  { use utf8;  nok      $a, $b; $test++; } # 70
+    # bug id 20001009.001
+
+    my($a,$b);
+    { use bytes; $a = "\xc3\xa4"; }  
+    { use utf8;  $b = "\xe4"; }
+    { use bytes; ok_bytes $a, $b; $test++; } # 69
+    { use utf8;  nok      $a, $b; $test++; } # 70
 }
 
 {
+    # bug id 20001008.001
+
     my @x = ("stra\337e 138","stra\337e 138");
     for (@x) {
        s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
@@ -346,6 +350,8 @@ sub nok_bytes {
 }
 
 {
+    # bug id 20000819.004 
+
     $_ = $dx = "\x{10f2}";
     s/($dx)/$dx$1/;
     {
@@ -374,3 +380,182 @@ sub nok_bytes {
        $test++;
     }
 }
+
+{
+    # bug id 20000323.056
+
+    use utf8;
+
+    print "not " unless "\x{41}" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x41" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{c8}" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\xc8" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{221b}" eq v8731;
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000427.003 
+
+    use utf8;
+    use warnings;
+    use strict;
+
+    my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";
+
+    my @charlist = split //, $sushi;
+    my $r = '';
+    foreach my $ch (@charlist) {
+       $r = $r . " " . sprintf "U+%04X", ord($ch);
+    }
+
+    print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000901.092
+    # test that undef left and right of utf8 results in a valid string
+
+    my $a;
+    $a .= "\x{1ff}";
+    print "not " unless $a eq "\x{1ff}";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000426.003
+
+    use utf8;
+
+    my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
+
+    my ($a, $b, $c) = split(/\x40/, $s);
+    print "not "
+       unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a;
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x{100}/, $s);
+    print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
+    print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x40\x{80}/, $s);
+    print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
+    print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000730.004
+
+    use utf8;
+
+    my $smiley = "\x{263a}";
+
+    for my $s ("\x{263a}",                     #  1
+              $smiley,                        #  2
+               
+              "" . $smiley,                   #  3
+              "" . "\x{263a}",                #  4
+
+              $smiley    . "",                #  5
+              "\x{263a}" . "",                #  6
+              ) {
+       my $length_chars = length($s);
+       my $length_bytes;
+       { use bytes; $length_bytes = length($s) }
+       my @regex_chars = $s =~ m/(.)/g;
+       my $regex_chars = @regex_chars;
+       my @split_chars = split //, $s;
+       my $split_chars = @split_chars;
+       print "not "
+           unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+                  "1/1/1/3";
+       print "ok $test\n";
+       $test++;
+    }
+
+    for my $s ("\x{263a}" . "\x{263a}",        #  7
+              $smiley    . $smiley,           #  8
+
+              "\x{263a}\x{263a}",             #  9
+              "$smiley$smiley",               # 10
+              
+              "\x{263a}" x 2,                 # 11
+              $smiley    x 2,                 # 12
+              ) {
+       my $length_chars = length($s);
+       my $length_bytes;
+       { use bytes; $length_bytes = length($s) }
+       my @regex_chars = $s =~ m/(.)/g;
+       my $regex_chars = @regex_chars;
+       my @split_chars = split //, $s;
+       my $split_chars = @split_chars;
+       print "not "
+           unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+                  "2/2/2/6";
+       print "ok $test\n";
+       $test++;
+    }
+}
+
+{
+    # ID 20001020.006
+
+    "x" =~ /(.)/; # unset $2
+
+    # Without the fix this will croak:
+    # Modification of a read-only value attempted at ...
+    "$2\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$2";
+
+    print "ok $test\n";
+    $test++;
+
+    *pi = \undef;
+    # This bug existed earlier than the $2 bug, but is fixed with the same
+    # patch. Without the fix this will also croak:
+    # Modification of a read-only value attempted at ...
+    "$pi\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$pi";
+
+    print "ok $test\n";
+    $test++;
+}
index 3c3cc60..4268205 100644 (file)
@@ -33,6 +33,9 @@
   readline() on closed filehandle %s           [Perl_do_readline]
     close STDIN ; $a = <STDIN>;
 
+  readline() on closed filehandle %s           [Perl_do_readline]
+    readline(NONESUCH);
+
   glob failed (child exited with status %d%s)  [Perl_do_readline] <<TODO
 
   Deep recursion on subroutine \"%s\"          [Perl_sub_crush_depth]
diff --git a/toke.c b/toke.c
index 644bc05..1728a7d 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -80,15 +80,19 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
 #endif
 
 #ifdef USE_PURE_BISON
-YYSTYPE* yylval_pointer = NULL;
-int* yychar_pointer = NULL;
+#ifndef YYMAXLEVEL
+#define YYMAXLEVEL 100
+#endif
+YYSTYPE* yylval_pointer[YYMAXLEVEL];
+int* yychar_pointer[YYMAXLEVEL];
+int yyactlevel = 0;
 #  undef yylval
 #  undef yychar
-#  define yylval (*yylval_pointer)
-#  define yychar (*yychar_pointer)
-#  define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
-#  undef yylex
-#  define yylex()      Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
+#  define yylval (*yylval_pointer[yyactlevel])
+#  define yychar (*yychar_pointer[yyactlevel])
+#  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
+#  undef yylex 
+#  define yylex()      Perl_yylex(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
 #endif
 
 #include "keywords.h"
@@ -844,7 +848,7 @@ S_force_version(pTHX_ char *s)
         for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
            SV *ver;
-            s = scan_num(s);
+            s = scan_num(s, &yylval);
             version = yylval.opval;
            ver = cSVOPx(version)->op_sv;
            if (SvPOK(ver) && !SvNIOK(ver)) {
@@ -2052,6 +2056,29 @@ Perl_yylex(pTHX)
 #endif
 {
     dTHR;
+    int r;
+
+#ifdef USE_PURE_BISON
+    yylval_pointer[yyactlevel] = lvalp;
+    yychar_pointer[yyactlevel] = lcharp;
+    yyactlevel++;
+    if (yyactlevel >= YYMAXLEVEL)
+       Perl_croak(aTHX_ "panic: YYMAXLEVEL");
+#endif
+
+    r = S_syylex(aTHX);
+
+#ifdef USE_PURE_BISON
+    yyactlevel--;
+#endif
+
+    return r;
+}
+
+STATIC int
+S_syylex(pTHX) /* need to be separate from yylex for reentrancy */
+{
+    dTHR;
     register char *s;
     register char *d;
     register I32 tmp;
@@ -2059,11 +2086,6 @@ Perl_yylex(pTHX)
     GV *gv = Nullgv;
     GV **gvp = 0;
 
-#ifdef USE_PURE_BISON
-    yylval_pointer = lvalp;
-    yychar_pointer = lcharp;
-#endif
-
     /* check if there's an identifier for us to look at */
     if (PL_pending_ident) {
         /* pit holds the identifier we read and pending_ident is reset */
@@ -3506,7 +3528,7 @@ Perl_yylex(pTHX)
        /* FALL THROUGH */
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
-       s = scan_num(s);
+       s = scan_num(s, &yylval);
        if (PL_expect == XOPERATOR)
            no_op("Number",s);
        TERM(THING);
@@ -3576,7 +3598,7 @@ Perl_yylex(pTHX)
            while (isDIGIT(*start) || *start == '_')
                start++;
            if (*start == '.' && isDIGIT(start[1])) {
-               s = scan_num(s);
+               s = scan_num(s, &yylval);
                TERM(THING);
            }
            /* avoid v123abc() or $h{v1}, allow C<print v10;> */
@@ -3587,7 +3609,7 @@ Perl_yylex(pTHX)
                gv = gv_fetchpv(s, FALSE, SVt_PVCV);
                *start = c;
                if (!gv) {
-                   s = scan_num(s);
+                   s = scan_num(s, &yylval);
                    TERM(THING);
                }
            }
@@ -6712,7 +6734,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 */
   
 char *
-Perl_scan_num(pTHX_ char *start)
+Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 {
     register char *s = start;          /* current position in buffer */
     register char *d;                  /* destination in temp buffer */
@@ -7125,9 +7147,9 @@ vstring:
     /* make the op for the constant and return */
 
     if (sv)
-       yylval.opval = newSVOP(OP_CONST, 0, sv);
+       lvalp->opval = newSVOP(OP_CONST, 0, sv);
     else
-       yylval.opval = Nullop;
+       lvalp->opval = Nullop;
 
     return s;
 }
diff --git a/utf8.c b/utf8.c
index 57f744f..ee30e23 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -116,13 +116,7 @@ Perl_is_utf8_char(pTHX_ U8 *s)
     if (!(u & 0x40))
        return 0;
 
-    if      (!(u & 0x20))      { len = 2; }
-    else if (!(u & 0x10))      { len = 3; }
-    else if (!(u & 0x08))      { len = 4; }
-    else if (!(u & 0x04))      { len = 5; }
-    else if (!(u & 0x02))      { len = 6; }
-    else if (!(u & 0x01))      { len = 7; }
-    else                       { len = 13; } /* whoa! */
+    len = UTF8SKIP(s);
 
     slen = len - 1;
     s++;
diff --git a/utf8.h b/utf8.h
index 32173ea..7407335 100644 (file)
--- a/utf8.h
+++ b/utf8.h
@@ -35,6 +35,24 @@ END_EXTERN_C
 
 #define UTF8SKIP(s) PL_utf8skip[*(U8*)s]
 
+#ifdef HAS_QUAD
+#define UTF8LEN(uv) ( (uv) < 0x80           ? 1 : \
+                     (uv) < 0x800          ? 2 : \
+                     (uv) < 0x10000        ? 3 : \
+                     (uv) < 0x200000       ? 4 : \
+                     (uv) < 0x4000000      ? 5 : \
+                     (uv) < 0x80000000     ? 6 : \
+                      (uv) < 0x1000000000LL ? 7 : 13 ) 
+#else
+/* No, I'm not even going to *TRY* putting #ifdef inside a #define */
+#define UTF8LEN(uv) ( (uv) < 0x80           ? 1 : \
+                     (uv) < 0x800          ? 2 : \
+                     (uv) < 0x10000        ? 3 : \
+                     (uv) < 0x200000       ? 4 : \
+                     (uv) < 0x4000000      ? 5 : \
+                     (uv) < 0x80000000     ? 6 : 7 )
+#endif
+
 /*
  * Note: we try to be careful never to call the isXXX_utf8() functions
  * unless we're pretty sure we've seen the beginning of a UTF-8 character
index e1dd783..313be20 100644 (file)
@@ -409,7 +409,11 @@ sub page {
     }
     else {
        foreach my $pager (@pagers) {
+          if ($Is_VMS) {
+           last if system("$pager $tmp") == 0; # quoting prevents logical expansion
+          } else {
            last if system("$pager \"$tmp\"") == 0;
+          }
        }
     }
 }
index b51f2c9..446b078 100644 (file)
@@ -134,7 +134,7 @@ This package C<ISA> IO::File, so that you can call IO::File
 methods on the handles returned by C<vmsopen> and C<vmssysopen>.
 The IO::File package is not initialized, however, until you
 actually call a method that VMS::Stdio doesn't provide.  This
-is doen to save startup time for users who don't wish to use
+is done to save startup time for users who don't wish to use
 the IO::File methods.
 
 B<Note:>  In order to conform to naming conventions for Perl
@@ -201,7 +201,7 @@ true value if successful, and C<undef> if it fails.
 This function sets the default device and directory for the process.
 It is identical to the built-in chdir() operator, except that the change
 persists after Perl exits.  It returns a true value on success, and
-C<undef> if it encounters and error.
+C<undef> if it encounters an error.
 
 =item sync
 
index a109f7b..6c81903 100644 (file)
@@ -68,16 +68,17 @@ if ($docc) {
   elsif (-f '[-]perl.h') { $dir = '[-]'; }
   else { die "$0: Can't find perl.h\n"; }
 
-  # Go see if debugging is enabled in config.h
-  $config = $dir . "config.h";
+  # Go see what is enabled in config.sh
+  $config = $dir . "config.sh";
   open CONFIG, "< $config";
   while(<CONFIG>) {
-    $debugging_enabled++ if /define\s+DEBUGGING/;
-    $use_mymalloc++ if /define\s+MYMALLOC/;
-    $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/;
-    $use_threads++ if /define\s+USE_THREADS/;
-    $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/;
+    $use_threads++ if /usethreads='define'/;
+    $use_mymalloc++ if /usemymalloc='Y'/;
+    $care_about_case++ if /d_vms_case_sensitive_symbols='define'/;
+    $debugging_enabled++ if /usedebugging_perl='Y'/;
+    $hide_mymalloc++ if /embedmymalloc='Y'/;
   }
+  close CONFIG;
   
   # put quotes back onto defines - they were removed by DCL on the way in
   if (($prefix,$defines,$suffix) =
@@ -328,6 +329,7 @@ if ($ENV{PERLSHR_USE_GSMATCH}) {
     # number in the top four bits and use the bottom four for build options
     # that'll cause incompatibilities
     ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
+    $ver += 0; $sub += 0;
     $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
                                                  # dev, but be more forgiving
                                                  # for releases
index afc1e57..522904d 100644 (file)
@@ -112,7 +112,7 @@ use Config;
 @libexcl=('db-btree.t','db-hash.t','db-recno.t',
           'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
           'io_sock.t', 'io_unix.t',
-          'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t');
+          'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
 
 # Note: POSIX is not part of basic build, but can be built
 # separately if you're using DECC
index 9454c79..985e6ea 100644 (file)
  */
 /*#define HAS_GETPGID          /**/
 
-/* HAS_GETPGRP:
- *     This symbol, if defined, indicates that the getpgrp routine is
- *     available to get the current process group.
- */
-/* USE_BSD_GETPGRP:
- *     This symbol, if defined, indicates that getpgrp needs one
- *     arguments whereas USG one needs none.
- */
-#define HAS_GETPGRP            /**/
-/*#define USE_BSD_GETPGRP      /**/
-
 /* HAS_GETPGRP2:
  *     This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
  *     routine is available to get the current process group.
  */
 /*#define HAS_SETPGID  /**/
 
-/* HAS_SETPGRP:
- *     This symbol, if defined, indicates that the setpgrp routine is
- *     available to set the current process group.
- */
-/* USE_BSD_SETPGRP:
- *     This symbol, if defined, indicates that setpgrp needs two
- *     arguments whereas USG one needs none.  See also HAS_SETPGID
- *     for a POSIX interface.
- */
-/*#define HAS_SETPGRP          /**/
-/*#define USE_BSD_SETPGRP      /**/
-
 /* HAS_SETPGRP2:
  *     This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
  *     routine is available to set the current process group.
 #define PERL_XS_APIVERSION "5.00563"
 #define PERL_PM_APIVERSION "5.005"
 
+/* HAS_GETPGRP:
+ *     This symbol, if defined, indicates that the getpgrp routine is
+ *     available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ *     This symbol, if defined, indicates that getpgrp needs one
+ *     arguments whereas USG one needs none.
+ */
+#define HAS_GETPGRP            /**/
+/*#define USE_BSD_GETPGRP      /**/
+
+/* HAS_SETPGRP:
+ *     This symbol, if defined, indicates that the setpgrp routine is
+ *     available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ *     This symbol, if defined, indicates that setpgrp needs two
+ *     arguments whereas USG one needs none.  See also HAS_SETPGID
+ *     for a POSIX interface.
+ */
+/*#define HAS_SETPGRP          /**/
+/*#define USE_BSD_SETPGRP      /**/
+
 #endif
index 7c70ab3..a209e6d 100755 (executable)
@@ -244,17 +244,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_getpgid HAS_GETPGID                /**/
 
-/* HAS_GETPGRP:
- *     This symbol, if defined, indicates that the getpgrp routine is
- *     available to get the current process group.
- */
-/* USE_BSD_GETPGRP:
- *     This symbol, if defined, indicates that getpgrp needs one
- *     arguments whereas USG one needs none.
- */
-#$d_getpgrp HAS_GETPGRP                /**/
-#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
-
 /* HAS_GETPGRP2:
  *     This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
  *     routine is available to get the current process group.
@@ -509,18 +498,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_setpgid HAS_SETPGID        /**/
 
-/* HAS_SETPGRP:
- *     This symbol, if defined, indicates that the setpgrp routine is
- *     available to set the current process group.
- */
-/* USE_BSD_SETPGRP:
- *     This symbol, if defined, indicates that setpgrp needs two
- *     arguments whereas USG one needs none.  See also HAS_SETPGID
- *     for a POSIX interface.
- */
-#$d_setpgrp HAS_SETPGRP                /**/
-#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
-
 /* HAS_SETPGRP2:
  *     This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
  *     routine is available to set the current process group.
@@ -3193,5 +3170,28 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #define PERL_XS_APIVERSION "$xs_apiversion"
 #define PERL_PM_APIVERSION "$pm_apiversion"
 
+/* HAS_GETPGRP:
+ *     This symbol, if defined, indicates that the getpgrp routine is
+ *     available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ *     This symbol, if defined, indicates that getpgrp needs one
+ *     arguments whereas USG one needs none.
+ */
+#$d_getpgrp HAS_GETPGRP                /**/
+#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
+
+/* HAS_SETPGRP:
+ *     This symbol, if defined, indicates that the setpgrp routine is
+ *     available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ *     This symbol, if defined, indicates that setpgrp needs two
+ *     arguments whereas USG one needs none.  See also HAS_SETPGID
+ *     for a POSIX interface.
+ */
+#$d_setpgrp HAS_SETPGRP                /**/
+#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+
 #endif
 !GROK!THIS!
index 5ee4027..097d429 100644 (file)
@@ -564,12 +564,27 @@ make_set_make='#'
 mallocobj='malloc.o'
 mallocsrc='malloc.c'
 malloctype='void *'
+man1='man1'
 man1dir='~INST_TOP~~INST_VER~\man\man1'
 man1direxp='~INST_TOP~~INST_VER~\man\man1'
 man1ext='1'
+man2='man2'
+man2ext='2'
+man3='man3'
 man3dir='~INST_TOP~~INST_VER~\man\man3'
 man3direxp='~INST_TOP~~INST_VER~\man\man3'
 man3ext='3'
+man4='man4'
+man4ext='4'
+man5='man5'
+man5ext='5'
+man6='man6'
+man6ext='6'
+man7='man7'
+man7ext='7'
+man8='man8'
+man8ext='8'
+mandirstyle='bsd'
 mips_type=''
 mkdir='mkdir'
 mmaptype='void *'
index b27c8e5..9251b24 100644 (file)
@@ -564,12 +564,27 @@ make_set_make='#'
 mallocobj='malloc.o'
 mallocsrc='malloc.c'
 malloctype='void *'
+man1='man1'
 man1dir='~INST_TOP~~INST_VER~\man\man1'
 man1direxp='~INST_TOP~~INST_VER~\man\man1'
 man1ext='1'
+man2='man2'
+man2ext='2'
+man3='man3'
 man3dir='~INST_TOP~~INST_VER~\man\man3'
 man3direxp='~INST_TOP~~INST_VER~\man\man3'
 man3ext='3'
+man4='man4'
+man4ext='4'
+man5='man5'
+man5ext='5'
+man6='man6'
+man6ext='6'
+man7='man7'
+man7ext='7'
+man8='man8'
+man8ext='8'
+mandirstyle='bsd'
 mips_type=''
 mkdir='mkdir'
 mmaptype='void *'
index 59295f5..61558e5 100644 (file)
@@ -564,12 +564,27 @@ make_set_make='#'
 mallocobj='malloc.o'
 mallocsrc='malloc.c'
 malloctype='void *'
+man1='man1'
 man1dir='~INST_TOP~~INST_VER~\man\man1'
 man1direxp='~INST_TOP~~INST_VER~\man\man1'
 man1ext='1'
+man2='man2'
+man2ext='2'
+man3='man3'
 man3dir='~INST_TOP~~INST_VER~\man\man3'
 man3direxp='~INST_TOP~~INST_VER~\man\man3'
 man3ext='3'
+man4='man4'
+man4ext='4'
+man5='man5'
+man5ext='5'
+man6='man6'
+man6ext='6'
+man7='man7'
+man7ext='7'
+man8='man8'
+man8ext='8'
+mandirstyle='bsd'
 mips_type=''
 mkdir='mkdir'
 mmaptype='void *'
index 3d1ddd6..7807495 100644 (file)
@@ -940,7 +940,7 @@ PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
 int
 PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
 {
-    return fstat(handle, buffer);
+    return win32_fstat(handle, buffer);
 }
 
 int
index 0e4c2e0..2b31878 100644 (file)
@@ -2312,7 +2312,25 @@ win32_abort(void)
 DllExport int
 win32_fstat(int fd,struct stat *sbufptr)
 {
+#ifdef __BORLANDC__
+    /* A file designated by filehandle is not shown as accessible
+     * for write operations, probably because it is opened for reading.
+     * --Vadim Konovalov
+     */ 
+    int rc = fstat(fd,sbufptr);
+    BY_HANDLE_FILE_INFORMATION bhfi;
+    if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
+        sbufptr->st_mode &= 0xFE00;
+        if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
+            sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
+        else
+            sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
+              + ((S_IREAD|S_IWRITE) >> 6));
+    }
+    return rc;
+#else
     return fstat(fd,sbufptr);
+#endif
 }
 
 DllExport int