diff options
| -rw-r--r-- | Changes | 829 | ||||
| -rwxr-xr-x | Configure | 1 | ||||
| -rw-r--r-- | INSTALL | 60 | ||||
| -rw-r--r-- | MANIFEST | 4 | ||||
| -rwxr-xr-x | Makefile.SH | 39 | ||||
| -rwxr-xr-x | Porting/makerel | 7 | ||||
| -rwxr-xr-x | Porting/patchls | 106 | ||||
| -rw-r--r-- | Porting/pumpkin.pod | 26 | ||||
| -rw-r--r-- | README.vms | 380 | ||||
| -rw-r--r-- | av.c | 11 | ||||
| -rwxr-xr-x | configpm | 3 | ||||
| -rw-r--r-- | doop.c | 1 | ||||
| -rw-r--r-- | eg/sysvipc/ipcsem | 4 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/DynaLoader/DynaLoader.pm | 59 | ||||
| -rw-r--r-- | ext/util/make_ext | 25 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | gv.c | 5 | ||||
| -rw-r--r-- | hints/bsdos.sh | 162 | ||||
| -rw-r--r-- | hints/linux.sh | 8 | ||||
| -rw-r--r-- | hv.c | 7 | ||||
| -rw-r--r-- | lib/AutoLoader.pm | 14 | ||||
| -rw-r--r-- | lib/Carp.pm | 2 | ||||
| -rw-r--r-- | lib/Cwd.pm | 44 | ||||
| -rw-r--r-- | lib/English.pm | 2 | ||||
| -rw-r--r-- | lib/ExtUtils/Install.pm | 34 | ||||
| -rw-r--r-- | lib/ExtUtils/Liblist.pm | 51 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 17 | ||||
| -rw-r--r-- | lib/File/DosGlob.pm | 63 | ||||
| -rw-r--r-- | lib/Math/Complex.pm | 424 | ||||
| -rw-r--r-- | lib/Test/Harness.pm | 13 | ||||
| -rw-r--r-- | lib/autouse.pm | 8 | ||||
| -rw-r--r-- | lib/base.pm | 49 | ||||
| -rw-r--r-- | lib/blib.pm | 1 | ||||
| -rw-r--r-- | lib/diagnostics.pm | 2 | ||||
| -rw-r--r-- | lib/perl5db.pl | 51 | ||||
| -rw-r--r-- | lib/vars.pm | 55 | ||||
| -rwxr-xr-x | makedepend.SH | 7 | ||||
| -rw-r--r-- | malloc.c | 6 | ||||
| -rw-r--r-- | mg.c | 63 | ||||
| -rw-r--r-- | op.c | 51 | ||||
| -rw-r--r-- | opcode.h | 2 | ||||
| -rw-r--r-- | os2/Changes | 5 | ||||
| -rw-r--r-- | os2/OS2/REXX/Makefile.PL | 2 | ||||
| -rw-r--r-- | os2/OS2/REXX/REXX.pm | 4 | ||||
| -rw-r--r-- | patchlevel.h | 7 | ||||
| -rw-r--r-- | perl.c | 145 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | perly.c | 24 | ||||
| -rw-r--r-- | perly.y | 24 | ||||
| -rw-r--r-- | pod/perlapio.pod | 4 | ||||
| -rw-r--r-- | pod/perldelta.pod | 2 | ||||
| -rw-r--r-- | pod/perldiag.pod | 36 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 142 | ||||
| -rw-r--r-- | pod/perlguts.pod | 36 | ||||
| -rw-r--r-- | pod/perlipc.pod | 6 | ||||
| -rw-r--r-- | pod/perlop.pod | 14 | ||||
| -rw-r--r-- | pod/perlrun.pod | 9 | ||||
| -rw-r--r-- | pod/perlsec.pod | 70 | ||||
| -rw-r--r-- | pod/perlsub.pod | 10 | ||||
| -rw-r--r-- | pod/perlvar.pod | 103 | ||||
| -rw-r--r-- | pp.c | 89 | ||||
| -rw-r--r-- | pp_hot.c | 83 | ||||
| -rw-r--r-- | pp_sys.c | 39 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | regcomp.c | 10 | ||||
| -rw-r--r-- | regexec.c | 8 | ||||
| -rw-r--r-- | scope.c | 77 | ||||
| -rw-r--r-- | sv.c | 22 | ||||
| -rwxr-xr-x | t/comp/proto.t | 15 | ||||
| -rwxr-xr-x | t/lib/complex.t | 69 | ||||
| -rwxr-xr-x | t/lib/dosglob.t | 94 | ||||
| -rwxr-xr-x | t/op/method.t | 13 | ||||
| -rwxr-xr-x | t/op/misc.t | 7 | ||||
| -rwxr-xr-x | t/op/ref.t | 16 | ||||
| -rwxr-xr-x | t/op/split.t | 16 | ||||
| -rwxr-xr-x | t/op/sprintf.t | 29 | ||||
| -rwxr-xr-x | t/op/subst.t | 7 | ||||
| -rwxr-xr-x | t/op/taint.t | 59 | ||||
| -rwxr-xr-x | t/pragma/locale.t | 28 | ||||
| -rw-r--r-- | taint.c | 2 | ||||
| -rw-r--r-- | toke.c | 13 | ||||
| -rw-r--r-- | util.c | 6 | ||||
| -rw-r--r-- | utils/h2ph.PL | 7 | ||||
| -rw-r--r-- | utils/perlbug.PL | 48 | ||||
| -rw-r--r-- | utils/perldoc.PL | 176 | ||||
| -rw-r--r-- | vms/perly_c.vms | 24 | ||||
| -rw-r--r-- | win32/Makefile | 25 | ||||
| -rw-r--r-- | win32/makefile.mk | 15 | ||||
| -rw-r--r-- | win32/win32io.c | 3 | ||||
| -rw-r--r-- | win32/win32sck.c | 32 | ||||
| -rwxr-xr-x | x2p/Makefile.SH | 2 | ||||
| -rw-r--r-- | x2p/util.c | 6 |
93 files changed, 3347 insertions, 1049 deletions
@@ -42,9 +42,836 @@ current addresses (as of March 1997): And the Keepers of the Patch Pumpkin: Charles Bailey <bailey@hmivax.humgen.upenn.edu> + Tim Bunce <Tim.Bunce@ig.co.uk> Andy Dougherty <doughera@lafcol.lafayette.edu> Chip Salzenberg <chip@perl.com> - Tim Bunce <Tim.Bunce@ig.co.uk> + + +---------------- +Version 5.004_04 Maintenance release 4 for 5.004 +---------------- + +"1. Out of clutter, find simplicity. + 2. From discord, find harmony. + 3. In the middle of difficulty lies opportunity." + -- Albert Einstein, three rules of work + + + HEADLINES FOR THIS MAINTENANCE RELEASE + + Fixed gaps in tainting (readdir, readlink, gecos, bit vector ops). + Fixed memory leak in splice(@_). + Fixed debugger core dumps. + IO::Socket now sets autoflush by default. + Several perldoc bugs fixed, now faster and more helpful. + Fixed Win32 handle leak. + Many other improvements to Win32 support. + Many many other bug fixes and enhancements. + + + ------ BUILD PROCESS ------ + + Title: "ExtUtils::Liblist prints diagnostics to STDOUT (vs. STDERR)" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, jesse@ginger + (Jesse Glick) + Msg-ID: <199708290032.UAA15663@ginger>, + <Pine.SUN.3.96.970829132217.28552A-100000@newton.phys> + Files: MANIFEST lib/ExtUtils/Liblist.pm + + Title: "Set LD_RUN_PATH when building suidperl" + From: Chip Salzenberg <chip@rio.atlantic.net>, Tony Sanders + <sanders@bsdi.com> + Msg-ID: <199708272226.QAA10206@austin.bsdi.com> + Files: Makefile.SH + + Title: "INSTALL version 1.26" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970828143314.27416B-100000@newton.phys> + Files: INSTALL + + Title: "Propagate MAKE=$(MAKE) through perl build" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970908143853.13750C-100000@newton.phys> + Files: Makefile.SH makedepend.SH x2p/Makefile.SH ext/util/make_ext + + Title: "update to installperl for perl5.004_02 to skip CVS dir" + From: Tony Sanders <sanders@bsdi.com> + Msg-ID: <199708272307.RAA13451@austin.bsdi.com> + Files: installperl + + Title: "makedepend loop on HP-UX 10.20" + Msg-ID: <1997Sep20.183731.2297443@cor.newman> + Files: Makefile.SH + + Title: "Tiny Grammaro in INSTALL" + From: koenig@anna.mind.de (Andreas J. Koenig) + Msg-ID: <sfcwwkb2pc8.fsf@anna.in-berlin.de> + Files: INSTALL + + Title: "Fix Configured osvers under Linux 1" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Hugo van der + Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199709241439.PAA17114@crypt.compulink.co.uk>, + <Pine.SUN.3.96.970924112654.5054D-100000@newton.phys> + Files: Configure + + Title: "INSTALL-1.28" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.971010131207.23751A-100000@newton.phys> + Files: INSTALL + + Title: "makedepend.SH fix for UNICOS" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199710132039.XAA21459@alpha.hut.fi> + Files: makedepend.SH + + ------ CORE LANGUAGE ------ + + Title: "Re: "perl -d" dumps core when loading syslog.ph" + From: Jochen Wiedmann <wiedmann@neckar-alb.de>, Stephen McCamant + <alias@mcs.com>, ilya@math.ohio-state.edu (Ilya + Zakharevich) + Msg-ID: <1997Aug30.034921.2297381@cor.newman.upenn.edu>, + <3407639E.FEBF20BA@neckar-alb.de>, + <m0x4ZGj-000EZYC@alias-2.pr.mcs.net> + Files: pp_ctl.c + + Title: "Allow $obj->$coderef()" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199708291649.MAA23276@nielsenmedia.com> + Files: pp_hot.c + + Title: "Localize PV value in save_gp()", "typeglob differences in perl4 and + perl5" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen McCamant + <alias@mcs.com> + Msg-ID: <199708272348.TAA03139@aatma.engin.umich.edu>, + <m0x4u2o-000EZkC@alias-2.pr.mcs.net> + Files: scope.c t/op/ref.t + + Title: "Avoid assumption that STRLEN == I32" + From: Chip Salzenberg <chip@rio.atlantic.net>, Hallvard B Furuseth + <h.b.furuseth@usit.uio.no> + Msg-ID: <199708242310.BAA05497@bombur2.uio.no> + Files: hv.c + + Title: "Fix memory leak in splice(@_)" + From: "Tuomas J. Lukka" <tjl@fkfuga.pc.helsinki.fi>, Chip Salzenberg + <chip@rio.atlantic.net> + Msg-ID: <m0x3iQE-000CBrC@lukka.student.harvard.edu> + Files: proto.h av.c global.sym pp.c + + Title: "Fix line number of warnings in while() conditional", "misleading + uninit value warning" + From: Chip Salzenberg <chip@rio.atlantic.net>, Greg Bacon + <gbacon@crp-201.adtran.com> + Msg-ID: <199708271607.LAA01403@crp-201.adtran.com> + Files: proto.h op.c perly.c perly.y + + Title: "-t and POSIX::isatty on IO::Handle objects", "Fix C<-t $handle>" + From: Chip Salzenberg <chip@rio.atlantic.net>, Greg Ward + <greg@bic.mni.mcgill.ca> + Msg-ID: <199708261754.NAA24826@bottom.bic.mni.mcgill.ca> + Files: pp_sys.c + + Title: "Fix output of invalid printf formats" + From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden + <hv@crypt.compulink.co.uk> + Msg-ID: <199708241529.QAA02457@crypt.compulink.co.uk> + Files: sv.c t/op/sprintf.t + + Title: "regexec.c regcppartblow declaration missing an arg" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199708290059.BAA05808@crypt.compulink.co.uk> + Files: regexec.c + + Title: "taint readlink, readdir, gecos" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199709131651.TAA13471@alpha.hut.fi> + Files: pod/perlfunc.pod pod/perlsec.pod pp_sys.c t/op/taint.t + + Title: "clean up old style package' usage in op.c" + From: Stephen Potter <spp@psa.pencom.com> + Msg-ID: <199709151813.NAA14433@psisa.psa.pencom.com> + Files: op.c + + Title: "beautifying usage() code in perl.c" + From: "John L. Allen" <"John L. Allen"<allen@gateway.grumman.com>> + Msg-ID: <Pine.SOL.3.91.970905091314.5991C-100000@gateway> + Files: perl.c + + Title: "debugger to fix core dumps, adds $^S" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199709170823.EAA21359@monk.mps.ohio-state.edu> + Files: pod/perlvar.pod perl.h gv.c lib/perl5db.pl mg.c perl.c toke.c + + Title: "downgrade "my $foo masks earlier" from mandatory to "-w"" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen Potter + <spp@psa.pencom.com> + Msg-ID: <199709091832.NAA14763@psisa.psa.pencom.com>, + <199709102019.QAA09591@aatma.engin.umich.edu> + Files: pod/perldelta.pod pod/perldiag.pod op.c + + Title: "fix overridden glob() problems" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199709171645.MAA13988@aatma.engin.umich.edu> + Files: MANIFEST pod/perlsub.pod lib/File/DosGlob.pm op.c t/lib/dosglob.t + toke.c + + Title: "Reverse previous "Fix C<qq #hi#>" patch" + From: Chip Salzenberg <chip@rio.atlantic.net>, Kenneth Albanowski + <kjahds@kjahds.com>, Tom Christiansen + <tchrist@jhereg.perl.com> + Msg-ID: <199707050155.VAA27394@rio.atlantic.net>, + <199708172326.RAA19344@jhereg.perl.com>, + <Pine.LNX.3.93.970817200236.170F-100000@kjahds.com> + Files: toke.c + + Title: "printf type warning buglets in m3t2" + From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no> + Msg-ID: <199708141017.MAA10225@bombur2.uio.no> + Files: regcomp.c regexec.c scope.c sv.c util.c x2p/util.c + + Title: "Localize PV value in save_gp()", "typeglob differences in perl4 and + perl5" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen McCamant + <alias@mcs.com> + Msg-ID: <199708272348.TAA03139@aatma.engin.umich.edu>, + <m0x4AUk-000EUJC@alias-2.pr.mcs.net> + Files: scope.c t/op/ref.t + + Title: "unpack now allows commas but -w warns", "unpack() difference + 5.003->5.004" + From: "John L. Allen" <allen@gateway.grumman.com>, Chip Salzenberg + <chip@rio.atlantic.net>, Jarkko Hietaniemi <jhi@iki.fi>, + Jim Esten <jesten@wdynamic.com>, Jim Esten + <jesten@wepco.com>, timbo (Tim Bunce) + Msg-ID: <199709031632.LAA29584@wepco.com>, + <199709090257.WAA32670@rio.atlantic.net>, + <199709090917.MAA05602@alpha.hut.fi>, + <199709091000.LAA24094@toad.ig.co.uk>, + <341077FE.132F@wdynamic.com>, + <Pine.SOL.3.91.970905171243.14630A-100000@gateway> + Files: pod/perldiag.pod pp.c + + Title: "5.004_04 trial 1 assorted minor details" + From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no> + Msg-ID: <HBF.970921p5f6@bombur2.uio.no> + Files: Porting/pumpkin.pod hv.c op.c sv.c x2p/util.c + + Title: "A couple of 4_04t1 problems" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9709210959.AA28772@claudius.bfsec.bt.co.uk> + Files: lib/Cwd.pm perl.c + + Title: "Minor changes to ease port to MVS" + From: Len Johnson <lenjay@ibm.net>, SMTP%"BAHUFF@us.oracle.com" , + SMTP%"pfuntner@vnet.ibm.com" , pvhp@forte.com (Peter + Prymmer) + Msg-ID: <199709162058.NAA00952@mailsun2.us.oracle.com> + Files: unixish.h miniperlmain.c + + Title: "Truer version string and more robust perlbug" + From: "Michael A. Chase" <mchase@ix.netcom.com>, Hugo van der Sanden + <hv@crypt.compulink.co.uk> + Msg-ID: <199709201514.QAA21187@crypt.compulink.co.uk>, + <1997Sep22.090701.2297448@cor.newman> + Files: perl.c utils/perlbug.PL + + Title: "Fix locale bug for constant (readonly) strings" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199709262125.AAA28292@alpha.hut.fi> + Files: sv.c t/pragma/locale.t + + Title: "Enable truly global glob()" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710080000.UAA18972@aatma.engin.umich.edu> + Files: op.c + + Title: "Fix for $0 truncation" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199710081703.SAA02653@toad.ig.co.uk> + Files: mg.c + + Title: "Fix for missing &import leaving stack untidy" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199709282252.SAA22915@nielsenmedia.com> + Files: pp_hot.c + + Title: "Larry's proto fix" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199709290004.UAA07559@nielsenmedia.com> + Files: op.c t/comp/proto.t + + Title: "Fix bugs with magical arrays and hashes (@ISA)" + From: Chip Salzenberg <chip@rio.atlantic.net> + Msg-ID: <199709232148.RAA29967@rio.atlantic.net> + Files: perl.h proto.h av.c global.sym gv.c mg.c pp.c pp_hot.c scope.c + t/op/method.t + + Title: "Perl_debug_log stream used for all DEBUG_*(...) macro uses" + From: Nick Ing-Simmons <nik@tiuk.ti.com>, Tim Bunce + Msg-ID: <199709230820.JAA11945@tiuk.ti.com> + Files: perl.c taint.c util.c + + Title: "Tainting bitwise vector ops" + From: Chip Salzenberg <chip@rio.atlantic.net> + Msg-ID: <199710061726.NAA16438@rio.atlantic.net> + Files: doop.c t/op/taint.t + + Title: "Enhance $^E on OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199709232236.SAA04463@monk.mps.ohio-state.edu> + Files: pod/perlvar.pod mg.c os2/Changes + + Title: "option "!#... -- ..." in perl 5.004.03 seems not to work" + From: "John L. Allen" <allen@gateway.grumman.com>, Urs Thuermann + <urs@isnogud.escape.de> + Msg-ID: <199709232030.WAA30425@isnogud.escape.de>, + <Pine.SOL.3.91.970930105158.10789A-100000@gateway> + Files: perl.c + + Title: "syswrite will again write a zero length buffer" + From: Cameron Simpson <cs@zip.com.au>, Jarkko Hietaniemi <jhi@iki.fi>, + aml@world.std.com (Andrew M. Langmead) + Msg-ID: <199710042107.AAA28561@alpha.hut.fi>, + <19971007104652-cameron-1-10391@sid.research.canon.com.au> + Files: pp_sys.c + + Title: "make Odd number of elements in hash list warning non-mandatory" + From: Jason Varsoke {81530} <jjv@caesun10.msd.ray.com> + Msg-ID: <199710021651.MAA15690@caesun7.msd.ray.com> + Files: pp.c pp_hot.c + + Title: "Fix defined() bug in m4t3 affecting LWP" + From: chip@atlantic.net@ig.co.uk () + Msg-ID: <199710101822.OAA14249@cyprus.atlantic.net> + Files: pp.c + + Title: "Include $archname in perl -v output" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Files: perl.c + + Title: "-I flag can easily lead to whitespace in @INC" + From: Kenneth Stephen <y2kmvs@us.ibm.com>, Tim Bunce <Tim.Bunce@ig.co.uk>, + pvhp@forte.com (Peter Prymmer) + Msg-ID: <199710130922.KAA07780@toad.ig.co.uk>, + <5040400007001448000002L082*@MHS>, + <9710132015.AA12457@forte.com> + Files: perl.c + + ------ DOCUMENTATION ------ + + Title: "perldiag.pod: gotcha in short pattern/char ops" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199709050718.KAA31405@alpha.hut.fi> + Files: pod/perldiag.pod + + Title: "Documenting the perl-thanks address" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.970913064628.12359F-100000@julie.teleport.com> + Files: pod/perl.pod + + Title: "Missing section for @_ in perlvar." + From: abigail@fnx.com (Abigail) + Msg-ID: <199708142146.RAA13146@fnx.com> + Files: pod/perlvar.pod + + Title: "Promised information about AvHASH in perguts is not delivered" + From: mjd@plover.com + Files: pod/perlguts.pod + + Title: "perlfunc.doc - $_ aliasing in map, grep, foreach etc" + From: Ted Ashton <ashted@southern.edu> + Msg-ID: <199708181852.OAA15901@ns.southern.edu> + Files: pod/perlfunc.pod + + Title: "-U Unsafe operations need -w to warn" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.970826141343.13463h-100000@julie.teleport.com> + Files: pod/perlrun.pod + + Title: "document the return value of syscall" + From: Hans Mulder <hansm@icgned.nl> + Msg-ID: <1997Sep7.160817.2297395@cor.newman> + Files: pod/perlfunc.pod + + Title: "minor fix for perltrap.pod" + From: abigail@fnx.com (Abigail) + Msg-ID: <199709170500.BAA14805@fnx.com> + Files: pod/perltrap.pod + + Title: "xsubpp: document advanced dynamic typemap usage" + From: "Rujith S. de Silva" <desilva@netbox.com> + Files: pod/perlxs.pod + + Title: "Improved diagnostic docs for here-documents" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.970921074004.21358G-100000@julie.teleport.com> + Files: pod/perldiag.pod + + Title: "[POD patch] do-FILE forces scalar context." + From: Robin Houston <robin@oneworld.org> + Msg-ID: <199709221553.QAA28409@carryon.oneworld.org> + Files: pod/perlfunc.pod + + Title: "perlop.pop. Behaviour of C<qq#hi#> vs C<qq #hi#>." + From: abigail@fnx.com (Abigail) + Msg-ID: <199709220107.VAA27064@fnx.com> + Files: pod/perlop.pod + + Title: "Clarify exec docs in perlfunc.pod" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199710081353.OAA00834@crypt.compulink.co.uk> + Files: pod/perlfunc.pod + + Title: "Documentation patch for perlguts.pod--document tainting routines" + From: Dan Sugalski <sugalskd@osshe.edu> + Msg-ID: <3.0.3.32.19971007165226.02fd2cd4@osshe.edu> + Files: pod/perlguts.pod + + Title: "Man perlfunc: incorrect split example" + From: Joerg Porath <Joerg.Porath@informatik.tu-chemnitz.de> + Msg-ID: <199709240620.IAA30928@pandora.hrz.tu-chemnitz.de> + Files: pod/perlfunc.pod + + Title: "Improve "Use of inherited AUTOLOAD for non-method" disgnostic" + From: rjray@uswest.com (Randy J. Ray) + Msg-ID: <199709231710.LAA08854@tremere.ecte.uswc.uswest.com> + Files: pod/perldiag.pod + + Title: "Document split-with-limit on empty string perl4/perl5 change" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Gisle Aas <aas@bergen.sn.no>, Hugo + van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199709221419.PAA03987@crypt.compulink.co.uk>, + <hiuvttdkv.fsf@bergen.sn.no> + Files: pod/perlfunc.pod pod/perltrap.pod URI/URL/http.pm t/op/split.t + + Title: "Clarify close() docs" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710081653.MAA20611@monk.mps.ohio-state.edu> + Files: pod/perlfunc.pod + + Title: "perldiag log & sqrt - refer to Math::Complex package" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199710042129.AAA20367@alpha.hut.fi> + Files: pod/perldiag.pod + + Title: "perlfunc.pod: sysread, syswrite docs" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199710061910.WAA15266@alpha.hut.fi> + Files: pod/perlfunc.pod + + Title: "Document //gc" + From: abigail@fnx.com (Abigail) + Msg-ID: <199709232302.TAA27947@fnx.com> + Files: pod/perlop.pod + + Title: "repeating #! switches" + From: Chip Salzenberg <chip@rio.atlantic.net>, Robin Barker + <rmb1@cise.npl.co.uk> + Msg-ID: <199709241736.NAA25855@rio.atlantic.net>, + <24778.9709241501@tempest.cise.npl.co.uk> + Files: pod/perlrun.pod + + Title: "Re: taint documentation bug" + From: Ken Estes <estes@ms.com>, Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.971006121349.10551X-100000@usertest.teleport.com> + Files: pod/perlsec.pod + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "FileHandle.pm fails if Exporter has not been loaded previously" + From: jan.dubois@ibm.net (Jan Dubois) + Msg-ID: <3445e05b.17874041@smtp2.ibm.net> + Files: lib/FileHandle.pm + + Title: "Prefer startperl path over perlpath in MakeMaker" + From: Andreas Klussmann <andreas@infosys.heitec.de> + Msg-ID: <199709162017.WAA05043@troubadix.infosys.heitec.net> + Files: lib/ExtUtils/MM_Unix.pm + + Title: "Sys::Hostname fails under Solaris 2.5 when setuid" + From: Patrick Hayes <Patrick.Hayes.CAP_SESA@renault.fr> + Msg-ID: <199708201240.OAA04243@goblin.renault.fr> + Files: lib/Sys/Hostname.pm + + Title: "Cwd::getcwd cannot handle path contains '0' element" + From: Hironori Ikura <hikura@tcc.co.jp>, Hironori Ikura + <hikura@trans-nt.com>, Stephen Zander <srz@mckesson.com> + Msg-ID: <19970830060142J.hikura@matsu.tcc.co.jp>, + <m0x4TzI-0003F1C@wsuse5.mckesson.com> + Files: lib/Cwd.pm + + Title: "Getopt::Long 2.11" + From: JVromans@squirrel.nl (Johan Vromans) + Msg-ID: <m0xBcdR-000RArC@plume.nl.compuware.com> + Files: lib/Getopt/Long.pm + + Title: "IO::Socket autoflush by default, assume tcp and PeerAddr" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Andy Dougherty + <doughera@newton.phys.lafayette.edu>, Gisle Aas + <aas@bergen.sn.no> + Msg-ID: <E0x9WpH-0003HT-00@ursa.cus.cam.ac.uk>, + <Pine.SUN.3.96.970915115856.23236F-100000@newton.phys>, + <hvi07zvo9.fsf@bergen.sn.no> + Files: ext/IO/lib/IO/Socket.pm + + Title: "Syslog.pm and missing _PATH_LOG" + From: Ulrich Pfeifer <upf@de.uu.net> + Msg-ID: <p5iuw1cris.fsf@knowway.de.uu.net> + Files: lib/Sys/Syslog.pm + + Title: "Undocumented: $Test::Harness::switches" + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9708272110.AA26904@o09.xray.mpe.mpg.de> + Files: lib/Test/Harness.pm + + Title: "Patches for lib/Math/Complex.pm and t/lib/complex.t" + From: Jarkko Hietaniemi <jhi@anna.in-berlin.de> + Msg-ID: <199709102009.WAA27428@anna.in-berlin.de> + Files: lib/Math/Complex.pm t/lib/complex.t + + Title: "Win32: Install.pm not correctly comparing binary files." + From: Jeff Urlwin <jurlwin@access.digex.net> + Msg-ID: <01BCBFAA.E325C4A0.jurlwin@access.digex.net> + Files: lib/ExtUtils/Install.pm + + Title: "Document that File::Find doesn't follow symlinks" + From: Greg Ward <greg@bic.mni.mcgill.ca> + Msg-ID: <199708191853.OAA07111@bottom.bic.mni.mcgill.ca> + Files: lib/File/Find.pm + + Title: "fix subroutines called in a void context in perl5db.pl" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0x6Gsa-0004VR-00@ursa.cus.cam.ac.uk> + Files: lib/perl5db.pl + + Title: "xsubpp fix to allow #ifdef's around entire XSubs" + From: John Tobey <jtobey@user1.channel1.com> + Msg-ID: <199709070034.AAA16457@remote119> + Files: lib/ExtUtils/xsubpp + + Title: "Banishing eval from getopt.pl and Getopt/Std.pm" + From: "John L. Allen" <allen@gateway.grumman.com> + Msg-ID: <Pine.SOL.3.91.970920154720.3683A@gateway> + Files: lib/getopt.pl lib/Getopt/Std.pm + + Title: "further complex number patches" + From: Jarkko Hietaniemi <jhi@iki.fi>, d-lewart@uiuc.edu (Daniel S. Lewart) + Msg-ID: <199709221009.FAA21216@staff2.cso.uiuc.edu>, + <199709221216.PAA15130@alpha.hut.fi> + Files: lib/Math/Complex.pm t/lib/complex.t + + Title: "Trap Time::Local infinite loop" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199710030030.BAA17372@crypt.compulink.co.uk> + Files: lib/Time/Local.pm + + Title: "Cosmetic Test::Harness patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710032226.SAA15354@monk.mps.ohio-state.edu> + Files: lib/Test/Harness.pm + + Title: "ExtUtil::Install sub my_cmp needs to binmode its files" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen Potter + <spp@psa.pencom.com> + Msg-ID: <199710010617.BAA02037@psisa.psa.pencom.com>, + <199710011819.OAA03288@aatma.engin.umich.edu> + Files: lib/ExtUtils/Install.pm + + Title: "Enable make test "TEST_FILES=t/*.t.were_failing"" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710032231.SAA15364@monk.mps.ohio-state.edu> + Files: lib/ExtUtils/MM_Unix.pm + + Title: "Fix for autouse.pm" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710071734.NAA19462@monk.mps.ohio-state.edu> + Files: lib/autouse.pm + + Title: "Math::Complex fixes - fixes problems on m68-linux" + From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com> + Msg-ID: <199709301422.HAA24368@koah.research.nokia.com> + Files: lib/Math/Complex.pm + + Title: "Updated CPAN.pm for 5.004_04" + From: koenig@anna.mind.de (Andreas J. Koenig) + Msg-ID: <sfcpvpv8teo.fsf@anna.in-berlin.de> + Files: lib/CPAN.pm lib/CPAN/FirstTime.pm + + Title: "debugger bug with 'c subname'" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199709232331.TAA04546@monk.mps.ohio-state.edu> + Files: lib/perl5db.pl + + Title: "Fix atan2 & restrict $t to (-pi,pi] instead of to [-pi,pi]" + From: Daniel S. Lewart, Jarkko Hietaniemi + <jarkko.hietaniemi@research.nokia.com> + Msg-ID: <199710010939.CAA00964@koah.research.nokia.com> + Files: lib/Math/Complex.pm + + Title: "Cwd::fastcwd needs changes to work with tainting" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk>, Ulrich Pfeifer + <pfeifer@wait.de>, Tim Bunce + Msg-ID: <yfmwwk6y0bc.ulp@gretchen.informatik.uni-dortmund.de> + Files: lib/Cwd.pm + + Title: "use autouse: requires prototype now" + From: user@agate.berkeley.edu + Msg-ID: <9709220450.AA0380@tuzik.HIP.Berkeley.EDU> + Files: lib/autouse.pm + + Title: ""use base qw(Foo Bar);" to set @ISA at compile time" + From: Gisle Aas <gisle@aas.no>, Graham Barr <gbarr@pobox.com>, Graham Barr + <gbarr@ti.com>, Tim Bunce <Tim.Bunce@ig.co.uk>, + jan.dubois@ibm.net (Jan Dubois), larry@wall.org (Larry + Wall) + Msg-ID: <199710022151.WAA21250@toad.ig.co.uk>, + <199710031613.JAA11286@wall.org>, + <199710040829.KAA16739@furu.g.aas.no>, + <3434E4C6.AE24135E@ti.com>, <343C2278.7DC1ADC6@pobox.com>, + <343ec306.50394803@smtp-gw01.ny.us.ibm.net> + Files: lib/base.pm + + Title: "Further Math/Complex.pm enhancements" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199710132055.XAA02086@alpha.hut.fi> + Files: lib/Math/Complex.pm t/lib/complex.t + + Title: "Further Math::Complex fixes" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199710120933.MAA01165@alpha.hut.fi> + Files: lib/Math/Complex.pm + + ------ OTHER CHANGES ------ + + Title: "POD patches w.r.t. $^S" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710030001.UAA14241@monk.mps.ohio-state.edu> + Files: ../pod/perlfunc.pod ../pod/perlvar.pod + + Title: "libperl.sl on HP-UX 10.20" + From: "Darren/Torin/Who Ever..." <torin@daft.com>, Hugo van der Sanden + <hv@crypt.compulink.co.uk> + Msg-ID: <199709250003.BAA18085@crypt.compulink.co.uk>, + <873emkbpit.fsf@perv.daft.com> + Files: + + Title: "myconfig / perl -V: remove randbits and add prototype" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199709290857.JAA07706@toad.ig.co.uk> + Files: myconfig + + Title: "Emacs CPerl update for 5.004_04" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710140835.EAA26825@monk.mps.ohio-state.edu> + Files: emacs/cperl-mode.el + + Title: "Enhance perly.fixer to help porters." + From: Tim Bunce + Files: perly.fixer + + ------ PORTABILITY - WIN32 ------ + + Title: "Fix win32/Makefile for perl95" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: win32/Makefile win32/makefile.mk + + Title: "Win32 archnames" + From: Bill Middleton <wmiddlet@Adobe.COM>, Gurusamy Sarathy + <gsar@engin.umich.edu>, Peter Prymmer <pvhp@forte.com>, Tim + Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199709111929.PAA22488@aatma.engin.umich.edu>, + <341719E4.4923@forte.com>, + <Pine.GSO.3.95.970905123145.12361B-100000@ducks> + Files: win32/config_H.bc win32/config_H.vc + + Title: "pl2bat.bat -> pl2bat.pl change in win32/pod.mak" + From: jan.dubois@ibm.net (Jan Dubois) + Msg-ID: <3411ee6f.9143607@smtp-gw01.ny.us.ibm.net> + Files: win32/pod.mak + + Title: "Add test-notty target to Win32 Makefile" + From: jan.dubois@ibm.net (Jan Dubois) + Msg-ID: <343f5106.12461608@smtp2.ibm.net> + Files: win32/Makefile + + Title: "Bug in Win32::GetShortPathName" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710092229.SAA21556@aatma.engin.umich.edu> + Files: win32/win32.c + + Title: "Fix NT handles leak." + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710111319.JAA10918@aatma.engin.umich.edu> + Files: win32/win32io.c win32/win32sck.c + + Title: "fix socket init duality on win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710111523.LAA12407@aatma.engin.umich.edu> + Files: win32/win32sck.c + + ------ PORTABILITY - GENERAL ------ + + Title: "Tweak to hints/machten.sh: stop t/lib/complex.t from failing" + From: Dominic Dunlop <domo@tcp.ip.lu> + Msg-ID: <v03110700b06a30bdfc42@[194.51.248.80]> + Files: hints/machten.sh + + Title: "Irix 6.2 build problem - so_locations" + From: "Billinghurst, David" <David.Billinghurst@riotinto.com.au> + Msg-ID: <D54B1932FFB4CF11B5C80000F8018BD2907E31@CRCMAIL> + Files: hints/irix_6.sh + + Title: "Porting/pumpkin.pod version 1.13" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970828142011.27416A-100000@newton.phys> + Files: Porting/pumpkin.pod + + Title: "lib/timelocal.t fails test 1 for VMS 7.1" + From: Dan Sugalski <sugalsd@lbcc.cc.or.us> + Msg-ID: <3.0.3.32.19970908112449.0087bc90@stargate.lbcc.cc.or.us> + Files: vms/vmsish.h vms/vms.c + + Title: "Patches to updated README.VMS for Perl 5.004_04" + From: Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us> + Msg-ID: <3.0.3.32.19970918100648.008b1c60@stargate.lbcc.cc.or.us> + Files: README.vms + + Title: "Fix perl build on Digital UNIX after JDK installs libnet.so" + From: Spider Boardman <spider@orb.nashua.nh.us> + Msg-ID: <199709191826.OAA18040@Orb.Nashua.NH.US> + Files: hints/dec_osf.sh + + Title: "Updated README.VMS for Perl 5.004_04" + From: Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us> + Msg-ID: <3.0.3.32.19970912091524.008a3620@stargate.lbcc.cc.or.us> + Files: README.vms + + Title: "Dynixptx hints" + From: bruce@aps.org ("Bruce P. Schuck") + Msg-ID: <Pine.PTX.3.95.971002104651.12112G-200000@lancelot.aps.org> + Files: hints/dynixptx.sh + + Title: "Minor OS/2 patch for 4_03" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710032224.SAA15345@monk.mps.ohio-state.edu> + Files: os2/os2.c + + Title: "OS2::REXX improvements" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199709272214.SAA08638@monk.mps.ohio-state.edu> + Files: os2/Changes os2/OS2/REXX/Makefile.PL os2/OS2/REXX/REXX.pm + + Title: "hints/qnx.sh update" + From: Norton Allen <allen@huarp.harvard.edu> + Msg-ID: <199709261508.LAA07889@dolores.harvard.edu> + Files: hints/qnx.sh + + Title: "New hints file for IBM OS/390 OpenEdition (MVS)" + From: pvhp@forte.com (Peter Prymmer) + Msg-ID: <9709240106.AA26484@forte.com> + Files: hints/os390.sh + + Title: "OS/2 Hints" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710130631.CAA25426@monk.mps.ohio-state.edu> + Files: hints/os2.sh + + ------ TESTS ------ + + Title: "op/glob.t test failure under Win32 with CVS" + From: Warren Jones <wjones@tc.fluke.com> + Msg-ID: <97Aug26.091048pdt.35761-1@gateway.fluke.com> + Files: t/op/glob.t + + Title: "tests fail if localhost/loopback address not defined" + From: David McLean <David McLean<davem@icc.gsfc.nasa.gov>>, David McLean + <davem@icc.gsfc.nasa.gov> + Msg-ID: <34048947.2944@icc.gsfc.nasa.gov> + Files: t/lib/io_sock.t t/lib/io_udp.t + + Title: "Improve pragma/locale test 102 - and don't fail, just warn" + From: Jarkko Hietaniemi <jhi@anna.in-berlin.de> + Files: t/pragma/locale.t + + Title: "Invalid test output in t/op/taint.t in trial 1" + From: Dan Sugalski <sugalsd@lbcc.cc.or.us> + Msg-ID: <3.0.3.32.19970919160918.00857a50@stargate.lbcc.cc.or.us> + Files: t/op/taint.t + + Title: "Identify t/*/*.t test failing because of file permissions" + From: koenig@anna.mind.de (Andreas J. Koenig) + Msg-ID: <sfcraah0xvy.fsf@anna.in-berlin.de> + Files: t/TEST + + Title: "fix poor t/op/runlevel.t test" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Hugo van der Sanden + <hv@crypt.compulink.co.uk>, Norton Allen + <allen@huarp.harvard.edu> + Msg-ID: <199709261458.KAA28611@dolores.harvard.edu> + Files: t/op/runlevel.t + + ------ UTILITIES ------ + + Title: "Missing 'require' in auto-generated .pm by h2xs" + From: davidk@tor.securecomputing.com (David Kerry) + Msg-ID: <97Aug27.131618edt.11650@janus.tor.securecomputing.com> + Files: utils/h2xs.PL + + Title: "Perldoc tiny patch to avoid $0" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199709122141.RAA16846@monk.mps.ohio-state.edu> + Files: utils/perldoc.PL + + Title: "h2ph broken in 5.004_02" + From: David Mazieres <dm@reeducation-labor.lcs.mit.edu>, + kstar@www.chapin.edu (Kurt D. Starsinic) + Msg-ID: <199708201454.KAA05122@reeducation-labor.lcs.mit.edu>, + <199708201700.KAA02621@www.chapin.edu> + Files: utils/h2ph.PL + + Title: "add key_t caddr_t to h2ph", "eg/sysvipc/ipcsem bug", "update + hints/bsdos.sh" + From: Tony Sanders <sanders@bsdi.com> + Msg-ID: <199708272301.RAA12803@austin.bsdi.com> + Files: eg/sysvipc/ipcsem utils/h2ph.PL + + Title: "perldoc search ., lib and blib/* if -f 'Makefile.PL'" + From: Tim Bunce + Msg-ID: <199708251732.KAA19299@gadget.cscaper.com> + Files: utils/perldoc.PL + + Title: "5.004m4t1: perlbug: NIS domainname gets into wrong places" + From: koenig@anna.mind.de (Andreas J. Koenig) + Msg-ID: <sfcg1qy38as.fsf@anna.in-berlin.de> + Files: utils/perlbug.PL + + Title: "add better local patch info to perlbug", "perlbug checks perl + build/run version changes" + From: Tim.Bunce@ig.co.uk + Files: utils/perlbug.PL + + Title: "perldoc - suggest modules if requested module not found" + From: Anthony David <adavid@netinfo.com.au> + Msg-ID: <3439CD83.6969@netinfo.com.au> + Files: utils/perldoc.PL + + Title: "perldoc mail::foo tries to read binary /usr/ucb/mail" + From: "Joseph Moof-in' Hall" <joseph@cscaper.com>, Tim Bunce + Msg-ID: <199710082014.NAA00808@gadget.cscaper.com> + Files: utils/perldoc.PL + + Title: "perldoc -f setpwent (for example) returns no descriptive text" + From: Tim Bunce + Files: utils/perldoc.PL + + Title: "perldoc diffs: don't search auto - much faster" + From: "Joseph N. Hall" <joseph@5sigma.com> + Msg-ID: <MailDrop1.2d7dPPC.971012211957@screechy.cscaper.com> + Files: utils/perldoc.PL + ---------------- @@ -1764,7 +1764,6 @@ EOM ;; linux) osname=linux case "$3" in - 1*) osvers=1 ;; *) osvers="$3" ;; esac ;; @@ -99,8 +99,11 @@ and Configure will use the defaults from then on. After it runs, Configure will perform variable substitution on all the *.SH files and offer to run make depend. -Configure supports a number of useful options. Run B<Configure -h> -to get a listing. To compile with gcc, for example, you can run +Configure supports a number of useful options. Run B<Configure -h> to +get a listing. See the Porting/Glossary file for a complete list of +Configure variables you can set and their definitions. + +To compile with gcc, for example, you should run sh Configure -Dcc=gcc @@ -325,12 +328,14 @@ and the following directories for manual pages: (Actually, Configure recognizes the SVR3-style /usr/local/man/l_man/man1 directories, if present, and uses those -instead.) The module man pages are stuck in that strange spot so that +instead.) + +The module man pages are stuck in that strange spot so that they don't collide with other man pages stored in /usr/local/man/man3, and so that Perl's man pages don't hide system man pages. On some systems, B<man less> would end up calling up Perl's less.pm module man -page, rather than the less program. (This location may change in a -future release of perl.) +page, rather than the less program. (This default location will likely +change to /usr/local/man/man3 in a future release of perl.) Note: Many users prefer to store the module man pages in /usr/local/man/man3. You can do this from the command line with @@ -423,6 +428,9 @@ installed on multiple systems. Here's one way to do that: make test make install cd /tmp/perl5 + # Edit lib/<archname>/<version>/Config.pm to change all the + # install* variables back to reflect where everything will + # really be installed. tar cvf ../perl5-archive.tar . # Then, on each machine where you want to install perl, cd /usr/local # Or wherever you specified as $prefix @@ -459,14 +467,17 @@ compatibility, answer "y". On the other hand, if you are embedding perl into another application and want the maximum namespace protection, then you probably ought to -answer "n" when Configure asks if you want binary compatibility. +answer "n" when Configure asks if you want binary compatibility, or +disable it from the Configure command line with + + sh Configure -Ud_bincompat3 The default answer of "y" to maintain binary compatibility is probably appropriate for almost everyone. -In a related issue, old extensions may possibly be affected by the changes -in the Perl language in the current release. Please see pod/perldelta for -a description of what's changed. +In a related issue, old extensions may possibly be affected by the +changes in the Perl language in the current release. Please see +pod/perldelta.pod for a description of what's changed. =head2 Selecting File IO mechanisms @@ -626,7 +637,7 @@ to point to the perl build directory. The only reliable answer is that you should specify a different directory for the architecture-dependent library for your -DDEBUGGING -version of perl. You can do this with by changing all the *archlib* +version of perl. You can do this by changing all the *archlib* variables in config.sh, namely archlib, archlib_exp, and installarchlib, to point to your new architecture-dependent library. @@ -1159,9 +1170,9 @@ should run plain 'make' before 'make test' otherwise you won't have a complete build). If 'make test' doesn't say "All tests successful" then something went wrong. See the file t/README in the t subdirectory. -If you want to run make test in the background you should Note that you can't run the tests in background if this disables -opening of /dev/tty. +opening of /dev/tty. You can use 'make test-notty' in that case but +a few tty tests will be skipped. If make test bombs out, just cd to the t directory and run ./TEST by hand to see if it makes any difference. If individual tests @@ -1174,10 +1185,10 @@ individual subtests is to cd to the t directory and run ./perl harness -(this assumes that most tests succeed, since harness uses +(this assumes that most basic tests succeed, since harness uses complicated constructs). -You can also read the individual tests to see if there are any helpful +You should also read the individual tests to see if there are any helpful comments that apply to your system. Note: One possible reason for errors is that some external programs @@ -1343,13 +1354,13 @@ to hand-edit some of the converted files to get them to parse correctly. For example, h2ph breaks spectacularly on type casting and certain structures. -=head installhtml --help +=head1 installhtml --help Some sites may wish to make perl documentation available in HTML format. The installhtml utility can be used to convert pod -documentation into linked HTML files and install install them. +documentation into linked HTML files and install them. -The following command-line is an example of the one we use to convert +The following command-line is an example of one used to convert perl documentation: ./installhtml \ @@ -1369,6 +1380,9 @@ see warnings like "no title", "unexpected directive" and "cannot resolve" as the files are processed. We are aware of these problems (and would welcome patches for them). +You may find it helpful to run installhtml twice. That should reduce +the number of "cannot resolve" warnings. + =head1 cd pod && make tex && (process the latex files) Some sites may also wish to make the documentation in the pod/ directory @@ -1417,10 +1431,14 @@ generate the documentation. =head1 AUTHOR -Andy Dougherty doughera@lafcol.lafayette.edu , borrowing very heavily -from the original README by Larry Wall, and also with lots of helpful -feedback from the perl5-porters@perl.org folks. +Original author: Andy Dougherty doughera@lafcol.lafayette.edu , +borrowing very heavily from the original README by Larry Wall, +with lots of helpful feedback and additions from the +perl5-porters@perl.org folks. + +If you have problems or questions, please see L<"Reporting Problems"> +above. =head1 LAST MODIFIED -$Id: INSTALL,v 1.22 1997/08/01 15:39:14 doughera Released $ +$Id: INSTALL,v 1.28 1997/10/10 16:50:59 doughera Released $ @@ -206,7 +206,6 @@ ext/SDBM_File/typemap SDBM extension interface types ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines -ext/util/extliblist Used by extension Makefile.PL to make lib lists ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info form.h Public declarations for the above @@ -275,6 +274,7 @@ hints/next_3_0.sh Hints for named architecture hints/next_4.sh Hints for named architecture hints/opus.sh Hints for named architecture hints/os2.sh Hints for named architecture +hints/os390.sh Hints for named architecture hints/powerux.sh Hints for named architecture hints/qnx.sh Hints for named architecture hints/sco.sh Hints for named architecture @@ -400,6 +400,7 @@ lib/User/pwent.pm By-name interface to Perl's builtin getpw* lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/autouse.pm Load and call a function only when it's used +lib/base.pm Establish IS-A relationship at compile time lib/bigfloat.pl An arbitrary precision floating point package lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package @@ -652,6 +653,7 @@ t/lib/db-btree.t See if DB_File works t/lib/db-hash.t See if DB_File works t/lib/db-recno.t See if DB_File works t/lib/dirhand.t See if DirHandle works +t/lib/dosglob.t See if File::DosGlob works t/lib/english.t See if English works t/lib/env.t See if Env works t/lib/filecache.t See if FileCache works diff --git a/Makefile.SH b/Makefile.SH index 86fd6ed02e..f2a4a9fbc7 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -52,6 +52,9 @@ true) aixinstdir=`pwd | sed 's/\/UU$//'` linklibperl="-L $archlibexp/CORE -L $aixinstdir -lperl" ;; + hpux10*) + linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+b$archlibexp/CORE -lperl" + ;; esac ;; *) pldlflags='' @@ -303,13 +306,13 @@ perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) # This version, if specified in Configure, does ONLY those scripts which need # set-id emulation. Suidperl must be setuid root. It contains the "taint" @@ -317,7 +320,7 @@ quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs # has been invoked correctly. suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) !NO!SUBS! @@ -341,6 +344,8 @@ preplibrary: miniperl lib/Config.pm $(plextract) autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm # Take care to avoid modifying lib/Config.pm without reason +# (If trying to create a new port and having problems with the configpm script, +# try 'make minitest' and/or commenting out the tests at the end of configpm.) lib/Config.pm: config.sh miniperl configpm ./miniperl configpm tmp sh mv-if-diff tmp lib/Config.pm @@ -382,12 +387,14 @@ install.html: all installhtml run_byacc: FORCE @ echo 'Expect' 113 shift/reduce and 1 reduce/reduce conflict $(BYACC) -d perly.y + chmod 664 perly.c sh $(shellflags) ./perly.fixer y.tab.c perly.c sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c echo 'extern YYSTYPE yylval;' >>y.tab.h cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h perly.h - - perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms + chmod 664 vms/perly_c.vms vms/perly_h.vms + perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms # We don't want to regenerate perly.c and perly.h, but they might # appear out-of-date after a patch is applied or a new distribution is @@ -422,13 +429,13 @@ regen_headers: FORCE # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): miniperl preplibrary FORCE - @sh ext/util/make_ext static $@ LIBPERL_A=$(LIBPERL) + @sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE - @sh ext/util/make_ext dynamic $@ LIBPERL_A=$(LIBPERL) + @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE - @sh ext/util/make_ext static $@ LIBPERL_A=$(LIBPERL) + @sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) clean: _tidy _mopup @@ -453,7 +460,7 @@ _tidy: -cd utils; $(MAKE) clean -cd x2p; $(MAKE) clean -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ - sh ext/util/make_ext clean $$x ; \ + sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \ done # Do not 'make _cleaner' directly. @@ -463,7 +470,7 @@ _cleaner: -cd utils; $(MAKE) realclean -cd x2p; $(MAKE) realclean -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ - sh ext/util/make_ext realclean $$x ; \ + sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \ done rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl rm -rf $(addedbyconf) @@ -482,11 +489,13 @@ _cleaner: lint: perly.c $(c) lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz -# Need to unset during recursion to go out of loop +# Need to unset during recursion to go out of loop. +# The README below ensures that the dependency list is never empty and +# that when MAKEDEPEND is empty $(FIRSTMAKEFILE) doesn't need rebuilding. MAKEDEPEND = Makefile makedepend -$(FIRSTMAKEFILE): $(MAKEDEPEND) +$(FIRSTMAKEFILE): README $(MAKEDEPEND) $(MAKE) depend MAKEDEPEND= config.h: config_h.SH config.sh @@ -497,7 +506,7 @@ perl.exp: perl_exp.SH config.sh # When done, touch perlmain.c so that it doesn't get remade each time. depend: makedepend - sh ./makedepend + sh ./makedepend MAKE=$(MAKE) - test -s perlmain.c && touch perlmain.c cd x2p; $(MAKE) depend @@ -523,8 +532,10 @@ minitest: miniperl - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \ && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t </dev/tty -# handy way to run perlbug -ok without having to install and run the +# Handy way to run perlbug -ok without having to install and run the # installed perlbug. We don't re-run the tests here - we trust the user. +# Please *don't* use this unless all tests pass. +# If you want to report test failures, just use "perlbug -Ilib". ok: ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' diff --git a/Porting/makerel b/Porting/makerel index bc472eee36..f719a5e936 100755 --- a/Porting/makerel +++ b/Porting/makerel @@ -27,6 +27,7 @@ $vers.= sprintf( "_%02d", $subversion) if $subversion; $perl = "perl$vers"; $reldir = "$relroot/$perl"; +$reldir .= "-$ARGV[0]" if $ARGV[0]; print "\nMaking a release for $perl in $reldir\n\n"; @@ -47,7 +48,9 @@ print "\n"; print "Setting file permissions...\n"; -system("find . -type f -print | xargs chmod -w"); +system("find . -type f -print | xargs chmod -w"); +system("find . -type d -print | xargs chmod g-s"); +system("find t -name '*.t' -print | xargs chmod +x"); system("chmod +w configure"); # special case (see pumpkin.pod) @exe = qw( Configure @@ -76,7 +79,7 @@ print "\n"; print "Creating $reldir release directory...\n"; die "$reldir release directory already exists\n" if -e "../$perl"; -die "$reldir.tar.gz release file already exists\n" if -e "../$perl.tar.gz"; +die "$reldir.tar.gz release file already exists\n" if -e "../$reldir.tar.gz"; mkdir($reldir, 0755) or die "mkdir $reldir: $!\n"; print "\n"; diff --git a/Porting/patchls b/Porting/patchls index f4de529f46..1d4bd5ac40 100755 --- a/Porting/patchls +++ b/Porting/patchls @@ -9,33 +9,37 @@ # modify it under the same terms as Perl itself. # # With thanks to Tom Horsley for the seed code. -# -# $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $ + use Getopt::Std; use Text::Wrap qw(wrap $columns); use Text::Tabs qw(expand unexpand); use strict; +use vars qw($VERSION); + +$VERSION = 2.04; sub usage { die q{ patchls [options] patchfile [ ... ] - -i Invert: for each patched file list which patch files patch it. -h no filename headers (like grep), only the listing. -l no listing (like grep), only the filename headers. + -i Invert: for each patched file list which patch files patch it. -c Categorise the patch and sort by category (perl specific). -m print formatted Meta-information (Subject,From,Msg-ID etc). -p N strip N levels of directory Prefix (like patch), else automatic. -v more verbose (-d for noisy debugging). -f F only list patches which patch files matching regexp F (F has $ appended unless it contains a /). + other options for special uses: -I just gather and display summary Information about the patches. + -4 write to stdout the PerForce commands to prepare for patching. + -M T Like -m but only output listed meta tags (eg -M 'Title From') + -W N set wrap width to N (defaults to 70, use 0 for no wrap) } } -$columns = 70; - $::opt_p = undef; # undef != 0 $::opt_d = 0; $::opt_v = 0; @@ -45,11 +49,21 @@ $::opt_h = 0; $::opt_l = 0; $::opt_c = 0; $::opt_f = ''; + +# special purpose options $::opt_I = 0; +$::opt_4 = 0; # output PerForce commands to prepare for patching +$::opt_M = ''; # like -m but only output these meta items (-M Title) +$::opt_W = 70; # set wrap width columns (see Text::Wrap module) usage unless @ARGV; -getopts("mihlvcp:f:I") or usage; +getopts("mihlvc4p:f:IM:W:") or usage; + +$columns = $::opt_W || 9999999; + +$::opt_m = 1 if $::opt_M; +my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID'); my %cat_title = ( 'BUILD' => 'BUILD PROCESS', @@ -57,7 +71,7 @@ my %cat_title = ( 'DOC' => 'DOCUMENTATION', 'LIB' => 'LIBRARY AND EXTENSIONS', 'PORT1' => 'PORTABILITY - WIN32', - 'PORT2' => 'PORTABILITY - OTHER', + 'PORT2' => 'PORTABILITY - GENERAL', 'TEST' => 'TESTS', 'UTIL' => 'UTILITIES', 'OTHER' => 'OTHER CHANGES', @@ -84,6 +98,8 @@ my %ls; # Index: embed.h my($in, $prevline, $prevtype, $ls); +my(@removed, @added); +my $prologue = 1; # assume prologue till patch or /^exit\b/ seen foreach my $argv (@ARGV) { $in = $argv; @@ -96,16 +112,24 @@ foreach my $argv (@ARGV) { my $type; while (<F>) { unless (/^([-+*]{3}) / || /^(Index):/) { - # not an interesting patch line but possibly meta-information + # not an interesting patch line + # but possibly meta-information or prologue + if ($prologue) { + push @added, $1 if /^touch\s+(\S+)/; + push @removed, $1 if /^rm\s+(?:-f)?\s*(\S+)/; + $prologue = 0 if /^exit\b/; + } next unless $::opt_m; - $ls->{From}{$1}=1 if /^From:\s+(.*\S)/i; - $ls->{Title}{$1}=1 if /^Subject:\s+(?:Re: )?(.*\S)/i; - $ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i; - $ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i; + $ls->{From}{$1}=1,next if /^From:\s+(.*\S)/i; + $ls->{Title}{$1}=1,next if /^Subject:\s+(?:Re: )?(.*\S)/i; + $ls->{'Msg-ID'}{$1}=1,next if /^Message-Id:\s+(.*\S)/i; + $ls->{Date}{$1}=1,next if /^Date:\s+(.*\S)/i; + $ls->{$1}{$2}=1,next if /^([-\w]+):\s+(.*\S)/; next; } $type = $1; next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/; + $prologue = 0; print "Last: $prevline","This: ${_}Got: $1\n\n" if $::opt_d; @@ -113,12 +137,12 @@ foreach my $argv (@ARGV) { # Patch copes with this, so must we. It's also handy for # documenting manual changes by simply adding Index: lines # to the file which describes the problem bing fixed. - add_file($ls, $1), next if /^Index:\s+(.*)/; + add_file($ls, $1), next if /^Index:\s+(\S+)/; if ( ($type eq '---' and $prevtype eq '***') # Style 1 or ($type eq '+++' and $prevtype eq '---') # Style 2 ) { - if (/^[-+*]{3} (\S+)\s+.*\d\d:\d\d:\d\d/) { # double check + if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check add_file($ls, $1); } else { @@ -141,9 +165,9 @@ foreach my $argv (@ARGV) { print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1; -my @ls = sort { - $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in} -} values %ls; +# --- Firstly we filter and sort as needed --- + +my @ls = values %ls; if ($::opt_f) { # filter out patches based on -f <regexp> my $out; @@ -158,6 +182,24 @@ if ($::opt_f) { # filter out patches based on -f <regexp> } @ls; } +@ls = sort { + $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in} +} @ls; + + +# --- Handle special modes --- + +if ($::opt_4) { + print map { "p4 delete $_\n" } @removed if @removed; + print map { "p4 add $_\n" } @added if @added; + my @patches = grep { $_->{is_in} } @ls; + my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches; + delete @patched{@added}; + my @patched = sort keys %patched; + print map { "p4 edit $_\n" } @patched if @patched; + exit 0; +} + if ($::opt_I) { my $n_patches = 0; my($in,$out); @@ -171,12 +213,16 @@ if ($::opt_I) { my @all_out = sort keys %all_out; my @missing = grep { ! -f $_ } @all_out; print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n"; + print "(use -v to list patches which patch 'missing' files)\n" + if @missing && !$::opt_v; if ($::opt_v and @missing) { print "Missing files:\n"; foreach $out (@missing) { printf " %-20s\t%s\n", $out, $all_out{$out}; } } + print "Added files: @added\n" if @added; + print "Removed files: @removed\n" if @removed; exit 0+@missing; } @@ -256,11 +302,27 @@ sub list_files_by_patch { $name = $ls->{in} unless defined $name; my @meta; if ($::opt_m) { - foreach(qw(Title From Msg-ID)) { - next unless $ls->{$_}; - my @list = sort keys %{$ls->{$_}}; - push @meta, sprintf "%7s: ", $_; - @list = map { "\"$_\"" } @list if $_ eq 'Title'; + my $meta; + foreach $meta (@show_meta) { + next unless $ls->{$meta}; + my @list = sort keys %{$ls->{$meta}}; + push @meta, sprintf "%7s: ", $meta; + if ($meta eq 'Title') { + @list = map { s/\[?PATCH\]?:?\s*//g; "\"$_\""; } @list + } + elsif ($meta eq 'From') { + # fix-up bizzare addresses from japan and ibm :-) + foreach(@list) { + s:\W+=?iso.*?<: <:; + s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//; + } + } + elsif ($meta eq 'Msg-ID') { + my %from; # limit long threads to one msg-id per site + @list = map { + $from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_); + } @list; + } push @meta, my_wrap(""," ", join(", ",@list)."\n"); } $name = "\n$name" if @meta and $name; diff --git a/Porting/pumpkin.pod b/Porting/pumpkin.pod index 5260e65fcf..6706c6c3c4 100644 --- a/Porting/pumpkin.pod +++ b/Porting/pumpkin.pod @@ -41,6 +41,10 @@ Subscribe by sending the message (in the body of your letter) to perl5-porters-request@perl.org . +Archives of the list are held at: + + http://www.rosat.mpe-garching.mpg.de/mailing-lists/perl-porters/ + =head1 How are Perl Releases Numbered? Perl version numbers are floating point numbers, such as 5.004. @@ -73,9 +77,10 @@ In addition, there may be "developer" sub-versions available. These are not official releases. They may contain unstable experimental features, and are subject to rapid change. Such developer sub-versions are numbered with sub-version numbers. For example, -version 5.004_04 is the 4'th developer version built on top of -5.004. It might include the _01, _02, and _03 changes, but it -also might not. Sub-versions are allowed to be subversive. +version 5.003_04 is the 4'th developer version built on top of +5.003. It might include the _01, _02, and _03 changes, but it +also might not. Sub-versions are allowed to be subversive. (But see +the next section for recent changes.) These sub-versions can also be used as floating point numbers, so you can do things such as @@ -100,6 +105,11 @@ way to distribute important bug fixes without waiting for the developers to untangle all the other problems in the current developer's release. +Trial releases of bug-fix maintenance releases are announced on +perl5-porters. Trial releases use the new subversion number (to avoid +testers installing it over the previous release) and include a 'local +patch' entry in patchlevel.h. + Watch for announcements of maintenance subversions in comp.lang.perl.announce. @@ -1157,14 +1167,14 @@ and/or fcntl() file locking. It's a mess. =back -=head1 AUTHOR - -Andy Dougherty <doughera@lafcol.lafayette.edu>. +=head1 AUTHORS -Additions by Chip Salzenberg <chip@perl.com>. +Original author: Andy Dougherty doughera@lafcol.lafayette.edu . +Additions by Chip Salzenberg chip@perl.com and +Tim Bunce Tim.Bunce@ig.co.uk . All opinions expressed herein are those of the authorZ<>(s). =head1 LAST MODIFIED -$Id: pumpkin.pod,v 1.10.1.1 1997/06/10 20:46:47 timbo Exp $ +$Id: pumpkin.pod,v 1.13 1997/08/28 18:26:40 doughera Released $ diff --git a/README.vms b/README.vms index 9a6a712f4a..4b8c29d345 100644 --- a/README.vms +++ b/README.vms @@ -1,3 +1,383 @@ +Last Revised 11-September-1997 by Dan Sugalski <sugalsd@lbcc.cc.or.us> +Originally by Charles Bailey <bailey@newman.upenn.edu> + +* Intro + +The VMS port of Perl is as functionally complete as any other Perl port +(and as complete as the ports on some Unix systems). The Perl binaries +provide all the Perl system calls that are either available under VMS or +reasonably emulated. There are some incompatibilites in process handling +(e.g the fork/exec model for creating subprocesses doesn't do what you +might expect under Unix), mainly because VMS and Unix handle processes and +sub-processes very differently. + +There are still some unimplemented system functions, and of coursse we +could use modules implementing useful VMS system services, so if you'd like +to lend a hand we'd love to have you. Join the Perl Porting Team Now! + +The current sources and build procedures have been tested on a VAX using +VaxC and Dec C, and on an AXP using Dec C. If you run into problems with +other compilers, please let us know. + +There are issues with varions versions of Dec C, so if you're not running a +relatively modern version, check the Dec C issues section later on in this +document. + +* Other required software + +In addition to VMS, you'll need: + 1) A C compiler. Dec C for AXP, or VAX C, Dec C, or gcc for the + VAX. + 2) A make tool. Dec's MMS (v2.6 or later), or MadGoat's free MMS + analog MMK (available from ftp.madgoat.com/madgoat) both work + just fine. Gnu Make might work, but it's been so long since + anyone's tested it that we're not sure. MMK's free, though, so + go ahead and use that. + + +If you want to include socket support, you'll need a TCP stack and either +Dec C, or socket libraries. See the Socket Support topic for more details. + +* Compiling Perl + +>From the top level of the Perl source directory, do this: + +MMS/DESCRIP=[.VMS]DESCRIP.MMS + +If you're on an Alpha, add /Macro=("__AXP__=1","decc=1") +If you're using Dec C as your C compiler (you are on all alphas), add +/Macro=("decc=1") +If Vac C is your default C compiler and you want to use Dec C, add +/Macro=("CC=CC/DECC") (Don't forget the /macro=("decc=1") +If Dec C is your default C compiler and you want to use Vax C, add +/Macro=("CC=CC/VAXC") +If you want Socket support and are using the SOCKETSHR socket library, add +/Macro=("SOCKETSHR_SOCKETS=1") +If you want Socket support and are using the Dec C RTL socket interface +(You must be using Dec C for this), add /Macro=("DECC_SOCKETS=1") + +If you have multiple /macro= items, combine them together in one /Macro=() +switch, with all the options inside the parentheses separated by commas. + +Samples: + +VMS AXP, with Socketshr sockets: + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("decc=1","__AXP__=1","SOCKETSHR_SOCKETS=1") + +VMS AXP with no sockets + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("decc=1","__AXP__=1") + +VMS AXP with the Dec C RTL sockets + +$MMS/DESCRIP=[.VMS]/Macro=("decc=1","__AXP__=1","DECC_SOCKETS=1") + +VMS VAX with default system compiler, no sockets + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS + +VMS VAX with Dec C compiler, no sockets + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1") + +VMS VAX with Dec C compiler, Dec C RTL sockets + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1","DECC_SOCKETS=1") + +VMS VAX with Dec C compiler, Socketshr sockets + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1","SOCKETSHR_SOCKETS=1") + +Using Dec C is recommended over Vax C. The compiler is newer, and +supported. (Vax C was decommisioned around 1993) Various older versions had +some gotchas, so if you're using a version older than 5.2, check the Dec C +Issues section. + +We'll also point out that Dec C will get you at least a ten-fold increase +in line-oriented IO over Vax C. The optimizer is amazingly better, too. If +you can use Dec C, then you *really*, *really* should. + + +Once you issue your MMS command, sit back and wait. Perl should build and +link without a problem. If it doesn't, check the Gotchas to watch out for +section. If that doesn't help, send some mail to the VMSPERL mailing list. +Instructions are in the Mailing Lists section. + +* Testing Perl + +Once Perl has built cleanly, you need to test it to make sure things work. +This step is very important--there are always things that can go wrong +somehow and get you a dysfunctional Perl. + +Testing is very easy, though, as there's a full test suite in the perl +distribution. To run the tests, enter the *exact* MMS line you used to +compile Perl and add the word "test" to the end, like this: + +Compile Command: + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") + +Test Command: + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") test + +MMS will run all the tests. This may take some time, as there are a lot of +tests. If any tests fail, there will be a note made on-screen. At the end +of all the tests, a summary of the tests, the number passed and failed, and +the time taken will be displayed. + +If any tests fail, it means something's wrong with Perl. If the test suite +hangs (some tests can take upwards of two or three minutes, or more if +you're on an especially slow machine, depending on you machine speed, so +don't be hasty), then the test *after* the last one displayed failed. Don't +install Perl unless you're confident that you're OK. Regardless of how +confident you are, make a bug report to the VMSPerl mailing list. + +If one or more tests fail, you can get more info on the failure by issuing +this command sequence: + +$ SET DEFAULT [.T] +$ @[-.VMS]TEST .typ -v [.subdir]test.T + +where ".typ" is the file type of the Perl images you just built (if you +didn't do anything special, use .EXE), and "[.subdir]test.T" is the test +that failed. For example, with a normal Perl build, if the test indicated +that [.op]time failed, then you'd do this: + +$ SET DEFAULT [.T] +$ @[-.VMS]TEST .EXE -v [.OP]TIME.T + +When you send in a bug report for failed tests, please include the output +from this command, which is run from the main source directory: + +MCR []MINIPERL "-V" + +Note that "-V" really is a capital V in double quotes. This will dump out a +couple of screens worth of config info, and can help us diagnose the problem. + +* Cleaning up and starting fresh + +If you need to recompile from scratch, you have to make sure you clean up +first. There's a procedure to do it--enter the *exact* MMS line you used to +compile and add "realclean" at the end, like this: + +Compile Command: + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") + +Cleanup Command: + +$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") realclean + +If you don't do this, things may behave erratically. They might not, too, +so it's best to be sure and do it. + +* Installing Perl + +There are several steps you need to take to get Perl installed and +running. At some point we'll have a working install in DESCRIP.MMS, but for +right now the procedure's manual, and goes like this. + +1) Create a directory somewhere and define the concealed logical PERL_ROOT +to point to it. For example, DEFINE/TRANS=(CONC,TERM) PERL_ROOT dka200:[perl.] + +2) Copy perl.exe into PERL_ROOT:[000000] + +3) Copy everything in [.LIB] and [.UTILS] (including all the +subdirectories!) to PERL_ROOT:[LIB] and PERL_ROOT:[UTILS]. + +4) Either copy PERLSHR.EXE to SYS$SHARE, or to somewhere globally accessble +and define the logical PERLSHR to point to it (DEFINE PERLSHR +PERL_ROOT:[000000]PERLSHR.EXE or something like that). The PerlShr image +should have W:RE protections on it. (Just W:E triggers increased security in +the image activator. Not a huge problem, but Perl will need to have any +other shared image it accesses INSTALLed. It's a huge pain, so don't unless +you know what you're doing) + +5) Either define the symbol PERL somewhere, such as +SYS$MANAGER:SYLOGIN.COM, to be "PERL :== $PERL_ROOT:[000000]PERL.EXE", or +install Perl into DCLTABLES.EXE )Check out the section "Installing Perl +into DCLTABLES" for more info), or put the image in a directory that's in +your DCL$PATH (if you're using VMS 6.2 or higher). + +6) Optionally define the command PERLDOC as +PERLDOC :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB.POD]PERLDOC.COM -T + +7) Optionally define the command PERLBUG (the Perl bug report generator) as +PERLBUG :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB]PERLBUG.COM" + +* Installing Perl into DCLTABLES + +Courtesy of Brad Hughes: + +Put the following, modified to reflect where your .exe is, in PERL.CLD: + +define verb perl +image perl_root:[exe]perl.exe +cliflags (foreign) + +and then + +$ set command perl /table=sys$common:[syslib]dcltables.exe - + /output=sys$common:[syslib]dcltables.exe +$ install replace sys$common:[syslib]dcltables.exe + +and you don't need perl :== $perl_root:[exe]perl.exe. + +* Changing compile-time things + +Most of the user-definable features of Perl are enabled or disabled in +[.VMS]CONFIG.VMS. There's code in there to Do The Right Thing, but that may +end up being the wrong thing for you. Make sure you understand what you're +doing, since changes here can get you a busted perl. + +Odds are that there's nothing here to change, unless you're on a version of +VMS later than 6.2 and Dec C later than 5.6. Even if you are, the correct +values will still be chosen, most likely. Poking around here should be +unnecessary. + +The one exception is the various *DIR install locations. Changing those +requires changes in genconfig.pl as well. Be really careful if you need to +change these,a s they can cause some fairly subtle problems. + +* Extra things in the Perl distribution + +In addition to the standard stuff that gets installed, there are two +optional extensions, DCLSYM and STDIO, that are handy. Instructions for +these two modules are in [.VMS.EXT.DCLSYM] and [.VMS.EXT.STDIO], +respectively. + +* Socket Support + +Perl includes a number of functions for IP sockets, which are available if +you choose to compile Perl with socket support. (See the section Compiling +Perl for more info on selecting a socket stack) Since IP networking is an +optional addition to VMS, there are several different IP stacks +available. How well integrated they are into the system depends on the +stack, your version of VMS, and the version of your C compiler. + +The most portable solution uses the SOCKETSHR library. In combination with +either UCX or NetLib, this supports all the major TCP stacks (Multinet, +Pathways, TCPWare, UCX, and CMU) on all versions of VMS Perl runs on, with +all the compilers on both VAX and Alpha. The socket interface is also +consistent across versions of VMS and C compilers. It has a problem with +UDP sockets when used with Multinet, though, so you should be aware of +that. + +The other solution available is to use the socket routines built into Dec +C. Which routines are available depend on the version of VMS you're +running, and require proper UCX emulation by your TCP/IP vendor. +Relatively current versions of Multinet, TCPWare, Pathway, and UCX all +provide the required libraries--check your manuals or release notes to see +if your version is new enough. + +* Reporting Bugs + +If you come across what you think might be a bug in Perl, please report +it. There's a script in PERL_ROOT:[UTILS], perlbug, that walks you through +the process of creating a bug report. This script includes details of your +installation, and is very handy. Completed bug reports should go to +PERLBUG@PERL.COM. + +* Gotchas to watch out for + +Probably the single biggest gotcha in compiling Perl is giving the wrong +switches to MMS/MMK when you build. If Perl's building oddly, double-check +your switches. If you're on a VAX, be sure to add a /Macro=("decc=1") if +you're using Dec C, and if you're on an alpha and using MMS, you'll need a +/Macro=("__AXP__=1") + +The next big gotcha is directory depth. Perl can create directories four +and five levels deep during the build, so you don't have to be too deep to +start to hit the RMS 8 level point. It's best to do a +$DEFINE/TRANS=(CONC,TERM) PERLSRC disk:[dir.dir.dir.perldir.]" (note the +trailing period) and $SET DEFAULT PERLSRC:[000000] before building. Perl +modules can be just as bad (or worse), so watch out for them, too. + +Finally, the third thing that bites people is leftover pieces from a failed +build. If things go wrong, make sure you do a "(MMK|MMS|make) realclean" +before you rebuild. + +* Dec C issues + +Note to DECC users: Some early versions (pre-5.2, some pre-4. If you're Dec +C 5.x or higher, with current patches if anym you're fine) of the DECCRTL +contained a few bugs which affect Perl performance: + - Newlines are lost on I/O through pipes, causing lines to run together. + This shows up as RMS RTB errors when reading from a pipe. You can + work around this by having one process write data to a file, and + then having the other read the file, instead of the pipe. This is + fixed in version 4 of DECC. + - The modf() routine returns a non-integral value for some values above + INT_MAX; the Perl "int" operator will return a non-integral value in + these cases. This is fixed in version 4 of DECC. + - On the AXP, if SYSNAM privilege is enabled, the CRTL chdir() routine + changes the process default device and directory permanently, even + though the call specified that the change should not persist after + Perl exited. This is fixed by DEC CSC patch AXPACRT04_061. + +* Mailing Lists + +There are several mailing lists available to the Perl porter. For VMS +specific issues (including both Perl questions and installation problems) +there is the VMSPERL mailing list. It's usually a low-volume (10-12 +messages a week) mailing list. + +The subscription address is VMSPERL-REQUEST@NEWMAN.UPENN.EDU. Send a mail +message with just the words SUBSCRIBE VMSPERL in the body of the message. + +The VMSPERL mailing list address is VMSPERL@NEWMAN.UPENN.EDU. Any mail +sent there gets echoed to all subscribers of the list. + +The Perl5-Porters list is for anyone involved in porting Perl to a +platform. This includes you, if you want to participate. It's a high-volume +list (60-100 messages a day during active development times), so be sure +you want to be there. The subscription address is +Perl5-Porters-request@perl.org. Send a message with just the word SUBSCRIBE +in the body. The posting address is Perl5-Porters@perl.org. + +* Acknowledgements + +A real big thanks needs to go to Charles Bailey +<bailey@newman.upenn.edu>, who is ultimately responsible for Perl 5.004 +running on VMS. Without him, nothing the rest of us have done would be at +all important. + +There are, of course, far too many people involved in the porting and testing +of Perl to mention everyone who deserves it, so please forgive us if we've +missed someone. That said, special thanks are due to the following: + Tim Adye <T.J.Adye@rl.ac.uk> + for the VMS emulations of getpw*() + David Denholm <denholm@conmat.phys.soton.ac.uk> + for extensive testing and provision of pipe and SocketShr code, + Mark Pizzolato <mark@infocomm.com> + for the getredirection() code + Rich Salz <rsalz@bbn.com> + for readdir() and related routines + Peter Prymmer <pvhp@lns62.lns.cornell.edu) + for extensive testing, as well as development work on + configuration and documentation for VMS Perl, + Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us> + for extensive contributions to recent version support, + development of VMS-specific extensions, and dissemination + of information about VMS Perl, + the Stanford Synchrotron Radiation Laboratory and the + Laboratory of Nuclear Studies at Cornell University for + the the opportunity to test and develop for the AXP, +and to the entire VMSperl group for useful advice and suggestions. In +addition the perl5-porters deserve credit for their creativity and +willingness to work with the VMS newcomers. Finally, the greatest debt of +gratitude is due to Larry Wall <larry@wall.org>, for having the ideas which +have made our sleepless nights possible. + +Thanks, +The VMSperl group + + +--------------------------------------------------------------------------- +[Here's the pre-5.004_04 version of README.vms, for the record.] + Last revised: 19-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu The VMS port of Perl is still under development. At this time, the Perl @@ -15,15 +15,15 @@ #include "EXTERN.h" #include "perl.h" -static void av_reify _((AV* av)); - -static void +void av_reify(av) AV* av; { I32 key; SV* sv; - + + if (AvREAL(av)) + return; key = AvMAX(av) + 1; while (key > AvFILL(av) + 1) AvARRAY(av)[--key] = &sv_undef; @@ -324,6 +324,9 @@ register AV *av; SvPVX(av) = (char*)AvALLOC(av); } AvFILL(av) = -1; + + if (SvRMAGICAL(av)) + mg_clear((SV*)av); } void @@ -180,6 +180,9 @@ ENDOFSET print CONFIG <<'ENDOFTAIL'; +# avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD +sub DESTROY { } + tie %Config, 'Config'; 1; @@ -440,6 +440,7 @@ SV *right; break; } } + SvTAINT(sv); } OP * diff --git a/eg/sysvipc/ipcsem b/eg/sysvipc/ipcsem index 4d871b901a..e0dc551bc5 100644 --- a/eg/sysvipc/ipcsem +++ b/eg/sysvipc/ipcsem @@ -18,7 +18,7 @@ print "semaphore id: $id\n"; if ($signal) { while (<STDIN>) { print "Signalling\n"; - unless (semop($id, 0, pack("sss", 0, 1, 0))) { + unless (semop($id, pack("sss", 0, 1, 0))) { die "Can't signal semaphore: $!\n"; } } @@ -26,7 +26,7 @@ if ($signal) { else { $SIG{'INT'} = $SIG{'QUIT'} = "leave"; for (;;) { - unless (semop($id, 0, pack("sss", 0, -1, 0))) { + unless (semop($id, pack("sss", 0, -1, 0))) { die "Can't wait for semaphore: $!\n"; } print "Unblocked\n"; @@ -46,6 +46,7 @@ #define av_make Perl_av_make #define av_pop Perl_av_pop #define av_push Perl_av_push +#define av_reify Perl_av_reify #define av_shift Perl_av_shift #define av_store Perl_av_store #define av_undef Perl_av_undef @@ -325,6 +326,7 @@ #define magic_len Perl_magic_len #define magic_nextpack Perl_magic_nextpack #define magic_set Perl_magic_set +#define magic_set_all_env Perl_magic_set_all_env #define magic_setamagic Perl_magic_setamagic #define magic_setarylen Perl_magic_setarylen #define magic_setbm Perl_magic_setbm diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index 04404b7ee9..712d575e38 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -12,16 +12,21 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -use vars qw($VERSION); +$VERSION = $VERSION = "1.03"; # avoid typo warning -$VERSION = "1.02"; - -require Carp; require Config; require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + + # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; @@ -82,6 +87,8 @@ if ($dl_debug) { 1; # End of main code +sub croak { require Carp; Carp::croak(@_) } + # The bootstrap function cannot be autoloaded (without complications) # so we define it here: @@ -91,11 +98,14 @@ sub bootstrap { local($module) = $args[0]; local(@dirs, $file); - Carp::confess("Usage: DynaLoader::bootstrap(module)") unless $module; + unless ($module) { + require Carp; + Carp::confess("Usage: DynaLoader::bootstrap(module)"); + } # A common error on platforms which don't support dynamic loading. # Since it's fatal and potentially confusing we give a detailed message. - Carp::croak("Can't load module $module, dynamic loading not available in this perl.\n". + croak("Can't load module $module, dynamic loading not available in this perl.\n". " (You may need to build a new perl executable which either supports\n". " dynamic loading or has the $module module statically linked into it.)\n") unless defined(&dl_load_file); @@ -119,16 +129,17 @@ sub bootstrap { next unless -d $dir; # skip over uninteresting directories # check for common cases to avoid autoload of dl_findfile - last if ($file=_check_file("$dir/$modfname.$dl_dlext")); + my $try = "$dir/$modfname.$dl_dlext"; + last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); # no luck here, save dir for possible later dl_findfile search - push(@dirs, "-L$dir"); + push @dirs, $dir; } # last resort, let dl_findfile have a go in all known locations - $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; + $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; - Carp::croak("Can't find loadable object for module $module in \@INC (@INC)") - unless $file; + croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @@ -153,16 +164,18 @@ sub bootstrap { # it executed. my $libref = dl_load_file($file, $module->dl_load_flags) or - Carp::croak("Can't load '$file' for module $module: ".dl_error()."\n"); + croak("Can't load '$file' for module $module: ".dl_error()."\n"); push(@dl_librefs,$libref); # record loaded object my @unresolved = dl_undef_symbols(); - Carp::carp("Undefined symbols present after loading $file: @unresolved\n") - if @unresolved; + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - Carp::croak("Can't find '$bootname' symbol in $file\n"); + croak("Can't find '$bootname' symbol in $file\n"); my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); @@ -173,12 +186,12 @@ sub bootstrap { } -sub _check_file { # private utility to handle dl_expandspec vs -f tests - my($file) = @_; - return $file if (!$do_expand && -f $file); # the common case - return $file if ( $do_expand && ($file=dl_expandspec($file))); - return undef; -} +#sub _check_file { # private utility to handle dl_expandspec vs -f tests +# my($file) = @_; +# return $file if (!$do_expand && -f $file); # the common case +# return $file if ( $do_expand && ($file=dl_expandspec($file))); +# return undef; +#} # Let autosplit and the autoloader deal with these functions: @@ -243,7 +256,8 @@ sub dl_findfile { foreach $name (@names) { my($file) = "$dir/$name"; print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = _check_file($file); + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); if ($file) { push(@found, $file); next arg; # no need to look any further @@ -279,6 +293,7 @@ sub dl_expandspec { my $file = $spec; # default output to input if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; Carp::croak("dl_expandspec: should be defined in XS file!\n"); } else { return undef unless -f $file; diff --git a/ext/util/make_ext b/ext/util/make_ext index bfbcc8340e..70a5d2eb23 100644 --- a/ext/util/make_ext +++ b/ext/util/make_ext @@ -4,16 +4,35 @@ # It primarily used by the perl Makefile: # # d_dummy $(dynamic_ext): miniperl preplibrary FORCE -# ext/util/make_ext dynamic $@ +# @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) # # It may be deleted in a later release of perl so try to # avoid using it for other purposes. target=$1; shift extspec=$1; shift +makecmd=$1; shift # Should be something like MAKE=make passthru="$*" # allow extra macro=value to be passed through echo "" +# Previously, $make was taken from config.sh. However, the user might +# instead be running a possibly incompatible make. This might happen if +# the user types "gmake" instead of a plain "make", for example. The +# correct current value of MAKE will come through from the main perl +# makefile as MAKE=/whatever/make in $makecmd. We'll be cautious in +# case third party users of this script (are there any?) don't have the +# MAKE=$(MAKE) argument, which was added after 5.004_03. +case "$makecmd" in +MAKE=*) + eval $makecmd + ;; +*) echo 'ext/util/make_ext: WARNING: Please include MAKE=$(MAKE)' + echo ' in your call to make_ext. See ext/util/make_ext for details.' + exit 1 + ;; +esac + + case $CONFIG in '') if test -f config.sh; then TOP=.; @@ -107,10 +126,10 @@ clean) ;; realclean) ;; *) # Give makefile an opportunity to rewrite itself. # reassure users that life goes on... - $make config $passthru || echo "$make config failed, continuing anyway..." + $MAKE config $passthru || echo "$MAKE config failed, continuing anyway..." ;; esac -$make $makeopts $target $makeargs $passthru || exit +$MAKE $makeopts $target $makeargs $passthru || exit exit $? diff --git a/global.sym b/global.sym index a8d99d75bb..864be81757 100644 --- a/global.sym +++ b/global.sym @@ -310,6 +310,7 @@ av_len av_make av_pop av_push +av_reify av_shift av_store av_undef @@ -530,6 +531,7 @@ magic_setsubstr magic_settaint magic_setuvar magic_setvec +magic_set_all_env magic_wipepack magicname markstack_grow @@ -170,8 +170,8 @@ I32 level; gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav; - /* create @.*::SUPER::ISA on demand */ - if (!av) { + /* create and re-create @.*::SUPER::ISA on demand */ + if (!av || !SvMAGIC(av)) { char* packname = HvNAME(stash); STRLEN packlen = strlen(packname); @@ -740,6 +740,7 @@ I32 sv_type; case '7': case '8': case '9': + case '\023': ro_magicalize: SvREADONLY_on(GvSV(gv)); magicalize: diff --git a/hints/bsdos.sh b/hints/bsdos.sh index ef98ace43f..53adfa3b50 100644 --- a/hints/bsdos.sh +++ b/hints/bsdos.sh @@ -1,39 +1,60 @@ # hints/bsdos.sh # -# hints file for BSD/OS 2.x (adapted from bsd386.sh) -# Original by Neil Bowers <neilb@khoros.unm.edu> -# Tue Oct 4 12:01:34 EDT 1994 -# Updated by Tony Sanders <sanders@bsdi.com> -# Mon Nov 27 17:25:51 CST 1995 +# hints file for BSD/OS (adapted from bsd386.sh) +# Original by Neil Bowers <neilb@khoros.unm.edu>; Tue Oct 4 12:01:34 EDT 1994 +# Updated by Tony Sanders <sanders@bsdi.com>; Sat Aug 23 12:47:45 MDT 1997 +# Added 3.1 with ELF dynamic libraries +# SYSV IPC tested Ok so I re-enabled. # -# You can override the compiler and loader on the Configure command line: -# ./Configure -Dcc=shlicc2 -Dld=shlicc2 - -# filename extension for shared library objects -so='o' +# To override the compiler on the command line: +# ./Configure -Dcc=gcc2 +# +# The BSD/OS distribution is built with: +# ./Configure -des -Dbsdos_distribution=defined -# Don't use this for Perl 5.002, which needs parallel sig_name and sig_num lists -#sig_name='ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 ' signal_t='void' d_voidsig='define' +usemymalloc='n' + +# setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions. +# See http://www.bsdi.com/bsdi-man?setuid(2) +d_setregid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' + # we don't want to use -lnm, since exp() is busted (in 1.1 anyway) set `echo X "$libswanted "| sed -e 's/ nm / /'` shift libswanted="$*" -# BSD/OS X libraries are in their own tree +# X libraries are in their own tree glibpth="$glibpth /usr/X11/lib" ldflags="$ldflags -L/usr/X11/lib" # Avoid telldir prototype conflict in pp_sys.c pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' +case "$optimize" in +'') optimize='-O2' ;; +esac + case "$bsdos_distribution" in -defined) - d_portable='no' +''|undef|false) ;; +*) + d_dosuid='define' + d_portable='undef' prefix='/usr/contrib' + perlpath='/usr/bin/perl5' + startperl='#!/usr/bin/perl5' + scriptdir='/usr/contrib/bin' + privlib='/usr/libdata/perl5' + man1dir='/usr/contrib/man/man1' man3dir='/usr/contrib/man/man3' + # phlib added by BSDI -- we share the *.ph include dir with perl4 + phlib="/usr/libdata/perl5/site_perl/$(arch)-$osname/include" + phlibexp="/usr/libdata/perl5/site_perl/$(arch)-$osname/include" ;; esac @@ -48,120 +69,41 @@ case "$osvers" in '') cc='gcc2' ;; esac ;; -2.0*) - # default to GCC 2.X w/shared libraries - case "$cc" in - '') cc='shlicc2' ;; - esac - - # default ld to shared library linker - case "$ld" in - '') ld='shlicc2' ;; - esac - - # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS stuff - # in 4.4BSD-based systems (including BSD/OS 2.0 and later). - # See http://www.bsdi.com/bsdi-man?setuid(2) - d_setregid='undef' - d_setreuid='undef' - d_setrgid='undef' - d_setruid='undef' - ;; -2.1*) - # Use 2.1's shlicc2 for dynamic linking - # Since cc -o is linking, use it for compiling too. - # I'm not sure whether Configure is careful about - # distinguishing between the two. +2.0*|2.1*|3.0*) + so='o' + # default to GCC 2.X w/shared libraries case "$cc" in '') cc='shlicc2' cccdlflags=' ' ;; # Avoid the dreaded -fpic esac - # Link with shared libraries in 2.1 - # Turns out that shlicc2 will automatically use the - # shared libs, so don't explicitly specify -lc_s.2.1.* + # default ld to shared library linker case "$ld" in '') ld='shlicc2' lddlflags='-r' ;; # this one is necessary esac - # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS stuff - # in 4.4BSD-based systems (including BSD/OS 2.0 and later). - # See http://www.bsdi.com/bsdi-man?setuid(2) - # This stuff may or may not be right, but it works. - d_setregid='undef' - d_setreuid='undef' - d_setrgid='undef' - d_setruid='undef' - - # based on the 5.001m hints file from BSD/OS source disk - # (this is needed for pTk to work) - - # BSD/OS 2.1 doesn't (yet) support true dynamic linking. - # So we "preload' the shared libraries by linking against - # them, even though we don't pull in any symbols thereby. + # Must preload the static shared libraries. libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" - ;; -3.0*) - # adapted from 2.1 entry by Christopher Davis <ckd@kei.com - # Use 3.0's shlicc2 for dynamic linking - # Since cc -o is linking, use it for compiling too. - # I'm not sure whether Configure is careful about - # distinguishing between the two. +3.1*) + # ELF dynamic link libraries starting in 3.1 + useshrplib='true' + so='so' + dlext='so' case "$cc" in - '') cc='shlicc2' - cccdlflags=' ' ;; # Avoid the dreaded -fpic + '') cc='cc' # cc is gcc2 in 3.1 + cccdlflags="-fPIC" + ccdlflags=" " ;; esac - # Link with shared libraries in 3.0 - # Turns out that shlicc2 will automatically use the - # shared libs, so don't explicitly specify them case "$ld" in - '') ld='shlicc2' - lddlflags='-r' ;; # this one is necessary + '') ld='ld' + lddlflags="-shared -x $lddlflags" ;; esac - - # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS stuff - # in 4.4BSD-based systems (including BSD/OS 2.0 and later). - # See http://www.bsdi.com/bsdi-man?setuid(2) - # This stuff may or may not be right, but it works. - d_setregid='undef' - d_setreuid='undef' - d_setrgid='undef' - d_setruid='undef' - - # this may still be needed for Tk and such - # BSD/OS doesn't (yet) support true dynamic linking. - # So we "preload' the shared libraries by linking against - # them, even though we don't pull in any symbols thereby. - libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" - libswanted="rpc curses termcap $libswanted" - - # the IPC stuff doesn't work the way perl expects - d_msg='undef' - d_msgctl='undef' - d_msgget='undef' - d_msgrcv='undef' - d_msgsnd='undef' - d_sem='undef' - d_semctl='undef' - d_semget='undef' - d_semop='undef' - d_shm='undef' - d_shmat='undef' - d_shmatprototype='undef' - d_shmctl='undef' - d_shmdt='undef' - d_shmget='undef' - - # use system malloc instead of perl's - d_mymalloc='undef' - i_malloc='undef' - usemymalloc='n' - ;; esac + diff --git a/hints/linux.sh b/hints/linux.sh index 6a11a42cc3..8ddb765e1e 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -29,6 +29,14 @@ esac # gcc-2.6.3 defines _G_HAVE_BOOL to 1, but doesn't actually supply bool. ccflags="-Dbool=char -DHAS_BOOL $ccflags" +# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined. +# Thanks to Bart Schuller <schuller@Lunatech.com> +# See Message-ID: <19971009002636.50729@tanglefoot> +# This is currently commented out for maintenance releases +# but should probably be uncommented for 5.005 or after +# more widespread testing. +#POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' + # BSD compatability library no longer needed set `echo X "$libswanted "| sed -e 's/ bsd / /'` shift @@ -886,7 +886,7 @@ HV *hv; } xhv->xhv_riter = -1; xhv->xhv_eiter = Null(HE*); - return xhv->xhv_fill; + return xhv->xhv_fill; /* should be xhv->xhv_keys? May change later */ } HE * @@ -962,7 +962,10 @@ register HE *entry; I32 *retlen; { if (HeKLEN(entry) == HEf_SVKEY) { - return SvPV(HeKEY_sv(entry), *(STRLEN*)retlen); + STRLEN len; + char *p = SvPV(HeKEY_sv(entry), len); + *retlen = len; + return p; } else { *retlen = HeKLEN(entry); diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index c45483b02d..2773a90f10 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -1,6 +1,5 @@ package AutoLoader; -use Carp; use vars qw(@EXPORT @EXPORT_OK); BEGIN { @@ -42,7 +41,9 @@ AUTOLOAD { } if ($@){ $@ =~ s/ at .*\n//; - croak $@; + my $error = $@; + require Carp; + Carp::croak($error); } } } @@ -83,7 +84,11 @@ sub import { $path ="auto/$calldir/autosplit.ix"; eval { require $path; }; } - carp $@ if ($@); + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } } } @@ -169,6 +174,7 @@ Instead, they should define their own AUTOLOAD subroutines along these lines: use AutoLoader; + use Carp; sub AUTOLOAD { my $constname; @@ -183,7 +189,7 @@ lines: croak "Your vendor has not defined constant $constname"; } } - eval "sub $AUTOLOAD { $val }"; + *$AUTOLOAD = sub { $val }; # same as: eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } diff --git a/lib/Carp.pm b/lib/Carp.pm index 351f83bdf5..685a7933d0 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -53,7 +53,7 @@ $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; -@ISA = Exporter; +@ISA = ('Exporter'); @EXPORT = qw(confess croak carp); @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode diff --git a/lib/Cwd.pm b/lib/Cwd.pm index efcfeca261..3bd0085c73 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -26,14 +26,22 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The fastcwd() function looks the same as getcwd(), but runs faster. -It's also more dangerous because you might conceivably chdir() out of a -directory that you can't chdir() back into. +It's also more dangerous because it might conceivably chdir() you out +of a directory that it can't chdir() you back into. If fastcwd +encounters a problem it will return undef but will probably leave you +in a different directory. For a measure of extra security, if +everything appears to have worked, the fastcwd() function will check +that it leaves you in the same directory that it started in. If it has +changed it will C<die> with the message "Unstable directory path, +current directory changed unexpectedly". That should never happen. The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without -the trailing line terminator). It is recommended that cwd (or another -*cwd() function) is used in I<all> code to ensure portability. +the trailing line terminator). + +It is recommended that cwd (or another *cwd() function) is used in +I<all> code to ensure portability. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See @@ -101,7 +109,7 @@ sub getcwd } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { - $dir = ''; + $dir = undef; } else { @@ -125,9 +133,9 @@ sub getcwd while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } - $cwd = "$dir/$cwd"; + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; closedir(PARENT); - } while ($dir); + } while (defined $dir); chop($cwd) unless $cwd eq '/'; # drop the trailing / $cwd; } @@ -140,33 +148,45 @@ sub getcwd # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. + +# List of metachars taken from do_exec() in doio.c +my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n"); sub fastcwd { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); - ($cdev, $cino) = stat('.'); + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); - chdir('..'); + chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.'); + opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); + last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; - last unless defined $direntry; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); + return undef unless defined $direntry; # should never happen unshift(@path, $direntry); } - chdir($path = '/' . join('/', @path)); + $path = '/' . join('/', @path); + # At this point $path may be tainted (if tainting) and chdir would fail. + # To be more useful we untaint it then check that we landed where we started. + $path = $1 if $path =~ /^(.*)$/; # untaint + chdir($path) || return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; $path; } diff --git a/lib/English.pm b/lib/English.pm index 0cf62bd3b6..bbb6bd7b28 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -92,7 +92,7 @@ sub import { *OSNAME ); -# The ground of all being. +# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) *ARG = *_ ; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index ff5dbf1517..4400858e89 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -34,6 +34,7 @@ sub install { use File::Copy qw(copy); use File::Find qw(find); use File::Path qw(mkpath); + use File::Compare qw(compare); my(%hash) = %$hash; my(%pack, %write, $dir, $warn_permissions); @@ -96,7 +97,7 @@ sub install { my $diff = 0; if ( -f $targetfile && -s _ == $size) { # We have a good chance, we can skip this one - $diff = my_cmp($_,$targetfile); + $diff = compare($_,$targetfile); } else { print "$_ differs\n" if $verbose>1; $diff++; @@ -166,32 +167,6 @@ sub install_default { },1,0,0); } -sub my_cmp { - my($one,$two) = @_; - local(*F,*T); - my $diff = 0; - open T, $two or return 1; - open F, $one or Carp::croak("Couldn't open $one: $!"); - my($fr, $tr, $fbuf, $tbuf, $size); - $size = 1024; - # print "Reading $one\n"; - while ( $fr = read(F,$fbuf,$size)) { - unless ( - $tr = read(T,$tbuf,$size) and - $tbuf eq $fbuf - ){ - # print "diff "; - $diff++; - last; - } - # print "$fr/$tr "; - } - # print "\n"; - close F; - close T; - $diff; -} - sub uninstall { my($fil,$verbose,$nonono) = @_; die "no packlist file found: $fil" unless -f $fil; @@ -226,7 +201,7 @@ sub inc_uninstall { my $diff = 0; if ( -f $targetfile && -s _ == -s $file) { # We have a good chance, we can skip this one - $diff = my_cmp($file,$targetfile); + $diff = compare($file,$targetfile); } else { print "#$file and $targetfile differ\n" if $verbose>1; $diff++; @@ -253,6 +228,7 @@ sub pm_to_blib { use File::Basename qw(dirname); use File::Copy qw(copy); use File::Path qw(mkpath); + use File::Compare qw(compare); use AutoSplit; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first @@ -272,7 +248,7 @@ sub pm_to_blib { mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (my_cmp($_,$fromto->{$_})){ + unless (compare($_,$fromto->{$_})){ print "Skip $fromto->{$_} (unchanged)\n"; next; } diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index fed25ae13b..d821e83729 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -24,7 +24,7 @@ sub _unix_os2_ext { $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; - print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; @@ -34,7 +34,6 @@ sub _unix_os2_ext { # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl - # its home is in <distribution>/ext/util my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; @@ -49,12 +48,12 @@ sub _unix_os2_ext { if ($thislib =~ s/^(-[LR])//){ # save path flag type my($ptype) = $1; unless (-d $thislib){ - print STDOUT "$ptype$thislib ignored, directory does not exist\n" + warn "$ptype$thislib ignored, directory does not exist\n" if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { - print STDOUT "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -65,7 +64,7 @@ sub _unix_os2_ext { # Handle possible library arguments. unless ($thislib =~ s/^-l//){ - print STDOUT "Unrecognized argument in LIBS ignored: '$thislib'\n"; + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; next; } @@ -125,10 +124,10 @@ sub _unix_os2_ext { # # , the compilation tools expand the environment variables.) } else { - print STDOUT "$thislib not found in $thispth\n" if $verbose; + warn "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'-l$thislib' found at $fullname\n" if $verbose; + warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; @@ -174,7 +173,7 @@ sub _unix_os2_ext { } last; # found one here so don't bother looking further } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for -l$thislib\n" unless $found_lib>0; } @@ -202,7 +201,7 @@ sub _win32_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } - print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + warn "Potential libraries are '$potential_libs':\n" if $verbose; # compute $extralibs from $potential_libs @@ -218,13 +217,13 @@ sub _win32_ext { # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { - print STDOUT "-L$thislib ignored, directory does not exist\n" + warn "-L$thislib ignored, directory does not exist\n" if $verbose; next; } elsif (-d $thislib) { unless ($self->file_name_is_absolute($thislib)) { - print STDOUT "Warning: -L$thislib changed to -L$pwd/$thislib\n"; + warn "Warning: -L$thislib changed to -L$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -238,22 +237,22 @@ sub _win32_ext { my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$thislib")) { - print STDOUT "$thislib not found in $thispth\n" if $verbose; + warn "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'$thislib' found at $fullname\n" if $verbose; + warn "'$thislib' found at $fullname\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); last; } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for '$thislib'\n" unless $found_lib>0; } return ('','','','') unless $found; $lib = join(' ',@extralibs); - print "Result: $lib\n" if $verbose; + warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } @@ -275,7 +274,7 @@ sub _vms_ext { 'Xmu' => 'DECW$XMULIBSHR'); if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } - print STDOUT "Potential libraries are '$potential_libs'\n" if $verbose; + warn "Potential libraries are '$potential_libs'\n" if $verbose; # First, sort out directories and library names in the input foreach $lib (split ' ',$potential_libs) { @@ -292,11 +291,11 @@ sub _vms_ext { # path in a logical name.) foreach $dir (@dirs) { unless (-d $dir) { - print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1; + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; $dir = ''; next; } - print STDOUT "Resolving directory $dir\n" if $verbose; + warn "Resolving directory $dir\n" if $verbose; if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } else { $dir = $self->catdir($cwd,$dir); } } @@ -321,24 +320,24 @@ sub _vms_ext { push(@variants,"lib$lib") if $lib !~ /[:>\]]/; } push(@variants,$lib); - print STDOUT "Looking for $lib\n" if $verbose; + warn "Looking for $lib\n" if $verbose; foreach $variant (@variants) { foreach $dir (@dirs) { my($type); $name = "$dir$variant"; - print "\tChecking $name\n" if $verbose > 2; + warn "\tChecking $name\n" if $verbose > 2; if (-f ($test = VMS::Filespec::rmsexpand($name))) { # It's got its own suffix, so we'll have to figure out the type if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } elsif ($test =~ /(?:$obj_ext|obj)$/i) { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; $type = 'obj'; } else { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Unknown library type for $test; assuming shared\n"; $type = 'sh'; } @@ -357,7 +356,7 @@ sub _vms_ext { elsif (not length($ctype) and # If we've got a lib already, don't bother ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; $type = 'obj'; $name = $test unless $test =~ /obj;?\d*$/i; @@ -370,11 +369,11 @@ sub _vms_ext { if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; - print STDOUT "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for $lib\n"; } @@ -387,7 +386,7 @@ sub _vms_ext { push(@libs, map { "$_/Library" } sort keys %olb); push(@libs, map { "$_/Share" } sort keys %sh); $lib = join(' ',@libs); - print "Result: $lib\n" if $verbose; + warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 85b0c1bbe5..4f7a9e8137 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1127,7 +1127,12 @@ sub fixin { # stolen from the pink Camel book, more or less # Now look (in reverse) for interpreter in absolute PATH (unless perl). if ($cmd eq "perl") { - $interpreter = $Config{perlpath}; + if ($Config{startperl} =~ m,^\#!.*/perl,) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } else { + $interpreter = $Config{perlpath}; + } } else { my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; $interpreter = ''; @@ -2935,11 +2940,13 @@ sub test { if (!$tests && -d 't') { $tests = $Is_Win32 ? join(' ', <t\\*.t>) : 't/*.t'; } + # note: 'test.pl' name is also hardcoded in init_dirscan() my(@m); push(@m," TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl +TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) @@ -2953,8 +2960,8 @@ test :: \$(TEST_TYPE) push(@m, "\n"); push(@m, "test_dynamic :: pure_all\n"); - push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests; - push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('$(FULLPERL)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('$(FULLPERL)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_dynamic :: pure_all\n"); @@ -2966,8 +2973,8 @@ test :: \$(TEST_TYPE) if ($self->needs_linking()) { push(@m, "test_static :: pure_all \$(MAP_TARGET)\n"); - push(@m, $self->test_via_harness('./$(MAP_TARGET)', $tests)) if $tests; - push(@m, $self->test_via_script('./$(MAP_TARGET)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n"); push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)')); diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index e0887d122c..4597c71564 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -100,16 +100,55 @@ sub doglob { } # -# this can be used to override CORE::glob -# by saying C<use File::DosGlob 'glob';>. +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. # -sub glob { doglob(1,@_) } + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my $pat = shift; + my $cxix = shift; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + $entries{$cxix} = [doglob(1,$pat)]; + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} sub import { my $pkg = shift; my $callpkg = caller(0); my $sym = shift; - *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} + if defined($sym) and $sym eq 'glob'; } 1; @@ -125,11 +164,14 @@ perlglob.bat - a more capable perlglob.exe replacement =head1 SYNOPSIS require 5.004; - use File::DosGlob 'glob'; # override CORE::glob + + # override CORE::glob in current package + use File::DosGlob 'glob'; + @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; - # from the command line + # from the command line (overrides only in main::) > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" > perlglob ../pe*/*p? @@ -155,7 +197,10 @@ to standard output. While one may replace perlglob.exe with this, usage by overriding CORE::glob via importation should be much more efficient, because it avoids launching a separate process, and is therefore strongly -recommended. +recommended. Note that it is currently possible to override +builtins like glob() only on a per-package basis, not "globally". +Thus, every namespace that wants to override glob() must explicitly +request the override. See L<perlsub>. Extending it to csh patterns is left as an exercise to the reader. @@ -178,6 +223,10 @@ Gurusamy Sarathy <gsar@umich.edu> =item * +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + A few dir-vs-file optimizations result in glob importation being 10 times faster than using perlglob.exe, and using perlglob.bat is only twice as slow as perlglob.exe (GSAR 28-MAY-97) diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 33c60231aa..64477fa7f3 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1,26 +1,29 @@ -# $RCSFile$ # # Complex numbers and associated mathematical functions -# -- Raphael Manfredi, September 1996 -# -- Jarkko Hietaniemi, March-April 1997 +# -- Raphael Manfredi September 1996 +# -- Jarkko Hietaniemi March-October 1997 +# -- Daniel S. Lewart September-October 1997 +# require Exporter; package Math::Complex; +$VERSION = 1.05; + +# $Id: Complex.pm,v 1.2 1997/10/15 10:08:39 jhi Exp $ + use strict; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $package $display - $i $logn %logn); + $i $ip2 $logn %logn); @ISA = qw(Exporter); -$VERSION = 1.01; - my @trig = qw( pi - sin cos tan + tan csc cosec sec cot cotan asin acos atan acsc acosec asec acot acotan @@ -32,7 +35,7 @@ my @trig = qw( @EXPORT = (qw( i Re Im arg - sqrt exp log ln + sqrt log ln log10 logn cbrt root cplx cplxe ), @@ -99,8 +102,11 @@ sub make { sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; - $theta += pi() if $rho < 0; - $self->{'polar'} = [abs($rho), $theta]; + if ($rho < 0) { + $rho = -$rho; + $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); + } + $self->{'polar'} = [$rho, $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; return $self; @@ -133,18 +139,30 @@ sub cplxe { # # pi # -# The number defined as 2 * pi = 360 degrees +# The number defined as pi = 180 degrees # - use constant pi => 4 * atan2(1, 1); # -# log2inv +# pit2 # -# Used in log10(). +# The full circle +# +use constant pit2 => 2 * pi; + # +# pip2 +# +# The quarter circle +# +use constant pip2 => pi / 2; -use constant log10inv => 1 / log(10); +# +# uplog10 +# +# Used in log10(). +# +use constant uplog10 => 1 / log(10); # # i @@ -155,7 +173,7 @@ sub i () { return $i if ($i); $i = bless {}; $i->{'cartesian'} = [0, 1]; - $i->{'polar'} = [1, pi/2]; + $i->{'polar'} = [1, pip2]; $i->{c_dirty} = 0; $i->{p_dirty} = 0; return $i; @@ -242,15 +260,28 @@ sub minus { # Computes z1*z2. # sub multiply { - my ($z1, $z2, $regular) = @_; - my ($r1, $t1) = @{$z1->polar}; - $z2 = cplxe(abs($z2), $z2 >= 0 ? 0 : pi) unless ref $z2; - my ($r2, $t2) = @{$z2->polar}; - unless (defined $regular) { - $z1->set_polar([$r1 * $r2, $t1 + $t2]); + my ($z1, $z2, $regular) = @_; + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t = $t1 + $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + unless (defined $regular) { + $z1->set_polar([$r1 * $r2, $t]); return $z1; + } + return (ref $z1)->emake($r1 * $r2, $t); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + my ($x2, $y2) = @{$z2->cartesian}; + return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2); + } else { + return (ref $z1)->make($x1*$z2, $y1*$z2); + } } - return (ref $z1)->emake($r1 * $r2, $t1 + $t2); } # @@ -268,7 +299,7 @@ sub _divbyzero { } my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -281,20 +312,45 @@ sub _divbyzero { # sub divide { my ($z1, $z2, $inverted) = @_; - my ($r1, $t1) = @{$z1->polar}; - $z2 = cplxe(abs($z2), $z2 >= 0 ? 0 : pi) unless ref $z2; - my ($r2, $t2) = @{$z2->polar}; - unless (defined $inverted) { - _divbyzero "$z1/0" if ($r2 == 0); - $z1->set_polar([$r1 / $r2, $t1 - $t2]); - return $z1; - } - if ($inverted) { + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t; + if ($inverted) { _divbyzero "$z2/0" if ($r1 == 0); - return (ref $z1)->emake($r2 / $r1, $t2 - $t1); - } else { + $t = $t2 - $t1; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r2 / $r1, $t); + } else { _divbyzero "$z1/0" if ($r2 == 0); - return (ref $z1)->emake($r1 / $r2, $t1 - $t2); + $t = $t1 - $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r1 / $r2, $t); + } + } else { + my ($d, $x2, $y2); + if ($inverted) { + ($x2, $y2) = @{$z1->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z2/0" if $d == 0; + return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + ($x2, $y2) = @{$z2->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z1/0" if $d == 0; + my $u = ($x1*$x2 + $y1*$y2)/$d; + my $v = ($y1*$x2 - $x1*$y2)/$d; + return (ref $z1)->make($u, $v); + } else { + _divbyzero "$z1/0" if $z2 == 0; + return (ref $z1)->make($x1/$z2, $y1/$z2); + } + } } } @@ -307,7 +363,7 @@ sub _zerotozero { my $mess = "The zero raised to the zeroth power is not defined.\n"; my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -330,14 +386,7 @@ sub power { return 0 if ($z1z); return 1 if ($z2z or $z1 == 1); } - $z2 = cplx($z2) unless ref $z2; - unless (defined $inverted) { - my $z3 = exp($z2 * log $z1); - $z1->set_cartesian([@{$z3->cartesian}]); - return $z1; - } - return exp($z2 * log $z1) unless $inverted; - return exp($z1 * log $z2); + return $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1); } # @@ -364,7 +413,8 @@ sub negate { my ($z) = @_; if ($z->{c_dirty}) { my ($r, $t) = @{$z->polar}; - return (ref $z)->emake($r, pi + $t); + $t = ($t <= 0) ? $t + pi : $t - pi; + return (ref $z)->emake($r, $t); } my ($re, $im) = @{$z->cartesian}; return (ref $z)->make(-$re, -$im); @@ -392,9 +442,8 @@ sub conjugate { # sub abs { my ($z) = @_; - return abs($z) unless ref $z; my ($r, $t) = @{$z->polar}; - return abs($r); + return $r; } # @@ -406,6 +455,8 @@ sub arg { my ($z) = @_; return ($z < 0 ? pi : 0) unless ref $z; my ($r, $t) = @{$z->polar}; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } return $t; } @@ -416,7 +467,9 @@ sub arg { # sub sqrt { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + return $z >= 0 ? sqrt($z) : cplx(0, sqrt(-$z)) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return cplx($re < 0 ? (0, sqrt(-$re)) : (sqrt($re), 0)) if $im == 0; my ($r, $t) = @{$z->polar}; return (ref $z)->emake(sqrt($r), $t/2); } @@ -428,9 +481,10 @@ sub sqrt { # sub cbrt { my ($z) = @_; - return cplx($z, 0) ** (1/3) unless ref $z; + return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) + unless ref $z; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake($r**(1/3), $t/3); + return (ref $z)->emake(exp(log($r)/3), $t/3); } # @@ -442,7 +496,7 @@ sub _rootbad { my $mess = "Root $_[0] not defined, root must be positive integer.\n"; my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -464,7 +518,7 @@ sub root { my ($r, $t) = ref $z ? @{$z->polar} : (abs($z), $z >= 0 ? 0 : pi); my @root; my $k; - my $theta_inc = 2 * pi / $n; + my $theta_inc = pit2 / $n; my $rho = $r ** (1/$n); my $theta; my $complex = ref($z) || $package; @@ -505,7 +559,6 @@ sub Im { # sub exp { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; return (ref $z)->emake(exp($x), $y); } @@ -513,7 +566,7 @@ sub exp { # # _logofzero # -# Die on division by zero. +# Die on logarithm of zero. # sub _logofzero { my $mess = "$_[0]: Logarithm of zero.\n"; @@ -525,7 +578,7 @@ sub _logofzero { } my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -538,11 +591,14 @@ sub _logofzero { # sub log { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($x, $y) = @{$z->cartesian}; + unless (ref $z) { + _logofzero("log") if $z == 0; + return $z > 0 ? log($z) : cplx(log(-$z), pi); + } my ($r, $t) = @{$z->polar}; - $t -= 2 * pi if ($t > pi() and $x < 0); - $t += 2 * pi if ($t < -pi() and $x < 0); + _logofzero("log") if $r == 0; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } return (ref $z)->make(log($r), $t); } @@ -560,11 +616,7 @@ sub ln { Math::Complex::log(@_) } # sub log10 { - my ($z) = @_; - - return log(cplx($z, 0)) * log10inv unless ref $z; - my ($r, $t) = @{$z->polar}; - return (ref $z)->make(log($r) * log10inv, $t * log10inv); + return Math::Complex::log($_[0]) * uplog10; } # @@ -587,7 +639,6 @@ sub logn { # sub cos { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = exp($y); my $ey_1 = 1 / $ey; @@ -602,7 +653,6 @@ sub cos { # sub sin { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = exp($y); my $ey_1 = 1 / $ey; @@ -656,7 +706,7 @@ sub cosec { Math::Complex::csc(@_) } # # cot # -# Computes cot(z) = 1 / tan(z). +# Computes cot(z) = cos(z) / sin(z). # sub cot { my ($z) = @_; @@ -678,21 +728,20 @@ sub cotan { Math::Complex::cot(@_) } # Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)). # sub acos { - my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return atan2(sqrt(1 - $re * $re), $re) - if ($im == 0 and abs($re) <= 1.0); - my $acos = ~i * log($z + sqrt($z*$z - 1)); - if ($im == 0 || - (abs($re) < 1 && abs($im) < 1) || - (abs($re) > 1 && abs($im) > 1 - && !($re > 1 && $im > 1) - && !($re < -1 && $im < -1))) { - # this rule really, REALLY, must be simpler - return -$acos; - } - return $acos; + my $z = $_[0]; + return atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2(sqrt(1-$beta*$beta), $beta); + my $v = log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); } # @@ -701,12 +750,20 @@ sub acos { # Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)). # sub asin { - my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return atan2($re, sqrt(1 - $re * $re)) - if ($im == 0 and abs($re) <= 1.0); - return ~i * log(i * $z + sqrt(1 - $z*$z)); + my $z = $_[0]; + return atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2($beta, sqrt(1-$beta*$beta)); + my $v = -log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); } # @@ -716,10 +773,12 @@ sub asin { # sub atan { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + return atan2($z, 1) unless ref $z; _divbyzero "atan(i)" if ( $z == i); _divbyzero "atan(-i)" if (-$z == i); - return i/2*log((i + $z) / (i - $z)); + my $log = log((i + $z) / (i - $z)); + $ip2 = 0.5 * i unless defined $ip2; + return $ip2 * $log; } # @@ -730,16 +789,7 @@ sub atan { sub asec { my ($z) = @_; _divbyzero "asec($z)", $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && abs($re) >= 1.0) { - my $ire = 1 / $re; - return atan2(sqrt(1 - $ire * $ire), $ire); - } - my $asec = acos(1 / $z); - return ~$asec if $re < 0 && $re > -1 && $im == 0; - return -$asec if $im && !($re > 0 && $im > 0) && !($re < 0 && $im < 0); - return $asec; + return acos(1 / $z); } # @@ -750,15 +800,7 @@ sub asec { sub acsc { my ($z) = @_; _divbyzero "acsc($z)", $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && abs($re) >= 1.0) { - my $ire = 1 / $re; - return atan2($ire, sqrt(1 - $ire * $ire)); - } - my $acsc = asin(1 / $z); - return ~$acsc if $re < 0 && $re > -1 && $im == 0; - return $acsc; + return asin(1 / $z); } # @@ -775,8 +817,7 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; - _divbyzero "acot($z)" if ($z == 0); - $z = cplx($z, 0) unless ref $z; + return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z; _divbyzero "acot(i)", if ( $z == i); _divbyzero "acot(-i)" if (-$z == i); return atan(1 / $z); @@ -796,15 +837,14 @@ sub acotan { Math::Complex::acot(@_) } # sub cosh { my ($z) = @_; - my $real; + my $ex; unless (ref $z) { - $z = cplx($z, 0); - $real = 1; + $ex = exp($z); + return ($ex + 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - my $ex = exp($x); + $ex = exp($x); my $ex_1 = 1 / $ex; - return cplx(0.5 * ($ex + $ex_1), 0) if $real; return (ref $z)->make(cos($y) * ($ex + $ex_1)/2, sin($y) * ($ex - $ex_1)/2); } @@ -816,15 +856,14 @@ sub cosh { # sub sinh { my ($z) = @_; - my $real; + my $ex; unless (ref $z) { - $z = cplx($z, 0); - $real = 1; + $ex = exp($z); + return ($ex - 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - my $ex = exp($x); + $ex = exp($x); my $ex_1 = 1 / $ex; - return cplx(0.5 * ($ex - $ex_1), 0) if $real; return (ref $z)->make(cos($y) * ($ex - $ex_1)/2, sin($y) * ($ex + $ex_1)/2); } @@ -894,14 +933,19 @@ sub cotanh { Math::Complex::coth(@_) } # # acosh # -# Computes the arc hyperbolic cosine acosh(z) = log(z +- sqrt(z*z-1)). +# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)). # sub acosh { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + unless (ref $z) { + return log($z + sqrt($z*$z-1)) if $z >= 1; + $z = cplx($z, 0); + } my ($re, $im) = @{$z->cartesian}; - return log($re + sqrt(cplx($re*$re - 1, 0))) - if ($im == 0 && $re < 0); + if ($im == 0) { + return cplx(log($re + sqrt($re*$re - 1)), 0) if $re >= 1; + return cplx(0, atan2(sqrt(1-$re*$re), $re)) if abs($re) <= 1; + } return log($z + sqrt($z*$z - 1)); } @@ -912,7 +956,6 @@ sub acosh { # sub asinh { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; return log($z + sqrt($z*$z + 1)); } @@ -923,14 +966,13 @@ sub asinh { # sub atanh { my ($z) = @_; + unless (ref $z) { + return log((1 + $z)/(1 - $z))/2 if abs($z) < 1; + $z = cplx($z, 0); + } _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); _logofzero 'atanh(-1)' if ($z == -1); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && $re > 1) { - return cplx(atanh(1 / $re), pi/2); - } - return log((1 + $z) / (1 - $z)) / 2; + return 0.5 * log((1 + $z) / (1 - $z)); } # @@ -941,12 +983,6 @@ sub atanh { sub asech { my ($z) = @_; _divbyzero 'asech(0)', $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && $re < 0) { - my $ire = 1 / $re; - return log($ire + sqrt(cplx($ire*$ire - 1, 0))); - } return acosh(1 / $z); } @@ -975,13 +1011,12 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; + unless (ref $z) { + return log(($z + 1)/($z - 1))/2 if abs($z) > 1; + $z = cplx($z, 0); + } _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); _logofzero 'acoth(-1)' if ($z == -1); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 and abs($re) < 1) { - return cplx(acoth(1/$re) , pi/2); - } return log((1 + $z) / ($z - 1)) / 2; } @@ -999,17 +1034,23 @@ sub acotanh { Math::Complex::acoth(@_) } # sub atan2 { my ($z1, $z2, $inverted) = @_; - my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0); - my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); - my $tan; - if (defined $inverted && $inverted) { # atan(z2/z1) - return pi * ($re2 > 0 ? 1 : -1) if $re1 == 0 && $im1 == 0; - $tan = $z2 / $z1; + my ($re1, $im1, $re2, $im2); + if ($inverted) { + ($re1, $im1) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + ($re2, $im2) = @{$z1->cartesian}; } else { - return pi * ($re1 > 0 ? 1 : -1) if $re2 == 0 && $im2 == 0; - $tan = $z1 / $z2; + ($re1, $im1) = @{$z1->cartesian}; + ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + } + if ($im2 == 0) { + return cplx(atan2($re1, $re2), 0) if $im1 == 0; + return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; } - return atan($tan); + my $w = atan($z1/$z2); + my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0); + $u += pi if $re2 < 0; + $u -= pit2 if $u > pi; + return cplx($u, $v); } # @@ -1017,7 +1058,7 @@ sub atan2 { # ->display_format # # Set (fetch if no argument) display format for all complex numbers that -# don't happen to have overrriden it via ->display_format +# don't happen to have overridden it via ->display_format # # When called as a method, this actually sets the display format for # the current object. @@ -1076,16 +1117,17 @@ sub stringify_cartesian { my $z = shift; my ($x, $y) = @{$z->cartesian}; my ($re, $im); + my $eps = 1e-14; - $x = int($x + ($x < 0 ? -1 : 1) * 1e-14) - if int(abs($x)) != int(abs($x) + 1e-14); - $y = int($y + ($y < 0 ? -1 : 1) * 1e-14) - if int(abs($y)) != int(abs($y) + 1e-14); + $x = int($x + ($x < 0 ? -1 : 1) * $eps) + if int(abs($x)) != int(abs($x) + $eps); + $y = int($y + ($y < 0 ? -1 : 1) * $eps) + if int(abs($y)) != int(abs($y) + $eps); - $re = "$x" if abs($x) >= 1e-14; - if ($y == 1) { $im = 'i' } - elsif ($y == -1) { $im = '-i' } - elsif (abs($y) >= 1e-14) { $im = $y . "i" } + $re = "$x" if abs($x) >= $eps; + if ($y == 1) { $im = 'i' } + elsif ($y == -1) { $im = '-i' } + elsif (abs($y) >= $eps) { $im = $y . "i" } my $str = ''; $str = $re if defined $re; @@ -1110,10 +1152,9 @@ sub stringify_polar { return '[0,0]' if $r <= $eps; - my $tpi = 2 * pi; - my $nt = $t / $tpi; - $nt = ($nt - int($nt)) * $tpi; - $nt += $tpi if $nt < 0; # Range [0, 2pi] + my $nt = $t / pit2; + $nt = ($nt - int($nt)) * pit2; + $nt += pit2 if $nt < 0; # Range [0, 2pi] if (abs($nt) <= $eps) { $theta = 0 } elsif (abs(pi-$nt) <= $eps) { $theta = 'pi' } @@ -1131,9 +1172,9 @@ sub stringify_polar { # Okay, number is not a real. Try to identify pi/n and friends... # - $nt -= $tpi if $nt > pi; + $nt -= pit2 if $nt > pi; my ($n, $k, $kpi); - + for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); if (abs($kpi/$n - $nt) <= $eps) { @@ -1164,7 +1205,7 @@ Math::Complex - complex numbers and associated mathematical functions =head1 SYNOPSIS use Math::Complex; - + $z = Math::Complex->make(5, 6); $t = 4 - 3*i + $z; $j = cplxe(1, 2*pi/3); @@ -1241,7 +1282,7 @@ between this form and the cartesian form C<a + bi> is immediate: which is also expressed by this formula: - z = rho * exp(i * theta) = rho * (cos theta + i * sin theta) + z = rho * exp(i * theta) = rho * (cos theta + i * sin theta) In other words, it's the projection of the vector onto the I<x> and I<y> axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta> @@ -1251,8 +1292,8 @@ noted C<abs(z)>. The polar notation (also known as the trigonometric representation) is much more handy for performing multiplications and divisions of complex numbers, whilst the cartesian notation is better -suited for additions and substractions. Real numbers are on the I<x> -axis, and therefore I<theta> is zero. +suited for additions and subtractions. Real numbers are on the I<x> +axis, and therefore I<theta> is zero or I<pi>. All the common operations that can be performed on a real number have been defined to work on complex numbers as well, and are merely @@ -1261,8 +1302,8 @@ they keep their natural meaning when there is no imaginary part, provided the number is within their definition set. For instance, the C<sqrt> routine which computes the square root of -its argument is only defined for positive real numbers and yields a -positive real number (it is an application from B<R+> to B<R+>). +its argument is only defined for non-negative real numbers and yields a +non-negative real number (it is an application from B<R+> to B<R+>). If we allow it to return a complex number, then it can be extended to negative real numbers to become an application from B<R> to B<C> (the set of complex numbers): @@ -1275,10 +1316,9 @@ the following definition: sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2) -Indeed, a negative real number can be noted C<[x,pi]> -(the modulus I<x> is always positive, so C<[x,pi]> is really C<-x>, a -negative number) -and the above definition states that +Indeed, a negative real number can be noted C<[x,pi]> (the modulus +I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative +number) and the above definition states that sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i @@ -1342,7 +1382,6 @@ the following (overloaded) operations are supported on complex numbers: log(z1) = log(r1) + i*t1 sin(z1) = 1/2i (exp(i * z1) - exp(-i * z1)) cos(z1) = 1/2 (exp(i * z1) + exp(-i * z1)) - abs(z1) = r1 atan2(z1, z2) = atan(z1/z2) The following extra operations are supported on both real and complex @@ -1363,7 +1402,7 @@ numbers: cot(z) = 1 / tan(z) asin(z) = -i * log(i*z + sqrt(1-z*z)) - acos(z) = -i * log(z + sqrt(z*z-1)) + acos(z) = -i * log(z + i*sqrt(1-z*z)) atan(z) = i/2 * log((i+z) / (i-z)) acsc(z) = asin(1 / z) @@ -1377,7 +1416,7 @@ numbers: csch(z) = 1 / sinh(z) sech(z) = 1 / cosh(z) coth(z) = 1 / tanh(z) - + asinh(z) = log(z + sqrt(z*z+1)) acosh(z) = log(z + sqrt(z*z-1)) atanh(z) = 1/2 * log((1+z) / (1-z)) @@ -1423,21 +1462,21 @@ if you know the cartesian form of the number, or $z = 3 + 4*i; -if you like. To create a number using the trigonometric form, use either: +if you like. To create a number using the polar form, use either: $z = Math::Complex->emake(5, pi/3); $x = cplxe(5, pi/3); instead. The first argument is the modulus, the second is the angle -(in radians, the full circle is 2*pi). (Mnmemonic: C<e> is used as a -notation for complex numbers in the trigonometric form). +(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a +notation for complex numbers in the polar form). It is possible to write: $x = cplxe(-3, pi/4); but that will be silently converted into C<[3,-3pi/4]>, since the modulus -must be positive (it represents the distance to the origin in the complex +must be non-negative (it represents the distance to the origin in the complex plane). =head1 STRINGIFICATION @@ -1534,17 +1573,8 @@ argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. =head1 BUGS Saying C<use Math::Complex;> exports many mathematical routines in the -caller environment and even overrides some (C<sin>, C<cos>, C<sqrt>, -C<log>, C<exp>). This is construed as a feature by the Authors, -actually... ;-) - -The code is not optimized for speed, although we try to use the cartesian -form for addition-like operators and the trigonometric form for all -multiplication-like operators. - -The arg() routine does not ensure the angle is within the range [-pi,+pi] -(a side effect caused by multiplication and division using the trigonometric -representation). +caller environment and even overrides some (C<sqrt>, C<log>). +This is construed as a feature by the Authors, actually... ;-) All routines expect to be given real or complex numbers. Don't attempt to use BigFloat, since Perl has currently no rule to disambiguate a '+' @@ -1555,6 +1585,8 @@ operation (for instance) between two overloaded entities. Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and Jarkko Hietaniemi <F<jhi@iki.fi>>. +Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. + =cut # eof diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 24e9148ff2..f5fc3d8cc5 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -19,11 +19,11 @@ $VERSION = "1.1502"; format STDOUT_TOP = Failed Test Status Wstat Total Fail Failed List of failed ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- . format STDOUT = -@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< { $curtest->{name}, $curtest->{estat}, $curtest->{wstat}, @@ -32,6 +32,8 @@ format STDOUT = $curtest->{percent}, $curtest->{canon} } +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $curtest->{canon} . @@ -110,7 +112,8 @@ sub runtests { : $wstatus >> 8); if ($wstatus) { my ($failed, $canon, $percent) = ('??', '??'); - print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n"; + printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n", + $wstatus,$wstatus; print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; if (corestatus($wstatus)) { # until we have a wait module if ($have_devel_corestack) { @@ -321,6 +324,10 @@ The global variable $Test::Harness::verbose is exportable and can be used to let runtests() display the standard output of the script without altering the behavior otherwise. +The global variable $Test::Harness::switches is exportable and can be +used to set perl command line options used for running the test +script(s). The default value is C<-w>. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. diff --git a/lib/autouse.pm b/lib/autouse.pm index a15d08abc5..ab95a19d8a 100644 --- a/lib/autouse.pm +++ b/lib/autouse.pm @@ -49,9 +49,9 @@ sub import { } my $load_sub = sub { - unless ($INC{pm}) { - require $pm; - die $@ if $@; + unless ($INC{$pm}) { + eval {require $pm}; + die if $@; vet_import $module; } *$closure_import_func = \&{"${module}::$closure_func"}; @@ -73,7 +73,7 @@ sub vet_import ($) { my $module = shift; if (my $import = $module->can('import')) { croak "autoused module has unique import() method" - unless defined(\&Exporter::import) + unless defined(&Exporter::import) && $import == \&Exporter::import; } } diff --git a/lib/base.pm b/lib/base.pm index e69de29bb2..e20a64bc9a 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -0,0 +1,49 @@ +=head1 NAME + +base - Establish IS-A relationship with base class at compile time + +=head1 SYNOPSIS + + package Baz; + + use base qw(Foo Bar); + +=head1 DESCRIPTION + +Roughly similar in effect to + + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + +This module was introduced with Perl 5.004_04. + +=head1 BUGS + +Needs proper documentation! + +=cut + +package base; + +sub import { + my $class = shift; + + foreach my $base (@_) { + unless (defined %{"$base\::"}) { + eval "require $base"; + unless (defined %{"$base\::"}) { + require Carp; + Carp::croak("Base class package \"$base\" is empty.\n", + "\t(Perhaps you need to 'use' the module ", + "which defines that package first.)"); + } + } + } + + push @{caller(0) . '::ISA'}, @_; +} + +1; diff --git a/lib/blib.pm b/lib/blib.pm index 2dd7802f4b..9e0f6c07c3 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -47,7 +47,6 @@ sub import my $dir = getcwd; if (@_) { - print join(',',@_),"\n"; $dir = shift; $dir =~ s/blib$//; $dir =~ s,/+$,,; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 10016f3bb7..78bf4457cb 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -175,6 +175,8 @@ if ($^O eq 'VMS') { @trypod = ("$archlib/pod/perldiag.pod", "$privlib/pod/perldiag-$].pod", "$privlib/pod/perldiag.pod"); +# handy for development testing of new warnings etc +unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; ($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; $DEBUG ||= 0; diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 469ebff023..d5dbfbdd68 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.00; +$VERSION = 1.01; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -808,9 +808,11 @@ sub DB { last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { end_report(), next CMD if $finished and $level <= 1; - $i = $1; + $subname = $i = $1; if ($i =~ /\D/) { # subroutine name - ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/); + $subname = $package."::".$subname + unless $subname =~ /::/; + ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; @@ -1128,7 +1130,11 @@ sub sub { $doret = -2 if $doret eq $#stack or $frame & 16; @ret; } else { - $ret = &$sub; + if (defined wantarray) { + $ret = &$sub; + } else { + &$sub; undef $ret; + }; $single |= pop(@stack); ($frame & 4 ? ( (print $LINEINFO ' ' x $#stack, "out "), @@ -1178,8 +1184,8 @@ sub postponed_sub { my $offset = $1 || 0; # Filename below can contain ':' my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); - $i += $offset; if ($i) { + $i += $offset; local *dbline = $main::{'_<' . $file}; local $^W = 0; # != 0 is magical below $had_breakpoints{$file}++; @@ -1822,18 +1828,15 @@ sub dbwarn { local $doret = -2; local $SIG{__WARN__} = ''; local $SIG{__DIE__} = ''; - eval { require Carp }; # If error/warning during compilation, - # require may be broken. - warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return - unless defined &Carp::longmess; - #&warn("Entering dbwarn\n"); + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"), + return unless defined &Carp::longmess; my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("Warning in dbwarn\n"); &warn($mess); - #&warn("Exiting dbwarn\n"); } sub dbdie { @@ -1842,28 +1845,24 @@ sub dbdie { local $SIG{__DIE__} = ''; local $SIG{__WARN__} = ''; my $i = 0; my $ineval = 0; my $sub; - #&warn("Entering dbdie\n"); - if ($dieLevel != 2) { - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; - } - { + if ($dieLevel > 2) { local $SIG{__WARN__} = \&dbwarn; - &warn(@_) if $dieLevel > 2; # Ineval is false during destruction? - } - #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2; - die @_ if $ineval and $dieLevel < 2; + &warn(@_); # Yell no matter what + return; + } + if ($dieLevel < 2) { + die @_ if $^S; # in eval propagate } - eval { require Carp }; # If error/warning during compilation, - # require may be broken. - die(@_, "\nUnrecoverable error") unless defined &Carp::longmess; + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") + unless defined &Carp::longmess; # We do not want to debug this chunk (automatic disabling works # inside DB::DB, but not in Carp). my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("dieing loudly in dbdie\n"); die $mess; } diff --git a/lib/vars.pm b/lib/vars.pm index e007baa7b9..5723ac6c2c 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -1,5 +1,39 @@ package vars; +require 5.002; + +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + +sub import { + my $callpack = caller; + my ($pack, @imports, $sym, $ch) = @_; + foreach $sym (@imports) { + if ($sym =~ /::/) { + require Carp; + Carp::croak("Can't declare another package's variables"); + } + ($ch, $sym) = unpack('a1a*', $sym); + *{"${callpack}::$sym"} = + ( $ch eq "\$" ? \$ {"${callpack}::$sym"} + : $ch eq "\@" ? \@ {"${callpack}::$sym"} + : $ch eq "\%" ? \% {"${callpack}::$sym"} + : $ch eq "\*" ? \* {"${callpack}::$sym"} + : $ch eq "\&" ? \& {"${callpack}::$sym"} + : do { + require Carp; + Carp::croak("'$ch$sym' is not a valid variable name\n"); + }); + } +}; + +1; +__END__ + =head1 NAME vars - Perl pragma to predeclare global variable names @@ -30,24 +64,3 @@ later-loaded routines. See L<perlmod/Pragmatic Modules>. =cut - -require 5.002; -use Carp; - -sub import { - my $callpack = caller; - my ($pack, @imports, $sym, $ch) = @_; - foreach $sym (@imports) { - croak "Can't declare another package's variables" if $sym =~ /::/; - ($ch, $sym) = unpack('a1a*', $sym); - *{"${callpack}::$sym"} = - ( $ch eq "\$" ? \$ {"${callpack}::$sym"} - : $ch eq "\@" ? \@ {"${callpack}::$sym"} - : $ch eq "\%" ? \% {"${callpack}::$sym"} - : $ch eq "\*" ? \* {"${callpack}::$sym"} - : $ch eq "\&" ? \& {"${callpack}::$sym"} - : croak "'$ch$sym' is not a valid variable name\n"); - } -}; - -1; diff --git a/makedepend.SH b/makedepend.SH index 89f650d26d..7a89fa9821 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -28,6 +28,12 @@ MAKE=$make !GROK!THIS! $spitshell >>makedepend <<'!NO!SUBS!' +# This script should be called with +# sh ./makedepend MAKE=$(MAKE) +case "$1" in + MAKE=*) eval $1 ;; +esac + export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) case $CONFIG in @@ -112,6 +118,7 @@ for file in `$cat .clist`; do $cppstdin $finc -I/usr/local/include -I. $cppflags $cppminus <UU/$file.c | $sed \ -e '/^#.*<stdin>/d' \ + -e '/^#.*"-"/d' \ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ -e 's/^[ ]*#[ ]*line/#/' \ -e '/^# *[0-9][0-9]* *[".\/]/!d' \ @@ -649,8 +649,8 @@ realloc(mp, nbytes) #ifdef PERL_CORE #ifdef DEBUGGING if (debug & 128) { - PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05lu) rfree\n",(unsigned long)res,(unsigned long)(an++)); - PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05lu) realloc %ld bytes\n", + PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) rfree\n",(unsigned long)res,(unsigned long)(an++)); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes\n", (unsigned long)res,(unsigned long)(an++),(long)size); } #endif @@ -814,7 +814,7 @@ int size; } #ifdef PERL_CORE - DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", + DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", size, reqsize, Perl_sbrk_oldsize, got)); #endif @@ -357,8 +357,15 @@ MAGIC *mg; } #else #ifdef OS2 - sv_setnv(sv, (double)Perl_rc); - sv_setpv(sv, os2error(Perl_rc)); + if (!(_emx_env & 0x200)) { /* Under DOS */ + sv_setnv(sv, (double)errno); + sv_setpv(sv, errno ? Strerror(errno) : ""); + } else { + if (errno != errno_isOS2) + Perl_rc = _syserrno(); + sv_setnv(sv, (double)Perl_rc); + sv_setpv(sv, os2error(Perl_rc)); + } #else sv_setnv(sv, (double)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); @@ -384,6 +391,14 @@ MAGIC *mg; case '\020': /* ^P */ sv_setiv(sv, (IV)perldb); break; + case '\023': /* ^S */ + if (lex_state != LEX_NOTPARSING) + SvOK_off(sv); + else if (in_eval) + sv_setiv(sv, 1); + else + sv_setiv(sv, 0); + break; case '\024': /* ^T */ #ifdef BIG_TIME sv_setnv(sv, basetime); @@ -654,6 +669,28 @@ MAGIC* mg; } int +magic_set_all_env(sv,mg) +SV* sv; +MAGIC* mg; +{ +#if defined(VMS) + die("Can't make list assignment to %%ENV on this system"); +#else + if (localizing) { + HE* entry; + magic_clear_all_env(sv,mg); + hv_iterinit((HV*)sv); + while (entry = hv_iternext((HV*)sv)) { + I32 keylen; + my_setenv(hv_iterkey(entry, &keylen), + SvPV(hv_iterval((HV*)sv, entry), na)); + } + } +#endif + return 0; +} + +int magic_clear_all_env(sv,mg) SV* sv; MAGIC* mg; @@ -1601,16 +1638,28 @@ MAGIC* mg; s += strlen(s); /* See if all the arguments are contiguous in memory */ for (i = 1; i < origargc; i++) { - if (origargv[i] == s + 1) + if (origargv[i] == s + 1 +#ifdef OS2 + || origargv[i] == s + 2 +#endif + ) s += strlen(++s); /* this one is ok too */ + else + break; } /* can grab env area too? */ - if (origenviron && origenviron[0] == s + 1) { + if (origenviron && (origenviron[0] == s + 1 +#ifdef OS2 + || (origenviron[0] == s + 9 && (s += 8)) +#endif + )) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ for (i = 0; origenviron[i]; i++) if (origenviron[i] == s + 1) s += strlen(++s); + else + break; } origalen = s - origargv[0]; } @@ -1618,9 +1667,11 @@ MAGIC* mg; i = len; if (i >= origalen) { i = origalen; - SvCUR_set(sv, i); - *SvEND(sv) = '\0'; + /* don't allow system to limit $0 seen by script */ + /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */ Copy(s, origargv[0], i, char); + s = origargv[0]+i; + *s = '\0'; } else { Copy(s, origargv[0], i, char); @@ -125,7 +125,7 @@ char *name; } croak("Can't use global %s in \"my\"",name); } - if (AvFILL(comppad_name) >= 0) { + if (dowarn && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) @@ -2771,7 +2771,8 @@ OP *block; if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) { + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); } @@ -2795,10 +2796,11 @@ OP *block; } OP * -newWHILEOP(flags, debuggable, loop, expr, block, cont) +newWHILEOP(flags, debuggable, loop, whileline, expr, block, cont) I32 flags; I32 debuggable; LOOP *loop; +I32 whileline; OP *expr; OP *block; OP *cont; @@ -2809,7 +2811,8 @@ OP *cont; OP *op; OP *condop; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { + if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); } @@ -2819,8 +2822,14 @@ OP *cont; if (cont) next = LINKLIST(cont); - if (expr) + if (expr) { cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + if ((line_t)whileline != NOLINE) { + copline = whileline; + cont = append_elem(OP_LINESEQ, cont, + newSTATEOP(0, Nullch, Nullop)); + } + } listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); redo = LINKLIST(listop); @@ -2878,10 +2887,10 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont #endif /* CAN_PROTOTYPE */ { LOOP *loop; + OP *wop; int padoff = 0; I32 iterflags = 0; - copline = forline; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ sv->op_type = OP_RV2GV; @@ -2908,8 +2917,9 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont assert(!loop->op_next); Renew(loop, 1, LOOP); loop->op_targ = padoff; - return newSTATEOP(0, label, newWHILEOP(flags, 1, loop, - newOP(OP_ITER, 0), block, cont)); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + copline = forline; + return newSTATEOP(0, label, wop); } OP* @@ -2993,7 +3003,7 @@ CV* cv; SV** ppad; I32 ix; - PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", + PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n", cv, (CvANON(cv) ? "ANON" : (cv == main_cv) ? "MAIN" @@ -3016,7 +3026,7 @@ CV* cv; for (ix = 1; ix <= AvFILL(pad_name); ix++) { if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n", + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", ix, ppad[ix], SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), @@ -3791,7 +3801,7 @@ OP *op; if (cLISTOP->op_first->op_type == OP_STUB) { op_free(op); op = newUNOP(type, OPf_SPECIAL, - newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV))); + newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV))); } return ck_fun(op); } @@ -3962,7 +3972,7 @@ OP *op; else { op_free(op); if (type == OP_FTTTY) - return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, + return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, SVt_PVIO)); else return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); @@ -4112,7 +4122,13 @@ OP * ck_glob(op) OP *op; { - GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); + GV *gv; + + if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling) + append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv))); + + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { static int glob_index; @@ -4127,10 +4143,10 @@ OP *op; append_elem(OP_LIST, op, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); - return ck_subr(op); + op = newUNOP(OP_NULL, 0, ck_subr(op)); + op->op_targ = OP_GLOB; /* hint at what it used to be */ + return op; } - if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling) - append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv))); gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); @@ -4617,7 +4633,8 @@ OP *op; prev = o; o = o->op_sibling; } - if (proto && !optional && *proto == '$') + if (proto && !optional && + (*proto && *proto != '@' && *proto != '%' && *proto != ';')) return too_few_arguments(op, gv_ename(namegv)); return op; } @@ -2252,7 +2252,7 @@ EXT U32 opargs[] = { 0x0001111c, /* vec */ 0x0009111c, /* index */ 0x0009111c, /* rindex */ - 0x0000210d, /* sprintf */ + 0x0000210f, /* sprintf */ 0x00002105, /* formline */ 0x0000099e, /* ord */ 0x0000098e, /* chr */ diff --git a/os2/Changes b/os2/Changes index 146ce87142..4e0c4d49b5 100644 --- a/os2/Changes +++ b/os2/Changes @@ -158,3 +158,8 @@ before 5.004_02: will work. Perl will also look in the current directory first. Moreover, a bug with \; in PATH being non-separator is fixed. +after 5.004_03: + $^E tracks calls to CRT now. (May break if Perl masks some + changes to errno?) + $0 may be edited to longer lengths (at least under OS/2). + OS2::REXX->loads looks in the OS/2-ish fashion too. diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index c27cb0d905..0b43a36612 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::REXX', - VERSION => '0.2', + VERSION => '0.21', MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', ); diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 114e1592c4..4580ede294 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -39,6 +39,7 @@ sub load $handle = DynaLoader::dl_load_file("$_/$file.dll"); last if $handle; } + $handle = DynaLoader::dl_load_file($file) unless $handle; return undef unless $handle; eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" . "sub AUTOLOAD {" @@ -244,7 +245,8 @@ variables may be usable even without C<REXX_call> though. NAME is DLL name, without path and extension. Directories are searched WHERE first (list of dirs), then environment -paths PERL5REXX, PERLREXX or, as last resort, PATH. +paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search +is performed in default DLL path (without adding paths and extensions). The DLL is not unloaded when the variable dies. diff --git a/patchlevel.h b/patchlevel.h index 7881ec90c9..2adaed5f72 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,9 +1,9 @@ #define PATCHLEVEL 4 -#define SUBVERSION 3 +#define SUBVERSION 4 /* local_patches -- list of locally applied less-than-subversion patches. - If you're distributing such a patch, please give it a name and a + If you're distributing such a patch, please give it a tag name and a one-line description, placed just before the last NULL in the array below. If your patch fixes a bug in the perlbug database, please mention the bugid. If your patch *IS* dependent on a prior patch, @@ -17,7 +17,7 @@ --- patchlevel.h <date here> *** 38,43 *** --- 38,44 --- - ,"FOO1235 - some patch" + ,"MAINT_TRIAL_1 - 5.00x_0x maintenance release trial 1" ,"BAR3141 - another patch" ,"BAZ2718 - and another patch" + ,"MINE001 - my new patch" @@ -36,6 +36,7 @@ This will prevent patch from choking if someone has previously applied different patches than you. */ +/* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ static char *local_patches[] = { NULL ,NULL @@ -144,6 +144,7 @@ register PerlInterpreter *sv_interp; #endif init_ids(); + lex_state = LEX_NOTPARSING; start_env.je_prev = NULL; start_env.je_ret = -1; @@ -605,20 +606,23 @@ setuid perl scripts securely.\n"); croak("No code specified for -e"); (void)PerlIO_putc(e_fp,'\n'); break; - case 'I': + case 'I': /* -I handled both here and in moreswitches() */ forbid_setid("-I"); - sv_catpv(sv,"-"); - sv_catpv(sv,s); - sv_catpv(sv," "); - if (*++s) { - incpush(s, TRUE); - } - else if (argv[1]) { - incpush(argv[1], TRUE); - sv_catpv(sv,argv[1]); + if (!*++s && (s=argv[1]) != Nullch) { argc--,argv++; - sv_catpv(sv," "); } + while (s && isSPACE(*s)) + ++s; + if (s && *s) { + char *e, *p; + for (e = s; *e && !isSPACE(*e); e++) ; + p = savepvn(s, e-s); + incpush(p, TRUE); + sv_catpv(sv,"-I"); + sv_catpv(sv,p); + sv_catpv(sv," "); + Safefree(p); + } /* XXX else croak? */ break; case 'P': forbid_setid("-P"); @@ -693,22 +697,24 @@ print \" \\@INC:\\n @INC\\n\";"); if (*s) cddir = savepv(s); break; - case '-': - if (*++s) { /* catch use of gnu style long options */ - if (strEQ(s, "version")) { - s = "v"; - goto reswitch; - } - if (strEQ(s, "help")) { - s = "h"; - goto reswitch; - } - croak("Unrecognized switch: --%s (-h will show valid options)",s); - } - argc--,argv++; - goto switch_end; case 0: break; + case '-': + if (!*++s || isSPACE(*s)) { + argc--,argv++; + goto switch_end; + } + /* catch use of gnu style long options */ + if (strEQ(s, "version")) { + s = "v"; + goto reswitch; + } + if (strEQ(s, "help")) { + s = "h"; + goto reswitch; + } + s--; + /* FALL THROUGH */ default: croak("Unrecognized switch: -%s (-h will show valid options)",s); } @@ -716,7 +722,7 @@ print \" \\@INC:\\n @INC\\n\";"); switch_end: if (!tainting && (s = getenv("PERL5OPT"))) { - for (;;) { + while (s && *s) { while (isSPACE(*s)) s++; if (*s == '-') { @@ -884,7 +890,7 @@ PerlInterpreter *sv_interp; break; } - DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n", + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", sawampersand ? "Enabling" : "Omitting")); if (!restartop) { @@ -1299,30 +1305,39 @@ char *name; { /* This message really ought to be max 23 lines. * Removed -h because the user already knows that opton. Others? */ + + static char *usage[] = { +"-0[octal] specify record separator (\\0, if no argument)", +"-a autosplit mode with -n or -p (splits $_ into @F)", +"-c check syntax only (runs BEGIN and END blocks)", +"-d[:debugger] run scripts under debugger", +"-D[number/list] set debugging flags (argument is a bit mask or flags)", +"-e 'command' one line of script. Several -e's allowed. Omit [programfile].", +"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.", +"-i[extension] edit <> files in place (make backup if extension supplied)", +"-Idirectory specify @INC/#include directory (may be used more than once)", +"-l[octal] enable line ending processing, specifies line terminator", +"-[mM][-]module.. executes `use/no module...' before executing your script.", +"-n assume 'while (<>) { ... }' loop around your script", +"-p assume loop like -n but print line also like sed", +"-P run script through C preprocessor before compilation", +"-s enable some switch parsing for switches after script name", +"-S look for the script using PATH environment variable", +"-T turn on tainting checks", +"-u dump core after parsing script", +"-U allow unsafe operations", +"-v print version number and patchlevel of perl", +"-V[:variable] print perl configuration information", +"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.", +"-x[directory] strip off text before #!perl line and perhaps cd to directory", +"\n", +NULL +}; + char **p = usage; + printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); - printf("\n -0[octal] specify record separator (\\0, if no argument)"); - printf("\n -a autosplit mode with -n or -p (splits $_ into @F)"); - printf("\n -c check syntax only (runs BEGIN and END blocks)"); - printf("\n -d[:debugger] run scripts under debugger"); - printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)"); - printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); - printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); - printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); - printf("\n -Idirectory specify @INC/#include directory (may be used more than once)"); - printf("\n -l[octal] enable line ending processing, specifies line terminator"); - printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); - printf("\n -n assume 'while (<>) { ... }' loop around your script"); - printf("\n -p assume loop like -n but print line also like sed"); - printf("\n -P run script through C preprocessor before compilation"); - printf("\n -s enable some switch parsing for switches after script name"); - printf("\n -S look for the script using PATH environment variable"); - printf("\n -T turn on tainting checks"); - printf("\n -u dump core after parsing script"); - printf("\n -U allow unsafe operations"); - printf("\n -v print version number and patchlevel of perl"); - printf("\n -V[:variable] print perl configuration information"); - printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended."); - printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); + while (*p) + printf("\n %s", *p++); } /* This routine handles any switches that can be given during run */ @@ -1402,22 +1417,25 @@ char *s; inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = inplace; *s && !isSPACE(*s); s++) ; - *s = '\0'; - break; - case 'I': + if (*s) + *s++ = '\0'; + return s; + case 'I': /* -I handled both here and in parse_perl() */ forbid_setid("-I"); - if (*++s) { + ++s; + while (*s && isSPACE(*s)) + ++s; + if (*s) { char *e, *p; for (e = s; *e && !isSPACE(*e); e++) ; p = savepvn(s, e-s); incpush(p, TRUE); Safefree(p); - if (*e) - return e; + s = e; } else croak("No space allowed after -I"); - break; + return s; case 'l': minus_l = TRUE; s++; @@ -1502,14 +1520,21 @@ char *s; return s; case 'v': #if defined(SUBVERSION) && SUBVERSION > 0 - printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION); + printf("\nThis is perl, version 5.%03d_%02d built for %s", + PATCHLEVEL, SUBVERSION, ARCHNAME); #else - printf("\nThis is perl, version %s",patchlevel); + printf("\nThis is perl, version %s built for %s", + patchlevel, ARCHNAME); +#endif +#if defined(LOCAL_PATCH_COUNT) + if (LOCAL_PATCH_COUNT > 0) + printf("\n(with %d registered patch%s, see perl -V for more detail)", + LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif printf("\n\nCopyright 1987-1997, Larry Wall\n"); #ifdef MSDOS - printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); @@ -1578,6 +1578,8 @@ EXTCONST char* block_type[]; #include "perly.h" +#define LEX_NOTPARSING 11 /* borrowed from toke.c */ + typedef enum { XOPERATOR, XTERM, @@ -1930,7 +1932,8 @@ EXT MGVTBL vtbl_sv = {magic_get, magic_set, magic_len, 0, 0}; -EXT MGVTBL vtbl_env = {0, 0, 0, magic_clear_all_env, +EXT MGVTBL vtbl_env = {0, magic_set_all_env, + 0, magic_clear_all_env, 0}; EXT MGVTBL vtbl_envelem = {0, magic_setenv, 0, magic_clearenv, @@ -1949,7 +1952,8 @@ EXT MGVTBL vtbl_packelem = {magic_getpack, EXT MGVTBL vtbl_dbline = {0, magic_setdbline, 0, 0, 0}; EXT MGVTBL vtbl_isa = {0, magic_setisa, - 0, 0, 0}; + 0, magic_setisa, + 0}; EXT MGVTBL vtbl_isaelem = {0, magic_setisa, 0, 0, 0}; EXT MGVTBL vtbl_arylen = {magic_getarylen, @@ -1643,7 +1643,7 @@ case 27: yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } + yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 28: #line 192 "perly.y" @@ -1651,7 +1651,7 @@ case 28: yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } + yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: #line 198 "perly.y" @@ -1671,19 +1671,19 @@ case 31: break; case 32: #line 209 "perly.y" -{ copline = yyvsp[-9].ival; - yyval.opval = block_end(yyvsp[-7].ival, - newSTATEOP(0, yyvsp[-10].pval, - append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval), - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar(yyvsp[-4].opval), - yyvsp[0].opval, scalar(yyvsp[-2].opval))))); } +{ OP *forop = append_elem(OP_LINESEQ, + scalar(yyvsp[-6].opval), + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-9].ival, scalar(yyvsp[-4].opval), + yyvsp[0].opval, scalar(yyvsp[-2].opval))); + copline = yyvsp[-9].ival; + yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); } break; case 33: #line 217 "perly.y" -{ yyval.opval = newSTATEOP(0, - yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } +{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 34: #line 223 "perly.y" @@ -187,13 +187,13 @@ loop : label WHILE '(' remember mtexpr ')' mblock cont $$ = block_end($4, newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, - $5, $7, $8))); } + $2, $5, $7, $8))); } | label UNTIL '(' remember miexpr ')' mblock cont { copline = $2; $$ = block_end($4, newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, - $5, $7, $8))); } + $2, $5, $7, $8))); } | label FOR MY remember my_scalar '(' mexpr ')' mblock cont { $$ = block_end($4, newFOROP(0, $1, $2, $5, $7, $9, $10)); } @@ -206,17 +206,17 @@ loop : label WHILE '(' remember mtexpr ')' mblock cont newFOROP(0, $1, $2, Nullop, $5, $7, $8)); } | label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock /* basically fake up an initialize-while lineseq */ - { copline = $2; - $$ = block_end($4, - newSTATEOP(0, $1, - append_elem(OP_LINESEQ, scalar($5), - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar($7), - $11, scalar($9))))); } + { OP *forop = append_elem(OP_LINESEQ, + scalar($5), + newWHILEOP(0, 1, (LOOP*)Nullop, + $2, scalar($7), + $11, scalar($9))); + copline = $2; + $$ = block_end($4, newSTATEOP(0, $1, forop)); } | label block cont /* a block is a loop that happens once */ - { $$ = newSTATEOP(0, - $1, newWHILEOP(0, 1, (LOOP*)Nullop, - Nullop, $2, $3)); } + { $$ = newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + NOLINE, Nullop, $2, $3)); } ; nexpr : /* NULL */ diff --git a/pod/perlapio.pod b/pod/perlapio.pod index 0db385e388..c963d232f6 100644 --- a/pod/perlapio.pod +++ b/pod/perlapio.pod @@ -29,8 +29,8 @@ perlapio - perl's IO abstraction interface. int PerlIO_fileno(PerlIO *); PerlIO *PerlIO_fdopen(int, const char *); - PerlIO *PerlIO_importFILE(FILE *); - FILE *PerlIO_exportFILE(PerlIO *); + PerlIO *PerlIO_importFILE(FILE *, int flags); + FILE *PerlIO_exportFILE(PerlIO *, int flags); FILE *PerlIO_findFILE(PerlIO *); void PerlIO_releaseFILE(PerlIO *,FILE *); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 8d191e82d7..7400940dca 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1163,7 +1163,7 @@ increasing order of desperation): =item "my" variable %s masks earlier declaration in same scope -(S) A lexical variable has been redeclared in the same scope, effectively +(W) A lexical variable has been redeclared in the same scope, effectively eliminating all access to the previous instance. This is almost always a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are diff --git a/pod/perldiag.pod b/pod/perldiag.pod index a4d9356977..166e046f22 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -35,7 +35,7 @@ if you want to localize a package variable. =item "my" variable %s masks earlier declaration in same scope -(S) A lexical variable has been redeclared in the same scope, effectively +(W) A lexical variable has been redeclared in the same scope, effectively eliminating all access to the previous instance. This is almost always a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are @@ -594,7 +594,11 @@ for us to go to. See L<perlfunc/goto>. the closing delimiter was omitted. Because bracketed quotes count nesting levels, the following is missing its final parenthesis: - print q(The character '(' starts a side comment.) + print q(The character '(' starts a side comment.); + +If you're getting this error from a here-document, you may have +included unseen whitespace before or after your closing tag. A good +programmer's editor will have a way to help you find these characters. =item Can't fork @@ -778,13 +782,16 @@ of suidperl. =item Can't take log of %g -(F) Logarithms are defined on only positive real numbers. +(F) For ordinary real numbers, you can't take the logarithm of a +negative number or zero. There's a Math::Complex package that comes +standard with Perl, though, if you really want to do that for +the negative numbers. =item Can't take sqrt of %g (F) For ordinary real numbers, you can't take the square root of a -negative number. There's a Complex package available for Perl, though, -if you really want to do that. +negative number. There's a Math::Complex package that comes standard +with Perl, though, if you really want to do that. =item Can't undef active subroutine @@ -1315,10 +1322,14 @@ See L<perlfunc/sprintf>. =item Invalid type in pack: '%s' (F) The given character is not a valid pack type. See L<perlfunc/pack>. +(W) The given character is not a valid pack type but used to be silently +ignored. =item Invalid type in unpack: '%s' (F) The given character is not a valid unpack type. See L<perlfunc/unpack>. +(W) The given character is not a valid unpack type but used to be silently +ignored. =item ioctl is not implemented @@ -2015,6 +2026,11 @@ an unintended loop in your inheritance hierarchy. (W) The internal sv_replace() function was handed a new SV with a reference count of other than 1. +=item regexp *+ operand could be empty + +(F) The part of the regexp subject to either the * or + quantifier +could match an empty string. + =item regexp memory corruption (P) The regular expression engine got confused by what the regular @@ -2082,6 +2098,7 @@ or setgid bit set. This doesn't make much sense. (F) The lexer couldn't find the final delimiter of a // or m{} 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 @@ -2252,11 +2269,13 @@ L<perlop/"Quote and Quote-like Operators">. (F) The lexer couldn't find the interior delimiter of a s/// or s{}{} construct. Remember that bracketing delimiters count nesting level. +Missing the leading C<$> from variable C<$s> may cause this error. =item Substitution replacement not terminated (F) The lexer couldn't find the final delimiter of a s/// or s{}{} construct. Remember that bracketing delimiters count nesting level. +Missing the leading C<$> from variable C<$s> may cause this error. =item substr outside of string @@ -2413,7 +2432,8 @@ it. See L<perlre>. =item Translation pattern not terminated (F) The lexer couldn't find the interior delimiter of a tr/// or tr[][] -construct. +or y/// or y[][] construct. Missing the leading C<$> from variables +C<$tr> or C<$y> may cause this error. =item Translation replacement not terminated @@ -2635,6 +2655,10 @@ non-methods. The simple fix for old code is: In any module that used to depend on inheriting C<AUTOLOAD> for non-methods from a base class named C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup. +In code that currently says C<use AutoLoader; @ISA = qw(AutoLoader);> you +should remove AutoLoader from @ISA and change C<use AutoLoader;> to +C<C<use AutoLoader 'AUTOLOAD';>. + =item Use of %s is deprecated (D) The construct indicated is no longer recommended for use, generally diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 4f3341d911..aa1e82eac8 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -551,23 +551,30 @@ omitted, does chroot to $_. Closes the file or pipe associated with the file handle, returning TRUE only if stdio successfully flushes buffers and closes the system file -descriptor. If the file handle came from a piped open C<close> will -additionally return FALSE if one of the other system calls involved -fails or if the program exits with non-zero status. (If the problem was -that the program exited non-zero $! will be set to 0.) -You don't have to close FILEHANDLE if you are immediately -going to do another open() on it, because open() will close it for you. (See +descriptor. + +You don't have to close FILEHANDLE if you are immediately going to do +another open() on it, because open() will close it for you. (See open().) However, an explicit close on an input file resets the line -counter ($.), while the implicit close done by open() does not. Also, -closing a pipe will wait for the process executing on the pipe to -complete, in case you want to look at the output of the pipe -afterwards. Closing a pipe explicitly also puts the status value of -the command into C<$?>. Example: +counter ($.), while the implicit close done by open() does not. + +If the file handle came from a piped open C<close> will additionally +return FALSE if one of the other system calls involved fails or if the +program exits with non-zero status. (If the only problem was that the +program exited non-zero $! will be set to 0.) Also, closing a pipe will +wait for the process executing on the pipe to complete, in case you +want to look at the output of the pipe afterwards. Closing a pipe +explicitly also puts the exit status value of the command into C<$?>. +Example: - open(OUTPUT, '|sort >foo'); # pipe to sort + open(OUTPUT, '|sort >foo') # pipe to sort + or die "Can't start sort: $!"; ... # print stuff to output - close OUTPUT; # wait for sort to finish - open(INPUT, 'foo'); # get sort's results + close OUTPUT # wait for sort to finish + or warn $! ? "Error closing sort pipe: $!" + : "Exit status $? from sort"; + open(INPUT, 'foo') # get sort's results + or die "Can't open 'foo' for input: $!"; FILEHANDLE may be an expression whose value gives the real filehandle name. @@ -803,11 +810,28 @@ produce, respectively See also exit() and warn(). +If LIST is empty and $@ already contains a value (typically from a +previous eval) that value is reused after appending "\t...propagated". +This is useful for propagating exceptions: + + eval { ... }; + die unless $@ =~ /Expected exception/; + +If $@ is empty then the string "Died" is used. + You can arrange for a callback to be called just before the die() does its deed, by setting the C<$SIG{__DIE__}> hook. The associated handler will be called with the error text and can change the error message, if -it sees fit, by calling die() again. See L<perlvar> for details on -setting C<%SIG> entries, and eval() for some examples. +it sees fit, by calling die() again. See L<perlvar/$SIG{expr}> for details on +setting C<%SIG> entries, and L<"eval BLOCK"> for some examples. + +Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed +blocks/strings. If one wants the hook to do nothing in such +situations, put + + die @_ if $^S; + +as the first line of the handler (see L<perlvar/$^S>). =item do BLOCK @@ -830,7 +854,7 @@ from a Perl subroutine library. is just like - eval `cat stat.pl`; + scalar eval `cat stat.pl`; except that it's more efficient, more concise, keeps track of the current filename for error messages, and searches all the B<-I> @@ -1030,10 +1054,10 @@ in case 6. =item exec LIST -The exec() function executes a system command I<AND NEVER RETURNS>, -unless the command does not exist and is executed directly instead of -via your system's command shell (see below). Use system() instead of -exec() if you want it to return. +The exec() function executes a system command I<AND NEVER RETURNS> - +use system() instead of exec() if you want it to return. It fails and +returns FALSE only if the command does not exist I<and> it is executed +directly instead of via your system's command shell (see below). If there is more than one argument in LIST, or if LIST is an array with more than one value, calls execvp(3) with the arguments in LIST. If @@ -1532,8 +1556,10 @@ supported, it can cause bizarre results if the LIST is not a named array. Similarly, grep returns aliases into the original list, much like the way that L<Foreach Loops>'s index variable aliases the list elements. That is, modifying an element of a list returned by grep +(for example, in a C<foreach>, C<map> or another C<grep>) actually modifies the element in the original list. +See also L</map> for an array composed of the results of the BLOCK or EXPR. =item hex EXPR =item hex @@ -1764,6 +1790,8 @@ In a scalar context, returns the ctime(3) value: $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994" +This scalar value is B<not> locale dependent, see L<perllocale>, +but instead a Perl builtin. Also see the Time::Local module, and the strftime(3) and mktime(3) function available via the POSIX module. @@ -1812,6 +1840,12 @@ is just a funny way to write $hash{getkey($_)} = $_; } +Note that, because $_ is a reference into the list value, it can be used +to modify the elements of the array. While this is useful and +supported, it can cause bizarre results if the LIST is not a named +array. See also L</grep> for an array composed of those items of the +original list for which the BLOCK or EXPR evaluates to true. + =item mkdir FILENAME,MODE Creates the directory specified by FILENAME, with permissions specified @@ -1932,6 +1966,14 @@ and those that don't is their text file formats. Systems like Unix and Plan9 that delimit lines with a single character, and that encode that character in C as '\n', do not need C<binmode>. The rest need it. +When opening a file, it's usually a bad idea to continue normal execution +if the request failed, so C<open> is frequently used in connection with +C<die>. Even if C<die> won't do what you want (say, in a CGI script, +where you want to make a nicely formatted error message (but there are +modules which can help with that problem)) you should always check +the return value from opening a file. The infrequent exception is when +working with an unopened filehandle is actually what you want to do. + Examples: $ARTICLE = 100; @@ -1939,12 +1981,16 @@ Examples: while (<ARTICLE>) {... open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) + # if the open fails, output is discarded - open(DBASE, '+<dbase.mine'); # open for update + open(DBASE, '+<dbase.mine') # open for update + or die "Can't open 'dbase.mine' for update: $!"; - open(ARTICLE, "caesar <$article |"); # decrypt article + open(ARTICLE, "caesar <$article |") # decrypt article + or die "Can't start caesar: $!"; - open(EXTRACT, "|sort >/tmp/Tmp$$"); # $$ is our process id + open(EXTRACT, "|sort >/tmp/Tmp$$") # $$ is our process id + or die "Can't start sort: $!"; # process argument list of files along with any includes @@ -3060,12 +3106,13 @@ value.) The use of implicit split to @_ is deprecated, however. If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, splits on whitespace (after skipping any leading whitespace). Anything matching PATTERN is taken to be a delimiter separating the fields. (Note -that the delimiter may be longer than one character.) If LIMIT is -specified and is not negative, splits into no more than that many fields -(though it may split into fewer). If LIMIT is unspecified, trailing null -fields are stripped (which potential users of pop() would do well to -remember). If LIMIT is negative, it is treated as if an arbitrarily large -LIMIT had been specified. +that the delimiter may be longer than one character.) + +If LIMIT is specified and is not negative, splits into no more than +that many fields (though it may split into fewer). If LIMIT is +unspecified, trailing null fields are stripped (which potential users +of pop() would do well to remember). If LIMIT is negative, it is +treated as if an arbitrarily large LIMIT had been specified. A pattern matching the null string (not to be confused with a null pattern C<//>, which is just one member of the set of patterns @@ -3099,7 +3146,7 @@ If you had the entire header of a normal Unix email message in $header, you could split it up into fields and their values this way: $header =~ s/\n\s+/ /g; # fix continuation lines - %hdrs = (UNIX_FROM => split /^(.*?):\s*/m, $header); + %hdrs = (UNIX_FROM => split /^(\S*?):\s*/m, $header); The pattern C</PATTERN/> may be replaced with an expression to specify patterns that vary at runtime. (To do runtime compilation only once, @@ -3412,6 +3459,17 @@ like numbers. Note that Perl supports passing of up to only 14 arguments to your system call, which in practice should usually suffice. +Syscall returns whatever value returned by the system call it calls. +If the system call fails, syscall returns -1 and sets C<$!> (errno). +Note that some system calls can legitimately return -1. The proper +way to handle such calls is to assign C<$!=0;> before the call and +check the value of <$!> if syscall returns -1. + +There's a problem with C<syscall(&SYS_pipe)>: it returns the file +number of the read end of the pipe it creates. There is no way +to retrieve the file number of the other end. You can avoid this +problem by using C<pipe> instead. + =item sysopen FILEHANDLE,FILENAME,MODE =item sysopen FILEHANDLE,FILENAME,MODE,PERMS @@ -3441,12 +3499,12 @@ into that kind of thing. =item sysread FILEHANDLE,SCALAR,LENGTH Attempts to read LENGTH bytes of data into variable SCALAR from the -specified FILEHANDLE, using the system call read(2). It bypasses stdio, -so mixing this with other kinds of reads, print(), write(), seek(), or -tell() can cause confusion. Returns the number of bytes actually read, -or undef if there was an error. SCALAR will be grown or shrunk so that -the last byte actually read is the last byte of the scalar after the -read. +specified FILEHANDLE, using the system call read(2). It bypasses +stdio, so mixing this with other kinds of reads, print(), write(), +seek(), or tell() can cause confusion because stdio usually buffers +data. Returns the number of bytes actually read, or undef if there +was an error. SCALAR will be grown or shrunk so that the last byte +actually read is the last byte of the scalar after the read. An OFFSET may be specified to place the read data at some place in the string other than the beginning. A negative OFFSET specifies @@ -3527,14 +3585,16 @@ for details. Attempts to write LENGTH bytes of data from variable SCALAR to the specified FILEHANDLE, using the system call write(2). It bypasses stdio, so mixing this with reads (other than sysread()), print(), -write(), seek(), or tell() may cause confusion. Returns the number of -bytes actually written, or undef if there was an error. If the length -is greater than the available data, only as much data as is available +write(), seek(), or tell() may cause confusion because stdio usually +buffers data. Returns the number of bytes actually written, or undef +if there was an error. If the LENGTH is greater than the available +data in the SCALAR after the OFFSET, only as much data as is available will be written. An OFFSET may be specified to write the data from some part of the string other than the beginning. A negative OFFSET specifies writing -that many bytes counting backwards from the end of the string. +that many bytes counting backwards from the end of the string. In the +case the SCALAR is empty you can use OFFSET but only zero offset. =item tell FILEHANDLE diff --git a/pod/perlguts.pod b/pod/perlguts.pod index ecf8610756..20a11ac45c 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1404,7 +1404,7 @@ extensions. =item AvFILL -See C<av_len>. +Same as C<av_len>. =item av_clear @@ -1851,6 +1851,11 @@ Prepares a starting point to traverse a hash table. I32 hv_iterinit _((HV* tb)); +Note that hv_iterinit I<currently> returns the number of I<buckets> in +the hash and I<not> the number of keys (as indicated in the Advanced +Perl Programming book). This may change in future. Use the HvKEYS(hv) +macro to find the number of keys in a hash. + =item hv_iterkey Returns the key from the current position of the hash iterator. See @@ -2823,6 +2828,35 @@ Dereferences an RV to return the SV. SV* SvRV (SV* sv); +=item SvTAINT + +Taints an SV if tainting is enabled + + SvTAINT (SV* sv); + +=item SvTAINTED + +Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if not. + + SvTAINTED (SV* sv); + +=item SvTAINTED_off + +Untaints an SV. Be I<very> careful with this routine, as it short-circuits +some of Perl's fundamental security features. XS module authors should +not use this function unless they fully understand all the implications +of unconditionally untainting the value. Untainting should be done in +the standard perl fashion, via a carefully crafted regexp, rather than +directly untainting variables. + + SvTAINTED_off (SV* sv); + +=item SvTAINTED_on + +Marks an SV as tainted. + + SvTAINTED_on (SV* sv); + =item sv_setiv Copies an integer into the given SV. diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 6b1f2ab335..030463c7a0 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -71,9 +71,9 @@ values are "inherited" by functions called from within that block.) } Sending a signal to a negative process ID means that you send the signal -to the entire Unix process-group. This code send a hang-up signal to all -processes in the current process group I<except for> the current process -itself: +to the entire Unix process-group. This code sends a hang-up signal to all +processes in the current process group (and sets $SIG{HUP} to IGNORE so +it doesn't kill itself): { local $SIG{HUP} = 'IGNORE'; diff --git a/pod/perlop.pod b/pod/perlop.pod index 56859029bf..17728df9d3 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -567,6 +567,15 @@ the same character fore and aft, but the 4 sorts of brackets s{}{} Substitution yes tr{}{} Translation no +Note that there can be whitespace between the operator and the quoting +characters, except when C<#> is being used as the quoting character. +C<q#foo#> is parsed as being the string C<foo>, which C<q #foo#> is the +operator C<q> followed by a comment. Its argument will be taken from the +next line. This allows you to write: + + s {foo} # Replace foo + {bar} # with bar. + For constructs that do interpolation, variables beginning with "C<$>" or "C<@>" are interpolated, as are the following sequences: @@ -619,9 +628,9 @@ patterns local to the current package are reset. This usage is vaguely deprecated, and may be removed in some future version of Perl. -=item m/PATTERN/gimosx +=item m/PATTERN/cgimosx -=item /PATTERN/gimosx +=item /PATTERN/cgimosx Searches a string for a pattern match, and in a scalar context returns true (1) or false (''). If no string is specified via the C<=~> or @@ -634,6 +643,7 @@ when C<use locale> is in effect. Options are: + c Do not reset search position on a failed match when /g is in effect. g Match globally, i.e., find all occurrences. i Do case-insensitive pattern matching. m Treat string as multiple lines. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 1e3279e374..a847133bb9 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -62,6 +62,11 @@ getting a - instead of a complete switch could cause Perl to try to execute standard input instead of your script. And a partial B<-I> switch could also cause odd results. +Some switches do care if they are processed twice, for instance combinations +of B<-l> and B<-0>. Either put all the switches after the 32 character +boundary (if applicable), or replace the use of B<-0>I<digits> by +C<BEGIN{ $/ = "\0digits"; }>. + Parsing of the #! switches starts wherever "perl" is mentioned in the line. The sequences "-*" and "- " are specifically ignored so that you could, if you were so inclined, say @@ -500,7 +505,9 @@ Perl. allows Perl to do unsafe operations. Currently the only "unsafe" operations are the unlinking of directories while running as superuser, and running setuid programs with fatal taint checks turned into -warnings. +warnings. Note that the B<-w> switch (or the C<$^W> variable) must +be used along with this option to actually B<generate> the +taint-check warnings. =item B<-v> diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 1a1ae21e81..73884790b0 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -18,25 +18,28 @@ user or group IDs. The setuid bit in Unix permissions is mode 04000, the setgid bit mode 02000; either or both may be set. You can also enable taint mode explicitly by using the B<-T> command line flag. This flag is I<strongly> suggested for server programs and any program run on behalf of -someone else, such as a CGI script. +someone else, such as a CGI script. Once taint mode is on, it's on for +the remainder of your script. While in this mode, Perl takes special precautions called I<taint checks> to prevent both obvious and subtle traps. Some of these checks are reasonably simple, such as verifying that path directories aren't writable by others; careful programmers have always used checks like these. Other checks, however, are best supported by the language itself, -and it is these checks especially that contribute to making a setuid Perl +and it is these checks especially that contribute to making a set-id Perl program more secure than the corresponding C program. -You may not use data derived from outside your program to affect something -else outside your program--at least, not by accident. All command line -arguments, environment variables, locale information (see L<perllocale>), -and file input are marked as "tainted". Tainted data may not be used -directly or indirectly in any command that invokes a sub-shell, nor in any -command that modifies files, directories, or processes. Any variable set -within an expression that has previously referenced a tainted value itself -becomes tainted, even if it is logically impossible for the tainted value -to influence the variable. Because taintedness is associated with each +You may not use data derived from outside your program to affect +something else outside your program--at least, not by accident. All +command line arguments, environment variables, locale information (see +L<perllocale>), results of certain system calls (readdir, readlink, +the gecos field of getpw* calls), and all file input are marked as +"tainted". Tainted data may not be used directly or indirectly in any +command that invokes a sub-shell, nor in any command that modifies +files, directories, or processes. Any variable set +to a value derived from tainted data will itself be tainted, +even if it is logically impossible for the tainted data +to alter the variable. Because taintedness is associated with each scalar value, some elements of an array can be tainted and others not. For example: @@ -90,8 +93,9 @@ doing something like the last example above. =head2 Laundering and Detecting Tainted Data To test whether a variable contains tainted data, and whose use would thus -trigger an "Insecure dependency" message, you can use the following -I<is_tainted()> function. +trigger an "Insecure dependency" message, check your nearby CPAN mirror +for the F<Taint.pm> module, which should become available around November +1997. Or you may be able to use the following I<is_tainted()> function. sub is_tainted { return ! eval { @@ -172,8 +176,8 @@ makes sure you set the PATH. It's also possible to get into trouble with other operations that don't care whether they use tainted values. Make judicious use of the file tests in dealing with any user-supplied filenames. When possible, do -opens and such after setting C<$E<gt> = $E<lt>>. (Remember group IDs, -too!) Perl doesn't prevent you from opening tainted filenames for reading, +opens and such B<after> properly dropping any special user (or group!) +privileges. Perl doesn't prevent you from opening tainted filenames for reading, so be careful what you print out. The tainting mechanism is intended to prevent stupid mistakes, not to remove the need for thought. @@ -199,30 +203,36 @@ doing something it shouldn't. Here's a way to do backticks reasonably safely. Notice how the B<exec> is not called with a string that the shell could expand. This is by far the best way to call something that might be subjected to shell escapes: just -never call the shell at all. By the time we get to the B<exec>, tainting -is turned off, however, so be careful what you call and what you pass it. +never call the shell at all. use English; - die unless defined $pid = open(KID, "-|"); + die "Can't fork: $!" unless defined $pid = open(KID, "-|"); if ($pid) { # parent while (<KID>) { # do something } close KID; } else { + my @temp = ($EUID, $EGID); $EUID = $UID; $EGID = $GID; # XXX: initgroups() not called + # Make sure privs are really gone + ($EUID, $EGID) = @temp; + die "Can't drop privileges" unless + $UID == $EUID and + $GID eq $EGID; # String test $ENV{PATH} = "/bin:/usr/bin"; - exec 'myprog', 'arg1', 'arg2'; + exec 'myprog', 'arg1', 'arg2' or die "can't exec myprog: $!"; } -A similar strategy would work for wildcard expansion via C<glob>. +A similar strategy would work for wildcard expansion via C<glob>, although +you can use C<readdir> instead. Taint checking is most useful when although you trust yourself not to have written a program to give away the farm, you don't necessarily trust those who end up using it not to try to trick it into doing something bad. This -is the kind of security checking that's useful for setuid programs and +is the kind of security checking that's useful for set-id programs and programs launched on someone else's behalf, like CGI programs. This is quite different, however, from not even trusting the writer of the @@ -236,28 +246,28 @@ are trapped and namespace access is carefully controlled. =head2 Security Bugs Beyond the obvious problems that stem from giving special privileges to -systems as flexible as scripts, on many versions of Unix, setuid scripts +systems as flexible as scripts, on many versions of Unix, set-id scripts are inherently insecure right from the start. The problem is a race condition in the kernel. Between the time the kernel opens the file to -see which interpreter to run and when the (now-setuid) interpreter turns +see which interpreter to run and when the (now-set-id) interpreter turns around and reopens the file to interpret it, the file in question may have changed, especially if you have symbolic links on your system. Fortunately, sometimes this kernel "feature" can be disabled. Unfortunately, there are two ways to disable it. The system can simply -outlaw scripts with the setuid bit set, which doesn't help much. -Alternately, it can simply ignore the setuid bit on scripts. If the +outlaw scripts with any set-id bit set, which doesn't help much. +Alternately, it can simply ignore the set-id bits on scripts. If the latter is true, Perl can emulate the setuid and setgid mechanism when it notices the otherwise useless setuid/gid bits on Perl scripts. It does this via a special executable called B<suidperl> that is automatically invoked for you if it's needed. -However, if the kernel setuid script feature isn't disabled, Perl will -complain loudly that your setuid script is insecure. You'll need to -either disable the kernel setuid script feature, or put a C wrapper around +However, if the kernel set-id script feature isn't disabled, Perl will +complain loudly that your set-id script is insecure. You'll need to +either disable the kernel set-id script feature, or put a C wrapper around the script. A C wrapper is just a compiled program that does nothing except call your Perl program. Compiled programs are not subject to the -kernel bug that plagues setuid scripts. Here's a simple wrapper, written +kernel bug that plagues set-id scripts. Here's a simple wrapper, written in C: #define REAL_PATH "/path/to/script" @@ -278,7 +288,7 @@ for each of them. In recent years, vendors have begun to supply systems free of this inherent security bug. On such systems, when the kernel passes the name -of the setuid script to open to the interpreter, rather than using a +of the set-id script to open to the interpreter, rather than using a pathname subject to meddling, it instead passes I</dev/fd/3>. This is a special file already opened on the script, so that there can be no race condition for evil scripts to exploit. On these systems, Perl should be diff --git a/pod/perlsub.pod b/pod/perlsub.pod index d08426adab..16babd2092 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -872,6 +872,12 @@ via the import syntax, and these names may then override the builtin ones: chdir $somewhere; sub chdir { ... } +To unambiguously refer to the builtin form, one may precede the +builtin name with the special package qualifier C<CORE::>. For example, +saying C<CORE::open()> will always refer to the builtin C<open()>, even +if the current package has imported some other subroutine called +C<&open()> from elsewhere. + Library modules should not in general export builtin names like "open" or "chdir" as part of their default @EXPORT list, because these may sneak into someone else's namespace and change the semantics unexpectedly. @@ -887,6 +893,10 @@ and it would import the open override, but if they said they would get the default imports without the overrides. +Note that such overriding is restricted to the package that requests +the import. Some means of "globally" overriding builtins may become +available in future. + =head2 Autoloading If you call a subroutine that is undefined, you would ordinarily get an diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 6487fdda36..75f4e6d5c2 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -18,9 +18,9 @@ long names in the current package. Some of them even have medium names, generally borrowed from B<awk>. To go a step further, those variables that depend on the currently -selected filehandle may instead be set by calling an object method on -the FileHandle object. (Summary lines below for this contain the word -HANDLE.) First you must say +selected filehandle may instead (and preferably) be set by calling an +object method on the FileHandle object. (Summary lines below for this +contain the word HANDLE.) First you must say use FileHandle; @@ -42,6 +42,12 @@ A few of these variables are considered "read-only". This means that if you try to assign to this variable, either directly or indirectly through a reference, you'll raise a run-time exception. +The following list is ordered by scalar variables first, then the +arrays, then the hashes (except $^M was added in the wrong place). +This is somewhat obscured by the fact that %ENV and %SIG are listed as +$ENV{expr} and $SIG{expr}. + + =over 8 =item $ARG @@ -438,16 +444,13 @@ operator. (Mnemonic: What just went bang?) =item $^E More specific information about the last system error than that provided by -C<$!>, if available. (If not, it's just C<$!> again, except under OS/2.) +C<$!>, if available. (If not, it's just C<$!> again.) At the moment, this differs from C<$!> under only VMS and OS/2, where it provides the VMS status value from the last system error, and OS/2 error -code of the last call to OS/2 API which was not directed via CRT. The +code of the last call to OS/2 API either via CRT, or directly from perl. The caveats mentioned in the description of C<$!> apply here, too. (Mnemonic: Extra error explanation.) -Note that under OS/2 C<$!> and C<$^E> do not track each other, so if an -OS/2-specific call is performed, you may need to check both. - =item $EVAL_ERROR =item $@ @@ -597,8 +600,8 @@ C<$^F> at the time of the open, not the time of the exec. =item $^H -The current set of syntax checks enabled by C<use strict>. See the -documentation of C<strict> for more details. +The current set of syntax checks enabled by C<use strict> and other block +scoped compiler hints. See the documentation of C<strict> for more details. =item $INPLACE_EDIT @@ -607,6 +610,20 @@ documentation of C<strict> for more details. The current value of the inplace-edit extension. Use C<undef> to disable inplace editing. (Mnemonic: value of B<-i> switch.) +=item $^M + +By default, running out of memory it is not trappable. However, if +compiled for this, Perl may use the contents of C<$^M> as an emergency +pool after die()ing with this message. Suppose that your Perl were +compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then + + $^M = 'a' x (1<<16); + +would allocate a 64K buffer for use when in emergency. See the F<INSTALL> +file for information on how to enable this option. As a disincentive to +casual use of this advanced feature, there is no L<English> long name for +this variable. + =item $OSNAME =item $^O @@ -653,6 +670,12 @@ Start with single-step on. Note that some bits may be relevent at compile-time only, some at run-time only. This is a new mechanism and the details may change. +=item $^S + +Current state of the interpreter. Undefined if parsing of the current +module/eval is not finished (may happen in $SIG{__DIE__} and +$SIG{__WARN__} handlers). True if inside an eval, othewise false. + =item $BASETIME =item $^T @@ -699,6 +722,11 @@ to get the machine-dependent library properly loaded also: use lib '/mypath/libdir/'; use SomeMod; +=item @_ + +Within a subroutine the array @_ contains the parameters passed to that +subroutine. See L<perlsub>. + =item %INC The hash %INC contains entries for each filename that has @@ -707,25 +735,25 @@ specified, and the value is the location of the file actually found. The C<require> command uses this array to determine whether a given file has already been included. -=item $ENV{expr} +=item %ENV $ENV{expr} The hash %ENV contains your current environment. Setting a value in C<ENV> changes the environment for child processes. -=item $SIG{expr} +=item %SIG $SIG{expr} The hash %SIG is used to set signal handlers for various signals. Example: sub handler { # 1st argument is signal name - local($sig) = @_; + my($sig) = @_; print "Caught a SIG$sig--shutting down\n"; close(LOG); exit(0); } - $SIG{'INT'} = 'handler'; - $SIG{'QUIT'} = 'handler'; + $SIG{'INT'} = \&handler; + $SIG{'QUIT'} = \&handler; ... $SIG{'INT'} = 'DEFAULT'; # restore default action $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT @@ -733,8 +761,8 @@ signals. Example: The %SIG array contains values for only the signals actually set within the Perl script. Here are some other examples: - $SIG{PIPE} = Plumber; # SCARY!! - $SIG{"PIPE"} = "Plumber"; # just fine, assumes main::Plumber + $SIG{"PIPE"} = Plumber; # SCARY!! + $SIG{"PIPE"} = "Plumber"; # assumes main::Plumber (not recommended) $SIG{"PIPE"} = \&Plumber; # just fine; assume current Plumber $SIG{"PIPE"} = Plumber(); # oops, what did Plumber() return?? @@ -775,21 +803,30 @@ argument. When a __DIE__ hook routine returns, the exception processing continues as it would have in the absence of the hook, unless the hook routine itself exits via a C<goto>, a loop exit, or a die(). The C<__DIE__> handler is explicitly disabled during the call, so that you -can die from a C<__DIE__> handler. Similarly for C<__WARN__>. See -L<perlfunc/die>, L<perlfunc/warn> and L<perlfunc/eval>. - -=item $^M - -By default, running out of memory it is not trappable. However, if -compiled for this, Perl may use the contents of C<$^M> as an emergency -pool after die()ing with this message. Suppose that your Perl were -compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then - - $^M = 'a' x (1<<16); - -would allocate a 64K buffer for use when in emergency. See the F<INSTALL> -file for information on how to enable this option. As a disincentive to -casual use of this advanced feature, there is no L<English> long name for -this variable. +can die from a C<__DIE__> handler. Similarly for C<__WARN__>. + +Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed +blocks/strings. See L<perlfunc/die>, L<perlvar/$^S> for how to +circumvent this. + +Note that C<__DIE__>/C<__WARN__> handlers are very special in one +respect: they may be called to report (probable) errors found by the +parser. In such a case the parser may be in inconsistent state, so +any attempt to evaluate Perl code from such a handler will probably +result in a segfault. This means that calls which result/may-result +in parsing Perl should be used with extreme causion, like this: + + require Carp if defined $^S; + Carp::confess("Something wrong") if defined &Carp::confess; + die "Something wrong, but could not load Carp to give backtrace... + To see backtrace try starting Perl with -MCarp switch"; + +Here the first line will load Carp I<unless> it is the parser who +called the handler. The second line will print backtrace and die if +Carp was available. The third line will be executed only if Carp was +not available. + +See L<perlfunc/die>, L<perlfunc/warn> and L<perlfunc/eval> for +additional info. =back @@ -440,6 +440,68 @@ PP(pp_bless) RETURN; } +PP(pp_gelem) +{ + GV *gv; + SV *sv; + SV *ref; + char *elem; + dSP; + + sv = POPs; + elem = SvPV(sv, na); + gv = (GV*)POPs; + ref = Nullsv; + sv = Nullsv; + switch (elem ? *elem : '\0') + { + case 'A': + if (strEQ(elem, "ARRAY")) + ref = (SV*)GvAV(gv); + break; + case 'C': + if (strEQ(elem, "CODE")) + ref = (SV*)GvCVu(gv); + break; + case 'F': + if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ + ref = (SV*)GvIOp(gv); + break; + case 'G': + if (strEQ(elem, "GLOB")) + ref = (SV*)gv; + break; + case 'H': + if (strEQ(elem, "HASH")) + ref = (SV*)GvHV(gv); + break; + case 'I': + if (strEQ(elem, "IO")) + ref = (SV*)GvIOp(gv); + break; + case 'N': + if (strEQ(elem, "NAME")) + sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); + break; + case 'P': + if (strEQ(elem, "PACKAGE")) + sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + break; + case 'S': + if (strEQ(elem, "SCALAR")) + ref = GvSV(gv); + break; + } + if (ref) + sv = newRV(ref); + if (sv) + sv_2mortal(sv); + else + sv = &sv_undef; + XPUSHs(sv); + RETURN; +} + /* Pattern matching */ PP(pp_study) @@ -567,11 +629,11 @@ PP(pp_defined) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvRMAGICAL(sv)) + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)) RETPUSHYES; break; case SVt_PVHV: - if (HvARRAY(sv) || SvRMAGICAL(sv)) + if (HvARRAY(sv) || SvGMAGICAL(sv)) RETPUSHYES; break; case SVt_PVCV: @@ -2324,7 +2386,7 @@ PP(pp_anonhash) SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else + else if (dowarn) warn("Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } @@ -2383,6 +2445,12 @@ PP(pp_splice) newlen = SP - MARK; diff = newlen - length; + if (newlen && !AvREAL(ary)) { + if (AvREIFY(ary)) + av_reify(ary); + else + assert(AvREAL(ary)); /* would leak, so croak */ + } if (diff < 0) { /* shrinking the area */ if (newlen) { @@ -2694,6 +2762,7 @@ PP(pp_unpack) register U32 culong; double cdouble; static char* bitcount = 0; + int commas = 0; if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ @@ -2727,6 +2796,10 @@ PP(pp_unpack) switch(datumtype) { default: croak("Invalid type in unpack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && dowarn) + warn("Invalid type in unpack: '%c'", (int)datumtype); + break; case '%': if (len == 1 && pat[-1] != '1') len = 16; @@ -3479,6 +3552,7 @@ PP(pp_pack) char *aptr; float afloat; double adouble; + int commas = 0; items = SP - MARK; MARK++; @@ -3502,6 +3576,10 @@ PP(pp_pack) switch(datumtype) { default: croak("Invalid type in pack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && dowarn) + warn("Invalid type in pack: '%c'", (int)datumtype); + break; case '%': DIE("%% may only be used in unpack"); case '@': @@ -4113,6 +4191,11 @@ PP(pp_split) } if (realarray) { SWITCHSTACK(ary, oldstack); + if (SvSMAGICAL(ary)) { + PUTBACK; + mg_set((SV*)ary); + SPAGAIN; + } if (gimme == G_ARRAY) { EXTEND(SP, iters); Copy(AvARRAY(ary), SP + 1, iters, SV*); @@ -76,68 +76,6 @@ PP(pp_gv) RETURN; } -PP(pp_gelem) -{ - GV *gv; - SV *sv; - SV *ref; - char *elem; - dSP; - - sv = POPs; - elem = SvPV(sv, na); - gv = (GV*)POPs; - ref = Nullsv; - sv = Nullsv; - switch (elem ? *elem : '\0') - { - case 'A': - if (strEQ(elem, "ARRAY")) - ref = (SV*)GvAV(gv); - break; - case 'C': - if (strEQ(elem, "CODE")) - ref = (SV*)GvCVu(gv); - break; - case 'F': - if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ - ref = (SV*)GvIOp(gv); - break; - case 'G': - if (strEQ(elem, "GLOB")) - ref = (SV*)gv; - break; - case 'H': - if (strEQ(elem, "HASH")) - ref = (SV*)GvHV(gv); - break; - case 'I': - if (strEQ(elem, "IO")) - ref = (SV*)GvIOp(gv); - break; - case 'N': - if (strEQ(elem, "NAME")) - sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); - break; - case 'P': - if (strEQ(elem, "PACKAGE")) - sv = newSVpv(HvNAME(GvSTASH(gv)), 0); - break; - case 'S': - if (strEQ(elem, "SCALAR")) - ref = GvSV(gv); - break; - } - if (ref) - sv = newRV(ref); - if (sv) - sv_2mortal(sv); - else - sv = &sv_undef; - XPUSHs(sv); - RETURN; -} - PP(pp_and) { dSP; @@ -628,7 +566,8 @@ PP(pp_aassign) *(relem++) = sv; didstore = av_store(ary,i++,sv); if (magic) { - mg_set(sv); + if (SvSMAGICAL(sv)) + mg_set(sv); if (!didstore) SvREFCNT_dec(sv); } @@ -655,13 +594,14 @@ PP(pp_aassign) *(relem++) = tmpstr; didstore = hv_store_ent(hash,sv,tmpstr,0); if (magic) { - mg_set(tmpstr); + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); if (!didstore) SvREFCNT_dec(tmpstr); } TAINT_NOT; } - if (relem == lastrelem) + if (relem == lastrelem && dowarn) warn("Odd number of elements in hash list"); } break; @@ -1755,8 +1695,11 @@ PP(pp_entersub) if (!SvROK(sv)) { char *sym; - if (sv == &sv_yes) /* unfound import, ignore */ + if (sv == &sv_yes) { /* unfound import, ignore */ + if (hasargs) + SP = stack_base + POPMARK; RETURN; + } if (SvGMAGICAL(sv)) { mg_get(sv); sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; @@ -2089,6 +2032,14 @@ PP(pp_method) char* packname; STRLEN packlen; + if (SvROK(TOPs)) { + sv = SvRV(TOPs); + if (SvTYPE(sv) == SVt_PVCV) { + SETs(sv); + RETURN; + } + } + name = SvPV(TOPs, na); sv = *(stack_base + TOPMARK + 1); @@ -1369,7 +1369,7 @@ PP(pp_send) if (-offset > blen) DIE("Offset outside string"); offset += blen; - } else if (offset >= blen) + } else if (offset >= blen && blen > 0) DIE("Offset outside string"); } else offset = 0; @@ -2402,16 +2402,20 @@ PP(pp_fttty) dSP; int fd; GV *gv; - char *tmps; - if (op->op_flags & OPf_REF) { + char *tmps = Nullch; + + if (op->op_flags & OPf_REF) gv = cGVOP->op_gv; - tmps = ""; - } + else if (isGV(TOPs)) + gv = (GV*)POPs; + else if (SvROK(TOPs) && isGV(SvRV(TOPs))) + gv = (GV*)SvRV(POPs); else gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); + if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (isDIGIT(*tmps)) + else if (tmps && isDIGIT(*tmps)) fd = atoi(tmps); else RETPUSHUNDEF; @@ -2705,6 +2709,9 @@ PP(pp_readlink) char buf[MAXPATHLEN]; int len; +#ifndef INCOMPLETE_TAINTS + TAINT; +#endif tmps = POPp; len = readlink(tmps, buf, sizeof buf); EXTEND(SP, 1); @@ -2881,6 +2888,7 @@ PP(pp_readdir) register Direntry_t *dp; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); + SV *sv; if (!io || !IoDIRP(io)) goto nope; @@ -2889,20 +2897,28 @@ PP(pp_readdir) /*SUPPRESS 560*/ while (dp = (Direntry_t *)readdir(IoDIRP(io))) { #ifdef DIRNAMLEN - XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); + sv = newSVpv(dp->d_name, dp->d_namlen); #else - XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); + sv = newSVpv(dp->d_name, 0); +#endif +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); #endif + XPUSHs(sv_2mortal(sv)); } } else { if (!(dp = (Direntry_t *)readdir(IoDIRP(io)))) goto nope; #ifdef DIRNAMLEN - XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); + sv = newSVpv(dp->d_name, dp->d_namlen); #else - XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); + sv = newSVpv(dp->d_name, 0); #endif +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + XPUSHs(sv_2mortal(sv)); } RETURN; @@ -4063,6 +4079,9 @@ PP(pp_gpwent) #endif PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_gecos); +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_dir); PUSHs(sv = sv_mortalcopy(&sv_no)); @@ -23,6 +23,7 @@ I32 av_len _((AV* ar)); AV* av_make _((I32 size, SV** svp)); SV* av_pop _((AV* ar)); void av_push _((AV* ar, SV* val)); +void av_reify _((AV* ar)); SV* av_shift _((AV* ar)); SV** av_store _((AV* ar, I32 key, SV* val)); void av_undef _((AV* ar)); @@ -223,6 +224,7 @@ int magic_setsubstr _((SV* sv, MAGIC* mg)); int magic_settaint _((SV* sv, MAGIC* mg)); int magic_setuvar _((SV* sv, MAGIC* mg)); int magic_setvec _((SV* sv, MAGIC* mg)); +int magic_set_all_env _((SV* sv, MAGIC* mg)); int magic_wipepack _((SV* sv, MAGIC* mg)); void magicname _((char* sym, char* name, I32 namlen)); int main _((int argc, char** argv, char** env)); @@ -316,7 +318,8 @@ SV* newSVpvf _((const char* pat, ...)); SV* newSVrv _((SV* rv, char* classname)); SV* newSVsv _((SV* old)); OP* newUNOP _((I32 type, I32 flags, OP* first)); -OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont)); +OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, + I32 whileline, OP* expr, OP* block, OP* cont)); PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP* oopsCV _((OP* o)); @@ -257,8 +257,8 @@ PMOP* pm; if (sawplus && (!sawopen || !regsawback)) r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ - DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %d\n", - OP(first), OP(NEXTOPER(first)), first - scan)); + DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %ld\n", + OP(first), OP(NEXTOPER(first)), (long)(first - scan))); /* * If there's something expensive in the r.e., find the * longest literal string that must appear and make it the @@ -702,7 +702,7 @@ I32 *flagp; } if (!(flags&HASWIDTH) && op != '?') - FAIL("regexp *+ operand could be empty"); + FAIL("regexp *+ operand could be empty"); /* else may core dump */ nextchar(); @@ -1539,13 +1539,13 @@ regexp *r; op = OP(s); /* where, what */ regprop(sv, s); - PerlIO_printf(Perl_debug_log, "%2d%s", s - r->program, SvPVX(sv)); + PerlIO_printf(Perl_debug_log, "%2ld%s", (long)(s - r->program), SvPVX(sv)); next = regnext(s); s += regarglen[(U8)op]; if (next == NULL) /* Next ptr. */ PerlIO_printf(Perl_debug_log, "(0)"); else - PerlIO_printf(Perl_debug_log, "(%d)", (s-r->program)+(next-s)); + PerlIO_printf(Perl_debug_log, "(%ld)", (long)(s-r->program)+(next-s)); s += 3; if (op == ANYOF) { s += 33; @@ -143,7 +143,8 @@ regcppop() * 0 > length [ "foobar" =~ / ( (foo) | (bar) )* /x ]->[1] */ static void -regcppartblow() +regcppartblow(base) +I32 base; { I32 i = SSPOPINT; U32 paren; @@ -160,6 +161,7 @@ regcppartblow() if (paren <= *reglastparen && regendp[paren] == endp) regstartp[paren] = startp; } + assert(savestack_ix == base); } #define regcpblow(cp) leave_scope(cp) @@ -664,8 +666,8 @@ char *prog; if (regnarrate) { SV *prop = sv_newmortal(); regprop(prop, scan); - PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", - regindent*2, "", scan - regprogram, + PerlIO_printf(Perl_debug_log, "%*s%2ld%-8.8s\t<%.10s>\n", + regindent*2, "", (long)(scan - regprogram), SvPVX(prop), locinput); } #else @@ -165,7 +165,12 @@ save_gp(gv, empty) GV *gv; I32 empty; { - SSCHECK(3); + SSCHECK(6); + SSPUSHIV((IV)SvLEN(gv)); + SvLEN(gv) = 0; /* forget that anything was allocated here */ + SSPUSHIV((IV)SvCUR(gv)); + SSPUSHPTR(SvPVX(gv)); + SvPOK_off(gv); SSPUSHPTR(SvREFCNT_inc(gv)); SSPUSHPTR(GvGP(gv)); SSPUSHINT(SAVEt_GP); @@ -188,26 +193,50 @@ AV * save_ary(gv) GV *gv; { + AV *oav, *av; + SSCHECK(3); SSPUSHPTR(gv); - SSPUSHPTR(GvAVn(gv)); + SSPUSHPTR(oav = GvAVn(gv)); SSPUSHINT(SAVEt_AV); GvAV(gv) = Null(AV*); - return GvAVn(gv); + av = GvAVn(gv); + if (SvMAGIC(oav)) { + SvMAGIC(av) = SvMAGIC(oav); + SvFLAGS(av) |= SvMAGICAL(oav); + SvMAGICAL_off(oav); + SvMAGIC(oav) = 0; + localizing = 1; + SvSETMAGIC((SV*)av); + localizing = 0; + } + return av; } HV * save_hash(gv) GV *gv; { + HV *ohv, *hv; + SSCHECK(3); SSPUSHPTR(gv); - SSPUSHPTR(GvHVn(gv)); + SSPUSHPTR(ohv = GvHVn(gv)); SSPUSHINT(SAVEt_HV); GvHV(gv) = Null(HV*); - return GvHVn(gv); + hv = GvHVn(gv); + if (SvMAGIC(ohv)) { + SvMAGIC(hv) = SvMAGIC(ohv); + SvFLAGS(hv) |= SvMAGICAL(ohv); + SvMAGICAL_off(ohv); + SvMAGIC(ohv) = 0; + localizing = 1; + SvSETMAGIC((SV*)hv); + localizing = 0; + } + return hv; } void @@ -463,14 +492,38 @@ I32 base; case SAVEt_AV: /* array reference */ av = (AV*)SSPOPPTR; gv = (GV*)SSPOPPTR; - SvREFCNT_dec(GvAV(gv)); + if (GvAV(gv)) { + AV *goner = GvAV(gv); + SvMAGIC(av) = SvMAGIC(goner); + SvFLAGS(av) |= SvMAGICAL(goner); + SvMAGICAL_off(goner); + SvMAGIC(goner) = 0; + SvREFCNT_dec(goner); + } GvAV(gv) = av; + if (SvMAGICAL(av)) { + localizing = 2; + SvSETMAGIC((SV*)av); + localizing = 0; + } break; case SAVEt_HV: /* hash reference */ hv = (HV*)SSPOPPTR; gv = (GV*)SSPOPPTR; - SvREFCNT_dec(GvHV(gv)); + if (GvHV(gv)) { + HV *goner = GvHV(gv); + SvMAGIC(hv) = SvMAGIC(goner); + SvFLAGS(hv) |= SvMAGICAL(goner); + SvMAGICAL_off(goner); + SvMAGIC(goner) = 0; + SvREFCNT_dec(goner); + } GvHV(gv) = hv; + if (SvMAGICAL(hv)) { + localizing = 2; + SvSETMAGIC((SV*)hv); + localizing = 0; + } break; case SAVEt_INT: /* int reference */ ptr = SSPOPPTR; @@ -512,11 +565,17 @@ I32 base; gv = (GV*)SSPOPPTR; (void)sv_clear((SV*)gv); break; - case SAVEt_GP: /* scalar reference */ + case SAVEt_GP: /* scalar reference */ ptr = SSPOPPTR; gv = (GV*)SSPOPPTR; gp_free(gv); GvGP(gv) = (GP*)ptr; + if (SvPOK(gv) && SvLEN(gv) > 0) { + Safefree(SvPVX(gv)); + } + SvPVX(gv) = (char *)SSPOPPTR; + SvCUR(gv) = (STRLEN)SSPOPIV; + SvLEN(gv) = (STRLEN)SSPOPIV; SvREFCNT_dec(gv); break; case SAVEt_FREESV: @@ -615,7 +674,7 @@ void cx_dump(cx) CONTEXT* cx; { - PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]); + PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]); if (cx->cx_type != CXt_SUBST) { PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop); @@ -3005,7 +3005,7 @@ sv_collxfrm(sv, nxp) if (SvREADONLY(sv)) { SAVEFREEPV(xf); *nxp = xlen; - return xf; + return xf + sizeof(collation_ix); } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); @@ -3215,8 +3215,8 @@ thats_really_all_folks: *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: done, len=%d, string=|%.*s|\n", - SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); + "Screamer: done, len=%ld, string=|%.*s|\n", + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); } else { @@ -4122,7 +4122,6 @@ IV iv; int sign; UV uv; char *p; - int i; sv_setpvn(sv, "", 0); if (iv >= 0) { @@ -4649,10 +4648,21 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) sv_catpv(msg, "end of string"); warn("%_", msg); /* yes, this is reentrant */ } - /* output mangled stuff */ + + /* output mangled stuff ... */ + if (c == '\0') + --q; eptr = p; elen = q - p; - break; + + /* ... right here, because formatting flags should not apply */ + SvGROW(sv, SvCUR(sv) + elen + 1); + p = SvEND(sv); + memcpy(p, eptr, elen); + p += elen; + *p = '\0'; + SvCUR(sv) = p - SvPVX(sv); + continue; /* not "break" */ } have = esignlen + zeros + elen; diff --git a/t/comp/proto.t b/t/comp/proto.t index 197ea78272..d1cfede8af 100755 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -16,7 +16,7 @@ BEGIN { use strict; -print "1..74\n"; +print "1..76\n"; my $i = 1; @@ -375,3 +375,16 @@ sub an_array_ref (\@) { an_array_ref @array; print "not " unless @array == 4; print @array; + +# correctly note too-short parameter lists that don't end with '$', +# a possible regression. + +sub foo1 ($\@); +eval q{ foo1 "s" }; +print "not " unless $@ =~ /^Not enough/; +print "ok ", $i++, "\n"; + +sub foo2 ($\%); +eval q{ foo2 "s" }; +print "not " unless $@ =~ /^Not enough/; +print "ok ", $i++, "\n"; diff --git a/t/lib/complex.t b/t/lib/complex.t index c05f40f2d3..3390334d34 100755 --- a/t/lib/complex.t +++ b/t/lib/complex.t @@ -1,10 +1,15 @@ #!./perl -# $RCSfile$ +# $RCSfile: complex.t,v $ # # Regression tests for the Math::Complex pacakge -# -- Raphael Manfredi, September 1996 -# -- Jarkko Hietaniemi, March-April 1997 +# -- Raphael Manfredi September 1996 +# -- Jarkko Hietaniemi March-October 1997 +# -- Daniel S. Lewart September-October 1997 + +$VERSION = '1.05'; + +# $Id: complex.t,v 1.1 1997/10/15 10:02:15 jhi Exp jhi $ BEGIN { chdir 't' if -d 't'; @@ -13,9 +18,14 @@ BEGIN { use Math::Complex; +my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); + $test = 0; $| = 1; -@script = (); +my @script = ( + 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . + "\n\n" +); my $eps = 1e-11; while (<DATA>) { @@ -58,7 +68,7 @@ sub test_dbz { # push(@script, qq(print "# '$op'\n";)); push(@script, qq(eval '$op';)); push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);)); - push(@script, qq(print "ok $test\n";)); + push(@script, qq( print "ok $test\\n";\n)); } } @@ -71,7 +81,7 @@ sub test_loz { # push(@script, qq(print "# '$op'\n";)); push(@script, qq(eval '$op';)); push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);)); - push(@script, qq(print "ok $test\n";)); + push(@script, qq( print "ok $test\\n";\n)); } } @@ -99,7 +109,10 @@ test_dbz( 'acoth(1)', ); +my $zero = cplx(0, 0); + test_loz( + 'log($zero)', 'atanh(-1)', 'acoth(-1)', ); @@ -112,7 +125,7 @@ sub test_ztz { # push(@script, qq(print "# 0**0\n";)); push(@script, qq(eval 'cplx(0)**cplx(0)';)); push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);)); - push(@script, qq(print "ok $test\n";)); + push(@script, qq( print "ok $test\\n";\n)); } test_ztz; @@ -126,7 +139,7 @@ sub test_broot { # push(@script, qq(print "# root(2, $op)\n";)); push(@script, qq(eval 'root(2, $op)';)); push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);)); - push(@script, qq(print "ok $test\n";)); + push(@script, qq( print "ok $test\\n";\n)); } } @@ -173,11 +186,11 @@ sub test { # check the op= works push @script, <<EOB; { - my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); + my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0); - my \$zb = cplx(\$z1r, \$z1i); + my \$zb = cplx(\$z1r, \$z1i); \$za $op= \$zb; my (\$zbr, \$zbi) = \@{\$zb->cartesian}; @@ -187,7 +200,7 @@ EOB $test++; # check that the rhs has not changed push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); - push @script, qq(print "ok $test\n";); + push @script, qq( print "ok $test\\n";\n); push @script, "}\n"; } } @@ -249,6 +262,17 @@ sub check { print "# '$try' expected: '$expected' got: '$got' for $args\n"; } } + +sub addsq { + my ($z1, $z2) = @_; + return ($z1 + i*$z2) * ($z1 - i*$z2); +} + +sub subsq { + my ($z1, $z2) = @_; + return ($z1 + $z2) * ($z1 - $z2); +} + __END__ &+;= (3,4):(3,4):(6,8) @@ -372,13 +396,13 @@ __END__ |'abs(z)':'r' |'acot(z)':'acotan(z)' |'acsc(z)':'acosec(z)' -|'abs(acsc(z))':'abs(asin(1 / z))' -|'abs(asec(z))':'abs(acos(1 / z))' +|'acsc(z)':'asin(1 / z)' +|'asec(z)':'acos(1 / z)' |'cbrt(z)':'cbrt(r) * exp(i * t/3)' |'cos(acos(z))':'z' -|'cos(z) ** 2 + sin(z) ** 2':1 +|'addsq(cos(z), sin(z))':1 |'cos(z)':'cosh(i*z)' -|'cosh(z) ** 2 - sinh(z) ** 2':1 +|'subsq(cosh(z), sinh(z))':1 |'cot(acot(z))':'z' |'cot(z)':'1 / tan(z)' |'cot(z)':'cotan(z)' @@ -430,6 +454,20 @@ __END__ |'atan(tan(z))':'z' |'atanh(tanh(z))':'z' +&log +(-2.0,0):( 0.69314718055995, 3.14159265358979) +(-1.0,0):( 0 , 3.14159265358979) +(-0.5,0):( -0.69314718055995, 3.14159265358979) +( 0.5,0):( -0.69314718055995, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0.69314718055995, 0 ) + +&log +( 2, 3):( 1.28247467873077, 0.98279372324733) +(-2, 3):( 1.28247467873077, 2.15879893034246) +(-2,-3):( 1.28247467873077, -2.15879893034246) +( 2,-3):( 1.28247467873077, -0.98279372324733) + &sin (-2.0,0):( -0.90929742682568, 0 ) (-1.0,0):( -0.84147098480790, 0 ) @@ -777,3 +815,4 @@ __END__ ( 2,-3):( 0.14694666622553, 0.23182380450040) # eof + diff --git a/t/lib/dosglob.t b/t/lib/dosglob.t index e69de29bb2..7398a14065 100755 --- a/t/lib/dosglob.t +++ b/t/lib/dosglob.t @@ -0,0 +1,94 @@ +#!./perl + +# +# test glob() in File::DosGlob +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..9\n"; + +# override it in main:: +use File::DosGlob 'glob'; + +# test if $_ takes as the default +$_ = "lib/a*.t"; +my @r = glob; +print "not " if $_ ne 'lib/a*.t'; +print "ok 1\n"; +# we should have at least abbrev.t, anydbm.t, autoloader.t +print "# |@r|\nnot " if @r < 3; +print "ok 2\n"; + +# check if <*/*> works +@r = <*/a*.t>; +# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t +print "not " if @r < 9; +print "ok 3\n"; +my $r = scalar @r; + +# check if scalar context works +@r = (); +while (defined($_ = <*/a*.t>)) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 4\n"; + +# check if array context works +@r = (); +for (<*/a*.t>) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 5\n"; + +# test if implicit assign to $_ in while() works +@r = (); +while (<*/a*.t>) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 6\n"; + +# test if explicit glob() gets assign magic too +my @s = (); +while (glob '*/a*.t') { + print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 7\n"; + +# how about in a different package, like? +package Foo; +use File::DosGlob 'glob'; +@s = (); +while (glob '*/a*.t') { + print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 8\n"; + +# test if different glob ops maintain independent contexts +@s = (); +while (<*/a*.t>) { + my $i = 0; + print "# $_ <"; + push @s, $_; + while (<*/b*.t>) { + print " $_"; + $i++; + } + print " >\n"; +} +print "not " if "@r" ne "@s"; +print "ok 9\n"; + diff --git a/t/op/method.t b/t/op/method.t index 21d7c8f397..d955705d1a 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -4,7 +4,7 @@ # test method calls and autoloading. # -print "1..20\n"; +print "1..24\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -25,6 +25,14 @@ test( A->d, "C::d"); # Update hash table; test (A->d, "D::d"); # Update hash table; { + local @A::ISA = qw(C); # Update hash table with split() assignment + test (A->d, "C::d"); + $#A::ISA = -1; + test (eval { A->d } || "fail", "fail"); +} +test (A->d, "D::d"); + +{ local *B::d; eval 'sub B::d {"B::d1"}'; # Import now. test (A->d, "B::d1"); # Update hash table; @@ -109,3 +117,6 @@ test(Y->f(), "B: In Y::f, 3"); # Which sticks test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload test(A->eee(), "new B: In A::eee, 4"); # Which sticks + +# this test added due to bug discovery +test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); diff --git a/t/op/misc.t b/t/op/misc.t index 660049b3f1..6156ac2f21 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -1,5 +1,8 @@ #!./perl +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + chdir 't' if -d 't'; @INC = "../lib"; $ENV{PERL5LIB} = "../lib"; @@ -18,8 +21,8 @@ $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); for (@prgs){ my $switch; - if (s/^\s*-\w+//){ - $switch = $&; + if (s/^\s*(-\w.*)//){ + $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); if ($^O eq 'MSWin32') { diff --git a/t/op/ref.t b/t/op/ref.t index e83a04fbee..9fcc8ac15c 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..50\n"; +print "1..51\n"; # Test glob operations. @@ -223,12 +223,20 @@ sub moe::DESTROY { print "# moe\nok 47\n"; } print "# left block\n"; +# another glob test + +$foo = "not ok 48"; +{ local(*bar) = "foo" } +$bar = "ok 48"; +local(*bar) = *bar; +print "$bar\n"; + package FINALE; { - $ref3 = bless ["ok 50\n"]; # package destruction - my $ref2 = bless ["ok 49\n"]; # lexical destruction - local $ref1 = bless ["ok 48\n"]; # dynamic destruction + $ref3 = bless ["ok 51\n"]; # package destruction + my $ref2 = bless ["ok 50\n"]; # lexical destruction + local $ref1 = bless ["ok 49\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/split.t b/t/op/split.t index b449ba96fa..07246522ee 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -2,7 +2,7 @@ # $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ -print "1..16\n"; +print "1..20\n"; $FS = ':'; @@ -76,3 +76,17 @@ print "$a|$b" eq "2|4" ? "ok 15\n" : "not ok 15\n"; local(undef, $a, undef, $b) = qw(1 2 3 4); print "$a|$b" eq "2|4" ? "ok 16\n" : "not ok 16\n"; } + +# check splitting of null string +$_ = join('|', split(/x/, '',-1), 'Z'); +print $_ eq "Z" ? "ok 17\n" : "#$_\nnot ok 17\n"; + +$_ = join('|', split(/x/, '', 1), 'Z'); +print $_ eq "Z" ? "ok 18\n" : "#$_\nnot ok 18\n"; + +$_ = join('|', split(/(p+)/,'',-1), 'Z'); +print $_ eq "Z" ? "ok 19\n" : "#$_\nnot ok 19\n"; + +$_ = join('|', split(/.?/, '',-1), 'Z'); +print $_ eq "Z" ? "ok 20\n" : "#$_\nnot ok 20\n"; + diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 8e1ef6958f..1450ae375f 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -2,7 +2,32 @@ # $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ -print "1..1\n"; +print "1..4\n"; +$^W = 1; +$SIG{__WARN__} = sub { + if ($_[0] =~ /^Invalid conversion/) { + $w++; + } else { + warn @_; + } +}; + +$w = 0; $x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999); -if ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";} +if ($x eq ' hi 123 %foo 456A3.1' && $w == 0) { + print "ok 1\n"; +} else { + print "not ok 1 '$x'\n"; +} + +for $i (2 .. 4) { + $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; + $w = 0; + $x = sprintf($f, ''); + if ($x eq $f && $w == 1) { + print "ok $i\n"; + } else { + print "not ok $i '$x' '$f' '$w'\n"; + } +} diff --git a/t/op/subst.t b/t/op/subst.t index 3b4734eadb..efea970dfc 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -2,7 +2,7 @@ # $RCSfile: s.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:22 $ -print "1..61\n"; +print "1..62\n"; $x = 'foo'; $_ = "x"; @@ -234,3 +234,8 @@ print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' $_ = "abcd"; s/../$x = $&, m#.#/eg; print $x eq "cd" ? "ok 61\n" : "not ok 61\n"; + +# check parsing of split subst with comment +eval 's{foo} # this is a comment, not a delimiter + {bar};'; +print @? ? "not ok 62\n" : "ok 62\n"; diff --git a/t/op/taint.t b/t/op/taint.t index e170f284ed..8437c43c45 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -82,7 +82,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..135\n"; +print "1..140\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -515,3 +515,60 @@ else { test 134, tainted $corge[1]; test 135, not tainted $corge[2]; } + +# Test for system/library calls returning string data of dubious origin. +{ + # No reliable %Config check for getpw* + if (eval { setpwent(); getpwent(); 1 }) { + setpwent(); + my @getpwent = getpwent(); + die "getpwent: $!\n" unless (@getpwent); + test 136,( not tainted $getpwent[0] + and not tainted $getpwent[1] + and not tainted $getpwent[2] + and not tainted $getpwent[3] + and not tainted $getpwent[4] + and not tainted $getpwent[5] + and tainted $getpwent[6] # gecos + and not tainted $getpwent[7] + and not tainted $getpwent[8]); + endpwent(); + } else { + print "# getpwent() is not available\n"; + print "ok 136\n"; + } + + if ($Config{d_readdir}) { # pretty hard to imagine not + local(*D); + opendir(D, "op") or die "opendir: $!\n"; + my $readdir = readdir(D); + test 137, tainted $readdir; + closedir(OP); + } else { + print "# readdir() is not available\n"; + print "ok 137\n"; + } + + if ($Config{d_readlink} && $Config{d_symlink}) { + my $symlink = "sl$$"; + unlink($symlink); + symlink("/something/naughty", $symlink) or die "symlink: $!\n"; + my $readlink = readlink($symlink); + test 138, tainted $readlink; + unlink($symlink); + } else { + print "# readlink() or symlink() is not available\n"; + print "ok 138\n"; + } +} + +# test bitwise ops (regression bug) +{ + my $why = "y"; + my $j = "x" | $why; + test 139, not tainted $j; + $why = $TAINT."y"; + $j = "x" | $why; + test 140, tainted $j; +} + diff --git a/t/pragma/locale.t b/t/pragma/locale.t index e1ec5a800f..8e296db8a7 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -394,13 +394,26 @@ for (map { chr } 0..255) { } print "ok 101\n"; +# Test for read-onlys. + +{ + no locale; + $a = "qwerty"; + { + use locale; + print "not " if $a cmp "qwerty"; + } +} +print "ok 102\n"; + +# This test must be the last one because its failure is not fatal. # The @Locale should be internally consistent. # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> # for inventing a way to test for ordering consistency # without requiring any particular order. # ++$jhi;#@iki.fi -print "# testing 102\n"; +print "# testing 103\n"; { my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); @@ -422,14 +435,14 @@ print "# testing 102\n"; ( $no.' ($lesser lt $greater)', # 0 $no.' ($lesser le $greater)', # 1 - $no.' ($lesser ne $greater)', # 2 - $yes.' ($lesser eq $greater)', # 3 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 $yes.' ($lesser ge $greater)', # 4 $yes.' ($lesser gt $greater)', # 5 $yes.' ($greater lt $lesser )', # 6 $yes.' ($greater le $lesser )', # 7 - $no.' ($greater ne $lesser )', # 8 - $yes.' ($greater eq $lesser )', # 9 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 $no.' ($greater ge $lesser )', # 10 $no.' ($greater gt $lesser )', # 11 'not (($lesser cmp $greater) == -$sign)' # 12 @@ -438,7 +451,7 @@ print "# testing 102\n"; $test = 0; for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } if ($test) { - print "# failed 102 at:\n"; + print "# failed 103 at:\n"; print "# lesser = '$lesser'\n"; print "# greater = '$greater'\n"; print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; @@ -453,11 +466,10 @@ print "# testing 102\n"; print "\n"; } - print 'not '; + warn "The locale definition on your system may have errors.\n"; last; } } } -print "ok 102\n"; # eof @@ -14,7 +14,7 @@ char *s; { char *ug; - DEBUG_u(PerlIO_printf(PerlIO_stderr(), + DEBUG_u(PerlIO_printf(Perl_debug_log, "%s %d %d %d\n", s, tainted, uid, euid)); if (tainted) { @@ -66,6 +66,8 @@ static struct { * can get by with a single comparison (if the compiler is smart enough). */ +/* #define LEX_NOTPARSING 11 is done in perl.h. */ + #define LEX_NORMAL 10 #define LEX_INTERPNORMAL 9 #define LEX_INTERPCASEMOD 8 @@ -3973,7 +3975,7 @@ I32 len; case 4: if (strEQ(d,"grep")) return KEY_grep; if (strEQ(d,"goto")) return KEY_goto; - if (strEQ(d,"glob")) return -KEY_glob; + if (strEQ(d,"glob")) return KEY_glob; break; case 6: if (strEQ(d,"gmtime")) return -KEY_gmtime; @@ -4950,13 +4952,8 @@ char *start; register char *to; I32 brackets = 1; - if (isSPACE(*s)) { - /* "#" is allowed as delimiter if on same line */ - while (*s == ' ' || *s == '\t') - s++; - if (isSPACE(*s)) - s = skipspace(s); - } + if (isSPACE(*s)) + s = skipspace(s); CLINE; term = *s; multi_start = curcop->cop_line; @@ -188,9 +188,9 @@ MEM_SIZE size; size *= count; ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) - DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #else - DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #endif if (ptr != Nullch) { memset((void*)ptr, 0, size); @@ -691,7 +691,7 @@ perl_init_i18nl10n(printwarn) && strnNE(*e, "LC_ALL=", 7) && (p = strchr(*e, '='))) PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", - (p - *e), *e, p + 1); + (int)(p - *e), *e, p + 1); } } diff --git a/utils/h2ph.PL b/utils/h2ph.PL index d48571f00f..1b469daab8 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -50,7 +50,7 @@ die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" short ushort u_short int uint u_int long ulong u_long - FILE + FILE key_t caddr_t END @isatype{@isatype} = (1) x @isatype; @@ -132,7 +132,7 @@ foreach $file (@ARGV) { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } else { - print OUT $t,"unless(defined(\&$name) {\nsub $name () {",$new,";}\n}\n"; + print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; } } } @@ -191,9 +191,10 @@ exit $Exit; sub expr { while ($_ ne '') { + s/^\&//; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)[LlUu]*// && do {$new .= $1; next;}; + s/^(\d+)\s*[LlUu]*// && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 6b670fc46b..724df6b449 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -26,18 +26,22 @@ open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!"; my $patchlevel_date = (stat PATCH_LEVEL)[9]; while (<PATCH_LEVEL>) { - last if index($_, "static\tchar\t*local_patches[] = {") >= 0; + last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; }; -my $patches; +my @patches; while (<PATCH_LEVEL>) { - last if /^}/; + last if /^\s*}/; chomp; s/^\s+,?"?//; s/"?,?$//; s/(['\\])/\\$1/g; - $patches .= "'$_',\n" unless $_ eq 'NULL'; + push @patches, $_ unless $_ eq 'NULL'; }; +my $patch_desc = "'" . join("',\n\t'", @patches) . "'"; +my @patch_tags = map { my $p=$_; $p=~s/\s.*//; $p } @patches; +my $patch_tags = join " ", map { "+$_" } @patch_tags; +$patch_tags .= " " if $patch_tags; close PATCH_LEVEL; @@ -56,8 +60,13 @@ $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; +my \$config_tag1 = '$] - $Config{cf_time}'; + my \$patchlevel_date = $patchlevel_date; -my \@patches = ( $patches ); +my \$patch_tags = '$patch_tags'; +my \@patches = ( + $patch_desc +); !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -80,7 +89,7 @@ use strict; sub paraprint; -my($Version) = "1.19"; +my($Version) = "1.20"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -104,6 +113,7 @@ my($Version) = "1.19"; # Changed in 1.19 '-ok' default not '-v' # add local patch information # warn on '-ok' if this is an old system; add '-okay' +# Changed in 1.20 Added patchlevel.h reading and version/config checks # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -114,6 +124,8 @@ my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $subject, $from, $verbose, $ed, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); +my $config_tag2 = "$] - $Config{cf_time}"; + Init(); if($::opt_h) { Help(); exit; } @@ -204,8 +216,8 @@ EOF $::opt_S = 1; # don't prompt for send $::opt_C = 1; # don't send a copy to the local admin $::opt_s = 1; - $subject = "OK: perl $] on" - ." $::Config{'osname'} $::Config{'osvers'} $subject"; + $subject = "OK: perl $] ${patch_tags}on" + ." $::Config{'archname'} $::Config{'osvers'} $subject"; $::opt_b = 1; $body = "Perl reported to build OK on this system.\n"; $ok = 1; @@ -292,12 +304,9 @@ EOF $domain = Mail::Util::maildomain(); } elsif ($Is_MSWin32) { $domain = $ENV{'USERDOMAIN'}; - } elsif ($Is_VMS) { + } else { require Sys::Hostname; $domain = Sys::Hostname::hostname(); - } else { - $domain = `hostname`.".".`domainname`; - $domain =~ s/[\r\n]+//g; } my($guess); @@ -534,9 +543,13 @@ EOF sub Dump { local(*OUT) = @_; - print OUT <<EOF; + print REP "\n---\n"; ---- + print REP "This perlbug was built using Perl $config_tag1\n", + "It is being executed now by Perl $config_tag2.\n\n" + if $config_tag2 ne $config_tag1; + + print OUT <<EOF; Site configuration information for perl $]: EOF @@ -548,7 +561,7 @@ EOF print OUT Config::myconfig; if (@patches) { - print OUT join "\n\t", "\nLocally applied patches:", @patches; + print OUT join "\n\t", "Locally applied patches:", @patches; print OUT "\n"; }; @@ -878,8 +891,9 @@ Options: This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. -ok Report successful build on this system to perl porters - (use alone or with -v). - -okay As -ok but also report on older systems. + (use alone or with -v). Only use -ok if *everything* was ok. + If there were *any* problems at all then don't use -ok. + -okay As -ok but allow report from old builds. -h Print this help message. EOF diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 38ea9ee5ca..d223a9aaf9 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -45,10 +45,11 @@ print OUT <<'!NO!SUBS!'; # the perl manuals, though it too is written in perl. if(@ARGV<1) { - $0 =~ s,.*/,,; + $me = $0; # Editing $0 is unportable + $me =~ s,.*/,,; die <<EOF; -Usage: $0 [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName - $0 -f PerlFunc +Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName + $me -f PerlFunc We suggest you use "perldoc perldoc" to get aquainted with the system. @@ -58,6 +59,9 @@ EOF use Getopt::Std; use Config '%Config'; +@global_found = (); +$global_target = ""; + $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; @@ -118,36 +122,60 @@ if ($opt_f) { @pages = @ARGV; } +# Does this look like a module or extension directory? +if (-f "Makefile.PL") { + # Add ., lib and blib/* libs to @INC (if they exist) + unshift(@INC, '.'); + unshift(@INC, 'lib') if -d 'lib'; + require ExtUtils::testlib; +} + sub containspod { - my($file) = @_; - local($_); - open(TEST,"<$file"); - while(<TEST>) { - if(/^=head/) { - close(TEST); - return 1; - } + my($file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod$/i; + local($_); + open(TEST,"<$file"); + while(<TEST>) { + if(/^=head/) { + close(TEST); + return 1; } - close(TEST); - return 0; + } + close(TEST); + return 0; } sub minus_f_nocase { my($file) = @_; # on a case-forgiving file system we can simply use -f $file if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') { - return ( -f $file ) ? $file : ''; + return $file if -f $file and -r _; + warn "Ignored $file: unreadable\n" unless -r _; + return ''; } local *DIR; local($")="/"; my(@p,$p,$cip); foreach $p (split(/\//, $file)){ - if (-d ("@p/$p")){ + my $try = "@p/$p"; + stat $try; + if (-d _){ push @p, $p; - } elsif (-f ("@p/$p")) { - return "@p/$p"; + if ( $p eq $global_target) { + $tmp_path = join ('/', @p); + my $path_f = 0; + for (@global_found) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@global_found, $tmp_path) unless $path_f; + print STDERR "Found as @p but directory\n" if $opt_v; + } + } elsif (-f _ && -r _) { + return $try; + } elsif (-f _) { + warn "Ignored $try: unreadable\n"; } else { my $found=0; my $lcp = lc $p; @@ -161,49 +189,64 @@ sub minus_f_nocase { closedir DIR; return "" unless $found; push @p, $cip; - return "@p" if -f "@p"; + return "@p" if -f "@p" and -r _; + warn "Ignored $file: unreadable\n" if -f _; } } return; # is not a file - } +} - sub searchfor { - my($recurse,$s,@dirs) = @_; - $s =~ s!::!/!g; - $s = VMS::Filespec::unixify($s) if $Is_VMS; - return $s if -f $s && containspod($s); - printf STDERR "looking for $s in @dirs\n" if $opt_v; - my $ret; - my $i; - my $dir; - for ($i=0;$i<@dirs;$i++) { - $dir = $dirs[$i]; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; - if (( $ret = minus_f_nocase "$dir/$s.pod") - or ( $ret = minus_f_nocase "$dir/$s.pm" and containspod($ret)) - or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) - or ( $Is_VMS and - $ret = minus_f_nocase "$dir/$s.com" and containspod($ret)) + +sub check_file { + my($file) = @_; + return minus_f_nocase($file) && containspod($file) ? $file : ""; +} + + +sub searchfor { + my($recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if $Is_VMS; + return $s if -f $s && containspod($s); + printf STDERR "Looking for $s in @dirs\n" if $opt_v; + my $ret; + my $i; + my $dir; + $global_target = (split('/', $s))[-1]; + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; + if ( ( $ret = check_file "$dir/$s.pod") + or ( $ret = check_file "$dir/$s.pm") + or ( $ret = check_file "$dir/$s") + or ( $Is_VMS and + $ret = check_file "$dir/$s.com") or ( $^O eq 'os2' and - $ret = minus_f_nocase "$dir/$s.cmd" and containspod($ret)) + $ret = check_file "$dir/$s.cmd") or ( ($Is_MSWin32 or $^O eq 'os2') and - $ret = minus_f_nocase "$dir/$s.bat" and containspod($ret)) - or ( $ret = minus_f_nocase "$dir/pod/$s.pod") - or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) - { return $ret; } - - if($recurse) { - opendir(D,$dir); - my(@newdirs) = grep(-d,map("$dir/$_",grep(!/^\.\.?$/,readdir(D)))); - closedir(D); - @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; - next unless @newdirs; - print STDERR "Also looking in @newdirs\n" if $opt_v; - push(@dirs,@newdirs); - } - } - return (); - } + $ret = check_file "$dir/$s.bat") + or ( $ret = check_file "$dir/pod/$s.pod") + or ( $ret = check_file "$dir/pod/$s") + ) { + return $ret; + } + + if ($recurse) { + opendir(D,$dir); + my @newdirs = map "$dir/$_", grep { + not /^\.\.?$/ and + not /^auto$/ and # save time! don't search auto dirs + -d "$dir/$_" + } readdir D; + closedir(D); + next unless @newdirs; + @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; + print STDERR "Also looking in @newdirs\n" if $opt_v; + push(@dirs,@newdirs); + } + } + return (); +} foreach (@pages) { @@ -230,12 +273,24 @@ foreach (@pages) { @searchdirs = grep(!/^\.$/,@INC); - @files= searchfor(1,$_,@searchdirs); if( @files ) { print STDERR "Loosely found as @files\n" if $opt_v; } else { - print STDERR "No documentation found for '$_'\n"; + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + my $dir = $file = ""; + for $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while ($file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; + } + } } } push(@found,@files); @@ -290,13 +345,16 @@ if ($opt_f) { # Look for our function my $found = 0; + my @pod; while (<PFUNC>) { if (/^=item\s+\Q$opt_f\E\b/o) { - $found++; + $found = 1; } elsif (/^=item/) { - last if $found; + last if $found > 1; } - push(@pod, $_) if $found; + next unless $found; + push @pod, $_; + ++$found if /^\w/; # found descriptive text } if (@pod) { if ($opt_t) { diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 60b0f54c09..ded0cf419c 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1646,7 +1646,7 @@ case 27: yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } + yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 28: #line 192 "perly.y" @@ -1654,7 +1654,7 @@ case 28: yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } + yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: #line 198 "perly.y" @@ -1674,19 +1674,19 @@ case 31: break; case 32: #line 209 "perly.y" -{ copline = yyvsp[-9].ival; - yyval.opval = block_end(yyvsp[-7].ival, - newSTATEOP(0, yyvsp[-10].pval, - append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval), - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar(yyvsp[-4].opval), - yyvsp[0].opval, scalar(yyvsp[-2].opval))))); } +{ OP *forop = append_elem(OP_LINESEQ, + scalar(yyvsp[-6].opval), + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-9].ival, scalar(yyvsp[-4].opval), + yyvsp[0].opval, scalar(yyvsp[-2].opval))); + copline = yyvsp[-9].ival; + yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); } break; case 33: #line 217 "perly.y" -{ yyval.opval = newSTATEOP(0, - yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, - Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } +{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 34: #line 223 "perly.y" diff --git a/win32/Makefile b/win32/Makefile index 9e4437f853..7a98f84c2c 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -201,6 +201,11 @@ WIN32_OBJ = win32.obj \ win32io.obj \ win32sck.obj +PERL95_OBJ = perl95.obj \ + win32mt.obj \ + win32iomt.obj \ + win32sckmt.obj + DLL_OBJ = perllib.obj $(DYNALOADER).obj CORE_H = ..\av.h \ @@ -356,9 +361,15 @@ perl95.obj : perl95.c win32iomt.obj : win32io.c $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c -$(PERL95EXE): $(PERLDLL) $(CONFIGPM) perl95.obj win32iomt.obj +win32sckmt.obj : win32sck.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c + +win32mt.obj : win32.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c + +$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \ - perl95.obj win32iomt.obj $(PERLIMPLIB) + $(PERL95_OBJ) $(PERLIMPLIB) copy perl95.exe $@ del perl95.exe @@ -469,10 +480,18 @@ minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t cd ..\win32 -test : all +test-prep : all $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) + +test : test-prep + cd ..\t + $(PERLEXE) -I..\lib harness + cd ..\win32 + +test-notty : test-prep + set PERL_SKIP_TTY_TEST=1 cd ..\t $(PERLEXE) -I..\lib harness cd ..\win32 diff --git a/win32/makefile.mk b/win32/makefile.mk index 4696dcbccf..dbac98f7ff 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -267,6 +267,11 @@ WIN32_OBJ = win32.obj \ win32io.obj \ win32sck.obj +PERL95_OBJ = perl95.obj \ + win32mt.obj \ + win32iomt.obj \ + win32sckmt.obj + DLL_OBJ = perllib.obj $(DYNALOADER).obj CORE_H = ..\av.h \ @@ -455,9 +460,15 @@ perl95.obj : perl95.c win32iomt.obj : win32io.c $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c -$(PERL95EXE): $(PERLDLL) $(CONFIGPM) perl95.obj win32iomt.obj +win32sckmt.obj : win32sck.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c + +win32mt.obj : win32.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c + +$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \ - perl95.obj win32iomt.obj $(PERLIMPLIB) + $(PERL95_OBJ) $(PERLIMPLIB) copy perl95.exe $@ del perl95.exe diff --git a/win32/win32io.c b/win32/win32io.c index 12bc645d2d..eeb684620b 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -238,6 +238,7 @@ my_flock(int fd, int oper) #undef LK_ERR #undef LK_LEN +EXT int my_fclose(FILE *pf); #ifdef PERLDLL __declspec(dllexport) @@ -259,7 +260,7 @@ WIN32_IOSUBSYSTEM win32stdio = { fopen, /* (*pfunc_fopen)(const char *path, const char *mode); */ fdopen, /* (*pfunc_fdopen)(int fh, const char *mode); */ freopen, /* (*pfunc_freopen)(const char *path, const char *mode, FILE *pf); */ - fclose, /* (*pfunc_fclose)(FILE *pf); */ + my_fclose, /* (*pfunc_fclose)(FILE *pf); */ fputs, /* (*pfunc_fputs)(const char *s,FILE *pf); */ fputc, /* (*pfunc_fputc)(int c,FILE *pf); */ ungetc, /* (*pfunc_ungetc)(int c,FILE *pf); */ diff --git a/win32/win32sck.c b/win32/win32sck.c index d541a7e3ba..3653fc8b88 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -227,11 +227,11 @@ myfdopen(int fd, char *mode) int retval; if (hWinSockDll == 0) - LoadWinSock(); + return(fdopen(fd, mode)); retval = pgetsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen); if(retval == SOCKET_ERROR && pWSAGetLastError() == WSAENOTSOCK) { - return(_fdopen(fd, mode)); + return(fdopen(fd, mode)); } /* @@ -258,7 +258,7 @@ u_long win32_htonl(u_long hostlong) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return phtonl(hostlong); } @@ -267,7 +267,7 @@ u_short win32_htons(u_short hostshort) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return phtons(hostshort); } @@ -276,7 +276,7 @@ u_long win32_ntohl(u_long netlong) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return pntohl(netlong); } @@ -285,7 +285,7 @@ u_short win32_ntohs(u_short netshort) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return pntohs(netshort); } @@ -503,6 +503,22 @@ win32_socket(int af, int type, int protocol) return s; } +#undef fclose +int +my_fclose (FILE *pf) +{ + int osf, retval; + if (hWinSockDll == 0) /* No WinSockDLL? */ + return(fclose(pf)); /* Then not a socket. */ + osf = TO_SOCKET(fileno(pf)); /* Get it now before it's gone! */ + retval = fclose(pf); /* Must fclose() before closesocket() */ + if (osf != -1 + && pclosesocket(osf) == SOCKET_ERROR + && WSAGetLastError() != WSAENOTSOCK) + retval = EOF; + return retval; +} + struct hostent * win32_gethostbyaddr(const char *addr, int len, int type) { @@ -576,7 +592,7 @@ char FAR * win32_inet_ntoa(struct in_addr in) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return pinet_ntoa(in); } @@ -585,7 +601,7 @@ unsigned long win32_inet_addr(const char FAR *cp) { if(hWinSockDll == 0) - LoadWinSock(); + StartSockets(); return pinet_addr(cp); diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 0ca3ff35db..65a3d75ec1 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -132,7 +132,7 @@ lint: lint $(lintflags) $(defs) $(c) > a2p.fuzz depend: $(mallocsrc) ../makedepend - sh ../makedepend + sh ../makedepend MAKE=$(MAKE) clist: echo $(c) | tr ' ' '\012' >.clist diff --git a/x2p/util.c b/x2p/util.c index e8b666f393..469beb0c14 100644 --- a/x2p/util.c +++ b/x2p/util.c @@ -33,8 +33,8 @@ MEM_SIZE size; ptr = malloc(size ? size : 1); #ifdef DEBUGGING if (debug & 128) - fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",(unsigned long)ptr, - an++,size); + fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",(unsigned long)ptr, + an++,(long)size); #endif if (ptr != Nullch) return ptr; @@ -59,7 +59,7 @@ MEM_SIZE size; #ifdef DEBUGGING if (debug & 128) { fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)where,an++); - fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",(unsigned long)ptr,an++,size); + fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",(unsigned long)ptr,an++,(long)size); } #endif if (ptr != Nullch) |