This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SYN SYN
authorCharles Bailey <bailey@newman.upenn.edu>
Thu, 8 Feb 2001 20:49:00 +0000 (20:49 +0000)
committerbailey <bailey@newman.upenn.edu>
Thu, 8 Feb 2001 20:49:00 +0000 (20:49 +0000)
p4raw-id: //depot/vmsperl@8718

111 files changed:
Configure
MANIFEST
Makefile.SH
Porting/makerel
README.os390
README.solaris
doio.c
dump.c
embed.h
embed.pl
embedvar.h
ext/Errno/Errno_pm.PL
ext/POSIX/POSIX.xs
global.sym
gv.c
hints/hpux.sh
hints/os390.sh
hints/solaris_2.sh
hv.c
installperl
intrpvar.h
lib/ExtUtils/MANIFEST.SKIP
lib/ExtUtils/Manifest.pm
lib/Getopt/Long.pm
lib/Math/BigFloat.pm
lib/Math/BigInt.pm
lib/Test/Harness.pm
lib/overload.pm
lib/unicode/Is/DCinital.pl [deleted file]
mg.c
objXSUB.h
op.c
patchlevel.h
perl.c
perl.h
perlapi.c
perlio.c
pod/perlapi.pod
pod/perlapio.pod
pod/perlboot.pod
pod/perldiag.pod
pod/perlfaq2.pod
pod/perlfaq8.pod
pod/perlfunc.pod
pod/perlguts.pod
pod/perlintern.pod
pod/perliol.pod [new file with mode: 0644]
pod/perlmodlib.PL
pod/perlobj.pod
pod/perlop.pod
pod/perlport.pod
pod/perlre.pod
pod/perltoot.pod
pod/perltootc.pod
pod/perlutil.pod
pp.c
pp.h
pp_hot.c
proto.h
regcomp.c
regexec.c
sv.c
t/TEST
t/base/term.t
t/io/tell.t
t/io/utf8.t
t/lib/1_compile.t
t/lib/b.t
t/lib/bigfltpm.t
t/lib/bigintpm.t
t/lib/charnames.t
t/lib/dprof/V.pm
t/lib/peek.t
t/lib/sample-tests/bailout [new file with mode: 0644]
t/lib/sample-tests/combined [new file with mode: 0644]
t/lib/sample-tests/descriptive [new file with mode: 0644]
t/lib/sample-tests/duplicates [new file with mode: 0644]
t/lib/sample-tests/header_at_end [new file with mode: 0644]
t/lib/sample-tests/no_nums [new file with mode: 0644]
t/lib/sample-tests/simple [new file with mode: 0644]
t/lib/sample-tests/simple_fail [new file with mode: 0644]
t/lib/sample-tests/skip [new file with mode: 0644]
t/lib/sample-tests/skip_all [new file with mode: 0644]
t/lib/sample-tests/todo [new file with mode: 0644]
t/lib/sample-tests/with_comments [new file with mode: 0644]
t/lib/st-06compat.t
t/lib/test-harness.t [new file with mode: 0644]
t/op/arith.t
t/op/each.t
t/op/flip.t
t/op/tr.t
t/pragma/overload.t
t/pragma/sub_lval.t
t/pragma/utf8.t
thrdvar.h
thread.h
toke.c
utf8.c
utf8.h
util.c
utils/h2xs.PL
utils/perldoc.PL
vms/test.com
win32/Makefile
win32/bin/search.pl
win32/config.bc
win32/config.gc
win32/config.vc
win32/config_H.bc
win32/makefile.mk
win32/vdir.h

index 59c448a..278cc23 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 Tue Jan 23 16:39:46 EET 2001 [metaconfig 3.0 PL70]
+# Generated on Sat Feb  3 18:24:21 EET 2001 [metaconfig 3.0 PL70]
 # (with additional metaconfig patches by perlbug@perl.org)
 
 cat >c1$$ <<EOF
@@ -1807,7 +1807,8 @@ EOH
        dflt='n'
        . ./myread
        case "$ans" in
-       [yY]) echo >&4 "Okay, continuing." ;;
+       [yY]) echo >&4 "Okay, continuing."
+             usedevel="$define" ;;
        *) echo >&4 "Okay, bye."
           exit 1
           ;;
@@ -1816,6 +1817,16 @@ EOH
     esac
     ;;
 esac
+case "$usedevel" in
+$define|true|[yY]*)
+       case "$versiononly" in
+       '') versiononly="$define" ;;
+       esac
+       case "$installusrbinperl" in
+       '') installusrbinperl="$undef" ;;
+       esac
+       ;;
+esac
 
 : general instructions
 needman=true
@@ -8798,13 +8809,11 @@ esac
 
 : check for non-blocking I/O stuff
 case "$h_sysfile" in
-true) echo "#include <sys/file.h>" > head.c;;
-*)
-       case "$h_fcntl" in
-       true) echo "#include <fcntl.h>" > head.c;;
-       *) echo "#include <sys/fcntl.h>" > head.c;;
-       esac
-       ;;
+true) echo "#include <sys/file.h>" >  head.c;;
+esac
+case "$h_fcntl" in
+true) echo "#include <fcntl.h>"    >> head.c;;
+*) echo "#include <sys/fcntl.h>"   >> head.c;;
 esac
 echo " "
 echo "Figuring out the flag used by open() for non-blocking I/O..." >&4
index 612b610..72b1edd 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1222,7 +1222,7 @@ pod/perl5004delta.pod     Changes from 5.003 to 5.004
 pod/perl5005delta.pod  Changes from 5.004 to 5.005
 pod/perl56delta.pod    Changes from 5.005 to 5.6
 pod/perlapi.pod         Perl API documentation (autogenerated)
-pod/perlapio.pod       IO API info
+pod/perlapio.pod       PerlIO IO API info
 pod/perlbook.pod       Perl book information
 pod/perlboot.pod       Beginner's Object-oriented Tutorial
 pod/perlbot.pod                Object-oriented Bag o' Tricks
@@ -1256,6 +1256,7 @@ pod/perlguts.pod  Internals info
 pod/perlhack.pod       Perl hackers guide
 pod/perlhist.pod       Perl history info
 pod/perlintern.pod      Perl internal function docs (autogenrated)
+pod/perliol.pod                Internals of PerlIO with layers.
 pod/perlipc.pod                IPC info
 pod/perllexwarn.pod    Lexical Warnings info
 pod/perllocale.pod     Locale support info
@@ -1476,6 +1477,18 @@ t/lib/ph.t               See if h2ph works
 t/lib/posix.t          See if POSIX works
 t/lib/safe1.t          See if Safe works
 t/lib/safe2.t          See if Safe works
+t/lib/sample-tests/bailout              Test data for Test::Harness
+t/lib/sample-tests/combined             Test data for Test::Harness
+t/lib/sample-tests/descriptive          Test data for Test::Harness
+t/lib/sample-tests/duplicates           Test data for Test::Harness
+t/lib/sample-tests/header_at_end        Test data for Test::Harness
+t/lib/sample-tests/no_nums              Test data for Test::Harness
+t/lib/sample-tests/simple               Test data for Test::Harness
+t/lib/sample-tests/simple_fail          Test data for Test::Harness
+t/lib/sample-tests/skip                 Test data for Test::Harness
+t/lib/sample-tests/skip_all             Test data for Test::Harness
+t/lib/sample-tests/todo                 Test data for Test::Harness
+t/lib/sample-tests/with_comments        Test data for Test::Harness
 t/lib/sdbm.t           See if SDBM_File works
 t/lib/searchdict.t     See if Search::Dict works
 t/lib/selectsaver.t    See if SelectSaver works
@@ -1501,6 +1514,7 @@ t/lib/st-utf8.t           See if Storable works
 t/lib/symbol.t         See if Symbol works
 t/lib/syslfs.t         See if large files work for sysio
 t/lib/syslog.t         See if Sys::Syslog works
+t/lib/test-harness.t    See if Test::Harness works
 t/lib/textfill.t       See if Text::Wrap::fill works
 t/lib/texttabs.t       See if Text::Tabs works
 t/lib/textwrap.t       See if Text::Wrap::wrap works
index e6a0ef4..81b0136 100644 (file)
@@ -78,6 +78,7 @@ true)
                linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl"
                ;;
        os390*)
+            shrpldflags='-W l,dll'
            linklibperl='libperl.x'
            DPERL_EXTERNAL_GLOB=''
            ;;
@@ -419,7 +420,7 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT)
        case "$useshrplib" in
        true)
                $spitshell >>Makefile <<'!NO!SUBS!'
-       $(LD) $(SHRPLDFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
+       $(LD) -o $@ $(SHRPLDFLAGS) perl$(OBJ_EXT) $(obj)
 !NO!SUBS!
                case "$osname" in
                aix)
@@ -484,16 +485,16 @@ miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT)
        $spitshell >>Makefile <<'!NO!SUBS!'
 
 perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
-       $(SHRPENV) $(LDLIBPTH) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+       $(SHRPENV) $(LDLIBPTH) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
-       $(SHRPENV) $(LDLIBPTH) purify $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+       $(SHRPENV) $(LDLIBPTH) purify $(CC) -o pureperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
-       $(SHRPENV) $(LDLIBPTH) purecov $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+       $(SHRPENV) $(LDLIBPTH) purecov $(CC) -o purecovperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
-       $(SHRPENV) $(LDLIBPTH) quantify $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+       $(SHRPENV) $(LDLIBPTH) quantify $(CC) -o quantperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 # This version, if specified in Configure, does ONLY those scripts which need
 # set-id emulation.  Suidperl must be setuid root.  It contains the "taint"
@@ -501,7 +502,7 @@ quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
 # has been invoked correctly.
 
 suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
-       $(SHRPENV) $(LDLIBPTH) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+       $(SHRPENV) $(LDLIBPTH) $(CC) -o suidperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 !NO!SUBS!
 
index 8341690..138fffa 100644 (file)
@@ -102,20 +102,31 @@ my @exe = qw(
 system("chmod +x @exe");
 
 my @writables = qw(
+    keywords.h
+    opcode.h
+    opnames.h
+    pp_proto.h
+    pp.sym
+    proto.h
     embed.h
     embedvar.h
-    ext/B/B/Asmdata.pm
-    ext/ByteLoader/byterun.c
-    ext/ByteLoader/byterun.h
     global.sym
-    keywords.h
-    lib/warnings.pm
+    pod/perlintern.pod
+    pod/perlapi.pod
     objXSUB.h
-    opcode.h
-    pp.sym
-    pp_proto.h
+    perlapi.h
+    perlapi.c
+    ext/ByteLoader/byterun.h
+    ext/ByteLoader/byterun.c
+    ext/B/B/Asmdata.pm
     regnodes.h
     warnings.h
+    lib/warnings.pm
+    vms/perly_c.vms
+    vms/perly_h.vms
+    win32/Makefile
+    win32/makefile.mk
+    win32/config_H.bc
     win32/config_H.bc
     win32/config_H.gc
     win32/config_H.vc
index 3507332..25041b9 100644 (file)
@@ -46,7 +46,7 @@ The IBM document that described such USS system setup issues was
 SC28-1890-07 "OS/390 UNIX System Services Planning", in particular
 Chapter 6 on customizing the OE shell.
 
-GNU make for OS/390, which is required for the build of perl (as well as
+GNU make for OS/390, which is recommended for the build of perl (as well as
 building CPAN modules and extensions), is available from:
 
   http://www.mks.com/s390/gnu/index.htm
@@ -58,6 +58,18 @@ from source to eliminate any such trouble.  You might also find GNU make
 (as well as Perl and Apache) in the red-piece/book "Open Source Software 
 for OS/390 UNIX", SG24-5944-00 from IBM.
 
+If instead of the recommended GNU make you would like to use the system 
+supplied make program then be sure to install the default rules file 
+properly via the shell command:
+
+    cp /samples/startup.mk /etc
+
+and be sure to also set the environment variable _C89_CCMODE=1 (exporting
+_C89_CCMODE=1 is also a good idea for users of GNU make).
+
+You might also want to have GNU groff for OS/390 installed before
+running the `make install` step for Perl.
+
 There is a syntax error in the /usr/include/sys/socket.h header file
 that IBM supplies with USS V2R7, V2R8, and possibly V2R9.  The problem with
 the header file is that near the definition of the SO_REUSEPORT constant
@@ -143,10 +155,13 @@ re extraction of the source tar ball.
 
 =item *
 
-This port doesn't support dynamic loading.  Although OS/390 has support 
-for DLLs via dllload(), there are some differences that cause problems 
-for Perl.  (We need a volunteer to write a ext/DynaLoader/dl_dllload.xs 
-file).
+This port will support dynamic loading, but it is not selected by
+default.  If you would like to experiment with dynamic loading then
+be sure to specify -Dusedl in the arguments to the Configure script.
+See the comments in hints/os390.sh for more information on dynamic loading.
+If you build with dynamic loading then you will need to add the
+$archlibexp/CORE directory to your LIBPATH environment variable in order
+for perl to work.  See the config.sh file for the value of $archlibexp.
 
 =item *
 
@@ -260,6 +275,12 @@ from an account with write access to the directory entry for /tmp.
 
 =back
 
+=head2 installation anomalies
+
+The installman script will try to run on OS/390.  There will be fewer errors
+if you have a roff utility installed.  You can obtain GNU groff from the 
+Redbook SG24-5944-00 ftp site.
+
 =head2 Usage Hints
 
 When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
@@ -321,8 +342,10 @@ Pure pure (that is non xs) modules may be installed via the usual:
     make test
     make install
 
-You can also build xs based extensions to Perl for OS/390 but will need 
-to follow the instructions in ExtUtils::MakeMaker for building 
+If you built perl with dynamic loading capability then that would also
+be the way to build xs based extensions.  However, if you built perl with
+the default static linking you can still build xs based extensions for OS/390 
+but you will need to follow the instructions in ExtUtils::MakeMaker for building 
 statically linked perl binaries.  In the simplest configurations building
 a static perl + xs extension boils down to:
 
@@ -337,12 +360,21 @@ In most cases people have reported better results with GNU make rather
 than the system's /bin/make program, whether for plain modules or for
 xs based extensions.
 
+If the make process encounters trouble with either compilation or
+linking then try setting the _C89_CCMODE to 1.  Assuming sh is your
+login shell then run:
+
+    export _C89_CCMODE=1
+
+If tcsh is your login shell then use the setenv command.
+
 =head1 AUTHORS
 
 David Fiander and Peter Prymmer with thanks to Dennis Longnecker
 and William Raffloer for valuable reports, LPAR and PTF feedback.
 Thanks to Mike MacIsaac and Egon Terwedow for SG24-5944-00.
 Thanks to Ignasi Roca for pointing out the floating point problems.
+Thanks to John Goodyear for dynamic loading help.
 
 =head1 SEE ALSO
 
@@ -387,5 +419,7 @@ Updated 12 November 2000 for the 5.7.1 release of Perl.
 
 Updated 15 January 2001 for the 5.7.1 release of Perl.
 
+Updated 24 January 2001 to mention dynamic loading.
+
 =cut
 
index 97e84a3..1a36a8a 100644 (file)
@@ -358,13 +358,6 @@ instead.
 All this should be handled automatically by the hints file, if
 requested.
 
-If you do want to be able to allocate more than 4GB memory inside
-perl, then you should use the Solaris malloc, since the perl
-malloc breaks when dealing with more than 2GB of memory.  You can do
-this with
-
-       sh Configure -Uusemymalloc
-
 =head3 Long Doubles.
 
 As of 5.6.0, long doubles are not working.
@@ -379,22 +372,22 @@ in -lrt.  The hints file should handle adding this automatically.
 
 =head2 Malloc Issues.
 
+Starting from Perl 5.7.1 Perl uses the Solaris malloc, since the perl
+malloc breaks when dealing with more than 2GB of memory, and the Solaris
+malloc also seems to be faster.
+
+If you for some reason (such as binary backward compatibility) really
+need to use perl's malloc, you can rebuild Perl from the sources
+and Configure the build with 
+
+       sh Configure -Dusemymalloc
+  
 You should not use perl's malloc if you are building with gcc.  There
 are reports of core dumps, especially in the PDL module.  The problem
 appears to go away under -DDEBUGGING, so it has been difficult to
 track down.  Sun's compiler appears to be ok with or without perl's
 malloc. [XXX further investigation is needed here.]
 
-You should also not use perl's malloc if you are building perl as
-an LP64 application, since perl's malloc has trouble allocating more
-than 2GB of memory.
-
-You can avoid perl's malloc by Configuring with
-
-       sh Configure -Uusemymalloc
-
-[XXX Update hints file.]
-
 =head1 MAKE PROBLEMS.
 
 =over 4
diff --git a/doio.c b/doio.c
index 6056ea7..a1d0e46 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1169,13 +1169,12 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        /* FALL THROUGH */
     default:
        if (PerlIO_isutf8(fp)) {
-           tmps = SvPVutf8(sv, len);
-       }
-       else {
-           if (DO_UTF8(sv))
-               sv_utf8_downgrade(sv, FALSE);
-           tmps = SvPV(sv, len);
+           if (!SvUTF8(sv))
+               sv_utf8_upgrade(sv = sv_mortalcopy(sv));
        }
+       else if (DO_UTF8(sv))
+           sv_utf8_downgrade((sv = sv_mortalcopy(sv)), FALSE);
+       tmps = SvPV(sv, len);
        break;
     }
     /* To detect whether the process is about to overstep its
diff --git a/dump.c b/dump.c
index 5bc7349..6805729 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -823,6 +823,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        if (CvCONST(sv))        sv_catpv(d, "CONST,");
        if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
        if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
+       if (CvLVALUE(sv))       sv_catpv(d, "LVALUE,");
+       if (CvMETHOD(sv))       sv_catpv(d, "METHOD,");
        break;
     case SVt_PVHV:
        if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
diff --git a/embed.h b/embed.h
index 790f43b..fe0b6b3 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define utf8_distance          Perl_utf8_distance
 #define utf8_hop               Perl_utf8_hop
 #define utf8_to_bytes          Perl_utf8_to_bytes
+#define bytes_from_utf8                Perl_bytes_from_utf8
 #define bytes_to_utf8          Perl_bytes_to_utf8
 #define utf8_to_uv_simple      Perl_utf8_to_uv_simple
 #define utf8_to_uv             Perl_utf8_to_uv
 #define filter_gets            S_filter_gets
 #define find_in_my_stash       S_find_in_my_stash
 #define new_constant           S_new_constant
+#define tokereport             S_tokereport
 #define ao                     S_ao
 #define depcom                 S_depcom
 #define incl_perldb            S_incl_perldb
 #define utf8_distance(a,b)     Perl_utf8_distance(aTHX_ a,b)
 #define utf8_hop(a,b)          Perl_utf8_hop(aTHX_ a,b)
 #define utf8_to_bytes(a,b)     Perl_utf8_to_bytes(aTHX_ a,b)
+#define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c)
 #define bytes_to_utf8(a,b)     Perl_bytes_to_utf8(aTHX_ a,b)
 #define utf8_to_uv_simple(a,b) Perl_utf8_to_uv_simple(aTHX_ a,b)
 #define utf8_to_uv(a,b,c,d)    Perl_utf8_to_uv(aTHX_ a,b,c,d)
 #define filter_gets(a,b,c)     S_filter_gets(aTHX_ a,b,c)
 #define find_in_my_stash(a,b)  S_find_in_my_stash(aTHX_ a,b)
 #define new_constant(a,b,c,d,e,f)      S_new_constant(aTHX_ a,b,c,d,e,f)
+#define tokereport(a,b,c)      S_tokereport(aTHX_ a,b,c)
 #define ao(a)                  S_ao(aTHX_ a)
 #define depcom()               S_depcom(aTHX)
 #define incl_perldb()          S_incl_perldb(aTHX)
 #define utf8_hop               Perl_utf8_hop
 #define Perl_utf8_to_bytes     CPerlObj::Perl_utf8_to_bytes
 #define utf8_to_bytes          Perl_utf8_to_bytes
+#define Perl_bytes_from_utf8   CPerlObj::Perl_bytes_from_utf8
+#define bytes_from_utf8                Perl_bytes_from_utf8
 #define Perl_bytes_to_utf8     CPerlObj::Perl_bytes_to_utf8
 #define bytes_to_utf8          Perl_bytes_to_utf8
 #define Perl_utf8_to_uv_simple CPerlObj::Perl_utf8_to_uv_simple
 #define find_in_my_stash       S_find_in_my_stash
 #define S_new_constant         CPerlObj::S_new_constant
 #define new_constant           S_new_constant
+#define S_tokereport           CPerlObj::S_tokereport
+#define tokereport             S_tokereport
 #define S_ao                   CPerlObj::S_ao
 #define ao                     S_ao
 #define S_depcom               CPerlObj::S_depcom
index e5ca87a..1b8b7b0 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -198,6 +198,7 @@ my @extvars = qw(sv_undef sv_yes sv_no na dowarn
                 diehook
                 dirty
                 perl_destruct_level
+                ppaddr
                 );
 
 sub readsyms (\%$) {
@@ -2085,6 +2086,7 @@ Adp       |STRLEN |utf8_length    |U8* s|U8 *e
 Apd    |IV     |utf8_distance  |U8 *a|U8 *b
 Apd    |U8*    |utf8_hop       |U8 *s|I32 off
 ApMd   |U8*    |utf8_to_bytes  |U8 *s|STRLEN *len
+ApMd   |U8*    |bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
 ApMd   |U8*    |bytes_to_utf8  |U8 *s|STRLEN *len
 Apd    |UV     |utf8_to_uv_simple|U8 *s|STRLEN* retlen
 Adp    |UV     |utf8_to_uv     |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags
@@ -2518,6 +2520,7 @@ s |char * |filter_gets    |SV *sv|PerlIO *fp|STRLEN append
 s      |HV *   |find_in_my_stash|char *pkgname|I32 len
 s      |SV*    |new_constant   |char *s|STRLEN len|const char *key|SV *sv \
                                |SV *pv|const char *type
+s      |void   |tokereport     |char *thing|char *s|I32 rv
 s      |int    |ao             |int toketype
 s      |void   |depcom
 s      |char*  |incl_perldb
index 205004c..8244ccc 100644 (file)
 #define no_modify              PL_no_modify
 #define perl_destruct_level    PL_perl_destruct_level
 #define perldb                 PL_perldb
+#define ppaddr                 PL_ppaddr
 #define rsfp                   PL_rsfp
 #define rsfp_filters           PL_rsfp_filters
 #define stack_base             PL_stack_base
index 3e34b90..dd16515 100644 (file)
@@ -83,6 +83,9 @@ sub get_files {
     } elsif ($^O eq 'vmesa') {
        # OS/390 C compiler doesn't generate #file or #line directives
        $file{'../../vmesa/errno.h'} = 1;
+    } elsif ($Config{archname} eq 'epoc') {
+       # Watch out for cross compiling for EPOC (usually done on linux)
+       $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1;
     } elsif ($^O eq 'linux') {
        # Some Linuxes have weird errno.hs which generate
        # no #file or #line directives
index 887fcbc..a81f044 100644 (file)
@@ -3417,9 +3417,8 @@ sigaction(sig, action, oldaction = 0)
                /* Set up any desired mask. */
                svp = hv_fetch(action, "MASK", 4, FALSE);
                if (svp && sv_isa(*svp, "POSIX::SigSet")) {
-                   unsigned long tmp;
-                   tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
-                   sigset = (sigset_t*) tmp;
+                   IV tmp = SvIV((SV*)SvRV(*svp));
+                   sigset =  INT2PTR(sigset_t*, tmp);
                    act.sa_mask = *sigset;
                }
                else
index 48128c9..dab2a7c 100644 (file)
@@ -470,6 +470,7 @@ Perl_utf8_length
 Perl_utf8_distance
 Perl_utf8_hop
 Perl_utf8_to_bytes
+Perl_bytes_from_utf8
 Perl_bytes_to_utf8
 Perl_utf8_to_uv_simple
 Perl_utf8_to_uv
diff --git a/gv.c b/gv.c
index ea96c6f..c73d503 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1411,6 +1411,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
             lr = 1;
           }
           break;
+        case int_amg:
         case iter_amg:                 /* XXXX Eventually should do to_gv. */
             /* FAIL safe */
             return NULL;       /* Delegate operation to standard mechanisms. */
index ca5c50b..ddcb62f 100644 (file)
@@ -348,9 +348,7 @@ EOM
             fi
 
             # HP-UX 10.X uses the old pthreads API
-            case "$d_oldpthreads" in
-            '') d_oldpthreads="$define" ;;
-            esac
+            d_oldpthreads="$define"
 
             # include libcma before all the others
             libswanted="cma $libswanted"
index ee75172..54787e8 100644 (file)
@@ -84,23 +84,37 @@ define)
     case "$useshrplib" in
     '') useshrplib='true' ;;
     esac
-    case "$dlext" in
-    '') dlext='dll' ;;
-    esac
     case "$dlsrc" in
     '') dlsrc='dl_dllload.xs' ;;
     esac
-    so='dll'
-    libperl='libperl.dll'
+    # For performance use 'so' at or beyond v2.8, 'dll' for 2.7 and prior versions
+    case "`uname -v`x`uname -r`" in
+    02x0[89].*|02x1[0-9].*|[0-9][3-9]x*) 
+        so='so'
+        case "$dlext" in
+        '') dlext='so' ;;
+        esac
+        ;;
+    *) 
+        so='dll'
+        case "$dlext" in
+        '') dlext='dll' ;;
+        esac
+        ;;
+    esac
+    libperl="libperl.$so"
     ccflags="$ccflags -D_SHR_ENVIRON -DPERL_EXTERNAL_GLOB -Wc,dll"
     cccdlflags='-c -Wc,dll,EXPORTALL'
     # You might add '-Wl,EDIT=NO' to get rid of the symbol
-    # information at the end of the executable.
-    #
-    # The following will need to be modified for the installed libperl.x
+    # information at the end of the executable (=> smaller binaries).
+    # Do so with -Dldflags='-Wl,EDIT=NO'.
+    case "$ldflags" in
+    '') ldflags='' ;;
+    esac
+    # The following will need to be modified for the installed libperl.x.
+    # The modification to Config.pm is done by the installperl script after the build and test.
     ccdlflags="-W l,dll `pwd`/libperl.x"
-    ldflags=''
-    lddlflags='-W l,dll'
+    lddlflags="-W l,dll `pwd`/libperl.x"
     ;;
 esac
 # even on static builds using LIBPATH should be OK.
@@ -140,7 +154,14 @@ esac
 # other things.  Unfortunately, cppflags occurs too late to be of 
 # value external to the script.  This may need to be revisited 
 # under a compiler other than c89.
+case "$usedl" in
+define)
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
+    ;;
+*)
 echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
+    ;;
+esac
 
 #
 # Note that Makefile.SH employs a bare yacc command to generate 
index 0bf5bab..86a375b 100644 (file)
@@ -1,5 +1,5 @@
 # hints/solaris_2.sh
-# Last modified: Tue Jan  2 10:16:35 2001
+# Last modified: Mon Jan 29 12:52:28 2001
 # Lupe Christoph <lupe@lupe-christoph.de>
 # Based on version by:
 # Andy Dougherty  <doughera@lafayette.edu>
 #  these ought to be harmless.  See below for more details.
 
 # See man vfork.
-usevfork=false
+usevfork=${usevfork:-false}
 
-d_suidsafe=define
+# Solaris has secure SUID scripts
+d_suidsafe=${d_suidsafe:-define}
+
+# Several people reported problems with perl's malloc, especially
+# when use64bitall is defined or when using gcc.
+#     http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg01318.html
+#     http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg00465.html
+usemymalloc=${usemymalloc:-false}
 
 # Avoid all libraries in /usr/ucblib.
 # /lib is just a symlink to /usr/lib
diff --git a/hv.c b/hv.c
index 0e50523..c999488 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -152,6 +152,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
     register HE *entry;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -196,6 +197,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
            return 0;
     }
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
@@ -208,6 +212,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        return &HeVAL(entry);
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -217,14 +223,24 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
        if (env) {
            sv = newSVpvn(env,len);
            SvTAINTED_on(sv);
+           if (key != keysave)
+               Safefree(key);
            return hv_store(hv,key,klen,sv,hash);
        }
     }
 #endif
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
-       return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
+       if (key != keysave) { /* must be is_utf8 == 0 */
+           SV **ret = hv_store(hv,key,klen,sv,hash);
+           Safefree(key);
+           return ret;
+       }
+       else
+           return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
     }
+    if (key != keysave)
+       Safefree(key);
     return 0;
 }
 
@@ -256,6 +272,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     register HE *entry;
     SV *sv;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -304,9 +321,12 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            return 0;
     }
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv)!=0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -320,6 +340,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        return entry;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -333,6 +355,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
        return hv_store_ent(hv,keysv,sv,hash);
@@ -385,6 +409,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
     register HE *entry;
     register HE **oentry;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -412,6 +437,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
 #endif
        }
     }
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -433,6 +461,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
            continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
+       if (key != keysave)
+           Safefree(key);
        return &HeVAL(entry);
     }
 
@@ -441,6 +471,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
        HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
        HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+    if (key != keysave)
+       Safefree(key);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -484,6 +516,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     register HE *entry;
     register HE **oentry;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -513,9 +546,12 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
        }
     }
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -537,6 +573,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
            continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
+       if (key != keysave)
+           Safefree(key);
        return entry;
     }
 
@@ -545,6 +583,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
        HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
        HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+    if (key != keysave)
+       Safefree(key);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -581,6 +621,7 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
     SV **svp;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return Nullsv;
@@ -615,6 +656,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
     if (!xhv->xhv_array)
        return Nullsv;
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
@@ -629,6 +673,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -645,6 +691,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
        --xhv->xhv_keys;
        return sv;
     }
+    if (key != keysave)
+       Safefree(key);
     return Nullsv;
 }
 
@@ -670,6 +718,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     register HE **oentry;
     SV *sv;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return Nullsv;
@@ -702,9 +751,12 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (!xhv->xhv_array)
        return Nullsv;
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -720,6 +772,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -736,6 +790,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
        --xhv->xhv_keys;
        return sv;
     }
+    if (key != keysave)
+       Safefree(key);
     return Nullsv;
 }
 
@@ -756,6 +812,7 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
     register HE *entry;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -786,6 +843,9 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
        return 0;
 #endif
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
 #ifdef DYNAMIC_ENV_FETCH
@@ -802,6 +862,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -816,6 +878,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     return FALSE;
 }
 
@@ -839,6 +903,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
     register HE *entry;
     SV *sv;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -867,8 +932,10 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
        return 0;
 #endif
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -886,6 +953,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
+       if (key != keysave)
+           Safefree(key);
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -900,6 +969,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     return FALSE;
 }
 
@@ -1471,10 +1542,13 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     register I32 i = 1;
     I32 found = 0;
     bool is_utf8 = FALSE;
+    const char *save = str;
 
     if (len < 0) {
       len = -len;
       is_utf8 = TRUE;
+      if (!(PL_hints & HINT_UTF8_DISTINCT))
+         str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
     }
 
     /* what follows is the moral equivalent of:
@@ -1507,7 +1581,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
        break;
     }
     UNLOCK_STRTAB_MUTEX;
-
+    if (str != save)
+       Safefree(str);
     if (!found && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
 }
@@ -1525,10 +1600,13 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
     register I32 i = 1;
     I32 found = 0;
     bool is_utf8 = FALSE;
+    const char *save = str;
 
     if (len < 0) {
       len = -len;
       is_utf8 = TRUE;
+      if (!(PL_hints & HINT_UTF8_DISTINCT))
+         str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
     }
 
     /* what follows is the moral equivalent of:
@@ -1568,8 +1646,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
 
     ++HeVAL(entry);                            /* use value slot as REFCNT */
     UNLOCK_STRTAB_MUTEX;
+    if (str != save)
+       Safefree(str);
     return HeKEY_hek(entry);
 }
-
-
-
index e2e9f0f..dbdd6b5 100755 (executable)
@@ -117,7 +117,7 @@ find(sub {
 # print "[$_]\n" for sort keys %archpms;
 
 my $ver = $Config{version};
-my $release = substr($],0,3);   # Not used presently.
+my $release = substr($],0,3);   # Not used currently.
 my $patchlevel = substr($],3,2);
 die "Patchlevel of perl ($patchlevel)",
     "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n"
@@ -137,6 +137,15 @@ my $libperl = $Config{libperl};
 my $so = $Config{so};
 my $dlext = $Config{dlext};
 my $dlsrc = $Config{dlsrc};
+if ($^O eq 'os390') {
+    my $pwd;
+    chomp($pwd=`pwd`);
+    my $archlibexp = $Config{archlibexp};
+    my $usedl = $Config{usedl};
+    if ($usedl eq 'define') {
+        `./$^X -pibak -e 's{$pwd\/libperl.x}{$archlibexp/CORE/libperl.x}' lib/Config.pm`;
+    }
+}
 
 my $d_dosuid = $Config{d_dosuid};
 my $binexp = $Config{binexp};
index c921904..8ecd10f 100644 (file)
@@ -34,7 +34,7 @@ PERLVAR(Iminus_F,     bool)
 PERLVAR(Idoswitches,   bool)
 
 /*
-=for apidoc Amn|bool|PL_dowarn
+=for apidoc mn|bool|PL_dowarn
 
 The C variable which corresponds to Perl's $^W warning variable.
 
@@ -89,20 +89,20 @@ PERLVAR(IDBgv,              GV *)
 PERLVAR(IDBline,       GV *)
 
 /*
-=for apidoc Amn|GV *|PL_DBsub
+=for apidoc mn|GV *|PL_DBsub
 When Perl is run in debugging mode, with the B<-d> switch, this GV contains
 the SV which holds the name of the sub being debugged.  This is the C
 variable which corresponds to Perl's $DB::sub variable.  See
 C<PL_DBsingle>.
 
-=for apidoc Amn|SV *|PL_DBsingle
+=for apidoc mn|SV *|PL_DBsingle
 When Perl is run in debugging mode, with the B<-d> switch, this SV is a
 boolean which indicates whether subs are being single-stepped.
 Single-stepping is automatically turned on after every step.  This is the C
 variable which corresponds to Perl's $DB::single variable.  See
 C<PL_DBsub>.
 
-=for apidoc Amn|SV *|PL_DBtrace
+=for apidoc mn|SV *|PL_DBtrace
 Trace variable used when Perl is run in debugging mode, with the B<-d>
 switch.  This is the C variable which corresponds to Perl's $DB::trace
 variable.  See C<PL_DBsingle>.
@@ -362,8 +362,8 @@ PERLVARI(Inumeric_standard, bool,   TRUE)
                                        /* Assume simple numerics */
 PERLVARI(Inumeric_local,       bool,   TRUE)
                                        /* Assume local numerics */
-PERLVAR(Inumeric_radix,                char)
-                                       /* The radix character if not '.' */
+PERLVAR(Inumeric_radix,                SV *)
+                                       /* The radix separator if not '.' */
 
 #endif /* !USE_LOCALE_NUMERIC */
 
index 030eedf..7103ee9 100644 (file)
@@ -360,6 +360,7 @@ expression to start with a sharp character. A typical example:
     ~$
     \.old$
     ^#.*#$
+    ^\.#
 
 If no MANIFEST.SKIP file is found, a default set of skips will be
 used, similar to the example above.  If you want nothing skipped,
index e933c48..472527d 100644 (file)
@@ -2,7 +2,7 @@
 
 package Getopt::Long;
 
-# RCS Status      : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp jv $
+# RCS Status      : $Id: GetoptLong.pl,v 2.26 2001-01-31 10:20:29+01 jv Exp $
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
@@ -35,8 +35,8 @@ use 5.004;
 use strict;
 
 use vars qw($VERSION $VERSION_STRING);
-$VERSION        =  2.24_02;
-$VERSION_STRING = "2.24_02";
+$VERSION        =  2.25;
+$VERSION_STRING = "2.25";
 
 use Exporter;
 use AutoLoader qw(AUTOLOAD);
@@ -215,7 +215,7 @@ __END__
 
 ################ AutoLoading subroutines ################
 
-# RCS Status      : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp jv $
+# RCS Status      : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $
 # Author          : Johan Vromans
 # Created On      : Fri Mar 27 11:50:30 1998
 # Last Modified By: Johan Vromans
@@ -244,7 +244,7 @@ sub GetOptions {
     print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
                  "called from package \"$pkg\".",
                  "\n  ",
-                 'GetOptionsAl $Revision: 2.29 $ ',
+                 'GetOptionsAl $Revision: 2.30 $ ',
                  "\n  ",
                  "ARGV: (@ARGV)",
                  "\n  ",
@@ -1694,6 +1694,10 @@ is equivalent to
 
     --foo -- arg1 --bar arg2 arg3
 
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
+
 =item bundling (default: disabled)
 
 Enabling this option will allow single-character options to be bundled.
@@ -1735,7 +1739,9 @@ errors. This makes it possible to write wrapper scripts that process
 only part of the user supplied command line arguments, and pass the
 remaining options to some other program.
 
-This can be very confusing, especially when C<permute> is also enabled.
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
 
 =item prefix
 
@@ -1880,6 +1886,5 @@ MA 02139, USA.
 =cut
 
 # Local Variables:
-# mode: perl
 # eval: (load-file "pod.el")
 # End:
index 74a023e..4c520fd 100644 (file)
@@ -18,6 +18,7 @@ use overload
                         scalar fdiv(${$_[0]},$_[1])},
 'neg'  =>      sub {new Math::BigFloat &fneg},
 'abs'  =>      sub {new Math::BigFloat &fabs},
+'int'  =>      sub {new Math::BigInt &f2int},
 
 qw(
 ""     stringify
@@ -58,6 +59,13 @@ sub stringify {
     return $n;
 }
 
+sub import {
+  shift;
+  return unless @_;
+  die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+  overload::constant float => sub {Math::BigFloat->new(shift)};
+}
+
 $div_scale = 40;
 
 # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
@@ -235,6 +243,26 @@ sub ffround { #(fnum_str, scale) return fnum_str
        }
     }
 }
+
+# Calculate the integer part of $x
+sub f2int { #(fnum_str) return inum_str
+    local($x) = ${$_[$[]};
+    if ($x eq 'NaN') {
+       die "Attempt to take int(NaN)";
+    } else {
+       local($xm,$xe) = split('E',$x);
+       if ($xe >= 0) {
+           $xm . '0' x $xe;
+       } else {
+           $xe = length($xm)+$xe;
+           if ($xe <= 1) {
+               '+0';
+           } else {
+               substr($xm,$[,$xe);
+           }
+       }
+    }
+}
     
 # compare 2 values returns one of undef, <0, =0, >0
 #   returns undef if either or both input value are not numbers
index 066577d..839b746 100644 (file)
@@ -25,6 +25,7 @@ use overload
 '|'    =>      sub {new Math::BigInt &bior},
 '^'    =>      sub {new Math::BigInt &bxor},
 '~'    =>      sub {new Math::BigInt &bnot},
+'int'  =>      sub { shift },
 
 qw(
 ""     stringify
index f438af6..e84a2e2 100644 (file)
@@ -7,42 +7,66 @@ use Benchmark;
 use Config;
 use strict;
 
-our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
-    $columns, @ISA, @EXPORT, @EXPORT_OK);
-$have_devel_corestack = 0;
+our($VERSION, $Verbose, $Switches, $Have_Devel_Corestack, $Curtest,
+    $Columns, $verbose, $switches,
+    @ISA, @EXPORT, @EXPORT_OK
+   );
 
-$VERSION = "1.1607";
+# Backwards compatibility for exportable variable names.
+*verbose  = \$Verbose;
+*switches = \$Switches;
+
+$Have_Devel_Corestack = 0;
+
+$VERSION = "1.1702";
 
 $ENV{HARNESS_ACTIVE} = 1;
 
 # Some experimental versions of OS/2 build have broken $?
-my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+
+my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
 
-my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
 
-my $tests_skipped = 0;
-my $subtests_skipped = 0;
+@ISA = ('Exporter');
+@EXPORT    = qw(&runtests);
+@EXPORT_OK = qw($verbose $switches);
 
-@ISA=('Exporter');
-@EXPORT= qw(&runtests);
-@EXPORT_OK= qw($verbose $switches);
+$Verbose  = 0;
+$Switches = "-w";
+$Columns  = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
 
-$verbose = 0;
-$switches = "-w";
-$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
 
 sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
 
 sub runtests {
     my(@tests) = @_;
+
+    my($tot, $failedtests) = _runtests(@tests);
+    _show_results($tot, $failedtests);
+
+    return ($tot->{bad} == 0 && $tot->{max}) ;
+}
+
+
+sub _runtests {
+    my(@tests) = @_;
     local($|) = 1;
-    my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
-    my $totmax = 0;
-    my $totok = 0;
-    my $files = 0;
-    my $bad = 0;
-    my $good = 0;
-    my $total = @tests;
+    my(%failedtests);
+
+    # Test-wide totals.
+    my(%tot) = (
+                bonus    => 0,
+                max      => 0,
+                ok       => 0,
+                files    => 0,
+                bad      => 0,
+                good     => 0,
+                tests    => scalar @tests,
+                sub_skipped  => 0,
+                skipped  => 0,
+                bench    => 0
+               );
 
     # pass -I flags to children
     my $old5lib = $ENV{PERL5LIB};
@@ -53,201 +77,135 @@ sub runtests {
     my $new5lib;
     if ($^O eq 'VMS') {
        $new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC);
-       $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
+       $Switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
     }
     else {
         $new5lib = join($Config{path_sep}, @INC);
     }
     local($ENV{'PERL5LIB'}) = $new5lib;
 
-    my @dir_files = globdir $files_in_dir if defined $files_in_dir;
+    my @dir_files = globdir $Files_In_Dir if defined $Files_In_Dir;
     my $t_start = new Benchmark;
-    while ($test = shift(@tests)) {
-       $te = $test;
-       chop($te);
+
+    foreach my $test (@tests) {
+       my $te = $test;
+       chop($te);      # XXX chomp?
+
        if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./s; }
        my $blank = (' ' x 77);
        my $leader = "$te" . '.' x (20 - length($te));
        my $ml = "";
        $ml = "\r$blank\r$leader"
-           if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose;
+           if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
        print $leader;
-       open(my $fh, $test) or print "can't open $test. $!\n";
-       my $first = <$fh>;
-       my $s = $switches;
-       $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
-           if exists $ENV{'HARNESS_PERL_SWITCHES'};
-       $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
-           if $first =~ /^#!.*\bperl.*-\w*T/;
-       close($fh) or print "can't close $test. $!\n";
+
+         my $s = _set_switches($test);
+
        my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
                ? "./perl -I../lib ../utils/perlcc $test "
                  . "-run 2>> ./compilelog |" 
                : "$^X $s $test|";
        $cmd = "MCR $cmd" if $^O eq 'VMS';
-       open($fh, $cmd) or print "can't run $test. $!\n";
-       $ok = $next = $max = 0;
-       @failed = ();
-       my %todo = ();
-        my $bonus = 0;
-       my $skipped = 0;
-       my $skip_reason;
+       open(my $fh, $cmd) or print "can't run $test. $!\n";
+
+        # state of the current test.
+        my %test = (
+                    ok          => 0,
+                    next        => 0,
+                    max         => 0,
+                    failed      => [],
+                    todo        => {},
+                    bonus       => 0,
+                    skipped     => 0,
+                    skip_reason => undef,
+                    ml          => $ml,
+                   );
+
+        my($seen_header, $tests_seen) = (0,0);
        while (<$fh>) {
-           if( $verbose ){
-               print $_;
-           }
-           if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
-               $max = $1;
-               for (split(/\s+/, $2)) { $todo{$_} = 1; }
-               $totmax += $max;
-               $files++;
-               $next = 1;
-           } elsif (/^1\.\.([0-9]+)(\s*\#\s*[Ss]kip\S*(?>\s+)(.+))?/) {
-               $max = $1;
-               $totmax += $max;
-               $files++;
-               $next = 1;
-               $skip_reason = $3 if not $max and defined $3;
-           } elsif ($max && /^(not\s+)?ok\b/) {
-               my $this = $next;
-               if (/^not ok\s*(\d*)/){
-                   $this = $1 if $1 > 0;
-                   print "${ml}NOK $this" if $ml;
-                   if (!$todo{$this}) {
-                       push @failed, $this;
-                   } else {
-                       $ok++;
-                       $totok++;
-                   }
-               } elsif (/^ok\s*(\d*) *(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?$/) {
-                   $this = $1 if $1 > 0;
-                   print "${ml}ok $this/$max" if $ml;
-                   $ok++;
-                   $totok++;
-                   $skipped++ if defined $2;
-                   my $reason;
-                   $reason = 'unknown reason' if defined $2;
-                   $reason = $3 if defined $3;
-                   if (defined $reason and defined $skip_reason) {
-                     # print "was: '$skip_reason' new '$reason'\n";
-                     $skip_reason = 'various reasons'
-                       if $skip_reason ne $reason;
-                   } elsif (defined $reason) {
-                     $skip_reason = $reason;
-                   }
-                   $bonus++, $totbonus++ if $todo{$this};
-               } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) {
-                   $this = $1 if $1 > 0;
-                   print "${ml}ok $this/$max" if $ml;
-                   $ok++;
-                   $totok++;
-               } else {
-                   # an ok or not ok not matching the 3 cases above...
-                   # just ignore it for compatibility with TEST
-                   next;
-               }
-               if ($this > $next) {
-                   # print "Test output counter mismatch [test $this]\n";
-                   # no need to warn probably
-                   push @failed, $next..$this-1;
-               } elsif ($this < $next) {
-                   #we have seen more "ok" lines than the number suggests
-                   print "Confused test output: test $this answered after test ", $next-1, "\n";
-                   $next = $this;
-               }
-               $next = $this + 1;
-           } elsif (/^Bail out!\s*(.*)/i) { # magic words
-                die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
+            if( _parse_header($_, \%test, \%tot) ) {
+                warn "Test header seen twice!\n" if $seen_header;
+
+                $seen_header = 1;
+
+                warn "1..M can only appear at the beginning or end of tests\n"
+                  if $tests_seen && $test{max} < $tests_seen;
+            }
+            elsif( _parse_test_line($_, \%test, \%tot) ) {
+                $tests_seen++;
             }
+            # else, ignore it.
        }
-       close($fh); # must close to reap child resource values
-       my $wstatus = $ignore_exitcode ? 0 : $?;        # Can trust $? ?
-       my $estatus;
-       $estatus = ($^O eq 'VMS'
-                      ? eval 'use vmsish "status"; $estatus = $?'
-                      : $wstatus >> 8);
+
+        my($estatus, $wstatus) = _close_fh($fh);
+
        if ($wstatus) {
-           my ($failed, $canon, $percent) = ('??', '??');
-           printf "${ml}dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
-                   $wstatus,$wstatus;
-           print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
-           if (corestatus($wstatus)) { # until we have a wait module
-               if ($have_devel_corestack) {
-                   Devel::CoreStack::stack($^X);
-               } else {
-                   print "\ttest program seems to have generated a core\n";
-               }
-           }
-           $bad++;
-           if ($max) {
-             if ($next == $max + 1 and not @failed) {
-               print "\tafter all the subtests completed successfully\n";
-               $percent = 0;
-               $failed = 0;    # But we do not set $canon!
-             } else {
-               push @failed, $next..$max;
-               $failed = @failed;
-               (my $txt, $canon) = canonfailed($max,$skipped,@failed);
-               $percent = 100*(scalar @failed)/$max;
-               print "DIED. ",$txt;
-             }
-           }
-           $failedtests{$test} = { canon => $canon,  max => $max || '??',
-                                   failed => $failed, 
-                                   name => $test, percent => $percent,
-                                   estat => $estatus, wstat => $wstatus,
-                                 };
-       } elsif ($ok == $max && $next == $max+1) {
-           if ($max and $skipped + $bonus) {
+            $failedtests{$test} = _dubious_return(\%test, \%tot, 
+                                                  $estatus, $wstatus);
+       }
+        elsif ($test{ok} == $test{max} && $test{next} == $test{max}+1) {
+           if ($test{max} and $test{skipped} + $test{bonus}) {
                my @msg;
-               push(@msg, "$skipped/$max skipped: $skip_reason")
-                   if $skipped;
-               push(@msg, "$bonus/$max unexpectedly succeeded")
-                   if $bonus;
-               print "${ml}ok, ".join(', ', @msg)."\n";
-           } elsif ($max) {
-               print "${ml}ok\n";
-           } elsif (defined $skip_reason) {
-               print "skipped: $skip_reason\n";
-               $tests_skipped++;
+               push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
+                   if $test{skipped};
+               push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
+                   if $test{bonus};
+               print "$test{ml}ok, ".join(', ', @msg)."\n";
+           } elsif ($test{max}) {
+               print "$test{ml}ok\n";
+           } elsif (defined $test{skip_reason}) {
+               print "skipped: $test{skip_reason}\n";
+               $tot{skipped}++;
            } else {
                print "skipped test on this platform\n";
-               $tests_skipped++;
+               $tot{skipped}++;
            }
-           $good++;
-       } elsif ($max) {
-           if ($next <= $max) {
-               push @failed, $next..$max;
+           $tot{good}++;
+       } elsif ($test{max}) {
+           if ($test{next} <= $test{max}) {
+               push @{$test{failed}}, $test{next}..$test{max};
            }
-           if (@failed) {
-               my ($txt, $canon) = canonfailed($max,$skipped,@failed);
-               print "${ml}$txt";
-               $failedtests{$test} = { canon => $canon,  max => $max,
-                                       failed => scalar @failed,
-                                       name => $test, percent => 100*(scalar @failed)/$max,
-                                       estat => '', wstat => '',
+           if (@{$test{failed}}) {
+               my ($txt, $canon) = canonfailed($test{max},$test{skipped},
+                                                @{$test{failed}});
+               print "$test{ml}$txt";
+               $failedtests{$test} = { canon   => $canon,
+                                        max     => $test{max},
+                                       failed  => scalar @{$test{failed}},
+                                       name    => $test, 
+                                        percent => 100*(scalar @{$test{failed}})/$test{max},
+                                       estat   => '',
+                                        wstat   => '',
                                      };
            } else {
-               print "Don't know which tests failed: got $ok ok, expected $max\n";
-               $failedtests{$test} = { canon => '??',  max => $max,
-                                       failed => '??', 
-                                       name => $test, percent => undef,
-                                       estat => '', wstat => '',
+               print "Don't know which tests failed: got $test{ok} ok, ".
+                      "expected $test{max}\n";
+               $failedtests{$test} = { canon   => '??',
+                                        max     => $test{max},
+                                       failed  => '??',
+                                       name    => $test, 
+                                        percent => undef,
+                                       estat   => '', 
+                                        wstat   => '',
                                      };
            }
-           $bad++;
-       } elsif ($next == 0) {
+           $tot{bad}++;
+       } elsif ($test{next} == 0) {
            print "FAILED before any test output arrived\n";
-           $bad++;
-           $failedtests{$test} = { canon => '??',  max => '??',
-                                   failed => '??',
-                                   name => $test, percent => undef,
-                                   estat => '', wstat => '',
+           $tot{bad}++;
+           $failedtests{$test} = { canon       => '??',
+                                    max         => '??',
+                                   failed      => '??',
+                                   name        => $test,
+                                    percent     => undef,
+                                   estat       => '', 
+                                    wstat       => '',
                                  };
        }
-       $subtests_skipped += $skipped;
-       if (defined $files_in_dir) {
-           my @new_dir_files = globdir $files_in_dir;
+       $tot{sub_skipped} += $test{skipped};
+
+       if (defined $Files_In_Dir) {
+           my @new_dir_files = globdir $Files_In_Dir;
            if (@new_dir_files != @dir_files) {
                my %f;
                @f{@new_dir_files} = (1) x @new_dir_files;
@@ -258,7 +216,7 @@ sub runtests {
            }
        }
     }
-    my $t_total = timediff(new Benchmark, $t_start);
+    $tot{bench} = timediff(new Benchmark, $t_start);
 
     if ($^O eq 'VMS') {
        if (defined $old5lib) {
@@ -267,97 +225,326 @@ sub runtests {
            delete $ENV{PERL5LIB};
        }
     }
-    my $bonusmsg = '';
-    $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
-              " UNEXPECTEDLY SUCCEEDED)")
-       if $totbonus;
-    if ($tests_skipped) {
-       $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
-       if ($subtests_skipped) {
-           $bonusmsg .= " and $subtests_skipped subtest"
-                        . ($subtests_skipped != 1 ? 's' : '');
-       }
-       $bonusmsg .= ' skipped';
-    }
-    elsif ($subtests_skipped) {
-       $bonusmsg .= ", $subtests_skipped subtest"
-                    . ($subtests_skipped != 1 ? 's' : '')
-                    . " skipped";
-    }
-    if ($bad == 0 && $totmax) {
+
+    return(\%tot, \%failedtests);
+}
+
+
+sub _show_results {
+    my($tot, $failedtests) = @_;
+
+    my $pct;
+    my $bonusmsg = _bonusmsg($tot);
+
+    if ($tot->{bad} == 0 && $tot->{max}) {
        print "All tests successful$bonusmsg.\n";
-    } elsif ($total==0){
+    } elsif ($tot->{tests}==0){
        die "FAILED--no tests were run for some reason.\n";
-    } elsif ($totmax==0) {
-       my $blurb = $total==1 ? "script" : "scripts";
-       die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
+    } elsif ($tot->{max} == 0) {
+       my $blurb = $tot->{tests}==1 ? "script" : "scripts";
+       die "FAILED--$tot->{tests} test $blurb could be run, ".
+            "alas--no output ever seen\n";
     } else {
-       $pct = sprintf("%.2f", $good / $total * 100);
+       $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
        my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
-       $totmax - $totok, $totmax, 100*$totok/$totmax;
-       # Create formats
-       #    First, figure out max length of test names
-       my $failed_str = "Failed Test";
-       my $middle_str = " Status Wstat Total Fail  Failed  ";
-       my $list_str = "List of Failed";
-       my $max_namelen = length($failed_str);
-       my $script;
-       foreach $script (keys %failedtests) {
-           $max_namelen =
-               (length $failedtests{$script}->{name} > $max_namelen) ?
-                   length $failedtests{$script}->{name} : $max_namelen;
-       }
-       my $list_len = $columns - length($middle_str) - $max_namelen;
-       if ($list_len < length($list_str)) {
-           $list_len = length($list_str);
-           $max_namelen = $columns - length($middle_str) - $list_len;
-           if ($max_namelen < length($failed_str)) {
-               $max_namelen = length($failed_str);
-               $columns = $max_namelen + length($middle_str) + $list_len;
-           }
-       }
-
-       my $fmt_top = "format STDOUT_TOP =\n"
-                     . sprintf("%-${max_namelen}s", $failed_str)
-                     . $middle_str
-                     . $list_str . "\n"
-                     . "-" x $columns
-                     . "\n.\n";
-       my $fmt = "format STDOUT =\n"
-                 . "@" . "<" x ($max_namelen - 1)
-                 . "    @>> @>>>> @>>>> @>>> ^##.##%  "
-                 . "^" . "<" x ($list_len - 1) . "\n"
-                 . '{ $curtest->{name}, $curtest->{estat},'
-                 . '  $curtest->{wstat}, $curtest->{max},'
-                 . '  $curtest->{failed}, $curtest->{percent},'
-                 . '  $curtest->{canon}'
-                 . "\n}\n"
-                 . "~~" . " " x ($columns - $list_len - 2) . "^"
-                 . "<" x ($list_len - 1) . "\n"
-                 . '$curtest->{canon}'
-                 . "\n.\n";
+                             $tot->{max} - $tot->{ok}, $tot->{max}, 
+                              100*$tot->{ok}/$tot->{max};
 
-       eval $fmt_top;
-       die $@ if $@;
-       eval $fmt;
-       die $@ if $@;
+        my($fmt_top, $fmt) = _create_fmts($failedtests);
 
        # Now write to formats
-       for $script (sort keys %failedtests) {
-         $curtest = $failedtests{$script};
+       for my $script (sort keys %$failedtests) {
+         $Curtest = $failedtests->{$script};
          write;
        }
-       if ($bad) {
+       if ($tot->{bad}) {
            $bonusmsg =~ s/^,\s*//;
            print "$bonusmsg.\n" if $bonusmsg;
-           die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
+           die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
+                "$subpct\n";
        }
     }
-    printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
 
-    return ($bad == 0 && $totmax) ;
+    printf("Files=%d, Tests=%d, %s\n",
+           $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
+}
+
+
+sub _parse_header {
+    my($line, $test, $tot) = @_;
+
+    my $is_header = 0;
+
+    print $line if $Verbose;
+
+    # 1..10 todo 4 7 10;
+    if ($line =~ /^1\.\.([0-9]+) todo([\d\s]+);?/i) {
+        $test->{max} = $1;
+        for (split(/\s+/, $2)) { $test->{todo}{$_} = 1; }
+
+        $tot->{max} += $test->{max};
+        $tot->{files}++;
+
+        $is_header = 1;
+    }
+    # 1..10
+    # 1..0 # skip  Why?  Because I said so!
+    elsif ($line =~ /^1\.\.([0-9]+)
+                      (\s*\#\s*[Ss]kip\S*(?>\s+) (.+))?
+                    /x
+          )
+    {
+        $test->{max} = $1;
+        $tot->{max} += $test->{max};
+        $tot->{files}++;
+        $test->{next} = 1 unless $test->{next};
+        $test->{skip_reason} = $3 if not $test->{max} and defined $3;
+
+        $is_header = 1;
+    }
+    else {
+        $is_header = 0;
+    }
+
+    return $is_header;
 }
 
+
+sub _parse_test_line {
+    my($line, $test, $tot) = @_;
+
+    if ($line =~ /^(not\s+)?ok\b/i) {
+        my $this = $test->{next} || 1;
+        # "not ok 23"
+        if ($line =~ /^not ok\s*(\d*)/){         # test failed
+            $this = $1 if length $1 and $1 > 0;
+            print "$test->{ml}NOK $this" if $test->{ml};
+            if (!$test->{todo}{$this}) {
+                push @{$test->{failed}}, $this;
+            } else {
+                $test->{ok}++;
+                $tot->{ok}++;
+            }
+        }
+        # "ok 23 # skip (you're not cleared for that)"
+        elsif ($line =~ /^ok\s*(\d*)\ *
+                         (\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?
+                        /x)        # test skipped
+        {
+            $this = $1 if length $1 and $1 > 0;
+            print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+            $test->{ok}++;
+            $tot->{ok}++;
+            $test->{skipped}++ if defined $2;
+            my $reason;
+            $reason = 'unknown reason' if defined $2;
+            $reason = $3 if defined $3;
+            if (defined $reason and defined $test->{skip_reason}) {
+                # print "was: '$skip_reason' new '$reason'\n";
+                $test->{skip_reason} = 'various reasons'
+                  if $test->{skip_reason} ne $reason;
+            } elsif (defined $reason) {
+                $test->{skip_reason} = $reason;
+            }
+            $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this};
+        }
+        # XXX ummm... dunno
+        elsif ($line =~ /^ok\s*(\d*)\s*\#([^\r]*)$/) { # XXX multiline ok?
+            $this = $1 if $1 > 0;
+            print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+            $test->{ok}++;
+            $tot->{ok}++;
+        }
+        else {
+            # an ok or not ok not matching the 3 cases above...
+            # just ignore it for compatibility with TEST
+            next;
+        }
+
+        if ($this > $test->{next}) {
+            # print "Test output counter mismatch [test $this]\n";
+            # no need to warn probably
+            push @{$test->{failed}}, $test->{next}..$this-1;
+        }
+        elsif ($this < $test->{next}) {
+            #we have seen more "ok" lines than the number suggests
+            print "Confused test output: test $this answered after ".
+                  "test ", $test->{next}-1, "\n";
+            $test->{next} = $this;
+        }
+        $test->{next} = $this + 1;
+
+    }
+    elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
+        die "FAILED--Further testing stopped" .
+            ($1 ? ": $1\n" : ".\n");
+    }
+}
+
+
+sub _bonusmsg {
+    my($tot) = @_;
+
+    my $bonusmsg = '';
+    $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
+              " UNEXPECTEDLY SUCCEEDED)")
+       if $tot->{bonus};
+
+    if ($tot->{skipped}) {
+       $bonusmsg .= ", $tot->{skipped} test"
+                     . ($tot->{skipped} != 1 ? 's' : '');
+       if ($tot->{sub_skipped}) {
+           $bonusmsg .= " and $tot->{sub_skipped} subtest"
+                        . ($tot->{sub_skipped} != 1 ? 's' : '');
+       }
+       $bonusmsg .= ' skipped';
+    }
+    elsif ($tot->{sub_skipped}) {
+       $bonusmsg .= ", $tot->{sub_skipped} subtest"
+                    . ($tot->{sub_skipped} != 1 ? 's' : '')
+                    . " skipped";
+    }
+
+    return $bonusmsg;
+}
+
+# VMS has some subtle nastiness with closing the test files.
+sub _close_fh {
+    my($fh) = shift;
+
+    close($fh); # must close to reap child resource values
+
+    my $wstatus = $Ignore_Exitcode ? 0 : $?;   # Can trust $? ?
+    my $estatus;
+    $estatus = ($^O eq 'VMS'
+                  ? eval 'use vmsish "status"; $estatus = $?'
+                  : $wstatus >> 8);
+
+    return($estatus, $wstatus);
+}
+
+
+# Set up the command-line switches to run perl as.
+sub _set_switches {
+    my($test) = shift;
+
+    open(my $fh, $test) or print "can't open $test. $!\n";
+    my $first = <$fh>;
+    my $s = $Switches;
+    $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
+      if exists $ENV{'HARNESS_PERL_SWITCHES'};
+    $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
+      if $first =~ /^#!.*\bperl.*-\w*T/;
+
+    close($fh) or print "can't close $test. $!\n";
+
+    return $s;
+}
+
+
+# Test program go boom.
+sub _dubious_return {
+    my($test, $tot, $estatus, $wstatus) = @_;
+    my ($failed, $canon, $percent) = ('??', '??');
+
+    printf "$test->{ml}dubious\n\tTest returned status $estatus ".
+           "(wstat %d, 0x%x)\n",
+           $wstatus,$wstatus;
+    print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
+
+    if (corestatus($wstatus)) { # until we have a wait module
+        if ($Have_Devel_Corestack) {
+            Devel::CoreStack::stack($^X);
+        } else {
+            print "\ttest program seems to have generated a core\n";
+        }
+    }
+
+    $tot->{bad}++;
+
+    if ($test->{max}) {
+        if ($test->{next} == $test->{max} + 1 and not @{$test->{failed}}) {
+            print "\tafter all the subtests completed successfully\n";
+            $percent = 0;
+            $failed = 0;       # But we do not set $canon!
+        }
+        else {
+            push @{$test->{failed}}, $test->{next}..$test->{max};
+            $failed = @{$test->{failed}};
+            (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
+            $percent = 100*(scalar @{$test->{failed}})/$test->{max};
+            print "DIED. ",$txt;
+        }
+    }
+
+    return { canon => $canon,  max => $test->{max} || '??',
+             failed => $failed, 
+             name => $test, percent => $percent,
+             estat => $estatus, wstat => $wstatus,
+           };
+}
+
+
+sub _garbled_output {
+    my($gibberish) = shift;
+    warn "Confusing test output:  '$gibberish'\n";
+}
+
+
+sub _create_fmts {
+    my($failedtests) = @_;
+
+    my $failed_str = "Failed Test";
+    my $middle_str = " Status Wstat Total Fail  Failed  ";
+    my $list_str = "List of Failed";
+
+    # Figure out our longest name string for formatting purposes.
+    my $max_namelen = length($failed_str);
+    foreach my $script (keys %$failedtests) {
+        my $namelen = length $failedtests->{$script}->{name};
+        $max_namelen = $namelen if $namelen > $max_namelen;
+    }
+
+    my $list_len = $Columns - length($middle_str) - $max_namelen;
+    if ($list_len < length($list_str)) {
+        $list_len = length($list_str);
+        $max_namelen = $Columns - length($middle_str) - $list_len;
+        if ($max_namelen < length($failed_str)) {
+            $max_namelen = length($failed_str);
+            $Columns = $max_namelen + length($middle_str) + $list_len;
+        }
+    }
+
+    my $fmt_top = "format STDOUT_TOP =\n"
+                  . sprintf("%-${max_namelen}s", $failed_str)
+                  . $middle_str
+                 . $list_str . "\n"
+                 . "-" x $Columns
+                 . "\n.\n";
+
+    my $fmt = "format STDOUT =\n"
+             . "@" . "<" x ($max_namelen - 1)
+              . "       @>> @>>>> @>>>> @>>> ^##.##%  "
+             . "^" . "<" x ($list_len - 1) . "\n"
+             . '{ $Curtest->{name}, $Curtest->{estat},'
+             . '  $Curtest->{wstat}, $Curtest->{max},'
+             . '  $Curtest->{failed}, $Curtest->{percent},'
+             . '  $Curtest->{canon}'
+             . "\n}\n"
+             . "~~" . " " x ($Columns - $list_len - 2) . "^"
+             . "<" x ($list_len - 1) . "\n"
+             . '$Curtest->{canon}'
+             . "\n.\n";
+
+    eval $fmt_top;
+    die $@ if $@;
+    eval $fmt;
+    die $@ if $@;
+
+    return($fmt_top, $fmt);
+}
+
+
 my $tried_devel_corestack;
 sub corestatus {
     my($st) = @_;
@@ -365,7 +552,7 @@ sub corestatus {
     eval {require 'wait.ph'};
     my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
 
-    eval { require Devel::CoreStack; $have_devel_corestack++ } 
+    eval { require Devel::CoreStack; $Have_Devel_Corestack++ } 
       unless $tried_devel_corestack++;
 
     $ret;
@@ -406,7 +593,9 @@ sub canonfailed ($@) {
     my $ender = 's' x ($skipped > 1);
     my $good = $max - $failed - $skipped;
     my $goodper = sprintf("%.2f",100*($good/$max));
-    push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
+    push @result, " (-$skipped skipped test$ender: $good okay, ".
+                  "$goodper%)"
+         if $skipped;
     push @result, "\n";
     my $txt = join "", @result;
     ($txt, $canon);
@@ -427,7 +616,7 @@ runtests(@tests);
 
 =head1 DESCRIPTION
 
-(By using the L<Test> module, you can write test scripts without
+(By using the Test module, you can write test scripts without
 knowing the exact output this module expects.  However, if you need to
 know the specifics, read on!)
 
@@ -444,14 +633,41 @@ performance statistics that are computed by the Benchmark module.
 
 =head2 The test script output
 
+=over 4
+
+=item B<1..M>
+
+This header tells how many tests there will be.  It should be the
+first line output by your test program (but its okay if its preceded
+by comments).
+
+In certain instanced, you may not know how many tests you will
+ultimately be running.  In this case, it is permitted (but not
+encouraged) for the 1..M header to appear as the B<last> line output
+by your test (again, it can be followed by further comments).  But we
+strongly encourage you to put it first.
+
+Under B<no> circumstances should 1..M appear in the middle of your
+output or more than once.
+
+
+=item B<'ok', 'not ok'.  Ok?>
+
 Any output from the testscript to standard error is ignored and
 bypassed, thus will be seen by the user. Lines written to standard
 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 runtests().  All other lines are discarded.
 
-It is tolerated if the test numbers after C<ok> are omitted. In this
-case Test::Harness maintains temporarily its own counter until the
-script supplies test numbers again. So the following test script
+C</^not ok/> indicates a failed test.  C</^ok/> is a successful test.
+
+
+=item B<test numbers>
+
+Perl normally expects the 'ok' or 'not ok' to be followed by a test
+number.  It is tolerated if the test numbers after 'ok' are
+omitted. In this case Test::Harness maintains temporarily its own
+counter until the script supplies test numbers again. So the following
+test script
 
     print <<END;
     1..6
@@ -467,27 +683,34 @@ will generate
     FAILED tests 1, 3, 6
     Failed 3/6 tests, 50.00% okay
 
+
+=item B<$Test::Harness::verbose>
+
 The global variable $Test::Harness::verbose is exportable and can be
 used to let runtests() display the standard output of the script
 without altering the behavior otherwise.
 
+=item B<$Test::Harness::switches>
+
 The global variable $Test::Harness::switches is exportable and can be
 used to set perl command line options used for running the test
 script(s). The default value is C<-w>.
 
+=item B<Skipping tests>
+
 If the standard output line contains substring C< # Skip> (with
 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
-counted as a skipped test.  In no other circumstance is anything
-allowed to follow C<ok> or C<ok NUMBER>.  If the whole testscript
-succeeds, the count of skipped tests is included in the generated
-output.
+counted as a skipped test.  If the whole testscript succeeds, the
+count of skipped tests is included in the generated output.
 
 C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
 for skipping.  Similarly, one can include a similar explanation in a
-C<1..0> line emitted if the test is skipped completely:
+C<1..0> line emitted if the test script is skipped completely:
 
   1..0 # Skipped: no leverage found
 
+=item B<Bail out!>
+
 As an emergency measure, a test script can decide that further tests
 are useless (e.g. missing dependencies) and testing should stop
 immediately. In that case the test script prints the magic words
@@ -497,10 +720,25 @@ immediately. In that case the test script prints the magic words
 to standard output. Any message after these words will be displayed by
 C<Test::Harness> as the reason why testing is stopped.
 
+=item B<Comments>
+
+Additional comments may be put into the testing output on their own
+lines.  Comment lines should begin with a '#', Test::Harness will
+ignore them.
+
+  ok 1
+  # Life is good, the sun is shining, RAM is cheap.
+  not ok 2
+  # got 'Bush' expected 'Gore'
+
+
 =head1 EXPORT
 
 C<&runtests> is exported by Test::Harness per default.
 
+C<$verbose> and C<$switches> are exported upon request.
+
+
 =head1 DIAGNOSTICS
 
 =over 4
@@ -517,8 +755,8 @@ above are printed.
 
 =item C<Test returned status %d (wstat %d)>
 
-Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
-printed in a message similar to the above.
+Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
+and C<$?> are printed in a message similar to the above.
 
 =item C<Failed 1 test, %.2f%% okay. %s>
 
index 69092a0..21a4b67 100644 (file)
@@ -123,7 +123,7 @@ sub mycan {                         # Real can would leave stubs.
         binary           => "& | ^",
         unary            => "neg ! ~",
         mutators         => '++ --',
-        func             => "atan2 cos sin exp abs log sqrt",
+        func             => "atan2 cos sin exp abs log sqrt int",
         conversion       => 'bool "" 0+',
         iterators        => '<>',
         dereferencing    => '${} @{} %{} &{} *{}',
@@ -370,11 +370,16 @@ postfix form.
 
 =item * I<Transcendental functions>
 
-    "atan2", "cos", "sin", "exp", "abs", "log", "sqrt",
+    "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int"
 
 If C<abs> is unavailable, it can be autogenerated using methods
 for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
 
+Note that traditionally the Perl function L<int> rounds to 0, thus for
+floating-point-like types one should follow the same semantic.  If
+C<int> is unavailable, it can be autogenerated using the overloading of
+C<0+>.
+
 =item * I<Boolean, string and numeric conversion>
 
     "bool", "\"\"", "0+",
@@ -969,7 +974,7 @@ would would lead to a memory leak.
 Both these problems can be cured.  Say, if we want to overload hash
 dereference on a reference to an object which is I<implemented> as a
 hash itself, the only problem one has to circumvent is how to access
-this I<actual> hash (as opposed to the I<virtual> exhibited by
+this I<actual> hash (as opposed to the I<virtual> hash exhibited by the
 overloaded dereference operator).  Here is one possible fetching routine:
 
   sub access_hash {
@@ -981,7 +986,7 @@ overloaded dereference operator).  Here is one possible fetching routine:
     $out;
   }
 
-To move creation of the tied hash on each access, one may an extra
+To remove creation of the tied hash on each access, one may an extra
 level of indirection which allows a non-circular structure of references:
 
   package two_refs1;
@@ -1018,10 +1023,10 @@ level of indirection which allows a non-circular structure of references:
     $a->[$key];
   }
 
-Now if $baz is overloaded like this, then C<$bar> is a reference to a
+Now if $baz is overloaded like this, then C<$baz> is a reference to a
 reference to the intermediate array, which keeps a reference to an
 actual array, and the access hash.  The tie()ing object for the access
-hash is also a reference to a reference to the actual array, so
+hash is a reference to a reference to the actual array, so
 
 =over
 
@@ -1108,7 +1113,7 @@ inside such a method it is not necessary to pretty-print the
 I<components> $a and $b of an object.  In the above subroutine
 C<"[$meth $a $b]"> is a catenation of some strings and components $a
 and $b.  If these components use overloading, the catenation operator
-will look for an overloaded operator C<.>, if not present, it will
+will look for an overloaded operator C<.>; if not present, it will
 look for an overloaded operator C<"">.  Thus it is enough to use
 
   use overload nomethod => \&wrap, '""' => \&str;
@@ -1211,7 +1216,7 @@ mutator methods (C<++>, C<-=> and so on), does not do deep copying
 (not required without mutators!), and implements only those arithmetic
 operations which are used in the example.
 
-To implement most arithmetic operations is easy, one should just use
+To implement most arithmetic operations is easy; one should just use
 the tables of operations, and change the code which fills %subr to
 
   my %subr = ( 'n' => sub {$_[0]} );
@@ -1233,7 +1238,7 @@ special to make C<+=> and friends work, except filling C<+=> entry of
 way to know that the implementation of C<'+='> does not mutate
 the argument, compare L<Copy Constructor>).
 
-To implement a copy constructor, add C<'=' => \&cpy> to C<use overload>
+To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload>
 line, and code (this code assumes that mutators change things one level
 deep only, so recursive copying is not needed):
 
diff --git a/lib/unicode/Is/DCinital.pl b/lib/unicode/Is/DCinital.pl
deleted file mode 100644 (file)
index 8778a75..0000000
+++ /dev/null
@@ -1,59 +0,0 @@
-# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
-# This file is built by mktables.PL from e.g. Unicode.301.
-# Any changes made here will be lost!
-return <<'END';
-fb55   
-fb59   
-fb5d   
-fb61   
-fb65   
-fb69   
-fb6d   
-fb71   
-fb75   
-fb79   
-fb7d   
-fb81   
-fb91   
-fb95   
-fb99   
-fb9d   
-fba3   
-fba9   
-fbad   
-fbd6   
-fbe7   
-fbe9   
-fbff   
-fcdf   fcf4
-fd34   fd3b
-fe71   
-fe77   
-fe79   
-fe7b   
-fe7d   
-fe7f   
-fe8c   
-fe92   
-fe98   
-fe9c   
-fea0   
-fea4   
-fea8   
-feb4   
-feb8   
-febc   
-fec0   
-fec4   
-fec8   
-fecc   
-fed0   
-fed4   
-fed8   
-fedc   
-fee0   
-fee4   
-fee8   
-feec   
-fef4   
-END
diff --git a/mg.c b/mg.c
index 8165302..bb9509a 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2264,6 +2264,7 @@ Perl_sighandler(int sig)
 
     POPSTACK;
     if (SvTRUE(ERRSV)) {
+#ifndef PERL_MICRO
 #ifdef HAS_SIGPROCMASK
        /* Handler "died", for example to get out of a restart-able read().
         * Before we re-do that on its behalf re-enable the signal which was
@@ -2278,6 +2279,7 @@ Perl_sighandler(int sig)
        (void)rsignal(sig, SIG_IGN);
        (void)rsignal(sig, &Perl_csighandler);
 #endif
+#endif /* !PERL_MICRO */
        Perl_die(aTHX_ Nullch);
     }
 cleanup:
index 8cdfec0..51e4eb2 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_utf8_to_bytes     pPerl->Perl_utf8_to_bytes
 #undef  utf8_to_bytes
 #define utf8_to_bytes          Perl_utf8_to_bytes
+#undef  Perl_bytes_from_utf8
+#define Perl_bytes_from_utf8   pPerl->Perl_bytes_from_utf8
+#undef  bytes_from_utf8
+#define bytes_from_utf8                Perl_bytes_from_utf8
 #undef  Perl_bytes_to_utf8
 #define Perl_bytes_to_utf8     pPerl->Perl_bytes_to_utf8
 #undef  bytes_to_utf8
diff --git a/op.c b/op.c
index 6729ca0..95a72fc 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1568,7 +1568,6 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_AASSIGN:
     case OP_NEXTSTATE:
     case OP_DBSTATE:
-    case OP_REFGEN:
     case OP_CHOMP:
        PL_modcount = RETURN_UNLIMITED_NUMBER;
        break;
index 5b72b85..d4fd59d 100644 (file)
@@ -70,7 +70,7 @@
 #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
 static char    *local_patches[] = {
         NULL
-       ,"DEVEL8530"
+       ,"DEVEL8670"
        ,NULL
 };
 
diff --git a/perl.c b/perl.c
index a5f4e68..21ca8aa 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -562,6 +562,7 @@ perl_destruct(pTHXx)
 #ifdef USE_LOCALE_NUMERIC
     Safefree(PL_numeric_name);
     PL_numeric_name = Nullch;
+    SvREFCNT_dec(PL_numeric_radix);
 #endif
 
     /* clear utf8 character classes */
diff --git a/perl.h b/perl.h
index bbea5dd..498e6e3 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3064,7 +3064,8 @@ enum {
   to_sv_amg,   to_av_amg,
   to_hv_amg,   to_gv_amg,
   to_cv_amg,   iter_amg,
-  DESTROY_amg, max_amg_code
+  int_amg,     DESTROY_amg,
+  max_amg_code
   /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };
 
@@ -3110,7 +3111,7 @@ EXTCONST char * PL_AMG_names[NofAMmeth] = {
   "(${}",      "(@{}",
   "(%{}",      "(*{}",
   "(&{}",      "(<>",
-  "DESTROY",
+  "(int",      "DESTROY",
 };
 #else
 EXTCONST char * PL_AMG_names[NofAMmeth];
@@ -3216,9 +3217,9 @@ typedef struct am_table_short AMTS;
 #define SET_NUMERIC_LOCAL() \
        set_numeric_local();
 
-#define IS_NUMERIC_RADIX(c)    \
+#define IS_NUMERIC_RADIX(s)    \
        ((PL_hints & HINT_LOCALE) && \
-         PL_numeric_radix && (c) == PL_numeric_radix)
+         PL_numeric_radix && memEQ(s, SvPVX(PL_numeric_radix), SvCUR(PL_numeric_radix)))
 
 #define STORE_NUMERIC_LOCAL_SET_STANDARD() \
        bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \
@@ -3339,12 +3340,14 @@ typedef struct am_table_short AMTS;
  * massively.
  */
 
-#ifndef PERL_OLD_SIGNALS
-#define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+#ifndef PERL_MICRO
+#   ifndef PERL_OLD_SIGNALS
+#       define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+#   endif
 #endif
 
 #ifndef PERL_ASYNC_CHECK
-#define PERL_ASYNC_CHECK()  NOOP
+#   define PERL_ASYNC_CHECK()  NOOP
 #endif
 
 /*
index f0016d5..04d48b9 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3413,6 +3413,13 @@ Perl_utf8_to_bytes(pTHXo_ U8 *s, STRLEN *len)
     return ((CPerlObj*)pPerl)->Perl_utf8_to_bytes(s, len);
 }
 
+#undef  Perl_bytes_from_utf8
+U8*
+Perl_bytes_from_utf8(pTHXo_ U8 *s, STRLEN *len, bool *is_utf8)
+{
+    return ((CPerlObj*)pPerl)->Perl_bytes_from_utf8(s, len, is_utf8);
+}
+
 #undef  Perl_bytes_to_utf8
 U8*
 Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len)
index 1c8f65d..1237497 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -651,6 +651,10 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
              PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
              if (tab)
               {
+              if (as && (ae == Nullch)) {
+               ae = e;
+               Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
+              }
                len = (as) ? (ae-(as++)-1) : 0;
                if (!PerlIO_push(f,tab,mode,as,len))
                 return -1;
index 25fe18a..aa50fbd 100644 (file)
@@ -182,6 +182,23 @@ must then use C<av_store> to assign values to these new elements.
 =for hackers
 Found in file av.c
 
+=item bytes_from_utf8
+
+Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
+the newly-created string, and updates C<len> to contain the new
+length.  Returns the original string if no conversion occurs, C<len>
+is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
+0 if C<s> is converted or contains all 7bit characters.
+
+NOTE: this function is experimental and may change or be
+removed without notice.
+
+       U8*     bytes_from_utf8(U8 *s, STRLEN *len, bool *is_utf8)
+
+=for hackers
+Found in file utf8.c
+
 =item bytes_to_utf8
 
 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
@@ -1465,60 +1482,6 @@ Tells a Perl interpreter to run.  See L<perlembed>.
 =for hackers
 Found in file perl.c
 
-=item PL_DBsingle
-
-When Perl is run in debugging mode, with the B<-d> switch, this SV is a
-boolean which indicates whether subs are being single-stepped.
-Single-stepping is automatically turned on after every step.  This is the C
-variable which corresponds to Perl's $DB::single variable.  See
-C<PL_DBsub>.
-
-       SV *    PL_DBsingle
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_DBsub
-
-When Perl is run in debugging mode, with the B<-d> switch, this GV contains
-the SV which holds the name of the sub being debugged.  This is the C
-variable which corresponds to Perl's $DB::sub variable.  See
-C<PL_DBsingle>.
-
-       GV *    PL_DBsub
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_DBtrace
-
-Trace variable used when Perl is run in debugging mode, with the B<-d>
-switch.  This is the C variable which corresponds to Perl's $DB::trace
-variable.  See C<PL_DBsingle>.
-
-       SV *    PL_DBtrace
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_dowarn
-
-The C variable which corresponds to Perl's $^W warning variable.
-
-       bool    PL_dowarn
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_last_in_gv
-
-The GV which was last used for a filehandle input operation. (C<< <FH> >>)
-
-       GV*     PL_last_in_gv
-
-=for hackers
-Found in file thrdvar.h
-
 =item PL_modglobal
 
 C<PL_modglobal> is a general purpose, interpreter global HV for use by
@@ -1544,24 +1507,6 @@ C<SvPV_nolen> macro.
 =for hackers
 Found in file thrdvar.h
 
-=item PL_ofs_sv
-
-The output field separator - C<$,> in Perl space.
-
-       SV*     PL_ofs_sv
-
-=for hackers
-Found in file thrdvar.h
-
-=item PL_rs
-
-The input record separator - C<$/> in Perl space.
-
-       SV*     PL_rs
-
-=for hackers
-Found in file thrdvar.h
-
 =item PL_sv_no
 
 This is the C<false> SV.  See C<PL_sv_yes>.  Always refer to this as
@@ -2420,19 +2365,19 @@ false, defined or undefined.  Does not handle 'get' magic.
 =for hackers
 Found in file sv.h
 
-=item svtype
+=item SvTYPE
 
-An enum of flags for Perl types.  These are found in the file B<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV.  See C<svtype>.
+
+       svtype  SvTYPE(SV* sv)
 
 =for hackers
 Found in file sv.h
 
-=item SvTYPE
-
-Returns the type of the SV.  See C<svtype>.
+=item svtype
 
-       svtype  SvTYPE(SV* sv)
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
 
 =for hackers
 Found in file sv.h
index 90475a9..06e3d14 100644 (file)
@@ -4,71 +4,121 @@ perlapio - perl's IO abstraction interface.
 
 =head1 SYNOPSIS
 
+    #define PERLIO_NOT_STDIO 0    /* For co-existence with stdio only */
+    #include <perlio.h>           /* Usually via #include <perl.h> */
+
     PerlIO *PerlIO_stdin(void);
     PerlIO *PerlIO_stdout(void);
     PerlIO *PerlIO_stderr(void);
 
-    PerlIO *PerlIO_open(const char *,const char *);
-    int     PerlIO_close(PerlIO *);
-
-    int     PerlIO_stdoutf(const char *,...)
-    int     PerlIO_puts(PerlIO *,const char *);
-    int     PerlIO_putc(PerlIO *,int);
-    int     PerlIO_write(PerlIO *,const void *,size_t);
-    int     PerlIO_printf(PerlIO *, const char *,...);
-    int     PerlIO_vprintf(PerlIO *, const char *, va_list);
-    int     PerlIO_flush(PerlIO *);
-
-    int     PerlIO_eof(PerlIO *);
-    int     PerlIO_error(PerlIO *);
-    void    PerlIO_clearerr(PerlIO *);
-
-    int     PerlIO_getc(PerlIO *);
-    int     PerlIO_ungetc(PerlIO *,int);
-    int     PerlIO_read(PerlIO *,void *,size_t);
-
-    int     PerlIO_fileno(PerlIO *);
-    PerlIO *PerlIO_fdopen(int, const char *);
-    PerlIO *PerlIO_importFILE(FILE *, int flags);
-    FILE   *PerlIO_exportFILE(PerlIO *, int flags);
-    FILE   *PerlIO_findFILE(PerlIO *);
-    void    PerlIO_releaseFILE(PerlIO *,FILE *);
-
-    void    PerlIO_setlinebuf(PerlIO *);
-
-    long    PerlIO_tell(PerlIO *);
-    int     PerlIO_seek(PerlIO *,off_t,int);
-    int     PerlIO_getpos(PerlIO *,Fpos_t *)
-    int     PerlIO_setpos(PerlIO *,Fpos_t *)
-    void    PerlIO_rewind(PerlIO *);
-
-    int     PerlIO_has_base(PerlIO *);
-    int     PerlIO_has_cntptr(PerlIO *);
-    int     PerlIO_fast_gets(PerlIO *);
-    int     PerlIO_canset_cnt(PerlIO *);
-
-    char   *PerlIO_get_ptr(PerlIO *);
-    int     PerlIO_get_cnt(PerlIO *);
-    void    PerlIO_set_cnt(PerlIO *,int);
-    void    PerlIO_set_ptrcnt(PerlIO *,char *,int);
-    char   *PerlIO_get_base(PerlIO *);
-    int     PerlIO_get_bufsiz(PerlIO *);
+    PerlIO *PerlIO_open(const char *path,const char *mode);
+    PerlIO *PerlIO_fdopen(int fd, const char *mode);
+    PerlIO *PerlIO_reopen(const char *path, const char *mode, PerlIO *old);  /* deprecated */
+    int     PerlIO_close(PerlIO *f);
+
+    int     PerlIO_stdoutf(const char *fmt,...)
+    int     PerlIO_puts(PerlIO *f,const char *string);
+    int     PerlIO_putc(PerlIO *f,int ch);
+    int     PerlIO_write(PerlIO *f,const void *buf,size_t numbytes);
+    int     PerlIO_printf(PerlIO *f, const char *fmt,...);
+    int     PerlIO_vprintf(PerlIO *f, const char *fmt, va_list args);
+    int     PerlIO_flush(PerlIO *f);
+
+    int     PerlIO_eof(PerlIO *f);
+    int     PerlIO_error(PerlIO *f);
+    void    PerlIO_clearerr(PerlIO *f);
+
+    int     PerlIO_getc(PerlIO *d);
+    int     PerlIO_ungetc(PerlIO *f,int ch);
+    int     PerlIO_read(PerlIO *f, void *buf, size_t numbytes);
+
+    int     PerlIO_fileno(PerlIO *f);
+
+    void    PerlIO_setlinebuf(PerlIO *f);
+
+    Off_t   PerlIO_tell(PerlIO *f);
+    int     PerlIO_seek(PerlIO *f, Off_t offset, int whence);
+    void    PerlIO_rewind(PerlIO *f);
+
+    int     PerlIO_getpos(PerlIO *f, SV *save);        /* prototype changed */
+    int     PerlIO_setpos(PerlIO *f, SV *saved);       /* prototype changed */
+
+    int     PerlIO_fast_gets(PerlIO *f);
+    int     PerlIO_has_cntptr(PerlIO *f);
+    int     PerlIO_get_cnt(PerlIO *f);
+    char   *PerlIO_get_ptr(PerlIO *f);
+    void    PerlIO_set_ptrcnt(PerlIO *f, char *ptr, int count);
+
+    int     PerlIO_canset_cnt(PerlIO *f);              /* deprecated */
+    void    PerlIO_set_cnt(PerlIO *f, int count);      /* deprecated */
+
+    int     PerlIO_has_base(PerlIO *f);
+    char   *PerlIO_get_base(PerlIO *f);
+    int     PerlIO_get_bufsiz(PerlIO *f);
+
+    PerlIO *PerlIO_importFILE(FILE *stdio, int flags);
+    FILE   *PerlIO_exportFILE(PerlIO *f, int flags);
+    FILE   *PerlIO_findFILE(PerlIO *f);
+    void    PerlIO_releaseFILE(PerlIO *f,FILE *stdio);
+
+    int     PerlIO_apply_layers(PerlIO *f, const char *mode, const char *layers);
+    int     PerlIO_binmode(PerlIO *f, int ptype, int imode, const char *layers);
+    void    PerlIO_debug(const char *fmt,...)
 
 =head1 DESCRIPTION
 
-Perl's source code should use the above functions instead of those
-defined in ANSI C's I<stdio.h>.  The perl headers will C<#define> them to
-the I/O mechanism selected at Configure time.
+Perl's source code, and extensions that want maximum portability, should use the above
+functions instead of those defined in ANSI C's I<stdio.h>.  The perl headers (in
+particular "perlio.h") will C<#define> them to the I/O mechanism selected at Configure time.
 
 The functions are modeled on those in I<stdio.h>, but parameter order
 has been "tidied up a little".
 
+C<PerlIO *> takes the place of FILE *. Like FILE * it should be treated as
+opaque (it is probably safe to assume it is a pointer to something).
+
+There are currently three implementations:
+
 =over 4
 
-=item B<PerlIO *>
+=item 1. USE_STDIO
 
-This takes the place of FILE *. Like FILE * it should be treated as
-opaque (it is probably safe to assume it is a pointer to something).
+All above are #define'd to stdio functions or are trivial wrapper functions which
+call stdio. In this case I<only> PerlIO * is a FILE *.
+This has been the default implementation since the abstraction was introduced
+in perl5.003_02.
+
+=item 2. USE_SFIO
+
+A "legacy" implementation in terms of the "sfio" library. Used for some specialist
+applications on Unix machines ("sfio" is not widely ported away from Unix).
+Most of above are #define'd to the sfio functions. PerlIO * is in this case Sfio_t *.
+
+=item 3. USE_PERLIO
+
+Introduced just after perl5.7.0 this is a re-implementation of the above abstraction
+which allows perl more control over how IO is done as it decouples IO from the
+way the operating system and C library choose to do things. For USE_PERLIO
+PerlIO * has an extra layer of indirection - it is a pointer-to-a-pointer.
+This allows the PerlIO * to remain with a known value while swapping the
+implementation arround underneath I<at run time>. In this case all the
+above are true (but very simple) functions which call the underlying implementation.
+
+This is the only implementation for which C<PerlIO_apply_layers()> does anything
+"interesting".
+
+The USE_PERLIO implementation is described in L<perliol>.
+
+=back
+
+Because "perlio.h" is a thing layer (for efficiency) the semantics of these functions are
+somewhat dependent on the the underlying implementation. Where these variations are
+understood they are noted below.
+
+Unless otherwise noted, functions return 0 on success, or a negative value (usually
+C<EOF> which is usually -1) and set C<errno> on error.
+
+=over 4
 
 =item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>
 
@@ -80,7 +130,20 @@ values.
 
 =item B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>
 
-These correspond to fopen()/fdopen() arguments are the same.
+These correspond to fopen()/fdopen() and the arguments are the same.
+Return C<NULL> and set C<errno> if there is an error.
+There may be an implementation limit on the number of open handles, which may
+be lower than the limit on the number of open files - C<errno> may
+not be set when C<NULL> is returned if this limnit is exceeded.
+
+=item B<PerlIO_reopen(path,mode,f)>
+
+While this currently exists in all three implementations perl itself
+does not use it. I<As perl does not use it, it is not well tested.>
+
+Perl prefers to C<dup> the new low-level descriptor to the descriptor used
+by the existing PerlIO. This may become the behaviour of this function
+in the future.
 
 =item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>
 
@@ -95,10 +158,16 @@ so it is (currently) legal to use C<printf(fmt,...)> in perl sources.
 
 These correspond to fread() and fwrite(). Note that arguments
 are different, there is only one "count" and order has
-"file" first.
+"file" first. Returns a byte count if successful (which may be zero),
+returns negative value and sets C<errno> on error.
+Depending on implementation C<errno> may be C<EINTR> if operation
+was interrupted by a signal.
 
 =item B<PerlIO_close(f)>
 
+Depending on implementation C<errno> may be C<EINTR> if operation
+was interrupted by a signal.
+
 =item B<PerlIO_puts(f,s)>, B<PerlIO_putc(f,c)>
 
 These correspond to fputs() and fputc().
@@ -108,56 +177,103 @@ Note that arguments have been revised to have "file" first.
 
 This corresponds to ungetc().
 Note that arguments have been revised to have "file" first.
+Arranges that next read operation will return the byte B<c>.
+Despite the implied "character" in the name only values in the
+range 0..0xFF are defined. Returns the byte B<c> on success or -1 (C<EOF>) on error.
+The number of bytes that can be "pushed back" may vary, only 1 character is
+certain, and then only if it is the last character that was read from the handle.
 
 =item B<PerlIO_getc(f)>
 
 This corresponds to getc().
+Despite the c in the name only byte range 0..0xFF is supported.
+Returns the character read or -1 (C<EOF>) on error.
 
 =item B<PerlIO_eof(f)>
 
 This corresponds to feof().
+Returns a true/false indication of whether the handle is at end of file.
+For terminal devices this may or may not be "sticky" depending on the implementation.
+The flag is cleared by PerlIO_seek(), or PerlIO_rewind().
 
 =item B<PerlIO_error(f)>
 
 This corresponds to ferror().
+Returns a true/false indication of whether there has been an IO error on the handle.
 
 =item B<PerlIO_fileno(f)>
 
 This corresponds to fileno(), note that on some platforms,
-the meaning of "fileno" may not match Unix.
+the meaning of "fileno" may not match Unix. Returns -1 if the handle has no
+open descriptor associated with it.
 
 =item B<PerlIO_clearerr(f)>
 
-This corresponds to clearerr(), i.e., clears 'eof' and 'error'
-flags for the "stream".
+This corresponds to clearerr(), i.e., clears 'error' and (usually) 'eof'
+flags for the "stream". Does not return a value.
 
 =item B<PerlIO_flush(f)>
 
 This corresponds to fflush().
+Sends any buffered write data to the underlying file.
+If called with C<NULL> this may flush all open streams (or core dump).
+Calling on a handle open for read only, or on which last operation was a read of some kind
+may lead to undefined behaviour.
 
-=item B<PerlIO_tell(f)>
+=item B<PerlIO_seek(f,offset,whence)>
 
-This corresponds to ftell().
+This corresponds to fseek().
+Sends buffered write data to the underlying file, or discards any buffered
+read data, then positions the file desciptor as specified by B<offset> and B<whence> (sic).
+This is the correct thing to do when switching between read and write on the same
+handle (see issues with PerlIO_flush() above).
+Offset is of type C<Off_t> which is a perl Configure value which may not be same
+as stdio's C<off_t>.
 
-=item B<PerlIO_seek(f,o,w)>
+=item B<PerlIO_tell(f)>
 
-This corresponds to fseek().
+This corresponds to ftell().
+Returns the current file position, or (Off_t) -1 on error.
+May just return value system "knows" without making a system call or checking
+the underlying file descriptor (so use on shared file descriptors is not
+safe without a PerlIO_seek()). Return value is of type C<Off_t> which is a perl Configure
+value which may not be same  as stdio's C<off_t>.
 
 =item B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>
 
-These correspond to fgetpos() and fsetpos(). If platform does not
-have the stdio calls then they are implemented in terms of PerlIO_tell()
-and PerlIO_seek().
+These correspond (loosely) to fgetpos() and fsetpos(). Rather than stdio's Fpos_t
+they expect a "Perl Scalar Value" to be passed. What is stored there should
+be considered opaque. The layout of the data may vary from handle to handle.
+When not using stdio or if platform does not have the stdio calls then they are
+implemented in terms of PerlIO_tell() and PerlIO_seek().
 
 =item B<PerlIO_rewind(f)>
 
-This corresponds to rewind(). Note may be redefined
-in terms of PerlIO_seek() at some point.
+This corresponds to rewind(). It is usually defined as being
+
+    PerlIO_seek(f,(Off_t)0L, SEEK_SET);
+    PerlIO_clearerr(f);
+
 
 =item B<PerlIO_tmpfile()>
 
 This corresponds to tmpfile(), i.e., returns an anonymous
-PerlIO which will automatically be deleted when closed.
+PerlIO  or NULL on error.
+The system will attempt to automatically delete the file when closed.
+On Unix the file is usually C<unlink>-ed just after
+it is created so it does not matter how it gets closed. On other systems the file may
+only be deleted if closed via PerlIO_close() and/or the program exits via C<exit>.
+Depending on the implementation there may be "race conditions" which allow other
+processes access to the file, though in general it will be safer in this regard
+than ad. hoc. schemes.
+
+=item B<PerlIO_setlinebuf(f)>
+
+This corresponds to setlinebuf().
+Does not return a value. What constitutes a "line" is implementation
+dependent but usually means that writing "\n" flushes the buffer.
+What happens with things like "this\nthat" is uncertain.
+(Perl core uses it I<only> when "dumping"; it has nothing to do with $| auto-flush.)
 
 =back
 
@@ -165,9 +281,19 @@ PerlIO which will automatically be deleted when closed.
 
 There is outline support for co-existence of PerlIO with stdio.
 Obviously if PerlIO is implemented in terms of stdio there is
-no problem. However if perlio is implemented on top of (say) sfio
-then mechanisms must exist to create a FILE * which can be passed
-to library code which is going to use stdio calls.
+no problem. However in other cases then mechanisms must exist to create a FILE *
+which can be passed to library code which is going to use stdio calls.
+
+The fisrt step is to add this line:
+
+   #define PERLIO_NOT_STDIO 0
+
+I<before> including any perl header files. (This will probably become the
+default at some point).  That prevents "perlio.h" from attempting to
+#define stdio functions onto PerlIO functions.
+
+XS code is probably better using "typemap" if it expects FILE * arguments.
+The standard typemap will be adjusted to comprehend any changes in this area.
 
 =over 4
 
@@ -176,9 +302,13 @@ to library code which is going to use stdio calls.
 Used to get a PerlIO * from a FILE *.
 May need additional arguments, interface under review.
 
+The flags argument was meant to be used for read vs write vs read/write
+information. In hindsight it would have been better to make it a char *mode
+as in fopen/freopen.
+
 =item B<PerlIO_exportFILE(f,flags)>
 
-Given an PerlIO * return a 'native' FILE * suitable for
+Given a PerlIO * return a 'native' FILE * suitable for
 passing to code expecting to be compiled and linked with
 ANSI C I<stdio.h>.
 
@@ -198,77 +328,157 @@ of FILE * is complete. It is removed from list of 'exported'
 FILE *s, and associated PerlIO * should revert to original
 behaviour.
 
-=item B<PerlIO_setlinebuf(f)>
-
-This corresponds to setlinebuf(). Use is deprecated pending
-further discussion. (Perl core uses it I<only> when "dumping";
-it has nothing to do with $| auto-flush.)
-
 =back
 
-In addition to user API above there is an "implementation" interface
+=head2 "Fast gets" Functions
+
+In addition to standard-like API defined so far above there is an "implementation" interface
 which allows perl to get at internals of PerlIO.
 The following calls correspond to the various FILE_xxx macros determined
-by Configure. This section is really of interest to only those
-concerned with detailed perl-core behaviour or implementing a
-PerlIO mapping.
+by Configure - or their equivalent in other implementations. This section is really of
+interest to only those concerned with detailed perl-core behaviour, implementing a
+PerlIO mapping or writing code which can make use of the "read ahead" that has been done by
+the IO system in the same way perl does. Note that any code that uses these interfaces
+must be prepared to do things the traditional way if a handle does not support
+them.
 
 =over 4
 
-=item B<PerlIO_has_cntptr(f)>
-
-Implementation can return pointer to current position in the "buffer" and
-a count of bytes available in the buffer.
+=item B<PerlIO_fast_gets(f)>
 
-=item B<PerlIO_get_ptr(f)>
+Returns true if implementation has all the interfaces required to
+allow perl's C<sv_gets> to "bypass" normal IO mechanism.
+This can vary from handle to handle.
 
-Return pointer to next readable byte in buffer.
+  PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \
+                        PerlIO_canset_cnt(f) && \
+                        `Can set pointer into buffer'
 
-=item B<PerlIO_get_cnt(f)>
 
-Return count of readable bytes in the buffer.
+=item B<PerlIO_has_cntptr(f)>
 
-=item B<PerlIO_canset_cnt(f)>
+Implementation can return pointer to current position in the "buffer" and
+a count of bytes available in the buffer.
+Do not use this - use PerlIO_fast_gets.
 
-Implementation can adjust its idea of number of
-bytes in the buffer.
+=item B<PerlIO_get_cnt(f)>
 
-=item B<PerlIO_fast_gets(f)>
+Return count of readable bytes in the buffer. Zero or negative return means
+no more bytes available.
 
-Implementation has all the interfaces required to
-allow perl's fast code to handle <FILE> mechanism.
+=item B<PerlIO_get_ptr(f)>
 
-  PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \
-                        PerlIO_canset_cnt(f) && \
-                        `Can set pointer into buffer'
+Return pointer to next readable byte in buffer, accessing via the pointer
+(dereferencing) is only safe if PerlIO_get_cnt() has returned a positive value.
+Only positive offsets up to value returned by PerlIO_get_cnt() are allowed.
 
 =item B<PerlIO_set_ptrcnt(f,p,c)>
 
 Set pointer into buffer, and a count of bytes still in the
 buffer. Should be used only to set
 pointer to within range implied by previous calls
-to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>.
+to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>. The two values I<must> be consistent
+with each other (implementation may only use one or the other or may require both).
+
+=item B<PerlIO_canset_cnt(f)>
+
+Implementation can adjust its idea of number of bytes in the buffer.
+Do not use this - use PerlIO_fast_gets.
 
 =item B<PerlIO_set_cnt(f,c)>
 
 Obscure - set count of bytes in the buffer. Deprecated.
-Currently used in only doio.c to force count < -1 to -1.
+Only usable if PerlIO_canset_cnt() returns true.
+Currently used in only doio.c to force count less than -1 to -1.
 Perhaps should be PerlIO_set_empty or similar.
 This call may actually do nothing if "count" is deduced from pointer
 and a "limit".
+Do not use this - use PerlIO_set_ptrcnt().
 
 =item B<PerlIO_has_base(f)>
 
-Implementation has a buffer, and can return pointer
+Returns true if implementation has a buffer, and can return pointer
 to whole buffer and its size. Used by perl for B<-T> / B<-B> tests.
 Other uses would be very obscure...
 
 =item B<PerlIO_get_base(f)>
 
-Return I<start> of buffer.
+Return I<start> of buffer. Access only positive offsets in the buffer
+up to the value returned by PerlIO_get_bufsiz().
 
 =item B<PerlIO_get_bufsiz(f)>
 
-Return I<total size> of buffer.
+Return the I<total number of bytes> in the buffer, this is neither the number
+that can be read, nor the amount of memory allocated to the buffer. Rather
+it is what the operating system and/or implementation happened to C<read()>
+(or whatever) last time IO was requested.
+
+=back
+
+=head2 Other Functions
+
+=over 4
+
+=item PerlIO_apply_layers(f,mode,layers)
+
+The new interface to the USE_PERLIO implementation. The layers ":crlf"
+and ":raw" are only ones allowed for other implementations and those
+are silently ignored. Use PerlIO_binmode() below for the portable
+case.
+
+=item PerlIO_binmode(f,ptype,imode,layers)
+
+The hook used by perl's C<binmode> operator.
+B<ptype> is perl's charcter for the kind of IO:
+
+=over 8
+
+=item 'E<lt>' read
+
+=item 'E<gt>' write
+
+=item '+' read/write
+
+=back
+
+B<imode> is C<O_BINARY> or C<O_TEXT>.
+
+B<layers> is a string of layers to apply, only ":raw" or :"crlf" make
+sense in the non USE_PERLIO case.
+
+Portable cases are:
+
+    PerlIO_binmode(f,ptype,O_BINARY,":raw");
+and
+    PerlIO_binmode(f,ptype,O_TEXT,":crlf");
+
+On Unix these calls probably have no effect whatsoever.
+Elsewhere they alter "\n" to CR,LF translation and possibly cause a special
+text "end of file" indicator to be written or honoured on read. The effect of
+making the call after doing any IO to the handle depends on the implementation. (It may be
+ignored, affect any data which is already buffered as well, or only apply
+to subsequent data.)
+
+=item PerlIO_debug(fmt,...)
+
+PerlIO_debug is a printf()-like function which can be used for debugging.
+No return value. Its main use is inside PerlIO where using real printf, warn() etc. would
+recursively call PerlIO and be a problem.
+
+PerlIO_debug writes to the file named by $ENV{'PERLIO_DEBUG'} typical use
+might be
+
+  Bourne shells:
+   PERLIO_DEBUG=/dev/tty ./perl somescript some args
+
+  Csh:
+   setenv PERLIO_DEBUG /dev/tty
+   ./perl somescript some args
+
+  Win32:
+   set PERLIO_DEBUG=CON
+   perl somescript some args
+
+If $ENV{'PERLIO_DEBUG'} is not set PerlIO_debug() is a no-op.
 
 =back
index b549f45..3c18246 100644 (file)
@@ -790,9 +790,13 @@ Hopefully, this gets you started, though.
 
 For more information, see L<perlobj> (for all the gritty details about
 Perl objects, now that you've seen the basics), L<perltoot> (the
-tutorial for those who already know objects), L<perlbot> (for some
-more tricks), and books such as Damian Conway's excellent I<Object
-Oriented Perl>.
+tutorial for those who already know objects), L<perltootc> (dealing
+with class data), L<perlbot> (for some more tricks), and books such as
+Damian Conway's excellent I<Object Oriented Perl>.
+
+Some modules which might prove interesting are Class::Accessor,
+Class::Class, Class::Contract, Class::Data::Inheritable,
+Class::MethodMaker and Tie::SecureHash
 
 =head1 COPYRIGHT
 
index 597473f..c142367 100644 (file)
@@ -2602,6 +2602,16 @@ the problem, however, you will get the same error message each time
 you run Perl.  How to really fix the problem can be found in
 L<perllocale> section B<LOCALE PROBLEMS>.
 
+=item perlio: argument list not closed for layer "%s"
+
+(S) When pusing a layer with arguments onto the Perl I/O system you forgot
+the ) that closes the argument list.  (Layers take care of transforming
+data between external and internal representations.)  Perl assumed that
+the argument list finished at the next : or the end of the layer
+specification. If your program didn't explicitly request the failing
+operation, it may be the result of the value of the environment variable
+PERLIO.
+
 =item perlio: unknown layer "%s"
 
 (S) An attempt was made to push an unknown layer onto the Perl I/O
@@ -3557,8 +3567,7 @@ bad switch on your behalf.)
 
 (W newline) A file operation was attempted on a filename, and that
 operation failed, PROBABLY because the filename contained a newline,
-PROBABLY because you forgot to chop() or chomp() it off.  See
-L<perlfunc/chomp>.
+PROBABLY because you forgot to chomp() it off.  See L<perlfunc/chomp>.
 
 =item Unsupported directory function "%s" called
 
index 4cd945b..9552ecf 100644 (file)
@@ -489,23 +489,21 @@ Other starting points include
     http://conference.perl.com/
     http://reference.perl.com/
 
-Perl Mongers is an advocacy organization for the Perl language.  For
-details, see the Perl Mongers web site at http://www.perlmongers.org/.
+Perl Mongers is an advocacy organization for the Perl language which
+maintains the web site http://www.perl.org/ as a general advocacy
+site for the Perl language, with many sub-domains for special topics,
+including
+
+    http://history.perl.org/
+    http://bugs.perl.org/
+    http://use.perl.org/
 
 Perl Mongers uses the pm.org domain for services related to Perl user
-groups.  See the Perl user group web site at http://www.pm.org/ for more
-information about joining, starting, or requesting services for a Perl
-user group.
+groups, including the hosting of mailing lists and web sites.  See the
+Perl user group web site at http://www.pm.org/ for more information about
+joining, starting, or requesting services for a Perl user group.
 
-Perl Mongers also maintains the perl.org domain to provide general
-support services to the Perl community, including the hosting of mailing
-lists, web sites, and other services.  The web site
-http://www.perl.org/ is a general advocacy site for the Perl language,
-and there are many other sub-domains for special topics, such as
 
-    http://history.perl.org/
-    http://bugs.perl.org/
-    http://www.news.perl.org/
 
 =head1 AUTHOR AND COPYRIGHT
 
index d806ed6..1df3b6a 100644 (file)
@@ -321,7 +321,7 @@ go bump in the night, finally came up with this:
        # been opened on a pipe...
        system("/bin/stty $stty");
        $_ = <MODEM_IN>;
-       chop;
+       chomp;
        if ( !m/^Connected/ ) {
            print STDERR "$0: cu printed `$_' instead of `Connected'\n";
        }
index 0d620d9..c75818e 100644 (file)
@@ -301,7 +301,7 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C>
 Example:
 
     while (<>) {
-       chop;
+       chomp;
        next unless -f $_;      # ignore specials
        #...
     }
@@ -630,23 +630,11 @@ characters removed is returned.
 =item chop
 
 Chops off the last character of a string and returns the character
-chopped.  It's used primarily to remove the newline from the end of an
-input record, but is much more efficient than C<s/\n//> because it neither
+chopped.  It is much more efficient than C<s/.$//s> because it neither
 scans nor copies the string.  If VARIABLE is omitted, chops C<$_>.
-Example:
-
-    while (<>) {
-       chop;   # avoid \n on last field
-       @array = split(/:/);
-       #...
-    }
-
 If VARIABLE is a hash, it chops the hash's values, but not its keys.
 
-You can actually chop anything that's an lvalue, including an assignment:
-
-    chop($cwd = `pwd`);
-    chop($answer = <STDIN>);
+You can actually chop anything that's an lvalue, including an assignment.
 
 If you chop a list, each element is chopped.  Only the value of the
 last C<chop> is returned.
@@ -4443,13 +4431,12 @@ Example:
 
     open(PASSWD, '/etc/passwd');
     while (<PASSWD>) {
-       ($login, $passwd, $uid, $gid,
+        chomp;
+        ($login, $passwd, $uid, $gid,
          $gcos, $home, $shell) = split(/:/);
        #...
     }
 
-(Note that $shell above will still have a newline on it.  See L</chop>,
-L</chomp>, and L</join>.)
 
 =item sprintf FORMAT, LIST
 
@@ -5524,7 +5511,7 @@ by C<use>, i.e., it calls C<unimport Module LIST> instead of C<import>.
 
 If no C<unimport> method can be found the call fails with a fatal error.
 
-See L<perlmod> for a list of standard modules and pragmas.  See L<perlrun>
+See L<perlmodlib> for a list of standard modules and pragmas.  See L<perlrun>
 for the C<-M> and C<-m> command-line options to perl that give C<use>
 functionality from the command-line.
 
index 924e993..8ff4a84 100644 (file)
@@ -1357,22 +1357,22 @@ function).
 Here is a handy table of equivalents between ordinary C and Perl's
 memory abstraction layer:
 
-    Instead Of:                        Use:
-
-    t* p = malloc(n)           New(id, p, n, t)
-    t* p = calloc(n, s)                Newz(id, p, n, t)
-    p = realloc(p, n)          Renew(p, n, t)
-    memcpy(dst, src, n)                Copy(src, dst, n, t)
-    memmove(dst, src, n)       Move(src, dst, n, t)
-    free(p)                    Safefree(p)
-    strdup(p)                  savepv(p)
-    strndup(p, n)              savepvn(p, n) (Hey, strndup doesn't exist!)
-    memcpy/*(struct foo *)     StructCopy(src, dst, t)
-
-    t  type
-    p  pointer
-    ck cookie for the memory region (now unused)
-    n  number of elements
+    Instead Of:                 Use:
+
+    t* p = malloc(n)            New(id, p, n, t)
+    t* p = calloc(n, s)         Newz(id, p, n, t)
+    p = realloc(p, n)           Renew(p, n, t)
+    memcpy(dst, src, n)         Copy(src, dst, n, t)
+    memmove(dst, src, n)        Move(src, dst, n, t)
+    free(p)                     Safefree(p)
+    strdup(p)                   savepv(p)
+    strndup(p, n)               savepvn(p, n) (Hey, strndup doesn't exist!)
+    memcpy/*(struct foo *)      StructCopy(src, dst, t)
+
+    t   type
+    p   pointer
+    ck  cookie for the memory region (now unused)
+    n   number of elements
     src source pointer
     dst destination pointer
 
@@ -1721,10 +1721,10 @@ is normally hidden via macros.  Consider C<sv_setsv>.  It expands
 something like this:
 
     ifdef PERL_IMPLICIT_CONTEXT
-      define sv_setsv(a,b)     Perl_sv_setsv(aTHX_ a, b)
+      define sv_setsv(a,b)      Perl_sv_setsv(aTHX_ a, b)
       /* can't do this for vararg functions, see below */
     else
-      define sv_setsv          Perl_sv_setsv
+      define sv_setsv           Perl_sv_setsv
     endif
 
 This works well, and means that XS authors can gleefully write:
@@ -1799,31 +1799,31 @@ work.
 The second, more efficient way is to use the following template for
 your Foo.xs:
 
-       #define PERL_NO_GET_CONTEXT     /* we want efficiency */
-       #include "EXTERN.h"
-       #include "perl.h"
-       #include "XSUB.h"
+        #define PERL_NO_GET_CONTEXT     /* we want efficiency */
+        #include "EXTERN.h"
+        #include "perl.h"
+        #include "XSUB.h"
 
         static my_private_function(int arg1, int arg2);
 
-       static SV *
-       my_private_function(int arg1, int arg2)
-       {
-           dTHX;       /* fetch context */
-           ... call many Perl API functions ...
-       }
+        static SV *
+        my_private_function(int arg1, int arg2)
+        {
+            dTHX;       /* fetch context */
+            ... call many Perl API functions ...
+        }
 
         [... etc ...]
 
-       MODULE = Foo            PACKAGE = Foo
+        MODULE = Foo            PACKAGE = Foo
 
-       /* typical XSUB */
+        /* typical XSUB */
 
-       void
-       my_xsub(arg)
-               int arg
-           CODE:
-               my_private_function(arg, 10);
+        void
+        my_xsub(arg)
+                int arg
+            CODE:
+                my_private_function(arg, 10);
 
 Note that the only two changes from the normal way of writing an
 extension is the addition of a C<#define PERL_NO_GET_CONTEXT> before
@@ -1838,32 +1838,32 @@ The third, even more efficient way is to ape how it is done within
 the Perl guts:
 
 
-       #define PERL_NO_GET_CONTEXT     /* we want efficiency */
-       #include "EXTERN.h"
-       #include "perl.h"
-       #include "XSUB.h"
+        #define PERL_NO_GET_CONTEXT     /* we want efficiency */
+        #include "EXTERN.h"
+        #include "perl.h"
+        #include "XSUB.h"
 
         /* pTHX_ only needed for functions that call Perl API */
         static my_private_function(pTHX_ int arg1, int arg2);
 
-       static SV *
-       my_private_function(pTHX_ int arg1, int arg2)
-       {
-           /* dTHX; not needed here, because THX is an argument */
-           ... call Perl API functions ...
-       }
+        static SV *
+        my_private_function(pTHX_ int arg1, int arg2)
+        {
+            /* dTHX; not needed here, because THX is an argument */
+            ... call Perl API functions ...
+        }
 
         [... etc ...]
 
-       MODULE = Foo            PACKAGE = Foo
+        MODULE = Foo            PACKAGE = Foo
 
-       /* typical XSUB */
+        /* typical XSUB */
 
-       void
-       my_xsub(arg)
-               int arg
-           CODE:
-               my_private_function(aTHX_ arg, 10);
+        void
+        my_xsub(arg)
+                int arg
+            CODE:
+                my_private_function(aTHX_ arg, 10);
 
 This implementation never has to fetch the context using a function
 call, since it is always passed as an extra argument.  Depending on
@@ -1990,18 +1990,18 @@ If you are printing IVs, UVs, or NVS instead of the stdio(3) style
 formatting codes like C<%d>, C<%ld>, C<%f>, you should use the
 following macros for portability
 
-       IVdf            IV in decimal
-       UVuf            UV in decimal
-       UVof            UV in octal
-       UVxf            UV in hexadecimal
-       NVef            NV %e-like
-       NVff            NV %f-like
-       NVgf            NV %g-like
+        IVdf            IV in decimal
+        UVuf            UV in decimal
+        UVof            UV in octal
+        UVxf            UV in hexadecimal
+        NVef            NV %e-like
+        NVff            NV %f-like
+        NVgf            NV %g-like
 
 These will take care of 64-bit integers and long doubles.
 For example:
 
-       printf("IV is %"IVdf"\n", iv);
+        printf("IV is %"IVdf"\n", iv);
 
 The IVdf will expand to whatever is the correct format for the IVs.
 
@@ -2013,20 +2013,20 @@ with PTR2UV(), do not use %lx or %p.
 Because pointer size does not necessarily equal integer size,
 use the follow macros to do it right.
 
-       PTR2UV(pointer)
-       PTR2IV(pointer)
-       PTR2NV(pointer)
-       INT2PTR(pointertotype, integer)
+        PTR2UV(pointer)
+        PTR2IV(pointer)
+        PTR2NV(pointer)
+        INT2PTR(pointertotype, integer)
 
 For example:
 
-       IV  iv = ...;
-       SV *sv = INT2PTR(SV*, iv);
+        IV  iv = ...;
+        SV *sv = INT2PTR(SV*, iv);
 
 and
 
-       AV *av = ...;
-       UV  uv = PTR2UV(av);
+        AV *av = ...;
+        UV  uv = PTR2UV(av);
 
 =head2 Source Documentation
 
index 6af18b5..8bfe5a3 100644 (file)
@@ -46,6 +46,78 @@ True if this op will be the return value of an lvalue subroutine
 =for hackers
 Found in file pp.h
 
+=item PL_DBsingle
+
+When Perl is run in debugging mode, with the B<-d> switch, this SV is a
+boolean which indicates whether subs are being single-stepped.
+Single-stepping is automatically turned on after every step.  This is the C
+variable which corresponds to Perl's $DB::single variable.  See
+C<PL_DBsub>.
+
+       SV *    PL_DBsingle
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_DBsub
+
+When Perl is run in debugging mode, with the B<-d> switch, this GV contains
+the SV which holds the name of the sub being debugged.  This is the C
+variable which corresponds to Perl's $DB::sub variable.  See
+C<PL_DBsingle>.
+
+       GV *    PL_DBsub
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_DBtrace
+
+Trace variable used when Perl is run in debugging mode, with the B<-d>
+switch.  This is the C variable which corresponds to Perl's $DB::trace
+variable.  See C<PL_DBsingle>.
+
+       SV *    PL_DBtrace
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
+       bool    PL_dowarn
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_last_in_gv
+
+The GV which was last used for a filehandle input operation. (C<< <FH> >>)
+
+       GV*     PL_last_in_gv
+
+=for hackers
+Found in file thrdvar.h
+
+=item PL_ofs_sv
+
+The output field separator - C<$,> in Perl space.
+
+       SV*     PL_ofs_sv
+
+=for hackers
+Found in file thrdvar.h
+
+=item PL_rs
+
+The input record separator - C<$/> in Perl space.
+
+       SV*     PL_rs
+
+=for hackers
+Found in file thrdvar.h
+
 =item start_glob
 
 Function called by C<do_readline> to spawn a glob (or do the glob inside
diff --git a/pod/perliol.pod b/pod/perliol.pod
new file mode 100644 (file)
index 0000000..ac6a4a2
--- /dev/null
@@ -0,0 +1,531 @@
+
+=head1 NAME
+
+perliol - C API for Perl's implementation of IO in Layers.
+
+=head1 SYNOPSIS
+
+    /* Defining a layer ... */
+    #include <perliol.h>
+
+
+=head1 DESCRIPTION
+
+This document describes the behavior and implementation of the PerlIO
+abstraction described in L<perlapio> when C<USE_PERLIO> is defined (and
+C<USE_SFIO> is not).
+
+=head2 History and Background
+
+The PerlIO abstraction was introduced in perl5.003_02 but languished as
+just an abstraction until perl5.7.0. However during that time a number
+of perl extentions switched to using it, so the API is mostly fixed to
+maintain (source) compatibility.
+
+The aim of the implementation is to provide the PerlIO API in a flexible
+and platform neutral manner. It is also a trial of an "Object Oriented
+C, with vtables" approach which may be applied to perl6.
+
+=head2 Layers vs Disciplines
+
+Initial discussion of the ability to modify IO streams behaviour used
+the term "discipline" for the entities which were added. This came (I
+believe) from the use of the term in "sfio", which in turn borrowed it
+from "line disciplines" on Unix terminals. However, this document (and
+the C code) uses the term "layer".
+
+This is, I hope, a natural term given the implementation, and should avoid
+connotations that are inherent in earlier uses of "discipline" for things
+which are rather different.
+
+=head2 Data Structures
+
+The basic data structure is a PerlIOl:
+
+       typedef struct _PerlIO PerlIOl;
+       typedef struct _PerlIO_funcs PerlIO_funcs;
+       typedef PerlIOl *PerlIO;
+
+       struct _PerlIO
+       {
+        PerlIOl *      next;       /* Lower layer */
+        PerlIO_funcs * tab;        /* Functions for this layer */
+        IV             flags;      /* Various flags for state */
+       };
+
+A C<PerlIOl *> is a pointer to to the struct, and the I<application> level
+C<PerlIO *> is a pointer to a C<PerlIOl *> - i.e. a pointer to a pointer to
+the struct. This allows the application level C<PerlIO *> to remain
+constant while the actual C<PerlIOl *> underneath changes. (Compare perl's
+C<SV *> which remains constant while its C<sv_any> field changes as the
+scalar's type changes.) An IO stream is then in general represented as a
+pointer to this linked-list of "layers".
+
+It should be noted that because of the double indirection in a C<PerlIO *>,
+a C<< &(perlio-E<gt>next) >> "is" a C<PerlIO *>, and so to some degree
+at least one layer can use the "standard" API on the next layer down.
+
+A "layer" is composed of two parts:
+
+=over 4
+
+=item 1. The functions and attributes of the "layer class".
+
+=item 2. The per-instance data for a particular handle.
+
+=back
+
+=head2 Functions and Attributes
+
+The functions and attributes are accessed via the "tab" (for table)
+member of C<PerlIOl>. The functions (methods of the layer "class") are
+fixed, and are defined by the C<PerlIO_funcs> type. They are broadly the
+same as the public C<PerlIO_xxxxx> functions:
+
+       struct _PerlIO_funcs
+       {
+        char *         name;
+        Size_t         size;
+        IV             kind;
+        IV             (*Fileno)(PerlIO *f);
+        PerlIO *       (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
+        PerlIO *       (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
+        int            (*Reopen)(const char *path, const char *mode, PerlIO *f);
+        IV             (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
+        IV             (*Popped)(PerlIO *f);
+        /* Unix-like functions - cf sfio line disciplines */
+        SSize_t        (*Read)(PerlIO *f, void *vbuf, Size_t count);
+        SSize_t        (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
+        SSize_t        (*Write)(PerlIO *f, const void *vbuf, Size_t count);
+        IV             (*Seek)(PerlIO *f, Off_t offset, int whence);
+        Off_t          (*Tell)(PerlIO *f);
+        IV             (*Close)(PerlIO *f);
+        /* Stdio-like buffered IO functions */
+        IV             (*Flush)(PerlIO *f);
+        IV             (*Fill)(PerlIO *f);
+        IV             (*Eof)(PerlIO *f);
+        IV             (*Error)(PerlIO *f);
+        void           (*Clearerr)(PerlIO *f);
+        void           (*Setlinebuf)(PerlIO *f);
+        /* Perl's snooping functions */
+        STDCHAR *      (*Get_base)(PerlIO *f);
+        Size_t         (*Get_bufsiz)(PerlIO *f);
+        STDCHAR *      (*Get_ptr)(PerlIO *f);
+        SSize_t        (*Get_cnt)(PerlIO *f);
+        void           (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
+       };
+
+The first few members of the struct give a "name" for the layer, the
+size to C<malloc> for the per-instance data, and some flags which are
+attributes of the class as whole (such as whether it is a buffering
+layer), then follow the functions which fall into four basic groups:
+
+=over 4
+
+=item 1. Opening and setup functions
+
+=item 2. Basic IO operations
+
+=item 3. Stdio class buffering options.
+
+=item 4. Functions to support Perl's traditional "fast" access to the buffer.
+
+=back
+
+A layer does not have to implement all the functions, but the whole table has
+to be present. Unimplemented slots can be NULL (which will will result in an error
+when called) or can be filled in with stubs to "inherit" behaviour from
+a "base class". This "inheritance" is fixed for all instances of the layer,
+but as the layer chooses which stubs to populate the table, limited
+"multiple inheritance" is possible.
+
+=head2 Per-instance Data
+
+The per-instance data are held in memory beyond the basic PerlIOl struct,
+by making a PerlIOl the first member of the layer's struct thus:
+
+       typedef struct
+       {
+        struct _PerlIO base;       /* Base "class" info */
+        STDCHAR *      buf;        /* Start of buffer */
+        STDCHAR *      end;        /* End of valid part of buffer */
+        STDCHAR *      ptr;        /* Current position in buffer */
+        Off_t          posn;       /* Offset of buf into the file */
+        Size_t         bufsiz;     /* Real size of buffer */
+        IV             oneword;    /* Emergency buffer */
+       } PerlIOBuf;
+
+In this way (as for perl's scalars) a pointer to a PerlIOBuf can be treated
+as a pointer to a PerlIOl.
+
+=head2 Layers in action.
+
+                table           perlio          unix
+            |           |
+            +-----------+    +----------+    +--------+
+   PerlIO ->|           |--->|  next    |--->|  NULL  |
+            +-----------+    +----------+    +--------+
+            |           |    |  buffer  |    |   fd   |
+            +-----------+    |          |    +--------+
+            |           |    +----------+
+
+
+The above attempts to show how the layer scheme works in a simple case.
+The application's C<PerlIO *> points to an entry in the table(s)
+representing open (allocated) handles. For example the first three slots
+in the table correspond to C<stdin>,C<stdout> and C<stderr>. The table
+in turn points to the current "top" layer for the handle - in this case
+an instance of the generic buffering layer "perlio". That layer in turn
+points to the next layer down - in this case the lowlevel "unix" layer.
+
+The above is roughly equivalent to a "stdio" buffered stream, but with
+much more flexibility:
+
+=over 4
+
+=item *
+
+If Unix level C<read>/C<write>/C<lseek> is not appropriate for (say)
+sockets then the "unix" layer can be replaced (at open time or even
+dynamically) with a "socket" layer.
+
+=item *
+
+Different handles can have different buffering schemes. The "top" layer
+could be the "mmap" layer if reading disk files was quicker using C<mmap>
+than C<read>. An "unbuffered" stream can be implemented simply by
+not having a buffer layer.
+
+=item *
+
+Extra layers can be inserted to process the data as it flows through.
+This was the driving need for including the scheme in perl 5.7.0+ - we
+needed a mechanism to allow data to be translated bewteen perl's
+internal encoding (conceptually at least Unicode as UTF-8), and the
+"native" format used by the system. This is provided by the
+":encoding(xxxx)" layer which typically sits above the buffering layer.
+
+=item *
+
+A layer can be added that does "\n" to CRLF translation. This layer can be used
+on any platform, not just those that normally do such things.
+
+=back
+
+=head2 Per-instance flag bits
+
+The generic flag bits are a hybrid of C<O_XXXXX> style flags deduced from
+the mode string passed to C<PerlIO_open()>, and state bits for typical buffer
+layers.
+
+=over 4
+
+=item PERLIO_F_EOF
+
+End of file.
+
+=item PERLIO_F_CANWRITE
+
+Writes are permitted, i.e. opened as "w" or "r+" or "a", etc.
+
+=item  PERLIO_F_CANREAD
+
+Reads are permitted i.e. opened "r" or "w+" (or even "a+" - ick).
+
+=item PERLIO_F_ERROR
+
+An error has occured (for C<PerlIO_error()>)
+
+=item PERLIO_F_TRUNCATE
+
+Truncate file suggested by open mode.
+
+=item PERLIO_F_APPEND
+
+All writes should be appends.
+
+=item PERLIO_F_CRLF
+
+Layer is performing Win32-like "\n" mapped to CR,LF for output and CR,LF
+mapped to "\n" for input. Normally the provided "crlf" layer is the only
+layer that need bother about this. C<PerlIO_binmode()> will mess with this
+flag rather than add/remove layers if the C<PERLIO_K_CANCRLF> bit is set
+for the layers class.
+
+=item PERLIO_F_UTF8
+
+Data written to this layer should be UTF-8 encoded; data provided
+by this layer should be considered UTF-8 encoded. Can be set on any layer
+by ":utf8" dummy layer. Also set on ":encoding" layer.
+
+=item PERLIO_F_UNBUF
+
+Layer is unbuffered - i.e. write to next layer down should occur for
+each write to this layer.
+
+=item PERLIO_F_WRBUF
+
+The buffer for this layer currently holds data written to it but not sent
+to next layer.
+
+=item PERLIO_F_RDBUF
+
+The buffer for this layer currently holds unconsumed data read from
+layer below.
+
+=item PERLIO_F_LINEBUF
+
+Layer is line buffered. Write data should be passed to next layer down
+whenever a "\n" is seen. Any data beyond the "\n" should then be
+processed.
+
+=item PERLIO_F_TEMP
+
+File has been C<unlink()>ed, or should be deleted on C<close()>.
+
+=item PERLIO_F_OPEN
+
+Handle is open.
+
+=item PERLIO_F_FASTGETS
+
+This instance of this layer supports the "fast C<gets>" interface.
+Normally set based on C<PERLIO_K_FASTGETS> for the class and by the
+existance of the function(s) in the table. However a class that
+normally provides that interface may need to avoid it on a
+particular instance. The "pending" layer needs to do this when
+it is pushed above an layer which does not support the interface.
+(Perl's C<sv_gets()> does not expect the streams fast C<gets> behaviour
+to change during one "get".)
+
+=back
+
+=head2 Methods in Detail
+
+=over 4
+
+=item IV       (*Fileno)(PerlIO *f);
+
+Returns the Unix/Posix numeric file decriptor for the handle. Normally
+C<PerlIOBase_fileno()> (which just asks next layer down) will suffice
+for this.
+
+=item  PerlIO *        (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
+
+Should (perhaps indirectly) call C<PerlIO_allocate()> to allocate a slot
+in the table and associate it with the given numeric file descriptor,
+which will be open in an manner compatible with the supplied mode string.
+
+=item  PerlIO *        (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
+
+Should attempt to open the given path and if that succeeds then (perhaps
+indirectly) call C<PerlIO_allocate()> to allocate a slot in the table and
+associate it with the layers information for the opened file.
+
+=item  int             (*Reopen)(const char *path, const char *mode, PerlIO *f);
+
+Re-open the supplied C<PerlIO *> to connect it to C<path> in C<mode>.
+Returns as success flag. Perl does not use this and L<perlapio> marks it
+as subject to change.
+
+=item  IV              (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
+
+Called when the layer is pushed onto the stack. The C<mode> argument may
+be NULL if this occurs post-open. The C<arg> and C<len> will be present
+if an argument string was passed. In most cases this should call
+C<PerlIOBase_pushed()> to convert C<mode> into the appropriate
+C<PERLIO_F_XXXXX> flags in addition to any actions the layer itself takes.
+
+=item  IV              (*Popped)(PerlIO *f);
+
+Called when the layer is popped from the stack. A layer will normally be
+popped after C<Close()> is called. But a layer can be popped without being
+closed if the program is dynamically managing layers on the stream. In
+such cases C<Popped()> should free any resources (buffers, translation
+tables, ...) not held directly in the layer's struct.
+
+=item  SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
+
+Basic read operation. Returns actual bytes read, or -1 on an error.
+Typically will call Fill and manipulate pointers (possibly via the API).
+C<PerlIOBuf_read()> may be suitable for derived classes which provide
+"fast gets" methods.
+
+=item  SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
+
+A superset of stdio's C<ungetc()>. Should arrange for future reads to
+see the bytes in C<vbuf>. If there is no obviously better implementation
+then C<PerlIOBase_unread()> provides the function by pushing a "fake"
+"pending" layer above the calling layer.
+
+=item  SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
+
+Basic write operation. Returns bytes written or -1 on an error.
+
+=item  IV              (*Seek)(PerlIO *f, Off_t offset, int whence);
+
+Position the file pointer. Should normally call its own C<Flush> method and
+then the C<Seek> method of next layer down.
+
+=item  Off_t           (*Tell)(PerlIO *f);
+
+Return the file pointer. May be based on layers cached concept of
+position to avoid overhead.
+
+=item  IV              (*Close)(PerlIO *f);
+
+Close the stream. Should normally call C<PerlIOBase_close()> to flush
+itself and close layers below, and then deallocate any data structures
+(buffers, translation tables, ...) not  held directly in the data
+structure.
+
+=item  IV              (*Flush)(PerlIO *f);
+
+Should make stream's state consistent with layers below. That is, any
+buffered write data should be written, and file position of lower layers
+adjusted for data read fron below but not actually consumed.
+
+=item  IV              (*Fill)(PerlIO *f);
+
+The buffer for this layer should be filled (for read) from layer below.
+
+=item  IV              (*Eof)(PerlIO *f);
+
+Return end-of-file indicator. C<PerlIOBase_eof()> is normally sufficient.
+
+=item  IV              (*Error)(PerlIO *f);
+
+Return error indicator. C<PerlIOBase_error()> is normally sufficient.
+
+=item  void            (*Clearerr)(PerlIO *f);
+
+Clear end-of-file and error indicators. Should call C<PerlIOBase_clearerr()>
+to set the C<PERLIO_F_XXXXX> flags, which may suffice.
+
+=item  void            (*Setlinebuf)(PerlIO *f);
+
+Mark the stream as line buffered.
+
+=item  STDCHAR *       (*Get_base)(PerlIO *f);
+
+Allocate (if not already done so) the read buffer for this layer and
+return pointer to it.
+
+=item  Size_t          (*Get_bufsiz)(PerlIO *f);
+
+Return the number of bytes that last C<Fill()> put in the buffer.
+
+=item  STDCHAR *       (*Get_ptr)(PerlIO *f);
+
+Return the current read pointer relative to this layer's buffer.
+
+=item  SSize_t (*Get_cnt)(PerlIO *f);
+
+Return the number of bytes left to be read in the current buffer.
+
+=item  void            (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
+
+Adjust the read pointer and count of bytes to match C<ptr> and/or C<cnt>.
+The application (or layer above) must ensure they are consistent.
+(Checking is allowed by the paranoid.)
+
+=back
+
+
+=head2 Core Layers
+
+The file C<perlio.c> provides the following layers:
+
+=over 4
+
+=item "unix"
+
+A basic non-buffered layer which calls Unix/POSIX C<read()>, C<write()>,
+C<lseek()>, C<close()>. No buffering. Even on platforms that distinguish
+between O_TEXT and O_BINARY this layer is always O_BINARY.
+
+=item "perlio"
+
+A very complete generic buffering layer which provides the whole of
+PerlIO API. It is also intended to be used as a "base class" for other
+layers. (For example its C<Read()> method is implemented in terms of the
+C<Get_cnt()>/C<Get_ptr()>/C<Set_ptrcnt()> methods).
+
+"perlio" over "unix" provides a complete replacement for stdio as seen
+via PerlIO API. This is the default for USE_PERLIO when system's stdio
+does not permit perl's "fast gets" access, and which do not distinguish
+between C<O_TEXT> and C<O_BINARY>.
+
+=item "stdio"
+
+A layer which provides the PerlIO API via the layer scheme, but
+implements it by calling system's stdio. This is (currently) the default
+if system's stdio provides sufficient access to allow perl's "fast gets"
+access and which do not distinguish between C<O_TEXT> and C<O_BINARY>.
+
+=item "crlf"
+
+A layer derived using "perlio" as a base class. It provides Win32-like
+"\n" to CR,LF translation. Can either be applied above "perlio" or serve
+as the buffer layer itself. "crlf" over "unix" is the default if system
+distinguishes between C<O_TEXT> and C<O_BINARY> opens. (At some point
+"unix" will be replaced by a "native" Win32 IO layer on that platform,
+as Win32's read/write layer has various drawbacks.) The "crlf" layer is
+a reasonable model for a layer which transforms data in some way.
+
+=item "mmap"
+
+If Configure detects C<mmap()> functions this layer is provided (with
+"perlio" as a "base") which does "read" operations by mmap()ing the
+file. Performance improvement is marginal on modern systems, so it is
+mainly there as a proof of concept. It is likely to be unbundled from
+the core at some point. The "mmap" layer is a reasonable model for a
+minimalist "derived" layer.
+
+=item "pending"
+
+An "internal" derivative of "perlio" which can be used to provide
+Unread() function for layers which have no buffer or cannot be bothered.
+(Basically this layer's C<Fill()> pops itself off the stack and so resumes
+reading from layer below.)
+
+=item "raw"
+
+A dummy layer which never exists on the layer stack. Instead when
+"pushed" it actually pops the stack(!), removing itself, and any other
+layers until it reaches a layer with the class C<PERLIO_K_RAW> bit set.
+
+=item "utf8"
+
+Another dummy layer. When pushed it pops itself and sets the
+C<PERLIO_F_UTF8> flag on the layer which was (and now is once more) the top
+of the stack.
+
+=back
+
+In addition F<perlio.c> also provides a number of C<PerlIOBase_xxxx()>
+functions which are intended to be used in the table slots of classes
+which do not need to do anything special for a particular method.
+
+=head2 Extension Layers
+
+Layers can made available by extension modules.
+
+=over 4
+
+=item "encoding"
+
+   use Encoding;
+
+makes this layer available. It is an example of a layer which takes an argument.
+as it is called as:
+
+   open($fh,"<:encoding(iso-8859-7)",$pathname)
+
+=back
+
+
+=cut
+
+
+
index c47affc..5546dc8 100644 (file)
@@ -43,6 +43,8 @@ while (<MANIFEST>) {
 }
 
 print OUT <<'EOF';
+# Generated by perlmodlib.PL  DO NOT EDIT!
+
 =head1 NAME
 
 perlmodlib - constructing new Perl modules and finding existing ones
@@ -157,66 +159,87 @@ modules are:
 =over
 
 =item *
+
 Language Extensions and Documentation Tools
 
 =item *
+
 Development Support
 
 =item *
+
 Operating System Interfaces
 
 =item *
+
 Networking, Device Control (modems) and InterProcess Communication
 
 =item *
+
 Data Types and Data Type Utilities
 
 =item *
+
 Database Interfaces
 
 =item *
+
 User Interfaces
 
 =item *
+
 Interfaces to / Emulations of Other Programming Languages
 
 =item *
+
 File Names, File Systems and File Locking (see also File Handles)
 
 =item *
+
 String Processing, Language Text Processing, Parsing, and Searching
 
 =item *
+
 Option, Argument, Parameter, and Configuration File Processing
 
 =item *
+
 Internationalization and Locale
 
 =item *
+
 Authentication, Security, and Encryption
 
 =item *
+
 World Wide Web, HTML, HTTP, CGI, MIME
 
 =item *
+
 Server and Daemon Utilities
 
 =item *
+
 Archiving and Compression
 
 =item *
+
 Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing
 
 =item *
+
 Mail and Usenet News
 
 =item *
+
 Control Flow Utilities (callbacks and exceptions etc)
 
 =item *
+
 File Handle and Input/Output Stream Utilities
 
 =item *
+
 Miscellaneous Modules
 
 =back
@@ -228,167 +251,230 @@ You should try to choose one close to you:
 
 =item Africa
 
-    South Africa   ftp://ftp.is.co.za/programming/perl/CPAN/
-                   ftp://ftp.saix.net/pub/CPAN/
-                   ftp://ftp.sun.ac.za/CPAN/
-                   ftp://ftpza.co.za/pub/mirrors/cpan/
-
+ South Africa   ftp://ftp.is.co.za/programming/perl/CPAN/
+                ftp://ftp.saix.net/pub/CPAN/
+                ftp://ftpza.co.za/pub/mirrors/cpan/
+                ftp://ftp.sun.ac.za/CPAN/
 
 =item Asia
 
-    China          ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/
-    Hong Kong      ftp://ftp.pacific.net.hk/pub/mirror/CPAN/
-    Indonesia      ftp://malone.piksi.itb.ac.id/pub/CPAN/
-    Israel         ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
-    Japan          ftp://ftp.dti.ad.jp/pub/lang/CPAN/
-                   ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/
-                   ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/
-                   ftp://ftp.meisei-u.ac.jp/pub/CPAN/
-                   ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/
-                   ftp://mirror.nucba.ac.jp/mirror/Perl/
-    Saudi-Arabia   ftp://ftp.isu.net.sa/pub/CPAN/
-    Singapore      ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/
-    South Korea    ftp://ftp.bora.net/pub/CPAN/
-                   ftp://ftp.kornet.net/pub/CPAN/
-                   ftp://ftp.nuri.net/pub/CPAN/
-    Taiwan         ftp://coda.nctu.edu.tw/computer-languages/perl/CPAN/
-                   ftp://ftp.ee.ncku.edu.tw/pub3/perl/CPAN/
-                   ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/
-    Thailand       ftp://ftp.nectec.or.th/pub/mirrors/CPAN/
-
-
-=item Australasia
-
-    Australia      ftp://cpan.topend.com.au/pub/CPAN/
-                   ftp://ftp.labyrinth.net.au/pub/perl-CPAN/
-                   ftp://ftp.sage-au.org.au/pub/compilers/perl/CPAN/
-                   ftp://mirror.aarnet.edu.au/pub/perl/CPAN/
-    New Zealand    ftp://ftp.auckland.ac.nz/pub/perl/CPAN/
-                   ftp://sunsite.net.nz/pub/languages/perl/CPAN/
-
+ China          ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/
+                http://www2.linuxforum.net/mirror/CPAN/
+ Hong Kong      http://CPAN.pacific.net.hk/
+                ftp://ftp.pacific.net.hk/pub/mirror/CPAN/
+ Indonesia      http://piksi.itb.ac.id/CPAN/
+                ftp://mirrors.piksi.itb.ac.id/CPAN/
+                http://CPAN.mweb.co.id/
+                ftp://ftp.mweb.co.id/pub/languages/perl/CPAN/
+ Israel         http://www.iglu.org.il:/pub/CPAN/
+                ftp://ftp.iglu.org.il/pub/CPAN/
+                http://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
+                ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
+ Japan          ftp://ftp.u-aizu.ac.jp/pub/lang/perl/CPAN/
+                ftp://ftp.kddlabs.co.jp/CPAN/
+                http://mirror.nucba.ac.jp/mirror/Perl/
+                ftp://mirror.nucba.ac.jp/mirror/Perl/
+                ftp://ftp.meisei-u.ac.jp/pub/CPAN/
+                ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/
+                ftp://ftp.dti.ad.jp/pub/lang/CPAN/
+                ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/
+ Saudi Arabia   ftp://ftp.isu.net.sa/pub/CPAN/
+ Singapore      http://ftp.nus.edu.sg/unix/perl/CPAN/
+                ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/
+ South Korea    http://CPAN.bora.net/
+                ftp://ftp.bora.net/pub/CPAN/
+                http://ftp.kornet.net/CPAN/
+                ftp://ftp.kornet.net/pub/CPAN/
+                ftp://ftp.nuri.net/pub/CPAN/
+ Taiwan         ftp://coda.nctu.edu.tw/computer-languages/perl/CPAN/
+                ftp://ftp.ee.ncku.edu.tw/pub/perl/CPAN/
+                ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/
+ Thailand       http://download.nectec.or.th/CPAN/
+                ftp://ftp.nectec.or.th/pub/languages/CPAN/
+                ftp://ftp.cs.riubon.ac.th/pub/mirrors/CPAN/
 
 =item Central America
 
-    Costa Rica     ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/
-
+ Costa Rica     ftp://ftp.linux.co.cr/mirrors/CPAN/
+                http://ftp.ucr.ac.cr/Unix/CPAN/
+                ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/
 
 =item Europe
 
-    Austria        ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/
-    Belgium        ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/
-    Bulgaria       ftp://ftp.ntrl.net/pub/mirrors/CPAN/
-    Croatia        ftp://ftp.linux.hr/pub/CPAN/
-    Czech Republic ftp://ftp.fi.muni.cz/pub/perl/
-                   ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/
-    Denmark        ftp://sunsite.auc.dk/pub/languages/perl/CPAN/
-    Estonia        ftp://ftp.ut.ee/pub/languages/perl/CPAN/
-    Finland        ftp://ftp.funet.fi/pub/languages/perl/CPAN/
-    France         ftp://ftp.grolier.fr/pub/perl/CPAN/
-                   ftp://ftp.lip6.fr/pub/perl/CPAN/
-                   ftp://ftp.oleane.net/pub/mirrors/CPAN/
-                   ftp://ftp.pasteur.fr/pub/computing/CPAN/
-                   ftp://ftp.uvsq.fr/pub/perl/CPAN/
-    German         ftp://ftp.gigabell.net/pub/CPAN/
-    Germany        ftp://ftp.archive.de.uu.net/pub/CPAN/
-                   ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/
-                   ftp://ftp.gmd.de/packages/CPAN/
-                   ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
-
-ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
-                   ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
-                   ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
-                   ftp://ftp.uni-erlangen.de/pub/source/CPAN/
-                   ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
-    Germany        ftp://ftp.archive.de.uu.net/pub/CPAN/
-                   ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/
-                   ftp://ftp.gmd.de/packages/CPAN/
-                   ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
-
-ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
-                   ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
-                   ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
-                   ftp://ftp.uni-erlangen.de/pub/source/CPAN/
-                   ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
-    Greece         ftp://ftp.ntua.gr/pub/lang/perl/
-    Hungary        ftp://ftp.kfki.hu/pub/packages/perl/CPAN/
-    Iceland        ftp://ftp.gm.is/pub/CPAN/
-    Ireland        ftp://cpan.indigo.ie/pub/CPAN/
-                   ftp://sunsite.compapp.dcu.ie/pub/perl/
-    Italy          ftp://cis.uniRoma2.it/CPAN/
-                   ftp://ftp.flashnet.it/pub/CPAN/
-                   ftp://ftp.unina.it/pub/Other/CPAN/
-                   ftp://ftp.unipi.it/pub/mirror/perl/CPAN/
-    Netherlands    ftp://ftp.cs.uu.nl/mirror/CPAN/
-                   ftp://ftp.nluug.nl/pub/languages/perl/CPAN/
-    Norway         ftp://ftp.uit.no/pub/languages/perl/cpan/
-                   ftp://sunsite.uio.no/pub/languages/perl/CPAN/
-    Poland         ftp://ftp.man.torun.pl/pub/CPAN/
-                   ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/
-                   ftp://sunsite.icm.edu.pl/pub/CPAN/
-    Portugal       ftp://ftp.ci.uminho.pt/pub/mirrors/cpan/
-                   ftp://ftp.ist.utl.pt/pub/CPAN/
-                   ftp://ftp.ua.pt/pub/CPAN/
-    Romania        ftp://ftp.dnttm.ro/pub/CPAN/
-    Russia         ftp://ftp.chg.ru/pub/lang/perl/CPAN/
-                   ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/
-    Slovakia       ftp://ftp.entry.sk/pub/languages/perl/CPAN/
-    Slovenia       ftp://ftp.arnes.si/software/perl/CPAN/
-    Spain          ftp://ftp.etse.urv.es/pub/perl/
-                   ftp://ftp.rediris.es/mirror/CPAN/
-    Sweden         ftp://ftp.sunet.se/pub/lang/perl/CPAN/
-    Switzerland    ftp://sunsite.cnlab-switch.ch/mirror/CPAN/
-    Turkey         ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/
-    United Kingdom ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
-                   ftp://ftp.flirble.org/pub/languages/perl/CPAN/
-
-ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/
-                   ftp://ftp.plig.org/pub/CPAN/
-                   ftp://sunsite.doc.ic.ac.uk/packages/CPAN/
-
+ Austria        ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/
+ Belgium        http://ftp.easynet.be/CPAN/
+                ftp://ftp.easynet.be/CPAN/
+                ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/
+ Bulgaria       ftp://ftp.ntrl.net/pub/mirrors/CPAN/
+ Croatia        ftp://ftp.linux.hr/pub/CPAN/
+ Czech Republic http://www.fi.muni.cz/pub/perl/
+                ftp://ftp.fi.muni.cz/pub/perl/
+                ftp://sunsite.mff.cuni.cz/MIRRORS/ftp.funet.fi/pub/languages/perl/CPAN/
+ Denmark        ftp://sunsite.auc.dk/pub/languages/perl/CPAN/
+                http://www.cpan.dk/CPAN/
+ England        http://www.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN
+                ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/
+                ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
+                ftp://ftp.flirble.org/pub/languages/perl/CPAN/
+                ftp://ftp.plig.org/pub/CPAN/
+                ftp://sunsite.doc.ic.ac.uk/packages/CPAN/
+                http://mirror.uklinux.net/CPAN/
+                ftp://mirror.uklinux.net/pub/CPAN/
+                ftp://usit.shef.ac.uk/pub/packages/CPAN/
+ Estonia        ftp://ftp.ut.ee/pub/languages/perl/CPAN/
+ Finland        ftp://ftp.funet.fi/pub/languages/perl/CPAN/
+ France         ftp://cpan.ftp.worldonline.fr/pub/CPAN/
+                ftp://ftp.club-internet.fr/pub/perl/CPAN/
+                ftp://ftp.lip6.fr/pub/perl/CPAN/
+                ftp://ftp.oleane.net/pub/mirrors/CPAN/
+                ftp://ftp.pasteur.fr/pub/computing/CPAN/
+                ftp://cpan.cict.fr/pub/CPAN/
+                ftp://ftp.uvsq.fr/pub/perl/CPAN/
+ Germany        ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
+                ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/CPAN/
+                ftp://ftp.uni-erlangen.de/pub/source/CPAN/
+                ftp://ftp-stud.fht-esslingen.de/pub/Mirrors/CPAN
+                ftp://ftp.gigabell.net/pub/CPAN/
+                http://ftp.gwdg.de/pub/languages/perl/CPAN/
+                ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
+                ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
+                ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
+                ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
+                ftp://ftp.gmd.de/packages/CPAN/
+ Greece         ftp://ftp.ntua.gr/pub/lang/perl/
+ Hungary        http://cpan.artifact.hu/
+                ftp://cpan.artifact.hu/CPAN/
+                ftp://ftp.kfki.hu/pub/packages/perl/CPAN/
+ Iceland        http://cpan.gm.is/
+                ftp://ftp.gm.is/pub/CPAN/
+ Ireland        http://cpan.indigo.ie/
+                ftp://cpan.indigo.ie/pub/CPAN/
+                http://sunsite.compapp.dcu.ie/pub/perl/
+                ftp://sunsite.compapp.dcu.ie/pub/perl/
+ Italy          http://cpan.nettuno.it/
+                http://softcity.iol.it/cpan
+                ftp://softcity.iol.it/pub/cpan
+                ftp://ftp.unina.it/pub/Other/CPAN/
+                ftp://ftp.unipi.it/pub/mirror/perl/CPAN/
+                ftp://cis.uniRoma2.it/CPAN/
+                ftp://ftp.edisontel.it/pub/CPAN_Mirror/
+                ftp://ftp.flashnet.it/pub/CPAN/
+ Latvia         http://kvin.lv/pub/CPAN/
+ Netherlands    ftp://download.xs4all.nl/pub/mirror/CPAN/
+                ftp://ftp.nl.uu.net/pub/CPAN/
+                ftp://ftp.cpan.nl/pub/CPAN/
+                ftp://ftp.nluug.nl/pub/languages/perl/CPAN/
+                http://www.cs.uu.nl/mirror/CPAN/
+                ftp://ftp.cs.uu.nl/mirror/CPAN/
+ Norway         ftp://sunsite.uio.no/pub/languages/perl/CPAN/
+                ftp://ftp.uit.no/pub/languages/perl/cpan/
+ Poland         ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/
+                ftp://ftp.mega.net.pl/pub/mirrors/ftp.perl.com/
+                ftp://ftp.man.torun.pl/pub/doc/CPAN/
+                ftp://sunsite.icm.edu.pl/pub/CPAN/
+ Portugal       ftp://ftp.ua.pt/pub/CPAN/
+                ftp://perl.di.uminho.pt/pub/CPAN/
+                ftp://ftp.ist.utl.pt/pub/CPAN/
+                ftp://ftp.netc.pt/pub/CPAN/
+ Romania        ftp://archive.logicnet.ro/mirrors/ftp.cpan.org/CPAN/
+                ftp://ftp.kappa.ro/pub/mirrors/ftp.perl.org/pub/CPAN/
+                ftp://ftp.dntis.ro/pub/cpan/
+                ftp://ftp.opsynet.com/cpan/
+                ftp://ftp.dnttm.ro/pub/CPAN/
+ Russia         ftp://ftp.chg.ru/pub/lang/perl/CPAN/
+                http://cpan.rinet.ru/
+                ftp://cpan.rinet.ru/pub/mirror/CPAN/
+                ftp://ftp.aha.ru/pub/CPAN/
+                ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/
+ Slovakia       ftp://ftp.entry.sk/pub/languages/perl/CPAN/
+ Slovenia       ftp://ftp.arnes.si/software/perl/CPAN/
+ Spain          ftp://ftp.rediris.es/mirror/CPAN/
+                ftp://ftp.etse.urv.es/pub/perl/
+ Sweden         http://ftp.du.se/CPAN/
+                ftp://ftp.du.se/pub/CPAN/
+                ftp://ftp.sunet.se/pub/lang/perl/CPAN/
+ Switzerland    ftp://ftp.danyk.ch/CPAN/
+                ftp://sunsite.cnlab-switch.ch/mirror/CPAN/
+ Turkey         ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/
 
 =item North America
 
-    Alberta        ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/
-    California     ftp://cpan.nas.nasa.gov/pub/perl/CPAN/
-                   ftp://cpan.valueclick.com/CPAN/
-                   ftp://ftp.cdrom.com/pub/perl/CPAN/
-                   http://download.sourceforge.net/mirrors/CPAN/
-    Colorado       ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
-    Florida        ftp://ftp.cise.ufl.edu/pub/perl/CPAN/
-    Georgia        ftp://ftp.twoguys.org/CPAN/
-    Illinois       ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/
-    Indiana        ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN/
-                   ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/
-    Kentucky       ftp://ftp.uky.edu/CPAN/
-    Manitoba       ftp://theoryx5.uwinnipeg.ca/pub/CPAN/
-    Massachusetts
-ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/
-                   ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/
-    Mexico         ftp://ftp.msg.com.mx/pub/CPAN/
-    New York       ftp://ftp.deao.net/pub/CPAN/
-                   ftp://ftp.rge.com/pub/languages/perl/
-    North Carolina ftp://ftp.duke.edu/pub/perl/
-    Nova Scotia    ftp://cpan.chebucto.ns.ca/pub/CPAN/
-    Oklahoma       ftp://ftp.ou.edu/mirrors/CPAN/
-    Ontario        ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/
-    Oregon         ftp://ftp.orst.edu/pub/packages/CPAN/
-    Pennsylvania   ftp://ftp.epix.net/pub/languages/perl/
-    Tennessee      ftp://ftp.sunsite.utk.edu/pub/CPAN/
-    Texas          ftp://ftp.sedl.org/pub/mirrors/CPAN/
-                   ftp://jhcloos.com/pub/mirror/CPAN/
-    Utah           ftp://mirror.xmission.com/CPAN/
-    Virginia       ftp://ftp.perl.org/pub/perl/CPAN/
-                   ftp://ruff.cs.jmu.edu/pub/CPAN/
-    Washington     ftp://ftp-mirror.internap.com/pub/CPAN/
-                   ftp://ftp.llarian.net/pub/CPAN/
-                   ftp://ftp.spu.edu/pub/CPAN/
-
+   Alberta        http://sunsite.ualberta.ca/pub/Mirror/CPAN/
+                  ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/
+   Alabama        http://mirror.hiwaay.net/CPAN/
+                  ftp://mirror.hiwaay.net/CPAN/
+   California     http://www.cpan.org/
+                  ftp://ftp.cpan.org/CPAN/
+                  ftp://cpan.nas.nasa.gov/pub/perl/CPAN/
+                  ftp://ftp.digital.com/pub/plan/perl/CPAN/
+                  http://www.kernel.org/pub/mirrors/cpan/
+                  ftp://ftp.kernel.org/pub/mirrors/cpan/
+                  http://www.perl.com/CPAN/
+                  http://download.sourceforge.net/mirrors/CPAN/
+   Colorado       ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
+   Florida        ftp://ftp.cise.ufl.edu/pub/perl/CPAN/
+   Georgia        ftp://ftp.twoguys.org/CPAN/
+   Illinois       http://www.neurogames.com/mirrors/CPAN
+   Indiana        ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/
+                  http://cpan.nitco.com/
+                  ftp://cpan.nitco.com/pub/CPAN/
+                  ftp://cpan.in-span.net/
+                  http://csociety-ftp.ecn.purdue.edu/pub/CPAN
+                  ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN
+   Manitoba       http://theoryx5.uwinnipeg.ca/pub/CPAN/
+                  ftp://theoryx5.uwinnipeg.ca/pub/CPAN/
+   Massachusetts  ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/
+                  ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/
+   Mexico         http://www.msg.com.mx/CPAN/
+                  ftp://ftp.msg.com.mx/pub/CPAN/
+   New Jersey     ftp://ftp.cpanel.net/pub/CPAN/
+   New York       ftp://ftp.freesoftware.com/pub/perl/CPAN/
+                  http://www.deao.net/mirrors/CPAN/
+                  ftp://ftp.deao.net/pub/CPAN/
+                  ftp://ftp.stealth.net/pub/mirrors/ftp.cpan.org/pub/CPAN/
+                  http://mirror.nyc.anidea.com/CPAN/
+                  ftp://mirror.nyc.anidea.com/pub/CPAN/
+                  http://www.rge.com/pub/languages/perl/
+                  ftp://ftp.rge.com/pub/languages/perl/
+                  ftp://mirrors.cloud9.net/pub/mirrors/CPAN/
+   North Carolina ftp://ftp.duke.edu/pub/perl/
+   Nova Scotia    ftp://cpan.chebucto.ns.ca/pub/CPAN/
+   Ohio           ftp://ftp.loaded.net/pub/CPAN/
+   Oklahoma       ftp://ftp.ou.edu/mirrors/CPAN/
+   Ontario        ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/
+   Oregon         ftp://ftp.orst.edu/pub/packages/CPAN/
+   Pennsylvania   http://ftp.epix.net/CPAN/
+                  ftp://ftp.epix.net/pub/languages/perl/
+                  ftp://carroll.cac.psu.edu/pub/CPAN/
+   Tennessee      ftp://ftp.sunsite.utk.edu/pub/CPAN/
+   Texas          http://ftp.sedl.org/pub/mirrors/CPAN/
+                  http://jhcloos.com/pub/mirror/CPAN/
+                  ftp://jhcloos.com/pub/mirror/CPAN/
+   Utah           ftp://mirror.xmission.com/CPAN/
+   Virginia       http://mirrors.rcn.net/pub/lang/CPAN/
+                  ftp://mirrors.rcn.net/pub/lang/CPAN/
+                  ftp://ruff.cs.jmu.edu/pub/CPAN/
+   Washington     http://cpan.llarian.net/
+                  ftp://cpan.llarian.net/pub/CPAN/
+                  ftp://ftp-mirror.internap.com/pub/CPAN/
+                  ftp://ftp.spu.edu/pub/CPAN/
+
+=item Oceania
+
+ Australia      http://ftp.planetmirror.com/pub/CPAN/
+                ftp://ftp.planetmirror.com/pub/CPAN/
+                ftp://mirror.aarnet.edu.au/pub/perl/CPAN/
+                ftp://cpan.topend.com.au/pub/CPAN/
+ New Zealand    ftp://ftp.auckland.ac.nz/pub/perl/CPAN/
 
 =item South America
 
-    Brazil         ftp://cpan.if.usp.br/pub/mirror/CPAN/
-                   ftp://ftp.matrix.com.br/pub/perl/
-    Chile          ftp://sunsite.dcc.uchile.cl/pub/Lang/PERL/
+ Argentina      ftp://mirrors.bannerlandia.com.ar/mirrors/CPAN/
+ Brazil         ftp://cpan.pop-mg.com.br/pub/CPAN/
+                ftp://ftp.matrix.com.br/pub/perl/
+                ftp://cpan.if.usp.br/pub/mirror/CPAN/
+ Chile          ftp://ftp.psinet.cl/pub/programming/perl/CPAN/
+                ftp://sunsite.dcc.uchile.cl/pub/lang/perl/
 
 =back
 
@@ -421,7 +507,9 @@ the AUTOLOAD mechanism.
 
 =over 4
 
-=item Do similar modules already exist in some form?
+=item  *
+
+Do similar modules already exist in some form?
 
 If so, please try to reuse the existing modules either in whole or
 by inheriting useful features into a new class.  If this is not
@@ -435,7 +523,9 @@ modules, please coordinate with the author of the package.  It
 helps if you follow the same naming scheme and module interaction
 scheme as the original author.
 
-=item Try to design the new module to be easy to extend and reuse.
+=item  *
+
+Try to design the new module to be easy to extend and reuse.
 
 Try to C<use warnings;> (or C<use warnings qw(...);>).
 Remember that you can add C<no warnings qw(...);> to individual blocks
@@ -500,7 +590,9 @@ Follow the guidelines in the perlstyle(1) manual.
 
 Always use B<-w>.
 
-=item Some simple style guidelines
+=item  *
+
+Some simple style guidelines
 
 The perlstyle manual supplied with Perl has many helpful points.
 
@@ -532,7 +624,9 @@ e.g., C<< $obj->as_string() >>.
 You can use a leading underscore to indicate that a variable or
 function should not be used outside the package that defined it.
 
-=item Select what to export.
+=item  *
+
+Select what to export.
 
 Do NOT export method names!
 
@@ -556,7 +650,9 @@ As a general rule, if the module is trying to be object oriented
 then export nothing. If it's just a collection of functions then
 @EXPORT_OK anything but use @EXPORT with caution.
 
-=item Select a name for the module.
+=item  *
+
+Select a name for the module.
 
 This name should be as descriptive, accurate, and complete as
 possible.  Avoid any risk of ambiguity. Always try to use two or
@@ -590,7 +686,9 @@ To be portable each component of a module name should be limited to
 11 characters. If it might be used on MS-DOS then try to ensure each is
 unique in the first 8 characters. Nested modules make this easier.
 
-=item Have you got it right?
+=item  *
+
+Have you got it right?
 
 How do you know that you've made the right decisions? Have you
 picked an interface design that will cause problems later? Have
@@ -609,7 +707,9 @@ Don't worry about posting if you can't say when the module will be
 ready - just say so in the message. It might be worth inviting
 others to help you, they may be able to complete it for you!
 
-=item README and other Additional Files.
+=item  *
+
+README and other Additional Files.
 
 It's well known that software developers usually fully document the
 software they write. If, however, the world is in urgent need of
@@ -619,24 +719,31 @@ documentation please at least provide a README file containing:
 =over 10
 
 =item *
+
 A description of the module/package/extension etc.
 
 =item *
+
 A copyright notice - see below.
 
 =item *
+
 Prerequisites - what else you may need to have.
 
 =item *
+
 How to build it - possible changes to Makefile.PL etc.
 
 =item *
+
 How to install it.
 
 =item *
+
 Recent changes in this release, especially incompatibilities
 
 =item *
+
 Changes / enhancements you plan to make in the future.
 
 =back
@@ -649,6 +756,7 @@ Copying, ToDo etc.
 
 =item Adding a Copyright Notice.
 
+
 How you choose to license your work is a personal decision.
 The general mechanism is to assert your Copyright and then make
 a declaration of how others may copy/use/modify your work.
@@ -668,7 +776,9 @@ This statement should at least appear in the README file. You may
 also wish to include it in a Copying file and your source files.
 Remember to include the other words in addition to the Copyright.
 
-=item Give the module a version/issue/release number.
+=item  *
+
+Give the module a version/issue/release number.
 
 To be fully compatible with the Exporter and MakeMaker modules you
 should store your module's version number in a non-my package
@@ -682,7 +792,9 @@ Use the number in announcements and archive file names when
 releasing the module (ModuleName-1.02.tar.Z).
 See perldoc ExtUtils::MakeMaker.pm for details.
 
-=item How to release and distribute a module.
+=item  *
+
+How to release and distribute a module.
 
 It's good idea to post an announcement of the availability of your
 module (or the module itself if small) to the comp.lang.perl.announce
@@ -721,7 +833,9 @@ CPAN!
 
 Please remember to send me an updated entry for the Module list!
 
-=item Take care when changing a released module.
+=item  *
+
+Take care when changing a released module.
 
 Always strive to remain compatible with previous released versions.
 Otherwise try to add a mechanism to revert to the
@@ -735,26 +849,34 @@ old behavior if people rely on it.  Document incompatible changes.
 
 =over 4
 
-=item There is no requirement to convert anything.
+=item  *
+
+There is no requirement to convert anything.
 
 If it ain't broke, don't fix it! Perl 4 library scripts should
 continue to work with no problems. You may need to make some minor
 changes (like escaping non-array @'s in double quoted strings) but
 there is no need to convert a .pl file into a Module for just that.
 
-=item Consider the implications.
+=item  *
+
+Consider the implications.
 
 All Perl applications that make use of the script will need to
 be changed (slightly) if the script is converted into a module.  Is
 it worth it unless you plan to make other changes at the same time?
 
-=item Make the most of the opportunity.
+=item  *
+
+Make the most of the opportunity.
 
 If you are going to convert the script to a module you can use the
 opportunity to redesign the interface.  The guidelines for module
 creation above include many of the issues you should consider.
 
-=item The pl2pm utility will get you started.
+=item  *
+
+The pl2pm utility will get you started.
 
 This utility will read *.pl files (given as parameters) and write
 corresponding *.pm files. The pl2pm utilities does the following:
@@ -762,15 +884,19 @@ corresponding *.pm files. The pl2pm utilities does the following:
 =over 10
 
 =item *
+
 Adds the standard Module prologue lines
 
 =item *
+
 Converts package specifiers from ' to ::
 
 =item *
+
 Converts die(...) to croak(...)
 
 =item *
+
 Several other minor changes
 
 =back
@@ -785,18 +911,28 @@ Don't delete the original .pl file till the new .pm one works!
 
 =over 4
 
-=item Complete applications rarely belong in the Perl Module Library.
+=item  *
+
+Complete applications rarely belong in the Perl Module Library.
+
+=item  *
 
-=item Many applications contain some Perl code that could be reused.
+Many applications contain some Perl code that could be reused.
 
 Help save the world! Share your code in a form that makes it easy
 to reuse.
 
-=item Break-out the reusable code into one or more separate module files.
+=item  *
+
+Break-out the reusable code into one or more separate module files.
+
+=item  *
+
+Take the opportunity to reconsider and redesign the interfaces.
 
-=item Take the opportunity to reconsider and redesign the interfaces.
+=item  *
 
-=item In some cases the 'application' can then be reduced to a small
+In some cases the 'application' can then be reduced to a small
 
 fragment of code built on top of the reusable modules. In these cases
 the application could invoked as:
index 9a9bda9..285ed99 100644 (file)
@@ -559,8 +559,8 @@ breaks the circularities in the self-referential structure.
 
 =head1 SEE ALSO
 
-A kinder, gentler tutorial on object-oriented programming in Perl
-can be found in L<perltoot> and L<perltootc>.  You should also check
-out L<perlbot> for other object tricks, traps, and tips, as well
-as L<perlmodlib> for some style guides on constructing both modules
-and classes.
+A kinder, gentler tutorial on object-oriented programming in Perl can
+be found in L<perltoot>, L<perlbootc> and L<perltootc>.  You should
+also check out L<perlbot> for other object tricks, traps, and tips, as
+well as L<perlmodlib> for some style guides on constructing both
+modules and classes.
index ebe52c5..464ba99 100644 (file)
@@ -1746,7 +1746,7 @@ is roughly equivalent to:
 
     open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|");
     while (<FOO>) {
-       chop;
+       chomp;
        chmod 0644, $_;
     }
 
index 1078e58..08a1704 100644 (file)
@@ -94,6 +94,26 @@ from) C<\015\012>, depending on whether you're reading or writing.
 Unix does the same thing on ttys in canonical mode.  C<\015\012>
 is commonly referred to as CRLF.
 
+A common cause of unportable programs is the misuse of chop() to trim
+newlines:
+
+    # XXX UNPORTABLE!
+    while(<FILE>) {
+        chop;
+        @array = split(/:/);
+        #...
+    }
+
+You can get away with this on Unix and MacOS (they have a single
+character end-of-line), but the same program will break under DOSish
+perls because you're only chop()ing half the end-of-line.  Instead,
+chomp() should be used to trim newlines.  The Dunce::Files module can
+help audit your code for misuses of chop().
+
+When dealing with binary files (or text files in binary mode) be sure
+to explicitly set $/ to the appropriate value for your file format
+before using chomp().
+
 Because of the "text" mode translation, DOSish perls have limitations
 in using C<seek> and C<tell> on a file accessed in "text" mode.
 Stick to C<seek>-ing to locations you got from C<tell> (and no
index 0c38ac7..2e2f59c 100644 (file)
@@ -1096,7 +1096,7 @@ For example:
     $_ = 'bar';
     s/\w??/<$&>/g;
 
-results in C<"<><b><><a><><r><>">.  At each position of the string the best
+results in C<< <><b><><a><><r><> >>.  At each position of the string the best
 match given by non-greedy C<??> is the zero-length match, and the I<second 
 best> match is what is matched by C<\w>.  Thus zero-length matches
 alternate with one-character-long matches.
index 594cb99..38cc1f3 100644 (file)
@@ -425,6 +425,10 @@ this could be done:
 Notice how there's no memory to deallocate in the destructor?  That's
 something that Perl takes care of for you all by itself.
 
+Alternatively, you could use the Class::Data::Inheritable module from
+CPAN.
+
+
 =head2 Accessing Class Data
 
 It turns out that this is not really a good way to go about handling
@@ -1750,6 +1754,16 @@ L<perltie>,
 and
 L<overload>.
 
+L<perlboot> is a kinder, gentler introduction to object-oriented
+programming.
+
+L<perltootc> provides more detail on class data.
+
+Some modules which might prove interesting are Class::Accessor,
+Class::Class, Class::Contract, Class::Data::Inheritable,
+Class::MethodMaker and Tie::SecureHash
+
+
 =head1 AUTHOR AND COPYRIGHT
 
 Copyright (c) 1997, 1998 Tom Christiansen 
index ee0bd02..d2d881c 100644 (file)
@@ -74,6 +74,15 @@ you can elect to permit access to them from anywhere in the entire file
 scope, or you can limit direct data access exclusively to the methods
 implementing those attributes.
 
+=head1 Class Data in a Can
+
+One of the easiest ways to solve a hard problem is to let someone else
+do it for you!  In this case, Class::Data::Inheritable (available on a
+CPAN near you) offers a canned solution to the class data problem
+using closures.  So before you wade into this document, consider
+having a look at that module.
+
+
 =head1 Class Data as Package Variables
 
 Because a class in Perl is really just a package, using package variables
@@ -1302,7 +1311,8 @@ would just confuse the examples.
 
 L<perltoot>, L<perlobj>, L<perlmod>, and L<perlbot>.
 
-The Tie::SecureHash module from CPAN is worth checking out.
+The Tie::SecureHash and Class::Data::Inheritable modules from CPAN are
+worth checking out.
 
 =head1 AUTHOR AND COPYRIGHT
 
@@ -1334,4 +1344,4 @@ object-oriented languages enforce.
 
 =head1 HISTORY
 
-Last edit: Fri May 21 15:47:56 MDT 1999
+Last edit: Sun Feb  4 20:50:28 EST 2001
index 7b56a17..be7a345 100644 (file)
@@ -97,7 +97,7 @@ Similarly, F<s2p> converts F<sed> scripts to Perl programs. F<s2p> run
 on C<s/foo/bar> will produce a Perl program based around this:
 
     while (<>) {
-        chop;
+        chomp;
         s/foo/bar/g;
         print if $printit;
     }
diff --git a/pp.c b/pp.c
index d9b0685..ae2ff93 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1242,134 +1242,106 @@ PP(pp_subtract)
     djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
     useleft = USE_LEFT(TOPm1s);
 #ifdef PERL_PRESERVE_IVUV
-    /* We must see if we can perform the addition with integers if possible,
-       as the integer code detects overflow while the NV code doesn't.
-       If either argument hasn't had a numeric conversion yet attempt to get
-       the IV. It's important to do this now, rather than just assuming that
-       it's not IOK as a PV of "9223372036854775806" may not take well to NV
-       addition, and an SV which is NOK, NV=6.0 ought to be coerced to
-       integer in case the second argument is IV=9223372036854775806
-       We can (now) rely on sv_2iv to do the right thing, only setting the
-       public IOK flag if the value in the NV (or PV) slot is truly integer.
-
-       A side effect is that this also aggressively prefers integer maths over
-       fp maths for integer values.  */
+    /* See comments in pp_add (in pp_hot.c) about Overflow, and how
+       "bad things" happen if you rely on signed integers wrapping.  */
     SvIV_please(TOPs);
     if (SvIOK(TOPs)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
+       register UV auv;
+       bool auvok;
+       bool a_valid = 0;
+
        if (!useleft) {
-           /* left operand is undef, treat as zero. + 0 is identity. */
-           if (SvUOK(TOPs)) {
-               dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
-               if (value <= (UV)IV_MIN) {
-                   /* 2s complement assumption.  */
-                   SETi(-(IV)value);
-                   RETURN;
-               } /* else drop through into NVs below */
-           } else {
-               dPOPiv;
-               SETu((UV)-value);
-               RETURN;
-           }
+           auv = 0;
+           a_valid = auvok = 1;
+           /* left operand is undef, treat as zero.  */
        } else {
            /* Left operand is defined, so is it IV? */
            SvIV_please(TOPm1s);
            if (SvIOK(TOPm1s)) {
-               bool auvok = SvUOK(TOPm1s);
-               bool buvok = SvUOK(TOPs);
-       
-               if (!auvok && !buvok) { /* ## IV - IV ## */
-                   IV aiv = SvIVX(TOPm1s);
-                   IV biv = SvIVX(TOPs);
-                   IV result = aiv - biv;
-               
-                   if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
-                       SP--;
-                       SETi( result );
-                       RETURN;
-                   }
-                   /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
-                   /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
-                   /* -ve - +ve can only overflow too negative. */
-                   /* leaving +ve - -ve, which will go UV */
-                   if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
-                       /* 2s complement assumption for IV_MIN */
-                       UV result = (UV)aiv + (UV)-biv;
-                       /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
-                          overflow UV (2s complement assumption */
-                       assert (result >= (UV) aiv);
-                       SP--;
-                       SETu( result );
-                       RETURN;
-                   }
-                   /* Overflow, drop through to NVs */
-               } else if (auvok && buvok) {    /* ## UV - UV ## */
-                   UV auv = SvUVX(TOPm1s);
-                   UV buv = SvUVX(TOPs);
-                   IV result;
-               
-                   if (auv >= buv) {
-                       SP--;
-                       SETu( auv - buv );
-                       RETURN;
-                   }
-                   /* Blatant 2s complement assumption.  */
-                   result = (IV)(auv - buv);
-                   if (result < 0) {
-                       SP--;
-                       SETi( result );
-                       RETURN;
+               if ((auvok = SvUOK(TOPm1s)))
+                   auv = SvUVX(TOPm1s);
+               else {
+                   register IV aiv = SvIVX(TOPm1s);
+                   if (aiv >= 0) {
+                       auv = aiv;
+                       auvok = 1;      /* Now acting as a sign flag.  */
+                   } else { /* 2s complement assumption for IV_MIN */
+                       auv = (UV)-aiv;
                    }
-                   /* Overflow on IV - IV, drop through to NVs */
-               } else if (auvok) {     /* ## Mixed UV - IV ## */
-                   UV auv = SvUVX(TOPm1s);
-                   IV biv = SvIVX(TOPs);
-
-                   if (biv < 0) {
-                       /* 2s complement assumptions for IV_MIN */
-                       UV result = auv + ((UV)-biv);
-                       /* UV + UV can only get bigger... */
-                       if (result >= auv) {
-                           SP--;
-                           SETu( result );
-                           RETURN;
-                       }
-                       /* and if it gets too big for UV then it's NV time.  */
-                   } else if (auv > (UV)IV_MAX) {
-                       /* I think I'm making an implicit 2s complement
-                          assumption that IV_MIN == -IV_MAX - 1 */
-                       /* biv is >= 0 */
-                       UV result = auv - (UV)biv;
-                       assert (result <= auv);
-                       SP--;
-                       SETu( result );
-                       RETURN;
-                   } else {
-                       /* biv is >= 0 */
-                       IV result = (IV)auv - biv;
-                       assert (result <= (IV)auv);
-                       SP--;
-                       SETi( result );
-                       RETURN;
+               }
+               a_valid = 1;
+           }
+       }
+       if (a_valid) {
+           bool result_good = 0;
+           UV result;
+           register UV buv;
+           bool buvok = SvUOK(TOPs);
+           
+           if (buvok)
+               buv = SvUVX(TOPs);
+           else {
+               register IV biv = SvIVX(TOPs);
+               if (biv >= 0) {
+                   buv = biv;
+                   buvok = 1;
+               } else
+                   buv = (UV)-biv;
+           }
+           /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+              else "IV" now, independant of how it came in.
+              if a, b represents positive, A, B negative, a maps to -A etc
+              a - b =>  (a - b)
+              A - b => -(a + b)
+              a - B =>  (a + b)
+              A - B => -(a - b)
+              all UV maths. negate result if A negative.
+              subtract if signs same, add if signs differ. */
+
+           if (auvok ^ buvok) {
+               /* Signs differ.  */
+               result = auv + buv;
+               if (result >= auv)
+                   result_good = 1;
+           } else {
+               /* Signs same */
+               if (auv >= buv) {
+                   result = auv - buv;
+                   /* Must get smaller */
+                   if (result <= auv)
+                       result_good = 1;
+               } else {
+                   result = buv - auv;
+                   if (result <= buv) {
+                       /* result really should be -(auv-buv). as its negation
+                          of true value, need to swap our result flag  */
+                       auvok = !auvok;
+                       result_good = 1;
                    }
-               } else {                /* ## Mixed IV - UV ## */
-                   IV aiv = SvIVX(TOPm1s);
-                   UV buv = SvUVX(TOPs);
-                   IV result = aiv - (IV)buv; /* 2s complement assumption. */
-               
-                   /* result must not get larger. */
-                   if (result <= aiv) {
-                       SP--;
-                       SETi( result );
-                       RETURN;
-                   } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
                }
            }
+           if (result_good) {
+               SP--;
+               if (auvok)
+                   SETu( result );
+               else {
+                   /* Negate result */
+                   if (result <= (UV)IV_MIN)
+                       SETi( -(IV)result );
+                   else {
+                       /* result valid, but out of range for IV.  */
+                       SETn( -(NV)result );
+                   }
+               }
+               RETURN;
+           } /* Overflow, drop through to NVs.  */
        }
     }
 #endif
+    useleft = USE_LEFT(TOPm1s);
     {
        dPOPnv;
        if (!useleft) {
@@ -2576,7 +2548,7 @@ PP(pp_sqrt)
 
 PP(pp_int)
 {
-    djSP; dTARGET;
+    djSP; dTARGET; tryAMAGICun(int);
     {
       NV value;
       IV iv = TOPi; /* attempt to convert to IV if possible. */
diff --git a/pp.h b/pp.h
index b05e6d0..d58d187 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -55,6 +55,7 @@ Refetch the stack pointer.  Used after a callback.  See L<perlcall>.
 
 =cut */
 
+#undef SP /* Solaris 2.7 i386 has this in /usr/include/sys/reg.h */
 #define SP sp
 #define MARK mark
 #define TARG targ
@@ -133,6 +134,7 @@ Pops a long off the stack.
 
 #define TOPs           (*sp)
 #define TOPm1s         (*(sp-1))
+#define TOPp1s         (*(sp+1))
 #define TOPp           (SvPV(TOPs, PL_na))             /* deprecated */
 #define TOPpx          (SvPV(TOPs, n_a))
 #define TOPn           (SvNV(TOPs))
index 0f1fee9..2216c2a 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -344,99 +344,137 @@ PP(pp_add)
        public IOK flag if the value in the NV (or PV) slot is truly integer.
 
        A side effect is that this also aggressively prefers integer maths over
-       fp maths for integer values.  */
+       fp maths for integer values.
+
+       How to detect overflow? 
+
+       C 99 section 6.2.6.1 says
+
+       The range of nonnegative values of a signed integer type is a subrange
+       of the corresponding unsigned integer type, and the representation of
+       the same value in each type is the same. A computation involving
+       unsigned operands can never overflow, because a result that cannot be
+       represented by the resulting unsigned integer type is reduced modulo
+       the number that is one greater than the largest value that can be
+       represented by the resulting type.
+
+       (the 9th paragraph)
+
+       which I read as "unsigned ints wrap."
+
+       signed integer overflow seems to be classed as "exception condition"
+
+       If an exceptional condition occurs during the evaluation of an
+       expression (that is, if the result is not mathematically defined or not
+       in the range of representable values for its type), the behavior is
+       undefined.
+
+       (6.5, the 5th paragraph)
+
+       I had assumed that on 2s complement machines signed arithmetic would
+       wrap, hence coded pp_add and pp_subtract on the assumption that
+       everything perl builds on would be happy.  After much wailing and
+       gnashing of teeth it would seem that irix64 knows its ANSI spec well,
+       knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
+       unsigned code below is actually shorter than the old code. :-)
+    */
+
     SvIV_please(TOPs);
     if (SvIOK(TOPs)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
+       register UV auv;
+       bool auvok;
+       bool a_valid = 0;
+
        if (!useleft) {
-           /* left operand is undef, treat as zero. + 0 is identity. */
-           if (SvUOK(TOPs)) {
-               dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
-               SETu(value);
-               RETURN;
-           } else {
-               dPOPiv;
-               SETi(value);
-               RETURN;
+           auv = 0;
+           a_valid = auvok = 1;
+           /* left operand is undef, treat as zero. + 0 is identity,
+              Could SETi or SETu right now, but space optimise by not adding
+              lots of code to speed up what is probably a rarish case.  */
+       } else {
+           /* Left operand is defined, so is it IV? */
+           SvIV_please(TOPm1s);
+           if (SvIOK(TOPm1s)) {
+               if ((auvok = SvUOK(TOPm1s)))
+                   auv = SvUVX(TOPm1s);
+               else {
+                   register IV aiv = SvIVX(TOPm1s);
+                   if (aiv >= 0) {
+                       auv = aiv;
+                       auvok = 1;      /* Now acting as a sign flag.  */
+                   } else { /* 2s complement assumption for IV_MIN */
+                       auv = (UV)-aiv;
+                   }
+               }
+               a_valid = 1;
            }
        }
-       /* Left operand is defined, so is it IV? */
-       SvIV_please(TOPm1s);
-       if (SvIOK(TOPm1s)) {
-           bool auvok = SvUOK(TOPm1s);
+       if (a_valid) {
+           bool result_good = 0;
+           UV result;
+           register UV buv;
            bool buvok = SvUOK(TOPs);
-       
-           if (!auvok && !buvok) { /* ## IV + IV ## */
-               IV aiv = SvIVX(TOPm1s);
-               IV biv = SvIVX(TOPs);
-               IV result = aiv + biv;
-               
-               if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
-                   SP--;
-                   SETi( result );
-                   RETURN;
-               }
-               if (biv >=0 && aiv >= 0) {
-                   UV result = (UV)aiv + (UV)biv;
-                   /* UV + UV can only get bigger... */
-                   if (result >= (UV) aiv) {
-                       SP--;
-                       SETu( result );
-                       RETURN;
+           
+           if (buvok)
+               buv = SvUVX(TOPs);
+           else {
+               register IV biv = SvIVX(TOPs);
+               if (biv >= 0) {
+                   buv = biv;
+                   buvok = 1;
+               } else
+                   buv = (UV)-biv;
+           }
+           /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+              else "IV" now, independant of how it came in.
+              if a, b represents positive, A, B negative, a maps to -A etc
+              a + b =>  (a + b)
+              A + b => -(a - b)
+              a + B =>  (a - b)
+              A + B => -(a + b)
+              all UV maths. negate result if A negative.
+              add if signs same, subtract if signs differ. */
+
+           if (auvok ^ buvok) {
+               /* Signs differ.  */
+               if (auv >= buv) {
+                   result = auv - buv;
+                   /* Must get smaller */
+                   if (result <= auv)
+                       result_good = 1;
+               } else {
+                   result = buv - auv;
+                   if (result <= buv) {
+                       /* result really should be -(auv-buv). as its negation
+                          of true value, need to swap our result flag  */
+                       auvok = !auvok;
+                       result_good = 1;
                    }
                }
-               /* Overflow, drop through to NVs (beyond next if () else ) */
-           } else if (auvok && buvok) {        /* ## UV + UV ## */
-               UV auv = SvUVX(TOPm1s);
-               UV buv = SvUVX(TOPs);
-               UV result = auv + buv;
-               if (result >= auv) {
-                   SP--;
+           } else {
+               /* Signs same */
+               result = auv + buv;
+               if (result >= auv)
+                   result_good = 1;
+           }
+           if (result_good) {
+               SP--;
+               if (auvok)
                    SETu( result );
-                   RETURN;
-               }
-               /* Overflow, drop through to NVs (beyond next if () else ) */
-           } else {                    /* ## Mixed IV,UV ## */
-               IV aiv;
-               UV buv;
-               
-               /* addition is commutative so swap if needed (save code) */
-               if (buvok) {
-                   aiv = SvIVX(TOPm1s);
-                   buv = SvUVX(TOPs);
-               } else {
-                   aiv = SvIVX(TOPs);
-                   buv = SvUVX(TOPm1s);
-               }
-       
-               if (aiv >= 0) {
-                   UV result = (UV)aiv + buv;
-                   if (result >= buv) {
-                       SP--;
-                       SETu( result );
-                       RETURN;
-                   }
-               } else if (buv > (UV) IV_MAX) {
-                   /* assuming 2s complement means that IV_MIN == -IV_MIN,
-                      and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
-                      as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
-                      as the value we can be subtracting from it only lies in
-                      the range (-IV_MIN to -1) it can't overflow a UV */
-                   SP--;
-                   SETu( buv - (UV)-aiv );
-                   RETURN;
-               } else {
-                   IV result = (IV) buv + aiv;
-                   /* aiv < 0 so it must get smaller.  */
-                   if (result < (IV) buv) {
-                       SP--;
-                       SETi( result );
-                       RETURN;
+               else {
+                   /* Negate result */
+                   if (result <= (UV)IV_MIN)
+                       SETi( -(IV)result );
+                   else {
+                       /* result valid, but out of range for IV.  */
+                       SETn( -(NV)result );
                    }
                }
-           } /* end of IV+IV / UV+UV / mixed */
+               RETURN;
+           } /* Overflow, drop through to NVs.  */
        }
     }
 #endif
diff --git a/proto.h b/proto.h
index 97e7ba7..e39d33e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -818,6 +818,7 @@ PERL_CALLCONV STRLEN        Perl_utf8_length(pTHX_ U8* s, U8 *e);
 PERL_CALLCONV IV       Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
 PERL_CALLCONV U8*      Perl_utf8_hop(pTHX_ U8 *s, I32 off);
 PERL_CALLCONV U8*      Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len);
+PERL_CALLCONV U8*      Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8);
 PERL_CALLCONV U8*      Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len);
 PERL_CALLCONV UV       Perl_utf8_to_uv_simple(pTHX_ U8 *s, STRLEN* retlen);
 PERL_CALLCONV UV       Perl_utf8_to_uv(pTHX_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags);
@@ -1252,6 +1253,7 @@ STATIC I32        S_sublex_start(pTHX);
 STATIC char *  S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append);
 STATIC HV *    S_find_in_my_stash(pTHX_ char *pkgname, I32 len);
 STATIC SV*     S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type);
+STATIC void    S_tokereport(pTHX_ char *thing, char *s, I32 rv);
 STATIC int     S_ao(pTHX_ int toketype);
 STATIC void    S_depcom(pTHX);
 STATIC char*   S_incl_perldb(pTHX);
index 96a2789..bdcea75 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
 /* *These* symbols are masked to allow static link. */
 #  define Perl_regnext my_regnext
 #  define Perl_save_re_context my_save_re_context
-#  define Perl_reginitcolors my_reginitcolors 
+#  define Perl_reginitcolors my_reginitcolors
 
 #  define PERL_NO_GET_CONTEXT
-#endif 
+#endif
 
 /*SUPPRESS 112*/
 /*
@@ -194,7 +194,7 @@ typedef struct scan_data_t {
  * Forward declarations for pregcomp()'s friends.
  */
 
-static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
+static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
                                      0, 0, 0, 0, 0, 0};
 
 #define SF_BEFORE_EOL          (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
@@ -247,7 +247,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define MARKER1 "HERE"      /* marker as it appears in the description */
 #define MARKER2 " << HERE "  /* marker as it appears within the regex */
-   
+
 #define REPORT_LOCATION " before " MARKER1 " mark in regex m/%.*s" MARKER2 "%s/"
 
 /*
@@ -428,24 +428,24 @@ S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
 {
     STRLEN l = CHR_SVLEN(data->last_found);
     STRLEN old_l = CHR_SVLEN(*data->longest);
-    
+
     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
        sv_setsv(*data->longest, data->last_found);
        if (*data->longest == data->longest_fixed) {
            data->offset_fixed = l ? data->last_start_min : data->pos_min;
            if (data->flags & SF_BEFORE_EOL)
-               data->flags 
+               data->flags
                    |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
            else
                data->flags &= ~SF_FIX_BEFORE_EOL;
        }
        else {
            data->offset_float_min = l ? data->last_start_min : data->pos_min;
-           data->offset_float_max = (l 
-                                     ? data->last_start_max 
+           data->offset_float_max = (l
+                                     ? data->last_start_max
                                      : data->pos_min + data->pos_delta);
            if (data->flags & SF_BEFORE_EOL)
-               data->flags 
+               data->flags
                    |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
            else
                data->flags &= ~SF_FL_BEFORE_EOL;
@@ -569,7 +569,7 @@ S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, str
     } else {
        /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
        if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
-            && (!(or_with->flags & ANYOF_FOLD) 
+            && (!(or_with->flags & ANYOF_FOLD)
                 || (cl->flags & ANYOF_FOLD)) ) {
            int i;
 
@@ -620,7 +620,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
     scan_data_t data_fake;
     struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
-    
+
     while (scan && OP(scan) != END && scan < last) {
        /* Peephole optimizer: */
 
@@ -630,12 +630,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
            U32 stringok = 1;
 #ifdef DEBUGGING
            regnode *stop = scan;
-#endif 
+#endif
 
            next = scan + NODE_SZ_STR(scan);
            /* Skip NOTHING, merge EXACT*. */
            while (n &&
-                  ( PL_regkind[(U8)OP(n)] == NOTHING || 
+                  ( PL_regkind[(U8)OP(n)] == NOTHING ||
                     (stringok && (OP(n) == OP(scan))))
                   && NEXT_OFF(n)
                   && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
@@ -647,14 +647,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
 #ifdef DEBUGGING
                    if (stringok)
                        stop = n;
-#endif 
+#endif
                    n = regnext(n);
                }
                else {
                    int oldl = STR_LEN(scan);
                    regnode *nnext = regnext(n);
-                   
-                   if (oldl + STR_LEN(n) > U8_MAX) 
+               
+                   if (oldl + STR_LEN(n) > U8_MAX)
                        break;
                    NEXT_OFF(scan) += NEXT_OFF(n);
                    STR_LEN(scan) += STR_LEN(n);
@@ -665,7 +665,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
 #ifdef DEBUGGING
                    if (stringok)
                        stop = next - 1;
-#endif 
+#endif
                    n = nnext;
                }
            }
@@ -691,7 +691,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
            int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
            int noff;
            regnode *n = scan;
-           
+       
            /* Skip NOTHING and LONGJMP. */
            while ((n = regnext(n))
                   && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
@@ -700,17 +700,17 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                off += noff;
            if (reg_off_by_arg[OP(scan)])
                ARG(scan) = off;
-           else 
+           else
                NEXT_OFF(scan) = off;
        }
        /* The principal pseudo-switch.  Cannot be a switch, since we
           look into several different things.  */
-       if (OP(scan) == BRANCH || OP(scan) == BRANCHJ 
+       if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
                   || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
            next = regnext(scan);
            code = OP(scan);
-           
-           if (OP(next) == code || code == IFTHEN || code == SUSPEND) { 
+       
+           if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
                I32 max1 = 0, min1 = I32_MAX, num = 0;
                struct regnode_charclass_class accum;
                
@@ -724,7 +724,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
 
                    num++;
                    data_fake.flags = 0;
-                   if (data) {             
+                   if (data) {         
                        data_fake.whilem_c = data->whilem_c;
                        data_fake.last_closep = data->last_closep;
                    }
@@ -738,13 +738,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        cl_init(pRExC_state, &this_class);
                        data_fake.start_class = &this_class;
                        f = SCF_DO_STCLASS_AND;
-                   }               
+                   }           
                    if (flags & SCF_WHILEM_VISITED_POS)
                        f |= SCF_WHILEM_VISITED_POS;
                    /* we suppose the run is continuous, last=next...*/
                    minnext = study_chunk(pRExC_state, &scan, &deltanext,
                                          next, &data_fake, f);
-                   if (min1 > minnext) 
+                   if (min1 > minnext)
                        min1 = minnext;
                    if (max1 < minnext + deltanext)
                        max1 = minnext + deltanext;
@@ -759,7 +759,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        data->whilem_c = data_fake.whilem_c;
                    if (flags & SCF_DO_STCLASS)
                        cl_or(pRExC_state, &accum, &this_class);
-                   if (code == SUSPEND) 
+                   if (code == SUSPEND)
                        break;
                }
                if (code == IFTHEN && num < 2) /* Empty ELSE branch */
@@ -785,7 +785,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        flags &= ~SCF_DO_STCLASS;
                    }
                    else {
-                       /* Switch to OR mode: cache the old value of 
+                       /* Switch to OR mode: cache the old value of
                         * data->start_class */
                        StructCopy(data->start_class, &and_with,
                                   struct regnode_charclass_class);
@@ -818,7 +818,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                if (data->last_end == -1) { /* Update the start info. */
                    data->last_start_min = data->pos_min;
                    data->last_start_max = is_inf
-                       ? I32_MAX : data->pos_min + data->pos_delta; 
+                       ? I32_MAX : data->pos_min + data->pos_delta;
                }
                sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
                data->last_end = data->pos_min + l;
@@ -830,7 +830,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                int compat = 1;
 
                if (uc >= 0x100 ||
-                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
+                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
                    && !ANYOF_BITMAP_TEST(data->start_class, uc)
                    && (!(data->start_class->flags & ANYOF_FOLD)
                        || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
@@ -859,7 +859,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
            UV uc = *((U8*)STRING(scan));
 
            /* Search for fixed substrings supports EXACT only. */
-           if (flags & SCF_DO_SUBSTR) 
+           if (flags & SCF_DO_SUBSTR)
                scan_commit(pRExC_state, data);
            if (UTF) {
                U8 *s = (U8 *)STRING(scan);
@@ -874,7 +874,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                int compat = 1;
 
                if (uc >= 0x100 ||
-                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
+                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
                    && !ANYOF_BITMAP_TEST(data->start_class, uc)
                    && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc]))
                    compat = 0;
@@ -915,8 +915,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
                    next = NEXTOPER(scan);
                    if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
-                       mincount = 1; 
-                       maxcount = REG_INFTY; 
+                       mincount = 1;
+                       maxcount = REG_INFTY;
                        next = regnext(scan);
                        scan = NEXTOPER(scan);
                        goto do_curly;
@@ -929,12 +929,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
            case STAR:
                if (flags & SCF_DO_STCLASS) {
                    mincount = 0;
-                   maxcount = REG_INFTY; 
+                   maxcount = REG_INFTY;
                    next = regnext(scan);
                    scan = NEXTOPER(scan);
                    goto do_curly;
                }
-               is_inf = is_inf_internal = 1; 
+               is_inf = is_inf_internal = 1;
                scan = regnext(scan);
                if (flags & SCF_DO_SUBSTR) {
                    scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
@@ -942,7 +942,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                }
                goto optimize_curly_tail;
            case CURLY:
-               mincount = ARG1(scan); 
+               mincount = ARG1(scan);
                maxcount = ARG2(scan);
                next = regnext(scan);
                if (OP(scan) == CURLYX) {
@@ -972,15 +972,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                /* These are the cases when once a subexpression
                   fails at a particular position, it cannot succeed
                   even after backtracking at the enclosing scope.
-                  
+               
                   XXXX what if minimal match and we are at the
                        initial run of {n,m}? */
                if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
                    f &= ~SCF_WHILEM_VISITED_POS;
 
                /* This will finish on WHILEM, setting scan, or on NULL: */
-               minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data, 
-                                     mincount == 0 
+               minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
+                                     mincount == 0
                                        ? (f & ~SCF_DO_SUBSTR) : f);
 
                if (flags & SCF_DO_STCLASS)
@@ -990,7 +990,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        cl_or(pRExC_state, data->start_class, &this_class);
                    }
                    else if (flags & SCF_DO_STCLASS_AND) {
-                       /* Switch to OR mode: cache the old value of 
+                       /* Switch to OR mode: cache the old value of
                         * data->start_class */
                        StructCopy(data->start_class, &and_with,
                                   struct regnode_charclass_class);
@@ -1011,7 +1011,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                }
                if (!scan)              /* It was not CURLYX, but CURLY. */
                    scan = next;
-               if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0) 
+               if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0)
                    && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
                    && maxcount <= REG_INFTY/3) /* Complement check for big count */
                {
@@ -1020,14 +1020,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                }
 
                min += minnext * mincount;
-               is_inf_internal |= ((maxcount == REG_INFTY 
+               is_inf_internal |= ((maxcount == REG_INFTY
                                     && (minnext + deltanext) > 0)
                                    || deltanext == I32_MAX);
                is_inf |= is_inf_internal;
                delta += (minnext + deltanext) * maxcount - minnext * mincount;
 
                /* Try powerful optimization CURLYX => CURLYN. */
-               if (  OP(oscan) == CURLYX && data 
+               if (  OP(oscan) == CURLYX && data
                      && data->flags & SF_IN_PAR
                      && !(data->flags & SF_HAS_EVAL)
                      && !deltanext && minnext == 1 ) {
@@ -1039,11 +1039,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                    nxt = regnext(nxt);
                    if (!strchr((char*)PL_simple,OP(nxt))
                        && !(PL_regkind[(U8)OP(nxt)] == EXACT
-                            && STR_LEN(nxt) == 1)) 
+                            && STR_LEN(nxt) == 1))
                        goto nogo;
                    nxt2 = nxt;
                    nxt = regnext(nxt);
-                   if (OP(nxt) != CLOSE) 
+                   if (OP(nxt) != CLOSE)
                        goto nogo;
                    /* Now we know that nxt2 is the only contents: */
                    oscan->flags = ARG(nxt);
@@ -1056,12 +1056,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                    OP(nxt) = OPTIMIZED;        /* was CLOSE. */
                    OP(nxt + 1) = OPTIMIZED; /* was count. */
                    NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
-#endif 
+#endif
                }
              nogo:
 
                /* Try optimization CURLYX => CURLYM. */
-               if (  OP(oscan) == CURLYX && data 
+               if (  OP(oscan) == CURLYX && data
                      && !(data->flags & SF_HAS_PAR)
                      && !(data->flags & SF_HAS_EVAL)
                      && !deltanext  ) {
@@ -1072,7 +1072,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
 
                    OP(oscan) = CURLYM;
                    while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
-                           && (OP(nxt2) != WHILEM)) 
+                           && (OP(nxt2) != WHILEM))
                        nxt = nxt2;
                    OP(nxt2)  = SUCCEED; /* Whas WHILEM */
                    /* Need to optimize away parenths. */
@@ -1080,7 +1080,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        /* Set the parenth number.  */
                        regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
 
-                       if (OP(nxt) != CLOSE) 
+                       if (OP(nxt) != CLOSE)
                            FAIL("Panic opt close");
                        oscan->flags = ARG(nxt);
                        OP(nxt1) = OPTIMIZED;   /* was OPEN. */
@@ -1090,11 +1090,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        OP(nxt + 1) = OPTIMIZED; /* was count. */
                        NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
                        NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
-#endif 
+#endif
 #if 0
                        while ( nxt1 && (OP(nxt1) != WHILEM)) {
                            regnode *nnxt = regnext(nxt1);
-                           
+                       
                            if (nnxt == nxt) {
                                if (reg_off_by_arg[OP(nxt1)])
                                    ARG_SET(nxt1, nxt2 - nxt1);
@@ -1107,7 +1107,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        }
 #endif
                        /* Optimize again: */
-                       study_chunk(pRExC_state, &nxt1, &deltanext, nxt, 
+                       study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
                                    NULL, 0);
                    }
                    else
@@ -1129,14 +1129,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                    PREVOPER(nxt)->flags = data->whilem_c
                        | (RExC_whilem_seen << 4); /* On WHILEM */
                }
-               if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) 
+               if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
                    pars++;
                if (flags & SCF_DO_SUBSTR) {
                    SV *last_str = Nullsv;
                    int counted = mincount != 0;
 
                    if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
-                       I32 b = pos_before >= data->last_start_min 
+                       I32 b = pos_before >= data->last_start_min
                            ? pos_before : data->last_start_min;
                        STRLEN l;
                        char *s = SvPV(data->last_found, l);
@@ -1152,11 +1152,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                            /* What was added is a constant string */
                            if (mincount > 1) {
                                SvGROW(last_str, (mincount * l) + 1);
-                               repeatcpy(SvPVX(last_str) + l, 
+                               repeatcpy(SvPVX(last_str) + l,
                                          SvPVX(last_str), l, mincount - 1);
                                SvCUR(last_str) *= mincount;
                                /* Add additional parts. */
-                               SvCUR_set(data->last_found, 
+                               SvCUR_set(data->last_found,
                                          SvCUR(data->last_found) - l);
                                sv_catsv(data->last_found, last_str);
                                data->last_end += l * (mincount - 1);
@@ -1179,10 +1179,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        if (mincount && last_str) {
                            sv_setsv(data->last_found, last_str);
                            data->last_end = data->pos_min;
-                           data->last_start_min = 
+                           data->last_start_min =
                                data->pos_min - CHR_SVLEN(last_str);
-                           data->last_start_max = is_inf 
-                               ? I32_MAX 
+                           data->last_start_max = is_inf
+                               ? I32_MAX
                                : data->pos_min + data->pos_delta
                                - CHR_SVLEN(last_str);
                        }
@@ -1266,7 +1266,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (isALNUM(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1295,7 +1295,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (!isALNUM(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1324,7 +1324,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (isSPACE(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1353,7 +1353,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (!isSPACE(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1384,7 +1384,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (isDIGIT(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1401,7 +1401,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
                        else {
                            for (value = 0; value < 256; value++)
                                if (!isDIGIT(value))
-                                   ANYOF_BITMAP_SET(data->start_class, value);                     
+                                   ANYOF_BITMAP_SET(data->start_class, value);                 
                        }
                    }
                    break;
@@ -1427,7 +1427,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
            int f = 0;
 
            data_fake.flags = 0;
-           if (data) {             
+           if (data) {         
                data_fake.whilem_c = data->whilem_c;
                data_fake.last_closep = data->last_closep;
            }
@@ -1501,7 +1501,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
   finish:
     *scanp = scan;
     *deltap = is_inf_internal ? I32_MAX : delta;
-    if (flags & SCF_DO_SUBSTR && is_inf) 
+    if (flags & SCF_DO_SUBSTR && is_inf)
        data->pos_delta = I32_MAX - data->pos_min;
     if (is_par > U8_MAX)
        is_par = 0;
@@ -1522,8 +1522,8 @@ STATIC I32
 S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
 {
     if (RExC_rx->data) {
-       Renewc(RExC_rx->data, 
-              sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1), 
+       Renewc(RExC_rx->data,
+              sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
               char, struct reg_data);
        Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
        RExC_rx->data->count += n;
@@ -1543,7 +1543,7 @@ Perl_reginitcolors(pTHX)
 {
     int i = 0;
     char *s = PerlEnv_getenv("PERL_RE_COLORS");
-           
+       
     if (s) {
        PL_colors[0] = s = savepv(s);
        while (++i < 6) {
@@ -1556,7 +1556,7 @@ Perl_reginitcolors(pTHX)
                PL_colors[i] = s = "";
        }
     } else {
-       while (i < 6) 
+       while (i < 6)
            PL_colors[i++] = "";
     }
     PL_colorset = 1;
@@ -1760,13 +1760,13 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            first = NEXTOPER(first);
            goto again;
        }
-       if (sawplus && (!sawopen || !RExC_sawback) 
+       if (sawplus && (!sawopen || !RExC_sawback)
            && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
            /* x+ must match at the 1st pos of run of x's */
            r->reganch |= ROPT_SKIP;
 
        /* Scan is after the zeroth branch, first is atomic matcher. */
-       DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n", 
+       DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
                              (IV)(first - scan + 1)));
        /*
        * If there's something expensive in the r.e., find the
@@ -1797,7 +1797,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
                             &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
        if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
-            && data.last_start_min == 0 && data.last_end > 0 
+            && data.last_start_min == 0 && data.last_end > 0
             && !RExC_seen_zerolen
             && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
            r->reganch |= ROPT_CHECK_ALL;
@@ -1850,7 +1850,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            SvREFCNT_dec(data.longest_fixed);
            longest_fixed_length = 0;
        }
-       if (r->regstclass 
+       if (r->regstclass
            && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
            r->regstclass = NULL;
        if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
@@ -1859,7 +1859,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            SV *sv;
            I32 n = add_data(pRExC_state, 1, "f");
 
-           New(1006, RExC_rx->data->data[n], 1, 
+           New(1006, RExC_rx->data->data[n], 1,
                struct regnode_charclass_class);
            StructCopy(data.start_class,
                       (struct regnode_charclass_class*)RExC_rx->data->data[n],
@@ -1911,7 +1911,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            SV *sv;
            I32 n = add_data(pRExC_state, 1, "f");
 
-           New(1006, RExC_rx->data->data[n], 1, 
+           New(1006, RExC_rx->data->data[n], 1,
                struct regnode_charclass_class);
            StructCopy(data.start_class,
                       (struct regnode_charclass_class*)RExC_rx->data->data[n],
@@ -1926,7 +1926,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     }
 
     r->minlen = minlen;
-    if (RExC_seen & REG_SEEN_GPOS) 
+    if (RExC_seen & REG_SEEN_GPOS)
        r->reganch |= ROPT_GPOS_SEEN;
     if (RExC_seen & REG_SEEN_LOOKBEHIND)
        r->reganch |= ROPT_LOOKBEHIND_SEEN;
@@ -1977,9 +1977,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
            switch (paren) {
            case '<':
                RExC_seen |= REG_SEEN_LOOKBEHIND;
-               if (*RExC_parse == '!') 
+               if (*RExC_parse == '!')
                    paren = ',';
-               if (*RExC_parse != '=' && *RExC_parse != '!') 
+               if (*RExC_parse != '=' && *RExC_parse != '!')
                    goto unknown;
                RExC_parse++;
            case '=':
@@ -2021,21 +2021,21 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
                while (count && (c = *RExC_parse)) {
                    if (c == '\\' && RExC_parse[1])
                        RExC_parse++;
-                   else if (c == '{') 
+                   else if (c == '{')
                        count++;
-                   else if (c == '}') 
+                   else if (c == '}')
                        count--;
                    RExC_parse++;
                }
                if (*RExC_parse != ')')
                {
-                   RExC_parse = s;                 
+                   RExC_parse = s;             
                    vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
                }
                if (!SIZE_ONLY) {
                    AV *av;
-                   
-                   if (RExC_parse - 1 - s) 
+               
+                   if (RExC_parse - 1 - s)
                        sv = newSVpvn(s, RExC_parse - 1 - s);
                    else
                        sv = newSVpvn("", 0);
@@ -2074,8 +2074,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
            case '(':
            {
                if (RExC_parse[0] == '?') {
-                   if (RExC_parse[1] == '=' || RExC_parse[1] == '!' 
-                       || RExC_parse[1] == '<' 
+                   if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
+                       || RExC_parse[1] == '<'
                        || RExC_parse[1] == '{') { /* Lookahead or eval. */
                        I32 flag;
                        
@@ -2084,7 +2084,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
                            ret->flags = 1;
                        regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
                        goto insert_if;
-                   } 
+                   }
                }
                else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
                    parno = atoi(RExC_parse++);
@@ -2300,18 +2300,18 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
     register regnode *latest;
     I32 flags = 0, c = 0;
 
-    if (first) 
+    if (first)
        ret = NULL;
     else {
-       if (!SIZE_ONLY && RExC_extralen) 
+       if (!SIZE_ONLY && RExC_extralen)
            ret = reganode(pRExC_state, BRANCHJ,0);
        else
            ret = reg_node(pRExC_state, BRANCH);
     }
        
-    if (!first && SIZE_ONLY) 
+    if (!first && SIZE_ONLY)
        RExC_extralen += 1;                     /* BRANCHJ */
-    
+
     *flagp = WORST;                    /* Tentatively. */
 
     RExC_parse--;
@@ -2466,7 +2466,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
 
     if (!(flags&HASWIDTH) && op != '?')
       vFAIL("Regexp *+ operand could be empty");
-#endif 
+#endif
 
     nextchar(pRExC_state);
 
@@ -2546,7 +2546,7 @@ tryagain:
        break;
     case '$':
        nextchar(pRExC_state);
-       if (*RExC_parse) 
+       if (*RExC_parse)
            RExC_seen_zerolen++;
        if (RExC_flags16 & PMf_MULTILINE)
            ret = reg_node(pRExC_state, MEOL);
@@ -2872,7 +2872,7 @@ tryagain:
                    case 'x':
                        if (*++p == '{') {
                            char* e = strchr(p, '}');
-        
+       
                            if (!e) {
                                RExC_parse = p + 1;
                                vFAIL("Missing right brace on \\x{}");
@@ -3028,7 +3028,7 @@ S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
         *RExC_parse == '.')) {
        char  c = *RExC_parse;
        char* s = RExC_parse++;
-           
+       
        while (RExC_parse < RExC_end && *RExC_parse != c)
            RExC_parse++;
        if (RExC_parse == RExC_end)
@@ -3292,7 +3292,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state)
            case 'x':
                if (*RExC_parse == '{') {
                    e = strchr(RExC_parse++, '}');
-                    if (!e) 
+                    if (!e)
                         vFAIL("Missing right brace on \\x{}");
                    numlen = 1;         /* allow underscores */
                    value = (UV)scan_hex(RExC_parse,
@@ -3813,7 +3813,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state)
        ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
     }
 
-    if (!SIZE_ONLY) { 
+    if (!SIZE_ONLY) {
        AV *av = newAV();
        SV *rv;
 
@@ -3926,7 +3926,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
     register regnode *dst;
     register regnode *place;
     register int offset = regarglen[(U8)op];
-    
+
 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
 
     if (SIZE_ONLY) {
@@ -4039,13 +4039,13 @@ S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
                      (int)(2*l + 1), "", SvPVX(sv));
        if (next == NULL)               /* Next ptr. */
            PerlIO_printf(Perl_debug_log, "(0)");
-       else 
+       else
            PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
        (void)PerlIO_putc(Perl_debug_log, '\n');
       after_print:
        if (PL_regkind[(U8)op] == BRANCHJ) {
-           register regnode *nnode = (OP(next) == LONGJMP 
-                                      ? regnext(next) 
+           register regnode *nnode = (OP(next) == LONGJMP
+                                      ? regnext(next)
                                       : next);
            if (last && nnode > last)
                nnode = last;
@@ -4101,25 +4101,25 @@ Perl_regdump(pTHX_ regexp *r)
     /* Header fields of interest. */
     if (r->anchored_substr)
        PerlIO_printf(Perl_debug_log,
-                     "anchored `%s%.*s%s'%s at %"IVdf" ", 
+                     "anchored `%s%.*s%s'%s at %"IVdf" ",
                      PL_colors[0],
                      (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
-                     SvPVX(r->anchored_substr), 
+                     SvPVX(r->anchored_substr),
                      PL_colors[1],
                      SvTAIL(r->anchored_substr) ? "$" : "",
                      (IV)r->anchored_offset);
     if (r->float_substr)
        PerlIO_printf(Perl_debug_log,
-                     "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ", 
+                     "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
                      PL_colors[0],
-                     (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)), 
+                     (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
                      SvPVX(r->float_substr),
                      PL_colors[1],
                      SvTAIL(r->float_substr) ? "$" : "",
                      (IV)r->float_min_offset, (UV)r->float_max_offset);
     if (r->check_substr)
-       PerlIO_printf(Perl_debug_log, 
-                     r->check_substr == r->float_substr 
+       PerlIO_printf(Perl_debug_log,
+                     r->check_substr == r->float_substr
                      ? "(checking floating" : "(checking anchored");
     if (r->reganch & ROPT_NOSCAN)
        PerlIO_printf(Perl_debug_log, " noscan");
@@ -4274,12 +4274,12 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
        {
            SV *lv;
            SV *sw = regclass_swash(o, FALSE, &lv);
-           
+       
            if (lv) {
                if (sw) {
                    UV i;
                    U8 s[UTF8_MAXLEN+1];
-                   
+               
                    for (i = 0; i <= 256; i++) { /* just the first 256 */
                        U8 *e = uv_to_utf8(s, i);
                        
@@ -4288,7 +4288,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
                                rangestart = i;
                        } else if (rangestart != -1) {
                            U8 *p;
-                           
+                       
                            if (i <= rangestart + 3)
                                for (; rangestart < i; rangestart++) {
                                    for(e = uv_to_utf8(s, rangestart), p = s; p < e; p++)
@@ -4311,9 +4311,9 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
                {
                    char *s = savepv(SvPVX(lv));
                    char *origs = s;
-                   
+               
                    while(*s && *s != '\n') s++;
-                   
+               
                    if (*s == '\n') {
                        char *t = ++s;
                        
@@ -4327,7 +4327,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
                        
                        sv_catpv(sv, t);
                    }
-                   
+               
                    Safefree(origs);
                }
            }
@@ -4492,7 +4492,7 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
 
 void
 Perl_save_re_context(pTHX)
-{                   
+{
 #if 0
     SAVEPPTR(RExC_precomp);            /* uncompiled string. */
     SAVEI32(RExC_npar);                /* () count. */
@@ -4517,9 +4517,8 @@ Perl_save_re_context(pTHX)
     SAVEVPTR(PL_reglastparen);         /* Similarly for lastparen. */
     SAVEPPTR(PL_regtill);              /* How far we are required to go. */
     SAVEI8(PL_regprev);                        /* char before regbol, \n if none */
-    SAVEVPTR(PL_reg_start_tmp);                /* from regexec.c */
+    SAVEGENERICPV(PL_reg_start_tmp);           /* from regexec.c */
     PL_reg_start_tmp = 0;
-    SAVEFREEPV(PL_reg_start_tmp);
     SAVEI32(PL_reg_start_tmpl);                /* from regexec.c */
     PL_reg_start_tmpl = 0;
     SAVEVPTR(PL_regdata);
@@ -4539,7 +4538,7 @@ Perl_save_re_context(pTHX)
     SAVEVPTR(PL_reg_curpm);            /* from regexec.c */
     SAVEI32(PL_regnpar);               /* () count. */
 #ifdef DEBUGGING
-    SAVEPPTR(PL_reg_starttry);         /* from regexec.c */    
+    SAVEPPTR(PL_reg_starttry);         /* from regexec.c */
 #endif
 }
 
index eef5f59..c70d1b1 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -147,8 +147,12 @@ S_regcppush(pTHX_ I32 parenfloor)
     SSPUSHINT(PL_regsize);
     SSPUSHINT(*PL_reglastparen);
     SSPUSHPTR(PL_reginput);
-    SSPUSHINT(paren_elems_to_push + (REGCP_PAREN_ELEMS - 1));
+#define REGCP_FRAME_ELEMS 2
+/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
+ * are needed for the regexp context stack bookkeeping. */
+    SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
+
     return retval;
 }
 
@@ -179,7 +183,8 @@ S_regcppop(pTHX)
     PL_regsize = SSPOPINT;
 
     /* Now restore the parentheses context. */
-    for (i -= (REGCP_PAREN_ELEMS - 1); i > 0; i -= REGCP_PAREN_ELEMS) {
+    for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
+        i > 0; i -= REGCP_PAREN_ELEMS) {
        paren = (U32)SSPOPINT;
        PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
        PL_regstartp[paren] = SSPOPINT;
diff --git a/sv.c b/sv.c
index 93188df..31a90e7 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2448,6 +2448,9 @@ Perl_looks_like_number(pTHX_ SV *sv)
     I32 numtype = 0;
     I32 sawinf  = 0;
     STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+    bool specialradix = FALSE;
+#endif
 
     if (SvPOK(sv)) {
        sbegin = SvPVX(sv);
@@ -2514,10 +2517,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
 
         if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-           || IS_NUMERIC_RADIX(*s)
+           || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
            ) {
-           s++;
+#ifdef USE_LOCALE_NUMERIC
+           if (specialradix)
+               s += SvCUR(PL_numeric_radix);
+           else
+#endif
+               s++;
            numtype |= IS_NUMBER_NOT_INT;
             while (isDIGIT(*s))  /* optional digits after the radix */
                 s++;
@@ -2525,10 +2533,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
     }
     else if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-           || IS_NUMERIC_RADIX(*s)
+           || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
            ) {
-        s++;
+#ifdef USE_LOCALE_NUMERIC
+       if (specialradix)
+           s += SvCUR(PL_numeric_radix);
+       else
+#endif
+           s++;
        numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
         /* no digits before the radix means we need digits after it */
         if (isDIGIT(*s)) {
@@ -3530,16 +3543,17 @@ void
 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 {
     register char *dptr;
-    {
-        /* len is STRLEN which is unsigned, need to copy to signed */
-       IV iv = len;
-       assert(iv >= 0);
-    }
+
     SV_CHECK_THINKFIRST(sv);
     if (!ptr) {
        (void)SvOK_off(sv);
        return;
     }
+    else {
+        /* len is STRLEN which is unsigned, need to copy to signed */
+       IV iv = len;
+       assert(iv >= 0);
+    }
     (void)SvUPGRADE(sv, SVt_PV);
 
     SvGROW(sv, len + 1);
@@ -4689,30 +4703,24 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 
     /* do not utf8ize the comparands as a side-effect */
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+       bool is_utf8 = TRUE;
+
        if (PL_hints & HINT_UTF8_DISTINCT)
            return FALSE;
 
        if (SvUTF8(sv1)) {
-           (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
-           {
-               IV scur1 = cur1;
-               if (scur1 < 0) {
-                   Safefree(pv1);
-                   return 0;
-               }
-           }
-           pv1tmp = TRUE;
+           char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+           if (is_utf8)
+               return 0;
+           pv1tmp = (pv != pv1);
+           pv1 = pv;
        }
        else {
-           (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
-           {
-               IV scur2 = cur2;
-               if (scur2 < 0) {
-                   Safefree(pv2);
-                   return 0;
-               }
-           }
-           pv2tmp = TRUE;
+           char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+           if (is_utf8)
+               return 0;
+           pv2tmp = (pv != pv2);
+           pv2 = pv;
        }
     }
 
@@ -5600,6 +5608,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
         len = -len;
         is_utf8 = TRUE;
     }
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       src = (char*)bytes_from_utf8((U8*)src, (STRLEN*)&len, &is_utf8);
     if (!hash)
        PERL_HASH(hash, src, len);
     new_SV(sv);
@@ -8836,7 +8846,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_numeric_name    = SAVEPV(proto_perl->Inumeric_name);
     PL_numeric_standard        = proto_perl->Inumeric_standard;
     PL_numeric_local   = proto_perl->Inumeric_local;
-    PL_numeric_radix   = proto_perl->Inumeric_radix;
+    PL_numeric_radix   = sv_dup_inc(proto_perl->Inumeric_radix);
 #endif /* !USE_LOCALE_NUMERIC */
 
     /* utf8 character classes */
diff --git a/t/TEST b/t/TEST
index cfee26c..65b1aa4 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -112,7 +112,7 @@ EOT
                }
                else {
                    $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
-                   if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) {
+                   if (/^ok (\d+)(\s*#.*)?/ && $1 == $next) {
                        $next = $next + 1;
                     }
                     elsif (/^Bail out!\s*(.*)/i) { # magic words
index 49df11f..061cd33 100755 (executable)
@@ -48,5 +48,5 @@ else {
     die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
 }
 
-open(try, "../Configure") || (die "Can't open ../Configure.");
+open(try, "harness") || (die "Can't open harness.");
 if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";}
index 560836d..c840c92 100755 (executable)
@@ -9,7 +9,7 @@ $TST = 'tst';
 $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
              $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin');
 
-open($TST, '../Configure') || (die "Can't open ../Configure");
+open($TST, 'harness') || (die "Can't open harness");
 binmode $TST if $Is_Dosish;
 if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
 
@@ -49,7 +49,7 @@ unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
 if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; }
 
 $curline = $.;
-open(other, '../Configure') || (die "Can't open ../Configure");
+open(other, 'harness') || (die "Can't open harness: $!");
 binmode other if $^O eq 'MSWin32';
 
 {
index 04554e7..d0201aa 100755 (executable)
@@ -91,17 +91,17 @@ print "not " unless $y == 1;
 print "ok 17\n";
 }
 
-print F $b,"\n"; # This upgrades $b!
+print F $b,"\n"; # Don't upgrades $b
 
 { # Check byte length of $b
 use bytes; my $y = length($b);
-print "not " unless $y == 2;
+print "not ($y) " unless $y == 1;
 print "ok 18\n";
 }
 
 { my $x = tell(F); 
     { use bytes; $y += 3;}
-    print "not " unless $x == $y;
+    print "not ($x,$y) " unless $x == $y;
     print "ok 19\n";
 }
 
@@ -110,14 +110,14 @@ close F;
 open F, "a" or die $!; # Not UTF
 $x = <F>;
 chomp($x);
-print "not " unless $x eq v196.172.194.130;
+printf "not (%vd) ", $x unless $x eq v196.172.194.130;
 print "ok 20\n";
 
 open F, "<:utf8", "a" or die $!;
 $x = <F>;
 chomp($x);
 close F;
-print "not " unless $x eq chr(300).chr(130);
+printf "not (%vd) ", $x unless $x eq chr(300).chr(130);
 print "ok 21\n";
 
 # Now let's make it suffer.
index e853dee..21e0c7c 100644 (file)
@@ -8,48 +8,73 @@ BEGIN {
 use strict;
 use warnings;
 use Config;
-use File::Find;
 
 my %Core_Modules;
 
-find(sub {
-        if ($File::Find::name =~ m!^lib\W+(.+)\.pm$!i) {
-           my $module = $1;
-           $module =~ s/[^\w-]/::/g;
-           $Core_Modules{$module}++;
-       }
-    }, "lib");
+unless (open(MANIFEST, "MANIFEST")) {
+    die "$0: failed to open 'MANIFEST': $!\n";
+}
+
+sub add_by_name {
+    $Core_Modules{$_[0]}++;
+}
+
+while (<MANIFEST>) {
+    next unless m!^lib/(\S+?)\.pm!;
+    my $module = $1;
+    $module =~ s!/!::!g;
+    add_by_name($module);
+}
+
+close(MANIFEST);
 
 # Delete stuff that can't be tested here.
 
-sub delete_unless_in_extensions {
-    delete $Core_Modules{$_[0]} unless $Config{extensions} =~ /\b$_[0]\b/;
+sub delete_by_name {
+    delete $Core_Modules{$_[0]};
+}
+
+sub has_extension {
+    $Config{extensions} =~ /\b$_[0]\b/i;
+}
+
+sub delete_unless_has_extension {
+    delete $Core_Modules{$_[0]} unless has_extension($_[0]);
 }
 
 foreach my $known_extension (split(' ', $Config{known_extensions})) {
-    delete_unless_in_extensions($known_extension);
+    delete_unless_has_extension($known_extension);
 }
 
 sub delete_by_prefix {
-    delete @Core_Modules{grep { /^$_[0]/ } keys %Core_Modules};
+    for my $match (grep { /^$_[0]/ } keys %Core_Modules) {
+       delete_by_name($match);
+    }
 }
 
-delete $Core_Modules{'CGI::Fast'}; # won't load without FCGI
+delete_by_name('CGI::Fast');           # won't load without FCGI
 
-delete $Core_Modules{'Devel::DProf'}; # needs to be run as -d:DProf
+delete_by_name('Devel::DProf');                # needs to be run as -d:DProf
 
 delete_by_prefix('ExtUtils::MM_');     # ExtUtils::MakeMaker's domain
 
 delete_by_prefix('File::Spec::');      # File::Spec's domain
-$Core_Modules{'File::Spec::Functions'}++;      # put this back
+add_by_name('File::Spec::Functions');  # put this back
 
-unless ($Config{extensions} =~ /\bThread\b/) {
-    delete $Core_Modules{Thread};
+sub using_feature {
+    my $use = "use$_[0]";
+    exists $Config{$use} &&
+       defined $Config{$use} &&
+       $Config{$use} eq 'define';
+}
+
+unless (using_feature('threads') && has_extension('Thread')) {
+    delete_by_name('Thread');
     delete_by_prefix('Thread::');
 }
 
 delete_by_prefix('unicode::');
-$Core_Modules{'unicode::distinct'}++;  # put this back
+add_by_name('unicode::distinct');      # put this back
 
 # Okay, this is the list.
 
@@ -65,11 +90,10 @@ foreach my $module (@Core_Modules) {
     $test_num++;
 }
 
-
-# We do this as a separate process else we'll blow the hell out of our
-# namespace.
+# We do this as a separate process else we'll blow the hell
+# out of our namespace.
 sub compile_module {
-    my($module) = @_;
+    my ($module) = $_[0];
     
     return scalar `./perl -Ilib t/lib/compmod.pl $module` =~ /^ok/;
 }
index 42760c8..1f7dc14 100755 (executable)
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -71,6 +71,8 @@ my $a;
 my $Is_VMS = $^O eq 'VMS';
 $a = `$^X "-I../lib" "-MO=Deparse" -anle 1 2>&1`;
 $a =~ s/-e syntax OK\n//g;
+$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
+$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 $b = <<'EOF';
 
 LINE: while (defined($_ = <ARGV>)) {
@@ -130,6 +132,9 @@ $a =~ s/-uCwd,// if $^O eq 'cygwin';
 if ($Config{static_ext} eq ' ') {
   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
      . '-umain,-ustrict,-uwarnings';
+  if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
+      $b = join ',', sort split /,/, $b;
+  }
   print "# [$a] vs [$b]\nnot " if $a ne $b;
   ok;
 } else {
@@ -140,7 +145,12 @@ if ($is_thread) {
     print "# use5005threads: test $test skipped\n";
 } else {
     $a = `$^X "-I../lib" "-MO=Showlex" -e "my %one" 2>&1`;
-    print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
+    if (ord('A') != 193) { # ASCIIish
+        print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
+    } 
+    else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
+        print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
+    }
 }
 ok;
 
index b335d13..a9725ba 100755 (executable)
@@ -9,7 +9,7 @@ use Math::BigFloat;
 
 $test = 0;
 $| = 1;
-print "1..362\n";
+print "1..406\n";
 while (<DATA>) {
        chop;
        if (s/^&//) {
@@ -33,6 +33,8 @@ while (<DATA>) {
                    $try .= "-\$x;";
                } elsif ($f eq "fabs") {
                    $try .= "abs \$x;";
+               } elsif ($f eq "fint") {
+                   $try .= "int \$x;";
                } elsif ($f eq "fround") {
                    $try .= "0+\$x->fround($args[1]);";
                } elsif ($f eq "ffround") {
@@ -73,6 +75,25 @@ while (<DATA>) {
                }
        }
 } 
+
+{
+  use Math::BigFloat ':constant';
+
+  $test++;
+  # print "# " . 2. * '1427247692705959881058285969449495136382746624' . "\n";
+  print "not "
+    unless 2. * '1427247692705959881058285969449495136382746624'
+           == "2854495385411919762116571938898990272765493248.";
+  print "ok $test\n";
+  $test++;
+  @a = ();
+  for ($i = 1.; $i < 10; $i++) {
+    push @a, $i;
+  }
+  print "not " unless "@a" eq "1. 2. 3. 4. 5. 6. 7. 8. 9.";
+  print "ok $test\n";
+}
+
 __END__
 &fnorm
 abc:NaN.
@@ -461,3 +482,46 @@ $Math::BigFloat::div_scale = 40
 +100:10.
 +123.456:11.11107555549866648462149404118219234119
 +15241.383936:123.456
+&fint
++0:+0
++1:+1
++11111111111111111234:+11111111111111111234
+-1:-1
+-11111111111111111234:-11111111111111111234
++0.3:+0
++1.3:+1
++23.3:+23
++12345678901234567890:+12345678901234567890
++12345678901234567.890:+12345678901234567
++12345678901234567890E13:+123456789012345678900000000000000
++12345678901234567.890E13:+123456789012345678900000000000
++12345678901234567890E-3:+12345678901234567
++12345678901234567.890E-3:+12345678901234
++12345678901234567890E-13:+1234567
++12345678901234567.890E-13:+1234
++12345678901234567890E-17:+123
++12345678901234567.890E-16:+1
++12345678901234567.890E-17:+0
++12345678901234567890E-19:+1
++12345678901234567890E-20:+0
++12345678901234567890E-21:+0
++12345678901234567890E-225:+0
+-0:+0
+-0.3:+0
+-1.3:-1
+-23.3:-23
+-12345678901234567890:-12345678901234567890
+-12345678901234567.890:-12345678901234567
+-12345678901234567890E13:-123456789012345678900000000000000
+-12345678901234567.890E13:-123456789012345678900000000000
+-12345678901234567890E-3:-12345678901234567
+-12345678901234567.890E-3:-12345678901234
+-12345678901234567890E-13:-1234567
+-12345678901234567.890E-13:-1234
+-12345678901234567890E-17:-123
+-12345678901234567.890E-16:-1
+-12345678901234567.890E-17:+0
+-12345678901234567890E-19:-1
+-12345678901234567890E-20:+0
+-12345678901234567890E-21:+0
+-12345678901234567890E-225:+0
index e76f246..dac6f5f 100755 (executable)
@@ -9,7 +9,7 @@ use Math::BigInt;
 
 $test = 0;
 $| = 1;
-print "1..278\n";
+print "1..283\n";
 while (<DATA>) {
        chop;
        if (s/^&//) {
@@ -25,6 +25,8 @@ while (<DATA>) {
                    $try .= "-\$x;";
                } elsif ($f eq "babs") {
                    $try .= "abs \$x;";
+               } elsif ($f eq "bint") {
+                   $try .= "int \$x;";
                } else {
                    $try .= "\$y = new Math::BigInt \"$args[1]\";";
                    if ($f eq "bcmp"){
@@ -375,3 +377,9 @@ abc:NaN
 +0:-1
 +8:-9
 +281474976710656:-281474976710657
+&bint
++0:+0
++1:+1
++11111111111111111234:+11111111111111111234
+-1:-1
+-11111111111111111234:-11111111111111111234
index 14da2e0..d00396f 100644 (file)
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..13\n";
+print "1..14\n";
 
 use charnames ':full';
 
@@ -44,8 +44,7 @@ $encoded_alpha = "\316\261";
 $encoded_bet = "\327\221";
 
 sub to_bytes {
-    use bytes;
-    "".shift;
+    pack"a*", shift;
 }
 
 {
@@ -90,3 +89,10 @@ sub to_bytes {
     print "ok 13\n";
 }
 
+{
+   use charnames qw(:full);
+   use utf8;
+   print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
+   print "ok 14\n";
+}
+
index cbdeca4..152cddc 100644 (file)
@@ -17,7 +17,10 @@ $dpp .= '.com' if $^O eq 'VMS';
 
 print "\nperl: $perl\n" if $opt_v;
 if( ! -f $perl ){ die "Where's Perl?" }
-if( ! -f $dpp ){ die "Where's dprofpp?" }
+if( ! -f $dpp ) { 
+    ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@;
+    die "Where's dprofpp?" if( ! -f $dpp );
+}
 
 sub dprofpp {
        my $switches = shift;
index 288d3bd..7bf1793 100644 (file)
@@ -101,7 +101,7 @@ do_test( 7,
   REFCNT = 1
   FLAGS = \\(NOK,pNOK\\)
   IV = 0
-  NV = 789\\.1
+  NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
   PV = $ADDR "789"\\\0
   CUR = 3
   LEN = 4');
diff --git a/t/lib/sample-tests/bailout b/t/lib/sample-tests/bailout
new file mode 100644 (file)
index 0000000..f67f673
--- /dev/null
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+Bail out!  GERONIMMMOOOOOO!!!
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/t/lib/sample-tests/combined b/t/lib/sample-tests/combined
new file mode 100644 (file)
index 0000000..8dfaa28
--- /dev/null
@@ -0,0 +1,13 @@
+print <<DUMMY_TEST;
+1..10 todo 4 10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3        all hell broke lose
+ok 4
+ok
+ok 6
+ok 7            # Skip contract negociations
+ok 8
+not ok 9
+not ok 10
+DUMMY_TEST
diff --git a/t/lib/sample-tests/descriptive b/t/lib/sample-tests/descriptive
new file mode 100644 (file)
index 0000000..e165ac1
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1    Interlock activated
+ok 2    Megathrusters are go
+ok 3    Head formed
+ok 4    Blazing sword formed
+ok 5    Robeast destroyed
+DUMMY_TEST
diff --git a/t/lib/sample-tests/duplicates b/t/lib/sample-tests/duplicates
new file mode 100644 (file)
index 0000000..63f6a70
--- /dev/null
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST
+1..10
+ok 1
+ok 2
+ok 3
+ok 4
+ok 4
+ok 5
+ok 6
+ok 7
+ok 8
+ok 9
+ok 10
+DUMMY_TEST
diff --git a/t/lib/sample-tests/header_at_end b/t/lib/sample-tests/header_at_end
new file mode 100644 (file)
index 0000000..14a32f2
--- /dev/null
@@ -0,0 +1,11 @@
+print <<DUMMY_TEST;
+# comments
+ok 1
+ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
diff --git a/t/lib/sample-tests/no_nums b/t/lib/sample-tests/no_nums
new file mode 100644 (file)
index 0000000..c32d3f2
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok
+ok
+not ok
+ok
+ok
+DUMMY_TEST
diff --git a/t/lib/sample-tests/simple b/t/lib/sample-tests/simple
new file mode 100644 (file)
index 0000000..d6b8584
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/t/lib/sample-tests/simple_fail b/t/lib/sample-tests/simple_fail
new file mode 100644 (file)
index 0000000..aa65f5f
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+not ok 2
+ok 3
+ok 4
+not ok 5
+DUMMY_TEST
diff --git a/t/lib/sample-tests/skip b/t/lib/sample-tests/skip
new file mode 100644 (file)
index 0000000..1b43d12
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2    # skipped rain delay
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/t/lib/sample-tests/skip_all b/t/lib/sample-tests/skip_all
new file mode 100644 (file)
index 0000000..8c46796
--- /dev/null
@@ -0,0 +1,3 @@
+print <<DUMMY_TEST;
+1..0 # skip: rope
+DUMMY_TEST
diff --git a/t/lib/sample-tests/todo b/t/lib/sample-tests/todo
new file mode 100644 (file)
index 0000000..5620ee2
--- /dev/null
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5 todo 3   2;
+ok 1
+ok 2
+not ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/t/lib/sample-tests/with_comments b/t/lib/sample-tests/with_comments
new file mode 100644 (file)
index 0000000..7aa9139
--- /dev/null
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST;
+# and stuff
+1..5 todo 1 2 4 5;
+# yeah, that
+not ok 1
+# Failed test 1 in t/todo.t at line 9 *TODO*
+ok 2 # (t/todo.t at line 10 TODO?!)
+ok 3
+not ok 4
+# Test 4 got: '0' (t/todo.t at line 12 *TODO*)
+#   Expected: '1' (need more tuits)
+ok 5 # (t/todo.t at line 13 TODO?!)
+# woo
+DUMMY_TEST
index e1a0780..8512974 100644 (file)
@@ -86,15 +86,29 @@ sub obj { $_[0]->{obj} }
 
 package main;
 
+my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
+
 my $r = ROOT->make;
 
 my $data = '';
-while (<DATA>) {
-       next if /^#/;
-       $data .= unpack("u", $_);
+if (!$Is_EBCDIC) {
+       while (<DATA>) {
+           next if /^#/;
+           $data .= unpack("u", $_);
+       }
+}
+else {
+       while (<DATA>) {
+           next if /^#$/;    # skip comments
+           next if /^#\s+/;  # skip comments
+           next if /^[^#]/;  # skip uuencoding for ASCII machines
+           s/^#//;           # prepare uuencoded data for EBCDIC machines
+           $data .= unpack("u", $_);
+       }
 }
 
-ok 1, length $data == 278;
+my $expected_length = $Is_EBCDIC ? 217 : 278;
+ok 1, length $data == $expected_length;
 
 my $y = thaw($data);
 ok 2, 1;
@@ -130,3 +144,12 @@ M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93
 M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
 M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
 (9F($4D]/5%@`
+#
+# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make));
+# on OS/390 (cp 1047) original size: 217 bytes
+#
+#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H
+#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D)
+#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("````
+#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00`````
+#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0``
diff --git a/t/lib/test-harness.t b/t/lib/test-harness.t
new file mode 100644 (file)
index 0000000..90326d9
--- /dev/null
@@ -0,0 +1,202 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+
+# For shutting up Test::Harness.
+package My::Dev::Null;
+use Tie::Handle;
+@ISA = qw(Tie::StdHandle);
+
+sub WRITE { }
+
+
+package main;
+
+# Utility testing functions.
+my $test_num = 1;
+sub ok ($;$) {
+    my($test, $name) = @_;
+    print "not " unless $test;
+    print "ok $test_num";
+    print " - $name" if defined $name;
+    print "\n";
+    $test_num++;
+}
+
+sub eqhash {
+    my($a1, $a2) = @_;
+    return 0 unless keys %$a1 == keys %$a2;
+
+    my $ok = 1;
+    foreach my $k (keys %$a1) {
+        $ok = $a1->{$k} eq $a2->{$k};
+        last unless $ok;
+    }
+
+    return $ok;
+}
+
+
+my $loaded;
+BEGIN { $| = 1; $^W = 1; }
+END {print "not ok $test_num\n" unless $loaded;}
+print "1..$Total_tests\n";
+use Test::Harness;
+$loaded = 1;
+ok(1, 'compile');
+######################### End of black magic.
+
+BEGIN {
+    %samples = (
+                simple            => {
+                                      bonus      => 0,
+                                      max        => 5,
+                                      ok         => 5,
+                                      files      => 1,
+                                      bad        => 0,
+                                      good       => 1,
+                                      tests      => 1,
+                                      sub_skipped=> 0,
+                                      skipped    => 0,
+                                     },
+                simple_fail      => {
+                                     bonus       => 0,
+                                     max         => 5,
+                                     ok          => 3,
+                                     files       => 1,
+                                     bad         => 1,
+                                     good        => 0,
+                                     tests       => 1,
+                                     sub_skipped => 0,
+                                     skipped     => 0,
+                                    },
+                descriptive       => {
+                                      bonus      => 0,
+                                      max        => 5,
+                                 &