This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate changes#6469..6484,6486..6501,6504..6505,6507..6509,
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 27 Nov 2000 11:50:46 +0000 (11:50 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 27 Nov 2000 11:50:46 +0000 (11:50 +0000)
6511..6513,6515..6523,6525..6536

    The swallow_bom() saga continues.  The #23 of require.t
    (UTF16-LE) still fails (silently, no output) but the #22
    (UTF16-BE) seems to be working now.  The root of the
    failure may be in sv_gets(): is it UTF-16LE-aware,
    especially when it comes to line endings?

    Document the problem with -P in HP-UX and its workaround.

    Subject: [PATCH] allow non-variable as lhs of non-updating tr///
    (aka ID 20000730.002)

    Subject: fix and question re: waitpid() under win32

    Make the safety catch for buggy gccs work with triple version
    numbers like 2.95.2.  Reported in
    Subject: [ID 20000731.005] Perl 5.6.0 "Configure" fails to recognize gcc 2.95.2

    In Digital UNIX warn if gcc explicitly chosen because even
    2.95.2 is known to cause problems.

    Make chr() for values >127 to create utf8 when under utf8.

    various syntax errors and such (not fixed: comp/require.t#22 coredump
    on Windows)

    Stash away the largefiles flags and libswanted.

    BOM patching from Simon Cozens.

    If gccosandvers is equal to osname, clear gccosandvers.

    Make p4desc to skip non-mainperl branches by default.

    Subject: [Proposed PATCH] Let Perl define QUAD_MIN and _MAX itself

    The test from this
    Subject: Re: [ID 20000411.002] qw() gives different results in 5.6 to previous versions

    In new BSDs changes to argv[] do not show up in ps(1) output,
    instead one must use setproctitle().  This was already addressed
    by change #6457, but the below has a new variant for FreeBSD 4.0
    or later, and the matter is also documented more.

    FreeBSD 3.* updates from
    Subject: [ID 20000801.007] setting $0 on FreeBSD 4.x does not get reflected in /bin/ps

    regen_headers, regen perltoc.

    Document in one place the memory abstractions used in Perl core.

    memcpy has n o in it, as pinted ut by Sarathy.

    Remove the extraneous "main::" prefix from all the
    "opened only for", "on closed", and "never opened" warnings.

    The name of a filehandle does not have <these>.

    The tr utf8 patching continues.

    The new setproctitle() feature is available only in
    bleeding edge FreeBSD.  From Paul Saab.

    Subject: [PATCH bleadperl] [ID 20000731.010] regex error

    Dump UVs as UVs in Data::Dumper.

    detypo #6494

    Document the IVdf UVuf UVof UVxf.

    require.t needs binmode() to work on windows

    Generate OP_IS_SOCKET() and OP_IS_FILETEST() macros
    that are hopefully soon put into use.

    Allow "no Module;" even if there is no 'unimport'.

    Better skip message for the test; one of the two problems in
    Subject: [ID 20000224.003] Not OK: perl v5.5.660 on i86pc-solaris 2.7

    The subtest 4 may fail also on VOBS, as pointed out
    by Nick Ing-Simmons in November 1999, bug id 19991124.003
    (but the failure in that bug report isn't the subtest 4).

    Be more informative on what is skipped and why,
    also repeat the list at the end.

    Add a URL for FSF.

    Subject: [PATCH] sv.h documentation - SvLEN

    Subject: [PATCH bleadperl] [ID 20000803.001] further regexp counting problems

    Subject: [PATCH perl-current] Comings and goings in op/sprintf.t

    Subject: [PATCH] bad cppsymbols on os2 + Configure question

    Subject: [ID 20000802.002] [PATCH] memory pseudo-leak in sv_dump

    Subject: [ID 20000802.004] Tests op/grent.t and op/pwent.t fail unnecessarily
    mention the idea of @( and @)

    This is 6512.  Really.

    Subject: [ID 19990721.004] Documentation bug in perlfunc

    Subject: Minor tweak to perlvar.pod

    In the warnings call filehandles consistently so;
    add "unopened" warning for stat().

    After the #6519 a warning about stat() is just that,
    not about a filetest, which now have their own warning.

    Subject: [ID 20000804.002] configure.gnu and arguments with whitespace characters

    Subject: Re: Array vs. List context

    Subject: New perlcc, take 2

    Weed buglets pointed out by
    Subject: Re: [ID 20000803.005] miniperl aborts during Perl make

    gcc versions might have (parentheses) in them.

    Subject: [ID 20000724.004] Perl interpreter segfault when using built-in flock

    Essential prototype changes were missing from #6527.
    Also make report_evil_fh() more bomb-proof.

    Zap lib/Sys directory when cleaning up.

    Change the Policy policy: now -Dprefix= with an existing
    Policy.sh and prefix == siteprefix == vendorprefix, then all
    of them follow along the new prefix.
    Subject: Re: [ID 20000508.002] -Dprefix completely broken [PATCH]

    Continue fixing the io warnings.  This also
    sort of fixes bug ID 20000802.003: the core dump
    is no more.  Whether the current behaviour is correct
    (giving a warning: "Not a format reference"), is another matter.

    Have symbols for the IoTYPEs.

    Subject: [PATCH] perlfunc.pod use documentation (5.6.0)

    Document a bit that UDP is not what you might think.
    Subject: Re: IO::Socket::INET bug sending large UDP packets/fragmentation
    tr memory corruption fix from Simon Cozens.

    Plug the security hole described in the Aug 05 2000 bugtraq message
    "sperl 5.00503 (and newer ;) exploit" by Michal Zalewski.
    The security hole exists only in suidperls, which isn't
    installed or even built by default.

p4raw-link: @6504 on //depot/perl: 631c47bf5044f10b5ce4a2b023eba24f85f536e5
p4raw-link: @6501 on //depot/perl: 22ba6426feae3c16a356ca31868a38eb31e39920
p4raw-link: @6486 on //depot/perl: 7029d033ad2d1a409046f74708867c2819cbafa0
p4raw-link: @6484 on //depot/perl: 298e5f695df9e9b8ba9d8ecad678734c47cd6d78
p4raw-link: @6469 on //depot/perl: dea0fc0b9e5a61b92c4be2ecafe0a8d9396d4cc1
p4raw-link: @6457 on //depot/perl: 0c9177abdae6e91f4dfdab2ef3cc817ec901e51eon //depot/metaconfig: efc5abcdbec468dfb20e18acbe3ab6c1cd9e92c3

p4raw-id: //depot/maint-5.6/perl@7883
p4raw-integrated: from //depot/perl@7882 'copy in' configure.gnu
(@3131..) Policy_sh.SH (@5266..) t/op/numconvert.t (@5345..)
pod/perlcall.pod (@6344..) ext/Data/Dumper/Dumper.xs (@6494..)
'edit in' Porting/p4desc (@6480..) t/pragma/warn/doio (@6519..)
'merge in' t/pragma/warn/4lint (@6466..)
p4raw-integrated: from //depot/perl@6536 'merge in' perl.c (@6442..)
p4raw-integrated: from //depot/perl@6535 'edit in' doop.c (@6491..)
p4raw-integrated: from //depot/perl@6534 'copy in' pod/perlipc.pod
(@6422..)
p4raw-integrated: from //depot/perl@6533 'edit in' pod/perlfunc.pod
(@6524..)
p4raw-integrated: from //depot/perl@6532 'copy in' pp_ctl.c (@6442..)
'edit in' toke.c (@6478..) sv.h (@6507..) doio.c pp_sys.c
util.c (@6531..)
p4raw-integrated: from //depot/perl@6531 'edit in' t/pragma/warn/pp_hot
(@6489..) pod/perldiag.pod (@6524..) pp_hot.c
t/pragma/warn/pp_sys (@6527..)
p4raw-integrated: from //depot/perl@6529 'merge in' Makefile.SH
(@6510..)
p4raw-integrated: from //depot/perl@6528 'edit in' embed.h (@6489..)
p4raw-integrated: from //depot/perl@6527 'edit in' embed.pl proto.h
(@6489..)
p4raw-integrated: from //depot/perl@6526 'edit in' Configure
config_h.SH (@6525..)
p4raw-integrated: from //depot/perl@6523 'copy in' utils/perlcc.PL
(@5726..)
p4raw-integrated: from //depot/perl@6522 'copy in' pod/perlembed.pod
(@6284..) pod/perlfaq4.pod (@6344..) pod/perlapi.pod (@6450..)
p4raw-integrated: from //depot/perl@6518 'edit in' pod/perlvar.pod
(@6483..)
p4raw-integrated: from //depot/perl@6517 'copy in' pod/perlop.pod
(@6350..)
p4raw-integrated: from //depot/perl@6516 'copy in' dump.c (@5683..)
p4raw-integrated: from //depot/perl@6515 'copy in' Todo-5.6 (@6355..)
p4raw-integrated: from //depot/perl@6513 'copy in' t/op/grent.t
t/op/pwent.t (@6076..)
p4raw-integrated: from //depot/perl@6512 'ignore' sv.c (@6465..)
p4raw-integrated: from //depot/perl@6509 'copy in' t/op/sprintf.t
(@6386..)
p4raw-integrated: from //depot/perl@6508 'copy in' regcomp.c (@6458..)
'edit in' t/op/re_tests (@6493..)
p4raw-integrated: from //depot/perl@6505 'copy in' README (@5009..)
p4raw-integrated: from //depot/perl@6501 'copy in' t/op/stat.t
(@5266..)
p4raw-integrated: from //depot/perl@6499 'copy in' gv.c (@6489..)
p4raw-integrated: from //depot/perl@6498 'copy in' opcode.h opcode.pl
opnames.h (@6434..)
p4raw-integrated: from //depot/perl@6497 'edit in' t/comp/require.t
(@6469..)
p4raw-integrated: from //depot/perl@6496 'copy in' pod/perlguts.pod
(@6488..)
p4raw-integrated: from //depot/perl@6493 'copy in' regexec.c (@6400..)
p4raw-integrated: from //depot/perl@6492 'edit in' mg.c (@6483..)
p4raw-integrated: from //depot/perl@6489 'edit in' objXSUB.h (@6469..)
p4raw-integrated: from //depot/perl@6486 'copy in' pod/perltoc.pod
(@6373..) perlapi.c (@6438..)
p4raw-integrated: from //depot/perl@6484 'copy in' hints/freebsd.sh
(@5767..)
p4raw-integrated: from //depot/perl@6483 'merge in' perl.h (@6481..)
p4raw-integrated: from //depot/perl@6482 'copy in' t/op/misc.t
(@5979..)
p4raw-integrated: from //depot/perl@6477 'copy in' hints/aix.sh
(@5570..) hints/hpux.sh (@5733..) hints/linux.sh (@5823..)
hints/solaris_2.sh (@6355..)
p4raw-integrated: from //depot/perl@6476 'copy in' win32/win32.c
(@6472..) t/pragma/utf8.t (@6475..) 'merge in' utf8.c (@6469..)
p4raw-integrated: from //depot/perl@6475 'merge in' pp.c (@6445..)
p4raw-integrated: from //depot/perl@6474 'copy in' hints/dec_osf.sh
(@6473..)
p4raw-integrated: from //depot/perl@6472 'copy in' win32/win32.h
(@6350..)
p4raw-integrated: from //depot/perl@6471 'merge in' t/op/tr.t (@6373..)
op.c (@6431..)
p4raw-integrated: from //depot/perl@6470 'copy in' README.hpux
(@6352..)

69 files changed:
Configure
Makefile.SH
Policy_sh.SH
Porting/p4desc
README
README.hpux
Todo-5.6
config_h.SH
configure.gnu
doio.c
doop.c
dump.c
embed.h
embed.pl
ext/Data/Dumper/Dumper.xs
gv.c
hints/aix.sh
hints/dec_osf.sh
hints/freebsd.sh
hints/hpux.sh
hints/linux.sh
hints/solaris_2.sh
mg.c
objXSUB.h
op.c
opcode.pl
opnames.h
perl.c
perl.h
perlapi.c
pod/perlapi.pod
pod/perlcall.pod
pod/perldiag.pod
pod/perlembed.pod
pod/perlfaq4.pod
pod/perlfunc.pod
pod/perlguts.pod
pod/perlipc.pod
pod/perlop.pod
pod/perltoc.pod
pod/perlvar.pod
pp.c
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regcomp.c
regexec.c
sv.h
t/comp/require.t
t/op/grent.t
t/op/misc.t
t/op/numconvert.t
t/op/pwent.t
t/op/re_tests
t/op/sprintf.t
t/op/stat.t
t/op/tr.t
t/pragma/utf8.t
t/pragma/warn/4lint
t/pragma/warn/doio
t/pragma/warn/pp_hot
t/pragma/warn/pp_sys
toke.c
utf8.c
util.c
utils/perlcc.PL
win32/win32.c
win32/win32.h

index 26d6ca3..1c7764d 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 Sat Jul 29 02:48:03 EET DST 2000 [metaconfig 3.0 PL70]
+# Generated on Sat Aug  5 00:21:09 EET DST 2000 [metaconfig 3.0 PL70]
 # (with additional metaconfig patches by perlbug@perl.com)
 
 cat >/tmp/c1$$ <<EOF
@@ -625,6 +625,7 @@ i_grp=''
 i_iconv=''
 i_ieeefp=''
 i_inttypes=''
+i_libutil=''
 i_limits=''
 i_locale=''
 i_machcthr=''
@@ -900,6 +901,9 @@ uidtype=''
 archname64=''
 use64bitall=''
 use64bitint=''
+ccflags_uselargefiles=''
+ldflags_uselargefiles=''
+libswanted_uselargefiles=''
 uselargefiles=''
 uselongdouble=''
 usemorebits=''
@@ -993,6 +997,9 @@ plibpth=''
 libswanted=''
 : some systems want to use only the non-versioned libso:s
 ignore_versioned_solibs=''
+ccflags_uselargefiles=''
+ldflags_uselargefiles=''
+libswanted_uselargefiles=''
 : set usemultiplicity on the Configure command line to enable multiplicity.
 : set usesocks on the Configure command line to enable socks.
 : set usethreads on the Configure command line to enable threads.
@@ -3179,9 +3186,12 @@ case "$gccversion" in
 esac
 case "$gccversion" in
 '') gccosandvers='' ;;
-*) gccosandvers=`$cc -v 2>&1|grep '/specs$'|sed 's!.*/[^-]*-[^-]*-\([^/]*\)/'$gccversion'/specs$!\1!'`
+*) gccshortvers=`echo "$gccversion"|sed 's/ .*//'`
+   gccosandvers=`$cc -v 2>&1|grep '/specs$'|sed "s!.*/[^-/]*-[^-/]*-\([^-/]*\)/$gccshortvers/specs!\1!"`
+   gccshortvers=''
    case "$gccosandvers" in
-   $osname$osvers) ;;
+   $osname) gccosandvers='' ;; # linux gccs seem to have no linux osvers, grr
+   $osname$osvers) ;; # looking good
    $osname*) cat <<EOM >&4
 
 *** WHOA THERE!!! ***
@@ -3195,7 +3205,8 @@ case "$gccversion" in
 
     I'm trying to be optimistic here, though, and will continue.
     If later during the configuration and build icky compilation
-    problems appear, I suggest reinstalling the gcc to match
+    problems appear (headerfile conflicts being the most common
+    manifestation), I suggest reinstalling the gcc to match
     your operating system release.
 
 EOM
@@ -14366,6 +14377,10 @@ eval $inhdr
 set ieeefp.h i_ieeefp
 eval $inhdr
 
+: see if this is a libutil.h system
+set libutil.h i_libutil
+eval $inhdr
+
 : see if locale.h is available
 set locale.h i_locale
 eval $inhdr
@@ -14517,8 +14532,9 @@ $osname
 EOSH
 ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a
 ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b
-$cat Cppsym.a Cppsym.b | $tr ' ' $trnl | sort | uniq > Cppsym.know
-$rm -f Cppsym.a Cppsym.b
+$cat Cppsym.know > Cppsym.c
+$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | sort | uniq > Cppsym.know
+$rm -f Cppsym.a Cppsym.b Cppsym.c
 cat <<EOSH > Cppsym
 $startsh
 if $test \$# -gt 0; then
@@ -14557,6 +14573,7 @@ cat <<EOSH >> Cppsym.try
 ccflags="$ccflags"
 case "$osname-$gccversion" in
 irix-) ccflags="\$ccflags -woff 1178" ;;
+os2-*) ccflags="\$ccflags -Zlinker /PM:VIO" ;;
 esac
 $cc $optimize \$ccflags $ldflags -o try try.c $libs && ./try$exe_ext
 EOSH
@@ -14612,7 +14629,7 @@ if $test -z ccsym.raw; then
 else
        if $test -s ccsym.com; then
                echo "Your C compiler and pre-processor define these symbols:"
-               $sed -e 's/\(.*\)=.*/\1/' ccsym.com
+               $sed -e 's/\(..*\)=.*/\1/' ccsym.com
                also='also '
                symbols='ones'
                cppccsymbols=`$cat ccsym.com`
@@ -14622,7 +14639,7 @@ else
        if $test -s ccsym.cpp; then
                $test "$also" && echo " "
                echo "Your C pre-processor ${also}defines the following symbols:"
-               $sed -e 's/\(.*\)=.*/\1/' ccsym.cpp
+               $sed -e 's/\(..*\)=.*/\1/' ccsym.cpp
                also='further '
                cppsymbols=`$cat ccsym.cpp`
                cppsymbols=`echo $cppsymbols`
@@ -14631,14 +14648,14 @@ else
        if $test -s ccsym.own; then
                $test "$also" && echo " "
                echo "Your C compiler ${also}defines the following cpp symbols:"
-               $sed -e 's/\(.*\)=1/\1/' ccsym.own
-               $sed -e 's/\(.*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true
+               $sed -e 's/\(..*\)=1/\1/' ccsym.own
+               $sed -e 's/\(..*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true
                ccsymbols=`$cat ccsym.own`
                ccsymbols=`echo $ccsymbols`
                $test "$silent" || sleep 1
        fi
 fi
-$rm -f ccsym*
+$rm -f ccsym* Cppsym.*
 
 : see if this is a termio system
 val="$undef"
@@ -15283,6 +15300,7 @@ cc='$cc'
 cccdlflags='$cccdlflags'
 ccdlflags='$ccdlflags'
 ccflags='$ccflags'
+ccflags_uselargefiles='$ccflags_uselargefiles'
 ccsymbols='$ccsymbols'
 cf_by='$cf_by'
 cf_email='$cf_email'
@@ -15675,6 +15693,7 @@ i_grp='$i_grp'
 i_iconv='$i_iconv'
 i_ieeefp='$i_ieeefp'
 i_inttypes='$i_inttypes'
+i_libutil='$i_libutil'
 i_limits='$i_limits'
 i_locale='$i_locale'
 i_machcthr='$i_machcthr'
@@ -15770,6 +15789,7 @@ large='$large'
 ld='$ld'
 lddlflags='$lddlflags'
 ldflags='$ldflags'
+ldflags_uselargefiles='$ldflags_uselargefiles'
 ldlibpthname='$ldlibpthname'
 less='$less'
 lib_ext='$lib_ext'
@@ -15782,6 +15802,7 @@ libsfiles='$libsfiles'
 libsfound='$libsfound'
 libspath='$libspath'
 libswanted='$libswanted'
+libswanted_uselargefiles='$libswanted_uselargefiles'
 line='$line'
 lint='$lint'
 lkflags='$lkflags'
index 5480824..b17e404 100644 (file)
@@ -710,7 +710,7 @@ _cleaner:
        rm -f h2ph.man pstruct
        rm -rf .config
        rm -f testcompile compilelog
-       -rmdir lib/B lib/Data lib/IO/Socket lib/IO
+       -rmdir lib/B lib/Data lib/IO/Socket lib/IO lib/Sys
 
 # The following lint has practically everything turned on.  Unfortunately,
 # you have to wade through a lot of mumbo jumbo that can't be suppressed.
index 0d9c1df..fec18b9 100644 (file)
@@ -7,18 +7,33 @@ $startsh
 #
 #  This file was produced by running the Policy_sh.SH script, which
 #  gets its values from config.sh, which is generally produced by
-#  running Configure.  The Policy.sh file gets overwritten each time
-#  Configure is run.  Any variables you add to Policy.sh will be lost
-#  unless you copy Policy.sh somewhere else before running Configure.
+#  running Configure.  
 #
 #  The idea here is to distill in one place the common site-wide
 #  "policy" answers (such as installation directories) that are
 #  to be "sticky".  If you keep the file Policy.sh around in
 #  the same directory as you are building Perl, then Configure will
 #  (by default) load up the Policy.sh file just before the
-#  platform-specific hints file.
+#  platform-specific hints file and rewrite it at the end.
+#
+#   The sequence of events is as follows:
+#   A:  If you are NOT re-using an old config.sh:
+#   1.  At start-up, Configure loads up the defaults from the
+#      os-specific  hints/osname_osvers.sh file and any previous
+#      Policy.sh file.
+#   2.  At the end, Configure runs Policy_sh.SH, which creates
+#      Policy.sh, overwriting a previous Policy.sh if necessary.
+#
+#   B: If you are re-using an old config.sh:
+#   1.  At start-up, Configure loads up the defaults from config.sh, 
+#      ignoring any previous Policy.sh file.
+#   2.  At the end, Configure runs Policy_sh.SH, which creates
+#      Policy.sh, overwriting a previous Policy.sh if necessary.
+#
+#  Thus the Policy.sh file gets overwritten each time
+#  Configure is run.  Any variables you add to Policy.sh will be lost
+#  unless you copy Policy.sh somewhere else before running Configure.
 #
-
 #  Allow Configure command-line overrides; usually these won't be
 #  needed, but something like -Dprefix=/test/location can be quite
 #  useful for testing out new versions.
@@ -37,16 +52,37 @@ esac
 case "\$prefix" in
 '') prefix='$prefix' ;;
 esac
+
+# By default, the next three are the same as \$prefix.  
+# If the user changes \$prefix, and previously \$siteprefix was the
+# same as \$prefix, then change \$siteprefix as well.
+# Use similar logic for \$vendorprefix and \$installprefix.
+
 case "\$siteprefix" in
-'') siteprefix='$siteprefix' ;;
+'') if test "$siteprefix" = "$prefix"; then
+       siteprefix="\$prefix"
+    else
+       siteprefix='$siteprefix'
+    fi
+    ;;
 esac
 case "\$vendorprefix" in
-'') vendorprefix='$vendorprefix' ;;
+'') if test "$vendorprefix" = "$prefix"; then
+       vendorprefix="\$prefix"
+    else
+       vendorprefix='$vendorprefix'
+    fi
+    ;;
 esac
 
 # Where installperl puts things.
 case "\$installprefix" in
-'') installprefix='$installprefix' ;;
+'') if test "$installprefix" = "$prefix"; then
+       installprefix="\$prefix"
+    else
+       installprefix='$installprefix'
+    fi
+    ;;
 esac
 
 # Installation directives.  Note that each one comes in three flavors.
index 0bf79da..2d1c9d8 100755 (executable)
@@ -6,7 +6,8 @@
 # Gurusamy Sarathy <gsar@activestate.com>
 #
 
-use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles);
+use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles
+           $branches $skip);
 
 BEGIN {
     $0 =~ s|^.*/||;
@@ -18,6 +19,9 @@ BEGIN {
         elsif (/^-p(.*)$/) {
            $p4port = $1 || ' ';
        }
+        elsif (/^-b(.*)$/) {
+           $branches = $1;
+       }
        elsif (/^-v$/) {
            $v++;
        }
@@ -30,20 +34,28 @@ BEGIN {
     }
     unless (@files) { @files = '-'; undef $^I; }
     @ARGV = @files;
+    $branches = '//depot/perl/' unless defined $branches;
     if ($h) {
        print STDERR <<USAGE;
 Usage: $0 [-p \$P4PORT] [-v] [-h] [files]
 
-       -p host:port    p4 port (e.g. myhost:1666)
+       -phost:port     p4 port (e.g. myhost:1666)
        -h              print this help
        -v              output progress messages
+       -bbranch(es)    which branches to include (regex)
+                       (default: //depot/perl/)
+       -h              show this help
 
 A smart 'cat'.  When fed the spew from "p4 describe ..." on STDIN,
 spits it right out on STDOUT, followed by patches for any new files
 detected in the spew.  Can also be used to edit insitu a bunch of
 files containing said spew.
 
-WARNING: Currently only emits unified diffs.
+WARNING 1: Currently only emits unified diffs (diff -u).
+
+WARNING 2: By default only the changes in the //depot/perl branch
+are shown.  To include all the branches, supply "-b." arguments
+to $0.
 
 Examples:
        p4 describe -du 123 | $0 > change-123.desc
@@ -65,14 +77,28 @@ my $cur = m|^Affected files| ... m|^Differences|;
 
 # while we are within range
 if ($cur) {
-    if (m{^\.\.\. (//depot/.+?#\d+) (add|branch)$}) {
-       my $newfile = $1;
-       push @addfiles, $newfile;
-       warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/;
+    if (m|^\.\.\. |) {
+       if (m|$branches|) {
+           if (m{^\.\.\. (//depot/.+?\#\d+) (add|branch)$}) {
+               my $newfile = $1;
+               push @addfiles, $newfile;
+               warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/;
+           }
+        } else {
+           push @skipped, "# $_";
+           $_ = '';
+       }
     }
     warn "file [$file] line [$cur] file# [$fnum]\n" if $v;
 }
 
+if (m|^==== //depot/|) { 
+    $skip = !m|$branches|;
+    print "# Skipped because not under branches: $branches\n" if $skip;
+}
+
+$_ = "# $_" if $skip; 
+
 if (/^Change (\d+) by/) {
     $_ = "\n\n" . $_ if $change;       # start of a new change list
     $change = $1;
@@ -84,6 +110,9 @@ if (/^Change (\d+) by/) {
 
 if (eof) {
     $_ .= newfiles();
+    $_ .= join('', "\n",
+               "# Skipped because not under branches: $branches\n",
+               @skipped, "\n") if @skipped; 
 }
 
 sub newfiles {
diff --git a/README b/README
index 0925b98..e846c30 100644 (file)
--- a/README
+++ b/README
     Kit, in the file named "Artistic".  If not, I'll be glad to provide one.
 
     You should also have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software Foundation,
-    Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+    along with this program in the file named "Copying". If not, write to the 
+    Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 
+    02111-1307, USA or visit their web page on the internet at
+    http://www.gnu.org/copyleft/gpl.html.
 
     For those of you that choose to use the GNU General Public License,
     my interpretation of the GNU General Public License is that no Perl
index 5fbddf7..47d1afc 100644 (file)
@@ -241,6 +241,25 @@ If you are compiling Perl on a remotely-mounted NFS filesystem, the test
 io/fs.t may fail on test #18.  This appears to be a bug in HP-UX and no
 fix is currently available.
 
+=head2 perl -P and //
+
+In HP-UX perl is compiled with flags that will cause problems if the
+-P flag of Perl (preprocess Perl code with the C preprocessor before
+perl sees it) is used.  The problem is that C<//>, being a C++-style
+until-end-of-line comment, will disappear along with the remainder
+of the line.  This means that common Perl constructs like
+
+       s/foo//;
+
+will turn into illegal code
+
+       s/foo
+
+The workaround is to use some other quoting characters than /,
+like for example !
+
+       s!foo!!;
+
 =head1 AUTHOR
 
 Jeff Okamoto <okamoto@corp.hp.com>
index d438969..30c7cc0 100644 (file)
--- a/Todo-5.6
+++ b/Todo-5.6
@@ -130,6 +130,7 @@ Win32 stuff
     work out DLL versioning
 
 Miscellaneous
+    introduce @( and @) because group names can have spaces
     add new modules (Archive::Tar, Compress::Zlib, CPAN::FTP?)
     sub-second sleep()? alarm()? time()? (integrate Time::HiRes?
        Configure doesn't yet probe for usleep/nanosleep/ualarm but
@@ -145,7 +146,9 @@ Miscellaneous
        PREFERABLY AS AN EXTENSION.
        As of 5.6.1 there is cpp macro Perl_isnan().
     fix the basic arithmetics (+ - * / %) to preserve IVness/UVness if
-       both arguments are IVs/UVs
+       both arguments are IVs/UVs: it sucks that one cannot see
+       the 'carry flag' (or equivalent) of the CPU from C,
+       C is too high-level...
     replace pod2html with new PodtoHtml? (requires other modules from CPAN)
     automate testing with large parts of CPAN
     Unicode collation? http://www.unicode.org/unicode/reports/tr10/
index aeed85f..8628f58 100644 (file)
@@ -3150,5 +3150,11 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
 #define PERL_XS_APIVERSION "$xs_apiversion"
 #define PERL_PM_APIVERSION "$pm_apiversion"
 
+/* I_LIBUTIL:
+ *     This symbol, if defined, indicates that <libutil.h> exists and
+ *     should be included.
+ */
+#$i_libutil    I_LIBUTIL               /**/
+
 #endif
 !GROK!THIS!
index 2ef8331..f98eb76 100755 (executable)
@@ -86,7 +86,7 @@ EOM
                exit 1
                ;;
        *)
-               opts="$opts $1"
+               opts="$opts '$1'"
                shift
                ;;
        esac
@@ -126,7 +126,7 @@ case "$verbose" in
 *) copt="$copt -d";;
 esac
 
-set X sh Configure $copt $create $opts
+eval "set X sh Configure $copt $create $opts"
 shift
 echo "$@"
 exec "$@"
diff --git a/doio.c b/doio.c
index 19f7861..ceb8321 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -108,7 +108,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 
     if (IoIFP(io)) {
        fd = PerlIO_fileno(IoIFP(io));
-       if (IoTYPE(io) == '-')
+       if (IoTYPE(io) == IoTYPE_STD)
            result = 0;
        else if (fd <= PL_maxsysfd) {
            saveifp = IoIFP(io);
@@ -116,7 +116,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            savetype = IoTYPE(io);
            result = 0;
        }
-       else if (IoTYPE(io) == '|')
+       else if (IoTYPE(io) == IoTYPE_PIPE)
            result = PerlProc_pclose(IoIFP(io));
        else if (IoIFP(io) != IoOFP(io)) {
            if (IoOFP(io)) {
@@ -146,14 +146,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 
        switch (result = rawmode & O_ACCMODE) {
        case O_RDONLY:
-            IoTYPE(io) = '<';
+            IoTYPE(io) = IoTYPE_RDONLY;
             break;
        case O_WRONLY:
-            IoTYPE(io) = '>';
+            IoTYPE(io) = IoTYPE_WRONLY;
             break;
        case O_RDWR:
        default:
-            IoTYPE(io) = '+';
+            IoTYPE(io) = IoTYPE_RDWR;
             break;
        }
 
@@ -265,7 +265,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            TAINT_PROPER("open");
            type++;
            if (*type == '>') {
-               mode[0] = IoTYPE(io) = 'a';
+               mode[0] = IoTYPE(io) = IoTYPE_APPEND;
                type++;
                tlen--;
            }
@@ -320,8 +320,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                             * fsetpos(src)+fgetpos(dst)?  --nik */
                            PerlIO_flush(fp);
                            fd = PerlIO_fileno(fp);
-                           if (IoTYPE(thatio) == 's')
-                               IoTYPE(io) = 's';
+                           if (IoTYPE(thatio) == IoTYPE_SOCKET)
+                               IoTYPE(io) = IoTYPE_SOCKET;
                        }
                        else
                            fd = -1;
@@ -341,7 +341,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                for (; isSPACE(*type); type++) ;
                if (strEQ(type,"-")) {
                    fp = PerlIO_stdout();
-                   IoTYPE(io) = '-';
+                   IoTYPE(io) = IoTYPE_STD;
                }
                else  {
                    fp = PerlIO_open((num_svs ? name : type), mode);
@@ -365,7 +365,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
            if (strEQ(type,"-")) {
                fp = PerlIO_stdin();
-               IoTYPE(io) = '-';
+               IoTYPE(io) = IoTYPE_STD;
            }
            else
                fp = PerlIO_open((num_svs ? name : type), mode);
@@ -403,18 +403,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                    mode = "r";
                fp = PerlProc_popen(name,mode);
            }
-           IoTYPE(io) = '|';
+           IoTYPE(io) = IoTYPE_PIPE;
        }
        else {
            if (num_svs)
                goto unknown_desr;
            name = type;
-           IoTYPE(io) = '<';
+           IoTYPE(io) = IoTYPE_RDONLY;
            /*SUPPRESS 530*/
            for (; isSPACE(*name); name++) ;
            if (strEQ(name,"-")) {
                fp = PerlIO_stdin();
-               IoTYPE(io) = '-';
+               IoTYPE(io) = IoTYPE_STD;
            }
            else {
                char *mode;
@@ -430,19 +430,19 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     }
     if (!fp) {
        dTHR;
-       if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
+       if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
            Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
        goto say_false;
     }
     if (IoTYPE(io) &&
-      IoTYPE(io) != '|' && IoTYPE(io) != '-') {
+      IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
        dTHR;
        if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
            (void)PerlIO_close(fp);
            goto say_false;
        }
        if (S_ISSOCK(PL_statbuf.st_mode))
-           IoTYPE(io) = 's';   /* in case a socket was passed in to us */
+           IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
 #ifdef HAS_SOCKET
        else if (
 #ifdef S_IFMT
@@ -456,7 +456,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
                            &buflen) >= 0
                  || errno != ENOTSOCK)
-               IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
+               IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
                                /* but some return 0 for streams too, sigh */
        }
 #endif
@@ -504,8 +504,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     IoFLAGS(io) &= ~IOf_NOLINE;
     if (writing) {
        dTHR;
-       if (IoTYPE(io) == 's'
-           || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) )
+       if (IoTYPE(io) == IoTYPE_SOCKET
+           || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
        {
            char *mode;
            if (out_raw)
@@ -773,8 +773,8 @@ Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
     IoIFP(wstio) = IoOFP(wstio);
-    IoTYPE(rstio) = '<';
-    IoTYPE(wstio) = '>';
+    IoTYPE(rstio) = IoTYPE_RDONLY;
+    IoTYPE(wstio) = IoTYPE_WRONLY;
     if (!IoIFP(rstio) || !IoOFP(wstio)) {
        if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
        else PerlLIO_close(fd[0]);
@@ -810,9 +810,8 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
     if (!io) {         /* never opened */
        if (not_implicit) {
            dTHR;
-           if (ckWARN(WARN_UNOPENED))
-               Perl_warner(aTHX_ WARN_UNOPENED, 
-                      "Close on unopened file <%s>",GvENAME(gv));
+           if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
+               report_evil_fh(gv, io, PL_op->op_type);
            SETERRNO(EBADF,SS$_IVCHAN);
        }
        return FALSE;
@@ -823,7 +822,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
        IoPAGE(io) = 0;
        IoLINES_LEFT(io) = IoPAGE_LEN(io);
     }
-    IoTYPE(io) = ' ';
+    IoTYPE(io) = IoTYPE_CLOSED;
     return retval;
 }
 
@@ -834,7 +833,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
     int status;
 
     if (IoIFP(io)) {
-       if (IoTYPE(io) == '|') {
+       if (IoTYPE(io) == IoTYPE_PIPE) {
            status = PerlProc_pclose(IoIFP(io));
            if (not_implicit) {
                STATUS_NATIVE_SET(status);
@@ -844,7 +843,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
                retval = (status != -1);
            }
        }
-       else if (IoTYPE(io) == '-')
+       else if (IoTYPE(io) == IoTYPE_STD)
            retval = TRUE;
        else {
            if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
@@ -875,13 +874,22 @@ Perl_do_eof(pTHX_ GV *gv)
     if (!io)
        return TRUE;
     else if (ckWARN(WARN_IO)
-            && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+            && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
                 || IoIFP(io) == PerlIO_stderr()))
     {
-       SV* sv = sv_newmortal();
-       gv_efullname3(sv, gv, Nullch);
-       Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
-                   SvPV_nolen(sv));
+       /* integrate to report_evil_fh()? */
+        char *name = NULL; 
+       if (isGV(gv)) {
+           SV* sv = sv_newmortal();
+           gv_efullname4(sv, gv, Nullch, FALSE);
+           name = SvPV_nolen(sv);
+       }
+       if (name && *name)
+           Perl_warner(aTHX_ WARN_IO,
+                       "Filehandle %s opened only for output", name);
+       else
+           Perl_warner(aTHX_ WARN_IO,
+                       "Filehandle opened only for output");
     }
 
     while (IoIFP(io)) {
@@ -925,8 +933,8 @@ Perl_do_tell(pTHX_ GV *gv)
     }
     {
        dTHR;
-       if (ckWARN(WARN_UNOPENED))
-           Perl_warner(aTHX_ WARN_UNOPENED, "tell() on unopened file");
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
     }
     SETERRNO(EBADF,RMS$_IFI);
     return (Off_t)-1;
@@ -947,8 +955,8 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
     }
     {
        dTHR;
-       if (ckWARN(WARN_UNOPENED))
-           Perl_warner(aTHX_ WARN_UNOPENED, "seek() on unopened file");
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
     }
     SETERRNO(EBADF,RMS$_IFI);
     return FALSE;
@@ -964,8 +972,8 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
        return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
     {
        dTHR;
-       if (ckWARN(WARN_UNOPENED))
-           Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file");
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
     }
     SETERRNO(EBADF,RMS$_IFI);
     return (Off_t)-1;
@@ -1179,25 +1187,24 @@ Perl_my_stat(pTHX)
 {
     djSP;
     IO *io;
-    GV* tmpgv;
+    GV* gv;
 
     if (PL_op->op_flags & OPf_REF) {
        EXTEND(SP,1);
-       tmpgv = cGVOP_gv;
+       gv = cGVOP_gv;
       do_fstat:
-       io = GvIO(tmpgv);
+       io = GvIO(gv);
        if (io && IoIFP(io)) {
-           PL_statgv = tmpgv;
+           PL_statgv = gv;
            sv_setpv(PL_statname,"");
            PL_laststype = OP_STAT;
            return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
        }
        else {
-           if (tmpgv == PL_defgv)
+           if (gv == PL_defgv)
                return PL_laststatval;
-           if (ckWARN(WARN_UNOPENED))
-               Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file <%s>",
-                 GvENAME(tmpgv));
+           if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+               report_evil_fh(gv, io, PL_op->op_type);
            PL_statgv = Nullgv;
            sv_setpv(PL_statname,"");
            return (PL_laststatval = -1);
@@ -1209,11 +1216,11 @@ Perl_my_stat(pTHX)
        STRLEN n_a;
        PUTBACK;
        if (SvTYPE(sv) == SVt_PVGV) {
-           tmpgv = (GV*)sv;
+           gv = (GV*)sv;
            goto do_fstat;
        }
        else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
-           tmpgv = (GV*)SvRV(sv);
+           gv = (GV*)SvRV(sv);
            goto do_fstat;
        }
 
diff --git a/doop.c b/doop.c
index c2f575f..befa8de 100644 (file)
--- a/doop.c
+++ b/doop.c
 
 #define HALF_UTF8_UPGRADE(start,end) \
     STMT_START {                               \
+      if ((start)<(end)) {                     \
        U8* NeWsTr;                             \
        STRLEN LeN = (end) - (start);           \
        NeWsTr = bytes_to_utf8(start, &LeN);    \
        Safefree(start);                        \
        (start) = NeWsTr;                       \
        (end) = (start) + LeN;                  \
+      }                                                \
     } STMT_END
 
 STATIC I32
@@ -89,8 +91,8 @@ S_do_trans_simple(pTHX_ SV *sv)
     }
     *d = '\0';
     sv_setpvn(sv, (const char*)dstart, d - dstart);
+    Safefree(dstart);
     SvUTF8_on(sv);
-    SvLEN_set(sv, 2*len+1);
     SvSETMAGIC(sv);
     return matches;
 }
diff --git a/dump.c b/dump.c
index 86c56ce..1570a91 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -769,7 +769,7 @@ void
 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
 {
     dTHR;
-    SV *d = sv_newmortal();
+    SV *d;
     char *s;
     U32 flags;
     U32 type;
@@ -783,7 +783,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     flags = SvFLAGS(sv);
     type = SvTYPE(sv);
 
-    Perl_sv_setpvf(aTHX_ d,
+    d = Perl_newSVpvf(aTHX_
                   "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
                   PTR2UV(SvANY(sv)), PTR2UV(sv),
                   (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
@@ -867,6 +867,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     switch (type) {
     case SVt_NULL:
        PerlIO_printf(file, "NULL%s\n", s);
+       SvREFCNT_dec(d);
        return;
     case SVt_IV:
        PerlIO_printf(file, "IV%s\n", s);
@@ -915,6 +916,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        break;
     default:
        PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
+       SvREFCNT_dec(d);
        return;
     }
     if (type >= SVt_PVIV || type == SVt_IV) {
@@ -940,10 +942,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
        if (nest < maxnest)
            do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
+       SvREFCNT_dec(d);
        return;
     }
-    if (type < SVt_PV)
+    if (type < SVt_PV) {
+       SvREFCNT_dec(d);
        return;
+    }
     if (type <= SVt_PVLV) {
        if (SvPVX(sv)) {
            Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv)));
@@ -1178,6 +1183,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
        break;
     }
+    SvREFCNT_dec(d);
 }
 
 void
diff --git a/embed.h b/embed.h
index 2969d86..d40e270 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define gv_check               Perl_gv_check
 #define gv_efullname           Perl_gv_efullname
 #define gv_efullname3          Perl_gv_efullname3
+#define gv_efullname4          Perl_gv_efullname4
 #define gv_fetchfile           Perl_gv_fetchfile
 #define gv_fetchmeth           Perl_gv_fetchmeth
 #define gv_fetchmethod         Perl_gv_fetchmethod
 #define gv_fetchpv             Perl_gv_fetchpv
 #define gv_fullname            Perl_gv_fullname
 #define gv_fullname3           Perl_gv_fullname3
+#define gv_fullname4           Perl_gv_fullname4
 #define gv_init                        Perl_gv_init
 #define gv_stashpv             Perl_gv_stashpv
 #define gv_stashpvn            Perl_gv_stashpvn
 #define vivify_defelem         Perl_vivify_defelem
 #define vivify_ref             Perl_vivify_ref
 #define wait4pid               Perl_wait4pid
-#define report_closed_fh       Perl_report_closed_fh
+#define report_evil_fh         Perl_report_evil_fh
 #define report_uninit          Perl_report_uninit
 #define warn                   Perl_warn
 #define vwarn                  Perl_vwarn
 #define gv_check(a)            Perl_gv_check(aTHX_ a)
 #define gv_efullname(a,b)      Perl_gv_efullname(aTHX_ a,b)
 #define gv_efullname3(a,b,c)   Perl_gv_efullname3(aTHX_ a,b,c)
+#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
 #define gv_fetchfile(a)                Perl_gv_fetchfile(aTHX_ a)
 #define gv_fetchmeth(a,b,c,d)  Perl_gv_fetchmeth(aTHX_ a,b,c,d)
 #define gv_fetchmethod(a,b)    Perl_gv_fetchmethod(aTHX_ a,b)
 #define gv_fetchpv(a,b,c)      Perl_gv_fetchpv(aTHX_ a,b,c)
 #define gv_fullname(a,b)       Perl_gv_fullname(aTHX_ a,b)
 #define gv_fullname3(a,b,c)    Perl_gv_fullname3(aTHX_ a,b,c)
+#define gv_fullname4(a,b,c,d)  Perl_gv_fullname4(aTHX_ a,b,c,d)
 #define gv_init(a,b,c,d,e)     Perl_gv_init(aTHX_ a,b,c,d,e)
 #define gv_stashpv(a,b)                Perl_gv_stashpv(aTHX_ a,b)
 #define gv_stashpvn(a,b,c)     Perl_gv_stashpvn(aTHX_ a,b,c)
 #define unsharepvn(a,b,c)      Perl_unsharepvn(aTHX_ a,b,c)
 #define unshare_hek(a)         Perl_unshare_hek(aTHX_ a)
 #define utilize(a,b,c,d,e)     Perl_utilize(aTHX_ a,b,c,d,e)
-#define utf16_to_utf8(a,b,c)   Perl_utf16_to_utf8(aTHX_ a,b,c)
-#define utf16_to_utf8_reversed(a,b,c)  Perl_utf16_to_utf8_reversed(aTHX_ a,b,c)
+#define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d)
+#define utf16_to_utf8_reversed(a,b,c,d)        Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d)
 #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 vivify_defelem(a)      Perl_vivify_defelem(aTHX_ a)
 #define vivify_ref(a,b)                Perl_vivify_ref(aTHX_ a,b)
 #define wait4pid(a,b,c)                Perl_wait4pid(aTHX_ a,b,c)
-#define report_closed_fh(a,b,c,d)      Perl_report_closed_fh(aTHX_ a,b,c,d)
+#define report_evil_fh(a,b,c)  Perl_report_evil_fh(aTHX_ a,b,c)
 #define report_uninit()                Perl_report_uninit(aTHX)
 #define vwarn(a,b)             Perl_vwarn(aTHX_ a,b)
 #define vwarner(a,b,c)         Perl_vwarner(aTHX_ a,b,c)
 #define gv_efullname           Perl_gv_efullname
 #define Perl_gv_efullname3     CPerlObj::Perl_gv_efullname3
 #define gv_efullname3          Perl_gv_efullname3
+#define Perl_gv_efullname4     CPerlObj::Perl_gv_efullname4
+#define gv_efullname4          Perl_gv_efullname4
 #define Perl_gv_fetchfile      CPerlObj::Perl_gv_fetchfile
 #define gv_fetchfile           Perl_gv_fetchfile
 #define Perl_gv_fetchmeth      CPerlObj::Perl_gv_fetchmeth
 #define gv_fullname            Perl_gv_fullname
 #define Perl_gv_fullname3      CPerlObj::Perl_gv_fullname3
 #define gv_fullname3           Perl_gv_fullname3
+#define Perl_gv_fullname4      CPerlObj::Perl_gv_fullname4
+#define gv_fullname4           Perl_gv_fullname4
 #define Perl_gv_init           CPerlObj::Perl_gv_init
 #define gv_init                        Perl_gv_init
 #define Perl_gv_stashpv                CPerlObj::Perl_gv_stashpv
 #define vivify_ref             Perl_vivify_ref
 #define Perl_wait4pid          CPerlObj::Perl_wait4pid
 #define wait4pid               Perl_wait4pid
-#define Perl_report_closed_fh  CPerlObj::Perl_report_closed_fh
-#define report_closed_fh       Perl_report_closed_fh
+#define Perl_report_evil_fh    CPerlObj::Perl_report_evil_fh
+#define report_evil_fh         Perl_report_evil_fh
 #define Perl_report_uninit     CPerlObj::Perl_report_uninit
 #define report_uninit          Perl_report_uninit
 #define Perl_warn              CPerlObj::Perl_warn
index a3adadc..3e4c7d5 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1545,6 +1545,7 @@ Ap        |GV*    |gv_autoload4   |HV* stash|const char* name|STRLEN len \
 Ap     |void   |gv_check       |HV* stash
 Ap     |void   |gv_efullname   |SV* sv|GV* gv
 Ap     |void   |gv_efullname3  |SV* sv|GV* gv|const char* prefix
+Ap     |void   |gv_efullname4  |SV* sv|GV* gv|const char* prefix|bool keepmain
 Ap     |GV*    |gv_fetchfile   |const char* name
 Apd    |GV*    |gv_fetchmeth   |HV* stash|const char* name|STRLEN len \
                                |I32 level
@@ -1554,6 +1555,7 @@ Apd       |GV*    |gv_fetchmethod_autoload|HV* stash|const char* name \
 Ap     |GV*    |gv_fetchpv     |const char* name|I32 add|I32 sv_type
 Ap     |void   |gv_fullname    |SV* sv|GV* gv
 Ap     |void   |gv_fullname3   |SV* sv|GV* gv|const char* prefix
+Ap     |void   |gv_fullname4   |SV* sv|GV* gv|const char* prefix|bool keepmain
 Ap     |void   |gv_init        |GV* gv|HV* stash|const char* name \
                                |STRLEN len|int multi
 Apd    |HV*    |gv_stashpv     |const char* name|I32 create
@@ -2064,8 +2066,8 @@ Ap        |void   |unlock_condpair|void* svv
 Ap     |void   |unsharepvn     |const char* sv|I32 len|U32 hash
 p      |void   |unshare_hek    |HEK* hek
 p      |void   |utilize        |int aver|I32 floor|OP* version|OP* id|OP* arg
-Ap     |U8*    |utf16_to_utf8  |U16* p|U8 *d|I32 bytelen
-Ap     |U8*    |utf16_to_utf8_reversed|U16* p|U8 *d|I32 bytelen
+Ap     |U8*    |utf16_to_utf8  |U8* p|U8 *d|I32 bytelen|I32 *newlen
+Ap     |U8*    |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen
 Ap     |I32    |utf8_distance  |U8 *a|U8 *b
 Ap     |U8*    |utf8_hop       |U8 *s|I32 off
 ApM    |U8*    |utf8_to_bytes  |U8 *s|STRLEN len
@@ -2075,7 +2077,7 @@ Ap        |U8*    |uv_to_utf8     |U8 *d|UV uv
 p      |void   |vivify_defelem |SV* sv
 p      |void   |vivify_ref     |SV* sv|U32 to_what
 p      |I32    |wait4pid       |Pid_t pid|int* statusp|int flags
-p      |void   |report_closed_fh|GV *gv|IO *io|const char *func|const char *obj
+p      |void   |report_evil_fh |GV *gv|IO *io|I32 op
 p      |void   |report_uninit
 Afpd   |void   |warn           |const char* pat|...
 Ap     |void   |vwarn          |const char* pat|va_list* args
index bb606f4..d3cf292 100644 (file)
@@ -584,7 +584,10 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 
        if (SvIOK(val)) {
             STRLEN len;
-            (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
+           if (SvIsUV(val))
+             (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
+           else
+             (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
             len = strlen(tmpbuf);
            sv_catpvn(retval, tmpbuf, len);
        }
diff --git a/gv.c b/gv.c
index 22e419e..836fdb2 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -372,7 +372,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 
     gv = gv_fetchmeth(stash, name, nend - name, 0);
     if (!gv) {
-       if (strEQ(name,"import"))
+       if (strEQ(name,"import") || strEQ(name,"unimport"))
            gv = (GV*)&PL_sv_yes;
        else if (autoload)
            gv = gv_autoload4(stash, name, nend - name, TRUE);
@@ -919,6 +919,22 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 }
 
 void
+Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+{
+    HV *hv = GvSTASH(gv);
+    if (!hv) {
+       (void)SvOK_off(sv);
+       return;
+    }
+    sv_setpv(sv, prefix ? prefix : "");
+    if (keepmain || strNE(HvNAME(hv), "main")) {
+       sv_catpv(sv,HvNAME(hv));
+       sv_catpvn(sv,"::", 2);
+    }
+    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+}
+
+void
 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 {
     HV *hv = GvSTASH(gv);
@@ -933,6 +949,15 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 }
 
 void
+Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+{
+    GV *egv = GvEGV(gv);
+    if (!egv)
+       egv = gv;
+    gv_fullname4(sv, egv, prefix, keepmain);
+}
+
+void
 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 {
     GV *egv = GvEGV(gv);
index d6f3dd7..8a29b93 100644 (file)
@@ -206,30 +206,29 @@ EOCBU
 cat > UU/uselargefiles.cbu <<'EOCBU'
 case "$uselargefiles" in
 ''|$define|true|[yY]*)
-       lfcflags="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`"
-       lfldflags="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`"
+# Keep these at the left margin.
+ccflags_largefiles="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`"
+ldflags_largefiles="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`"
        # _Somehow_ in AIX 4.3.1.0 the above getconf call manages to
        # insert(?) *something* to $ldflags so that later (in Configure) evaluating
        # $ldflags causes a newline after the '-b64' (the result of the getconf).
        # (nothing strange shows up in $ldflags even in hexdump;
        #  so it may be something in the shell, instead?)
        # Try it out: just uncomment the below line and rerun Configure:
-# echo >&4 "AIX 4.3.1.0 $lfldflags mystery" ; exit 1
+# echo >&4 "AIX 4.3.1.0 $ldflags_largefiles mystery" ; exit 1
        # Just don't ask me how AIX does it, I spent hours wondering.
-       # Therefore the line re-evaluating lfldflags: it seems to fix
+       # Therefore the line re-evaluating ldflags_largefiles: it seems to fix
        # the whatever it was that AIX managed to break. --jhi
-       lfldflags="`echo $lfldflags`"
-       lflibs="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
-       case "$lfcflags$lfldflags$lflibs" in
+       ldflags_largefiles="`echo $ldflags_largefiles`"
+# Keep this at the left margin.
+libswanted_largefiles="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+       case "$ccflags_largefiles$ldflags_largefiles$libs_largefiles" in
        '');;
-       *) ccflags="$ccflags $lfcflags"
-          ldflags="$ldflags $lfldflags"
-          libswanted="$libswanted $lflibs"
+       *) ccflags="$ccflags $ccflags_largefiles"
+          ldflags="$ldflags $ldflags_largefiles"
+          libswanted="$libswanted $libswanted_largefiles"
           ;;
        esac
-       lfcflags=''
-       lfldflags=''
-       lflibs=''
        ;;
 esac
 EOCBU
@@ -279,18 +278,18 @@ int main (void)
 EOCP
            set size
            if eval $compile_ok; then
-               lfcpuwidth=`./size`
-               echo "You are running on $lfcpuwidth bit hardware."
+               qacpuwidth=`./size`
+               echo "You are running on $qacpuwidth bit hardware."
            else
                dflt="32"
                echo " "
                echo "(I can't seem to compile the test program.  Guessing...)"
                rp="What is the width of your CPU (in bits)?"
                . ./myread
-               lfcpuwidth="$ans"
+               qacpuwidth="$ans"
            fi
            $rm -f size.c size
-           case "$lfcpuwidth" in
+           case "$qacpuwidth" in
            32*)
                cat >&4 <<EOM
 Bzzzt! At present, you can only perform a
@@ -299,8 +298,8 @@ EOM
                exit 1
                ;;
            esac
-           lfcflags="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
-           lfldflags="`getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`"
+           qacflags="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
+           qaldflags="`getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`"
            # See jhi's comments above regarding this re-eval.  I've
            # seen similar weirdness in the form of:
            #
@@ -309,8 +308,8 @@ EOM
            # error messages from 'cc -E' invocation. Again, the offending
            # string is simply not detectable by any means.  Since it doesn't
            # do any harm, I didn't pursue it. -- sh
-           lfldflags="`echo $lfldflags`"
-           lflibs="`getconf XBS5_LP64_OFF64_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+           qaldflags="`echo $qaldflags`"
+           qalibs="`getconf XBS5_LP64_OFF64_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
            # -q32 and -b32 may have been set by uselargefiles or user.
            # Remove them.
            ccflags="`echo $ccflags | sed -e 's@-q32@@'`"
@@ -322,15 +321,15 @@ EOM
            trylist="`echo $trylist | sed -e 's@^ar @@' -e 's@ ar @ @g' -e 's@ ar$@@'`"
            ar="ar -X64"
            nm_opt="-X64 $nm_opt"
-           # Note: Placing the 'lfcflags' variable into the 'ldflags' string
-           # is NOT a typo.  ldlflags is passed to the C compiler for final
+           # Note: Placing the 'qacflags' variable into the 'ldflags' string
+           # is NOT a typo.  ldqalags is passed to the C compiler for final
            # linking, and it wants -q64 (-b64 is for ld only!).
-           case "$lfcflags$lfldflags$lflibs" in
+           case "$qacflags$qaldflags$qalibs" in
            '');;
-           *) ccflags="$ccflags $lfcflags"
-              ldflags="$ldflags $lfcflags"
-              lddlflags="$lfldflags $lddlflags"
-              libswanted="$libswanted $lflibs"
+           *) ccflags="$ccflags $qacflags"
+              ldflags="$ldflags $qacflags"
+              lddqalags="$qaldflags $lddqalags"
+              libswanted="$libswanted $qalibs"
               ;;
            esac
            case "$ccflags" in
@@ -344,10 +343,10 @@ EOM
            # Don't try backwards compatibility
            bincompat="$undef"
            d_bincompat5005="$undef"
-           lfcflags=''
-           lfldflags=''
-           lflibs=''
-           lfcpuwidth=''
+           qacflags=''
+           qaldflags=''
+           qalibs=''
+           qacpuwidth=''
            ;;
 esac
 EOCBU
index db7b869..c110d1e 100644 (file)
@@ -65,30 +65,38 @@ cc=${cc:-cc}
        # reset
        _DEC_cc_style=
 case "`$cc -v 2>&1 | grep cc`" in
-*gcc*) _gcc_version=`$cc -v 2>&1 | grep "gcc version" | sed 's%^gcc version \([0-9]*\)\.\([0-9]*\) .*%\1 \2%'`
+*gcc*) _gcc_version=`$cc --version 2>&1 | tr . ' '`
        set $_gcc_version
-       if test "$1" -lt 2 -o \( "$1" -eq 2 -a "$2" -lt 95 \); then
+       if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then
            cat >&4 <<EOF
 
-Your cc seems to be gcc and its version seems to be less than 2.95.
-This is not a good idea since old versions of gcc are known to produce
-buggy code when compiling Perl (and no doubt for other programs, too).
-
-Therefore, I strongly suggest upgrading your gcc.  (Why don't you
-use the vendor cc is also a good question.  It comes with the operating
-system and produces good code.)
-
-Note that as of gcc 2.95 (19990728) and Perl 5.6.0 (end of March 2000)
-if the said Perl is compiled with the said gcc the lib/sdbm test will 
-dump core.  As this doesn't happen with the vendor cc, this is
-most probably a lingering bug in gcc.  Therefore unless you have
-a better gcc you are still better off using the vendor cc.
+*** Your cc seems to be gcc and its version seems to be less than 2.95.2.
+*** This is not a good idea since old versions of gcc are known to produce
+*** buggy code when compiling Perl (and no doubt for other programs, too).
+***
+*** Therefore, I strongly suggest upgrading your gcc.  (Why don't you
+*** use the vendor cc is also a good question.  It comes with the operating
+*** system and produces good code.)
 
 Cannot continue, aborting.
 
 EOF
            exit 1
        fi
+       if test "$1" -eq 2 -a "$2" -eq 95 -a "$3" -le 2; then
+           cat >&4 <<EOF
+
+*** Note that as of gcc 2.95.2 (19991024) and Perl 5.6.0 (March 2000)
+*** if the said Perl is compiled with the said gcc the lib/sdbm test
+*** dumps core (meaning  that the SDBM_File is unusable).  As this core
+*** dump doesn't happen with the vendor cc, this is most probably
+*** a lingering bug in gcc.  Therefore unless you have a better gcc
+*** you are still better off using the vendor cc.
+
+Since you explicitly chose gcc, I assume that you know what are doing.
+
+EOF
+       fi
         ;;
 *)     # compile something small: taint.c is fine for this.
        # the main point is the '-v' flag of 'cc'.
index fd60ba3..7122813 100644 (file)
@@ -86,8 +86,13 @@ case "$osvers" in
        d_setegid='undef'
        d_seteuid='undef'
        ;;
+3.*)
+       usevfork='true'         
+       usemymalloc='n'
+       libswanted=`echo $libswanted | sed 's/ malloc / /'`     
+       ;;
 #
-# Guesses at what will be needed after 2.2
+# Guesses at what will be needed after 3.*
 *)     usevfork='true'
        usemymalloc='n'
        libswanted=`echo $libswanted | sed 's/ malloc / /'`
index ce15f55..ecfcb6d 100644 (file)
@@ -387,8 +387,10 @@ cat > UU/uselargefiles.cbu <<'EOCBU'
 case "$uselargefiles" in
 ''|$define|true|[yY]*)
        # there are largefile flags available via getconf(1)
-       # but we cheat for now.
-       ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
+       # but we cheat for now.  (Keep that in the left margin.)
+ccflags_largefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
+
+       ccflags="$ccflags $ccflags_largefiles"
 
         if test -z "$ccisgcc" -a -z "$gccversion"; then
            # The strict ANSI mode (-Aa) doesn't like large files.
index 4fb2f89..0fa46bd 100644 (file)
@@ -282,7 +282,10 @@ cat > UU/uselargefiles.cbu <<'EOCBU'
 # after it has prompted the user for whether to use large files.
 case "$uselargefiles" in
 ''|$define|true|[yY]*)
-       ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
+# Keep this in the left margin.
+ccflags_largefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
+
+       ccflags="$ccflags $ccflags_largefiles"
        ;;
 esac
 EOCBU
index 6e84bac..21b0b0e 100644 (file)
@@ -374,9 +374,15 @@ cat > UU/uselargefiles.cbu <<'EOCBU'
 # after it has prompted the user for whether to use large files.
 case "$uselargefiles" in
 ''|$define|true|[yY]*)
-    ccflags="$ccflags `getconf LFS_CFLAGS 2>/dev/null`"
-    ldflags="$ldflags `getconf LFS_LDFLAGS 2>/dev/null`"
-    libswanted="$libswanted `getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+
+# Keep these in the left margin.
+ccflags_largefiles="`getconf LFS_CFLAGS 2>/dev/null`"
+ldflags_largefiles="`getconf LFS_LDFLAGS 2>/dev/null`"
+libswanted_largefiles="`getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+
+    ccflags="$ccflags $ccflags_largefiles"
+    ldflags="$ldflags $ldflags_largefiles"
+    libswanted="$libswanted $libswanted_largefiles"
     ;;
 esac
 EOCBU
diff --git a/mg.c b/mg.c
index 02a74f5..8cb41e7 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1997,6 +1997,30 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        break;
 #ifndef MACOS_TRADITIONAL
     case '0':
+#ifdef HAS_SETPROCTITLE
+       /* The BSDs don't show the argv[] in ps(1) output, they
+        * show a string from the process struct and provide
+        * the setproctitle() routine to manipulate that. */
+       {
+           s = SvPV(sv, len);
+#   if __FreeBSD_version >= 410001
+           /* The leading "-" removes the "perl: " prefix,
+            * but not the "(perl) suffix from the ps(1)
+            * output, because that's what ps(1) shows if the
+            * argv[] is modified. */
+           setproctitle("-%s", s, len + 1);
+#   else       /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
+           /* This doesn't really work if you assume that
+            * $0 = 'foobar'; will wipe out 'perl' from the $0
+            * because in ps(1) output the result will be like
+            * sprintf("perl: %s (perl)", s)
+            * I guess this is a security feature:
+            * one (a user process) cannot get rid of the original name.
+            * --jhi */
+           setproctitle("%s", s);
+#   endif
+       }
+#endif
        if (!PL_origalen) {
            s = PL_origargv[0];
            s += strlen(s);
@@ -2052,9 +2076,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            for (i = 1; i < PL_origargc; i++)
                PL_origargv[i] = Nullch;
        }
-#ifdef HAS_SETPROCTITLE
-       setproctitle("%s", SvPV_nolen(sv));
-#endif
        break;
 #endif
 #ifdef USE_THREADS
index fb501c3..3e0ccce 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_gv_efullname3     pPerl->Perl_gv_efullname3
 #undef  gv_efullname3
 #define gv_efullname3          Perl_gv_efullname3
+#undef  Perl_gv_efullname4
+#define Perl_gv_efullname4     pPerl->Perl_gv_efullname4
+#undef  gv_efullname4
+#define gv_efullname4          Perl_gv_efullname4
 #undef  Perl_gv_fetchfile
 #define Perl_gv_fetchfile      pPerl->Perl_gv_fetchfile
 #undef  gv_fetchfile
 #define Perl_gv_fullname3      pPerl->Perl_gv_fullname3
 #undef  gv_fullname3
 #define gv_fullname3           Perl_gv_fullname3
+#undef  Perl_gv_fullname4
+#define Perl_gv_fullname4      pPerl->Perl_gv_fullname4
+#undef  gv_fullname4
+#define gv_fullname4           Perl_gv_fullname4
 #undef  Perl_gv_init
 #define Perl_gv_init           pPerl->Perl_gv_init
 #undef  gv_init
diff --git a/op.c b/op.c
index 85a71a4..9192ae8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1987,7 +1987,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        right->op_type == OP_SUBST ||
        right->op_type == OP_TRANS)) {
        right->op_flags |= OPf_STACKED;
-       if (right->op_type != OP_MATCH)
+       if (right->op_type != OP_MATCH &&
+            ! (right->op_type == OP_TRANS &&
+               right->op_private & OPpTRANS_IDENTICAL))
            left = mod(left, right->op_type);
        if (right->op_type == OP_TRANS)
            o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
index 1c1d9bf..ab98824 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -193,6 +193,9 @@ END
     '}',  13,          # loopexop
 );
 
+my %OP_IS_SOCKET;
+my %OP_IS_FILETEST;
+
 for (@ops) {
     $argsum = 0;
     $flags = $flags{$_};
@@ -210,7 +213,12 @@ for (@ops) {
     $argsum |= $opclass{$1} << 9;
     $mul = 0x2000;                             # 2 ^ OASHIFT
     for $arg (split(' ',$args{$_})) {
+       if ($arg =~ /^F/) {
+           $OP_IS_SOCKET{$_}   = 1 if $arg =~ s/s//;
+           $OP_IS_FILETEST{$_} = 1 if $arg =~ s/-//;
+        }
        $argnum = ($arg =~ s/\?//) ? 8 : 0;
+        die "op = $_, arg = $arg\n" unless length($arg) == 1;
        $argnum += $argnum{$arg};
        warn "# Conflicting bit 32 for '$_'.\n"
            if $argnum & 8 and $mul == 0x10000000;
@@ -228,6 +236,20 @@ print <<END;
 END_EXTERN_C
 END
 
+if (keys %OP_IS_SOCKET) {
+    print ON "\n#define OP_IS_SOCKET(op)       \\\n\t(";
+    print ON join(" || \\\n\t ",
+               map { "(op) == OP_" . uc() } sort keys %OP_IS_SOCKET);
+    print ON ")\n\n";
+}
+
+if (keys %OP_IS_FILETEST) {
+    print ON "\n#define OP_IS_FILETEST(op)     \\\n\t(";
+    print ON join(" || \\\n\t ",
+               map { "(op) == OP_" . uc() } sort keys %OP_IS_FILETEST);
+    print ON ")\n\n";
+}
+
 close OC or die "Error closing opcode.h: $!";
 close ON or die "Error closing opnames.h: $!";
 
@@ -635,8 +657,8 @@ sysseek             sysseek                 ck_fun          s@      F S S
 sysread                sysread                 ck_fun          imst@   F R S S?
 syswrite       syswrite                ck_fun          imst@   F S S? S?
 
-send           send                    ck_fun          imst@   F S S S?
-recv           recv                    ck_fun          imst@   F R S S
+send           send                    ck_fun          imst@   Fs S S S?
+recv           recv                    ck_fun          imst@   Fs R S S
 
 eof            eof                     ck_eof          is%     F?
 tell           tell                    ck_fun          st%     F?
@@ -650,52 +672,52 @@ flock             flock                   ck_fun          isT@    F S
 
 # Sockets.
 
-socket         socket                  ck_fun          is@     F S S S
-sockpair       socketpair              ck_fun          is@     F F S S S
+socket         socket                  ck_fun          is@     Fs S S S
+sockpair       socketpair              ck_fun          is@     Fs Fs S S S
 
-bind           bind                    ck_fun          is@     F S
-connect                connect                 ck_fun          is@     F S
-listen         listen                  ck_fun          is@     F S
-accept         accept                  ck_fun          ist@    F F
-shutdown       shutdown                ck_fun          ist@    F S
+bind           bind                    ck_fun          is@     Fs S
+connect                connect                 ck_fun          is@     Fs S
+listen         listen                  ck_fun          is@     Fs S
+accept         accept                  ck_fun          ist@    Fs Fs
+shutdown       shutdown                ck_fun          ist@    Fs S
 
-gsockopt       getsockopt              ck_fun          is@     F S S
-ssockopt       setsockopt              ck_fun          is@     F S S S
+gsockopt       getsockopt              ck_fun          is@     Fs S S
+ssockopt       setsockopt              ck_fun          is@     Fs S S S
 
-getsockname    getsockname             ck_fun          is%     F
-getpeername    getpeername             ck_fun          is%     F
+getsockname    getsockname             ck_fun          is%     Fs
+getpeername    getpeername             ck_fun          is%     Fs
 
 # Stat calls.
 
 lstat          lstat                   ck_ftst         u-      F
 stat           stat                    ck_ftst         u-      F
-ftrread                -R                      ck_ftst         isu-    F
-ftrwrite       -W                      ck_ftst         isu-    F
-ftrexec                -X                      ck_ftst         isu-    F
-fteread                -r                      ck_ftst         isu-    F
-ftewrite       -w                      ck_ftst         isu-    F
-fteexec                -x                      ck_ftst         isu-    F
-ftis           -e                      ck_ftst         isu-    F
-fteowned       -O                      ck_ftst         isu-    F
-ftrowned       -o                      ck_ftst         isu-    F
-ftzero         -z                      ck_ftst         isu-    F
-ftsize         -s                      ck_ftst         istu-   F
-ftmtime                -M                      ck_ftst         stu-    F
-ftatime                -A                      ck_ftst         stu-    F
-ftctime                -C                      ck_ftst         stu-    F
-ftsock         -S                      ck_ftst         isu-    F
-ftchr          -c                      ck_ftst         isu-    F
-ftblk          -b                      ck_ftst         isu-    F
-ftfile         -f                      ck_ftst         isu-    F
-ftdir          -d                      ck_ftst         isu-    F
-ftpipe         -p                      ck_ftst         isu-    F
-ftlink         -l                      ck_ftst         isu-    F
-ftsuid         -u                      ck_ftst         isu-    F
-ftsgid         -g                      ck_ftst         isu-    F
-ftsvtx         -k                      ck_ftst         isu-    F
-fttty          -t                      ck_ftst         is-     F
-fttext         -T                      ck_ftst         isu-    F
-ftbinary       -B                      ck_ftst         isu-    F
+ftrread                -R                      ck_ftst         isu-    F-
+ftrwrite       -W                      ck_ftst         isu-    F-
+ftrexec                -X                      ck_ftst         isu-    F-
+fteread                -r                      ck_ftst         isu-    F-
+ftewrite       -w                      ck_ftst         isu-    F-
+fteexec                -x                      ck_ftst         isu-    F-
+ftis           -e                      ck_ftst         isu-    F-
+fteowned       -O                      ck_ftst         isu-    F-
+ftrowned       -o                      ck_ftst         isu-    F-
+ftzero         -z                      ck_ftst         isu-    F-
+ftsize         -s                      ck_ftst         istu-   F-
+ftmtime                -M                      ck_ftst         stu-    F-
+ftatime                -A                      ck_ftst         stu-    F-
+ftctime                -C                      ck_ftst         stu-    F-
+ftsock         -S                      ck_ftst         isu-    F-
+ftchr          -c                      ck_ftst         isu-    F-
+ftblk          -b                      ck_ftst         isu-    F-
+ftfile         -f                      ck_ftst         isu-    F-
+ftdir          -d                      ck_ftst         isu-    F-
+ftpipe         -p                      ck_ftst         isu-    F-
+ftlink         -l                      ck_ftst         isu-    F-
+ftsuid         -u                      ck_ftst         isu-    F-
+ftsgid         -g                      ck_ftst         isu-    F-
+ftsvtx         -k                      ck_ftst         isu-    F-
+fttty          -t                      ck_ftst         is-     F-
+fttext         -T                      ck_ftst         isu-    F-
+ftbinary       -B                      ck_ftst         isu-    F-
 
 # File calls.
 
index e9f8b4f..ba28f68 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -360,3 +360,49 @@ typedef enum opcode {
 
 #define MAXO 351
 
+
+#define OP_IS_SOCKET(op)       \
+       ((op) == OP_ACCEPT || \
+        (op) == OP_BIND || \
+        (op) == OP_CONNECT || \
+        (op) == OP_GETPEERNAME || \
+        (op) == OP_GETSOCKNAME || \
+        (op) == OP_GSOCKOPT || \
+        (op) == OP_LISTEN || \
+        (op) == OP_RECV || \
+        (op) == OP_SEND || \
+        (op) == OP_SHUTDOWN || \
+        (op) == OP_SOCKET || \
+        (op) == OP_SOCKPAIR || \
+        (op) == OP_SSOCKOPT)
+
+
+#define OP_IS_FILETEST(op)     \
+       ((op) == OP_FTATIME || \
+        (op) == OP_FTBINARY || \
+        (op) == OP_FTBLK || \
+        (op) == OP_FTCHR || \
+        (op) == OP_FTCTIME || \
+        (op) == OP_FTDIR || \
+        (op) == OP_FTEEXEC || \
+        (op) == OP_FTEOWNED || \
+        (op) == OP_FTEREAD || \
+        (op) == OP_FTEWRITE || \
+        (op) == OP_FTFILE || \
+        (op) == OP_FTIS || \
+        (op) == OP_FTLINK || \
+        (op) == OP_FTMTIME || \
+        (op) == OP_FTPIPE || \
+        (op) == OP_FTREXEC || \
+        (op) == OP_FTROWNED || \
+        (op) == OP_FTRREAD || \
+        (op) == OP_FTRWRITE || \
+        (op) == OP_FTSGID || \
+        (op) == OP_FTSIZE || \
+        (op) == OP_FTSOCK || \
+        (op) == OP_FTSUID || \
+        (op) == OP_FTSVTX || \
+        (op) == OP_FTTEXT || \
+        (op) == OP_FTTTY || \
+        (op) == OP_FTZERO)
+
diff --git a/perl.c b/perl.c
index 4fc60f4..a287a84 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2847,6 +2847,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
            if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
                tmpstatbuf.st_ino != PL_statbuf.st_ino) {
                (void)PerlIO_close(PL_rsfp);
+#ifdef MAIL_CAN_BE_USED_SAFELY /* No, it can't.  As of Aug 05 200, there's bugtraq exploit.  */
                if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
                    PerlIO_printf(PL_rsfp,
 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
@@ -2857,6 +2858,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
                        PL_statbuf.st_uid, PL_statbuf.st_gid);
                    (void)PerlProc_pclose(PL_rsfp);
                }
+#endif
                Perl_croak(aTHX_ "Permission denied\n");
            }
            if (
diff --git a/perl.h b/perl.h
index fa33269..c4add20 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1386,25 +1386,10 @@ typedef NVTYPE NV;
 
 #ifdef UV_IS_QUAD
 
-#  ifdef UQUAD_MAX
-#    define PERL_UQUAD_MAX ((UV)UQUAD_MAX)
-#  else
 #    define PERL_UQUAD_MAX     (~(UV)0)
-#  endif
-
-#  define PERL_UQUAD_MIN ((UV)0)
-
-#  ifdef QUAD_MAX
-#    define PERL_QUAD_MAX ((IV)QUAD_MAX)
-#  else
+#    define PERL_UQUAD_MIN     ((UV)0)
 #    define PERL_QUAD_MAX      ((IV) (PERL_UQUAD_MAX >> 1))
-#  endif
-
-#  ifdef QUAD_MIN
-#    define PERL_QUAD_MIN ((IV)QUAD_MIN)
-#  else
 #    define PERL_QUAD_MIN      (-PERL_QUAD_MAX - ((3 & -1) == 3))
-#  endif
 
 #endif
 
@@ -3320,6 +3305,10 @@ typedef struct am_table_short AMTS;
 
 #endif /* IAMSUID */
 
+#ifdef I_LIBUTIL
+#   include <libutil.h>                /* setproctitle() in some FreeBSDs */
+#endif
+
 /* and finally... */
 #define PERL_PATCHLEVEL_H_IMPLICIT
 #include "patchlevel.h"
index cecc697..f7b16cd 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3317,16 +3317,16 @@ Perl_unsharepvn(pTHXo_ const char* sv, I32 len, U32 hash)
 
 #undef  Perl_utf16_to_utf8
 U8*
-Perl_utf16_to_utf8(pTHXo_ U16* p, U8 *d, I32 bytelen)
+Perl_utf16_to_utf8(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
 {
-    return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8(p, d, bytelen);
+    return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8(p, d, bytelen, newlen);
 }
 
 #undef  Perl_utf16_to_utf8_reversed
 U8*
-Perl_utf16_to_utf8_reversed(pTHXo_ U16* p, U8 *d, I32 bytelen)
+Perl_utf16_to_utf8_reversed(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
 {
-    return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen);
+    return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen, newlen);
 }
 
 #undef  Perl_utf8_distance
index e0b7c2b..4a7573b 100644 (file)
@@ -478,7 +478,7 @@ Found in file op.h
 =item GIMME_V
 
 The XSUB-writer's equivalent to Perl's C<wantarray>.  Returns C<G_VOID>,
-C<G_SCALAR> or C<G_ARRAY> for void, scalar or array context,
+C<G_SCALAR> or C<G_ARRAY> for void, scalar or list context,
 respectively.
 
        U32     GIMME_V
@@ -579,7 +579,7 @@ Found in file gv.c
 
 =item G_ARRAY
 
-Used to indicate array context.  See C<GIMME_V>, C<GIMME> and
+Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
 L<perlcall>.
 
 =for hackers
index 148b24b..94edd34 100644 (file)
@@ -201,8 +201,8 @@ As with G_SCALAR, this flag has 2 effects:
 
 =item 1.
 
-It indicates to the subroutine being called that it is executing in an
-array context (if it executes I<wantarray> the result will be true).
+It indicates to the subroutine being called that it is executing in a
+list context (if it executes I<wantarray> the result will be true).
 
 
 =item 2.
@@ -355,7 +355,7 @@ use of this flag.
 As mentioned above, you can determine the context of the currently
 executing subroutine in Perl with I<wantarray>.  The equivalent test
 can be made in C by using the C<GIMME_V> macro, which returns
-C<G_ARRAY> if you have been called in an array context, C<G_SCALAR> if
+C<G_ARRAY> if you have been called in a list context, C<G_SCALAR> if
 in a scalar context, or C<G_VOID> if in a void context (i.e. the
 return value will not be used).  An older version of this macro is
 called C<GIMME>; in a void context it returns C<G_SCALAR> instead of
@@ -806,7 +806,7 @@ Notes
 
 =item 1.
 
-We wanted array context, so G_ARRAY was used.
+We wanted list context, so G_ARRAY was used.
 
 =item 2.
 
index 62e177f..3c7e939 100644 (file)
@@ -1057,7 +1057,7 @@ not realizing that 777 will be interpreted as a decimal number,
 equivalent to 01411.  Octal constants are introduced with a leading 0 in
 Perl, as in C.
 
-=item Close on unopened file <%s>
+=item close() on unopened filehandle %s
 
 (W unopened) You tried to close a filehandle that was never opened.
 
@@ -1353,12 +1353,6 @@ you which section of the Perl source code is distressed.
 (F) Your machine apparently doesn't implement fcntl().  What is this, a
 PDP-11 or something?
 
-=item Filehandle %s never opened
-
-(W unopened) An I/O operation was attempted on a filehandle that was
-never initialized.  You need to do an open() or a socket() call, or call
-a constructor from the FileHandle package.
-
 =item Filehandle %s opened only for input
 
 (W io) You tried to write on a read-only filehandle.  If you intended it
@@ -1776,6 +1770,11 @@ a builtin library search path, prefix2 is substituted.  The error may
 appear if components are not found, or are too long.  See
 "PERLLIB_PREFIX" in L<perlos2>.
 
+=item Malformed UTF-16 surrogate
+
+Perl thought it was reading UTF-16 encoded character data but while
+doing it Perl met a malformed Unicode surrogate.
+
 =item %s matches null string many times
 
 (W regexp) The pattern you've specified would be an infinite loop if the
@@ -2230,6 +2229,17 @@ pointing outside the buffer.  This is difficult to imagine.  The sole
 exception to this is that C<sysread()>ing past the buffer will extend
 the buffer and zero pad the new area.
 
+=item -%s on unopened filehandle %s
+
+(W unopened) You tried to invoke a file test operator on a filehandle
+that isn't open.  Check your logic.  See also L<perlfunc/-X>.
+
+=item %s() on unopened %s %s
+
+(W unopened) An I/O operation was attempted on a filehandle that was
+never initialized.  You need to do an open(), a sysopen(), or a socket()
+call, or call a constructor from the FileHandle package.
+
 =item oops: oopsAV
 
 (S internal) An internal warning that the grammar is screwed up.
@@ -2478,6 +2488,11 @@ was string.
 
 (P) The lexer got into a bad state while processing a case modifier.
 
+=item panic: utf16_to_utf8: odd bytelen
+
+(P) Something tried to call utf16_to_utf8 with an odd (as opposed
+to even) byte length. 
+
 =item Parentheses missing around "%s" list
 
 (W parenthesis) You said something like
@@ -2793,7 +2808,7 @@ or setgid bit set.  This doesn't make much sense.
 construct.  Remember that bracketing delimiters count nesting level.
 Missing the leading C<$> from a variable C<$m> may cause this error.
 
-=item %sseek() on unopened file
+=item %sseek() on unopened filehandle
 
 (W unopened) You tried to use the seek() or sysseek() function on a
 filehandle that was either never opened or has since been closed.
@@ -2968,11 +2983,10 @@ unless there was a failure.  You probably wanted to use system()
 instead, which does return.  To suppress this warning, put the exec() in
 a block by itself.
 
-=item Stat on unopened file <%s>
+=item stat() on unopened filehandle %s
 
-(W unopened) You tried to use the stat() function (or an equivalent file
-test) on a filehandle that was either never opened or has since been
-closed.
+(W unopened) You tried to use the stat() function on a filehandle that
+was either never opened or has since been closed.
 
 =item Strange *+?{} on zero-length expression
 
@@ -3083,16 +3097,11 @@ before now.  Check your logic flow.
 (F) You tried to use C<goto> to reach a label that was too deeply nested
 for Perl to reach.  Perl is doing you a favor by refusing.
 
-=item tell() on unopened file
+=item tell() on unopened filehandle
 
 (W unopened) You tried to use the tell() function on a filehandle that
 was either never opened or has since been closed.
 
-=item Test on unopened file <%s>
-
-(W unopened) You tried to invoke a file test operator on a filehandle
-that isn't open.  Check your logic.  See also L<perlfunc/-X>.
-
 =item That use of $[ is unsupported
 
 (F) Assignment to C<$[> is now strictly circumscribed, and interpreted
index dce785e..1787e4b 100644 (file)
@@ -356,7 +356,7 @@ made.
    int matches(SV *string, char *pattern, AV **matches);
 
 Given an C<SV>, a pattern, and a pointer to an empty C<AV>,
-matches() evaluates C<$string =~ $pattern> in an array context, and
+matches() evaluates C<$string =~ $pattern> in a list context, and
 fills in I<matches> with the array elements, returning the number of matches found.
 
 Here's a sample program, I<match.c>, that uses all three (long lines have
@@ -434,7 +434,7 @@ been wrapped here):
 
  /** matches(string, pattern, matches)
  **
- ** Used for matches in an array context.
+ ** Used for matches in a list context.
  **
  ** Returns the number of matches,
  ** and fills in **matches with the matching substrings
index ecbd652..112b1ed 100644 (file)
@@ -370,7 +370,7 @@ you can.  Is that the pencil's fault?  Of course it isn't.
 The date and time functions supplied with Perl (gmtime and localtime)
 supply adequate information to determine the year well beyond 2000
 (2038 is when trouble strikes for 32-bit machines).  The year returned
-by these functions when used in an array context is the year minus 1900.
+by these functions when used in a list context is the year minus 1900.
 For years between 1910 and 1999 this I<happens> to be a 2-digit decimal
 number. To avoid the year 2000 problem simply do not treat the year as
 a 2-digit number.  It isn't.
index 1e3151a..5e06324 100644 (file)
@@ -688,8 +688,11 @@ On POSIX systems, you can detect this condition this way:
 
 Returns the character represented by that NUMBER in the character set.
 For example, C<chr(65)> is C<"A"> in either ASCII or Unicode, and
-chr(0x263a) is a Unicode smiley face (but only within the scope of
-a C<use utf8>).  For the reverse, use L</ord>.  
+chr(0x263a) is a Unicode smiley face. Within the scope of C<use utf8>, 
+characters higher than 127 are encoded in Unicode; if you don't want
+this, temporarily C<use bytes> or use C<pack("C*",...)>
+
+For the reverse, use L</ord>.  
 See L<utf8> for more about Unicode.
 
 If NUMBER is omitted, uses C<$_>.
@@ -5375,7 +5378,8 @@ derive their C<import> method via inheritance from the C<Exporter> class that
 is defined in the C<Exporter> module.  See L<Exporter>.  If no C<import>
 method can be found then the call is skipped.
 
-If you don't want your namespace altered, explicitly supply an empty list:
+If you do not want to call the package's C<import> method (for instance,
+to stop your namespace from being altered), explicitly supply the empty list:
 
     use Module ();
 
@@ -5396,8 +5400,9 @@ called).  Note that there is no comma after VERSION!
 Because this is a wide-open interface, pragmas (compiler directives)
 are also implemented this way.  Currently implemented pragmas are:
 
-    use integer;
+    use constant;
     use diagnostics;
+    use integer;
     use sigtrap  qw(SEGV BUS);
     use strict   qw(subs vars refs);
     use subs     qw(afunc blurfl);
@@ -5417,7 +5422,9 @@ 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<perlmod> 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.
 
 =item utime LIST
 
index 1738742..f2b4b90 100644 (file)
@@ -1317,6 +1317,21 @@ destination starting points.  Perl will move, copy, or zero out C<number>
 instances of the size of the C<type> data structure (using the C<sizeof>
 function).
 
+Here is a handy table of equivalents between ordinary C and Perl's
+memory abstraction layer:
+
+    Instead Of:                Use:
+
+    malloc                     New
+    calloc                     Newz
+    realloc                    Renew
+    memcopy                    Copy
+    memmove                    Move
+    free                       Safefree
+    strdup                     savepv
+    strndup                    savepvn (Hey, strndup doesn't exist!)
+    memcpy/*(struct foo *)    StructCopy
+
 =head2 PerlIO
 
 The most recent development releases of Perl has been experimenting with
@@ -1862,6 +1877,19 @@ This function isn't exported out of the Perl core.
 If you edit F<embed.pl>, you will need to run C<make regen_headers> to
 force a rebuild of F<embed.h> and other auto-generated files.
 
+=head2 Formatted Printing of IVs and UVs
+
+If you are printing IVs or UVs instead of the stdio(3) style formatting
+codes like C<%d> you should use the following macros for portability
+
+       IVdf            IV in decimal
+       UVuf            UV in decimal
+       UVof            UV in octal
+       UVxf            UV in hexadecimal
+
+For example: printf("IV is %"IVdf"\n", iv);  That will expand
+to whatever is the correct format for the IVs.
+
 =head2 Source Documentation
 
 There's an effort going on to document the internal functions and
index 6467a29..47556a5 100644 (file)
@@ -1246,6 +1246,11 @@ find yourself overly concerned about reliability and start building checks
 into your message system, then you probably should use just TCP to start
 with.
 
+Note that UDP datagrams are I<not> a bytestream and should not be treated
+as such. This makes using I/O mechanisms with internal buffering
+like stdio (i.e. print() and friends) especially cumbersome. Use syswrite(),
+or better send(), like in the example below.
+
 Here's a UDP program similar to the sample Internet TCP client given
 earlier.  However, instead of checking one host at a time, the UDP version
 will check many of them asynchronously by simulating a multicast and then
@@ -1296,6 +1301,11 @@ with TCP, you'd have to use a different socket handle for each host.
        $count--;
     }
 
+Note that this example does not include any retries and may consequently
+fail to contact a reachable host. The most prominent reason for this
+is congestion of the queues on the sending host if the number of
+list of hosts to contact is sufficietly large.
+
 =head1 SysV IPC
 
 While System V IPC isn't so widely used as sockets, it still has some
index 3c84e60..0f83ed1 100644 (file)
@@ -196,7 +196,7 @@ C<$a> minus the largest multiple of C<$b> that is not greater than
 C<$a>.  If C<$b> is negative, then C<$a % $b> is C<$a> minus the
 smallest multiple of C<$b> that is not less than C<$a> (i.e. the
 result will be less than or equal to zero). 
-Note than when C<use integer> is in scope, "%" give you direct access
+Note than when C<use integer> is in scope, "%" gives you direct access
 to the modulus operator as implemented by your C compiler.  This
 operator is not as well defined for negative operands, but it will
 execute faster.
index accb11c..74c1f4e 100644 (file)
@@ -2243,6 +2243,8 @@ isa(CLASS), can(METHOD), VERSION( [NEED] )
 
 =item INSTANCE VARIABLES
 
+=item SCALAR INSTANCE VARIABLES
+
 =item INSTANCE VARIABLE INHERITANCE
 
 =item OBJECT RELATIONSHIPS
@@ -2340,8 +2342,8 @@ LIST, READ this, LIST, READLINE this, GETC this, CLOSE this, DESTROY this
 =item Pragmatic Modules
 
 attributes, attrs, autouse, base, blib, bytes, charnames, constant,
-diagnostics, fields, filetest, integer, less, locale, open, ops, overload,
-re, sigtrap, strict, subs, utf8, vars, warnings
+diagnostics, fields, filetest, integer, less, lib, locale, open, ops,
+overload, re, sigtrap, strict, subs, utf8, vars, warnings
 
 =item Standard Modules
 
@@ -2364,15 +2366,14 @@ File::stat, FileCache, FileHandle, FindBin, Getopt::Long, Getopt::Std,
 I18N::Collate, IO, IPC::Open2, IPC::Open3, Math::BigFloat, Math::BigInt,
 Math::Complex, Math::Trig, NDBM_File, Net::Ping, Net::hostent, Net::netent,
 Net::protoent, Net::servent, O, ODBM_File, Opcode, Pod::Checker, Pod::Find,
-Pod::Html, Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils,
-Pod::Parser, Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color,
-Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver,
-SelfLoader, Shell, Socket, Symbol, Term::ANSIColor, Term::Cap,
-Term::Complete, Term::ReadLine, Test, Test::Harness, Text::Abbrev,
-Text::ParseWords, Text::Soundex, Text::Wrap, Tie::Array, Tie::Handle,
-Tie::Hash, Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local,
-Time::gmtime, Time::localtime, Time::tm, UNIVERSAL, User::grent,
-User::pwent
+Pod::Html, Pod::InputObjects, Pod::Man, Pod::ParseUtils, Pod::Parser,
+Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, Pod::Text::Termcap,
+Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell,
+Socket, Symbol, Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine,
+Test, Test::Harness, Text::Abbrev, Text::ParseWords, Text::Soundex,
+Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash, Tie::RefHash, Tie::Scalar,
+Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, Time::tm,
+UNIVERSAL, User::grent, User::pwent
 
 =item Extension Modules
 
@@ -3763,6 +3764,34 @@ C<void save_hptr(HV **hptr)>
 
 =back
 
+=item Internal Functions
+
+A, p, d, s, n, r, f, m, o, j, x
+
+=over
+
+=item Source Documentation
+
+=back
+
+=item Unicode Support
+
+=over
+
+=item What B<is> Unicode, anyway?
+
+=item How can I recognise a UTF8 string?
+
+=item How does UTF8 represent Unicode characters?
+
+=item How does Perl store UTF8 strings?
+
+=item How do I convert a string to UTF8?
+
+=item Is there anything else I need to know?
+
+=back
+
 =item AUTHORS
 
 =item SEE ALSO
@@ -3950,45 +3979,48 @@ B<filter_fetch_value>
 
 =item DESCRIPTION
 
-AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop, av_push,
-av_shift, av_store, av_undef, av_unshift, bytes_to_utf8, call_argv,
-call_method, call_pv, call_sv, CLASS, Copy, croak, CvSTASH, dMARK,
-dORIGMARK, dSP, dXSARGS, dXSI32, ENTER, eval_pv, eval_sv, EXTEND,
-fbm_compile, fbm_instr, FREETMPS, get_av, get_cv, get_hv, get_sv, GIMME,
-GIMME_V, GvSV, gv_fetchmeth, gv_fetchmethod, gv_fetchmethod_autoload,
-gv_stashpv, gv_stashsv, G_ARRAY, G_DISCARD, G_EVAL, G_NOARGS, G_SCALAR,
-G_VOID, HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV, HeSVKEY, HeSVKEY_force,
-HeSVKEY_set, HeVAL, HvNAME, hv_clear, hv_delete, hv_delete_ent, hv_exists,
-hv_exists_ent, hv_fetch, hv_fetch_ent, hv_iterinit, hv_iterkey,
-hv_iterkeysv, hv_iternext, hv_iternextsv, hv_iterval, hv_magic, hv_store,
-hv_store_ent, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE,
-isUPPER, items, ix, LEAVE, looks_like_number, MARK, mg_clear, mg_copy,
-mg_find, mg_free, mg_get, mg_length, mg_magical, mg_set, Move, New, newAV,
-Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv,
-newSVpv, newSVpvf, newSVpvn, newSVrv, newSVsv, newSVuv, newXS, newXSproto,
-Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc,
-perl_construct, perl_destruct, perl_free, perl_parse, perl_run,
-PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn, PL_modglobal, PL_na,
-PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn, POPp, POPs, PUSHi,
-PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc, require_pv,
-RETVAL, Safefree, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE,
-strGT, strLE, strLT, strNE, strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set,
-SvEND, SvGETMAGIC, SvGROW, SvIOK, SvIOKp, SvIOK_off, SvIOK_on, SvIOK_only,
-SvIV, SvIVX, SvLEN, SvLOCK, SvNIOK, SvNIOKp, SvNIOK_off, SvNOK, SvNOKp,
-SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, SvOK, SvOOK, SvPOK, SvPOKp,
-SvPOK_off, SvPOK_on, SvPOK_only, SvPV, SvPVX, SvPV_force, SvPV_nolen,
-SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV,
-SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT, SvTAINTED,
-SvTAINTED_off, SvTAINTED_on, SvTRUE, SvTYPE, svtype, SVt_IV, SVt_NV,
-SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUNLOCK, SvUPGRADE, SvUV,
+AvFILL, av_clear, av_delete, av_exists, av_extend, av_fetch, av_fill,
+av_len, av_make, av_pop, av_push, av_shift, av_store, av_undef, av_unshift,
+bytes_to_utf8, call_argv, call_method, call_pv, call_sv, CLASS, Copy,
+croak, CvSTASH, dMARK, dORIGMARK, dSP, dXSARGS, dXSI32, ENTER, eval_pv,
+eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS, get_av, get_cv, get_hv,
+get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth, gv_fetchmethod,
+gv_fetchmethod_autoload, gv_stashpv, gv_stashsv, G_ARRAY, G_DISCARD,
+G_EVAL, G_NOARGS, G_SCALAR, G_VOID, HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV,
+HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, HvNAME, hv_clear, hv_delete,
+hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent,
+hv_iterinit, hv_iterkey, hv_iterkeysv, hv_iternext, hv_iternextsv,
+hv_iterval, hv_magic, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA,
+isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, looks_like_number,
+MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_length, mg_magical,
+mg_set, Move, New, newAV, Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc,
+NEWSV, newSViv, newSVnv, newSVpv, newSVpvf, newSVpvn, newSVrv, newSVsv,
+newSVuv, newXS, newXSproto, Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv,
+ORIGMARK, perl_alloc, perl_construct, perl_destruct, perl_free, perl_parse,
+perl_run, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn, PL_modglobal,
+PL_na, PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn, POPp, POPs,
+PUSHi, PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc,
+require_pv, RETVAL, Safefree, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST,
+strEQ, strGE, strGT, strLE, strLT, strNE, strnEQ, strnNE, StructCopy,
+SvCUR, SvCUR_set, SvEND, SvGETMAGIC, SvGROW, SvIOK, SvIOKp, SvIOK_off,
+SvIOK_on, SvIOK_only, SvIV, SvIVX, SvLEN, SvNIOK, SvNIOKp, SvNIOK_off,
+SvNOK, SvNOKp, SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, SvOK, SvOOK,
+SvPOK, SvPOKp, SvPOK_off, SvPOK_on, SvPOK_only, SvPV, SvPVX, SvPV_force,
+SvPV_nolen, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off,
+SvROK_on, SvRV, SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT,
+SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, svtype, SvTYPE, SVt_IV,
+SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUPGRADE, SvUV,
 SvUVX, sv_2mortal, sv_bless, sv_catpv, sv_catpvf, sv_catpvf_mg, sv_catpvn,
-sv_catpvn_mg, sv_catpv_mg, sv_catsv, sv_catsv_mg, sv_chop, sv_cmp, sv_dec,
-sv_derived_from, sv_eq, sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject,
-sv_len, sv_magic, sv_mortalcopy, sv_newmortal, sv_setiv, sv_setiv_mg,
-sv_setnv, sv_setnv_mg, sv_setpv, sv_setpvf, sv_setpvf_mg, sv_setpviv,
-sv_setpviv_mg, sv_setpvn, sv_setpvn_mg, sv_setpv_mg, sv_setref_iv,
-sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, sv_setsv_mg, sv_setuv,
-sv_setuv_mg, sv_unref, sv_upgrade, sv_usepvn, sv_usepvn_mg, sv_vcatpvfn,
+sv_catpvn_mg, sv_catpv_mg, sv_catsv, sv_catsv_mg, sv_chop, sv_clear,
+sv_cmp, sv_cmp_locale, sv_dec, sv_derived_from, sv_eq, sv_free, sv_gets,
+sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, sv_len, sv_len_utf8,
+sv_magic, sv_mortalcopy, sv_newmortal, sv_pvn_force, sv_pvutf8n_force,
+sv_reftype, sv_replace, sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv,
+sv_setnv_mg, sv_setpv, sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg,
+sv_setpvn, sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, sv_setref_nv,
+sv_setref_pv, sv_setref_pvn, sv_setsv, sv_setsv_mg, sv_setuv, sv_setuv_mg,
+sv_true, sv_unmagic, sv_unref, sv_upgrade, sv_usepvn, sv_usepvn_mg,
+sv_utf8_downgrade, sv_utf8_encode, sv_utf8_upgrade, sv_vcatpvfn,
 sv_vsetpvfn, THIS, toLOWER, toUPPER, U8 *s, utf8_to_bytes, warn, XPUSHi,
 XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV,
 XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES,
@@ -4372,426 +4404,121 @@ the feature generic enough?, Does it potentially introduce new bugs?, Does
 it preclude other desirable features?, Is the implementation robust?, Is
 the implementation generic enough to be portable?, Is there enough
 documentation?, Is there another way to do it?, Does it create too much
-work?, Patches speak louder than words
-
-=item AUTHOR
-
-=back
-
-=head2 perlhist - the Perl history records
-
-=over
-
-=item DESCRIPTION
-
-=item INTRODUCTION
-
-=item THE KEEPERS OF THE PUMPKIN
+work?, Patches speak louder than words, L<perlguts>, L<perlxstut> and
+L<perlxs>, L<perlapi>, F<Porting/pumpkin.pod>, The perl5-porters FAQ
 
 =over
 
-=item PUMPKIN?
-
-=back
-
-=item THE RECORDS
-
-=over
-
-=item SELECTED RELEASE SIZES
-
-=item SELECTED PATCH SIZES
-
-=back
-
-=item THE KEEPERS OF THE RECORDS
-
-=back
-
-=head2 perldelta - what's new for perl v5.6.0
-
-=over
-
-=item DESCRIPTION
-
-=item Core Enhancements
-
-=over
-
-=item Interpreter cloning, threads, and concurrency
-
-=item Lexically scoped warning categories
-
-=item Unicode and UTF-8 support
-
-=item Support for interpolating named characters
-
-=item "our" declarations
-
-=item Support for strings represented as a vector of ordinals
-
-=item Improved Perl version numbering system
-
-=item New syntax for declaring subroutine attributes
-
-=item File and directory handles can be autovivified
-
-=item open() with more than two arguments
-
-=item 64-bit support
-
-=item Large file support
-
-=item Long doubles
-
-=item "more bits"
-
-=item Enhanced support for sort() subroutines
-
-=item C<sort $coderef @foo> allowed
-
-=item File globbing implemented internally
-
-Support for CHECK blocks
-
-=item POSIX character class syntax [: :] supported
+=item Finding Your Way Around
 
-Better pseudo-random number generator
+Core modules, Documentation, Configure, Interpreter
 
-=item Improved C<qw//> operator
+=item Elements of the interpreter
 
-Better worst-case behavior of hashes
+Startup, Parsing, Optimization, Running
 
-=item pack() format 'Z' supported
+=item Internal Variable Types
 
-=item pack() format modifier '!' supported
+=item Op Trees
 
-=item pack() and unpack() support counted strings
+=item Stacks
 
-=item Comments in pack() templates
+Argument stack, Mark stack, Save stack
 
-=item Weak references
+=item Millions of Macros
 
-=item Binary numbers supported
+=item Poking at Perl
 
-=item Lvalue subroutines
+=item Using a source-level debugger
 
-=item Some arrows may be omitted in calls through references
+run [args], break function_name, break source.c:xxx, step, next, continue,
+finish, print
 
-=item Boolean assignment operators are legal lvalues
+=item Dumping Perl Data Structures
 
-=item exists() is supported on subroutine names
+=item Patching
 
-=item exists() and delete() are supported on array elements
-
-=item Pseudo-hashes work better
-
-=item Automatic flushing of output buffers
-
-=item Better diagnostics on meaningless filehandle operations
-
-=item Where possible, buffered data discarded from duped input filehandle
-
-=item eof() has the same old magic as <>
-
-=item binmode() can be used to set :crlf and :raw modes
-
-=item C<-T> filetest recognizes UTF-8 encoded files as "text"
-
-=item system(), backticks and pipe open now reflect exec() failure
-
-=item Improved diagnostics
-
-=item Diagnostics follow STDERR
-
-More consistent close-on-exec behavior
-
-=item syswrite() ease-of-use
-
-=item Better syntax checks on parenthesized unary operators
-
-=item Bit operators support full native integer width
-
-=item Improved security features
-
-More functional bareword prototype (*)
-
-=item C<require> and C<do> may be overridden
-
-=item $^X variables may now have names longer than one character
-
-=item New variable $^C reflects C<-c> switch
+=item CONCLUSION
 
-=item New variable $^V contains Perl version as a string
-
-=item Optional Y2K warnings
+I<The Road goes ever on and on, down from the door where it began.>
 
 =back
 
-=item Modules and Pragmata
-
-=over
-
-=item Modules
-
-attributes, B, Benchmark, ByteLoader, constant, charnames, Data::Dumper,
-DB, DB_File, Devel::DProf, Devel::Peek, Dumpvalue, DynaLoader, English,
-Env, Fcntl, File::Compare, File::Find, File::Glob, File::Spec,
-File::Spec::Functions, Getopt::Long, IO, JPL, lib, Math::BigInt,
-Math::Complex, Math::Trig, Pod::Parser, Pod::InputObjects, Pod::Checker,
-podchecker, Pod::ParseUtils, Pod::Find, Pod::Select, podselect, Pod::Usage,
-pod2usage, Pod::Text and Pod::Man, SDBM_File, Sys::Syslog, Sys::Hostname,
-Term::ANSIColor, Time::Local, Win32, XSLoader, DBM Filters
-
-=item Pragmata
+=item AUTHOR
 
 =back
 
-=item Utility Changes
+=head2 perlhist - the Perl history records
 
 =over
 
-=item dprofpp
-
-=item find2perl
+=item DESCRIPTION
 
-=item h2xs
+=item INTRODUCTION
 
-=item perlcc
+=item THE KEEPERS OF THE PUMPKIN
 
-=item perldoc
+=over
 
-=item The Perl Debugger
+=item PUMPKIN?
 
 =back
 
-=item Improved Documentation
-
-perlapi.pod, perlboot.pod, perlcompile.pod, perldbmfilter.pod,
-perldebug.pod, perldebguts.pod, perlfork.pod, perlfilter.pod, perlhack.pod,
-perlintern.pod, perllexwarn.pod, perlnumber.pod, perlopentut.pod,
-perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod
-
-=item Performance enhancements
+=item THE RECORDS
 
 =over
 
-=item Simple sort() using { $a <=> $b } and the like are optimized
+=item SELECTED RELEASE SIZES
 
-=item Optimized assignments to lexical variables
+=item SELECTED PATCH SIZES
 
-=item Faster subroutine calls
+=back
 
-delete(), each(), values() and hash iteration are faster
+=item THE KEEPERS OF THE RECORDS
 
 =back
 
-=item Installation and Configuration Improvements
+=head2 perldelta - what's new for perl v5.8.0
 
 =over
 
-=item -Dusethreads means something different
-
-=item New Configure flags
+=item DESCRIPTION
 
-=item Threadedness and 64-bitness now more daring
+=item Core Enhancements
 
-=item Long Doubles
+=item Modules and Pragmata
 
-=item -Dusemorebits
+=item Utility Changes
 
-=item -Duselargefiles
+=item Improved Documentation
 
-=item installusrbinperl
+=item Performance enhancements
 
-=item SOCKS support
+=item Installation and Configuration Improvements
 
-=item C<-A> flag
+=over
 
-=item Enhanced Installation Directories
+=item gcc automatically tried if 'cc' does not seem to be working
 
 =back
 
 =item Platform specific changes
 
-=over
-
-=item Supported platforms
-
-=item DOS
-
-=item OS390 (OpenEdition MVS)
-
-=item VMS
-
-=item Win32
-
-=back
-
 =item Significant bug fixes
 
-=over
-
-=item <HANDLE> on empty files
-
-=item C<eval '...'> improvements
-
-=item All compilation errors are true errors
-
-=item Implicitly closed filehandles are safer
-
-=item Behavior of list slices is more consistent
-
-=item C<(\$)> prototype and C<$foo{a}>
-
-=item C<goto &sub> and AUTOLOAD
-
-=item C<-bareword> allowed under C<use integer>
-
-=item Failures in DESTROY()
-
-=item Locale bugs fixed
-
-=item Memory leaks
-
-=item Spurious subroutine stubs after failed subroutine calls
-
-=item Taint failures under C<-U>
-
-=item END blocks and the C<-c> switch
-
-=item Potential to leak DATA filehandles
-
-=back
-
 =item New or Changed Diagnostics
 
-(perhaps you forgot to load "%s"?), "%s" variable %s masks earlier
-declaration in same %s, "my sub" not yet implemented, "our" variable %s
-redeclared, '!' allowed only after types %s, / cannot take a count, / must
-be followed by a, A or Z, / must be followed by a*, A* or Z*, / must follow
-a numeric type, /%s/: Unrecognized escape \\%c passed through, /%s/:
-Unrecognized escape \\%c in character class passed through, /%s/ should
-probably be written as "%s", %s() called too early to check prototype, %s
-argument is not a HASH or ARRAY element, %s argument is not a HASH or ARRAY
-element or slice, %s argument is not a subroutine name, %s package
-attribute may clash with future reserved word: %s, (in cleanup) %s, <>
-should be quotes, Ambiguous range in transliteration operator, Attempt to
-join self, Bad evalled substitution pattern, Bad realloc() ignored,
-Bareword found in conditional, Binary number >
-0b11111111111111111111111111111111 non-portable, Bit vector size > 32
-non-portable, Buffer overflow in prime_env_iter: %s, Can't check filesystem
-of script "%s", Can't declare class for non-scalar %s in "%s", Can't
-declare %s in "%s", Can't ignore signal CHLD, forcing to default, Can't
-modify non-lvalue subroutine call, Can't read CRTL environ, Can't remove
-%s: %s, skipping file, Can't return %s from lvalue subroutine, Can't weaken
-a nonreference, Character class [:%s:] unknown, Character class syntax [%s]
-belongs inside character classes, Constant is not %s reference,
-constant(%s): %s, CORE::%s is not a keyword, defined(@array) is deprecated,
-defined(%hash) is deprecated, Did not produce a valid header, (Did you mean
-"local" instead of "our"?), Document contains no data, entering effective
-%s failed, false [] range "%s" in regexp, Filehandle %s opened only for
-output, flock() on closed filehandle %s, Global symbol "%s" requires
-explicit package name, Hexadecimal number > 0xffffffff non-portable,
-Ill-formed CRTL environ value "%s", Ill-formed message in prime_env_iter:
-|%s|, Illegal binary digit %s, Illegal binary digit %s ignored, Illegal
-number of bits in vec, Integer overflow in %s number, Invalid %s attribute:
-%s, Invalid %s attributes: %s, invalid [] range "%s" in regexp, invalid []
-range "%s" in transliteration operator, Invalid separator character %s in
-attribute list, Invalid separator character %s in subroutine attribute
-list, leaving effective %s failed, Lvalue subs returning %s not implemented
-yet, Method %s not permitted, Missing %sbrace%s on \N{}, Missing command in
-piped open, Missing name in "my sub", No %s specified for -%c, No package
-name allowed for variable %s in "our", No space allowed after -%c, no UTC
-offset information; assuming local time is UTC, Octal number > 037777777777
-non-portable, panic: del_backref, panic: kid popen errno read, panic:
-magic_killbackrefs, Parentheses missing around "%s" list, Possible Y2K bug:
-%s, pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead, Premature
-end of script headers, Repeat count in pack overflows, Repeat count in
-unpack overflows, realloc() of freed memory ignored, Reference is already
-weak, setpgrp can't take arguments, Strange *+?{} on zero-length
-expression, switching effective %s is not implemented, This Perl can't
-reset CRTL environ elements (%s), This Perl can't set CRTL environ elements
-(%s=%s), Too late to run %s block, Unknown open() mode '%s', Unknown
-process %x sent message to prime_env_iter: %s, Unrecognized escape \\%c
-passed through, Unterminated attribute parameter in attribute list,
-Unterminated attribute list, Unterminated attribute parameter in subroutine
-attribute list, Unterminated subroutine attribute list, Value of CLI symbol
-"%s" too long, Version number must be a constant number
+(perhaps you forgot to load "%s"?), Ambiguous range in transliteration
+operator
 
 =item New tests
 
 =item Incompatible Changes
 
-=over
-
-=item Perl Source Incompatibilities
-
-CHECK is a new keyword, Treatment of list slices of undef has changed
-
-=item Format of $English::PERL_VERSION is different
-
-Literals of the form C<1.2.3> parse differently, Possibly changed
-pseudo-random number generator, Hashing function for hash keys has changed,
-C<undef> fails on read only values, Close-on-exec bit may be set on pipe
-and socket handles, Writing C<"$$1"> to mean C<"${$}1"> is unsupported,
-delete(), values() and C<\(%h)> operate on aliases to values, not copies,
-vec(EXPR,OFFSET,BITS) enforces powers-of-two BITS, Text of some diagnostic
-output has changed, C<%@> has been removed, Parenthesized not() behaves
-like a list operator, Semantics of bareword prototype C<(*)> have changed
-
-=item Semantics of bit operators may have changed on 64-bit platforms
-
-=item More builtins taint their results
-
-=item C Source Incompatibilities
-
-C<PERL_POLLUTE>, C<PERL_IMPLICIT_CONTEXT>, C<PERL_POLLUTE_MALLOC>
-
-=item Compatible C Source API Changes
-
-C<PATCHLEVEL> is now C<PERL_VERSION>
-
-=item Binary Incompatibilities
-
-=back
-
 =item Known Problems
 
-=over
-
-=item Thread test failures
-
-=item EBCDIC platforms not supported
-
-=item In 64-bit HP-UX the lib/io_multihomed test may hang
-
-=item NEXTSTEP 3.3 POSIX test failure
-
-=item Tru64 (aka Digital UNIX, aka DEC OSF/1) lib/sdbm test failure with
-gcc
-
-=item UNICOS/mk CC failures during Configure run
-
-=item Arrow operator and arrays
-
-=item Windows 2000
-
-=item Experimental features
-
-Threads, Unicode, 64-bit support, Lvalue subroutines, Weak references, The
-pseudo-hash data type, The Compiler suite, Internal implementation of file
-globbing, The DB module, The regular expression constructs C<(?{ code })>
-and C<(??{ code })>
-
-=back
-
 =item Obsolete Diagnostics
 
-Character class syntax [: :] is reserved for future extensions, Ill-formed
-logical name |%s| in prime_env_iter, Probable precedence problem on %s,
-regexp too big, Use of "$$<digit>" to mean "${$}<digit>" is deprecated
-
 =item Reporting Bugs
 
 =item SEE ALSO
@@ -5782,6 +5509,8 @@ DJGPP, Pthreads
 
 =item NFS filesystems and utime(2)
 
+=item perl -P and //
+
 =back
 
 =item AUTHOR
@@ -6777,6 +6506,8 @@ warnings::warn([$category,] $message)
 
 =item Package Lexicals
 
+=item Not Using AutoLoader
+
 =item B<AutoLoader> vs. B<SelfLoader>
 
 =back
@@ -6960,7 +6691,7 @@ bytecode
 
 =item DESCRIPTION
 
-=item AUTHORS
+=item AUTHOR
 
 =back
 
@@ -6987,15 +6718,14 @@ bytecode
 =item OPTIONS
 
 B<-ofilename>, B<-afilename>, B<-->, B<-f>, B<-fcompress-nullops>,
-B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-On>, B<-D>, B<-Do>,
-B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-Ppackage>    Stores package in the
-output.    =back
+B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-fstrip-syntax-tree>,
+B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m>
 
 =item EXAMPLES
 
 =item BUGS
 
-=item AUTHORS
+=item AUTHOR
 
 =back
 
@@ -7289,15 +7019,14 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache (
 =item OPTIONS
 
 B<-ofilename>, B<-afilename>, B<-->, B<-f>, B<-fcompress-nullops>,
-B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-On>, B<-D>, B<-Do>,
-B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-Ppackage>    Stores package in the
-output.    =back
+B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-fstrip-syntax-tree>,
+B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m>
 
 =item EXAMPLES
 
 =item BUGS
 
-=item AUTHORS
+=item AUTHOR
 
 =back
 
@@ -8586,8 +8315,6 @@ arrays
 
 =item Specialised Import Lists
 
-=item Constants can be inlined
-
 =item Exporting without using Export's import method
 
 =item Module Version Checking
@@ -12082,6 +11809,18 @@ C<-pathlist>
 
 =item DESCRIPTION
 
+C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
+
+=item DIAGNOSTICS
+
+=over
+
+=item C<sdbm store returned -1, errno 22, key "..." at ...>
+
+=back
+
+=item BUGS AND WARNINGS
+
 =back
 
 =head2 Safe - Compile and execute code in restricted compartments
index 15308e4..83f4d9c 100644 (file)
@@ -691,6 +691,11 @@ program sees.  This is more useful as a way of indicating the current
 program state than it is for hiding the program you're running.
 (Mnemonic: same as B<sh> and B<ksh>.)
 
+Note for BSD users: setting C<$0> does not completely remove "perl"
+from the ps(1) output.  For example, setting C<$0> to C<"foobar"> will
+result in C<"perl: foobar (perl)">.  This is an operating system
+feature.
+
 =item $[
 
 The index of the first element in an array, and of the first character
@@ -821,7 +826,7 @@ Then
 would allocate a 64K buffer for use in an emergency.  See the
 F<INSTALL> file in the Perl distribution for information on how to
 enable this option.  To discourage casual use of this advanced
-feature, there is no L<English> long name for this variable.
+feature, there is no L<English|English> long name for this variable.
 
 =item $OSNAME
 
diff --git a/pp.c b/pp.c
index cb55181..66800aa 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2203,7 +2203,7 @@ PP(pp_chr)
 
     (void)SvUPGRADE(TARG,SVt_PV);
 
-    if (value > 255 && !IN_BYTE) {
+    if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
        SvGROW(TARG, UTF8_MAXLEN+1);
        tmps = SvPVX(TARG);
        tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
index ce9e198..06b29ec 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3093,7 +3093,7 @@ trylocal: {
 
                            if (io) {
                                tryrsfp = IoIFP(io);
-                               if (IoTYPE(io) == '|') {
+                               if (IoTYPE(io) == IoTYPE_PIPE) {
                                    /* reading from a child process doesn't
                                       nest -- when returning from reading
                                       the inner module, the outer one is
index 39cc0e0..1b5f278 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -398,26 +398,31 @@ PP(pp_print)
        RETURN;
     }
     if (!(io = GvIO(gv))) {
-       if (ckWARN(WARN_UNOPENED)) {
-           SV* sv = sv_newmortal();
-           gv_efullname3(sv, gv, Nullch);
-            Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
-                       SvPV(sv,n_a));
-        }
+        dTHR;
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
        SETERRNO(EBADF,RMS$_IFI);
        goto just_say_no;
     }
     else if (!(fp = IoOFP(io))) {
        if (ckWARN2(WARN_CLOSED, WARN_IO))  {
            if (IoIFP(io)) {
-               SV* sv = sv_newmortal();
-               gv_efullname3(sv, gv, Nullch);
-               Perl_warner(aTHX_ WARN_IO,
-                           "Filehandle %s opened only for input",
-                           SvPV(sv,n_a));
+               /* integrate with report_evil_fh()? */
+               char *name = NULL;
+               if (isGV(gv)) {
+                   SV* sv = sv_newmortal();
+                   gv_efullname4(sv, gv, Nullch, FALSE);
+                   name = SvPV_nolen(sv);
+               }
+               if (name && *name)
+                 Perl_warner(aTHX_ WARN_IO,
+                             "Filehandle %s opened only for input", name);
+               else
+                   Perl_warner(aTHX_ WARN_IO,
+                               "Filehandle opened only for input");
            }
-           else if (ckWARN(WARN_CLOSED))
-               report_closed_fh(gv, io, "print", "filehandle");
+           else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+               report_evil_fh(gv, io, PL_op->op_type);
        }
        SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
        goto just_say_no;
@@ -1381,10 +1386,19 @@ Perl_do_readline(pTHX)
                 && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
                     || fp == PerlIO_stderr()))
        {
-           SV* sv = sv_newmortal();
-           gv_efullname3(sv, PL_last_in_gv, Nullch);
-           Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
-                       SvPV_nolen(sv));
+           /* integrate with report_evil_fh()? */
+           char *name = NULL;
+           if (isGV(PL_last_in_gv)) { /* can this ever fail? */
+               SV* sv = sv_newmortal();
+               gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE);
+               name = SvPV_nolen(sv);
+           }
+           if (name && *name)
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle %s opened only for output", name);
+           else
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle opened only for output");
        }
     }
     if (!fp) {
@@ -1394,7 +1408,7 @@ Perl_do_readline(pTHX)
                            "glob failed (can't start child: %s)",
                            Strerror(errno));
            else
-               report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
+               report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
        }
        if (gimme == G_SCALAR) {
            (void)SvOK_off(TARG);
index 3134182..5186025 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -612,8 +612,8 @@ PP(pp_pipe_op)
     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
     IoIFP(wstio) = IoOFP(wstio);
-    IoTYPE(rstio) = '<';
-    IoTYPE(wstio) = '>';
+    IoTYPE(rstio) = IoTYPE_RDONLY;
+    IoTYPE(wstio) = IoTYPE_WRONLY;
 
     if (!IoIFP(rstio) || !IoOFP(wstio)) {
        if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
@@ -1070,7 +1070,7 @@ PP(pp_select)
     else {
        GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
        if (gvp && *gvp == egv) {
-           gv_efullname3(TARG, PL_defoutgv, Nullch);
+           gv_efullname4(TARG, PL_defoutgv, Nullch, FALSE);
            XPUSHTARG;
        }
        else {
@@ -1174,11 +1174,14 @@ PP(pp_enterwrite)
 
     cv = GvFORM(fgv);
     if (!cv) {
+        char *name = NULL;
        if (fgv) {
            SV *tmpsv = sv_newmortal();
-           gv_efullname3(tmpsv, fgv, Nullch);
-           DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
+           gv_efullname4(tmpsv, fgv, Nullch, FALSE);
+           name = SvPV_nolen(tmpsv);
        }
+       if (name && *name)
+           DIE(aTHX_ "Undefined format \"%s\" called", name);
        DIE(aTHX_ "Not a format reference");
     }
     if (CvCLONE(cv))
@@ -1255,10 +1258,19 @@ PP(pp_leavewrite)
        if (!fgv)
            DIE(aTHX_ "bad top format reference");
        cv = GvFORM(fgv);
-       if (!cv) {
-           SV *tmpsv = sv_newmortal();
-           gv_efullname3(tmpsv, fgv, Nullch);
-           DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
+       {
+           char *name = NULL;
+           if (!cv) {
+               SV *sv = sv_newmortal();
+               gv_efullname4(sv, fgv, Nullch, FALSE);
+               name = SvPV_nolen(sv);
+           }
+           if (name && *name)
+               DIE(aTHX_ "Undefined top format \"%s\" called",name);
+           /* why no:
+           else
+               DIE(aTHX_ "Undefined top format called");
+           ?*/
        }
        if (CvCLONE(cv))
            cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
@@ -1274,14 +1286,22 @@ PP(pp_leavewrite)
     if (!fp) {
        if (ckWARN2(WARN_CLOSED,WARN_IO)) {
            if (IoIFP(io)) {
-               SV* sv = sv_newmortal();
-               gv_efullname3(sv, gv, Nullch);
-               Perl_warner(aTHX_ WARN_IO,
-                           "Filehandle %s opened only for input",
-                           SvPV_nolen(sv));
+               /* integrate with report_evil_fh()? */
+               char *name = NULL;
+               if (isGV(gv)) {
+                   SV* sv = sv_newmortal();
+                   gv_efullname4(sv, gv, Nullch, FALSE);
+                   name = SvPV_nolen(sv);
+               }
+               if (name && *name)
+                   Perl_warner(aTHX_ WARN_IO,
+                               "Filehandle %s opened only for input", name);
+               else
+                   Perl_warner(aTHX_ WARN_IO,
+                               "Filehandle opened only for input");
            }
            else if (ckWARN(WARN_CLOSED))
-               report_closed_fh(gv, io, "write", "filehandle");
+               report_evil_fh(gv, io, PL_op->op_type);
        }
        PUSHs(&PL_sv_no);
     }
@@ -1344,24 +1364,30 @@ PP(pp_prtf)
 
     sv = NEWSV(0,0);
     if (!(io = GvIO(gv))) {
-       if (ckWARN(WARN_UNOPENED)) {
-           gv_efullname3(sv, gv, Nullch);
-           Perl_warner(aTHX_ WARN_UNOPENED,
-                       "Filehandle %s never opened", SvPV(sv,n_a));
-       }
+        dTHR;
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
        SETERRNO(EBADF,RMS$_IFI);
        goto just_say_no;
     }
     else if (!(fp = IoOFP(io))) {
        if (ckWARN2(WARN_CLOSED,WARN_IO))  {
+           /* integrate with report_evil_fh()? */
            if (IoIFP(io)) {
-               gv_efullname3(sv, gv, Nullch);
-               Perl_warner(aTHX_ WARN_IO,
-                           "Filehandle %s opened only for input",
-                           SvPV(sv,n_a));
+               char *name = NULL;
+               if (isGV(gv)) {
+                   gv_efullname4(sv, gv, Nullch, FALSE);
+                   name = SvPV_nolen(sv);
+               }
+               if (name && *name)
+                   Perl_warner(aTHX_ WARN_IO,
+                               "Filehandle %s opened only for input", name);
+               else
+                   Perl_warner(aTHX_ WARN_IO,
+                               "Filehandle opened only for input");
            }
            else if (ckWARN(WARN_CLOSED))
-               report_closed_fh(gv, io, "printf", "filehandle");
+               report_evil_fh(gv, io, PL_op->op_type);
        }
        SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
        goto just_say_no;
@@ -1515,7 +1541,7 @@ PP(pp_sysread)
     }
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
-       if (IoTYPE(io) == 's') {
+       if (IoTYPE(io) == IoTYPE_SOCKET) {
            length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
                                   buffer+offset, length, 0);
        }
@@ -1528,7 +1554,7 @@ PP(pp_sysread)
     }
     else
 #ifdef HAS_SOCKET__bad_code_maybe
-    if (IoTYPE(io) == 's') {
+    if (IoTYPE(io) == IoTYPE_SOCKET) {
        char namebuf[MAXPATHLEN];
 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
        bufsize = sizeof (struct sockaddr_in);
@@ -1547,13 +1573,22 @@ PP(pp_sysread)
            length = -1;
     }
     if (length < 0) {
-       if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+       if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
            || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
        {
-           SV* sv = sv_newmortal();
-           gv_efullname3(sv, gv, Nullch);
-           Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
-                       SvPV_nolen(sv));
+           /* integrate with report_evil_fh()? */
+           char *name = NULL;
+           if (isGV(gv)) {
+               SV* sv = sv_newmortal();
+               gv_efullname4(sv, gv, Nullch, FALSE);
+               name = SvPV_nolen(sv);
+           }
+           if (name && *name)
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle %s opened only for output", name);
+           else
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle opened only for output");
        }
        goto say_undef;
     }
@@ -1630,12 +1665,8 @@ PP(pp_send)
     io = GvIO(gv);
     if (!io || !IoIFP(io)) {
        retval = -1;
-       if (ckWARN(WARN_CLOSED)) {
-           if (PL_op->op_type == OP_SYSWRITE)
-               report_closed_fh(gv, io, "syswrite", "filehandle");
-           else
-               report_closed_fh(gv, io, "send", "socket");
-       }
+       if (ckWARN(WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
     }
     else if (PL_op->op_type == OP_SYSWRITE) {
        if (MARK < SP) {
@@ -1651,7 +1682,7 @@ PP(pp_send)
        if (length > blen - offset)
            length = blen - offset;
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
-       if (IoTYPE(io) == 's') {
+       if (IoTYPE(io) == IoTYPE_SOCKET) {
            retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
                                   buffer+offset, length, 0);
        }
@@ -1992,6 +2023,7 @@ PP(pp_flock)
     I32 value;
     int argtype;
     GV *gv;
+    IO *io = NULL;
     PerlIO *fp;
 
 #ifdef FLOCK
@@ -2000,19 +2032,21 @@ PP(pp_flock)
        gv = PL_last_in_gv;
     else
        gv = (GV*)POPs;
-    if (gv && GvIO(gv))
-       fp = IoIFP(GvIOp(gv));
-    else
+    if (gv && (io = GvIO(gv)))
+       fp = IoIFP(io);
+    else {
        fp = Nullfp;
+       io = NULL;
+    }
     if (fp) {
        (void)PerlIO_flush(fp);
        value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
     }
     else {
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
        value = 0;
        SETERRNO(EBADF,RMS$_IFI);
-       if (ckWARN(WARN_CLOSED))
-           report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
     }
     PUSHi(value);
     RETURN;
@@ -2051,7 +2085,7 @@ PP(pp_socket)
        RETPUSHUNDEF;
     IoIFP(io) = PerlIO_fdopen(fd, "r");        /* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w");
-    IoTYPE(io) = 's';
+    IoTYPE(io) = IoTYPE_SOCKET;
     if (!IoIFP(io) || !IoOFP(io)) {
        if (IoIFP(io)) PerlIO_close(IoIFP(io));
        if (IoOFP(io)) PerlIO_close(IoOFP(io));
@@ -2098,10 +2132,10 @@ PP(pp_sockpair)
        RETPUSHUNDEF;
     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
-    IoTYPE(io1) = 's';
+    IoTYPE(io1) = IoTYPE_SOCKET;
     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
-    IoTYPE(io2) = 's';
+    IoTYPE(io2) = IoTYPE_SOCKET;
     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
        if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
        if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
@@ -2173,7 +2207,7 @@ PP(pp_bind)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io, "bind", "socket");
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2203,7 +2237,7 @@ PP(pp_connect)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io, "connect", "socket");
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2229,7 +2263,7 @@ PP(pp_listen)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io, "listen", "socket");
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2270,7 +2304,7 @@ PP(pp_accept)
        goto badexit;
     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
-    IoTYPE(nstio) = 's';
+    IoTYPE(nstio) = IoTYPE_SOCKET;
     if (!IoIFP(nstio) || !IoOFP(nstio)) {
        if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
        if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
@@ -2286,7 +2320,7 @@ PP(pp_accept)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
+       report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
 
 badexit:
@@ -2313,7 +2347,7 @@ PP(pp_shutdown)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io, "shutdown", "socket");
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2392,9 +2426,7 @@ PP(pp_ssockopt)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io,
-                        optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
-                        "socket");
+       report_evil_fh(gv, io, optype);
     SETERRNO(EBADF,SS$_IVCHAN);
 nuts2:
     RETPUSHUNDEF;
@@ -2467,10 +2499,7 @@ PP(pp_getpeername)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-       report_closed_fh(gv, io,
-                        optype == OP_GETSOCKNAME ? "getsockname"
-                                                 : "getpeername",
-                        "socket");
+       report_evil_fh(gv, io, optype);
     SETERRNO(EBADF,SS$_IVCHAN);
 nuts2:
     RETPUSHUNDEF;
@@ -2490,7 +2519,7 @@ PP(pp_lstat)
 PP(pp_stat)
 {
     djSP;
-    GV *tmpgv;
+    GV *gv;
     I32 gimme;
     I32 max = 13;
     STRLEN n_a;
@@ -2498,24 +2527,28 @@ PP(pp_stat)
     if (PL_op->op_flags & OPf_REF) {
        tmpgv = cGVOP_gv;
       do_fstat:
-       if (tmpgv != PL_defgv) {
+       if (gv != PL_defgv) {
            PL_laststype = OP_STAT;
-           PL_statgv = tmpgv;
+           PL_statgv = gv;
            sv_setpv(PL_statname, "");
-           PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
-               ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
+           PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
+               ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
        }
-       if (PL_laststatval < 0)
+       if (PL_laststatval < 0) {
+           dTHR;
+           if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+               report_evil_fh(gv, GvIO(gv), PL_op->op_type);
            max = 0;
+       }
     }
     else {
        SV* sv = POPs;
        if (SvTYPE(sv) == SVt_PVGV) {
-           tmpgv = (GV*)sv;
+           gv = (GV*)sv;
            goto do_fstat;
        }
        else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
-           tmpgv = (GV*)SvRV(sv);
+           gv = (GV*)SvRV(sv);
            goto do_fstat;
        }
        sv_setpv(PL_statname, SvPV(sv,n_a));
@@ -3057,10 +3090,10 @@ PP(pp_fttext)
                len = 512;
        }
        else {
-           if (ckWARN(WARN_UNOPENED)) {
+           dTHR;
+           if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
                gv = cGVOP_gv;
-               Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
-                           GvENAME(gv));
+               report_evil_fh(gv, GvIO(gv), PL_op->op_type);
            }
            SETERRNO(EBADF,RMS$_IFI);
            RETPUSHUNDEF;
diff --git a/proto.h b/proto.h
index f65f898..b3e5f99 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -292,6 +292,7 @@ PERL_CALLCONV GV*   Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN le
 PERL_CALLCONV void     Perl_gv_check(pTHX_ HV* stash);
 PERL_CALLCONV void     Perl_gv_efullname(pTHX_ SV* sv, GV* gv);
 PERL_CALLCONV void     Perl_gv_efullname3(pTHX_ SV* sv, GV* gv, const char* prefix);
+PERL_CALLCONV void     Perl_gv_efullname4(pTHX_ SV* sv, GV* gv, const char* prefix, bool keepmain);
 PERL_CALLCONV GV*      Perl_gv_fetchfile(pTHX_ const char* name);
 PERL_CALLCONV GV*      Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level);
 PERL_CALLCONV GV*      Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name);
@@ -299,6 +300,7 @@ PERL_CALLCONV GV*   Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name
 PERL_CALLCONV GV*      Perl_gv_fetchpv(pTHX_ const char* name, I32 add, I32 sv_type);
 PERL_CALLCONV void     Perl_gv_fullname(pTHX_ SV* sv, GV* gv);
 PERL_CALLCONV void     Perl_gv_fullname3(pTHX_ SV* sv, GV* gv, const char* prefix);
+PERL_CALLCONV void     Perl_gv_fullname4(pTHX_ SV* sv, GV* gv, const char* prefix, bool keepmain);
 PERL_CALLCONV void     Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi);
 PERL_CALLCONV HV*      Perl_gv_stashpv(pTHX_ const char* name, I32 create);
 PERL_CALLCONV HV*      Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 create);
@@ -807,8 +809,8 @@ PERL_CALLCONV void  Perl_unlock_condpair(pTHX_ void* svv);
 PERL_CALLCONV void     Perl_unsharepvn(pTHX_ const char* sv, I32 len, U32 hash);
 PERL_CALLCONV void     Perl_unshare_hek(pTHX_ HEK* hek);
 PERL_CALLCONV void     Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* id, OP* arg);
-PERL_CALLCONV U8*      Perl_utf16_to_utf8(pTHX_ U16* p, U8 *d, I32 bytelen);
-PERL_CALLCONV U8*      Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8 *d, I32 bytelen);
+PERL_CALLCONV U8*      Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
+PERL_CALLCONV U8*      Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
 PERL_CALLCONV I32      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);
@@ -818,7 +820,7 @@ PERL_CALLCONV U8*   Perl_uv_to_utf8(pTHX_ U8 *d, UV uv);
 PERL_CALLCONV void     Perl_vivify_defelem(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_vivify_ref(pTHX_ SV* sv, U32 to_what);
 PERL_CALLCONV I32      Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags);
-PERL_CALLCONV void     Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj);
+PERL_CALLCONV void     Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op);
 PERL_CALLCONV void     Perl_report_uninit(pTHX);
 PERL_CALLCONV void     Perl_warn(pTHX_ const char* pat, ...)
 #ifdef CHECK_FORMAT
index a15eb23..f092e7e 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -904,6 +904,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                        } else {
                            /* start offset must point into the last copy */
                            data->last_start_min += minnext * (mincount - 1);
+                           data->last_start_max += is_inf ? 0 : (maxcount - 1)
+                               * (minnext + data->pos_delta);
                        }
                    }
                    /* It is counted once already... */
index 7472d09..002b66a 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -641,7 +641,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                       than for "\n", so one should lower the limit for t? */
                    DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
                        PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
-                   strpos = s = t + 1;
+                   other_last = strpos = s = t + 1;
                    goto restart;
                }
                t++;
diff --git a/sv.h b/sv.h
index c670f80..d242bf5 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -505,7 +505,8 @@ string.
 Returns the length of the string which is in the SV.  See C<SvLEN>.
 
 =for apidoc Am|STRLEN|SvLEN|SV* sv
-Returns the size of the string buffer in the SV.  See C<SvCUR>.
+Returns the size of the string buffer in the SV, not including any part
+attributable to C<SvOOK>.  See C<SvCUR>.
 
 =for apidoc Am|char*|SvEND|SV* sv
 Returns a pointer to the last character in the string which is in the SV.
@@ -733,18 +734,15 @@ Set the length of the string which is in the SV.  See C<SvCUR>.
 #define IoTYPE(sv)     ((XPVIO*)  SvANY(sv))->xio_type
 #define IoFLAGS(sv)    ((XPVIO*)  SvANY(sv))->xio_flags
 
-/*
-IoTYPE(sv) is a single character saying what type of I/O connection
-this is:
-    |        pipe
-    -        stdin or stdout
-    <        read-only
-    >        write-only
-    a        append
-    +        read and write
-    s        socket
-    space    closed
-*/
+/* IoTYPE(sv) is a single character telling the type of I/O connection. */
+#define IoTYPE_RDONLY  '<'
+#define IoTYPE_WRONLY  '>'
+#define IoTYPE_RDWR    '+'
+#define IoTYPE_APPEND  'a'
+#define IoTYPE_PIPE    '|'
+#define IoTYPE_STD     '-'     /* stdin or stdout */
+#define IoTYPE_SOCKET  's'
+#define IoTYPE_CLOSED  ' '
 
 /*
 =for apidoc Am|bool|SvTAINTED|SV* sv
index 51f513f..bfd4a37 100755 (executable)
@@ -19,6 +19,7 @@ sub do_require {
 sub write_file {
     my $f = shift;
     open(REQ,">$f") or die "Can't write '$f': $!";
+    binmode REQ;
     print REQ @_;
     close REQ;
 }
@@ -122,18 +123,19 @@ do "bleah.do";
 dofile();
 sub dofile { do "bleah.do"; };
 print $x;
-$i++;
 
 # UTF-encoded things
 my $utf8 = chr(0xFEFF);
-my $utf16 = chr(255).chr(254);
-do_require("${utf8}print \"ok $i\n\"; 1;\n");
-$i++;
-do_require("$utf8\nprint \"ok $i\n\"; 1;\n");
-$i++;
-do_require("$utf16\n1;");
-print "not " unless $@ =~ /^Unrecognized character /;
-print "ok $i\n";
+
+$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
+
+sub bytes_to_utf16 {
+    my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
+    return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; 
+}
+
+$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
+$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE
 
 END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; }
 
index d4b0e87..f2b5b9c 100755 (executable)
@@ -70,7 +70,8 @@ my %seen;
 setgrent();
 while (<GR>) {
     chomp;
-    my @s = split /:/;
+    # LIMIT -1 so that groups with no users don't fall off
+    my @s = split /:/, $_, -1;
     my ($name_s,$passwd_s,$gid_s,$members_s) = @s;
     if (@s) {
        push @{ $seen{$name_s} }, $.;
index 55f459d..00abc99 100755 (executable)
@@ -558,3 +558,7 @@ eval "C";
 M(C);
 EXPECT
 Modification of a read-only value attempted at - line 2.
+########
+print qw(ab a\b a\\b);
+EXPECT
+aba\ba\b
index 8eb9b6e..f3c9867 100755 (executable)
@@ -51,7 +51,13 @@ my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
 
 print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n";
 if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
-  print "1..0\n# Unsigned arithmetic is not sane\n";
+  print "1..0 # skipped: unsigned perl arithmetic is not sane";
+  eval { require Config; import Config };
+  use vars qw(%Config);
+  if ($Config{d_quad} eq 'define') {
+      print " (common in 64-bit platforms)";
+  }
+  print "\n";
   exit 0;
 }
 
index 0f67eb4..c09d7c2 100755 (executable)
@@ -71,7 +71,8 @@ my %seen;
 setpwent();
 while (<PW>) {
     chomp;
-    my @s = split /:/;
+    # LIMIT -1 so that users with empty shells don't fall off
+    my @s = split /:/, $_, -1;
     my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s;
     next if /^\+/; # ignore NIS includes
     if (@s) {
index 421442d..3848325 100644 (file)
@@ -756,9 +756,22 @@ tt+$       xxxtt   y       -       -
 ^(.,){2}c      a,b,c   y       $1      b,
 ^(?:[^,]*,){2}c        a,b,c   y       -       -
 ^([^,]*,){2}c  a,b,c   y       $1      b,
+^([^,]*,){3}d  aaa,b,c,d       y       $1      c,
+^([^,]*,){3,}d aaa,b,c,d       y       $1      c,
+^([^,]*,){0,3}d        aaa,b,c,d       y       $1      c,
+^([^,]{1,3},){3}d      aaa,b,c,d       y       $1      c,
+^([^,]{1,3},){3,}d     aaa,b,c,d       y       $1      c,
+^([^,]{1,3},){0,3}d    aaa,b,c,d       y       $1      c,
+^([^,]{1,},){3}d       aaa,b,c,d       y       $1      c,
+^([^,]{1,},){3,}d      aaa,b,c,d       y       $1      c,
+^([^,]{1,},){0,3}d     aaa,b,c,d       y       $1      c,
+^([^,]{0,3},){3}d      aaa,b,c,d       y       $1      c,
+^([^,]{0,3},){3,}d     aaa,b,c,d       y       $1      c,
+^([^,]{0,3},){0,3}d    aaa,b,c,d       y       $1      c,
 (?i)           y       -       -
 '(?!\A)x'm     a\nxb\n y       -       -
 ^(a(b)?)+$     aba     y       -$1-$2- -a--
 ^(aa(bb)?)+$   aabbaa  y       -$1-$2- -aa--
+'^.{9}abc.*\n'm        123\nabcabcabcabc\n     y       -       -
 ^(a)?a$        a       y       -$1-    --
 ^(a)?(?(1)a|b)+$       a       n       -       -
index c484355..8bb7536 100755 (executable)
@@ -76,6 +76,20 @@ for ($i = 1; @tests; $i++) {
 # number of elements.  Even so, subterfuge is sometimes required: see
 # tests for %n and %p.
 #
+# The following tests are not currently run, for the reasons stated:
+
+=pod
+
+=begin problematic
+
+>%.0f<      >-0.1<        >-0<  >C library bug: no minus on VMS, HP-UX<
+>%.0f<      >1.5<         >2<   >Standard vague: no rounding rules<
+>%.0f<      >2.5<         >2<   >Standard vague: no rounding rules<
+
+=end problematic
+
+=cut
+
 # template    data          result
 __END__
 >%6. 6s<    >''<          >%6. 6s INVALID< >(See use of $w in code above)<
@@ -176,6 +190,7 @@ __END__
 >%+e<       >-1234.875<   >-1.234875e+03<
 >%#e<       >-1234.875<   >-1.234875e+03<
 >%.0e<      >1234.875<    >1e+03<
+>%#.0e<     >1234.875<    >1.e+03<
 >%.*e<      >[0, 1234.875]< >1e+03<
 >%.1e<      >1234.875<    >1.2e+03<
 >%-12.4e<   >1234.875<    >1.2349e+03  <
@@ -205,13 +220,15 @@ __END__
 >%.0f<      >0<           >0<
 >%.0f<      >2**38<       >274877906944<   >Should have exact int'l rep'n<
 >%.0f<      >0.1<         >0<
->%.0f<      >-0.1<        >-0<
->%.0f<      >0.6<         >1<
->%.0f<      >-0.6<        >-1<
+>%.0f<      >0.6<         >1<              >Known to fail with sfio<
+>%.0f<      >-0.6<        >-1<             >Known to fail with sfio<
+>%.0f<      >1<           >1<
+>%#.0f<     >1<           >1.<
 >%g<        >12345.6789<  >12345.7<
 >%+g<       >12345.6789<  >+12345.7<
 >%#g<       >12345.6789<  >12345.7<
 >%.0g<      >12345.6789<  >1e+04<
+>%#.0g<     >12345.6789<  >1.e+04<
 >%.2g<      >12345.6789<  >1.2e+04<
 >%.*g<      >[2, 12345.6789]< >1.2e+04<
 >%.9g<      >12345.6789<  >12345.6789<
index af4920c..353b3b3 100755 (executable)
@@ -80,6 +80,7 @@ else {
     print "not ok 4\n";
     print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n";
     print "#4 of some sort.  Building in /tmp sometimes has this problem.\n";
+    print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n";
 }
 print "#4      :$mtime: should != :$ctime:\n";
 
index 100dcfe..890a859 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
-print "1..15\n";
+print "1..19\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -108,3 +108,21 @@ $y = $x =~ tr/\x{190}/\x{190}/;
 print "not " if $y != 0;
 print "ok 15\n";
 }
+
+# 16: test cannot update if read-only
+eval '$1 =~ tr/x/y/';
+print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
+       "ok 16\n");
+
+# 17: test can count read-only
+'abcdef' =~ /(bcd)/;
+print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 17\n");
+
+# 18: test lhs OK if not updating
+print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 18\n");
+
+# 19: test lhs bad if updating
+eval '"123" =~ tr/1/1/';
+print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
+       ? '' : 'not ', "ok 19\n");
+
index 8db3d1a..d1546fe 100755 (executable)
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..65\n";
+print "1..66\n";
 
 my $test = 1;
 
@@ -289,3 +289,9 @@ sub ok_bytes {
     ok "\x{ab}" =~ /^\x{ab}$/, 1;
     $test++;                                   # 65
 }
+
+{
+    use utf8;
+    ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2);
+    $test++;                # 66
+}
index 56e3fab..b2fa75f 100644 (file)
@@ -9,14 +9,14 @@ $a = 1 if $a EQ $b ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
 Use of EQ is deprecated at - line 5.
-print() on closed filehandle main::STDIN at - line 6.
+print() on closed filehandle STDIN at - line 6.
 ########
 -W
 # lint: check runtime $^W is zapped
 $^W = 0 ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
-print() on closed filehandle main::STDIN at - line 4.
+print() on closed filehandle STDIN at - line 4.
 ########
 -W
 # lint: check runtime $^W is zapped
@@ -25,7 +25,7 @@ print() on closed filehandle main::STDIN at - line 4.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -W
 # lint: check "no warnings" is zapped
@@ -35,7 +35,7 @@ $a = 1 if $a EQ $b ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
 Use of EQ is deprecated at - line 5.
-print() on closed filehandle main::STDIN at - line 6.
+print() on closed filehandle STDIN at - line 6.
 ########
 -W
 # lint: check "no warnings" is zapped
@@ -44,7 +44,7 @@ print() on closed filehandle main::STDIN at - line 6.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -Ww
 # lint: check combination of -w and -W
@@ -53,7 +53,7 @@ print() on closed filehandle main::STDIN at - line 5.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -W
 --FILE-- abc.pm
index bd40972..2a357e2 100644 (file)
   warn(warn_nl, "open");               [Perl_do_open9]
     open(F, "true\ncd")
 
-  Close on unopened file <%s>          [Perl_do_close] <<TODO
+  close() on unopened filehandle %s    [Perl_do_close]
     $a = "fred";close("$a")
 
-  tell() on unopened file              [Perl_do_tell]
+  tell() on closed filehandle          [Perl_do_tell]
     $a = "fred";$a = tell($a)
 
-  seek() on unopened file              [Perl_do_seek]
+  seek() on closed filehandle          [Perl_do_seek]
     $a = "fred";$a = seek($a,1,1)
 
-  sysseek() on unopened file           [Perl_do_sysseek]
+  sysseek() on closed filehandle       [Perl_do_sysseek]
     $a = "fred";$a = seek($a,1,1)
 
   warn(warn_uninit);                   [Perl_do_print]
     print $a ;
 
-  Stat on unopened file <%s>           [Perl_my_stat]
+  -x on closed filehandle %s           [Perl_my_stat]
     close STDIN ; -x STDIN ;
 
   warn(warn_nl, "stat");               [Perl_my_stat]
@@ -96,7 +96,7 @@ close "fred" ;
 no warnings 'unopened' ;
 close "joe" ;
 EXPECT
-Close on unopened file <fred> at - line 3.
+close() on unopened filehandle fred at - line 3.
 ########
 # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat]
 use warnings 'io' ;
@@ -105,17 +105,35 @@ tell(STDIN);
 $a = seek(STDIN,1,1);
 $a = sysseek(STDIN,1,1);
 -x STDIN ;
+stat(STDIN) ;
+$a = "fred";
+tell($a);
+seek($a,1,1);
+sysseek($a,1,1);
+-x $a; # ok
+stat($a); # ok
 no warnings 'io' ;
 close STDIN ;
 tell(STDIN);
 $a = seek(STDIN,1,1);
 $a = sysseek(STDIN,1,1);
 -x STDIN ;
+stat(STDIN) ;
+$a = "fred";
+tell($a);
+seek($a,1,1);
+sysseek($a,1,1);
+-x $a;
+stat($a);
 EXPECT
-tell() on unopened file at - line 4.
-seek() on unopened file at - line 5.
-sysseek() on unopened file at - line 6.
-Stat on unopened file <STDIN> at - line 7.
+tell() on closed filehandle STDIN at - line 4.
+seek() on closed filehandle STDIN at - line 5.
+sysseek() on closed filehandle STDIN at - line 6.
+-x on closed filehandle STDIN at - line 7.
+stat() on closed filehandle STDIN at - line 8.
+tell() on unopened filehandle at - line 10.
+seek() on unopened filehandle at - line 11.
+sysseek() on unopened filehandle at - line 12.
 ########
 # doio.c [Perl_do_print]
 use warnings 'uninitialized' ;
@@ -188,4 +206,4 @@ my $a = eof STDOUT ;
 no warnings 'io' ;
 $a = eof STDOUT ;
 EXPECT
-Filehandle main::STDOUT opened only for output at - line 3.
+Filehandle STDOUT opened only for output at - line 3.
index 2759057..3c3cc60 100644 (file)
@@ -1,6 +1,6 @@
   pp_hot.c     
 
-  Filehandle %s never opened                   [pp_print]
+  print() on unopened filehandle abc           [pp_print]
     $f = $a = "abc" ; print $f $a
 
   Filehandle %s opened only for input          [pp_print]
@@ -52,7 +52,7 @@ print $f $a;
 no warnings 'unopened' ;
 print $f $a;
 EXPECT
-Filehandle main::abc never opened at - line 4.
+print() on unopened filehandle abc at - line 4.
 ########
 # pp_hot.c [pp_print]
 use warnings 'io' ;
@@ -71,12 +71,12 @@ print getc(FOO);
 no warnings 'io' ;
 print STDIN "anc";
 EXPECT
-Filehandle main::STDIN opened only for input at - line 3.
-Filehandle main::STDOUT opened only for output at - line 4.
-Filehandle main::STDERR opened only for output at - line 5.
-Filehandle main::FOO opened only for output at - line 6.
-Filehandle main::STDERR opened only for output at - line 7.
-Filehandle main::FOO opened only for output at - line 8.
+Filehandle STDIN opened only for input at - line 3.
+Filehandle STDOUT opened only for output at - line 4.
+Filehandle STDERR opened only for output at - line 5.
+Filehandle FOO opened only for output at - line 6.
+Filehandle STDERR opened only for output at - line 7.
+Filehandle FOO opened only for output at - line 8.
 ########
 # pp_hot.c [pp_print]
 use warnings 'closed' ;
@@ -90,9 +90,9 @@ print STDIN "anc";
 opendir STDIN, ".";
 print STDIN "anc";
 EXPECT
-print() on closed filehandle main::STDIN at - line 4.
-print() on closed filehandle main::STDIN at - line 6.
-       (Are you trying to call print() on dirhandle main::STDIN?)
+print() on closed filehandle STDIN at - line 4.
+print() on closed filehandle STDIN at - line 6.
+       (Are you trying to call print() on dirhandle STDIN?)
 ########
 # pp_hot.c [pp_rv2av]
 use warnings 'uninitialized' ;
@@ -137,9 +137,9 @@ no warnings 'closed' ;
 opendir STDIN, "." ; $a = <STDIN> ;
 $a = <STDIN> ;
 EXPECT
-readline() on closed filehandle main::STDIN at - line 3.
-readline() on closed filehandle main::STDIN at - line 4.
-       (Are you trying to call readline() on dirhandle main::STDIN?)
+readline() on closed filehandle STDIN at - line 3.
+readline() on closed filehandle STDIN at - line 4.
+       (Are you trying to call readline() on dirhandle STDIN?)
 ########
 # pp_hot.c [Perl_do_readline]
 use warnings 'io' ;
@@ -150,7 +150,7 @@ no warnings 'io' ;
 $a = <FH> ;
 unlink $file ;
 EXPECT
-Filehandle main::FH opened only for output at - line 5.
+Filehandle FH opened only for output at - line 5.
 ########
 # pp_hot.c [Perl_sub_crush_depth]
 use warnings 'recursion' ;
index 7c38727..79b5e48 100644 (file)
@@ -16,7 +16,7 @@
 
   page overflow                                        [pp_leavewrite]
 
-  Filehandle %s never opened                   [pp_prtf]
+  printf() on unopened filehandle abc          [pp_prtf]
     $a = "abc"; printf $a "fred"
 
   Filehandle %s opened only for input          [pp_prtf]
     getpeername STDIN;
 
   flock() on closed socket %s                  [pp_flock]
+  flock() on closed socket                     [pp_flock]
     close STDIN;
     flock STDIN, 8;
+    flock $a, 8;
 
   warn(warn_nl, "stat");                       [pp_stat]
 
-  Test on unopened file <%s>
-       close STDIN ; -T STDIN ;
+  -T on closed filehandle %s
+  stat() on closed filehandle %s
+       close STDIN ; -T STDIN ; stat(STDIN) ;
 
   warn(warn_nl, "open");                       [pp_fttext]
     -T "abc\ndef" ;
@@ -107,7 +110,7 @@ write STDIN;
 no warnings 'io' ;
 write STDIN;
 EXPECT
-Filehandle main::STDIN opened only for input at - line 5.
+Filehandle STDIN opened only for input at - line 5.
 ########
 # pp_sys.c [pp_leavewrite]
 use warnings 'closed' ;
@@ -123,9 +126,9 @@ write STDIN;
 opendir STDIN, ".";
 write STDIN;
 EXPECT
-write() on closed filehandle main::STDIN at - line 6.
-write() on closed filehandle main::STDIN at - line 8.
-       (Are you trying to call write() on dirhandle main::STDIN?)
+write() on closed filehandle STDIN at - line 6.
+write() on closed filehandle STDIN at - line 8.
+       (Are you trying to call write() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_leavewrite]
 use warnings 'io' ;
@@ -152,7 +155,7 @@ printf $a "fred";
 no warnings 'unopened' ;
 printf $a "fred";
 EXPECT
-Filehandle main::abc never opened at - line 4.
+printf() on unopened filehandle abc at - line 4.
 ########
 # pp_sys.c [pp_prtf]
 use warnings 'closed' ;
@@ -166,9 +169,9 @@ printf STDIN "fred";
 opendir STDIN, ".";
 printf STDIN "fred";
 EXPECT
-printf() on closed filehandle main::STDIN at - line 4.
-printf() on closed filehandle main::STDIN at - line 6.
-       (Are you trying to call printf() on dirhandle main::STDIN?)
+printf() on closed filehandle STDIN at - line 4.
+printf() on closed filehandle STDIN at - line 6.
+       (Are you trying to call printf() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_prtf]
 use warnings 'io' ;
@@ -176,7 +179,7 @@ printf STDIN "fred";
 no warnings 'io' ;
 printf STDIN "fred";
 EXPECT
-Filehandle main::STDIN opened only for input at - line 3.
+Filehandle STDIN opened only for input at - line 3.
 ########
 # pp_sys.c [pp_send]
 use warnings 'closed' ;
@@ -190,9 +193,9 @@ syswrite STDIN, "fred", 1;
 opendir STDIN, ".";
 syswrite STDIN, "fred", 1;
 EXPECT
-syswrite() on closed filehandle main::STDIN at - line 4.
-syswrite() on closed filehandle main::STDIN at - line 6.
-       (Are you trying to call syswrite() on dirhandle main::STDIN?)
+syswrite() on closed filehandle STDIN at - line 4.
+syswrite() on closed filehandle STDIN at - line 6.
+       (Are you trying to call syswrite() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_flock]
 use Config; 
@@ -205,19 +208,25 @@ EOM
     exit ;
   } 
 }
-use warnings 'closed' ;
+use warnings qw(unopened closed);
 close STDIN;
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
-no warnings 'closed' ;
+flock FOO, 8;
+flock $a, 8;
+no warnings qw(unopened closed);
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
+flock FOO, 8;
+flock $a, 8;
 EXPECT
-flock() on closed filehandle main::STDIN at - line 14.
-flock() on closed filehandle main::STDIN at - line 16.
-       (Are you trying to call flock() on dirhandle main::STDIN?)
+flock() on closed filehandle STDIN at - line 14.
+flock() on closed filehandle STDIN at - line 16.
+       (Are you trying to call flock() on dirhandle STDIN?)
+flock() on unopened filehandle FOO at - line 17.
+flock() on unopened filehandle at - line 18.
 ########
 # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername]
 use warnings 'io' ;
@@ -285,36 +294,36 @@ getsockopt STDIN, 1,2;
 getsockname STDIN;
 getpeername STDIN;
 EXPECT
-send() on closed socket main::STDIN at - line 22.
-bind() on closed socket main::STDIN at - line 23.
-connect() on closed socket main::STDIN at - line 24.
-listen() on closed socket main::STDIN at - line 25.
-accept() on closed socket main::STDIN at - line 26.
-shutdown() on closed socket main::STDIN at - line 27.
-setsockopt() on closed socket main::STDIN at - line 28.
-getsockopt() on closed socket main::STDIN at - line 29.
-getsockname() on closed socket main::STDIN at - line 30.
-getpeername() on closed socket main::STDIN at - line 31.
-send() on closed socket main::STDIN at - line 33.
-       (Are you trying to call send() on dirhandle main::STDIN?)
-bind() on closed socket main::STDIN at - line 34.
-       (Are you trying to call bind() on dirhandle main::STDIN?)
-connect() on closed socket main::STDIN at - line 35.
-       (Are you trying to call connect() on dirhandle main::STDIN?)
-listen() on closed socket main::STDIN at - line 36.
-       (Are you trying to call listen() on dirhandle main::STDIN?)
-accept() on closed socket main::STDIN at - line 37.
-       (Are you trying to call accept() on dirhandle main::STDIN?)
-shutdown() on closed socket main::STDIN at - line 38.
-       (Are you trying to call shutdown() on dirhandle main::STDIN?)
-setsockopt() on closed socket main::STDIN at - line 39.
-       (Are you trying to call setsockopt() on dirhandle main::STDIN?)
-getsockopt() on closed socket main::STDIN at - line 40.
-       (Are you trying to call getsockopt() on dirhandle main::STDIN?)
-getsockname() on closed socket main::STDIN at - line 41.
-       (Are you trying to call getsockname() on dirhandle main::STDIN?)
-getpeername() on closed socket main::STDIN at - line 42.
-       (Are you trying to call getpeername() on dirhandle main::STDIN?)
+send() on closed socket STDIN at - line 22.
+bind() on closed socket STDIN at - line 23.
+connect() on closed socket STDIN at - line 24.
+listen() on closed socket STDIN at - line 25.
+accept() on closed socket STDIN at - line 26.
+shutdown() on closed socket STDIN at - line 27.
+setsockopt() on closed socket STDIN at - line 28.
+getsockopt() on closed socket STDIN at - line 29.
+getsockname() on closed socket STDIN at - line 30.
+getpeername() on closed socket STDIN at - line 31.
+send() on closed socket STDIN at - line 33.
+       (Are you trying to call send() on dirhandle STDIN?)
+bind() on closed socket STDIN at - line 34.
+       (Are you trying to call bind() on dirhandle STDIN?)
+connect() on closed socket STDIN at - line 35.
+       (Are you trying to call connect() on dirhandle STDIN?)
+listen() on closed socket STDIN at - line 36.
+       (Are you trying to call listen() on dirhandle STDIN?)
+accept() on closed socket STDIN at - line 37.
+       (Are you trying to call accept() on dirhandle STDIN?)
+shutdown() on closed socket STDIN at - line 38.
+       (Are you trying to call shutdown() on dirhandle STDIN?)
+setsockopt() on closed socket STDIN at - line 39.
+       (Are you trying to call setsockopt() on dirhandle STDIN?)
+getsockopt() on closed socket STDIN at - line 40.
+       (Are you trying to call getsockopt() on dirhandle STDIN?)
+getsockname() on closed socket STDIN at - line 41.
+       (Are you trying to call getsockname() on dirhandle STDIN?)
+getpeername() on closed socket STDIN at - line 42.
+       (Are you trying to call getpeername() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_stat]
 use warnings 'newline' ;
@@ -325,13 +334,22 @@ EXPECT
 Unsuccessful stat on filename containing newline at - line 3.
 ########
 # pp_sys.c [pp_fttext]
-use warnings 'unopened' ;
+use warnings qw(unopened closed) ;
 close STDIN ; 
 -T STDIN ;
-no warnings 'unopened' ;
+stat(STDIN) ;
+-T HOCUS;
+stat(POCUS);
+no warnings qw(unopened closed) ;
 -T STDIN ;
+stat(STDIN);
+-T HOCUS;
+stat(POCUS);
 EXPECT
-Test on unopened file <STDIN> at - line 4.
+-T on closed filehandle STDIN at - line 4.
+stat() on closed filehandle STDIN at - line 5.
+-T on unopened filehandle HOCUS at - line 6.
+stat() on unopened filehandle POCUS at - line 7.
 ########
 # pp_sys.c [pp_fttext]
 use warnings 'newline' ;
@@ -351,4 +369,4 @@ my $a = sysread(F, $a,10) ;
 close F ;
 unlink $file ;
 EXPECT
-Filehandle main::F opened only for output at - line 5.
+Filehandle F opened only for output at - line 5.
diff --git a/toke.c b/toke.c
index cb9976c..3fb35c3 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2468,7 +2468,8 @@ Perl_yylex(pTHX)
        do {
            bool bof;
            bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
-           if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+           s = filter_gets(PL_linestr, PL_rsfp, 0);
+           if (s == Nullch) {
              fake_eof:
                if (PL_rsfp) {
                    if (PL_preprocess && !PL_in_eval)
@@ -2491,6 +2492,9 @@ Perl_yylex(pTHX)
                PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
                sv_setpv(PL_linestr,"");
                TOKEN(';');     /* not infinite loop because rsfp is NULL now */
+           } else if (bof) {
+               PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+               s = swallow_bom((U8*)s);
            }
            if (PL_doextract) {
                if (*s == '#' && s[1] == '!' && instr(s,"perl"))
@@ -2504,14 +2508,6 @@ Perl_yylex(pTHX)
                    PL_doextract = FALSE;
                }
            } 
-           if (bof)
-           {
-               PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
-               /* Shouldn't this swallow_bom() be earlier, e.g.
-                * immediately after where bof is set?  Currently you can't
-                * have e.g. a UTF16 sharpbang line. --Mike Guy */
-               s = swallow_bom((U8*)s);
-           }
            incline(s);
        } while (PL_doextract);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -3970,11 +3966,11 @@ Perl_yylex(pTHX)
                /* Mark this internal pseudo-handle as clean */
                IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
                if (PL_preprocess)
-                   IoTYPE(GvIOp(gv)) = '|';
+                   IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
                else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
-                   IoTYPE(GvIOp(gv)) = '-';
+                   IoTYPE(GvIOp(gv)) = IoTYPE_STD;
                else
-                   IoTYPE(GvIOp(gv)) = '<';
+                   IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
                /* if the script was opened in binmode, we need to revert
                 * it to text mode for compatibility; but only iff it has CRs
@@ -3983,7 +3979,7 @@ Perl_yylex(pTHX)
                    && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
                {
                    Off_t loc = 0;
-                   if (IoTYPE(GvIOp(gv)) == '<') {
+                   if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
                        loc = PerlIO_tell(PL_rsfp);
                        (void)PerlIO_seek(PL_rsfp, 0L, 0);
                    }
@@ -7376,26 +7372,31 @@ STATIC char*
 S_swallow_bom(pTHX_ U8 *s)
 {
     STRLEN slen;
-    U8 *olds = s;
     slen = SvCUR(PL_linestr);
     switch (*s) {
     case 0xFF:       
        if (s[1] == 0xFE) { 
            /* UTF-16 little-endian */
-#ifndef PERL_NO_UTF16_FILTER
-           U8 *news;
-#endif
            if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
                Perl_croak(aTHX_ "Unsupported script encoding");
 #ifndef PERL_NO_UTF16_FILTER
+           DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
            s += 2;
-           filter_add(utf16rev_textfilter, NULL);
-           New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
-           /* See the notes on utf16_to_utf8() in utf8.c --Mike Guy */
-           PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
-                                            PL_bufend - (char*)s);
-           Safefree(olds);
-           s = news;
+           if (PL_bufend > (char*)s) {
+               U8 *news;
+               I32 newlen;
+
+               filter_add(utf16rev_textfilter, NULL);
+               New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+               PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
+                                                PL_bufend - (char*)s - 1,
+                                                &newlen);
+               Copy(news, s, newlen, U8);
+               SvCUR_set(PL_linestr, newlen);
+               PL_bufend = SvPVX(PL_linestr) + newlen;
+               news[newlen++] = '\0';
+               Safefree(news);
+           }
 #else
            Perl_croak(aTHX_ "Unsupported script encoding");
 #endif
@@ -7405,14 +7406,23 @@ S_swallow_bom(pTHX_ U8 *s)
     case 0xFE:
        if (s[1] == 0xFF) {   /* UTF-16 big-endian */
 #ifndef PERL_NO_UTF16_FILTER
-           U8 *news;
-           filter_add(utf16_textfilter, NULL);
-           New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
-           /* See the notes on utf16_to_utf8() in utf8.c --Mike Guy */
-           PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
-                                            PL_bufend - (char*)s);
-           Safefree(olds);
-           s = news;
+           DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
+           s += 2;
+           if (PL_bufend > (char *)s) {
+               U8 *news;
+               I32 newlen;
+
+               filter_add(utf16_textfilter, NULL);
+               New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+               PL_bufend = (char*)utf16_to_utf8(s, news,
+                                                PL_bufend - (char*)s,
+                                                &newlen);
+               Copy(news, s, newlen, U8);
+               SvCUR_set(PL_linestr, newlen);
+               PL_bufend = SvPVX(PL_linestr) + newlen;
+               news[newlen++] = '\0';
+               Safefree(news);
+           }
 #else
            Perl_croak(aTHX_ "Unsupported script encoding");
 #endif
@@ -7421,6 +7431,7 @@ S_swallow_bom(pTHX_ U8 *s)
 
     case 0xEF:
        if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
+           DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
            s += 3;                      /* UTF-8 */
        }
        break;
@@ -7463,8 +7474,13 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
     if (count) {
        U8* tmps;
        U8* tend;
+       I32 newlen;
        New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
-       tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
+       if (!*SvPV_nolen(sv))
+       /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+       return count;
+       
+       tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
        sv_usepvn(sv, (char*)tmps, tend - tmps);
     }
     return count;
@@ -7477,8 +7493,13 @@ utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
     if (count) {
        U8* tmps;
        U8* tend;
+       I32 newlen;
+       if (!*SvPV_nolen(sv))
+       /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+       return count;
+
        New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
-       tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
+       tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
        sv_usepvn(sv, (char*)tmps, tend - tmps);
     }
     return count;
diff --git a/utf8.c b/utf8.c
index a24d392..65dd2e4 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -321,26 +321,25 @@ Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
 }
 
 /*
- * Convert native or reversed UTF-16 to UTF-8.
+ * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
  *
  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
  * We optimize for native, for obvious reasons. */
 
-/* There are several problems with utf16_to_utf8().
- * (1) U16 is not necessarily *exactly* two bytes.
- * (2) Secondly, no check is made for odd length.
- * (3) Thirdly, the "Malformed UTF-16 surrogate" should probably be
- *     a hard error (and it should be listed in perldiag).
- * (4) The tests (in comp/t/require.t) are a joke: the UTF16 BOM
- *     really ought to be followed by valid UTF16 characters.
- * See swallow_bom() in toke.c.
- * --Mike Guy */
 U8*
-Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
+Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 {
-    U16* pend = p + bytelen / 2;
+    U8* pend;
+    U8* dstart = d;
+
+    if (bytelen & 1)
+       Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
+
+    pend = p + bytelen;
+
     while (p < pend) {
-       UV uv = *p++;
+       UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
+       p += 2;
        if (uv < 0x80) {
            *d++ = uv;
            continue;
@@ -352,13 +351,9 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
        }
        if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
             dTHR;
-           int low = *p++;
-           if (low < 0xdc00 || low >= 0xdfff) {
-               if (ckWARN_d(WARN_UTF8))     
-                   Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-16 surrogate");
-               p--;
-               uv = 0xfffd;
-           }
+           UV low = *p++;
+           if (low < 0xdc00 || low >= 0xdfff)
+               Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
            uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
        }
        if (uv < 0x10000) {
@@ -375,13 +370,14 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
            continue;
        }
     }
+    *newlen = d - dstart;
     return d;
 }
 
 /* Note: this one is slightly destructive of the source. */
 
 U8*
-Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
+Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 {
     U8* s = (U8*)p;
     U8* send = s + bytelen;
@@ -391,7 +387,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
        s[1] = tmp;
        s += 2;
     }
-    return utf16_to_utf8(p, d, bytelen);
+    return utf16_to_utf8(p, d, bytelen, newlen);
 }
 
 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
diff --git a/util.c b/util.c
index dcf6ea4..4ea7f5d 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3878,21 +3878,48 @@ Perl_my_atof(pTHX_ const char* s)
 }
 
 void
-Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
+Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
 {
-    SV *sv;
-    char *name;
-
-    assert(gv);
+    char *vile;
+    I32   warn;
+    char *func =
+       op == OP_READLINE   ? "readline"  :
+       op == OP_LEAVEWRITE ? "write" :
+       PL_op_desc[op];
+    char *pars = OP_IS_FILETEST(op) ? "" : "()";
+    char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                     "socket" : "filehandle";
+    char *name = NULL;
 
-    sv = sv_newmortal();
-    gv_efullname3(sv, gv, Nullch);
-    name = SvPVX(sv);
+    if (isGV(gv)) {
+       SV *sv = sv_newmortal();
+       gv_efullname4(sv, gv, Nullch, FALSE);
+       name = SvPVX(sv);
+    }
 
-    Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn = WARN_CLOSED;
+    }
+    else {
+       vile = "unopened";
+       warn = WARN_UNOPENED;
+    }
 
-    if (io && IoDIRP(io))
-       Perl_warner(aTHX_ WARN_CLOSED,
-                   "\t(Are you trying to call %s() on dirhandle %s?)\n",
-                   func, name);
+    if (name && *name) {
+       Perl_warner(aTHX_ warn,
+                   "%s%s on %s %s %s", func, pars, vile, type, name);
+       if (io && IoDIRP(io))
+           Perl_warner(aTHX_ warn,
+                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                       func, pars, name);
+    }
+    else {
+       Perl_warner(aTHX_ warn,
+                   "%s%s on %s %s", func, pars, vile, type);
+       if (io && IoDIRP(io))
+           Perl_warner(aTHX_ warn,
+                       "\t(Are you trying to call %s%s on dirhandle?)\n",
+                       func, pars);
+    }
 }
index f0636f6..0215c8d 100644 (file)
@@ -31,836 +31,443 @@ print OUT <<"!GROK!THIS!";
 $Config{startperl}
     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
     if \$running_under_some_shell;
+--\$running_under_some_shell;
 !GROK!THIS!
  
 # In the following, perl variables are not expanded during extraction.
  
 print OUT <<'!NO!SUBS!';
 
-use Config;
+# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 
+# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
+# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
+
 use strict;
-use FileHandle;
-use File::Basename qw(&basename &dirname);
-use Cwd;
+use warnings;
+use v5.6.0;
 
-use Getopt::Long;
+use Config;
+use Fcntl qw(:DEFAULT :flock);
+use File::Temp qw(tempfile);
+use Cwd;
+our $VERSION = 2.02;
+$| = 1;
 
-$Getopt::Long::bundling_override = 1;
-$Getopt::Long::passthrough = 0;
-$Getopt::Long::ignore_case = 0;
+use subs qw{
+    cc_harness check_read check_write checkopts_byte choose_backend
+    compile_byte compile_cstyle compile_module generate_code
+    grab_stash parse_argv sanity_check vprint yclept spawnit
+};
+sub opt(*); # imal quoting
 
-my $pathsep = ($Config{'osname'} eq 'MSWin32')? "\\" : "/"; # MAJOR HACK. SHOULD
-                                                            # BE IN Config.pm
+our ($Options, $BinPerl, $Backend);
+our ($Input => $Output);
 
-my $options = {};
-my $_fh;
-unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
+# eval { main(); 1 } or die;
 
 main();
 
-sub main
-{
-
-    GetOptions
-            (
-            $options,   "L:s",
-                        "I:s",
-                        "C:s",
-                        "o:s",
-                        "e:s",
-                        "regex:s",
-                        "verbose:s",
-                        "log:s",
-                        "argv:s",
-                        "b",
-                        "opt",
-                        "gen",
-                        "sav",
-                        "run",
-                        "prog",
-                        "mod"
-            );
-
-
-    my $key;
-
-    local($") = "|";
-
-    _usage() if (!_checkopts());
-    push(@ARGV, _maketempfile()) if ($options->{'e'});
-
-    _usage() if (!@ARGV);
-                
-    my $file;
-    foreach $file (@ARGV)
-    {
-        _print("
---------------------------------------------------------------------------------
-Compiling $file:
---------------------------------------------------------------------------------
-", 36 );
-        _doit($file);
-    }
+sub main { 
+    parse_argv();
+    check_write($Output);
+    choose_backend();
+    generate_code();
+    die "XXX: Not reached?";
+    exit(0);
 }
-        
-sub _doit
-{
-    my ($file) = @_;
-
-    my ($program_ext, $module_ext) = _getRegexps();
-    my ($obj, $objfile, $so, $type, $backend, $gentype);
-
-    $backend = $options->{'b'} ? 'Bytecode' : $options->{'opt'} ? 'CC' : 'C';
 
-    $gentype = $options->{'b'} ? 'Bytecode' : 'C';
+#######################################################################
 
-    if  (
-            (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext"))
-            || (defined($options->{'prog'}) || defined($options->{'run'}))
-        )
-    {
-        $type = 'program';
-
-        if ($options->{'b'})
-        {
-            $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c";
-        }
-        else
-        {
-            $objfile = $options->{'C'} ? $options->{'C'} : "$file.c";
-            $obj = $options->{'o'} ? $options->{'o'}
-                                   : _getExecutable( $file,$program_ext);
-        }
-
-        return() if (!$obj);
-
-    }
-    elsif (($file =~ m"@$module_ext") || ($options->{'mod'}))
-    {
-        $type = 'module';
-
-        if ($options->{'b'})
-        {
-            $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c";
-        }
-        else
-        {
-            die "Shared objects are not supported on Win32 yet!!!!\n"
-                                          if ($Config{'osname'} eq 'MSWin32');
-
-            $objfile = $options->{'C'} ? $options->{'C'} : "$file.c";
-            $obj = $options->{'o'} ? $options->{'o'}
-                                   : _getExecutable($file, $module_ext);
-            $so = "$obj.$Config{so}";
-        }
-
-        return() if (!$obj);
+sub choose_backend {
+    # Choose the backend.
+    $Backend = 'C';
+    if (opt(B)) {
+        checkopts_byte();
+        $Backend = 'Bytecode';
     }
-    else
-    {
-        _error("noextension", $file, $program_ext, $module_ext);
-        return();
+    if (opt(S) && opt(c)) {
+        # die "$0: Do you want me to compile this or not?\n";
+        delete $Options->{S};
     }
-
-    if ($type eq 'program')
-    {
-        _print("Making $gentype($objfile) for $file!\n", 36 );
-
-        my $errcode = _createCode($backend, $objfile, $file);
-        (_print( "ERROR: In generating code for $file!\n", -1), return()) 
-                                                                if ($errcode);
-
-        _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'} &&
-                                                          !$options->{'b'});
-        $errcode = _compileCode($file, $objfile, $obj) 
-                                            if (!$options->{'gen'} &&
-                                                !$options->{'b'});
-
-        if ($errcode)
-               {
-                       _print( "ERROR: In compiling code for $objfile !\n", -1);
-                       my $ofile = File::Basename::basename($objfile);
-                       $ofile =~ s"\.c$"\.o"s;
-                       
-                       _removeCode("$ofile"); 
-                       return()
-               }
-    
-        _runCode($objfile) if ($options->{'run'} && $options->{'b'});
-        _runCode($obj) if ($options->{'run'} && !$options->{'b'});
-
-        _removeCode($objfile) if (($options->{'b'} &&
-                                   ($options->{'e'} && !$options->{'o'})) ||
-                                  (!$options->{'b'} &&
-                                   (!$options->{'sav'} || 
-                                    ($options->{'e'} && !$options->{'C'}))));
-
-        _removeCode($file) if ($options->{'e'}); 
-
-        _removeCode($obj) if (!$options->{'b'} &&
-                              (($options->{'e'} &&
-                               !$options->{'sav'} && !$options->{'o'}) ||
-                              ($options->{'run'} && !$options->{'sav'})));
-    }
-    else
-    {
-        _print( "Making $gentype($objfile) for $file!\n", 36 );
-        my $errcode = _createCode($backend, $objfile, $file, $obj);
-        (_print( "ERROR: In generating code for $file!\n", -1), return()) 
-                                                                if ($errcode);
-    
-        _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'} &&
-                                                          !$options->{'b'});
-
-        $errcode = 
-            _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'} &&
-                                                          !$options->{'b'});
-
-        (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) 
-                                                                if ($errcode);
-    }
-}
-
-sub _getExecutable
-{
-    my ($sourceprog, $ext) = @_;
-    my ($obj);
-
-    if (defined($options->{'regex'}))
-    {
-        eval("(\$obj = \$sourceprog) =~ $options->{'regex'}");
-        return(0) if (_error('badeval', $@));
-        return(0) if (_error('equal', $obj, $sourceprog));
-    }
-    elsif (defined ($options->{'ext'}))
-    {
-        ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g;        
-        return(0) if (_error('equal', $obj, $sourceprog));
-    }
-    elsif (defined ($options->{'run'}))
-    {
-           $obj = "perlc$$";
-    }
-    else
-    {
-        ($obj = $sourceprog) =~ s"@$ext""g;
-        return(0) if (_error('equal', $obj, $sourceprog));
-    }
-    return($obj);
+    $Backend = 'CC' if opt(O);
 }
 
-sub _createCode
-{
-    my ( $backend, $generated_file, $file, $final_output ) = @_;
-    my $return;
-    my $output_switch = "o";
-    my $max_line_len = '';
-
-    local($") = " -I";
 
-    if ($^O eq 'MSWin32' && $backend =~ /^CC?$/ && $Config{cc} =~ /^cl/i) {
-       $max_line_len = '-l2000,';
-    }
-
-    if ($backend eq "Bytecode")
-    {
-        require ByteLoader;
-
-       open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!";
-       binmode GENFILE;
-        print GENFILE "#!$^X\n" if @_ == 3;
-        print GENFILE "use ByteLoader $ByteLoader::VERSION;\n";
-       close(GENFILE);
+sub generate_code { 
 
-       $output_switch ="a";
-    }
+    vprint 0, "Compiling $Input";
 
-    if (@_ == 3)                                   # compiling a program   
-    {
-        chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode";
-       my $null=File::Spec->devnull;
-        _print( "$^X -I@INC -MB::Stash -c  $file\n", 36);
-        my @stash=`$^X -I@INC -MB::Stash -c  $file 2>$null`;
-       my $stash=$stash[-1];
-        chomp $stash;
-
-        _print( "$^X -I@INC -MO=$backend,$max_line_len$stash $file\n", 36);
-        $return =  _run("$^X -I@INC -MO=$backend,$max_line_len$stash,-$output_switch$generated_file $file", 9);
-        $return;
-    }
-    else                                           # compiling a shared object
-    {            
-        _print( 
-            "$^X -I@INC -MO=$backend,$max_line_len-m$final_output $file\n", 36);
-        $return = 
-        _run("$^X -I@INC -MO=$backend,$max_line_len-m$final_output,-$output_switch$generated_file $file  ", 9);
-        $return;
-    }
-}
+    $BinPerl  = yclept();  # Calling convention for perl.
 
-sub _compileCode
-{
-    my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_;
-    my @return;
-
-    if (@_ == 3)                            # just compiling a program 
-    {
-        $return[0] = 
-        _ccharness('static', $sourceprog, "-o", $output_executable,
-                  $generated_cfile);  
-        $return[0];
-    }
-    else
-    {
-        my $object_file = $generated_cfile;
-        $object_file =~ s"\.c$"$Config{_o}";   
-
-        $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile);
-        $return[1] = _ccharness
-                            (
-                                'dynamic', 
-                                $sourceprog, "-o", 
-                                $shared_object, $object_file 
-                            );
-        return(1) if (grep ($_, @return));
-        return(0);
+    if (opt(shared)) {
+        compile_module();
+    } else {
+        if ($Backend eq 'Bytecode') {
+            compile_byte();
+        } else {
+            compile_cstyle();
+        }
     }
-}
 
-sub _runCode
-{
-    my ($executable) = @_;
-    _print("$executable $options->{'argv'}\n", 36);
-    _run("$executable $options->{'argv'}", -1 );
 }
 
-sub _removeCode
-{
-    my ($file) = @_;
-    unlink($file) if (-e $file);
-}
-
-sub _ccharness
-{
-    my $type = shift;
-    my (@args) = @_;
-    local($") = " ";
-
-    my $sourceprog = shift(@args);
-    my ($libdir, $incdir);
-
-    my $L = '-L';
-    $L = '-libpath:' if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i;
-
-    if (-d "$Config{installarchlib}/CORE")
-    {
-        $libdir = "$L$Config{installarchlib}/CORE";
-        $incdir = "-I$Config{installarchlib}/CORE";
-    }
-    else
-    {
-        $libdir = "$L.. $L."; 
-        $incdir = "-I.. -I.";
+# usage: vprint [level] msg args
+sub vprint {
+    my $level;
+    if (@_ == 1) {
+        $level = 1;
+    } elsif ($_[0] =~ /^\d$/) {
+        $level = shift;
+    } else {
+        # well, they forgot to use a number; means >0
+        $level = 0;
+    } 
+    my $msg = "@_";
+    $msg .= "\n" unless substr($msg, -1) eq "\n";
+    print "$0: $msg" if opt(v) > $level;
+} 
+
+sub parse_argv {
+
+    use Getopt::Long; 
+    Getopt::Long::Configure("bundling");
+    Getopt::Long::Configure("no_ignore_case");
+
+    # no difference in exists and defined for %ENV; also, a "0"
+    # argument or a "" would not help cc, so skip
+    unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
+
+    $Options = {};
+    Getopt::Long::GetOptions( $Options,
+        'L:s',          # lib directory
+        'I:s',          # include directories (FOR C, NOT FOR PERL)
+        'o:s',          # Output executable
+        'v+',           # Verbosity level
+        'e:s',          # One-liner
+        'B',            # Byte compiler backend
+        'O',            # Optimised C backend
+        'c',            # Compile only
+        'h',            # Help me
+        'S',            # Dump C files
+        's:s',          # Dirty hack to enable -shared/-static
+        'shared',       # Create a shared library (--shared for compat.)
+    );
+        
+    # This is an attempt to make perlcc's arg. handling look like cc.
+    if ( opt('s') ) {  # must quote: looks like s)foo)bar)!
+        if (opt('s') eq 'hared') {
+            $Options->{shared}++; 
+        } elsif (opt('s') eq 'tatic') {
+            $Options->{static}++; 
+        } else {
+            warn "$0: Unknown option -s", opt('s');
+        }
     }
 
-    $libdir .= " $L$options->{L}" if (defined($options->{L}));
-    $incdir .= " -I$options->{L}" if (defined($options->{L}));
-
-    my $linkargs = '';
-    my $dynaloader = '';
-    my $optimize = '';
-    my $flags = '';
+    $Options->{v} += 0;
 
-    if (!grep(/^-[cS]$/, @args))
-    {
-       my $lperl = $^O eq 'os2' ? '-llibperl' 
-          : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\$Config{libperl}"
-          : '-lperl';
-       ($lperl = $Config{libperl}) =~ s/lib(.*)\Q$Config{_a}\E/-l$1/
-           if($^O eq 'cygwin');
+    helpme() if opt(h); # And exit
 
-       $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'};
+    $Output = opt(o) || 'a.out';
 
-       $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags};
-       $linkargs = "$flags $libdir $lperl @Config{libs}";
-       $linkargs = "/link $linkargs" if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i;
+    if (opt(e)) {
+        warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
+        # We don't use a temporary file here; why bother?
+        # XXX: this is not bullet proof -- spaces or quotes in name!
+        $Input = "-e '".opt(e)."'"; # Quotes eaten by shell
+    } else {
+        $Input = shift @ARGV;  # XXX: more files?
+        die "$0: No input file specified\n" unless $Input;
+        # DWIM modules. This is bad but necessary.
+        $Options->{shared}++ if $Input =~ /\.pm\z/;
+        warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
+        check_read($Input);
+        check_perl($Input);
+        sanity_check();
     }
 
-    my $libs = _getSharedObjects($sourceprog);
-    @$libs = grep { !(/DynaLoader\.a$/ && ($dynaloader = $_)) } @$libs
-       if($^O eq 'cygwin');
-
-    my $args = "@args";
-    if ($^O eq 'MSWin32' && $Config{cc} =~ /^bcc/i) {
-        # BC++ cmd line syntax does not allow space between -[oexz...] and arg
-        $args =~ s/(^|\s+)-([oe])\s+/$1-$2/g;
-    }
+}
 
-    my $ccflags = $Config{ccflags};
-    $ccflags .= ' -DUSEIMPORTLIB' if $^O eq 'cygwin';
-    my $cccmd = "$Config{cc} $ccflags $optimize $incdir "
-               ."$args $dynaloader $linkargs @$libs";
+sub opt(*) {
+    my $opt = shift;
+    return exists($Options->{$opt}) && ($Options->{$opt} || 0);
+} 
 
-    _print ("$cccmd\n", 36);
-    _run("$cccmd", 18 );
+sub compile_module { 
+    die "$0: Compiling to shared libraries is currently disabled\n";
 }
 
-sub _getSharedObjects
-{
-    my ($sourceprog) = @_;
-    my ($tmpfile, $incfile);
-    my (@sharedobjects, @libraries);
-    local($") = " -I";
+sub compile_byte {
+    require ByteLoader;
+    my $stash = grab_stash();
+    my $command = "$BinPerl -MO=Bytecode,$stash $Input";
+    # The -a option means we'd have to close the file and lose the
+    # lock, which would create the tiniest of races. Instead, append
+    # the output ourselves. 
+    vprint 1, "Writing on $Output";
 
-    my ($tmpprog);
-    ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2";
+    my $openflags = O_WRONLY | O_CREAT;
+    $openflags |= O_BINARY if eval { O_BINARY; 1 };
+    $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 };
 
-    my $tempdir= File::Spec->tmpdir;
+    # these dies are not "$0: .... \n" because they "can't happen"
 
-    $tmpfile = "$tempdir/$tmpprog.tst";
-    $incfile = "$tempdir/$tmpprog.val";
+    sysopen(OUT, $Output, $openflags)
+        or die "can't write to $Output: $!";
 
-    my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n";
-    my $fd2 = 
-        new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n";
+    # this is blocking; hold on; why are we doing this??
+    # flock OUT, LOCK_EX or die "can't lock $Output: $!"
+    #    unless eval { O_EXLOCK; 1 };
 
-    print $fd <<"EOF";
-        use FileHandle;
-        my \$fh3  = new FileHandle("> $incfile") 
-                                        || die "Couldn't open $incfile\\n";
+    truncate(OUT, 0)
+        or die "couldn't trunc $Output: $!";
 
-        my \$key;
-        foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; }
-        close(\$fh3);
-        exit();
+    print OUT <<EOF;
+#!$^X
+use ByteLoader $ByteLoader::VERSION;
 EOF
 
-    print $fd (   <$fd2>    );
-    close($fd);
-
-    _print("$^X -I@INC $tmpfile\n", 36);
-    _run("$^X -I@INC $tmpfile", 9 );
-
-    $fd = new FileHandle ("$incfile"); 
-    my @lines = <$fd>;    
-
-    unlink($tmpfile);
-    unlink($incfile);
+    # Now the compile:
+    vprint 1, "Compiling...";
+    vprint 3, "Calling $command";
 
-    my $line;
-    my $autolib;
+       my ($output_r, $error_r) = spawnit($command);
+       my @output = @$output_r;
+       my @error = @$error_r;
 
-    my @return;
-
-    foreach $line (@lines) 
-    {
-        chomp($line);
-
-        my ($modname, $modpath) = split(':', $line);
-        my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)");
-
-        if ($autolib = _lookforAuto($dir, $file)) { push(@return, $autolib); }
+    if (@error && $? != 0) {
+        die "$0: $Input did not compile, which can't happen:\n@error\n";
     }
-    return(\@return);
-}
-
-sub _maketempfile
-{
-    my $return;
 
-#    if ($Config{'osname'} eq 'MSWin32') 
-#            { $return = "C:\\TEMP\\comp$$.p"; }
-#    else
-#            { $return = "/tmp/comp$$.p"; }
+    # Write it and leave.
+    print OUT @output               or die "can't write $Output: $!";
+    close OUT                       or die "can't close $Output: $!";
 
-    $return = "comp$$.p"; 
-
-    my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n";
-    print $fd $options->{'e'};
-    close($fd);
-
-    return($return);
+    # wait, how could it be anything but what you see next?
+    chmod 0777 & ~umask, $Output    or die "can't chmod $Output: $!";
+    exit 0;
 }
-    
-    
-sub _lookforAuto
-{
-    my ($dir, $file) = @_;    
-
-    my ($relabs, $relshared);
-    my ($prefix);
-    my $return;
-    my $sharedextension = $^O =~ /MSWin32|cygwin|os2/i
-                         ? $Config{_a} : ".$Config{so}";
-    ($prefix = $file) =~ s"(.*)\.pm"$1";
 
-    my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s);
-
-    $relshared = "$pathsep$prefix$pathsep$modname$sharedextension";
-    $relabs    = "$pathsep$prefix$pathsep$modname$Config{_a}";
-                                               # HACK . WHY DOES _a HAVE A '.'
-                                               # AND so HAVE NONE??
-
-    my @searchpaths =   map("$_${pathsep}auto", @INC);
+sub compile_cstyle {
+    my $stash = grab_stash();
     
-    my $path;
-    foreach $path (@searchpaths)
-    {
-        if (-e ($return = "$path$relshared")) { return($return); } 
-        if (-e ($return = "$path$relabs"))    { return($return); }
+    # What are we going to call our output C file?
+    my ($cfile,$cfh);
+    my $lose = 0;
+    if (opt(S) || opt(c)) {
+        # We need to keep it.
+        if (opt(e)) {
+            $cfile = "a.out.c";
+        } else {
+            $cfile = $Input;
+            # File off extension if present
+            # hold on: plx is executable; also, careful of ordering!
+            $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
+            $cfile .= ".c";
+            $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
+        }
+        check_write($cfile);
+    } else {
+        # Don't need to keep it, be safe with a tempfile.
+        $lose = 1;
+        ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); 
+        close $cfh; # See comment just below
     }
-   return(undef);
-}
-
-sub _getRegexps    # make the appropriate regexps for making executables, 
-{                  # shared libs
-
-    my ($program_ext, $module_ext) = ([],[]); 
+    vprint 1, "Writing C on $cfile";
 
+    my $max_line_len = '';
+    if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
+        $max_line_len = '-l2000,';
+    }
 
-    @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) :
-                                            ('.p$', '.pl$', '.bat$');
+    # This has to do the write itself, so we can't keep a lock. Life
+    # sucks.
+    my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input";
+    vprint 1, "Compiling...";
+    vprint 1, "Calling $command";
 
+       my ($output_r, $error_r) = spawnit($command);
+       my @output = @$output_r;
+       my @error = @$error_r;
 
-    @$module_ext  = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) :
-                                            ('.pm$');
+    if (@error && $? != 0) {
+        die "$0: $Input did not compile, which can't happen:\n@error\n";
+    }
 
-    _mungeRegexp( $program_ext );
-    _mungeRegexp( $module_ext  );    
+    cc_harness($cfile,$stash) unless opt(c);
 
-    return($program_ext, $module_ext);
+    if ($lose) {
+        vprint 2, "unlinking $cfile";
+        unlink $cfile or die "can't unlink $cfile: $!" if $lose;
+    }
+       exit(0);
 }
 
-sub _mungeRegexp
-{
-    my ($regexp) = @_;
-
-    grep(s:(^|[^\\])\.:$1\x00\\.:g, @$regexp);
-    grep(s:(^|[^\x00])\\\.:$1\.:g,  @$regexp);
-    grep(s:\x00::g,                 @$regexp);
+sub cc_harness {
+       my ($cfile,$stash)=@_;
+       use ExtUtils::Embed ();
+       my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
+       $command .= join " -I", split /\s+/, opt(I);
+       $command .= join " -L", split /\s+/, opt(L);
+       my @mods = split /-?u /, $stash;
+       $command .= ExtUtils::Embed::ldopts("-std", \@mods);
+       vprint 3, "running cc $command";
+       system("cc $command");
 }
 
-sub _error
-{
-    my ($type, @args) = @_;
-
-    if ($type eq 'equal')
-    {
-            
-        if ($args[0] eq $args[1])
-        {
-            _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1);
-            return(1);
+# Where Perl is, and which include path to give it.
+sub yclept {
+    my $command = "$^X ";
+
+    # DWIM the -I to be Perl, not C, include directories.
+    if (opt(I) && $Backend eq "Bytecode") {
+        for (split /\s+/, opt(I)) {
+            if (-d $_) {
+                push @INC, $_;
+            } else {
+                warn "$0: Include directory $_ not found, skipping\n";
+            }
         }
     }
-    elsif ($type eq 'badeval')
-    {
-        if ($args[0])
-        {
-            _print ("ERROR: $args[0]\n", -1);
-            return(1);
-        }
-    }
-    elsif ($type eq 'noextension')
-    {
-        my $progext = join(',', @{$args[1]});
-        my $modext  = join(',', @{$args[2]});
-
-        $progext =~ s"\\""g;
-        $modext  =~ s"\\""g;
-
-        $progext =~ s"\$""g;
-        $modext  =~ s"\$""g;
-
-        _print 
-        (
-"
-ERROR: '$args[0]' does not have a proper extension! Proper extensions are:
-
-    PROGRAM:       $progext 
-    SHARED OBJECT: $modext
-
-Use the '-prog' flag to force your files to be interpreted as programs.
-Use the '-mod' flag to force your files to be interpreted as modules.
-", -1
-        );
-        return(1);
-    }
-
-    return(0);
+            
+    $command .= "-I$_ " for @INC;
+    return $command;
 }
 
-sub _checkopts
+# Use B::Stash to find additional modules and stuff.
 {
-    my @errors;
-    local($") = "\n";
+    my $_stash;
+    sub grab_stash {
 
-    if ($options->{'log'})
-    {
-        $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n");
-    }
+        warn "already called get_stash once" if $_stash;
 
-    if ($options->{'b'} && $options->{'c'})
-    {
-        push(@errors,
-"ERROR: The '-b' and '-c' options are incompatible. The '-c' option specifies
-       a name for the intermediate C code but '-b' generates byte code
-       directly.\n");
-    }
-    if ($options->{'b'} && ($options->{'sav'} || $options->{'gen'}))
-    {
-        push(@errors,
-"ERROR: The '-sav' and '-gen' options are incompatible with the '-b' option.
-       They ask for intermediate C code to be saved by '-b' generates byte
-       code directly.\n");
-    }
+        my $command = "$BinPerl -MB::Stash -c $Input";
+        # Filename here is perfectly sanitised.
+        vprint 3, "Calling $command\n";
 
-    if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} ))
-    {
-        push(@errors, 
-"ERROR: The '-sav' and '-C' options are incompatible when you have more than 
-       one input file! ('-C' explicitly names resulting C code, '-sav' saves it,
-       and hence, with more than one file, the c code will be overwritten for 
-       each file that you compile)\n");
-    }
-    if (($options->{'o'}) && (@ARGV > 1))
-    {
-        push(@errors, 
-"ERROR: The '-o' option is incompatible when you have more than one input 
-       file! (-o explicitly names the resulting file, hence, with more than 
-       one file the names clash)\n");
-    }
+               my ($stash_r, $error_r) = spawnit($command);
+               my @stash = @$stash_r;
+               my @error = @$error_r;
 
-    if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) &&
-                                                            !$options->{'C'})
-    {
-        push(@errors, 
-"ERROR: You need to specify where you are going to save the resulting 
-       C code when using '-sav' and '-e'. Use '-C'.\n");
-    }
+       if (@error && $? != 0) {
+            die "$0: $Input did not compile:\n@error\n";
+        }
 
-    if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) 
-                                                    && $options->{'gen'})
-    {
-        push(@errors, 
-"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. 
-       '-gen' says to stop at C generation, and the other three modify the 
-       compilation and/or running process!\n");
+        $stash[0] =~ s/,-u\<none\>//;
+        vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
+        chomp $stash[0];
+        return $_stash = $stash[0];
     }
 
-    if ($options->{'run'} && $options->{'mod'})
-    {
-        push(@errors, 
-"ERROR: Can't run modules that you are compiling! '-run' and '-mod' are 
-       incompatible!\n"); 
-    }
+}
 
-    if ($options->{'e'} && @ARGV)
-    {
-        push (@errors, 
-"ERROR: The option '-e' needs to be all by itself without any other 
-       file arguments!\n");
-    }
-    if ($options->{'e'} && !($options->{'o'} || $options->{'run'}))
-    {
-        $options->{'run'} = 1;
-    }
+# Check the consistency of options if -B is selected.
+# To wit, (-B|-O) ==> no -shared, no -S, no -c
+sub checkopts_byte {
 
-    if (!defined($options->{'verbose'})) 
-    { 
-        $options->{'verbose'} = ($options->{'log'})? 64 : 7; 
-    }
+    die "$0: Please choose one of either -B and -O.\n" if opt(O);
 
-    my $verbose_error;
+    if (opt(shared)) {
+        warn "$0: Will not create a shared library for bytecode\n";
+        delete $Options->{shared};
+    }
 
-    if ($options->{'verbose'} =~ m"[^tagfcd]" && 
-            !( $options->{'verbose'} eq '0' || 
-                ($options->{'verbose'} < 64 && $options->{'verbose'} > 0)))
-    {
-        $verbose_error = 1;
-        push(@errors, 
-"ERROR: Illegal verbosity level.  Needs to have either the letters 
-       't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n");
+    for my $o ( qw[c S] ) { 
+        if (opt($o)) { 
+            warn "$0: Compiling to bytecode is a one-pass process--",
+                  "-$o ignored\n";
+            delete $Options->{$o};
+        }
     }
 
-    $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")? 
-                            ($options->{'verbose'} =~ m"d") * 32 +     
-                            ($options->{'verbose'} =~ m"c") * 16 +     
-                            ($options->{'verbose'} =~ m"f") * 8     +     
-                            ($options->{'verbose'} =~ m"t") * 4     +     
-                            ($options->{'verbose'} =~ m"a") * 2     +     
-                            ($options->{'verbose'} =~ m"g") * 1     
-                                                    : $options->{'verbose'};
-
-    if     (!$verbose_error && (    $options->{'log'} && 
-                                !(
-                                    ($options->{'verbose'} & 8)   || 
-                                    ($options->{'verbose'} & 16)  || 
-                                    ($options->{'verbose'} & 32 ) 
-                                )
-                            )
-        )
-    {
-        push(@errors, 
-"ERROR: The verbosity level '$options->{'verbose'}' does not output anything 
-       to a logfile, and you specified '-log'!\n");
-    } # }
-
-    if     (!$verbose_error && (    !$options->{'log'} && 
-                                (
-                                    ($options->{'verbose'} & 8)   || 
-                                    ($options->{'verbose'} & 16)  || 
-                                    ($options->{'verbose'} & 32)  || 
-                                    ($options->{'verbose'} & 64)
-                                )
-                            )
-        )
-    {
-        push(@errors, 
-"ERROR: The verbosity level '$options->{'verbose'}' requires that you also 
-       specify a logfile via '-log'\n");
-    } # }
-
-
-    (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors);
-    return(1);
 }
 
-sub _print
-{
-    my ($text, $flag ) = @_;
-    
-    my $logflag = int($flag/8) * 8;
-    my $regflag = $flag % 8;
-
-    if ($flag == -1 || ($flag & $options->{'verbose'}))
-    {
-        my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1) 
-                                                        && $options->{'log'}); 
-
-        my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
-        
-        if ($doreg) { print( STDERR $text ); }
-        if ($dolog) { print $_fh $text; }
+# Check the input and output files make sense, are read/writeable.
+sub sanity_check {
+    if ($Input eq $Output) {
+        if ($Input eq 'a.out') {
+            warn "$0: Compiling a.out is probably not what you want to do.\n";
+            # You fully deserve what you get now.
+        } else {
+            warn "$0: Will not write output on top of input file, ",
+                "compiling to a.out instead\n";
+            $Output = "a.out";
+        }
     }
 }
 
-sub _run
-{
-    my ($command, $flag) = @_;
-
-    my $logflag = ($flag != -1)? int($flag/8) * 8 : 0;
-    my $regflag = $flag % 8;
-
-    if ($flag == -1 || ($flag & $options->{'verbose'}))
-    {
-        my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'});
-        my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
-
-        if ($doreg && !$dolog) 
-        {
-           print _interruptrun("$command");
-       }
-        elsif ($doreg && $dolog) 
-        { 
-           my $text = _interruptrun($command); 
-           print $_fh $text; 
-           print STDERR $text;
-       }
-        else 
-        { 
-           my $text = _interruptrun($command);
-           print $_fh $text; 
-       }
-    }
-    else 
-    {
-       _interruptrun($command);
+sub check_read { 
+    my $file = shift;
+    unless (-r $file) {
+        die "$0: Input file $file is a directory, not a file\n" if -d _;
+        unless (-e _) {
+            die "$0: Input file $file was not found\n";
+        } else {
+            die "$0: Cannot read input file $file: $!\n";
+        }
     }
-    return($?);
+    unless (-f _) {
+        # XXX: die?  don't try this on /dev/tty
+        warn "$0: WARNING: input $file is not a plain file\n";
+    } 
 }
 
-sub _interruptrun
-{
-    my ($command) = @_;
-    my $pid = open (FD, "$command  |");
-
-    local($SIG{HUP}) = sub { 
-#      kill 9, $pid + 1;  
-#      HACK... 2>&1 doesn't propogate
-#      kill, comment out for quick and dirty
-#      process killing of child.
-
-       kill 9, $pid;  
-       exit(); 
-    };
-    local($SIG{INT}) = sub { 
-#      kill 9, $pid + 1;  
-#      HACK... 2>&1 doesn't propogate
-#      kill, comment out for quick and dirty
-#      process killing of child.
-       kill 9, $pid; 
-       exit(); 
-    }; 
-
-    my $needalarm = 
-            ($ENV{'PERLCC_TIMEOUT'} && 
-                    $Config{'osname'} ne 'MSWin32' && $command =~ m"^perlc");
-    my $text;
-
-    eval
-    {
-        local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
-        alarm($ENV{'PERLCC_TIMEOUT'}) if ($needalarm);
-        $text = join('', <FD>); 
-        alarm(0) if ($needalarm);
-    };
-
-    if ($@) 
-    { 
-        eval { kill 'HUP', $pid; };
-        _print("SYSTEM TIMEOUT (infinite loop?)\n", 36); 
+sub check_write {
+    my $file = shift;
+    if (-d $file) {
+        die "$0: Cannot write on $file, is a directory\n";
+    }
+    if (-e _) {
+        die "$0: Cannot write on $file: $!\n" unless -w _;
+    } 
+    unless (-w cwd()) { 
+        die "$0: Cannot write in this directory: $!\n" 
     }
-        
-    close(FD);
-    return($text);
 }
 
-sub _usage
-{
-    _print
-    ( 
-    <<"EOF"
-
-Usage: $0 <file_list> 
-
-WARNING: The whole compiler suite ('perlcc' included) is considered VERY
-experimental.  Use for production purposes is strongly discouraged.
-
-    Flags with arguments
-        -L       < extra library dirs for installation (form of 'dir1:dir2') >
-        -I       < extra include dirs for installation (form of 'dir1:dir2') >
-        -C       < explicit name of resulting C code > 
-        -o       < explicit name of resulting executable >
-        -e       < to compile 'one liners'. Need executable name (-o) or '-run'>
-        -regex   < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe >
-        -verbose < verbose level < 1-63, or following letters 'gatfcd' >
-        -argv    < arguments for the executables to be run via '-run' or '-e' > 
-
-    Boolean flags
-        -b       ( to generate byte code )
-        -opt     ( to generated optimised C code. May not work in some cases. )
-        -gen     ( to just generate the C code. Implies '-sav' )
-        -sav     ( to save intermediate C code, (and executables with '-run'))
-        -run     ( to run the compiled program on the fly, as were interpreted.)
-        -prog    ( to indicate that the files on command line are programs )
-        -mod     ( to indicate that the files on command line are modules  )
-
-EOF
-, -1
+sub check_perl {
+    my $file = shift;
+    unless (-T $file) {
+        warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
+        print "Checking file type... ";
+        system("file", $file);  
+        die "Please try a perlier file!\n";
+    } 
+
+    open(my $handle, "<", $file)    or die "XXX: can't open $file: $!";
+    local $_ = <$handle>;
+    if (/^#!/ && !/perl/) {
+        die "$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n";
+    } 
+
+} 
+
+# File spawning and error collecting
+sub spawnit {
+       my ($command) = shift;
+       my (@error,@output);
+       my $errname;
+       (undef, $errname) = tempfile("pccXXXXX");
+       { 
+       open (S_OUT, "$command 2>$errname |")
+               or die "$0: Couldn't spawn the compiler.\n";
+       @output = <S_OUT>;
+       }
+       open (S_ERROR, $errname) or die "$0: Couldn't read the error file.\n";
+       @error = <S_ERROR>;
+       close S_ERROR;
+       close S_OUT;
+       unlink $errname or die "$0: Can't unlink error file $errname";
+       return (\@output, \@error);
+}
 
-    );
-    exit(255);
+sub helpme {
+       print "perlcc compiler frontend, version $VERSION\n\n";
+       { no warnings;
+       exec "pod2usage $0";
+       exec "perldoc $0";
+       exec "pod2text $0";
+       }
 }
 
 
@@ -868,247 +475,83 @@ __END__
 
 =head1 NAME
 
-perlcc - frontend for perl compiler
+perlcc - generate executables from Perl programs
 
 =head1 SYNOPSIS
 
-    %prompt  perlcc a.p        # compiles into executable 'a'
-
-    %prompt  perlcc A.pm       # compile into 'A.so'
-
-    %prompt  perlcc a.p -o execute  # compiles 'a.p' into 'execute'.
-
-    %prompt  perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on
-                                        # the fly
+    $ perlcc hello              # Compiles into executable 'a.out'
+    $ perlcc -o hello hello.pl  # Compiles into executable 'hello'
 
-    %prompt  perlcc a.p -o execute -run -argv 'arg1 arg2 arg3' 
-                                        # compiles into execute, runs with 
-                                        # arg1 arg2 arg3 as @ARGV
+    $ perlcc -O file            # Compiles using the optimised C backend
+    $ perlcc -B file            # Compiles using the bytecode backend
 
-    %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe'
-                                        # compiles into 'a.exe','b.exe','c.exe'.
-
-    %prompt perlcc a.p -log compilelog  # compiles into 'a', saves compilation
-                                        # info into compilelog, as well
-                                        # as mirroring to screen
-
-    %prompt perlcc a.p -log compilelog -verbose cdf 
-                                        # compiles into 'a', saves compilation
-                                        # info into compilelog, being silent
-                                        # on screen.
-
-    %prompt perlcc a.p -C a.c -gen      # generates C code (into a.c) and 
-                                        # stops without compile.
-
-    %prompt perlcc a.p -L ../lib a.c 
-                                        # Compiles with the perl libraries 
-                                        # inside ../lib included.
+    $ perlcc -c file            # Creates a C file, 'file.c'
+    $ perlcc -S -o hello file   # Creates a C file, 'file.c',
+                                # then compiles it to executable 'hello'
+    $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'
 
+    $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
+    $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
+    
 =head1 DESCRIPTION
 
-'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p'
-compiles the code inside a.p into a standalone executable, and 
-perlcc A.pm will compile into a shared object, A.so, suitable for inclusion 
-into a perl program via "use A".
+F<perlcc> creates standalone executables from Perl programs, using the
+code generators provided by the L<B> module. At present, you may
+either create executable Perl bytecode, using the C<-B> option, or 
+generate and compile C files using the standard and 'optimised' C
+backends.
 
-There are quite a few flags to perlcc which help with such issues as compiling 
-programs in bulk, testing compiled programs for compatibility with the 
-interpreter, and controlling.
+The code generated in this way is not guaranteed to work. The whole
+codegen suite (C<perlcc> included) should be considered B<very>
+experimental. Use for production purposes is strongly discouraged.
 
-=head1 OPTIONS 
+=head1 OPTIONS
 
 =over 4
 
-=item -L < library_directories >
-
-Adds directories in B<library_directories> to the compilation command.
-
-=item -I  < include_directories > 
-
-Adds directories inside B<include_directories> to the compilation command.
-
-=item -C   < c_code_name > 
-
-Explicitly gives the name B<c_code_name> to the generated file containing
-the C code which is to be compiled. Can only be used if compiling one file
-on the command line.
-
-=item -o   < executable_name >
-
-Explicitly gives the name B<executable_name> to the executable which is to be
-compiled. Can only be used if compiling one file on the command line.
+=item -LI<library directories>
 
-=item -e   < perl_line_to_execute>
+Adds the given directories to the library search path when C code is
+passed to your C compiler.
 
-Compiles 'one liners', in the same way that B<perl -e> runs text strings at 
-the command line. Default is to have the 'one liner' be compiled, and run all
-in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, 
-rather than throwing it away. Use '-argv' to pass arguments to the executable
-created.
+=item -II<include directories>
 
-=item -b
+Adds the given directories to the include file search path when C code is
+passed to your C compiler; when using the Perl bytecode option, adds the
+given directories to Perl's include path.
 
-Generates bytecode instead of C code.
+=item -o I<output file name>
 
-=item -opt
+Specifies the file name for the final compiled executable.
 
-Uses the optimized C backend (C<B::CC>)rather than the simple C backend
-(C<B::C>).  Beware that the optimized C backend creates very large
-switch structures and structure initializations.  Many C compilers
-find it a challenge to compile the resulting output in finite amounts
-of time.  Many Perl features such as C<goto LABEL> are also not
-supported by the optimized C backend.  The simple C backend should
-work in more instances, but can only offer modest speed increases.
+=item -c I<C file name>
 
-=item -regex   <rename_regex>
+Create C code only; do not compile to a standalone binary.
 
-Gives a rule B<rename_regex> - which is a legal perl regular expression - to 
-create executable file names.
+=item -e I<perl code>
 
-=item -verbose <verbose_level>
+Compile a one-liner, much the same as C<perl -e '...'>
 
-Show exactly what steps perlcc is taking to compile your code. You can
-change the verbosity level B<verbose_level> much in the same way that
-the C<-D> switch changes perl's debugging level, by giving either a
-number which is the sum of bits you want or a list of letters
-representing what you wish to see. Here are the verbosity levels so
-far :
+=item -S
 
-    Bit 1(g):      Code Generation Errors to STDERR
-    Bit 2(a):      Compilation Errors to STDERR
-    Bit 4(t):      Descriptive text to STDERR 
-    Bit 8(f):      Code Generation Errors to file (B<-log> flag needed)
-    Bit 16(c):     Compilation Errors to file (B<-log> flag needed)
-    Bit 32(d):     Descriptive text to file (B<-log> flag needed) 
+Do not delete generated C code after compilation.
 
-If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring 
-all of perlcc's output to both the screen and to a log file). If no B<-log>
-tag is given, then the default verbose level is 7 (ie: outputting all of 
-perlcc's output to STDERR).
+=item -B
 
-NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to
-both a file, and to the screen! Suggestions are welcome on how to overcome this
-difficulty, but for now it simply does not work properly, and hence will only go
-to the screen.
+Use the Perl bytecode code generator.
 
-=item -log <logname>
+=item -O
 
-Opens, for append, a logfile to save some or all of the text for a given 
-compile command. No rewrite version is available, so this needs to be done 
-manually.
+Use the 'optimised' C code generator. This is more experimental than
+everything else put together, and the code created is not guaranteed to
+compile in finite time and memory, or indeed, at all.
 
-=item -argv <arguments>
+=item -v
 
-In combination with C<-run> or C<-e>, tells perlcc to run the resulting 
-executable with the string B<arguments> as @ARGV.
-
-=item -sav
-
-Tells perl to save the intermediate C code. Usually, this C code is the name
-of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c',
-for example. If used with the C<-e> operator, you need to tell perlcc where to 
-save resulting executables.
-
-=item -gen
-
-Tells perlcc to only create the intermediate C code, and not compile the 
-results. Does an implicit B<-sav>, saving the C code rather than deleting it.
-
-=item -run
-
-Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE 
-B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS 
-ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING.
-
-=item -prog
-
-Indicate that the programs at the command line are programs, and should be
-compiled as such. B<perlcc> will automatically determine files to be 
-programs if they have B<.p>, B<.pl>, B<.bat> extensions.
-
-=item -mod
-
-Indicate that the programs at the command line are modules, and should be
-compiled as such. B<perlcc> will automatically determine files to be 
-modules if they have the extension B<.pm>.
+Increase verbosity of output; can be repeated for more verbose output.
 
 =back
 
-=head1 ENVIRONMENT
-
-Most of the work of B<perlcc> is done at the command line. However, you can 
-change the heuristic which determines what is a module and what is a program.
-As indicated above, B<perlcc> assumes that the extensions:
-
-.p$, .pl$, and .bat$
-
-indicate a perl program, and:
-
-.pm$
-
-indicate a library, for the purposes of creating executables. And furthermore,
-by default, these extensions will be replaced (and dropped) in the process of 
-creating an executable. 
-
-To change the extensions which are programs, and which are modules, set the
-environmental variables:
-
-PERL_SCRIPT_EXT
-PERL_MODULE_EXT
-
-These two environmental variables take colon-separated, legal perl regular 
-expressions, and are used by perlcc to decide which objects are which. 
-For example:
-
-setenv PERL_SCRIPT_EXT  '.prl$:.perl$'
-prompt%   perlcc sample.perl
-
-will compile the script 'sample.perl' into the executable 'sample', and
-
-setenv PERL_MODULE_EXT  '.perlmod$:.perlmodule$'
-
-prompt%   perlcc sample.perlmod
-
-will  compile the module 'sample.perlmod' into the shared object 
-'sample.so'
-
-NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT
-is a literal '.', and not a wild-card. To get a true wild-card, you need to 
-backslash the '.'; as in:
-
-setenv PERL_SCRIPT_EXT '\.\.\.\.\.'
-
-which would have the effect of compiling ANYTHING (except what is in 
-PERL_MODULE_EXT) into an executable with 5 less characters in its name.
-
-The PERLCC_OPTS environment variable can be set to the default flags
-that must be used by the compiler.
-
-The PERLCC_TIMEOUT environment variable can be set to the number of
-seconds to wait for the backends before giving up.  This is sometimes
-necessary to avoid some compilers taking forever to compile the
-generated output.  May not work on Windows and similar platforms.
-
-=head1 FILES
-
-'perlcc' uses a temporary file when you use the B<-e> option to evaluate 
-text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is
-perlc$$.p.c, and the temporary executable is perlc$$.
-
-When you use '-run' and don't save your executable, the temporary executable is
-perlc$$
-
-=head1 BUGS
-
-The whole compiler suite (C<perlcc> included) should be considered very
-experimental.  Use for production purposes is strongly discouraged.
-
-perlcc currently cannot compile shared objects on Win32. This should be fixed
-in future.
-
-Bugs in the various compiler backends still exist, and are perhaps too
-numerous to list here.
-
 =cut
 
 !NO!SUBS!
index 60777fa..6856884 100644 (file)
@@ -53,7 +53,6 @@
 #else
 #include <utime.h>
 #endif
-
 #ifdef __GNUC__
 /* Mingw32 defaults to globing command line 
  * So we turn it off like this:
@@ -1645,8 +1644,12 @@ win32_waitpid(int pid, int *status, int flags)
        long child = find_pseudo_pid(-pid);
        if (child >= 0) {
            HANDLE hThread = w32_pseudo_child_handles[child];
-           DWORD waitcode = WaitForSingleObject(hThread, INFINITE);
-           if (waitcode != WAIT_FAILED) {
+           DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
+           DWORD waitcode = WaitForSingleObject(hThread, timeout);
+           if (waitcode == WAIT_TIMEOUT) {
+               return 0;
+           }
+           else if (waitcode != WAIT_FAILED) {
                if (GetExitCodeThread(hThread, &waitcode)) {
                    *status = (int)((waitcode & 0xff) << 8);
                    retval = (int)w32_pseudo_child_pids[child];
@@ -1663,14 +1666,18 @@ win32_waitpid(int pid, int *status, int flags)
        long child = find_pid(pid);
        if (child >= 0) {
            HANDLE hProcess = w32_child_handles[child];
-           DWORD waitcode = WaitForSingleObject(hProcess, INFINITE);
-           if (waitcode != WAIT_FAILED) {
-               if (GetExitCodeProcess(hProcess, &waitcode)) {
-                   *status = (int)((waitcode & 0xff) << 8);
-                   retval = (int)w32_child_pids[child];
-                   remove_dead_process(child);
-                   return retval;
-               }
+           DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
+           DWORD waitcode = WaitForSingleObject(hProcess, timeout);
+           if (waitcode == WAIT_TIMEOUT) {
+               return 0;
+           }
+           else if (waitcode != WAIT_FAILED) {
+                if (GetExitCodeProcess(hProcess, &waitcode)) {
+                    *status = (int)((waitcode & 0xff) << 8);
+                    retval = (int)w32_child_pids[child];
+                    remove_dead_process(child);
+                    return retval;
+                }
            }
            else
                errno = ECHILD;
index 2e5b074..eb5ecd2 100644 (file)
@@ -492,5 +492,9 @@ struct interp_intern {
  */
 #include "win32iop.h"
 
+#ifndef WNOHANG
+#  define WNOHANG 1
+#endif
+
 #endif /* _INC_WIN32_PERL5 */