diff options
248 files changed, 12079 insertions, 4860 deletions
diff --git a/Changes5.004 b/Changes5.004 index 90a8b53374..d0601663ec 100644 --- a/Changes5.004 +++ b/Changes5.004 @@ -51,6 +51,2170 @@ And, of course, the Author of Perl: Larry Wall <larry@wall.org> ---------------- +Version 5.004_05 Maintenance release 5 for 5.004 +---------------- + +"I said to my soul, be still, and wait without hope + For hope would hope for the wrong thing; wait without love + For love would be love of the wrong thing; there is yet faith + But the faith and the love and the hope are all in the waiting. + Wait without thought, for you are not ready for thought: + So the darkness shall be light, and the stillness the dancing." + -- T.S.Eliot, East Coker + + + HEADLINES FOR THIS MAINTENANCE RELEASE + + TBA + + +Change 996 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Negative array subscript unrecognized in regex" + From: Mark-Jason Dominus <mjd@plover.com>, + h.sanden@elsevier.nl (Hugo van der Sanden) + Msg-ID: <19980425040819.13828.qmail@plover.com>, + <199805151514.RAA04121@dorlas.elsevier.nl> + Files: t/base/lex.t toke.c + + Title: "Remove e_fp from toke.c after change 955" + From: Tim Bunce + Files: toke.c + +Change 995 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Fix -e security hole (no longer uses temp file)" + From: Tim Bunce + Files: embed.h perl.h perl.c + +Change 992 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "install non-backwards compatible .pm files into archlib" + From: Tim Bunce + Files: installperl + + Title: "revert "Can't locate" message to original for maintenance" + From: Tim Bunce + Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com> + Files: pod/perldiag.pod pp_ctl.c + +Change 990 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Add tests for die $ref" + From: Graham Barr <gbarr@ti.com> + Msg-ID: <355C6297.121B576B@ti.com> + Files: MANIFEST t/op/die.t + +Change 989 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Fix t/op/ipcmsg.t for Digital UNIX" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199805151337.QAA01174@alpha.hut.fi> + Files: t/op/ipcmsg.t + +Change 986 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Patches for BeOS port of Perl, courtesy of Tom Spindler" + From: Jarkko Hietaniemi <jhi@iki.fi>, Tom Spindler + Msg-ID: <199805042312.CAA09025@alpha.hut.fi> + Files: MANIFEST Configure config_h.SH hints/beos.sh pod/perlfunc.pod + Porting/Glossary README.beos beos/nm.c lib/Term/ReadLine.pm + plan9/config.plan9 pp_sys.c t/io/pipe.t vms/config.vms + win32/config.bc win32/config.vc win32/config_H.bc + win32/config_H.vc + +Change 985 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "allow die $ref" + From: Graham Barr <gbarr@ti.com>, Tim.Bunce@ig.co.uk (Tim Bunce) + Msg-ID: <199805151351.OAA01985@toad.ig.co.uk>, <355C3E67.AF25B9F7@ti.com> + Files: pp_ctl.c pp_sys.c util.c + + Title: "ExtUtils::Manifest could truncate files during "make dist"" + From: "James E Jurach Jr." <muaddib@arrakis.int.ein.cz>, + koenig@kulturbox.de (Andreas J. Koenig) + Msg-ID: <199805111048.MAA02573@arrakis.int.ein.cz>, + <sfc90o8bgie.fsf@dubravka.in-berlin.de> + Files: lib/ExtUtils/Manifest.pm + + Title: "Autosplit doesn't like upper case letters in sub names on VMS" + From: Dan Sugalski <sugalskd@osshe.edu> + Msg-ID: <3.0.5.32.19980330152332.009cb130@osshe.edu> + Files: lib/AutoSplit.pm + + Title: "AutoSplit/AutoLoaded subs: give useful line numbers in warnings etc" + From: "Jesse N. Glick" <jglick@sig.bsh.com>, koenig@anna.mind.de (Andreas + J. Koenig), larry@wall.org (Larry Wall) + Msg-ID: <199709292015.NAA09627@wall.org>, <342FCDDF.23534195@sig.bsh.com>, + <sfc202c9jsb.fsf@anna.in-berlin.de>, + <sfc3efg5rhg.fsf@dubravka.in-berlin.de> + Files: lib/AutoSplit.pm + +Change 984 on 1998/05/15 by TimBunce@ig.co.uk + + ------ CORE LANGUAGE ------ + + Title: "Fix close pipe returning status from wrong child" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, kstar@chapin.edu@ig.co.uk () + Msg-ID: <199805142313.TAA02684@chapin.edu>, + <E0yZ8ah-0005d8-00@taurus.cus.cam.ac.uk> + Files: t/io/pipe.t util.c + + Title: "Avoid English.pm triggering load of Errno.pm" + From: Tim Bunce + Files: gv.c lib/English.pm + + ------ DOCUMENTATION ------ + + Title: "Document child exit cause a parent sleep to end early" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0yZwMK-0000D9-00@taurus.cus.cam.ac.uk> + Files: pod/perlfunc.pod + + ------ EXTENSIONS ------ + + Title: "BSD Platforms need STRUCT_TM_HASZONE for POSIX" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980512095524.8158C-100000@newton.phys> + Files: MANIFEST ext/POSIX/hints/bsdos.pl ext/POSIX/hints/freebsd.pl + ext/POSIX/hints/netbsd.pl ext/POSIX/hints/openbsd.pl + + Title: "MM_VMS.pm fixes for building external library" + From: Dan Sugalski <sugalskd@ous.edu> + Msg-ID: <3.0.5.32.19980511160542.009dd480@ous.edu> + Files: lib/ExtUtils/MM_VMS.pm + + Title: "Appease picky DEC compiler in POSIX.xs" + From: Dan Sugalski <sugalskd@ous.edu> + Msg-ID: <3.0.5.32.19980511161434.009f8bb0@ous.edu> + Files: ext/POSIX/POSIX.xs + + ------ TESTS ------ + + Title: "Fix constant detection in t/op/ipcsem.t for Digit UNIX" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199805121212.PAA15351@alpha.hut.fi> + Files: t/op/ipcsem.t + + Title: "Fix doc bug for system() return value" + From: Daniel Grisinger <dgris@perrin.dimensional.com> + Msg-ID: <Pine.LNX.3.96.980514165608.4062A-100000@perrin.dimensional.com> + Files: pod/perlfunc.pod t/op/exec.t + + ------ UTILITIES ------ + + Title: "Avoid possible constant autoload loop" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Graham Barr <gbarr@ti.com>, Ilya + Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199805141910.PAA26994@monk.mps.ohio-state.edu>, + <355B475A.C5AD4B90@ti.com>, + <E0ya11X-0000hm-00@taurus.cus.cam.ac.uk> + Files: utils/h2xs.PL + + Title: "Further improvements to h2ph.PL" + From: kstar@chapin.edu + Msg-ID: <199805130241.WAA25459@chapin.edu> + Files: utils/h2ph.PL + +Change 982 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "comment init_postdump_symbols issues" + From: Tim Bunce + Files: perl.c + + Title: "Improve sort docs re SUBNAME" + From: circle@azstarnet.com + Msg-ID: <199804281828.LAA22737@andromeda.azstarnet.com> + Files: pod/perlfunc.pod + +Change 981 on 1998/05/15 by TimBunce@ig.co.uk + + Title: "Add hook to tie %! to external Errno.pm module (not included)" + From: Graham Barr <gbarr@ti.com> + Msg-ID: <355080CD.1111BC81@ti.com> + Files: gv.c + +Change 971 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "fix C<print "foo ${\()}"> (pp_refgen fumbles when G_SCALAR, no args)" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199805070402.AAA02858@aatma.engin.umich.edu> + Files: pp.c + +Change 970 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "perlbug reformatted" + From: Dominic Dunlop <domo@vo.lu>, Hugo van der Sanden + <hv@crypt0.demon.co.uk> + Msg-ID: <199805110954.LAA20367@dorlas.elsevier.nl>, + <l03130300b17cebcb6d33@[194.222.64.89]>, + <v03110702b17ccbab6824@[195.95.102.67]> + Files: utils/perlbug.PL + +Change 965 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "Sub declaration cost reduced from ~500 to ~100 bytes" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199805050607.CAA02050@monk.mps.ohio-state.edu> + Files: gv.h gv.c op.c + +Change 949 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "while($x=<>) no longer warns (implicit defined added)" + From: Nick Ing-Simmons <nik@tiuk.ti.com> + Msg-ID: <199805051035.LAA27365@pluto.tiuk.ti.com> + Files: MANIFEST op.c t/op/defins.t + +Change 946 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "Fix PERL_DESTRUCT_LEVEL core dumps" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199805062301.TAA24599@aatma.engin.umich.edu> + Files: perl.c sv.c t/op/misc.t + +Change 944 on 1998/05/14 by TimBunce@ig.co.uk + + Title: "5.004_04-m2 Cleanup of test failures" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199805070416.AAA03082@aatma.engin.umich.edu> + Files: t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t t/op/taint.t + win32/config.bc win32/config.vc + +Change 922 on 1998/05/11 by TimBunce@ig.co.uk + + Assorted patches: + + ------ CORE LANGUAGE ------ + + Title: "incorrect return value for hv_iterinit" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199805031848.OAA20618@aatma.engin.umich.edu> + Files: pod/perlguts.pod hv.c + + ------ DOCUMENTATION ------ + + Title: "perlvar.pod buglet E<EVMSERR>" + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9805041415.AA22185@o09.xray.mpe.mpg.de> + Files: pod/perlvar.pod + + Title: "Improve docs for warning about code after an exec()" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Chaim Frenkel + <chaimf@concentric.net> + Msg-ID: <E0yYUit-0003yb-00@taurus.cus.cam.ac.uk>, + <m3ra22qn1z.fsf@chany-p100.emwp.com> + Files: pod/perlfunc.pod + + Title: "Remove dead code from pod2man" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0yXmuT-0006Ll-00@ursa.cus.cam.ac.uk> + Files: pod/pod2man.PL + + Title: "tweak doc for C<do FILENAME>" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199805090017.UAA06888@aatma.engin.umich.edu> + Files: pod/perlfunc.pod + + Title: "Document integer pragma effect on % operator" + From: Gisle Aas <gisle@aas.no> + Msg-ID: <m3yawjmzhx.fsf@furu.g.aas.no> + Files: pod/perlop.pod + + Title: "Reduce rm command line length in pod/Makefile" + From: Hugo van der Sanden <h.sanden@elsevier.nl> + Msg-ID: <199805041423.QAA13199@dorlas.elsevier.nl> + Files: pod/Makefile + + ------ EXTENSIONS ------ + + Title: "Clarify Termios usage in POSIX.pod" + From: Rocco Caputo <troc@netrus.net> + Msg-ID: <199805101952.PAA12738@ns.netrus.net> + Files: ext/POSIX/POSIX.pod + + ------ LIBRARY ------ + + Title: "Fix File::Find::finddepth typo in trial 2 release" + From: koenig@kulturbox.de (Andreas J. Koenig) + Msg-ID: <sfcbttflsjz.fsf@dubravka.in-berlin.de> + Files: lib/File/Find.pm t/lib/filefind.t + + ------ PORTABILITY - GENERAL ------ + + Title: "Add Porting/patching.pod document" + From: Daniel Grisinger <dgris@tdrenterprises.com> + Msg-ID: <199805030305.XAA16147@relay.pair.com> + Files: MANIFEST Porting/patching.pod + + Title: "hints/machten.sh: disable semctl(), align with devel version" + From: Dominic Dunlop <domo@vo.lu> + Msg-ID: <v03110701b175fc029eb1@[195.95.102.115]> + Files: hints/machten.sh + + Title: "Add VMS specifics to Porting/makerel" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01IWDK1LONRQ0026P0@cor.newman.upenn.edu>, + <199804271732.SAA13762@toad.ig.co.uk>, + <9804250212.AA27695@forte.com> + Files: Porting/makerel + +Change 913 on 1998/05/01 by TimBunce@ig.co.uk + + Update MANIFEST for trial 2. + (Porting/Contract lib/Tie/Handle.pm t/op/tiehandle.t) + +Change 912 on 1998/05/01 by TimBunce@ig.co.uk + + Add t/op/tiehandle.t as xtext to repository (see change 911) + +Change 911 on 1998/05/01 by TimBunce@ig.co.uk + + Title: "Add ERRSV, ERRHV, DEFSV and SAVE_DEFSV for XS 5.005 compatibility" + From: timbo@ig.co.uk (Tim Bunce) + Msg-ID: <199804200854.JAA01482@toad.ig.co.uk> + Files: perl.h + + Title: "Add WRITE & CLOSE to TIEHANDLE" + From: Graham Barr <gbarr@pobox.com> + Msg-ID: <34F63DC8.CA95670F@pobox.com> + Files: pod/perltie.pod lib/Tie/Handle.pm pp_sys.c t/op/tiehandle.t + +Change 910 on 1998/05/01 by TimBunce@ig.co.uk + + Title: "Add warning for Illegal hex digit" + From: Stephen P Potter <spp@spp.users.ds.net>, Stephen Potter + <spp@psasolar.colltech.com>, Tim.Bunce@ig.co.uk (Tim Bunce) + Msg-ID: <199804232219.SAA02267@spp.users.ds.net>, + <199804271409.PAA12819@toad.ig.co.uk>, + <199804280307.WAA12332@psasolar.psa.pencom.com> + Files: pod/perldiag.pod util.c + + Title: "perl_call_method() bug fix (corrupt op pointer)" + From: "Alterman, Eugene" <Eugene.Alterman@bremer-inc.com> + Msg-ID: <510415F72ECFD111A31700A0C9B3CCDE3098@efx98digmasa.bremer-inc.com> + Files: perl.c + + Title: "Fix printf segmentation fault" + From: Hugo van der Sanden <hv@crypt0.demon.co.uk> + Msg-ID: <l03130300b16bebdbc314@[194.222.64.89]> + Files: pp_hot.c + + Title: "Document changed local($a[$i],$b{$j}) behaviour re delete/splice" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01IVMVIHNZ36001NKH@cor.newman.upenn.edu> + Files: pod/perlsub.pod + +Change 909 on 1998/05/01 by TimBunce@ig.co.uk + + Title: "Change Ilya's do_binmode to K&R prototype and move to doio.c" + Files: doio.c util.c + +Change 907 on 1998/05/01 by TimBunce@ig.co.uk + + Title: "Runtime Carp verbosity without aliasing" + From: Joshua.Pritikin@NewYork2.dmg.deuba.com, Tim Bunce + Msg-ID: <H00000e50003936c@MHS> + Files: lib/Carp.pm + + Title: "Fix File::Basename to not untaint results (using new //t flag)" + From: Eric Hammond <erich@finity.citysearch.com>, Tom Phoenix + <rootbeer@teleport.com> + Msg-ID: <199710070515.WAA00682@finity.citysearch.com>, + <Pine.GSO.3.96.971007074114.14211J-100000@usertest.teleport.com> + Files: lib/File/Basename.pm + +Change 906 on 1998/04/28 by TimBunce@ig.co.uk + + ------ CORE LANGUAGE ------ + + Title: "5.004_04m5t1: Fix dangling references in LVs", "Fix dangling + references in LVs" + From: Spider Boardman <spider@orb.nashua.nh.us> + Msg-ID: <199804010541.AAA32615@Orb.Nashua.NH.US>, + <19980422164037.D29222@perl.org> + Files: embed.h keywords.h opcode.h perl.h proto.h doop.c global.sym mg.c + pp.c sv.c + + Title: "Fix SvGMAGIC typo in change 904" + Files: doop.c + +Change 905 on 1998/04/28 by TimBunce@ig.co.uk + + Regexp patches + + Title: "New regex flag //t to leave $1 etc. tainted" + From: Chip Salzenberg <chip@pobox.com>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <19980310192640.37826@cyprus> + Files: pod/perlop.pod pod/perlre.pod op.h dump.c mg.c pp_hot.c sv.c + t/op/taint.t toke.c + + Title: "Don't accidentally untaint target of s///" + From: Chip Salzenberg <chip@pobox.com> + Msg-ID: <19980310151756.24767@cyprus> + Files: pp_ctl.c pp_hot.c t/op/taint.t + + Title: "Allow but ignore embedded /...(?o).../ in regexp" + From: h.sanden@elsevier.nl (Hugo van der Sanden) + Msg-ID: <199804201243.OAA08244@dorlas.elsevier.nl> + Files: regcomp.c + +Change 904 on 1998/04/27 by TimBunce@ig.co.uk + + Assorted patches: + + ------ CORE LANGUAGE ------ + + Title: "Protect join() against double reads on undef and SvGMAGICALs" + From: Chip Salzenberg <chip@perlsupport.com>, Tim Bunce + <Tim.Bunce@ig.co.uk> + Msg-ID: <19980424080630.D13985@perl.org> + Files: doop.c + + Title: "Better error message for require failure" + From: epeschko@den-mdev1 (Ed Peschko) + Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com> + Files: pod/perldiag.pod pp_ctl.c + + Title: "fixes for various noises under PERL_DESTRUCT_LEVEL" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199804231926.PAA23969@aatma.engin.umich.edu> + Files: perl.c + + Title: "Fix nice_chunk memory leak" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199804052347.TAA15699@aatma.engin.umich.edu> + Files: sv.c + + Title: "-2.0 vs. -2 (was Number representations)" + From: Chip Salzenberg <chip@pobox.com> + Msg-ID: <19980309185652.11231@cyprus> + Files: op.c + + Title: "perl.c fixes for -DUNEXEC" + From: Matt Wette <mwette@mr-ed.jpl.nasa.gov>, Matthew R Wette + <mwette@mr-ed.jpl.nasa.gov> + Msg-ID: <199710152146.OAA07283@mr-ed.jpl.nasa.gov> + Files: perl.c + + ------ DOCUMENTATION ------ + + Title: "perlcall is Perl from C, not C from Perl" + From: Steve A Fink <sfink@cs.berkeley.edu> + Files: pod/perlembed.pod + + Title: "Clarify require "Foo::Bar" non-bareword issue" + From: Dominique Dumont <domi@ss7serv.grenoble.hp.com> + Msg-ID: <199804231527.AA153445256@ss7serv.grenoble.hp.com> + Files: pod/perlfunc.pod + + Title: "(repost) new text for perlsec", "new text for perlsec" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.980423161605.5518N-100000@user2.teleport.com> + Files: pod/perlsec.pod + + ------ EXTENSIONS ------ + + Title: "IO::Socket->socketpair broken (typo)" + From: Olaf Titz <olaf@bigred.inka.de> + Msg-ID: <19980425224535.2807.qmail@bigred.inka.de> + Files: ext/IO/lib/IO/Socket.pm + + Title: "NDBM_File man page needs Fcntl" + From: "Danny R. Faught" <faught@mailhost.rsn.hp.com> + Msg-ID: <199707011500.IAA00601@palrel3.hp.com> + Files: ext/NDBM_File/NDBM_File.pm + + ------ LIBRARY ------ + + Title: "Documentation discrepancy: pragmatic modules" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, h.sanden@elsevier.nl (Hugo van der Sanden) + Msg-ID: <199804221525.RAA12695@dorlas.elsevier.nl>, + <E0ySPhk-00034f-00@taurus.cus.cam.ac.uk> + Files: lib/strict.pm lib/subs.pm lib/vars.pm + + ------ PORTABILITY - GENERAL ------ + + Title: "Updated hints file for svr4" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980423110522.26621A-100000@newton.phys> + Files: hints/svr4.sh + + Title: "Pumpkin update -- shared libperl.so location" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980424115837.6222A-100000@newton.phys> + Files: Porting/pumpkin.pod + + Title: "perl compile fix for AIX 4.3" + From: Jens-Uwe Mager <jum@helios.de> + Msg-ID: <199804261611.SAA34728@ans.helios.de> + Files: ext/DynaLoader/dl_aix.xs + + Title: "Dynaloader build on VMS", + From: pvhp@forte.com (Peter Prymmer), timbo@ig.co.uk (Tim Bunce) + Msg-ID: <199804271732.SAA13762@toad.ig.co.uk>, <9804250212.AA27695@forte.com> + Files: vms/descrip.mms + + ------ UTILITIES ------ + + Title: "Major update to h2ph.PL" + From: Billy <wdconsta@cs.adelaide.edu.au> + Msg-ID: <Pine.SV4.3.93.980424031837.20782A-200000@ermintrude.teaching.cs.adelaide.edu.au> + Files: utils/h2ph.PL + +Change 897 on 1998/04/23 by TimBunce@ig.co.uk + + Assorted patches: + + ------ CORE LANGUAGE ------ + + Title: "fix for "Unbalanced string table refcount"" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199804042251.RAA25527@aatma.engin.umich.edu> + Files: sv.c + + Title: "Allow more lenient switch processing" + From: "John L. Allen" <allen@grumman.com> + Msg-ID: <199803251638.LAA22664@gateway.grumman.com> + Files: perl.c + + Title: "Add fourth arg to substr: substr EXPR,OFFSET,LEN,REPLACEMENT" + From: Gisle Aas <gisle@aas.no> + Msg-ID: <m3g1jglqtm.fsf@furu.g.aas.no> + Files: pod/perlfunc.pod Todo opcode.pl pp.c t/op/substr.t + + Title: "Odd number of elements in hash list." + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.980328151929.29336D-100000@user2.teleport.com> + Files: MANIFEST pod/perldiag.pod pp.c pp_hot.c t/op/hashwarn.t + + Title: "another destruct_level fix" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199804030105.UAA04400@aatma.engin.umich.edu> + Files: hv.c + + Title: "bidirectional pipe warning blues" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9804082151.AA20399@claudius.bfsec.bt.co.uk> + Files: doio.c + + Title: "stale pointers after realloc (MEXTEND in pp_print and pp_prtf)" + From: Malcolm Beattie <mbeattie@sable.ox.ac.uk> + Msg-ID: <199801191107.LAA17979@sable.ox.ac.uk> + Files: pp_hot.c pp_sys.c + + Title: "unimplemented umask() should return undef not die" + From: kstar@chapin.edu (Kurt D. Starsinic) + Msg-ID: <199803120515.VAA08660@chapin.edu> + Files: pod/perlfunc.pod pp_sys.c + + Title: "warning for: bless $foo, """ + From: Joshua.Pritikin@NewYork2.dmg.deuba.com + Msg-ID: <H00000e5000378a0@MHS> + Files: pod/perldiag.pod pp.c + + ------ DOCUMENTATION ------ + + Title: "Mention SWIG in perlxs.pod" + From: Steve A Fink <sfink@cs.berkeley.edu> + Msg-ID: <Pine.HPP.3.96.980408154956.20990K-100000@brooksie.CS.Berkeley.EDU> + Files: pod/perlxs.pod + + Title: "fix-up of previous perlre.pod patch" + From: Ted Ashton <ashted@southern.edu> + Msg-ID: <199803031540.KAA09388@ns.southern.edu> + Files: pod/perlre.pod + + Title: "long list of man page nitpicks" + From: Greg Bacon <gbacon@mickey.cs.uah.edu>, Tom Christiansen + <tchrist@jhereg.perl.com> + Msg-ID: <199804221844.NAA08338@pluto.cs.uah.edu>, + <199804222204.QAA20805@jhereg.perl.com> + Files: pod/perlapio.pod pod/perlcall.pod pod/perldebug.pod pod/perldelta.pod + pod/perldiag.pod pod/perlembed.pod pod/perlfaq2.pod + pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod + pod/perlfaq7.pod pod/perlfaq8.pod pod/perlform.pod + pod/perlfunc.pod pod/perlguts.pod pod/perlipc.pod + pod/perllocale.pod pod/perlmodlib.pod pod/perlop.pod + pod/perlre.pod pod/perlref.pod pod/perlrun.pod + pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod + pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod + pod/pod2man.PL + + Title: "document that system() does not set $! when it fails" + From: "Mark R. Levinson" <mrl@isc.upenn.edu> + Msg-ID: <199803011946.OAA31942@anaximander.dccs.upenn.edu> + Files: pod/perlfunc.pod + + Title: "Fix pod/roffitall execute permission" + From: lvirden@cas.org + Msg-ID: <1997Nov17.132031.2589892@cor.newman> + Files: pod/roffitall + + Title: "document when split ignores trailing empty fields" + From: Hugo van der Sanden <hv@crypt0.demon.co.uk> + Msg-ID: <l03130300b14fac832b77@[194.222.64.89]> + Files: pod/perlfunc.pod + + ------ EXTENSIONS ------ + + Title: "Buglet in Opcode.pm documentation" + From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl> + Msg-ID: <199804170349.XAA32445@sleipnir.valparaiso.cl> + Files: ext/Opcode/Opcode.pm + + Title: "Failure to append to perllocal.pod should not be fatal" + From: koenig@kulturbox.de (Andreas J. Koenig) + Msg-ID: <sfciuogy67x.fsf@dubravka.in-berlin.de> + Files: lib/ExtUtils/MM_Unix.pm + + Title: "Document that IO.pm does not load IO::Select etc" + From: Graham Barr <gbarr@ti.com> + Msg-ID: <353B48F1.64E35A63@ti.com> + Files: ext/IO/IO.pm + + Title: "Install extensions with bootstrap (again) in $archlib" + From: Achim Bohnet <ach@mpe.mpg.de>, koenig@kulturbox.de (Andreas J. + Koenig) + Msg-ID: <9804061909.AA12675@o09.xray.mpe.mpg.de>, + <sfc90oxc0uj.fsf@dubravka.in-berlin.de> + Files: lib/ExtUtils/Install.pm + + Title: "glibc2.0.6 missing MSG_* <sys/socket.h> defines." + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980406113950.3166L-100000@newton.phys> + Files: ext/Socket/Socket.xs + + ------ LIBRARY ------ + + Title: "Benchmark.pm: add run-for-some-time mode" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199804080647.JAA15136@alpha.hut.fi> + Files: lib/Benchmark.pm + + Title: "Comments added to Carp.pm" + From: Andy Wardley <abw@cre.canon.co.uk>, Chip Salzenberg + <chip@perlsupport.com>, Tom Christiansen + <tchrist@jhereg.perl.com> + Msg-ID: <19980422164242.E29222@perl.org>, + <199804222033.OAA17959@jhereg.perl.com>, + <980409182357.ZM21638@bandanna> + Files: lib/Carp.pm + + Title: "chat2.pl fix" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01IVMVF507PO001NKH@cor.newman.upenn.edu> + Files: lib/chat2.pl + + Title: "lib/Pod/Html.pm" + From: d-lewart@uiuc.edu (Daniel S. Lewart) + Msg-ID: <199710170718.DAA25472@staff1.cso.uiuc.edu>, + <199710180417.AAA19778@staff2.cso.uiuc.edu> + Files: lib/Pod/Html.pm + + Title: "ormaments method in Term/ReadLine.pm causes warning with string + arg." + From: hiroo.hayashi@computer.org + Msg-ID: <199804061519.AAA21907@mail.fb3.so-net.ne.jp> + Files: lib/Term/ReadLine.pm + + ------ OTHER CHANGES ------ + + Title: "ptags broken" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199804120208.WAA29264@monk.mps.ohio-state.edu> + Files: emacs/ptags + + ------ PORTABILITY - WIN32 ------ + + Title: "win32 tweaks (signals and crypt support)" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199804170505.BAA06413@aatma.engin.umich.edu> + Files: perl.h win32/config.bc win32/config.vc win32/config_H.bc + win32/config_H.vc win32/win32.c + + ------ PORTABILITY - GENERAL ------ + + Title: "Add Social Contract (2nd Draft) as Porting/Contract" + From: Russ Allbery <rra@stanford.edu> + Msg-ID: <m3btw66n8i.fsf@windlord.Stanford.EDU> + Files: Porting/Contract + + Title: "Config: Irix 5 hints" + From: kstar@O2.chapin.edu + Msg-ID: <199804061712.NAA22823@O2.chapin.edu> + Files: hints/irix_5.sh + + Title: "VMS patches to 5.004_03" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01IVYJS0L8D200209B@cor.newman.upenn.edu> + Files: vms/vms.c + + Title: "hints/netbsd.sh - enable vfork" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980417110749.19327B-100000@newton.phys> + Files: hints/netbsd.sh + + ------ UTILITIES ------ + + Title: "support find2perl -follow" + From: Billy <wdconsta@cs.adelaide.edu.au> + Msg-ID: <Pine.SV4.3.93.980408005903.24081A-100000@ermintrude.teaching.cs.adelaide.edu.au> + Files: x2p/find2perl.PL + +Change 896 on 1998/04/22 by TimBunce@ig.co.uk + + Assorted patches: + + ------ CORE LANGUAGE ------ + + Title: "Additional regex-cache patch" + From: Chip Salzenberg <chip@atlantic.net> + Msg-ID: <19980305104831.38100@cyprus> + Files: pp_ctl.c + + Title: "Conservative C<*x = undef> patch" + From: Chip Salzenberg <chip@atlantic.net> + Msg-ID: <19980310163310.48509@cyprus> + Files: pod/perldiag.pod pod/perlfunc.pod pp.c sv.c t/op/gv.t + + Title: "Consider @ARGV to be plain files if inplace (-i)" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199802042106.QAA04082@nielsenmedia.com> + Files: doio.c + + Title: "Fix semctl for Linux, Sun and SVR4" + From: Graham Barr <gbarr@ti.com>, lvirden@cas.org (Larry W. Virden, x2487) + Msg-ID: <3484247D.BB036D39@ti.com>, <9712021313.AA11495@cas.org> + Files: doio.c + + Title: "C<dSP> entails using C<SP>, not C<sp>" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199803070149.UAA12217@aatma.engin.umich.edu> + Files: pod/perlcall.pod pod/perlembed.pod pod/perlguts.pod pod/perlxs.pod + doio.c doop.c ext/DB_File/DB_File.xs + ext/DynaLoader/dl_dld.xs ext/Opcode/Opcode.xs + ext/POSIX/POSIX.xs ext/Socket/Socket.xs gv.c + lib/ExtUtils/typemap mg.c os2/OS2/REXX/REXX.xs + win32/win32.c + + Title: "Make autouse -w-safe" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199803030236.VAA13244@monk.mps.ohio-state.edu> + Files: lib/autouse.pm op.c sv.c + + Title: "Misleading error on close of unopened handle" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0y4R07-0003PH-00@ursa.cus.cam.ac.uk> + Files: doio.c + + Title: "Confusing error from perl -e "x'"" + From: Hans Mulder <hansmu@xs4all.nl> + Msg-ID: <1998Mar25.174320.2866352@cor.newman.upenn.edu> + Files: toke.c + + Title: "Add HAS_GNULIBC define" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980305115202.9180K-100000@newton.phys> + Files: config_H config_h.SH + + Title: "h_errno might not be an int" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980325165059.22255D-100000@newton.phys> + Files: pp_sys.c + + Title: "Revised taint hole closer", "Revised taint hole closer" + From: Chip Salzenberg <chip@atlantic.net>, Ilya Zakharevich + <ilya@math.ohio-state.edu> + Msg-ID: <19980310222127.09350@cyprus>, + <199803110554.AAA29157@monk.mps.ohio-state.edu> + Files: doio.c + + Title: "SEGV compiling localised lexical in perl5.004_05t1" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, h.sanden@elsevier.nl (Hugo + van der Sanden) + Msg-ID: <199803171530.QAA24053@dorlas.elsevier.nl>, + <199803171727.MAA05234@aatma.engin.umich.edu> + Files: op.c t/op/misc.t + + Title: "Stale SP in pp_substr" + From: Stephen McCamant <alias@mcs.com> + Msg-ID: <m0yFsTS-000EZpC@alias-2.pr.mcs.net> + Files: pp.c + + Title: "Statement unlikely to be reached warning" + From: Hans Mulder <hansm@icgned.nl> + Msg-ID: <1997Dec24.171511.2683516@cor.newman> + Files: op.c + + Title: "Tainting propagates from nowhere" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199803140411.XAA09343@aatma.engin.umich.edu> + Files: pp.c + + Title: "two trivial tweaks to 5.004m5t1" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199803060553.AAA28461@aatma.engin.umich.edu> + Files: proto.h win32/Makefile + + Title: "unpacking negatives on Alpha" + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9710201503.AA24797@o09.xray.mpe.mpg.de> + Files: pp.c t/op/pack.t + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "Cwd.pm: abs_path() and fast_abs_path() plus code merge" + From: Graham Barr <gbarr@ti.com> + Msg-ID: <3482F365.4A0486BA@ti.com> + Files: lib/Cwd.pm + + Title: "Math/BigInt.pm, fixed use of undefined value." + From: abigail@fnx.com + Msg-ID: <19980313052452.27365.qmail@betelgeuse.wayne.fnx.com> + Files: lib/Math/BigInt.pm + + Title: "File::Find rewrite" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199803052344.SAA01008@monk.mps.ohio-state.edu> + Files: lib/File/Find.pm + + Title: "efficient version of strict.pm" + From: koenig@anna.mind.de (Andreas J. Koenig) + Msg-ID: <sfcpvonhdnc.fsf@anna.in-berlin.de> + Files: lib/strict.pm + + Title: "Socket occasional SEGV in pack_sockaddr_un" + From: Trevor Blackwell <tlb@viaweb.com> + Msg-ID: <199710281804.NAA09632@wagg.viaweb.com> + Files: ext/Socket/Socket.xs + + Title: "Warning on mis-use of 'use lib'" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Tom Phoenix + <rootbeer@teleport.com>, chip@atlantic.net + Msg-ID: <199801270435.XAA14147@cyprus.atlantic.net>, + <E0xx9x4-0006jc-00@ursa.cus.cam.ac.uk>, + <Pine.GSO.3.96.980126192445.22284N-100000@user2.teleport.com> + Files: lib/lib.pm + + Title: "bug in Class::Struct" + From: Tom Christiansen <tchrist@toy.perl.com> + Msg-ID: <199803290814.KAA05699@toy.perl.com> + Files: lib/Class/Struct.pm + + Title: "Allow POSIX to export nice()" + From: bkeelerx@iwa.dp.intel.com (Bruce J. Keeler) + Msg-ID: <eclg1kf5yf0.fsf@ws010.dp.intel.com> + Files: ext/POSIX/POSIX.pm + + Title: "'use Env' on WinNT/95 fails" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199803280511.AAA15933@aatma.engin.umich.edu> + Files: lib/Env.pm + + ------ OTHER CHANGES ------ + + Title: "mv-if-diff" + From: Robin Barker <rmb1@cise.npl.co.uk> + Msg-ID: <14572.9803271806@tempest.cise.npl.co.uk> + Files: mv-if-diff + + ------ PORTABILITY - WIN32 ------ + + Title: "fix various problems with backticks on win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199803070705.CAA15945@aatma.engin.umich.edu> + Files: win32/config_h.PL win32/win32.c + + ------ TESTS ------ + + Title: "Fix bug in locale.t" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199801042148.XAA08599@alpha.hut.fi> + Files: t/pragma/locale.t + +Change 887 on 1998/04/10 by TimBunce@ig.co.uk + + Assorted patches: + + ------ CORE LANGUAGE ------ + + Title: "Re: die exits with 0" + From: Robin Barker <rmb1@cise.npl.co.uk> + Files: perl.c t/op/die_exit.t + + Title: "More toke.c commentary; fix oddity" + From: h.sanden@elsevier.nl (Hugo van der Sanden) + Msg-ID: <199803251022.LAA01308@dorlas.elsevier.nl> + Files: toke.c + + Title: "for semctl on solaris" + From: Graham Barr <gbarr@ti.com> + Msg-ID: <34624B80.C014E841@ti.com> + Files: doio.c t/op/ipcmsg.t t/op/ipcsem.t + + ------ DOCUMENTATION ------ + + Title: "Add more 'see also's to perlre.pod.", "Perl regexp /g modifier bug" + From: Ilya Zakharevich <ilya@math.ohio-state.edu>, epeschko@den-mdev1 (Ed + Peschko), pjr@watcher.telstra.com.au (Peter Richardson) + Msg-ID: <199803050000.LAA11476@watcher.telecom.com.au>, + <199803050231.VAA19128@monk.mps.ohio-state.edu>, + <199803050605.XAA09785@den-mdev1.co.csgsystems.com> + Files: pod/perlre.pod + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "BigFloat - small neagtive numbers cause panic" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199711201325.NAA09732@crypt.compulink.co.uk> + Files: lib/Math/BigFloat.pm + + Title: "Update Getopt::Long to 2.16" + From: JVromans@Squirrel.nl (Johan Vromans), Johan Vromans + <jvromans@squirrel.nl> + Msg-ID: <13571.48089.726787.147769@plume.nl.compuware.com>, + <13572.6847.863219.973795@phoenix.squirrel.nl> + Files: lib/Getopt/Long.pm + + Title: "New Text::ParseWords" + From: pomeranz@netcom.com (Hal Pomeranz) + Msg-ID: <199710162118.OAA06275@netcom7.netcom.com> + Files: lib/Text/ParseWords.pm t/lib/parsewords.t + + Title: "Fixed Text/Wrap.pm bugs (2)" + From: Jacqui Caren <Jacqui.Caren@ig.co.uk> + Msg-ID: <199709291548.QAA08645@toad.ig.co.uk> + Files: lib/Text/Wrap.pm + + Title: "Very *evil* File::CheckTree behavior! (now uses warn/die not + print/exit)" + From: Eryq <eryq@zeegee.com>, Randal Schwartz <merlyn@stonehenge.com> + Msg-ID: <34B542FD.190A@zeegee.com>, <8cen2i9k6f.fsf@gadget.cscaper.com> + Files: lib/File/CheckTree.pm + + ------ OTHER CHANGES ------ + + Title: "Add ./emacs/ptags" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199803150847.DAA08196@monk.mps.ohio-state.edu> + Files: emacs/ptags + + ------ TESTS ------ + + Title: "Avoid stat test failure from build in /tmp (tmpfs)", "Build in /tmp" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Greg Bacon + <gbacon@adtran.com>, pudge@pobox.com (Chris Nandor) + Msg-ID: <199710171616.LAA13435@crp-201.adtran.com>, + <Pine.SUN.3.96.971017171023.2349A-100000@newton.phys>, + <v02130515b06be80f1486@[205.228.240.16]> + Files: t/op/stat.t + + Title: "for failure with lib/timelocal" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, jan.dubois@ibm.net (Jan Dubois) + Msg-ID: <34c78f61.2529827@smtp1.ibm.net>, + <E0xvdfI-00057d-00@ursa.cus.cam.ac.uk> + Files: t/lib/timelocal.t + + Title: "Make "localhost" related failures more clear" + From: Paul Hoffman <phoffman@proper.com> + Msg-ID: <199801201859.KAA05686@mail.proper.com> + Files: t/lib/io_sock.t t/lib/io_udp.t + + ------ UTILITIES ------ + + Title: "Let h2xs read multiple header files" + From: Andy Dougherty <doughera@lafcol.lafayette.edu>, Benjamin Sugars + <bsugars@canoe.ca> + Msg-ID: <Pine.SOL.3.95.980310091946.25236A-100000@interact>, + <Pine.SUN.3.96.980310145455.638A-100000@newton.phys> + Files: utils/h2xs.PL + +Change 886 on 1998/04/10 by TimBunce@ig.co.uk + + Changes relating primarily to portability. + + ------ CORE LANGUAGE ------ + + Title: "5.004_55: Another round of OS/2 patches" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199803050945.EAA20153@monk.mps.ohio-state.edu> + Files: hints/os2.sh pod/perlguts.pod cop.h perl.h proto.h README.os2 + global.sym lib/ExtUtils/MM_OS2.pm lib/File/Path.pm op.c + os2/Changes os2/Makefile.SHs os2/os2.c os2/perl2cmd.pl + perl.c pod/pod2man.PL pp_ctl.c pp_hot.c pp_sys.c + t/lib/filecopy.t util.c utils/perldoc.PL + + Title: "VMS: chdir() with empty arg list" + From: lane@duphy4.drexel.edu (Charles Lane) + Msg-ID: <980317125556.222041c7@DUPHY4.Physics.Drexel.Edu> + Files: pp_sys.c + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "ExtUtils/MM_Unix.pm changed to use ld -rpath on IRIX" + From: "W. Phillip Moore" <wpm@ms.com> + Msg-ID: <199712011738.MAA21139@zappa.morgan.com> + Files: lib/ExtUtils/MM_Unix.pm + + Title: "[Linux] POSIX::_[PS]C_.+ bug (add HINT_SC_EXIST)" + From: Yutaka OIWA <oiwa@is.s.u-tokyo.ac.jp> + Msg-ID: <199712251923.EAA08260@tjms1f.is.s.u-tokyo.ac.jp> + Files: ext/POSIX/hints/linux.pl ext/POSIX/POSIX.xs + + Title: "5.004_04-m1] Use HAS_GNULIBC in POSIX.xs" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980305115517.9180L-100000@newton.phys> + Files: ext/POSIX/POSIX.xs + + Title: ""ODBM_File.c", line 275: NULL undefined" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9803091310.AA23264@claudius.bfsec.bt.co.uk> + Files: ext/ODBM_File/ODBM_File.xs + + ------ PORTABILITY - GENERAL ------ + + Title: "5.004_04 QNX getcwd" + From: Norton Allen <allen@huarp.harvard.edu> + Msg-ID: <199802121838.NAA20452@dolores.harvard.edu>, + <199803061511.KAA22346@bottesini.harvard.edu> + Files: hints/qnx.sh lib/Cwd.pm t/op/magic.t + + Title: "hints/netbsd.sh d_setrgid d_setruid" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199802281435.QAA10866@alpha.hut.fi> + Files: hints/netbsd.sh + + Title: "osname=unixware, osvers=2.03, archname=i386-unixware + d_casti32=undef" + From: Tom Hughes <tom@compton.demon.co.uk> + Msg-ID: <465398da47%tom@compton.demon.co.uk> + Files: hints/svr4.sh + + Title: "hints/bsdos.sh patch for BSDI 3.1" + From: Jan-Pieter Cornet <johnpc@xs4all.nl> + Msg-ID: <6fbip6$3cp$1@xs1.xs4all.nl> + Files: hints/bsdos.sh + + Title: "Remove BIND_NOSTART from DynaLoader for HP" + From: Keong Lim <Keong.Lim@sr.com.au> + Msg-ID: <01BD1D03.53B65E90@sieplan2.sr.com.au> + Files: ext/DynaLoader/dl_hpux.xs + + Title: "Building Perl on AIX 4+ with shared libraries and dynamic loading" + From: Juan Gallego <Little.Boss@physics.mcgill.ca> + Msg-ID: <Pine.SGI.3.91.971022084517.17052F-100000@nazgul.physics.mcgill.ca> + Files: hints/aix.sh + + Title: "alpha-dec_osf 5.0" + From: Spider Boardman <spider@Orb.Nashua.NH.US> + Msg-ID: <199712232305.SAA08359@Orb.Nashua.NH.US> + Files: hints/dec_osf.sh + + Title: "Off-by-one error with OS2::PrfDB" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710170920.FAA00390@monk.mps.ohio-state.edu> + Files: os2/OS2/PrfDB/PrfDB.xs + + Title: "5.004_04-m1] Allow overrides in hints/openbsd.sh" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980305115956.9180N-100000@newton.phys> + Files: hints/openbsd.sh + + Title: "5.004_04-m1] Linux shouldn't use -lnet" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980305115843.9180M-100000@newton.phys> + Files: hints/linux.sh + + Title: "5.004_(04|63)] Close VMS security hole" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01IV6LRJCSSC0009C4@cor.newman.upenn.edu> + Files: vms/vms.c + + Title: "Re: Perl online documentation on OpenVMS" + From: pvhp@forte.com (Peter Prymmer) + Msg-ID: <9803192143.AA28120@forte.com> + Files: README.vms + + Title: "Perl5.004_04m4t4 *almost* makes it for VMS", "Updated + vms/perly_c.vms and vms/perly_h.vms" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Dan Sugalski + <sugalskd@osshe.edu>, larry@wall.org (Larry Wall) + Msg-ID: <199710151650.JAA29185@wall.org>, + <3.0.3.32.19971014150404.02fdef78@osshe.edu>, + <Pine.SUN.3.96.971015121704.28456F-100000@newton.phys> + Files: vms/perly_c.vms + + Title: "Updated, non-wordwrapped, patch to README.VMS" + From: Dan Sugalski <sugalskd@osshe.edu> + Msg-ID: <3.0.5.32.19980213133828.0092c870@osshe.edu> + Files: README.vms + + Title: "VMS patches to 5.004_03 (excluding installperl and timelocal.t)" + From: Charles Bailey <BAILEY@newman.upenn.edu> + Msg-ID: <01INZT9G2LZS0006YW@cor.newman.upenn.edu> + Files: lib/File/Basename.pm lib/File/Path.pm vms/config.vms vms/descrip.mms + vms/genconfig.pl vms/test.com vms/vms.c vms/ext/Filespec.pm + vms/ext/filespec.t + + Title: "Re: VMSperl crashes on -Mblib argument" + From: bailey@newman.upenn.edu (Charles Bailey) + Msg-ID: <1997Dec10.004439.2635060@cor.newman> + Files: lib/blib.pm vms/vms.c + + Title: "hints/linux.sh (MkLinux / PPC)" + From: pudge@pobox.com (Chris Nandor) + Msg-ID: <v0213050cb06c19682a25@[205.228.240.28]> + Files: hints/linux.sh + + Title: "hpux.sh hints file clarification suggestion" + From: root@qad.com + Msg-ID: <199802192351.QAA09096@jhereg.perl.com> + Files: hints/hpux.sh + + Title: "new hints/solaris_2.sh" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0xw80h-0005SV-00@ursa.cus.cam.ac.uk> + Files: hints/solaris_2.sh + +Change 873 on 1998/04/03 by TimBunce@ig.co.uk + + Title: "FileHandle Documentation patch" + From: "Darren/Torin/Who Ever..." <torin@daft.com> + Msg-ID: <87emzqo49g.fsf@perv.daft.com> + Files: lib/FileHandle.pm + +Change 872 on 1998/04/03 by TimBunce@ig.co.uk + + Documentation and documentation related patches: + + ------ BUILD PROCESS ------ + + Title: "Docs re /usr/bin/perl quasi-standard location" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.971117080737.12318C-100000@usertest.teleport.com> + Files: INSTALL pod/perlrun.pod + + ------ DOCUMENTATION ------ + + Title: "/RFC|RFC-1305/ non-greedy" + From: Jan-Pieter Cornet <johnpc@xs4all.nl> + Msg-ID: <6epo02$c4r$1@xs1.xs4all.nl> + Files: pod/perlre.pod + + Title: "5.004_04: perlhist.pod, buildtoc, perltoc.pod" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199802191543.RAA29231@alpha.hut.fi> + Files: pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc + + Title: "5.004_04: pod/perlfunc.pod: i18n example for localtime()" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199711141555.RAA18875@alpha.hut.fi> + Files: pod/perlfunc.pod + + Title: "typo-fix and suggestion for perlguts.pod" + From: h.sanden@elsevier.nl (Hugo van der Sanden) + Msg-ID: <199803051543.QAA03097@dorlas.elsevier.nl> + Files: pod/perlguts.pod + + Title: "perlfunc/syscall curiosity" + From: Roderick Schertler <roderick@argon.org>, Tkil + <tkil@reptile.scrye.com> + Msg-ID: <199711302259.PAA02134@reptile.scrye.com>, + <pziut8snva.fsf@eeyore.ibcinc.com> + Files: pod/perlfunc.pod + + Title: "Document sprintf %#x behaviour for zero value" + From: ilya@math.ohio-state.edu (Ilya Zakharevich) + Msg-ID: <1997Nov5.185959.2539604@cor.newman> + Files: pod/perlfunc.pod + + Title: "NUL termination (was Re: STOP THE PRESSES)" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0xsn5M-0002gw-00@ursa.cus.cam.ac.uk> + Files: pod/perlguts.pod + + Title: "Typo fix." + From: abigail@fnx.com + Msg-ID: <19971101120114.1030.qmail@betelgeuse.wayne.fnx.com> + Files: pod/perlop.pod pod/perlvar.pod + + Title: "5.004_63 perlrun.pod: _DEBUG_MSTATS" + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9803181940.AA22587@o09.xray.mpe.mpg.de> + Files: pod/perlrun.pod + + Title: "Re: Conservative C<*x = undef> patch" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0yCjHT-0005Dt-00@ursa.cus.cam.ac.uk> + Files: pod/perltrap.pod + + Title: "perlfunc.pod for flock()" + From: "Jeremy D. Zawodny" <jzawodn@wcnet.org> + Msg-ID: <3.0.5.32.19971118203119.00a723e0@woody.wcnet.org> + Files: pod/perlfunc.pod + + Title: "buglet: 'perltoc' not mentioned in perl.pod" + From: Tkil <tkil@scrye.com> + Msg-ID: <19971127035036.17668.qmail@scrye.com> + Files: pod/perl.pod + + Title: "for() and map() peculiarity" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0y4YAa-0003Qu-00@ursa.cus.cam.ac.uk> + Files: pod/perlsyn.pod + + Title: "Re: new text for perlsec" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.980328100418.22321T-100000@user2.teleport.com> + Files: pod/perlsec.pod + + Title: "perldsc's debugger x command" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <10669.878352893@eeyore.ibcinc.com> + Files: pod/perldsc.pod + + Title: "perlre.pod" + From: Ted Ashton <ashted@southern.edu> + Msg-ID: <199802271501.KAA09279@ns.southern.edu> + Files: pod/perlre.pod + + Title: "Re: printf and $\", "printf and $\" + From: Roderick Schertler <roderick@argon.org>, Tom Phoenix + <rootbeer@teleport.com>, nag <nick@flirble.org> + Msg-ID: <199711141918.TAA08096@flirble.org>, + <Pine.GSO.3.96.971117085421.12318J-100000@usertest.teleport + .com>, <pzyb2ncr42.fsf@eeyore.ibcinc.com> + Files: pod/perlfunc.pod + + Title: "recv() typo" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <12064.877012073@eeyore.ibcinc.com> + Files: pod/perlfunc.pod + + Title: "truncate return value" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <5490.878337883@eeyore.ibcinc.com> + Files: pod/perlfunc.pod + + Title: "update to perlbook.pod" + From: "Nathan V. Patwardhan" <nvp@mediaone.net>, Randal Schwartz + <merlyn@stonehenge.com>, Stephen Potter + <spp@psasolar.colltech.com>, Tom Phoenix + <rootbeer@teleport.com> + Msg-ID: <199803241354.HAA23938@psasolar.psa.pencom.com>, + <199803241441.OAA01261@mediaone.net>, + <8clnu0i05k.fsf@gadget.cscaper.com>, + <Pine.GSO.3.96.980324111957.15753C-100000@user1.teleport.com> + Files: pod/perlbook.pod + + Title: "utime documentation" + From: "Brandon S. Allbery KF8NH" <bsa@kf8nh.apk.net>, "M.J.T. Guy" + <mjtg@cus.cam.ac.uk> + Msg-ID: <199802180256.VAA11369@speaker.kf8nh.apk.net>, + <E0y4qd6-0000P6-00@ursa.cus.cam.ac.uk> + Files: pod/perlfunc.pod + + Title: "(well, doc patch) use of // requires successful match" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <pz7mb4bips.fsf@eeyore.ibcinc.com> + Files: pod/perlop.pod + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "MakeMaker PM doc patch and a DIR buglet" + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9711101050.AA13868@o09.xray.mpe.mpg.de> + Files: lib/ExtUtils/MakeMaker.pm + + Title: "bareword clarification for constant.pm" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <6460.878143077@eeyore.ibcinc.com> + Files: lib/constant.pm + + Title: "integer rand - bug or feature?" + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <pzhg8lvgta.fsf@eeyore.ibcinc.com> + Files: lib/integer.pm + + ------ OTHER CHANGES ------ + + Title: "FileHandle Documentation patch" + From: "Darren/Torin/Who Ever..." <torin@daft.com> + Msg-ID: <87emzqo49g.fsf@perv.daft.com> + + Title: "perl5.004_61 myconfig updates" + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980305150629.11530G-100000@newton.phys> + Files: myconfig + + Title: "small fixups in pod2latex.PL" + From: "Darren/Torin/Who Ever..." <torin@daft.com> + Msg-ID: <873eg6o3v2.fsf@perv.daft.com> + + ------ PORTABILITY - GENERAL ------ + + Title: "Misc doc fixes for README.VMS" + From: Dan Sugalski <sugalskd@osshe.edu> + Msg-ID: <3.0.5.32.19980121113134.00924a20@osshe.edu> + Files: README.vms + + Title: "moved DynaLib" + From: John Tobey <jtobey@channel1.com> + Msg-ID: <199710182332.XAA21630@remote212> + Files: ext/DynaLoader/DynaLoader.pm.PL + + ------ UTILITIES ------ + + Title: "Searching for FAQs (patch to perldoc)" + From: Piers Cawley <pdcawley@bofh.org.uk>, Russ Allbery <rra@stanford.edu> + Msg-ID: <m3d8gsb8uk.fsf@windlord.Stanford.EDU>, + <m3iuqkfmiq.fsf@tower.bofh.org.uk> + Files: utils/perldoc.PL + + Title: "perldoc" + From: Ted Ashton <ashted@southern.edu> + Msg-ID: <199802271510.KAA10506@ns.southern.edu> + Files: utils/perldoc.PL + + Title: "perldoc -f not using pod2man" + From: Russ Allbery <rra@stanford.edu> + Msg-ID: <m3hg4f9vyy.fsf@windlord.Stanford.EDU> + Files: utils/perldoc.PL + + Title: "perldoc -m should not require pod" + From: Robin Houston <robin@nml.guardian.co.uk> + Msg-ID: <199803241319.NAA24777@stringfellow.guardian.co.uk> + Files: utils/perldoc.PL + + Title: "small fix for perldoc in perl 5.004_04" + From: Julian Yip <julian@imoney.com> + Msg-ID: <Roam.SIMC.2.0.6.884805579.5280.julian@imoney.com> + Files: utils/perldoc.PL + +Change 764 on 1998/03/05 by TimBunce@ig.co.uk + + APPLLIB_EXP now has arch and version dirs added to @INC + +Change 761 on 1998/03/05 by TimBunce@ig.co.uk + + Title: "properly refcount localization, fix C<local $tied{foo}>" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802191207.MAA10742@toad.ig.co.uk> + Files: av.c hv.c scope.c t/op/local.t + +Change 758 on 1998/03/04 by TimBunce@ig.co.uk + + perldoc -f now uses pager if text is too long for screen + +Change 757 on 1998/03/04 by TimBunce@ig.co.uk + + Added OpenBSD hint file from <Todd.Miller@courtesan.com> + Document 'warn with no args' behaviour, from <johnpc@xs4all.net> + +Change 756 on 1998/03/04 by TimBunce@ig.co.uk + + Fix for new gnulibc stdio.h when using sfio+perlio + +Change 755 on 1998/03/04 by TimBunce@ig.co.uk + + Fixed typo in vms/ext/Stdio/Stdio.pm AUTOLOAD + Added details of split in scalar context to perlfunc.pod + +Change 754 on 1998/03/04 by TimBunce@ig.co.uk + + Updated perl -v info to include reference to docs and home page. + +Change 753 on 1998/03/04 by TimBunce@ig.co.uk + + Updated hints/bsdos.sh for BSD/OS 3.1 + Fixed typo in pod/perlsyn.pod + Added workaround for old gmake in ext/SDBM_File/sdbm/Makefile.PL + Fixed typo in ext/GDBM_File/GDBM_File.pm + +Change 752 on 1998/03/04 by TimBunce@ig.co.uk + + Changed bug address in README to perlbug@perl.com + Changed Copyright in perl.c to 1998 + Added op/pos.t test from Robin Houston <robin@oneworld.org> + +Change 751 on 1998/03/04 by TimBunce@ig.co.uk + + Make t/comp/require.t and t/lib/ph.t executable in repository + +Change 750 on 1998/03/04 by TimBunce@ig.co.uk + + Added dTHR definition to ease backwards compatibility for XS + source code from 5.005. + +Change 749 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "rename local 'op' variables to 'o'", #F114 + From: Gurusamy Sarathy + Files: op.h opcode.h proto.h dump.c op.c opcode.pl pp_ctl.c run.c scope.c + toke.c + +Change 748 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "consolidated win32 patch", #F112 + From: Gurusamy Sarathy + Files: MANIFEST pod/perlfaq2.pod pod/perlrun.pod win32/include/sys/socket.h + EXTERN.h INTERN.h dosish.h lib/ExtUtils/Command.pm + lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm + lib/ExtUtils/Mksymlists.pm lib/File/DosGlob.pm t/TEST + t/harness win32/win32.h win32/win32iop.h README.win32 + doio.c installhtml installperl pp_sys.c win32/Makefile + win32/config.bc win32/config.vc win32/config_H.bc + win32/config_H.vc win32/config_h.PL win32/config_sh.PL + win32/dl_win32.xs win32/makedef.pl win32/makefile.mk + win32/perllib.c win32/runperl.c win32/win32.c + win32/win32sck.c win32/bin/perlglob.pl x2p/a2p.h x2p/a2p.c + x2p/a2py.c + +Change 747 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "initialize @INC in ph.t, and fix up MANIFEST", #F111 + From: Gurusamy Sarathy + Files: MANIFEST t/lib/ph.t + +Change 746 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "properly save STDOUT during system() in debugger", #F110 + From: Jason Smith <smithj4@rpi.edu> + Files: lib/perl5db.pl + +Change 745 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "generate DynaLoader.pm at build time", #F109 + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9802111938.AA26224@o09.xray.mpe.mpg.de> + Files: MANIFEST ext/DynaLoader/DynaLoader.pm.PL ext/DynaLoader/Makefile.PL + +Change 744 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Install extensions with bootstrap in $archlib", #F108 + From: koenig@anna.mind.de (Andreas J. Koenig), koenig@kulturbox.de (Andreas + J. Koenig) + Msg-ID: <sfcra9fqx0n.fsf@anna.in-berlin.de> + Files: lib/ExtUtils/Install.pm + +Change 743 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Pod::Html trips over "C<0>"", #F107 + From: Chip Salzenberg + Files: lib/Pod/Html.pm + +Change 742 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "5.004_58 | _04: pod2*,perlpod: L<show this|man/section>", #F106 + From: Achim Bohnet <ach@mpe.mpg.de> + Msg-ID: <9802111629.AA00595@o09.xray.mpe.mpg.de> + Files: pod/perlpod.pod lib/Pod/Html.pm lib/Pod/Text.pm pod/pod2man.PL + +Change 741 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "New patch for $^E==GetLastError() under Win32", #F105 + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Tye McQueen + <tye@metronet.com>, ilya@math.ohio-state.edu (Ilya + Zakharevich) + Msg-ID: <199801040630.AA29298@metronet.com>, + <199801041826.NAA11568@aatma.engin.umich.edu>, + <1998Jan4.130412.2719461@cor.newman> + Files: pod/perlfunc.pod pod/perlvar.pod doio.c lib/dumpvar.pl lib/perl5db.pl + win32/win32.h mg.c util.c win32/makedef.pl win32/win32.c + +Change 740 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "5.004_56: Patch to Tie::Hash and docs", #F104 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199801120134.UAA05437@monk.mps.ohio-state.edu> + Files: pod/perlfunc.pod lib/Tie/Hash.pm + +Change 739 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "more doc for perldoc", #F103 + From: Gurusamy Sarathy + Files: utils/perldoc.PL + +Change 738 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Make perldoc look for an index file ", #F102 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <199801221220.NAA22902@furu.g.aas.no> + Files: utils/perldoc.PL + +Change 737 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "perldoc -F filename", #F101 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199712120037.TAA00176@math.mps.ohio-state.edu> + Files: utils/perldoc.PL + +Change 736 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "sv_grow can fail for HAS_64K_LIMIT systems", #F100 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <m3iuqsl3oq.fsf@furu.g.aas.no> + Files: sv.c + +Change 735 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Benchmark.pm: timethese corrupts $_", #F099 + From: abigail@fnx.com + Msg-ID: <19980201114609.7779.qmail@betelgeuse.wayne.fnx.com> + Files: lib/Benchmark.pm + +Change 734 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "STRANGE_MALLOC should test failed alloc", #F098 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <199802021406.PAA03285@furu.g.aas.no> + Files: hv.c + +Change 733 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "support caseless %ENV", #F097 + From: Gurusamy Sarathy + Files: hv.c t/op/magic.t win32/win32.h + +Change 732 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "newer cperl-mode.el (from 5.004_60)", #F096 + From: Ilya Zakharevich + Files: emacs/cperl-mode.el + +Change 731 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Handle set magic on xsub OUTPUT args, add API functions that handle + magic", #F095 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199801190409.XAA26710@aatma.engin.umich.edu> + Files: pod/perlguts.pod pod/perlxs.pod embed.h proto.h sv.h global.sym + lib/ExtUtils/xsubpp sv.c + +Change 730 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Fix flawed cleanup when signal handlers are not defined", #F094 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710290106.UAA11485@aatma.engin.umich.edu> + Files: mg.c + +Change 729 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Tests for C<sort 'foo','bar'>", #F093 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199711021247.MAA01743@crypt.compulink.co.uk> + Files: t/op/sort.t + +Change 728 on 1998/03/04 by TimBunce@ig.co.uk + + Title: "Make search.pl work on win32", #F092 + From: Gurusamy Sarathy + Files: win32/bin/search.pl + +Change 721 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix spurious perldoc warnings on DOSISH platforms", #F091 + From: Molnar Laszlo <molnarl@cdata.tvnet.hu> + Msg-ID: <34475659.1AA69855@cdata.tvnet.hu> + Files: utils/perldoc.PL + +Change 720 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Make ExtUtils::MM_Unix::fixin() do something meaningful on win32", + #F090 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199801070016.TAA17766@aatma.engin.umich.edu> + Files: lib/ExtUtils/MM_Unix.pm + +Change 719 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix inconsistent case $ENV{Path} (vs $ENV{PATH})", #F089 + From: Gurusamy Sarathy + Files: lib/FindBin.pm + +Change 718 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix File::Find's longstanding confusion about win32 being like VMS", + #F088 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802020459.XAA04964@aatma.engin.umich.edu> + Files: lib/File/Find.pm + +Change 717 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "do_postponed breaks with multiple interpreters", #F087 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710290316.WAA15888@aatma.engin.umich.edu> + Files: op.c + +Change 716 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Make warning on C<Nosuch::> optional, add to perl{diag,delta}.pod", + #F086 + From: Gurusamy Sarathy + Files: pod/perldelta.pod pod/perldiag.pod toke.c + +Change 715 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Pod::Html bug and fix: missing </UL> in index", #F085 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802192314.SAA23326@aatma.engin.umich.edu> + Files: lib/Pod/Html.pm + +Change 714 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "New pod: perlhist", #F084 + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199802191556.RAA09578@alpha.hut.fi> + Files: MANIFEST pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc + +Change 713 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix restoration of locals on scope unwinding", #F083 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802110515.AAA23700@aatma.engin.umich.edu> + Files: pp_ctl.c t/op/local.t + +Change 712 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "after an eval-ed bad require, requiring a string ref SEGVs", #F082 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802102349.SAA16001@aatma.engin.umich.edu> + Files: pp_ctl.c + +Change 711 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix seg fault on eval/require and syntax errors", #F081 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199802102321.SAA15346@aatma.engin.umich.edu> + Files: MANIFEST scope.h op.c pp_ctl.c scope.c t/comp/require.t toke.c + +Change 710 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "5.004_58: the locale.t problem in IRIX", #F080 + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199802091747.TAA01735@alpha.hut.fi> + Files: t/pragma/locale.t + +Change 709 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "sv_setnv will upgrade SVt_NV to SVt_PVNV", #F079 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <m3g1lwl3bq.fsf@furu.g.aas.no> + Files: sv.c + +Change 708 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Eliminate double warnings under C<package;>", #F077 + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0y0paq-0000Ov-00@ursa.cus.cam.ac.uk> + Files: gv.c op.c toke.c + +Change 707 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix infinite loop on unlink() failure in File::Path::rmtree()", + #F076 + From: Murray Nesbitt <mjn@pathcom.com>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199802061100.LAA16423@toad.ig.co.uk> + Files: lib/File/Path.pm + +Change 706 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Update of h2ph", #F075 + From: kstar@www.chapin.edu (Kurt D. Starsinic) + Msg-ID: <199802051354.FAA11452@www.chapin.edu> + Files: t/lib/ph.t utils/h2ph.PL + +Change 705 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix AutoLoader for deep packages", #F074 + From: Zachary Miller <zcmiller@zappy.er.usgs.gov> + Msg-ID: <199710092348.SAA02108@zappy.er.usgs.gov> + Files: lib/AutoLoader.pm + +Change 704 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix order of warnings for misplaced subscripts", #F073 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199710131023.LAA16796@crypt.compulink.co.uk> + Files: op.c + +Change 703 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Make recursive lexical analysis more robust", #F072 + From: Ilya Zakharevich and Chip Salzenberg + Msg-ID: <199710160102.VAA28817@monk.mps.ohio-state.edu> + Files: toke.c + +Change 702 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix random whitespace errors in docs", #F070 + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <12726.877706444@eeyore.ibcinc.com> + Files: pod/perlfunc.pod pod/checkpods.PL + +Change 701 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix line numbers after here documents in eval STRING", #F069 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199710241745.NAA08166@monk.mps.ohio-state.edu> + Files: toke.c + +Change 700 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix SEGV from combining caller and C<package;>", #F068 + From: James Duncan <jduncan@epitome.hawk.igs.net>, Nicholas Clark + <nick@flirble.org> + Msg-ID: <199710241248.NAA00163@flirble.org>, + <Pine.LNX.3.96.971024135912.12197A-100000@epitome.hawk.igs. + net> + Files: pp_ctl.c sv.c + +Change 699 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Don't fold string comparison under C<use locale>", #F067 + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199711151506.RAA26287@alpha.hut.fi> + Files: op.c + +Change 698 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix SEGV on constant at end of sort block", #F066 + From: Administration <fadmin@informatics.muni.cz> + Msg-ID: <199711170838.JAA26073@thetis.fi.muni.cz> + Files: op.c + +Change 697 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Allow C<last()> to mean C<last>", #F065 + From: Chip Salzenberg + Files: op.c + +Change 696 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix extension version mismatch message", #F064 + From: Chip Salzenberg + Files: XSUB.h + +Change 695 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Better handle and test struct tm of Linux and SunOS", #F063 + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.980205134340.15567B-100000@newton.phys> + Files: MANIFEST ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl + hints/linux.sh hints/sunos_4_1.sh t/lib/posix.t + +Change 694 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix doc bug in getservbyname() examples", #F062 + From: Tom Christiansen + Files: ext/Socket/Socket.pm + +Change 693 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Kill warning about parameter type", #F061 + From: Chip Salzenberg + Files: op.c + +Change 692 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Socket occasional SEGV", #F060 + From: Trevor Blackwell <tlb@viaweb.com> + Msg-ID: <199710281804.NAA09632@wagg.viaweb.com> + Files: ext/Socket/Socket.xs + +Change 691 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Avoid SEGV from local($@)", #F059 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710290251.VAA14362@aatma.engin.umich.edu> + Files: pp_ctl.c + +Change 690 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Don't use broken pad_reset() (was Re: Perl bug in 5.004_03 )", #F058 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710300036.TAA01004@aatma.engin.umich.edu> + Files: op.c + +Change 689 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Use STMT_{START,END} in XSRETURN", #F057 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199710300245.VAA04244@aatma.engin.umich.edu> + Files: XSUB.h + +Change 688 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Re: Sort grammar bug", #F056 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199711011946.OAA18882@aatma.engin.umich.edu> + Files: toke.c + +Change 687 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Document indirect object cases for exec(), system()", #F055 + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03110700b084e89234a7@[194.51.248.90]> + Files: pod/perlfunc.pod + +Change 686 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Update docs on tr///", #F054 + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.971103071602.10568C-100000@usertest.teleport.com> + Files: pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod + pod/perllocale.pod pod/perlmod.pod pod/perlop.pod + pod/perlstyle.pod toke.c + +Change 685 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Re: perlop bitwise & | ^ documentation", #F053 + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.96.971106073858.29771O-100000@usertest.teleport.com> + Files: pod/perlop.pod + +Change 684 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix SEGV on C<*glob{'SCALAR','ARRAY'}>", #F052 + From: "Joseph N. Hall" <joseph@cscaper.com> + Msg-ID: <199711110552.WAA12613@gadget.cscaper.com> + Files: perly.c perly.c.diff perly.y vms/perly_c.vms + +Change 683 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "for perlguts.pod: document sv_derived_from, sv_vcatpfn and + sv_vsetpfn", #F051 + From: jan.dubois@ibm.net (Jan Dubois) and Chip Salzenberg + Msg-ID: <346ae970.7444534@smtp1.ibm.net> + Files: pod/perlguts.pod + +Change 682 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "5.004_04: locale startup failure (at last) documented", #F050 + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199711172054.WAA08261@alpha.hut.fi> + Files: INSTALL pod/perldiag.pod pod/perllocale.pod + +Change 681 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Cope with lack of args in Fcntl::AUTOLOAD", #F049 + From: Jerome Abela <abela@hsc.fr> + Msg-ID: <19971120183248.23588@coredump.hsc.fr> + Files: ext/Fcntl/Fcntl.pm + +Change 680 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Commenting toke.c", #F048 + From: gnat@frii.com + Msg-ID: <199801082138.OAA14186@prometheus.frii.com> + Files: toke.c + +Change 679 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Re: 5.004_04 vec() fails with 32-bit values", #F047 + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0xsnr8-0007SS-00@taurus.cus.cam.ac.uk> + Files: pod/perlguts.pod pp.c t/op/vec.t + +Change 678 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "A few perl5.004_03 bugs", #F046 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199801221211.MAA05315@crypt.compulink.co.uk> + Files: mg.c t/op/magic.t + +Change 677 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Faster, cleaner av_unshift() ", #F045 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <199801221850.TAA23111@furu.g.aas.no> + Files: av.c + +Change 676 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "New hints/solaris2.sh", #F044 + From: Stephen Zander <srz@mckesson.com> + Msg-ID: <87oh12y458.fsf@wsuse5.mckesson.com> + Files: hints/solaris_2.sh + +Change 675 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Refresh Complex.pm and test", #F043 + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199802051608.SAA20262@alpha.hut.fi> + Files: lib/Math/Complex.pm t/lib/complex.t + +Change 674 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix (\@@) proto", #F042 + From: "Joseph N. Hall" <joseph@cscaper.com> + Msg-ID: <199801240132.SAA25111@gadget.cscaper.com> + Files: op.c t/comp/proto.t + +Change 673 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Allow empty BLOCK in code", #F041 + From: Vladimir Alexiev <vladimir@cs.ualberta.ca> + Msg-ID: <19980129002112Z13378-6931+226@scapa.cs.ualberta.ca> + Files: toke.c + +Change 672 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix name of $Foo::{'Bar::'}: '*Foo::Bar::'", #F040 + From: Chip Salzenberg + Files: gv.c t/op/gv.t + +Change 671 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Keep accurate reference count on globs' stashes", #F038 + From: Gisle Aas <gisle@aas.no> + Msg-ID: <m3zpk7sd3n.fsf@furu.g.aas.no> + Files: gv.c sv.c + +Change 670 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Avoid memory allocation in gv_fetchpv(), for speed", #F037 + From: Chip Salzenberg + Files: gv.c + +Change 669 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Make Configure less negative about PerlIO", #F036 + From: chip@atlantic.net + Msg-ID: <199801312323.SAA15237@cyprus.atlantic.net> + Files: Configure + +Change 668 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix (mostly) pseudo-same-REs due to embedded NULs", #F035 + From: Martin Plechsmid <plechsmi@karlin.mff.cuni.cz> + Msg-ID: <199802021217.NAA05230@albert.karlin.mff.cuni.cz> + Files: pp_ctl.c + +Change 667 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Make Getopt::Long avoid $&, $`, $'", #F034 + From: Irving Reid <irving@tor.securecomputing.com> + Msg-ID: <98Feb3.005102est.11655@janus.tor.securecomputing.com> + Files: lib/Getopt/Long.pm + +Change 666 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "adding the newSVpvn API function", #F033 + From: Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch> + Msg-ID: <199801310532.GAA23798@solar.ethz.ch> + Files: pod/perlguts.pod pod/perltoc.pod proto.h global.sym sv.c + +Change 665 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Support C<Package::> as function-blind bearword", #F032 + From: Chip Salzenberg + Files: toke.c + +Change 664 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Re-optimize character classes", #F031 + From: Chip Salzenberg + Files: regcomp.h regcomp.c regexec.c + +Change 663 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix C<if (1) { local $x }> which needed ENTER/LEAVE", #F030 + From: dfh@dwroll.lucent.com (D461-David_F_Haertig(Dave)83040) + Msg-ID: <EnKC0q.6qI@drnews.dr.lucent.com> + Files: op.c t/op/local.t + +Change 662 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Dramatically improve performance of // with parens or $&", #F029 + From: Chip Salzenberg + Files: cop.h perl.h proto.h regexp.h gv.c interp.sym perl.c pp.c pp_ctl.c + pp_hot.c regexec.c scope.c + +Change 661 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Don't warn on $x{shift}, ne => 1, or -f => 1", #F028 + From: Chip Salzenberg + Files: toke.c + +Change 660 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Protect against weirdness with unreal @_ in C<local @_>", #F027 + From: Chip Salzenberg + Files: scope.c + +Change 659 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix C<printf "%.0d", 0>", #F026 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199711021331.NAA01826@crypt.compulink.co.uk> + Files: sv.c t/op/sprintf.t + +Change 658 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Tiny core patch for source filters", #F025 + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9711202312.AA02937@claudius.bfsec.bt.co.uk> + Files: toke.c + +Change 657 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Here-doc in s///e (was: Bug)", #F024 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199711221445.OAA14153@crypt.compulink.co.uk> + Files: t/base/lex.t toke.c + +Change 656 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix duplicate warnings on C<-e undef>", #F023 + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199711221252.MAA14000@crypt.compulink.co.uk> + Files: doio.c t/pragma/warn-1global + +Change 655 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix '*' prototype", #F022 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199711212225.RAA00755@monk.mps.ohio-state.edu> + Files: toke.c + +Change 654 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "File::Find bugs (and patches)", "File::Find bugs & patches", #F021 + From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com> + Msg-ID: <199711260703.XAA21257@mailgate2.boeing.com> + Files: lib/File/Find.pm + +Change 653 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix typo: FORM{,AT}LINE", #F020 + From: Chip Salzenberg + Files: sv.c + +Change 652 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix use of unref mem when blessed object goes out of scope", #F019 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199711282326.SAA15090@aatma.engin.umich.edu> + Files: scope.c + +Change 651 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix C<my ($a, undef, $b) = @x>", #F018 + From: Stephane Payrard <stef@francenet.fr> + Msg-ID: <199712040054.BAA04612@www.zweig.com> + Files: op.c t/op/my.t + +Change 650 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "enhanced "use strict" warning", #F017 + From: Tkil <tkil@reptile.scrye.com> + Msg-ID: <199712040938.CAA07628@reptile.scrye.com> + Files: gv.c t/pragma/strict-subs t/pragma/strict-vars + +Change 649 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "eval of sub gives spurious "uninitialised" warning", #F016 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199712061025.FAA14396@aatma.engin.umich.edu> + Files: pod/perldelta.pod pod/perlfunc.pod op.c t/op/eval.t + +Change 648 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "[PERL] Assigning result of pop scrambles unrelated reference", #F015 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199712061100.GAA14864@aatma.engin.umich.edu> + Files: sv.c + +Change 647 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "[PERL] Filedescriptor leak in 5.004_55 (and earlier)", #F014 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199712151922.OAA06410@monk.mps.ohio-state.edu> + Files: os2/os2.c util.c + +Change 646 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix fdopen() on STD{IN,OUT,ERR}", #F013 + From: Roderick Schertler <roderick@argon.org> + Msg-ID: <pzg1npp6e3.fsf@eeyore.ibcinc.com> + Files: doio.c t/op/misc.t + +Change 645 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix local $a[0] and local $h{a}", #F012 + From: Stephen McCamant <alias@mcs.com> + Msg-ID: <m0xjWFq-000EZeC@alias-2.pr.mcs.net> + Files: embed.h scope.h global.sym pp.c pp_hot.c scope.c t/op/local.t + +Change 644 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Eliminate redundant mg_get() in SvTRUE()", #F011 + From: Spider Boardman <spider@orb.nashua.nh.us> + Msg-ID: <199712251839.NAA14800@Orb.Nashua.NH.US> + Files: sv.c + +Change 643 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Don't force scalar context on C<my @x> or C<my %x>", #F010 + From: Chip Salzenberg + Files: op.c t/op/my.t + +Change 642 on 1998/03/03 by TimBunce@ig.co.uk + + Title: "Fix assignment to $_[0] in DESTROY", #F009 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199801010030.TAA14274@aatma.engin.umich.edu> + Files: pod/perlobj.pod sv.c t/op/ref.t + +Change 627 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "Fix inefficient checks for TIEHANDLE", #F008 + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199801080106.UAA05048@aatma.engin.umich.edu> + Files: pp_hot.c pp_sys.c + +Change 626 on 1998/03/02 by TimBunce@ig.co.uk + + This is the change description for change 625 + Title: "Fix tr///s option", #F007 + From: Inaba Hiroto <inaba@st.rim.or.jp> + Msg-ID: <19980110155333D.inaba@st.rim.or.jp> + Files: doop.c + +Change 623 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "Fix lexical lookup in eval-sub-eval", #F006 + From: Chip Salzenberg + Files: pp_ctl.c + +Change 622 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "Don't upgrade target of assignment from LVALUE", #F005 + From: Chip Salzenberg + Files: sv.c + +Change 621 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "Fix compile-time warning line in while ()", #F004 + From: Chip Salzenberg + Files: op.c + +Change 620 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "STMT foreach LIST;", #F002 + From: Chip Salzenberg + Files: pod/perlsyn.pod perly.c perly.c.diff perly.y t/cmd/mod.t toke.c + vms/perly_c.vms + +Change 619 on 1998/03/02 by TimBunce@ig.co.uk + + Title: "Fix SIGSEGV on C<42 until forever>", #F001 + From: Chip Salzenberg + Files: op.c + +---------------- Version 5.004_04 Maintenance release 4 for 5.004 ---------------- @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Thu Apr 2 09:30:50 EST 1998 [metaconfig 3.0 PL70] +# Generated on Wed May 13 13:35:54 EDT 1998 [metaconfig 3.0 PL70] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -63,7 +63,7 @@ if test -d c:/. ; then p_=\; PATH=`cmd /c "echo %PATH%" | tr '\\\\' / ` OS2_SHELL=`cmd /c "echo %OS2_SHELL%" | tr '\\\\' / | tr '[A-Z]' '[a-z]'` - elif test -n "$DJDIR"; then + elif test -n "$DJGPP"; then p_=\; fi fi @@ -109,7 +109,7 @@ if test -d /usr/lpp -a -f /usr/bin/bsh -a -f /usr/bin/uname; then fi case "$inksh/$needksh" in /[a-z]*) - unset ENV + ENV='' changesh=true reason="$needksh" ;; @@ -140,7 +140,7 @@ esac : Configure runs within the UU subdirectory test -d UU || mkdir UU -unset CDPATH +CDPATH='' cd UU && rm -f ./* dynamic_ext='' @@ -249,6 +249,7 @@ obj_ext='' path_sep='' afs='' alignbytes='' +ansi2knr='' archlib='' archlibexp='' d_archlib='' @@ -532,6 +533,7 @@ d_pwchange='' d_pwclass='' d_pwcomment='' d_pwexpire='' +d_pwgecos='' d_pwquota='' i_pwd='' i_sfio='' @@ -1551,8 +1553,12 @@ for dir in \$*; do echo \$thisthing exit 0 elif test -f \$dir/\$thing.exe; then - : on Eunice apparently - echo \$dir/\$thing + if test -n "$DJGPP"; then + echo \$dir/\$thing.exe + else + : on Eunice apparently + echo \$dir/\$thing + fi exit 0 fi ;; @@ -1873,6 +1879,12 @@ EOM fi fi ;; + pc*) + if test -n "$DJGPP"; then + osname=dos + osvers=djgpp + fi + ;; esac case "$1" in @@ -2012,11 +2024,11 @@ EOM *) if test -f /etc/systemid; then osname=sco set `echo $3 | $sed 's/\./ /g'` $4 - if $test -f sco_$1_$2_$3.sh; then + if $test -f $src/hints/sco_$1_$2_$3.sh; then osvers=$1.$2.$3 - elif $test -f sco_$1_$2.sh; then + elif $test -f $src/hints/sco_$1_$2.sh; then osvers=$1.$2 - elif $test -f sco_$1.sh; then + elif $test -f $src/hints/sco_$1.sh; then osvers=$1 fi else @@ -2049,10 +2061,6 @@ EOM set X $myuname osname=os2 osvers="$5" - if test -n "$DJDIR"; then - osname=dos - osvers=djgpp - fi fi fi @@ -3012,38 +3020,6 @@ esac set d_dosuid eval $setvar -: determine where public executables go -echo " " -set dflt bin bin -eval $prefixit -fn=d~ -rp='Pathname where the public executables will reside?' -. ./getfile -if $test "X$ansexp" != "X$binexp"; then - installbin='' -fi -bin="$ans" -binexp="$ansexp" -if $afs; then - $cat <<EOM - -Since you are running AFS, I need to distinguish the directory in which -executables reside from the directory in which they are installed (and from -which they are presumably copied to the former directory by occult means). - -EOM - case "$installbin" in - '') dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;; - *) dflt="$installbin";; - esac - fn=de~ - rp='Where will public executables be installed?' - . ./getfile - installbin="$ans" -else - installbin="$binexp" -fi - : determine where manual pages are on this system echo " " case "$sysman" in @@ -3342,6 +3318,144 @@ y) fn=d/ ;; esac +: see how we invoke the C preprocessor +echo " " +echo "Now, how can we feed standard input to your C preprocessor..." >&4 +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +cd .. +echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin +chmod 755 cppstdin +wrapper=`pwd`/cppstdin +ok='false' +cd UU + +if $test "X$cppstdin" != "X" && \ + $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 +then + echo "You used to use $cppstdin $cppminus so we'll use that again." + case "$cpprun" in + '') echo "But let's see if we can live without a wrapper..." ;; + *) + if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "(And we'll use $cpprun $cpplast to preprocess directly.)" + ok='true' + else + echo "(However, $cpprun $cpplast does not work, let's see...)" + fi + ;; + esac +else + case "$cppstdin" in + '') ;; + *) + echo "Good old $cppstdin $cppminus does not seem to be of any help..." + ;; + esac +fi + +if $ok; then + : nothing +elif echo 'Maybe "'"$cc"' -E" will work...'; \ + $cc -E <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ + $cc -E - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus='-'; +elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ + $cc -P <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yipee, that works!" + x_cpp="$cc -P" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ + $cc -P - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "At long last!" + x_cpp="$cc -P" + x_minus='-'; +elif echo 'No such luck, maybe "'$cpp'" will work...'; \ + $cpp <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + x_cpp="$cpp" + x_minus=''; +elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ + $cpp - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, it works! I was beginning to wonder." + x_cpp="$cpp" + x_minus='-'; +elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + x_cpp="$wrapper" + x_minus='' + echo "Eureka!" +else + dflt='' + rp="No dice. I can't find a C preprocessor. Name one:" + . ./myread + x_cpp="$ans" + x_minus='' + $x_cpp <testcpp.c >testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "OK, that will do." >&4 + else +echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 + exit 1 + fi +fi + +case "$ok" in +false) + cppstdin="$x_cpp" + cppminus="$x_minus" + cpprun="$x_cpp" + cpplast="$x_minus" + set X $x_cpp + shift + case "$1" in + "$cpp") + echo "Perhaps can we force $cc -E using a wrapper..." + if $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "Yup, we can." + cppstdin="$wrapper" + cppminus=''; + else + echo "Nope, we'll have to live without it..." + fi + ;; + esac + case "$cpprun" in + "$wrapper") + cpprun='' + cpplast='' + ;; + esac + ;; +esac + +case "$cppstdin" in +"$wrapper") ;; +*) $rm -f $wrapper;; +esac +$rm -f testcpp.c testcpp.out + : Set private lib path case "$plibpth" in '') if ./mips; then @@ -3536,144 +3650,6 @@ none) libs=' ';; *) libs="$ans";; esac -: see how we invoke the C preprocessor -echo " " -echo "Now, how can we feed standard input to your C preprocessor..." >&4 -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -cd .. -echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin -chmod 755 cppstdin -wrapper=`pwd`/cppstdin -ok='false' -cd UU - -if $test "X$cppstdin" != "X" && \ - $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 -then - echo "You used to use $cppstdin $cppminus so we'll use that again." - case "$cpprun" in - '') echo "But let's see if we can live without a wrapper..." ;; - *) - if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "(And we'll use $cpprun $cpplast to preprocess directly.)" - ok='true' - else - echo "(However, $cpprun $cpplast does not work, let's see...)" - fi - ;; - esac -else - case "$cppstdin" in - '') ;; - *) - echo "Good old $cppstdin $cppminus does not seem to be of any help..." - ;; - esac -fi - -if $ok; then - : nothing -elif echo 'Maybe "'"$cc"' -E" will work...'; \ - $cc -E <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ - $cc -E - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus='-'; -elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ - $cc -P <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yipee, that works!" - x_cpp="$cc -P" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ - $cc -P - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "At long last!" - x_cpp="$cc -P" - x_minus='-'; -elif echo 'No such luck, maybe "'$cpp'" will work...'; \ - $cpp <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - x_cpp="$cpp" - x_minus=''; -elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ - $cpp - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, it works! I was beginning to wonder." - x_cpp="$cpp" - x_minus='-'; -elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - x_cpp="$wrapper" - x_minus='' - echo "Eureka!" -else - dflt='' - rp="No dice. I can't find a C preprocessor. Name one:" - . ./myread - x_cpp="$ans" - x_minus='' - $x_cpp <testcpp.c >testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "OK, that will do." >&4 - else -echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 - exit 1 - fi -fi - -case "$ok" in -false) - cppstdin="$x_cpp" - cppminus="$x_minus" - cpprun="$x_cpp" - cpplast="$x_minus" - set X $x_cpp - shift - case "$1" in - "$cpp") - echo "Perhaps can we force $cc -E using a wrapper..." - if $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "Yup, we can." - cppstdin="$wrapper" - cppminus=''; - else - echo "Nope, we'll have to live without it..." - fi - ;; - esac - case "$cpprun" in - "$wrapper") - cpprun='' - cpplast='' - ;; - esac - ;; -esac - -case "$cppstdin" in -"$wrapper") ;; -*) $rm -f $wrapper;; -esac -$rm -f testcpp.c testcpp.out - : determine optimize, if desired, or use for debug flag also case "$optimize" in ' '|$undef) dflt='none';; @@ -3957,16 +3933,89 @@ n) echo "OK, that should do.";; esac $rm -f try try.* core +: Cruising for prototypes +echo " " +echo "Checking out function prototypes..." >&4 +$cat >prototype.c <<'EOCP' +main(int argc, char *argv[]) { + exit(0);} +EOCP +if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then + echo "Your C compiler appears to support function prototypes." + val="$define" +else + echo "Your C compiler doesn't seem to understand function prototypes." + val="$undef" +fi +set prototype +eval $setvar +$rm -f prototype* + +case "$prototype" in +"$define") ;; +*) ansi2knr='ansi2knr' + echo " " + cat <<EOM >&4 + +$me: FATAL ERROR: +This version of $package can only be compiled by a compiler that +understands function prototypes. Unfortunately, your C compiler + $cc $ccflags +doesn't seem to understand them. Sorry about that. + +If GNU cc is avaiable for your system, perhaps you could try that instead. + +Eventually, we hope to support building Perl with pre-ANSI compilers. +If you would like to help in that effort, please contact <perlbug@perl.org>. + +Aborting Configure now. +EOM + exit 2 + ;; +esac + +: determine where public executables go +echo " " +set dflt bin bin +eval $prefixit +fn=d~ +rp='Pathname where the public executables will reside?' +. ./getfile +if $test "X$ansexp" != "X$binexp"; then + installbin='' +fi +bin="$ans" +binexp="$ansexp" +if $afs; then + $cat <<EOM + +Since you are running AFS, I need to distinguish the directory in which +executables reside from the directory in which they are installed (and from +which they are presumably copied to the former directory by occult means). + +EOM + case "$installbin" in + '') dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;; + *) dflt="$installbin";; + esac + fn=de~ + rp='Where will public executables be installed?' + . ./getfile + installbin="$ans" +else + installbin="$binexp" +fi + : define a shorthand compile call compile=' mc_file=$1; shift; -$cc $optimize $ccflags $ldflags -o ${mc_file}$_exe $* ${mc_file}.c $libs > /dev/null 2>&1;' +$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs > /dev/null 2>&1;' : define a shorthand compile call for compilations that should be ok. compile_ok=' mc_file=$1; shift; -$cc $optimize $ccflags $ldflags -o ${mc_file}$_exe $* ${mc_file}.c $libs;' +$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs;' echo " " echo "Checking for GNU C Library..." >&4 @@ -4012,7 +4061,7 @@ case "$usenm" in ;; esac case "$dflt" in - '') dflt=`egrep 'inlibc|csym' ../Configure | wc -l 2>/dev/null` + '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` if $test $dflt -gt 20; then dflt=y else @@ -4758,10 +4807,6 @@ $undef) ;; esac ;; - sunos) - dflt=n - also='Building a shared libperl will definitely not work on SunOS 4.' - ;; *) dflt=n ;; esac @@ -6504,7 +6549,7 @@ $define|y|true) $cat << EOM On a few systems, the dynamically loaded modules that perl generates and uses -will need a different extension then shared libs. The default will probably +will need a different extension than shared libs. The default will probably be appropriate. EOM @@ -7185,13 +7230,13 @@ main() } EOCP set try - if eval $compile_ok; then + if eval $compile; then longdblsize=`./try` $echo " $longdblsize bytes." >&4 else dflt='8' echo " " - echo "(I can't seem to compile the test program. Guessing...)" + echo "(I can't seem to compile the test program. Guessing...)" >&4 rp="What is the size of a long double (in bytes)?" . ./myread longdblsize="$ans" @@ -7558,6 +7603,14 @@ $define) set d_pwcomment eval $setvar + if $contains 'pw_gecos' $$.h >/dev/null 2>&1; then + val="$define" + else + val="$undef" + fi + set d_pwgecos + eval $setvar + $rm -f $$.h ;; *) @@ -7568,6 +7621,7 @@ $define) set d_pwclass; eval $setvar set d_pwexpire; eval $setvar set d_pwcomment; eval $setvar + set d_pwgecos; eval $setvar ;; esac @@ -8432,6 +8486,9 @@ case "$varval" in for inc in $inclist; do echo "#include <$inc>" >>temp.c; done; + echo "#ifdef $type" >> temp.c; + echo "printf(\"We have $type\");" >> temp.c; + echo "#endif" >> temp.c; $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null; if $contains $type temp.E >/dev/null 2>&1; then eval "$var=\$type"; @@ -8454,6 +8511,9 @@ case "$varval" in for inc in $inclist; do echo "#include <$inc>" >>temp.c; done; + echo "#ifdef $type" >> temp.c; + echo "printf(\"We have $type\");" >> temp.c; + echo "#endif" >> temp.c; $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null; echo " " ; echo "$rp" | $sed -e "s/What is/Looking for/" -e "s/?/./"; @@ -9105,7 +9165,7 @@ EOCP set try if eval $compile_ok; then doublesize=`./try` - $echo $doublesize >&4 + $echo " $doublesize bytes." >&4 else dflt='8' echo "(I can't seem to compile the test program. Guessing...)" @@ -9220,24 +9280,6 @@ rp="What is the type used for file modes for system calls (e.g. fchmod())?" set mode_t modetype int stdio.h sys/types.h eval $typedef_ask -: Cruising for prototypes -echo " " -echo "Checking out function prototypes..." >&4 -$cat >prototype.c <<'EOCP' -main(int argc, char *argv[]) { - exit(0);} -EOCP -if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then - echo "Your C compiler appears to support function prototypes." - val="$define" -else - echo "Your C compiler doesn't seem to understand function prototypes." - val="$undef" -fi -set prototype -eval $setvar -$rm -f prototype* - : define a fucntion to check prototypes $cat > protochk <<EOSH $startsh @@ -10699,7 +10741,7 @@ EOM # Perhaps we are reusing an old out-of-date config.sh. case "$hint" in previous) - if test X"$dynamic_ext" != X$"avail_ext"; then + if test X"$dynamic_ext" != X"$avail_ext"; then $cat <<EOM NOTICE: Your previous config.sh list may be incorrect. The extensions now available to you are @@ -10764,7 +10806,7 @@ EOM # Perhaps we are reusing an old out-of-date config.sh. case "$hint" in previous) - if test X"$static_ext" != X$"avail_ext"; then + if test X"$static_ext" != X"$avail_ext"; then $cat <<EOM NOTICE: Your previous config.sh list may be incorrect. The extensions now available to you are @@ -10837,7 +10879,9 @@ case "$d_portable" in echo " " echo "Stripping down executable paths..." >&4 for file in $loclist $trylist; do - eval $file="\$file" + if test X$file != Xln -a X$file != Xar -o X$osname != Xos2; then + eval $file="\$file" + fi done ;; esac @@ -10876,6 +10920,7 @@ _exe='$_exe' _o='$_o' afs='$afs' alignbytes='$alignbytes' +ansi2knr='$ansi2knr' aphostname='$aphostname' ar='$ar' archlib='$archlib' @@ -11038,6 +11083,7 @@ d_pwchange='$d_pwchange' d_pwclass='$d_pwclass' d_pwcomment='$d_pwcomment' d_pwexpire='$d_pwexpire' +d_pwgecos='$d_pwgecos' d_pwquota='$d_pwquota' d_readdir='$d_readdir' d_readlink='$d_readlink' @@ -125,7 +125,7 @@ L<"Site-wide Policy settings"> below. Configure will figure out various things about your system. Some things Configure will figure out for itself, other things it will ask you about. To accept the default, just press RETURN. The default -is almost always ok. At any Configure prompt, you can type &-d +is almost always okay. At any Configure prompt, you can type &-d and Configure will use the defaults from then on. After it runs, Configure will perform variable substitution on all the @@ -162,6 +162,22 @@ NOTE: You must not specify an installation directory that is below your perl source directory. If you do, installperl will attempt infinite recursion. +It may seem obvious to say, but Perl is useful only when users can +easily find it. When possible, it's good for both /usr/bin/perl and +/usr/local/bin/perl to be symlinks to the actual binary. If that can't +be done, system administrators are strongly encouraged to put +(symlinks to) perl and its accompanying utilities, such as perldoc, +into a directory typically found along a user's PATH, or in another +obvious and convenient place. + +It may seem obvious to say, but Perl is useful only when users can +easily find it. When possible, it's good for both /usr/bin/perl and +/usr/local/bin/perl to be symlinks to the actual binary. If that can't +be done, system administrators are strongly encouraged to put +(symlinks to) perl and its accompanying utilities, such as perldoc, +into a directory typically found along a user's PATH, or in another +obvious and convenient place. + By default, Configure will compile perl to use dynamic loading if your system supports it. If you want to force perl to be compiled statically, you can either choose this when Configure prompts you or @@ -499,6 +515,14 @@ system. For most users, the defaults are sensible and will work. Some users, however, may wish to further customize perl. Here are some of the main things you can change. +=head2 Installing perl under different names + +If you want to install perl under a name other than "perl" (for example, +when installing perl with special features enabled, such as debugging), +indicate the alternate name on the "make install" line, such as: + + make install PERLNAME=myperl + =head2 Threads On some platforms, perl5.005 can be compiled to use threads. To @@ -751,7 +775,7 @@ you probably want to do This will do two independent things: First, it will force compilation to use cc -g so that you can use your system's debugger on the executable. (Note: Your system may actually require something like -cc -g2. Check you man pages for cc(1) and also any hint file for your +cc -g2. Check your man pages for cc(1) and also any hint file for your system.) Second, it will add -DDEBUGGING to your ccflags variable in config.sh so that you can use B<perl -D> to access perl's internal state. (Note: Configure will only add -DDEBUGGING by @@ -1217,6 +1241,8 @@ Note that you can't run the tests in background if this disables opening of /dev/tty. You can use 'make test-notty' in that case but a few tty tests will be skipped. +=head2 What if make test doesn't work? + 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 bomb, you can run them by hand, e.g., @@ -1234,6 +1260,10 @@ complicated constructs). You should also read the individual tests to see if there are any helpful comments that apply to your system. +=over 4 + +=item locale + Note: One possible reason for errors is that some external programs may be broken due to the combination of your environment and the way B<make test> exercises them. For example, this may happen if you have @@ -1257,6 +1287,29 @@ things like: exec, `backquoted command`, system, open("|...") or open("...|"). All these mean that Perl is trying to run some external program. +=item Out of memory + +On some systems, particularly those with smaller amounts of RAM, some +of the tests in t/op/pat.t may fail with an "Out of memory" message. +Specifically, in perl5.004_64, tests 74 and 78 have been reported to +fail on some systems. On my SparcStation IPC with 8 MB of RAM, test 78 +will fail if the system is running any other significant tasks at the +same time. + +Try stopping other jobs on the system and then running the test by itself: + + cd t; ./perl op/pat.t + +to see if you have any better luck. If your perl still fails this +test, it does not necessarily mean you have a broken perl. This test +tries to exercise the regular expression subsystem quite thoroughly, +and may well be far more demanding than your normal usage. + +You may also be able to reduce perl's memory usage by using some of +the ideas described above in L<"Malloc Performance Flags">. + +=back + =head1 make install This will put perl into the public directory you specified to @@ -1535,4 +1588,4 @@ above. =head1 LAST MODIFIED -$Id: INSTALL,v 1.32 1998/03/20 19:20:08 doughera Released $ +$Id: INSTALL,v 1.34 1998/04/23 18:19:41 doughera Released $ @@ -13,14 +13,17 @@ INTERN.h Included before domestic .h files MANIFEST This list of files Makefile.SH A script that generates Makefile Policy_sh.SH Hold site-wide preferences between Configure runs. +Porting/Contract Social contract for contributed modules in Perl core Porting/Glossary Glossary of config.sh variables Porting/config.sh Sample config.sh Porting/config_H Sample config.h Porting/makerel Release making utility +Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers README The Instructions README.amiga Notes about AmigaOS port +README.beos Notes about BeOS port README.cygwin32 Notes about Cygwin32 port README.dos Notes about dos/djgpp port README.os2 Notes about OS/2 port @@ -36,6 +39,7 @@ XSUB.h Include file for extension subroutines atomic.h Atomic refcount handling for multi-threading av.c Array value code av.h Array value header +beos/nm.c BeOS port bytecode.h Bytecode header for compiler bytecode.pl Produces byterun.h, byterun.c and ext/B/Asmdata.pm byterun.c Runtime support for compiler-generated bytecode @@ -170,7 +174,7 @@ ext/DB_File/DB_File.xs Berkeley DB extension external subroutines ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder ext/DB_File/Makefile.PL Berkeley DB extension makefile writer ext/DB_File/typemap Berkeley DB extension interface types -ext/DynaLoader/DynaLoader.pm Dynamic Loader perl module +ext/DynaLoader/DynaLoader.pm.PL Dynamic Loader perl module ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro ext/DynaLoader/dl_aix.xs AIX implementation @@ -226,8 +230,12 @@ ext/POSIX/Makefile.PL POSIX extension makefile writer ext/POSIX/POSIX.pm POSIX extension Perl module ext/POSIX/POSIX.pod POSIX extension documentation ext/POSIX/POSIX.xs POSIX extension external subroutines +ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture +ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture ext/POSIX/hints/linux.pl Hint for POSIX for named architecture +ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture +ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.PL SDBM extension makefile writer @@ -320,6 +328,7 @@ hints/altos486.sh Hints for named architecture hints/amigaos.sh Hints for named architecture hints/apollo.sh Hints for named architecture hints/aux_3.sh Hints for named architecture +hints/beos.sh Hints for named architecture hints/broken-db.msg Warning message for systems with broken DB library hints/bsdos.sh Hints for named architecture hints/convexos.sh Hints for named architecture @@ -359,6 +368,7 @@ hints/newsos4.sh Hints for named architecture hints/next_3.sh Hints for named architecture hints/next_3_0.sh Hints for named architecture hints/next_4.sh Hints for named architecture +hints/openbsd.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 @@ -658,6 +668,7 @@ pod/perlcall.pod Callback info pod/perldata.pod Data structure info pod/perldebug.pod Debugger info pod/perldelta.pod Changes since last version +pod/perldelta4.pod Changes from 5.003 to 5.004 pod/perldiag.pod Diagnostic info pod/perldsc.pod Data Structures Cookbook pod/perlembed.pod Embedding info @@ -825,7 +836,10 @@ t/op/chop.t See if chop works t/op/closure.t See if closures work t/op/cmp.t See if the various string and numeric compare work t/op/cond.t See if conditional expressions work +t/op/defins.t See if auto-insert of defined() works t/op/delete.t See if delete works +t/op/die.t See if die works +t/op/die_exit.t See if die and exit status interaction works t/op/do.t See if subroutines work t/op/each.t See if hash iterators work t/op/eval.t See if eval operator works @@ -841,6 +855,8 @@ t/op/hashwarn.t See if warnings for bad hash assignments work t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/int.t See if int works +t/op/ipcmsg.t See if msg* ops work +t/op/ipcsem.t See if sem* ops work t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works @@ -854,6 +870,7 @@ t/op/oct.t See if oct and hex work t/op/ord.t See if ord works t/op/pack.t See if pack and unpack work t/op/pat.t See if esoteric patterns work +t/op/pos.t See if pos works t/op/push.t See if push and pop work t/op/quotemeta.t See if quotemeta works t/op/rand.t See if rand works @@ -913,6 +930,7 @@ utils/perlbug.PL A simple tool to submit a bug report utils/perldoc.PL A simple tool to find & display perl's documentation utils/pl2pm.PL A pl to pm translator utils/splain.PL Stand-alone version of diagnostics.pm +utils/perlcc.PL Front-end for compiler vms/config.vms default config.h for VMS vms/descrip.mms MM[SK] description file for build vms/ext/DCLsym/0README.txt ReadMe file for VMS::DCLsym @@ -958,7 +976,7 @@ win32/bin/search.pl Win32 port win32/bin/webget.pl Win32 port win32/bin/www.pl Win32 port win32/config.bc Win32 base line config.sh (Borland C++ build) -win32/config.gc Win32 base line config.sh (GNU build)? +win32/config.gc Win32 base line config.sh (mingw32/gcc build) win32/config.vc Win32 base line config.sh (Visual C++ build) win32/config_H.bc Win32 config header (Borland C++ build) win32/config_H.gc Win32 config header (GNU build)? diff --git a/Makefile.SH b/Makefile.SH index c1689cd11d..a70b53e4fe 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -25,8 +25,13 @@ esac linklibperl='$(LIBPERL)' shrpldflags='$(LDDLFLAGS)' +ldlibpth='' case "$useshrplib" in true) + # Prefix all runs of 'miniperl' and 'perl' with + # $ldlibpth so that ./perl finds *this* libperl.so. + ldlibpth="LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH" + pldlflags="$cccdlflags" # NeXT-4 specific stuff. Can't we do this in the hint file? case "${osname}${osvers}" in @@ -35,6 +40,11 @@ true) lddlflags="-dynamic -undefined warning -framework System \ -compatibility_version 1 -current_version $patchlevel \ -prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@" + # NeXT uses a different name. + ldlibpth="DYLD_LIBRARY_PATH=`pwd`:$DYLD_LIBRARY_PATH" + ;; + os2*) # OS/2 doesn't need anything special for LD_LIBRARY_PATH. + ldlibpth='' ;; sunos*|freebsd[23]*|netbsd*) linklibperl="-lperl" @@ -124,6 +134,10 @@ LIBPERL = $libperl LLIBPERL= $linklibperl SHRPENV = $shrpenv +# The following is used to include the current directory in +# LD_LIBRARY_PATH if you are building a shared libperl.so. +LDLIBPTH = $ldlibpth + dynamic_ext = $dynamic_list static_ext = $static_list ext = \$(dynamic_ext) \$(static_ext) @@ -219,11 +233,17 @@ lintflags = -hbvxac all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext) @echo " "; echo " Everything is up to date." +compile: all + echo "testing compilation" > testcompile; + cd utils; $(MAKE) compile; + cd x2p; $(MAKE) compile; + cd pod; $(MAKE) compile; + translators: miniperl lib/Config.pm FORCE - @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all + @echo " "; echo " Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all utilities: miniperl lib/Config.pm FORCE - @echo " "; echo " Making utilities"; cd utils; $(MAKE) all + @echo " "; echo " Making utilities"; cd utils; $(LDLIBPTH) $(MAKE) all # This is now done by installman only if you actually want the man pages. @@ -299,20 +319,20 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) # The Module used here must not depend on Config or any extensions. miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) - @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest + $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) + @ $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest 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) + $(SHRPENV) $(LDLIBPTH) $(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 - $(SHRPENV) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) 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 - $(SHRPENV) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) 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 - $(SHRPENV) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) 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" @@ -320,7 +340,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 - $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) !NO!SUBS! @@ -340,34 +360,40 @@ sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h) preplibrary: miniperl lib/Config.pm $(plextract) @sh ./makedir lib/auto @echo " AutoSplitting perl library" - @./miniperl -Ilib -e 'use AutoSplit; \ + @$(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \ 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 + $(LDLIBPTH) ./miniperl configpm tmp sh mv-if-diff tmp lib/Config.pm lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm - ./miniperl minimod.pl > tmp && mv tmp $@ + $(LDLIBPTH) ./miniperl minimod.pl > tmp && mv tmp $@ $(plextract): miniperl lib/Config.pm - `echo ./miniperl -Ilib $@.PL` - + $(LDLIBPTH) ./miniperl -Ilib $@.PL + install: all install.perl install.man install.perl: all installperl - ./perl installperl + if [ -n "$(COMPILE)" ]; \ + then \ + cd utils; $(MAKE) compile; \ + cd ../x2p; $(MAKE) compile; \ + cd ../pod; $(MAKE) compile; \ + fi + $(LDLIBPTH) ./perl installperl install.man: all installman - ./perl installman + $(LDLIBPTH) ./perl installman # XXX Experimental. Hardwired values, but useful for testing. # Eventually Configure could ask for some of these values. install.html: all installhtml - ./perl installhtml \ + $(LDLIBPTH) ./perl installhtml \ --podroot=. --podpath=. --recurse \ --htmldir=$(privlib)/html \ --htmlroot=$(privlib)/html \ @@ -438,13 +464,13 @@ regen_headers: FORCE # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): miniperl preplibrary FORCE - @sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) 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 $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) 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 $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) clean: _tidy _mopup @@ -471,6 +497,7 @@ _tidy: -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \ done + rm -f testcompile compilelog # Do not 'make _cleaner' directly. _cleaner: @@ -489,6 +516,7 @@ _cleaner: rm -f lib/.exists rm -f h2ph.man pstruct rm -rf .config + rm -f testcompile compilelog # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. @@ -528,11 +556,11 @@ test-prep: miniperl perl preplibrary $(dynamic_ext) cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) test check: test-prep - cd t && ./perl TEST </dev/tty + cd t && $(LDLIBPTH) ./perl TEST </dev/tty # For testing without a tty or controling terminal. See t/op/stat.t test-notty: test-prep - cd t && PERL_SKIP_TTY_TEST=1 ./perl TEST + cd t && PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) ./perl TEST # Can't depend on lib/Config.pm because that might be where miniperl # is crashing. @@ -540,14 +568,14 @@ minitest: miniperl @echo "You may see some irrelevant test failures if you have been unable" @echo "to build lib/Config.pm." - 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 + && $(LDLIBPTH) ./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 # 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: utilities - ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' + $(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' clist: $(c) echo $(c) | tr ' ' '\012' >.clist diff --git a/Policy_sh.SH b/Policy_sh.SH index acac3ed8af..4ae0bb10dd 100644 --- a/Policy_sh.SH +++ b/Policy_sh.SH @@ -46,7 +46,7 @@ esac # Installation directives. Note that each one comes in three flavors. # For example, we have privlib, privlibexp, and installprivlib. # privlib is for private (to perl) library files. -# privlibexp is the same, expcept any '~' the user gave to Configure +# privlibexp is the same, except any '~' the user gave to Configure # is expanded to the user's home directory. This is figured # out automatically by Configure, so you don't have to include it here. # installprivlib is for systems (such as those running AFS) that @@ -82,7 +82,13 @@ for var in bin scriptdir privlib archlib \ case "$var" in bin) dflt=$prefix/bin ;; # The scriptdir test is more complex, but this is probably usually ok. - scriptdir) dflt=$prefix/script ;; + scriptdir) + if $test -d $prefix/script; then + dflt=$prefix/script + else + dflt=$bin + fi + ;; privlib) case "$prefix" in *perl*) dflt=$prefix/lib ;; @@ -97,7 +103,7 @@ for var in bin scriptdir privlib archlib \ case "$prefix" in *perl*) dflt=`echo $man1dir | sed -e 's/man1/man3/g' -e 's/man\.1/man\.3/g'` ;; - *) dflt=$privlib/man3 ;; + *) dflt=$privlib/man/man3 ;; esac ;; @@ -122,7 +128,6 @@ for var in bin scriptdir privlib archlib \ echo "# $var='$dflt'" else echo "# Preserving custom $var" - eval val=$var echo "$var='$val'" fi diff --git a/Porting/Contract b/Porting/Contract new file mode 100644 index 0000000000..cc91af26bc --- /dev/null +++ b/Porting/Contract @@ -0,0 +1,108 @@ + + Contributed Modules in Perl Core + A Social Contract about Artistic Control + +What follows is a statement about artistic control, defined as the ability +of authors of packages to guide the future of their code and maintain +control over their work. It is a recognition that authors should have +control over their work, and that it is a responsibility of the rest of +the Perl community to ensure that they retain this control. It is an +attempt to document the standards to which we, as Perl developers, intend +to hold ourselves. It is an attempt to write down rough guidelines about +the respect we owe each other as Perl developers. + +This statement is not a legal contract. This statement is not a legal +document in any way, shape, or form. Perl is distributed under the GNU +Public License and under the Artistic License; those are the precise legal +terms. This statement isn't about the law or licenses. It's about +community, mutual respect, trust, and good-faith cooperation. + +We recognize that the Perl core, defined as the software distributed with +the heart of Perl itself, is a joint project on the part of all of us. +>From time to time, a script, module, or set of modules (hereafter referred +to simply as a "module") will prove so widely useful and/or so integral to +the correct functioning of Perl itself that it should be distributed with +Perl core. This should never be done without the author's explicit +consent, and a clear recognition on all parts that this means the module +is being distributed under the same terms as Perl itself. A module author +should realize that inclusion of a module into the Perl core will +necessarily mean some loss of control over it, since changes may +occasionally have to be made on short notice or for consistency with the +rest of Perl. + +Once a module has been included in the Perl core, however, everyone +involved in maintaining Perl should be aware that the module is still the +property of the original author unless the original author explicitly +gives up their ownership of it. In particular: + + 1) The version of the module in the core should still be considered the + work of the original author. All patches, bug reports, and so forth + should be fed back to them. Their development directions should be + respected whenever possible. + + 2) Patches may be applied by the pumpkin holder without the explicit + cooperation of the module author if and only if they are very minor, + time-critical in some fashion (such as urgent security fixes), or if + the module author cannot be reached. Those patches must still be + given back to the author when possible, and if the author decides on + an alternate fix in their version, that fix should be strongly + preferred unless there is a serious problem with it. Any changes not + endorsed by the author should be marked as such, and the contributor + of the change acknowledged. + + 3) The version of the module distributed with Perl should, whenever + possible, be the latest version of the module as distributed by the + author (the latest non-beta version in the case of public Perl + releases), although the pumpkin holder may hold off on upgrading the + version of the module distributed with Perl to the latest version + until the latest version has had sufficient testing. + +In other words, the author of a module should be considered to have final +say on modifications to their module whenever possible (bearing in mind +that it's expected that everyone involved will work together and arrive at +reasonable compromises when there are disagreements). + +As a last resort, however: + + 4) If the author's vision of the future of their module is sufficiently + different from the vision of the pumpkin holder and perl5-porters as a + whole so as to cause serious problems for Perl, the pumpkin holder may + choose to formally fork the version of the module in the core from the + one maintained by the author. This should not be done lightly and + should *always* if at all possible be done only after direct input + from Larry. If this is done, it must then be made explicit in the + module as distributed with Perl core that it is a forked version and + that while it is based on the original author's work, it is no longer + maintained by them. This must be noted in both the documentation and + in the comments in the source of the module. + +Again, this should be a last resort only. Ideally, this should never +happen, and every possible effort at cooperation and compromise should be +made before doing this. If it does prove necessary to fork a module for +the overall health of Perl, proper credit must be given to the original +author in perpetuity and the decision should be constantly re-evaluated to +see if a remerging of the two branches is possible down the road. + +In all dealings with contributed modules, everyone maintaining Perl should +keep in mind that the code belongs to the original author, that they may +not be on perl5-porters at any given time, and that a patch is not +official unless it has been integrated into the author's copy of the +module. To aid with this, and with points #1, #2, and #3 above, contact +information for the authors of all contributed modules should be kept with +the Perl distribution. + +Finally, the Perl community as a whole recognizes that respect for +ownership of code, respect for artistic control, proper credit, and active +effort to prevent unintentional code skew or communication gaps is vital +to the health of the community and Perl itself. Members of a community +should not normally have to resort to rules and laws to deal with each +other, and this document, although it contains rules so as to be clear, is +about an attitude and general approach. The first step in any dispute +should be open communication, respect for opposing views, and an attempt +at a compromise. In nearly every circumstance nothing more will be +necessary, and certainly no more drastic measure should be used until +every avenue of communication and discussion has failed. + +-- +Version 1.2. By Russ Allbery (rra@stanford.edu) and the perl5-porters. + diff --git a/Porting/Glossary b/Porting/Glossary index 6a37060020..15ca4f9050 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -26,6 +26,10 @@ alignbytes (alignbytes.U): This variable holds the number of bytes required to align a double. Usual values are 2, 4 and 8. +ansi2knr (ansi2knr.U): + This variable is set if the user needs to run ansi2knr. + Currently, this is not supported, so we just abort. + aphostname (d_gethname.U): Thie variable contains the command which can be used to compute the host name. The command is fully qualified by its absolute path, to make @@ -699,27 +703,31 @@ d_pthreads_created_joinable (d_pthreadj.U): state. d_pwage (i_pwd.U): - This varaible conditionally defines PWAGE, which indicates + This variable conditionally defines PWAGE, which indicates that struct passwd contains pw_age. d_pwchange (i_pwd.U): - This varaible conditionally defines PWCHANGE, which indicates + This variable conditionally defines PWCHANGE, which indicates that struct passwd contains pw_change. d_pwclass (i_pwd.U): - This varaible conditionally defines PWCLASS, which indicates + This variable conditionally defines PWCLASS, which indicates that struct passwd contains pw_class. d_pwcomment (i_pwd.U): - This varaible conditionally defines PWCOMMENT, which indicates + This variable conditionally defines PWCOMMENT, which indicates that struct passwd contains pw_comment. d_pwexpire (i_pwd.U): - This varaible conditionally defines PWEXPIRE, which indicates + This variable conditionally defines PWEXPIRE, which indicates that struct passwd contains pw_expire. +d_pwgecos (i_pwd.U): + This variable conditionally defines PWGECOS, which indicates + that struct passwd contains pw_gecos. + d_pwquota (i_pwd.U): - This varaible conditionally defines PWQUOTA, which indicates + This variable conditionally defines PWQUOTA, which indicates that struct passwd contains pw_quota. d_readdir (d_readdir.U): diff --git a/Porting/config.sh b/Porting/config.sh index ff4f72528b..69da4a96b0 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : . -# Configuration time: Tue Mar 31 15:51:58 EST 1998 +# Configuration time: Wed May 13 13:36:52 EDT 1998 # Configured by : doughera # Target system : linux fractal 2.0.33 #1 tue feb 3 10:11:46 est 1998 i686 unknown @@ -28,10 +28,11 @@ _exe='' _o='.o' afs='false' alignbytes='4' +ansi2knr='' aphostname='' ar='ar' -archlib='/opt/perl/lib/i686-linux-thread/5.00463' -archlibexp='/opt/perl/lib/i686-linux-thread/5.00463' +archlib='/opt/perl/lib/i686-linux-thread/5.00464' +archlibexp='/opt/perl/lib/i686-linux-thread/5.00464' archname='i686-linux-thread' archobjs='' awk='awk' @@ -51,7 +52,7 @@ ccdlflags='-rdynamic' ccflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -I/usr/local/include' cf_by='doughera' cf_email='yourname@yourhost.yourplace.com' -cf_time='Tue Mar 31 15:51:58 EST 1998' +cf_time='Wed May 13 13:36:52 EDT 1998' chgrp='' chmod='' chown='' @@ -190,6 +191,7 @@ d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' +d_pwgecos='define' d_pwquota='undef' d_readdir='define' d_readlink='define' @@ -370,7 +372,7 @@ i_varhdr='stdarg.h' i_vfork='undef' incpath='' inews='' -installarchlib='/opt/perl/lib/i686-linux-thread/5.00463' +installarchlib='/opt/perl/lib/i686-linux-thread/5.00464' installbin='/opt/perl/bin' installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' @@ -516,7 +518,7 @@ stdio_filbuf='' stdio_ptr='((fp)->_IO_read_ptr)' strings='/usr/include/string.h' submit='' -subversion='63' +subversion='64' sysman='/usr/man/man1' tail='' tar='' @@ -549,5 +551,5 @@ xlibpth='/usr/lib/386 /lib/386' zcat='' zip='zip' PATCHLEVEL=4 -SUBVERSION=63 +SUBVERSION=64 CONFIG=true diff --git a/Porting/config_H b/Porting/config_H index 2f07d01ee4..de0cfd6684 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : . - * Configuration time: Tue Mar 31 15:51:58 EST 1998 + * Configuration time: Wed May 13 13:36:52 EDT 1998 * Configured by : doughera * Target system : linux fractal 2.0.33 #1 tue feb 3 10:11:46 est 1998 i686 unknown */ @@ -904,42 +904,6 @@ */ #define I_NETINET_IN /**/ -/* I_PWD: - * This symbol, if defined, indicates to the C program that it should - * include <pwd.h>. - */ -/* PWQUOTA: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -#define I_PWD /**/ -/*#define PWQUOTA / **/ -/*#define PWAGE / **/ -/*#define PWCHANGE / **/ -/*#define PWCLASS / **/ -/*#define PWEXPIRE / **/ -/*#define PWCOMMENT / **/ - /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include <sfio.h>. @@ -1490,8 +1454,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/opt/perl/lib/i686-linux-thread/5.00463" /**/ -#define ARCHLIB_EXP "/opt/perl/lib/i686-linux-thread/5.00463" /**/ +#define ARCHLIB "/opt/perl/lib/i686-linux-thread/5.00464" /**/ +#define ARCHLIB_EXP "/opt/perl/lib/i686-linux-thread/5.00464" /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -1725,6 +1689,47 @@ */ #define I_NETDB /**/ +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ +#define I_PWD /**/ +/*#define PWQUOTA / **/ +/*#define PWAGE / **/ +/*#define PWCHANGE / **/ +/*#define PWCLASS / **/ +/*#define PWEXPIRE / **/ +/*#define PWCOMMENT / **/ +#define PWGECOS /**/ + /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include <sys/types.h>. @@ -1744,6 +1749,37 @@ #define PRIVLIB "/opt/perl/lib" /**/ #define PRIVLIB_EXP "/opt/perl/lib" /**/ +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "IOT", "CLD", "POLL", 0 /**/ +#define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 17, 29, 0 /**/ + /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's @@ -1884,37 +1920,6 @@ */ #define Select_fd_set_t fd_set * /**/ -/* SIG_NAME: - * This symbol contains a list of signal names in order of - * signal number. This is intended - * to be used as a static array initialization, like this: - * char *sig_name[] = { SIG_NAME }; - * The signals in the list are separated with commas, and each signal - * is surrounded by double quotes. There is no leading SIG in the signal - * name, i.e. SIGQUIT is known as "QUIT". - * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, - * etc., where nn is the actual signal number (e.g. NUM37). - * The signal number for sig_name[i] is stored in sig_num[i]. - * The last element is 0 to terminate the list with a NULL. This - * corresponds to the 0 at the end of the sig_num list. - */ -/* SIG_NUM: - * This symbol contains a list of signal numbers, in the same order as the - * SIG_NAME list. It is suitable for static array initialization, as in: - * int sig_num[] = { SIG_NUM }; - * The signals in the list are separated with commas, and the indices - * within that list and the SIG_NAME list match, so it's easy to compute - * the signal name from a number or vice versa at the price of a small - * dynamic linear lookup. - * Duplicates are allowed, but are moved to the end of the list. - * The signal number corresponding to sig_name[i] is sig_number[i]. - * if (i < NSIG) then sig_number[i] == i. - * The last element is 0, corresponding to the 0 at the end of - * the sig_name list. - */ -#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "IOT", "CLD", "POLL", 0 /**/ -#define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 17, 29, 0 /**/ - /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname @@ -1928,7 +1933,13 @@ * routine is available to yield the execution of the current * thread. */ +/* HAS_SCHED_YIELD: + * This symbol, if defined, indicates that the sched_yield + * routine is available to yield the execution of the current + * thread. + */ /*#define HAS_PTHREAD_YIELD / **/ +#define HAS_SCHED_YIELD /**/ /* PTHREADS_CREATED_JOINABLE: * This symbol, if defined, indicates that pthreads are created diff --git a/Porting/makerel b/Porting/makerel index f719a5e936..5a7cd8b967 100644 --- a/Porting/makerel +++ b/Porting/makerel @@ -21,15 +21,21 @@ $patchlevel_h = `grep '#define ' patchlevel.h`; print $patchlevel_h; $patchlevel = $1 if $patchlevel_h =~ /PATCHLEVEL\s+(\d+)/; $subversion = $1 if $patchlevel_h =~ /SUBVERSION\s+(\d+)/; -die "Unable to parse patchlevel.h" unless $subversion > 0; +die "Unable to parse patchlevel.h" unless $subversion >= 0; $vers = sprintf("5.%03d", $patchlevel); -$vers.= sprintf( "_%02d", $subversion) if $subversion; +$vms_vers = sprintf("5_%03d", $patchlevel); +if ($subversion) { + $vers.= sprintf( "_%02d", $subversion); + $vms_vers.= sprintf( "%02d", $subversion); +} else { + $vms_vers.= " "; +} $perl = "perl$vers"; -$reldir = "$relroot/$perl"; +$reldir = "$perl"; $reldir .= "-$ARGV[0]" if $ARGV[0]; -print "\nMaking a release for $perl in $reldir\n\n"; +print "\nMaking a release for $perl in $relroot/$reldir\n\n"; print "Cross-checking the MANIFEST...\n"; @@ -47,6 +53,10 @@ die "Aborted.\n" if @$missentry or @$missfile; print "\n"; +print "Updating VMS version specific files with $vms_vers...\n"; +system("perl -pi -e 's/^\QPERL_VERSION = \E\d\_\d+(\s*\#)/PERL_VERSION = $vms_vers$1/' vms/descrip.mms"); + + print "Setting file permissions...\n"; system("find . -type f -print | xargs chmod -w"); system("find . -type d -print | xargs chmod g-s"); @@ -77,23 +87,24 @@ system("chmod +x @exe"); 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 "../$reldir.tar.gz"; -mkdir($reldir, 0755) or die "mkdir $reldir: $!\n"; +print "Creating $relroot/$reldir release directory...\n"; +die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir"; +die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz"; +mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n"; print "\n"; print "Copying files to release directory...\n"; # ExtUtils::Manifest maniread does not preserve the order -$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $reldir"; +$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir"; system($cmd) == 0 or die "$cmd failed"; print "\n"; chdir $relroot or die $!; print "Creating and compressing the tar file...\n"; -$cmd = "tar cf - $perl | gzip --best > $perl.tar.gz"; +my $src = (-e $perl) ? $perl : 'perl'; # 'perl' in maint branch +$cmd = "tar cf - $reldir | gzip --best > $perl.tar.gz"; system($cmd) == 0 or die "$cmd failed"; print "\n"; diff --git a/Porting/patching.pod b/Porting/patching.pod new file mode 100644 index 0000000000..b2a86b6f34 --- /dev/null +++ b/Porting/patching.pod @@ -0,0 +1,275 @@ +=head1 Name + +patching.pod - Appropriate format for patches to the perl source tree + +=head2re to get this document + +The latest version of this document is available from + http://www.tdrenterprises.com/perl/perlpatch.html + +=head2 How to contribute to this document + +You may mail corrections, additions, and suggestions to me +at dgris@tdrenterprises.com but the preferred method would be +to follow the instructions set forth in this document and +submit a patch 8-). + +=head1 Description + +=head2 Why this document exists + +As an open source project Perl relies on patches and contributions from +its users to continue functioning properly and to root out the inevitable +bugs. But, some users are unsure as to the I<right> way to prepare a patch +and end up submitting seriously malformed patches. This makes it very +difficult for the current maintainer to integrate said patches into their +distribution. This document sets out usage guidelines for patches in an +attempt to make everybody's life easier. + +=head2 Common problems + +The most common problems appear to be patches being mangled by certain +mailers (I won't name names, but most of these seem to be originating on +boxes running a certain popular commercial operating system). Other problems +include patches not rooted in the appropriate place in the directory structure, +and patches not produced using standard utilities (such as diff). + +=head1 Proper Patch Guidelines + +=head2 How to prepare your patch + +=over 4 + +=item Creating your patch + +First, back up the original files. This can't be stressed enough, +back everything up _first_. + +Also, please create patches against a clean distribution of the perl source. +This insures that everyone else can apply your patch without clobbering their +source tree. + +=item diff + +While individual tastes vary (and are not the point here) patches should +be created using either C<-u> or C<-c> arguments to diff. These produce, +respectively, unified diffs (where the changed line appears immediately next +to the original) and context diffs (where several lines surrounding the changes +are included). See the manpage for diff for more details. + +Also, the preferred method for patching is - + +C<diff [C<-c> | C<-u>] E<lt>old-fileE<gt> E<lt>new-fileE<gt>> + +Note the order of files. + +Also, if your patch is to the core (rather than to a module) it +is better to create it as a context diff as some machines have +broken patch utilities that choke on unified diffs. + +=item Directories + +Patches should be generated from the source root directory, not from the +directory that the patched file resides in. This insures that the maintainer +patches the proper file and avoids name collisions (especially common when trying +to apply patches to files that appear in both $src_root/ext/* and $src_root/lib/*). +It is better to diff the file in $src_root/ext than the file in $src_root/lib. + +=item Filenames + +The most usual convention when submitting patches for a single file is to make +your changes to a copy of the file with the same name as the original. Rename +the original file in such a way that it is obvious what is being patched ($file~ or +$file.old seem to be popular). + +If you are submitting patches that affect multiple files then you should backup +the entire directory tree (to $source_root.old/ for example). This will allow +C<diff C<-c> E<lt>old-dirE<gt> E<lt>new-dirE<gt>> to create all the patches +at once. + +=back + +=head2 What to include in your patch + +=over 4 + +=item Description of problem + +The first thing you should include is a description of the problem that +the patch corrects. If it is a code patch (rather than a documentation +patch) you should also include a small test case that illustrates the +bug. + +=item Direction for application + +You should include instructions on how to properly apply your patch. +These should include the files affected, any shell scripts or commands +that need to be run before or after application of the patch, and +the command line necessary for application. + +=item If you have a code patch + +If you are submitting a code patch there are several other things that +you need to do. + +=over 4 + +=item Comments, Comments, Comments + +Be sure to adequately comment your code. While commenting every +line is unnecessary, anything that takes advantage of side effects of +operators, that creates changes that will be felt outside of the +function being patched, or that others may find confusing should +be documented. If you are going to err, it is better to err on the +side of adding too many comments than too few. + +=item Style + +Please follow the indentation style and nesting style in use in the +block of code that you are patching. + +=item Testsuite + +Also please include an addition to the regression tests to properly +exercise your patch. + +=back + +=item Test your patch + +Apply your patch to a clean distribution, compile, and run the +regression test suite (you did remember to add one for your +patch, didn't you). + +=back + +=head2 An example patch creation + +This should work for most patches- + + cp MANIFEST MANIFEST.old + emacs MANIFEST + (make changes) + cd .. + diff -c perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST > mypatch + (testing the patch:) + mv perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new + cp perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST + patch -p < mypatch + (should succeed) + diff perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new + (should produce no output) + +=head2 Submitting your patch + +=over 4 + +=item Mailers + +Please, please, please (get the point? 8-) don't use a mailer that +word wraps your patch or that MIME encodes it. Both of these leave +the patch essentially worthless to the maintainer. + +If you have no choice in mailers and no way to get your hands on a +better one there is, of course, a perl solution. Just do this- + + perl -ne 'print pack("u*",$_)' patch > patch.uue + +and post patch.uue with a note saying to unpack it using + + perl -ne 'print unpack("u*",$_)' patch.uue > patch + +=item Subject lines for patches + +The subject line on your patch should read + +[PATCH]5.xxx_xx (Area) Description + +where the x's are replaced by the appropriate version number, +area is a short keyword identifying what area of perl you are +patching, and description is a very brief summary of the +problem (don't forget this is an email header). + +Examples- + +[PATCH]5.004_04 (DOC) fix minor typos + +[PATCH]5.004_99 (CORE) New warning for foo() when frobbing + +[PATCH]5.005_42 (CONFIG) Added support for fribnatz 1.5 + +=item Where to send your patch + +If your patch is for the perl core it should be sent perlbug@perl.org. +If it is a patch to a module that you downloaded from CPAN you should +submit your patch to that module's author. + +=back + +=head2 Applying a patch + +=over 4 + +=item General notes on applying patches + +The following are some general notes on applying a patch +to your perl distribution. + +=over 4 + +=item patch C<-p> + +It is generally easier to apply patches with the C<-p> argument to +patch. This helps reconcile differing paths between the machine the +patch was created on and the machine on which it is being applied. + +=item Cut and paste + +_Never_ cut and paste a patch into your editor. This usually clobbers +the tabs and confuses patch. + +=item Hand editing patches + +Avoid hand editing patches as this frequently screws up the whitespace +in the patch and confuses the patch program. + +=back + +=back + +=head2 Final notes + +If you follow these guidelines it will make everybody's life a little +easier. You'll have the satisfaction of having contributed to perl, +others will have an easy time using your work, and it should be easier +for the maintainers to coordinate the occasionally large numbers of +patches received. + +Also, just because you're not a brilliant coder doesn't mean that you can't +contribute. As valuable as code patches are there is always a need for better +documentation (especially considering the general level of joy that most +programmers feel when forced to sit down and write docs). If all you do +is patch the documentation you have still contributed more than the person +who sent in an amazing new feature that noone can use because noone understands +the code (what I'm getting at is that documentation is both the hardest part to +do (because everyone hates doing it) and the most valuable). + +Mostly, when contributing patches, imagine that it is B<you> receiving hundreds +of patches and that it is B<your> responsibility to integrate them into the source. +Obviously you'd want the patches to be as easy to apply as possible. Keep that in +mind. 8-) + +=head1 Last Modified + +Last modified 1 May 1998 by Daniel Grisinger <dgris@tdrenterprises.com> + +=head1 Author and Copyright Information + +Copyright (c) 1998 Daniel Grisinger + +Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk). + +I'd like to thank the perl5-porters for their suggestions. + + + diff --git a/Porting/patchls b/Porting/patchls index 1d4bd5ac40..5b958323d2 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -17,10 +17,10 @@ use Text::Tabs qw(expand unexpand); use strict; use vars qw($VERSION); -$VERSION = 2.04; +$VERSION = 2.05; sub usage { -die q{ +die qq{ patchls [options] patchfile [ ... ] -h no filename headers (like grep), only the listing. @@ -31,12 +31,17 @@ die q{ -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 /). + (F has \$ appended unless it contains a /). + -e Expect patched files to Exist (relative to current directory) + Will print warnings for files which don't. Also affects -4 option. 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. + -5 like -4 but add "|| exit 1" after each command -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) + + patchls version $VERSION by Tim Bunce } } @@ -49,21 +54,25 @@ $::opt_h = 0; $::opt_l = 0; $::opt_c = 0; $::opt_f = ''; +$::opt_e = 0; # special purpose options $::opt_I = 0; $::opt_4 = 0; # output PerForce commands to prepare for patching +$::opt_5 = 0; $::opt_M = ''; # like -m but only output these meta items (-M Title) $::opt_W = 70; # set wrap width columns (see Text::Wrap module) +$::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented usage unless @ARGV; -getopts("mihlvc4p:f:IM:W:") or usage; +getopts("mihlvecC45p: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'); +$::opt_4 = 1 if $::opt_5; +my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID'); # see get_meta_info() my %cat_title = ( 'BUILD' => 'BUILD PROCESS', @@ -77,7 +86,17 @@ my %cat_title = ( 'OTHER' => 'OTHER CHANGES', ); -my %ls; + +sub get_meta_info { + my $ls = shift; + local($_) = shift; + $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->{$1}{$2}=1 if $::opt_M && /^([-\w]+):\s+(.*\S)/; +} + # Style 1: # *** perl-5.004/embed.h Sat May 10 03:39:32 1997 @@ -97,10 +116,14 @@ my %ls; # Variation: # Index: embed.h -my($in, $prevline, $prevtype, $ls); -my(@removed, @added); +my %ls; + +my ($in, $prevline, $ls); +my $prevtype = ''; +my (@removed, @added); my $prologue = 1; # assume prologue till patch or /^exit\b/ seen + foreach my $argv (@ARGV) { $in = $argv; unless (open F, "<$in") { @@ -119,12 +142,7 @@ foreach my $argv (@ARGV) { push @removed, $1 if /^rm\s+(?:-f)?\s*(\S+)/; $prologue = 0 if /^exit\b/; } - next unless $::opt_m; - $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)/; + get_meta_info($ls, $_) if $::opt_m; next; } $type = $1; @@ -155,6 +173,25 @@ foreach my $argv (@ARGV) { $prevtype = $type; $type = ''; } + + # special mode for patch sets from Chip + if ($::opt_C && $in =~ m:[\\/]patch$:) { + my $chip; + my $dir; ($dir = $in) =~ s:[\\/]patch$::; + if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) { + get_meta_info($ls, $_) while (<CHIP>); + } + if (open CHIP,"<$dir/from") { + chop($chip = <CHIP>); + $ls->{From} = { $chip => 1 }; + } + if (open CHIP,"<$dir/tag") { + chop($chip = <CHIP>); + $ls->{Title} = { $chip => 1 }; + } + $ls->{From} = { "Chip Salzenberg" => 1 } unless $ls->{From}; + } + # if we don't have a title for -m then use the file name $ls->{Title}{$in}=1 if $::opt_m and !$ls->{Title} and $ls->{out}; @@ -190,14 +227,18 @@ if ($::opt_f) { # filter out patches based on -f <regexp> # --- Handle special modes --- if ($::opt_4) { - print map { "p4 delete $_\n" } @removed if @removed; - print map { "p4 add $_\n" } @added if @added; + my $tail = ($::opt_5) ? "|| exit 1" : ""; + print map { "p4 delete $_$tail\n" } @removed if @removed; + print map { "p4 add $_$tail\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; + print map { + my $edit = ($::opt_e && !-f $_) ? "add " : "edit"; + "p4 $edit $_$tail\n" + } @patched if @patched; + exit 0 unless $::opt_C; } if ($::opt_I) { @@ -267,6 +308,8 @@ sub add_file { $ls->{out}->{$out} = 1; + warn "$out patched but not present\n" if $::opt_e && !-f $out; + # do the -i inverse as well, even if we're not doing -i my $i = $ls{$out} ||= { is_out => 1, @@ -308,7 +351,8 @@ sub list_files_by_patch { my @list = sort keys %{$ls->{$meta}}; push @meta, sprintf "%7s: ", $meta; if ($meta eq 'Title') { - @list = map { s/\[?PATCH\]?:?\s*//g; "\"$_\""; } @list + @list = map { s/\[?(PATCH|PERL)\]?:?\s*//g; "\"$_\""; } @list; + push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:; } elsif ($meta eq 'From') { # fix-up bizzare addresses from japan and ibm :-) @@ -329,7 +373,7 @@ sub list_files_by_patch { } # don't print the header unless the file contains something interesting return if !@meta and !$ls->{out}; - print("$ls->{in}\n"),return if $::opt_l; # -l = no listing + print("$ls->{in}\n"),return if $::opt_l; # -l = no listing, just names # a twisty maze of little options my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : ""; diff --git a/Porting/pumpkin.pod b/Porting/pumpkin.pod index 27cf1198ee..724f1ba478 100644 --- a/Porting/pumpkin.pod +++ b/Porting/pumpkin.pod @@ -508,6 +508,9 @@ You might like, early in your pumpkin-holding career, to see if you can find champions for partiticular issues on the to-do list: an issue owned is an issue more likely to be resolved. +There are also some more porting-specific L<Todo> items later in this +file. + =head2 OS/2-specific updates In the os2 directory is F<diff.configure>, a set of OS/2-specific @@ -1071,6 +1074,62 @@ distribution modules. If you do then perl.c will put /my/override ahead of ARCHLIB and PRIVLIB. +=head2 Shared libperl.so location + +Why isn't the shared libperl.so installed in /usr/lib/ along +with "all the other" shared libraries? Instead, it is installed +in $archlib, which is typically something like + + /usr/local/lib/perl5/archname/5.00404 + +and is architecture- and version-specific. + +The basic reason why a shared libperl.so gets put in $archlib is so that +you can have more than one version of perl on the system at the same time, +and have each refer to its own libperl.so. + +Three examples might help. All of these work now; none would work if you +put libperl.so in /usr/lib. + +=over + +=item 1. + +Suppose you want to have both threaded and non-threaded perl versions +around. Configure will name both perl libraries "libperl.so" (so that +you can link to them with -lperl). The perl binaries tell them apart +by having looking in the appropriate $archlib directories. + +=item 2. + +Suppose you have perl5.004_04 installed and you want to try to compile +it again, perhaps with different options or after applying a patch. +If you already have libperl.so installed in /usr/lib/, then it may be +either difficult or impossible to get ld.so to find the new libperl.so +that you're trying to build. If, instead, libperl.so is tucked away in +$archlib, then you can always just change $archlib in the current perl +you're trying to build so that ld.so won't find your old libperl.so. +(The INSTALL file suggests you do this when building a debugging perl.) + +=item 3. + +The shared perl library is not a "well-behaved" shared library with +proper major and minor version numbers, so you can't necessarily +have perl5.004_04 and perl5.004_05 installed simultaneously. Suppose +perl5.004_04 were to install /usr/lib/libperl.so.4.4, and perl5.004_05 +were to install /usr/lib/libperl.so.4.5. Now, when you try to run +perl5.004_04, ld.so might try to load libperl.so.4.5, since it has +the right "major version" number. If this works at all, it almost +certainly defeats the reason for keeping perl5.004_04 around. Worse, +with development subversions, you certaily can't guarantee that +libperl.so.4.4 and libperl.so.4.55 will be compatible. + +Anyway, all this leads to quite obscure failures that are sure to drive +casual users crazy. Even experienced users will get confused :-). Upon +reflection, I'd say leave libperl.so in $archlib. + +=back + =head1 Upload Your Work to CPAN You can upload your work to CPAN if you have a CPAN id. Check out @@ -1114,12 +1173,13 @@ described in F<INSTALL>. AFS users also are treated specially. We should probably duplicate the metaconfig prefix stuff for an install prefix. -=item Configure -Dsrcdir=/blah/blah +=item Configure -Dsrc=/blah/blah We should be able to emulate B<configure --srcdir>. Tom Tromey tromey@creche.cygnus.com has submitted some patches to -the dist-users mailing list along these lines. Eventually, they ought -to get folded back into the main distribution. +the dist-users mailing list along these lines. They have been folded +back into the main distribution, but various parts of the perl +Configure/build/install process still assume src='.'. =item Hint file fixes @@ -1131,6 +1191,47 @@ Configure so that most of them aren't needed. Some of the hint file information (particularly dynamic loading stuff) ought to be fed back into the main metaconfig distribution. +=item Catch GNU Libc "Stub" functions + +Some functions (such as lchown()) are present in libc, but are +unimplmented. That is, they always fail and set errno=ENOSYS. + +Thomas Bushnell provided the following sample code and the explanation +that follows: + + /* System header to define __stub macros and hopefully few prototypes, + which can conflict with char FOO(); below. */ + #include <assert.h> + /* Override any gcc2 internal prototype to avoid an error. */ + /* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ + char FOO(); + + int main() { + + /* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ + #if defined (__stub_FOO) || defined (__stub___FOO) + choke me + #else + FOO(); + #endif + + ; return 0; } + +The choice of <assert.h> is essentially arbitrary. The GNU libc +macros are found in <gnu/stubs.h>. You can include that file instead +of <assert.h> (which itself includes <gnu/stubs.h>) if you test for +its existence first. <assert.h> is assumed to exist on every system, +which is why it's used here. Any GNU libc header file will include +the stubs macros. If either __stub_NAME or __stub___NAME is defined, +then the function doesn't actually exist. Tests using <assert.h> work +on every system around. + +The declaration of FOO is there to override builtin prototypes for +ANSI C functions. + =back =head2 Probably good ideas waiting for round tuits @@ -1176,12 +1277,6 @@ Get some of the Macintosh stuff folded back into the main distribution. Maybe include a replacement function that doesn't lose data in rare cases of coercion between string and numerical values. -=item long long - -Can we support C<long long> on systems where C<long long> is larger -than what we've been using for C<IV>? What if you can't C<sprintf> -a C<long long>? - =item Improve makedepend The current makedepend process is clunky and annoyingly slow, but it @@ -1218,4 +1313,4 @@ All opinions expressed herein are those of the authorZ<>(s). =head1 LAST MODIFIED -$Id: pumpkin.pod,v 1.14 1998/03/03 17:14:47 doughera Released $ +$Id: pumpkin.pod,v 1.15 1998/04/23 17:03:48 doughera Released $ @@ -76,11 +76,10 @@ or if you have any problems building.) 2) Read the manual entries before running perl. 3) IMPORTANT! Help save the world! Communicate any problems and suggested -patches to me, larry@wall.org (Larry Wall), so we can -keep the world in sync. If you have a problem, there's someone else -out there who either has had or will have the same problem. -It's usually helpful if you send the output of the "myconfig" script -in the main perl directory. +patches to perlbug@perl.com so we can keep the world in sync. +If you have a problem, there's someone else out there who either has had +or will have the same problem. It's usually helpful if you send the +output of the "myconfig" script in the main perl directory. If you've succeeded in compiling perl, the perlbug script in the utils/ subdirectory can be used to help mail in a bug report. diff --git a/README.beos b/README.beos new file mode 100644 index 0000000000..8c24393d6e --- /dev/null +++ b/README.beos @@ -0,0 +1,75 @@ +$Id: README.beos,v 1.2 1998/05/02 01:55:04 dogcow Exp dogcow $ + +Notes on building perl under BeOS: + +GENERAL ISSUES +-------------- +perl will almost compile straight out of the box with ./Configure -d, but +there are a few gotchas: + +Currently, you have to edit config.sh and remove SDBM_File from the +dynamic_ext= and extensions= lines. SDBM_File does not build properly +at this time. You need to run ./Configure -S after editing config.sh. + +In addition, with mwcc, after doing `make depend`, you need to edit +makefile and x2p/makefile and remove the lines that mention 'Bletch:'. +This is not necessary if you're using gnu cpp. + +in short: +./Configure -d +remove SDBM_File from config.sh +./Configure -S +make depend +remove Bletch: from makefile and x2p/makefile +make + +Other than that, perl should build without problems. There are some +technical comments in hints/beos.sh. + +OS RELEASE-SPECIFIC NOTES +------------------------- + +PR1/PPC: +See R3/X86. Same bug, different form. + +PR2/PPC: +Signals are somewhat unreliable, but they can work. Use caution. +The POSIX module is still somewhat buggy. + +R3/X86: +Under R3 x86, there are some serious problems with the math routines +such that numbers are incorrectly printed. This causes problems with +modules that encode their version numbers - in particular, IO.pm will +probably not work properly. This should be fixed under R3.1. + +The problem has manifested itself if you see something similar to the +following during the compile: + +cc -c -I/usr/local/include -O -DVERSION=\"1.1504\" -DXS_VERSION=\"1.1499999999\" -fpic -I../.. IO.c +(lots of 9's are the indication of the problem.) + +In the meantime, you can use the following workaround: + +make perl +cd ext/IO +cc -c -I/usr/local/include -O -DVERSION=\"1.1504\" -DXS_VERSION=\"1.15\" -fpic -I../.. IO.c +cd .. +make + +(Substitute the correct numbers if IO has been updated.) + +R3/PPC- +There's math problems, but of a different kind. In particular, +perl -e 'print (240000 - (3e4<<3))' gives a non-zero answer. +I'm looking into this. There is no workaround as yet. Hopefully, +this will be fixed in R3.1. + +CONTACT INFORMATION +------------------- +If you have comments, problem reports, or even patches or bugfixes (gasp!) +please email me. + +1 May 1998 +Tom Spindler +dogcow@merit.edu + diff --git a/README.os2 b/README.os2 index 667423c382..903702aa0d 100644 --- a/README.os2 +++ b/README.os2 @@ -308,7 +308,31 @@ L<"Frequently asked questions">), and perl should be able to find it The only cases when the shell is not used is the multi-argument system() (see L<perlfunc/system>)/exec() (see L<perlfunc/exec>), and one-argument version thereof without redirection and shell -meta-characters. +meta-characters. Perl may also start scripts which start with cookies +C<extproc> or C<#!> directly, without an intervention of shell. + +If starting scripts directly, Perl will use exactly the same algorithm as for +the search of script given by B<-S> command-line option: it will look in +the current directory, then on components of C<$ENV{PATH}> using the +following order of appended extensions: no extension, F<.cmd>, F<.btm>, +F<.bat>, F<.pl>. + +Note that Perl will start to look for scripts only if OS/2 cannot start the +specified application, thus C<system 'blah'> will not look for a script if +there is an executable file F<blah.exe> I<anywhere> on C<PATH>. + +Note also that executable files on OS/2 can have an arbitrary extension, +but F<.exe> will be automatically appended if no dot is present in the name. +The workaround as as simple as that: since F<blah.> and F<blah> denote the +same file, to start an executable residing in file F<n:/bin/blah> (no +extension) give an argument C<n:/bin/blah.> to system(). + +The last note is that currently it is not straightforward to start PM +programs from VIO (=text-mode) Perl process and visa versa. Either ensure +that shell will be used, as in C<system 'cmd /c epm'>, or start it using +optional arguments to system() documented in C<OS2::Process> module. This +is considered a bug and should be fixed soon. + =head1 Frequently asked questions @@ -780,6 +804,10 @@ F<POSIX.c>. =head2 Testing +If you haven't yet moved perl.dll onto LIBPATH, do it now(alternatively, if +you have a previous perl installation you'd rather not disrupt until this one +is installed, copy perl.dll to the t directory). + Now run make test @@ -911,6 +939,8 @@ to 1. =head2 Installing the built perl +If you haven't yet moved perl.dll onto LIBPATH, do it now. + Run make install diff --git a/README.vms b/README.vms index 40de6acac7..21efaa0459 100644 --- a/README.vms +++ b/README.vms @@ -203,6 +203,8 @@ 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 +Note that if you wish to use most as a pager please see +ftp://space.mit.edu/pub/davis/ for both most and slang. 7) Optionally define the command PERLBUG (the Perl bug report generator) as PERLBUG :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB]PERLBUG.COM" @@ -214,6 +216,13 @@ module builds) as DEFINE/NOLOG POD2MAN PERL_ROOT:[LIB.POD]POD2MAN.COM POD2MAN :== $PERL_ROOT:[000000]PERL POD2MAN +8) Optionally define the command POD2MAN (Converts POD files to nroff +source suitable for converting to man pages. Also quiets complaints during +module builds) as + +DEFINE/NOLOG POD2MAN PERL_ROOT:[LIB.POD]POD2MAN.COM +POD2MAN :== $PERL_ROOT:[000000]PERL POD2MAN + * Installing Perl into DCLTABLES Courtesy of Brad Hughes: @@ -21,7 +21,8 @@ Would be nice to have reference to compiled regexp lexically scoped functions: my sub foo { ... } lvalue functions - Full 64 bit support + regression/sanity tests for suidperl + Full 64 bit support (i.e. "long long") Possible pragmas debugger @@ -55,5 +56,4 @@ Vague possibilities structured types autocroak? Modifiable $1 et al - substr EXPR,OFFSET,LENGTH,STRING @@ -11,7 +11,7 @@ #endif #define dXSARGS \ - dSP; dMARK; \ + dSP; dMARK; \ I32 ax = mark - stack_base + 1; \ I32 items = sp - mark @@ -21,10 +21,10 @@ av_reify(AV *av) I32 key; SV* sv; - if (AvREAL(av)) - return; + if (AvREAL(av)) + return; #ifdef DEBUGGING - if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) + if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) warn("av_reify called on tied array"); #endif key = AvMAX(av) + 1; @@ -369,7 +369,6 @@ av_undef(register AV *av) SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); - SvPVX(av) = 0; AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILLp(av) = -1; @@ -479,7 +478,7 @@ av_unshift(register AV *av, register I32 num) AvFILLp(av) += i; SvPVX(av) = (char*)(AvARRAY(av) - i); } - if (num) { + if (num) { i = AvFILLp(av); av_extend(av, i + num); AvFILLp(av) += num; diff --git a/beos/nm.c b/beos/nm.c new file mode 100644 index 0000000000..4f53f743b2 --- /dev/null +++ b/beos/nm.c @@ -0,0 +1,53 @@ +/* nm.c - a feeble shared-lib library parser + * Copyright 1997, 1998 Tom Spindler + * This software is covered under perl's Artistic license. + */ + +/* $Id: nm.c,v 1.1 1998/02/16 03:51:26 dogcow Exp $ */ + +#include <be/kernel/image.h> +#include <malloc.h> +#include <string.h> +#include <unistd.h> +#include <stdio.h> +#include <stdlib.h> + +main(int argc, char **argv) { +char *path, *symname; +image_id img; +int32 n = 0; +volatile int32 symnamelen, symtype; +void *symloc; + +if (argc != 2) { printf("more args, bozo\n"); exit(1); } + +path = (void *) malloc((size_t) 2048); +symname = (void *) malloc((size_t) 2048); + +if (!getcwd(path, 2048)) { printf("aiee!\n"); exit(1); } +if (!strcat(path, "/")) {printf("naah.\n"); exit (1); } +/*printf("%s\n",path);*/ + +if ('/' != argv[1][0]) { + if (!strcat(path, argv[1])) { printf("feh1\n"); exit(1); } +} else { + if (!strcpy(path, argv[1])) { printf("gah!\n"); exit(1); } +} +/*printf("%s\n",path);*/ + +img = load_add_on(path); +if (B_ERROR == img) {printf("Couldn't load_add_on() %s.\n", path); exit(2); } + +symnamelen=2047; + +while (B_BAD_INDEX != get_nth_image_symbol(img, n++, symname, &symnamelen, + &symtype, &symloc)) { + printf("%s |%s |GLOB %Lx | \n", symname, + ((B_SYMBOL_TYPE_ANY == symtype) || (B_SYMBOL_TYPE_TEXT == symtype)) ? "FUNC" : "VAR ", symloc); + symnamelen=2047; +} +printf("number of symbols: %d\n", n); +if (B_ERROR == unload_add_on(img)) {printf("err while closing.\n"); exit(3); } +free(path); +return(0); +} diff --git a/bytecode.h b/bytecode.h index 0239866d0a..3e8a6a9ead 100644 --- a/bytecode.h +++ b/bytecode.h @@ -2,7 +2,7 @@ typedef char *pvcontents; typedef char *strconst; typedef U32 PV; typedef char *op_tr_array; -typedef int comment; +typedef int comment_t; typedef SV *svindex; typedef OP *opindex; typedef IV IV64; @@ -38,7 +38,7 @@ void byterun(PerlIO *fp) switch (insn) { case INSN_COMMENT: /* 35 */ { - comment arg; + comment_t arg; BGET_comment(arg); arg = arg; break; @@ -124,6 +124,7 @@ for file do optimize="$optdebug" fi + : Can we perhaps use $ansi2knr here echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split" eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"' diff --git a/config_h.SH b/config_h.SH index 1d3a13d209..5d4cffccf6 100644 --- a/config_h.SH +++ b/config_h.SH @@ -918,42 +918,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_niin I_NETINET_IN /**/ -/* I_PWD: - * This symbol, if defined, indicates to the C program that it should - * include <pwd.h>. - */ -/* PWQUOTA: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -#$i_pwd I_PWD /**/ -#$d_pwquota PWQUOTA /**/ -#$d_pwage PWAGE /**/ -#$d_pwchange PWCHANGE /**/ -#$d_pwclass PWCLASS /**/ -#$d_pwexpire PWEXPIRE /**/ -#$d_pwcomment PWCOMMENT /**/ - /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include <sfio.h>. @@ -1739,6 +1703,47 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_netdb I_NETDB /**/ +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ +#$i_pwd I_PWD /**/ +#$d_pwquota PWQUOTA /**/ +#$d_pwage PWAGE /**/ +#$d_pwchange PWCHANGE /**/ +#$d_pwclass PWCLASS /**/ +#$d_pwexpire PWEXPIRE /**/ +#$d_pwcomment PWCOMMENT /**/ +#$d_pwgecos PWGECOS /**/ + /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include <sys/types.h>. @@ -1758,6 +1763,37 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define PRIVLIB "$privlib" /**/ #define PRIVLIB_EXP "$privlibexp" /**/ +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME $sig_name_init /**/ +#define SIG_NUM $sig_num /**/ + /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's @@ -1898,37 +1934,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define Select_fd_set_t $selecttype /**/ -/* SIG_NAME: - * This symbol contains a list of signal names in order of - * signal number. This is intended - * to be used as a static array initialization, like this: - * char *sig_name[] = { SIG_NAME }; - * The signals in the list are separated with commas, and each signal - * is surrounded by double quotes. There is no leading SIG in the signal - * name, i.e. SIGQUIT is known as "QUIT". - * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, - * etc., where nn is the actual signal number (e.g. NUM37). - * The signal number for sig_name[i] is stored in sig_num[i]. - * The last element is 0 to terminate the list with a NULL. This - * corresponds to the 0 at the end of the sig_num list. - */ -/* SIG_NUM: - * This symbol contains a list of signal numbers, in the same order as the - * SIG_NAME list. It is suitable for static array initialization, as in: - * int sig_num[] = { SIG_NUM }; - * The signals in the list are separated with commas, and the indices - * within that list and the SIG_NAME list match, so it's easy to compute - * the signal name from a number or vice versa at the price of a small - * dynamic linear lookup. - * Duplicates are allowed, but are moved to the end of the list. - * The signal number corresponding to sig_name[i] is sig_number[i]. - * if (i < NSIG) then sig_number[i] == i. - * The last element is 0, corresponding to the 0 at the end of - * the sig_name list. - */ -#define SIG_NAME $sig_name_init /**/ -#define SIG_NUM $sig_num /**/ - /* ARCHNAME: * This symbol holds a string representing the architecture name. * It may be used to construct an architecture-dependant pathname @@ -1942,7 +1947,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * routine is available to yield the execution of the current * thread. */ +/* HAS_SCHED_YIELD: + * This symbol, if defined, indicates that the sched_yield + * routine is available to yield the execution of the current + * thread. + */ #$d_pthread_yield HAS_PTHREAD_YIELD /**/ +#$d_sched_yield HAS_SCHED_YIELD /**/ /* PTHREADS_CREATED_JOINABLE: * This symbol, if defined, indicates that pthreads are created @@ -285,6 +285,7 @@ struct context { #define G_EVAL 4 /* Assume eval {} around subroutine call. */ #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ +#define G_NODEBUG 32 /* Disable debugging at toplevel. */ /* Support for switching (stack and block) contexts. * This ensures magic doesn't invalidate local stack and cx pointers. diff --git a/djgpp/djgppsed.sh b/djgpp/djgppsed.sh index 5acf0ce8f3..96a6885f10 100644 --- a/djgpp/djgppsed.sh +++ b/djgpp/djgppsed.sh @@ -25,7 +25,7 @@ SSTAT='s=\.\(stat\.\)=_\1=g' STMP2='s=tmp2=tm2=g' SPACKLIST='s=\.\(packlist\)=_\1=g' -sed -e $SCONFIG -e $SGREPTMP -e $SECHOTMP -e $SDDC -e $SOUT Configure |tr -d '\r' >s; mv -f s Configure +sed -e $SCONFIG -e $SGREPTMP -e $SECHOTMP -e $SDDC -e $SOUT -e 's=\.\( \./\$file\)$=sh\1=g' Configure |tr -d '\r' >s; mv -f s Configure sed -e $SEXISTS -e $SLIST -e $SCONFIG Makefile.SH |tr -d '\r' >s; mv -f s Makefile.SH sed -e $SEXISTS -e $SPACKLIST lib/ExtUtils/Install.pm |tr -d '\r' >s; mv -f s lib/ExtUtils/Install.pm sed -e $SEXISTS -e $SPACKLIST lib/ExtUtils/MM_Unix.pm |tr -d '\r' >s; mv -f s lib/ExtUtils/MM_Unix.pm @@ -171,8 +171,11 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); - if (dowarn && name[strlen(name)-1] == '|') - warn("Can't do bidirectional pipe"); + if (name[strlen(name)-1] == '|') { + name[strlen(name)-1] = '\0' ; + if (dowarn) + warn("Can't do bidirectional pipe"); + } fp = PerlProc_popen(name,"w"); writing = 1; } @@ -583,6 +586,7 @@ do_close(GV *gv, bool not_implicit) if (!io) { /* never opened */ if (dowarn && not_implicit) warn("Close on unopened file <%s>",GvENAME(gv)); + SETERRNO(EBADF,SS$_IVCHAN); return FALSE; } retval = io_close(io); @@ -619,6 +623,9 @@ io_close(IO *io) } IoOFP(io) = IoIFP(io) = Nullfp; } + else { + SETERRNO(EBADF,SS$_IVCHAN); + } return retval; } @@ -713,6 +720,46 @@ do_sysseek(GV *gv, long int pos, int whence) return -1L; } +int +do_binmode(PerlIO *fp, int iotype, int flag) +{ + if (flag != TRUE) + croak("panic: unsetting binmode"); /* Not implemented yet */ +#ifdef DOSISH +#ifdef atarist + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + return 1; + else + return 0; +#else + if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { +#if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + PerlIO_seek(fp,0L,0); + fp->flags |= _F_BIN; +#endif + return 1; + } + else + return 0; +#endif +#else +#if defined(USEMYBINMODE) + if (my_binmode(fp,iotype) != NULL) + return 1; + else + return 0; +#else + return 1; +#endif +#endif +} + #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) /* code courtesy of William Kucharski */ #define HAS_CHSIZE @@ -1033,9 +1080,14 @@ apply(I32 type, register SV **mark, register SV **sp) register I32 val; register I32 val2; register I32 tot = 0; + char *what; char *s; SV **oldmark = mark; +#define APPLY_TAINT_PROPER() \ + if (!(tainting && tainted)) {} else { goto taint_proper; } + + /* This is a first heuristic; it doesn't catch tainting magic. */ if (tainting) { while (++mark <= sp) { if (SvTAINTED(*mark)) { @@ -1047,25 +1099,33 @@ apply(I32 type, register SV **mark, register SV **sp) } switch (type) { case OP_CHMOD: - TAINT_PROPER("chmod"); + what = "chmod"; + APPLY_TAINT_PROPER(); if (++mark <= sp) { - tot = sp - mark; val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; while (++mark <= sp) { - if (PerlLIO_chmod(SvPVx(*mark, na),val)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (PerlLIO_chmod(name, val)) tot--; } } break; #ifdef HAS_CHOWN case OP_CHOWN: - TAINT_PROPER("chown"); + what = "chown"; + APPLY_TAINT_PROPER(); if (sp - mark > 2) { val = SvIVx(*++mark); val2 = SvIVx(*++mark); + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - if (PerlLIO_chown(SvPVx(*mark, na),val,val2)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (PerlLIO_chown(name, val, val2)) tot--; } } @@ -1073,11 +1133,11 @@ apply(I32 type, register SV **mark, register SV **sp) #endif #ifdef HAS_KILL case OP_KILL: - TAINT_PROPER("kill"); + what = "kill"; + APPLY_TAINT_PROPER(); if (mark == sp) break; s = SvPVx(*++mark, na); - tot = sp - mark; if (isUPPER(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; @@ -1086,6 +1146,8 @@ apply(I32 type, register SV **mark, register SV **sp) } else val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; #ifdef VMS /* kill() doesn't do process groups (job trees?) under VMS */ if (val < 0) val = -val; @@ -1098,6 +1160,7 @@ apply(I32 type, register SV **mark, register SV **sp) while (++mark <= sp) { I32 proc = SvIVx(*mark); register unsigned long int __vmssts; + APPLY_TAINT_PROPER(); if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { tot--; switch (__vmssts) { @@ -1120,6 +1183,7 @@ apply(I32 type, register SV **mark, register SV **sp) val = -val; while (++mark <= sp) { I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG if (PerlProc_killpg(proc,val)) /* BSD */ #else @@ -1130,17 +1194,21 @@ apply(I32 type, register SV **mark, register SV **sp) } else { while (++mark <= sp) { - if (PerlProc_kill(SvIVx(*mark),val)) + I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); + if (PerlProc_kill(proc, val)) tot--; } } break; #endif case OP_UNLINK: - TAINT_PROPER("unlink"); + what = "unlink"; + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { s = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); if (euid || unsafe) { if (UNLINK(s)) tot--; @@ -1161,7 +1229,8 @@ apply(I32 type, register SV **mark, register SV **sp) break; #ifdef HAS_UTIME case OP_UTIME: - TAINT_PROPER("utime"); + what = "utime"; + APPLY_TAINT_PROPER(); if (sp - mark > 2) { #if defined(I_UTIME) || defined(VMS) struct utimbuf utbuf; @@ -1180,9 +1249,12 @@ apply(I32 type, register SV **mark, register SV **sp) utbuf.actime = SvIVx(*++mark); /* time accessed */ utbuf.modtime = SvIVx(*++mark); /* time modified */ #endif + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - if (PerlLIO_utime(SvPVx(*mark, na),&utbuf)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (PerlLIO_utime(name, &utbuf)) tot--; } } @@ -1192,6 +1264,12 @@ apply(I32 type, register SV **mark, register SV **sp) #endif } return tot; + + taint_proper: + TAINT_PROPER(what); + return 0; /* this should never happen */ + +#undef APPLY_TAINT_PROPER } /* Do the permissions allow some operation? Assumes statcache already set. */ @@ -1305,6 +1383,21 @@ do_ipcget(I32 optype, SV **mark, SV **sp) return -1; /* should never happen */ } +#if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */ +/* Solaris manpage says that it uses (like linux) + int semctl (int semid, int semnum, int cmd, union semun arg) + but the system include files do not define union semun !!!! + Note: Linux/glibc *does* declare union semun in <sys/sem_buf.h> + but, unlike the older Linux libc and Solaris, it has an extra + struct seminfo * on the end. +*/ +union semun { + int val; + struct semid_ds *buf; + ushort *array; +}; +#endif + I32 do_ipcctl(I32 optype, SV **mark, SV **sp) { @@ -1313,8 +1406,25 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) char *a; I32 id, n, cmd, infosize, getinfo; I32 ret = -1; -#ifdef __linux__ /* XXX Need metaconfig test */ - union semun unsemds; +/* XXX REALLY need metaconfig test */ +/* linux and Solaris2 use: + int semctl (int semid, int semnum, int cmd, union semun arg) + instead of: + int semctl (int semid, int semnum, int cmd, struct semid_ds *arg); + Solaris and Linux (pre-glibc) use + union semun { + int val; + struct semid_ds *buf; + ushort *array; + }; + but Solaris doesn't declare it in a header file (we declared it + explicitly earlier). Linux/glibc declares a *different* union semun + so we just refer to "union semun" here. + +*/ +#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) +# define SEMCTL_SEMUN + union semun unsemds, semun; #endif id = SvIVx(*++mark); @@ -1345,16 +1455,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) else if (cmd == GETALL || cmd == SETALL) { struct semid_ds semds; -#ifdef __linux__ /* XXX Need metaconfig test */ -/* linux (and Solaris2?) uses : - int semctl (int semid, int semnum, int cmd, union semun arg) - union semun { - int val; - struct semid_ds *buf; - ushort *array; - }; -*/ - union semun semun; +#ifdef SEMCTL_SEMUN semun.buf = &semds; if (semctl(id, 0, IPC_STAT, semun) == -1) #else @@ -1405,7 +1506,8 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) #endif #ifdef HAS_SEM case OP_SEMCTL: -#ifdef __linux__ /* XXX Need metaconfig test */ +#ifdef SEMCTL_SEMUN + /* XXX Need metaconfig test */ unsemds.buf = (struct semid_ds *)a; ret = semctl(id, n, cmd, unsemds); #else @@ -106,7 +106,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) sv_upgrade(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { - if (*mark) { + if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } @@ -474,7 +474,7 @@ do_kv(ARGSproto) RETURN; if (gimme == G_SCALAR) { - I32 i; + IV i; dTARGET; if (op->op_flags & OPf_MOD) { /* lvalue */ @@ -483,7 +483,11 @@ do_kv(ARGSproto) sv_magic(TARG, Nullsv, 'k', Nullch, 0); } LvTYPE(TARG) = 'k'; - LvTARG(TARG) = (SV*)hv; + if (LvTARG(TARG) != (SV*)hv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(hv); + } PUSHs(TARG); RETURN; } @@ -363,7 +363,7 @@ dump_pm(PMOP *pm) } if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) { SV *tmpsv = newSVpv("", 0); - if (pm->op_pmflags & PMf_USED) + if (pm->op_pmdynflags & PMdf_USED) sv_catpv(tmpsv, ",USED"); if (pm->op_pmflags & PMf_ONCE) sv_catpv(tmpsv, ",ONCE"); @@ -383,6 +383,8 @@ dump_pm(PMOP *pm) sv_catpv(tmpsv, ",GLOBAL"); if (pm->op_pmflags & PMf_CONTINUE) sv_catpv(tmpsv, ",CONTINUE"); + if (pm->op_pmflags & PMf_TAINTMEM) + sv_catpv(tmpsv, ",TAINTMEM"); if (pm->op_pmflags & PMf_EVAL) sv_catpv(tmpsv, ",EVAL"); dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); diff --git a/emacs/ptags b/emacs/ptags index 8831988c92..d71d1b3f50 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -29,10 +29,13 @@ xsfiles="`find . -name '*.xs' -print | sort`" ## IEXT char * Isplitstr IINIT(" "); ## dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; ## PP(pp_const) +## PERLVARI(Grsfp, PerlIO *, Nullfp) +## PERLVAR(cvcache, HV *) set x -d -l c \ -r '/[dI]?EXT\(CONST\)?[ \t*]+\([a-zA-Z_0-9]+[ \t*]+\)*\([a-zA-Z_0-9]+\)[ \t]*\($\|;\|\[\|[ \t]I+NIT[ \t]*(\|\/\*\)/\3/' \ -r '/IEXT[ \t][^\/]*[ \t*]I\([a-zA-Z_][a-zA-Z_0-9]*\)[\[; \t]/\1/' \ + -r '/PERLVAR[a-zA-Z_0-9]*[ \t]*([ \t]*[GIT]?\([a-zA-Z_][a-zA-Z_0-9]*\)[ \t]*,/\1/' \ -r '/PP[ \t]*([ \t]*\([^ \t()]*\)[ \t]*)/\1/' shift @@ -141,6 +141,7 @@ #define div_amg Perl_div_amg #define div_ass_amg Perl_div_ass_amg #define do_aexec Perl_do_aexec +#define do_binmode Perl_do_binmode #define do_chomp Perl_do_chomp #define do_chop Perl_do_chop #define do_close Perl_do_close @@ -192,6 +193,7 @@ #define filter_add Perl_filter_add #define filter_del Perl_filter_del #define filter_read Perl_filter_read +#define find_script Perl_find_script #define find_threadsv Perl_find_threadsv #define fold Perl_fold #define fold_constants Perl_fold_constants @@ -290,11 +292,14 @@ #define magic_getarylen Perl_magic_getarylen #define magic_getdefelem Perl_magic_getdefelem #define magic_getglob Perl_magic_getglob +#define magic_getnkeys Perl_magic_getnkeys #define magic_getpack Perl_magic_getpack #define magic_getpos Perl_magic_getpos #define magic_getsig Perl_magic_getsig +#define magic_getsubstr Perl_magic_getsubstr #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar +#define magic_getvec Perl_magic_getvec #define magic_len Perl_magic_len #define magic_mutexfree Perl_magic_mutexfree #define magic_nextpack Perl_magic_nextpack diff --git a/embedvar.h b/embedvar.h index 7a7c80fd98..2e52562fb9 100644 --- a/embedvar.h +++ b/embedvar.h @@ -45,6 +45,7 @@ #define markstack (curinterp->Tmarkstack) #define markstack_max (curinterp->Tmarkstack_max) #define markstack_ptr (curinterp->Tmarkstack_ptr) +#define modcount (curinterp->Tmodcount) #define nrs (curinterp->Tnrs) #define ofs (curinterp->Tofs) #define ofslen (curinterp->Tofslen) @@ -113,14 +114,14 @@ #define doswitches (curinterp->Idoswitches) #define dowarn (curinterp->Idowarn) #define dumplvl (curinterp->Idumplvl) -#define e_fp (curinterp->Ie_fp) -#define e_tmpname (curinterp->Ie_tmpname) +#define e_script (curinterp->Ie_script) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) #define errgv (curinterp->Ierrgv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) -#define extralen (curinterp->Iextralen) +#define exitlist (curinterp->Iexitlist) +#define exitlistlen (curinterp->Iexitlistlen) #define fdpid (curinterp->Ifdpid) #define filemode (curinterp->Ifilemode) #define firstgv (curinterp->Ifirstgv) @@ -158,7 +159,7 @@ #define minus_l (curinterp->Iminus_l) #define minus_n (curinterp->Iminus_n) #define minus_p (curinterp->Iminus_p) -#define modcount (curinterp->Imodcount) +#define modglobal (curinterp->Imodglobal) #define multiline (curinterp->Imultiline) #define mystrk (curinterp->Imystrk) #define ofmt (curinterp->Iofmt) @@ -233,6 +234,7 @@ #define sv_count (curinterp->Isv_count) #define sv_objcount (curinterp->Isv_objcount) #define sv_root (curinterp->Isv_root) +#define sys_intern (curinterp->Isys_intern) #define tainting (curinterp->Itainting) #define threadnum (curinterp->Ithreadnum) #define thrsv (curinterp->Ithrsv) @@ -275,14 +277,14 @@ #define Idoswitches doswitches #define Idowarn dowarn #define Idumplvl dumplvl -#define Ie_fp e_fp -#define Ie_tmpname e_tmpname +#define Ie_script e_script #define Iendav endav #define Ienvgv envgv #define Ierrgv errgv #define Ieval_root eval_root #define Ieval_start eval_start -#define Iextralen extralen +#define Iexitlist exitlist +#define Iexitlistlen exitlistlen #define Ifdpid fdpid #define Ifilemode filemode #define Ifirstgv firstgv @@ -320,7 +322,7 @@ #define Iminus_l minus_l #define Iminus_n minus_n #define Iminus_p minus_p -#define Imodcount modcount +#define Imodglobal modglobal #define Imultiline multiline #define Imystrk mystrk #define Iofmt ofmt @@ -395,6 +397,7 @@ #define Isv_count sv_count #define Isv_objcount sv_objcount #define Isv_root sv_root +#define Isys_intern sys_intern #define Itainting tainting #define Ithreadnum threadnum #define Ithrsv thrsv @@ -428,6 +431,7 @@ #define Tmarkstack markstack #define Tmarkstack_max markstack_max #define Tmarkstack_ptr markstack_ptr +#define Tmodcount modcount #define Tnrs nrs #define Tofs ofs #define Tofslen ofslen @@ -498,14 +502,14 @@ #define doswitches Perl_doswitches #define dowarn Perl_dowarn #define dumplvl Perl_dumplvl -#define e_fp Perl_e_fp -#define e_tmpname Perl_e_tmpname +#define e_script Perl_e_script #define endav Perl_endav #define envgv Perl_envgv #define errgv Perl_errgv #define eval_root Perl_eval_root #define eval_start Perl_eval_start -#define extralen Perl_extralen +#define exitlist Perl_exitlist +#define exitlistlen Perl_exitlistlen #define fdpid Perl_fdpid #define filemode Perl_filemode #define firstgv Perl_firstgv @@ -543,7 +547,7 @@ #define minus_l Perl_minus_l #define minus_n Perl_minus_n #define minus_p Perl_minus_p -#define modcount Perl_modcount +#define modglobal Perl_modglobal #define multiline Perl_multiline #define mystrk Perl_mystrk #define ofmt Perl_ofmt @@ -618,6 +622,7 @@ #define sv_count Perl_sv_count #define sv_objcount Perl_sv_objcount #define sv_root Perl_sv_root +#define sys_intern Perl_sys_intern #define tainting Perl_tainting #define threadnum Perl_threadnum #define thrsv Perl_thrsv @@ -651,6 +656,7 @@ #define markstack Perl_markstack #define markstack_max Perl_markstack_max #define markstack_ptr Perl_markstack_ptr +#define modcount Perl_modcount #define nrs Perl_nrs #define ofs Perl_ofs #define ofslen Perl_ofslen @@ -714,6 +720,7 @@ #define markstack (thr->Tmarkstack) #define markstack_max (thr->Tmarkstack_max) #define markstack_ptr (thr->Tmarkstack_ptr) +#define modcount (thr->Tmodcount) #define nrs (thr->Tnrs) #define ofs (thr->Tofs) #define ofslen (thr->Tofslen) diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index fc7cf6dad2..4c877d9c5b 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -788,7 +788,7 @@ BEGIN { my $divide_op = infix_op("/"); my $modulo_op = infix_op("%"); my $lshift_op = infix_op("<<"); - my $rshift_op = infix_op("<<"); + my $rshift_op = infix_op(">>"); my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" }; my $scmp_op = prefix_op("sv_cmp"); my $seq_op = prefix_op("sv_eq"); @@ -1438,7 +1438,7 @@ sub compile { last OPTION; } elsif ($opt eq "o") { $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; + open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; } elsif ($opt eq "n") { $arg ||= shift @options; $module_name = $arg; diff --git a/ext/B/byteperl.c b/ext/B/byteperl.c index a42edfb8d5..323d63a809 100644 --- a/ext/B/byteperl.c +++ b/ext/B/byteperl.c @@ -37,7 +37,11 @@ main(int argc, char **argv, char **env) if (!do_undump) { my_perl = perl_alloc(); if (!my_perl) +#ifdef VMS + exit(vaxc$errno); +#else exit(1); +#endif perl_construct( my_perl ); } @@ -56,7 +60,11 @@ main(int argc, char **argv, char **env) #endif if (!fp) { perror(argv[1]); +#ifdef VMS + exit(vaxc$errno); +#else exit(1); +#endif } argv++; argc--; diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm.PL index 712d575e38..4c4155985d 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm.PL @@ -1,3 +1,19 @@ + +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\'/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "DynaLoader.pm" if -f "DynaLoader.pm"; +open OUT, ">DynaLoader.pm" or die $!; +print OUT <<'EOT'; + +# Generated from DynaLoader.pm.PL (resolved %Config::Config values) + package DynaLoader; # And Gandalf said: 'Many folk like to know beforehand what is to @@ -14,8 +30,6 @@ package DynaLoader; $VERSION = $VERSION = "1.03"; # avoid typo warning -require Config; - require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; @@ -43,10 +57,15 @@ $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; sub dl_load_flags { 0x00 } -# +# ($dl_dlext, $dlsrc) +# = @Config::Config{'dlext', 'dlsrc'}; +EOT + +print OUT " (\$dl_dlext, \$dlsrc) = (", + to_string($Config::Config{'dlext'}), ",", + to_string($Config::Config{'dlsrc'}), ")\n;" ; -($dl_dlext, $dlsrc) - = @Config::Config{'dlext', 'dlsrc'}; +print OUT <<'EOT'; # Some systems need special handling to expand file specifications # (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) @@ -65,7 +84,14 @@ $do_expand = $Is_VMS = $^O eq 'VMS'; # Initialise @dl_library_path with the 'standard' library path # for this platform as determined by Configure -push(@dl_library_path, split(' ',$Config::Config{'libpth'})); + +# push(@dl_library_path, split(' ', $Config::Config{'libpth'}); +EOT + +print OUT "push(\@dl_library_path, split(' ', ", + to_string($Config::Config{'libpth'}), "));\n"; + +print OUT <<'EOT'; # Add to @dl_library_path any extra directories we can gather from # environment variables. So far LD_LIBRARY_PATH is the only known @@ -205,8 +231,14 @@ sub dl_findfile { my (@args) = @_; my (@dirs, $dir); # which directories to search my (@found); # full paths to real files we have found - my $dl_ext= $Config::Config{'dlext'}; # suffix for perl extensions - my $dl_so = $Config::Config{'so'}; # suffix for shared libraries +EOT + +print OUT ' my $dl_ext= ' . to_string($Config::Config{'dlext'}) . + "; # \$Config::Config{'dlext'} suffix for perl extensions\n"; +print OUT ' my $dl_so = ' . to_string($Config::Config{'so'}) . + "; # \$Config::Config{'so'} suffix for shared libraries\n"; + +print OUT <<'EOT'; print STDERR "dl_findfile(@args)\n" if $dl_debug; @@ -350,7 +382,7 @@ etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). It must be stressed that the DynaLoader, by itself, is practically useless for accessing non-Perl libraries because it provides almost no Perl-to-C 'glue'. There is, for example, no mechanism for calling a C -library function or supplying arguments. A ExtUtils::DynaLib module +library function or supplying arguments. A C::DynaLib module is available from CPAN sites which performs that function for some common system types. @@ -691,3 +723,7 @@ Solaris global loading added by Nick Ing-Simmons with design/coding assistance from Tim Bunce, January 1996. =cut +EOT + +close OUT or die $!; + diff --git a/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL index 9323935880..2c86abfc41 100644 --- a/ext/DynaLoader/Makefile.PL +++ b/ext/DynaLoader/Makefile.PL @@ -7,11 +7,12 @@ WriteMakefile( MAN3PODS => ' ', # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'DynaLoader.pm', - clean => {FILES => 'DynaLoader.c DynaLoader.xs'}, + VERSION_FROM => 'DynaLoader.pm.PL', + PL_FILES => {'DynaLoader.pm.PL'=>'DynaLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, ); - sub MY::postamble { ' DynaLoader.xs: $(DLSRC) diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index 4e865edd3b..ea5040857d 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -29,6 +29,20 @@ #include <a.out.h> #include <ldfcn.h> +/* + * AIX 4.3 does remove some useful definitions from ldfcn.h. Define + * these here to compensate for that lossage. + */ +#ifndef BEGINNING +# define BEGINNING SEEK_SET +#endif +#ifndef FSEEK +# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p) +#endif +#ifndef FREAD +# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) +#endif + /* If using PerlIO, redefine these macros from <ldfcn.h> */ #ifdef USE_PERLIO #define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 51d464e6de..a82e0eac11 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -65,6 +65,9 @@ dl_load_file(filename, flags=0) * unresolved references in situations like this. */ /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ } + /* BIND_NOSTART removed from bind_type because it causes the shared library's */ + /* initialisers not to be run. This causes problems with all of the static objects */ + /* in the library. */ #ifdef DEBUGGING if (dl_debug) bind_type |= BIND_VERBOSE; @@ -74,14 +77,14 @@ dl_load_file(filename, flags=0) for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); - obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); + obj = shl_load(sym, bind_type, 0L); if (obj == NULL) { goto end; } } DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); - obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); + obj = shl_load(filename, bind_type, 0L); DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); end: diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 74de3dfc65..ab19670af7 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -76,9 +76,8 @@ $VERSION = "1.03"; ); sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, (@_ && (caller(0))[4]) ? $_[0] : 0); + (my $constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; @@ -90,7 +89,7 @@ sub AUTOLOAD { "; } } - eval "sub $AUTOLOAD { $val }"; + *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index 9c7ae066b7..09df4373fb 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -7,7 +7,7 @@ GDBM_File - Perl5 access to the gdbm library. =head1 SYNOPSIS use GDBM_File ; - tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640); + tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640; # Use the %hash array. untie %hash ; diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm index 1ba05ca916..4d4c81ce40 100644 --- a/ext/IO/IO.pm +++ b/ext/IO/IO.pm @@ -12,7 +12,7 @@ IO - load various IO modules =head1 DESCRIPTION -C<IO> provides a simple mechanism to load all of the IO modules at one go. +C<IO> provides a simple mechanism to load some of the IO modules at one go. Currently this includes: IO::Handle diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index aadb502f19..406f74d2ff 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -186,7 +186,7 @@ sub socketpair { my $fh1 = $class->new(); my $fh2 = $class->new(); - socketpair($fh1,$fh1,$domain,$type,$protocol) or + socketpair($fh1,$fh2,$domain,$type,$protocol) or return (); ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index 47b1f5aa3c..ed4fe2b36f 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -12,7 +12,7 @@ require DynaLoader; @ISA = qw(Tie::Hash DynaLoader); -$VERSION = "1.00"; +$VERSION = "1.01"; bootstrap NDBM_File $VERSION; @@ -27,6 +27,7 @@ NDBM_File - Tied access to ndbm files =head1 SYNOPSIS use NDBM_File; + use Fcntl; # for O_ constants tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index b71e8b43cf..717b97ff84 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -152,7 +152,7 @@ like gv2cv, i_ncmp and ftsvtx. =item an operator tag name (optag) Operator tags can be used to refer to groups (or sets) of operators. -Tag names always being with a colon. The Opcode module defines several +Tag names always begin with a colon. The Opcode module defines several optags and the user can define others using the define_optag function. =item a negated opname or optag @@ -569,7 +569,7 @@ Originally designed and implemented by Malcolm Beattie, mbeattie@sable.ox.ac.uk as part of Safe version 1. Split out from Safe module version 1, named opcode tags and other -changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. +changes added by Tim Bunce. =cut diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 3359d1742c..bc1dda9387 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'POSIX', - LIBS => ["-lm -lposix -lcposix"], + ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 33dc73d8f2..32010d62e0 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -827,7 +827,14 @@ sub fork { sub getcwd { usage "getcwd()" if @_ != 0; - chop($cwd = `pwd`); + if ($^O eq 'MSWin32') { + # this perhaps applies to everyone else also? + require Cwd; + $cwd = &Cwd::cwd; + } + else { + chop($cwd = `pwd`); + } $cwd; } diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index c781765a14..4726487b47 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1392,7 +1392,9 @@ Tests the SigSet object to see if it contains a specific signal. =item new Create a new Termios object. This object will be destroyed automatically -when it is no longer needed. +when it is no longer needed. A Termios object corresponds to the termios +C struct. new() mallocs a new one, getattr() fills it from a file descriptor, +and setattr() sets a file descriptor's parameters to match Termios' contents. $termios = POSIX::Termios->new; @@ -1474,13 +1476,13 @@ array so an index must be specified. Set the c_cflag field of a termios object. - $termios->setcflag( &POSIX::CLOCAL ); + $termios->setcflag( $c_cflag | &POSIX::CLOCAL ); =item setiflag Set the c_iflag field of a termios object. - $termios->setiflag( &POSIX::BRKINT ); + $termios->setiflag( $c_iflag | &POSIX::BRKINT ); =item setispeed @@ -1494,13 +1496,13 @@ Returns C<undef> on failure. Set the c_lflag field of a termios object. - $termios->setlflag( &POSIX::ECHO ); + $termios->setlflag( $c_lflag | &POSIX::ECHO ); =item setoflag Set the c_oflag field of a termios object. - $termios->setoflag( &POSIX::OPOST ); + $termios->setoflag( $c_oflag | &POSIX::OPOST ); =item setospeed diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 922438dca5..1dba9a61f8 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,3 +1,6 @@ +#ifdef WIN32 +#define _POSIX_ +#endif #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" @@ -40,7 +43,9 @@ #include <sys/stat.h> #include <sys/types.h> #include <time.h> +#ifdef I_UNISTD #include <unistd.h> /* see hints/sunos_4_1.sh */ +#endif #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -91,6 +96,28 @@ } # define times(t) vms_times(t) #else +#if defined (WIN32) +# undef mkfifo /* #defined in perl.h */ +# define mkfifo(a,b) not_here("mkfifo") +# define ttyname(a) not_here("ttyname") +# define sigset_t long +# define pid_t long +# ifdef __BORLANDC__ +# define tzname _tzname +# endif +# ifdef _MSC_VER +# define mode_t short +# endif +# define sigaction(a,b,c) not_here("sigaction") +# define sigpending(a) not_here("sigpending") +# define sigprocmask(a,b,c) not_here("sigprocmask") +# define sigsuspend(a) not_here("sigsuspend") +# define sigemptyset(a) not_here("sigemptyset") +# define sigaddset(a,b) not_here("sigaddset") +# define sigdelset(a,b) not_here("sigdelset") +# define sigfillset(a) not_here("sigfillset") +# define sigismember(a,b) not_here("sigismember") +#else # include <grp.h> # include <sys/times.h> # ifdef HAS_UNAME @@ -100,7 +127,8 @@ # ifdef I_UTIME # include <utime.h> # endif -#endif +#endif /* WIN32 */ +#endif /* __VMS */ typedef int SysRet; typedef long SysRetLong; @@ -227,11 +255,13 @@ unsigned long strtoul _((const char *, char **, int)); #define localeconv() not_here("localeconv") #endif +#ifndef WIN32 #ifdef HAS_TZNAME extern char *tzname[]; #else char *tzname[] = { "" , "" }; #endif +#endif /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) * fields for which we don't have Configure support yet: @@ -2259,55 +2289,55 @@ constant(char *name, int arg) case '_': if (strnEQ(name, "_PC_", 4)) { if (strEQ(name, "_PC_CHOWN_RESTRICTED")) -#ifdef _PC_CHOWN_RESTRICTED +#if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST return _PC_CHOWN_RESTRICTED; #else goto not_there; #endif if (strEQ(name, "_PC_LINK_MAX")) -#ifdef _PC_LINK_MAX +#if defined(_PC_LINK_MAX) || HINT_SC_EXIST return _PC_LINK_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_CANON")) -#ifdef _PC_MAX_CANON +#if defined(_PC_MAX_CANON) || HINT_SC_EXIST return _PC_MAX_CANON; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_INPUT")) -#ifdef _PC_MAX_INPUT +#if defined(_PC_MAX_INPUT) || HINT_SC_EXIST return _PC_MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "_PC_NAME_MAX")) -#ifdef _PC_NAME_MAX +#if defined(_PC_NAME_MAX) || HINT_SC_EXIST return _PC_NAME_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_NO_TRUNC")) -#ifdef _PC_NO_TRUNC +#if defined(_PC_NO_TRUNC) || HINT_SC_EXIST return _PC_NO_TRUNC; #else goto not_there; #endif if (strEQ(name, "_PC_PATH_MAX")) -#ifdef _PC_PATH_MAX +#if defined(_PC_PATH_MAX) || HINT_SC_EXIST return _PC_PATH_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_PIPE_BUF")) -#ifdef _PC_PIPE_BUF +#if defined(_PC_PIPE_BUF) || HINT_SC_EXIST return _PC_PIPE_BUF; #else goto not_there; #endif if (strEQ(name, "_PC_VDISABLE")) -#ifdef _PC_VDISABLE +#if defined(_PC_VDISABLE) || HINT_SC_EXIST return _PC_VDISABLE; #else goto not_there; @@ -2433,61 +2463,61 @@ constant(char *name, int arg) } if (strnEQ(name, "_SC_", 4)) { if (strEQ(name, "_SC_ARG_MAX")) -#ifdef _SC_ARG_MAX +#if defined(_SC_ARG_MAX) || HINT_SC_EXIST return _SC_ARG_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CHILD_MAX")) -#ifdef _SC_CHILD_MAX +#if defined(_SC_CHILD_MAX) || HINT_SC_EXIST return _SC_CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CLK_TCK")) -#ifdef _SC_CLK_TCK +#if defined(_SC_CLK_TCK) || HINT_SC_EXIST return _SC_CLK_TCK; #else goto not_there; #endif if (strEQ(name, "_SC_JOB_CONTROL")) -#ifdef _SC_JOB_CONTROL +#if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST return _SC_JOB_CONTROL; #else goto not_there; #endif if (strEQ(name, "_SC_NGROUPS_MAX")) -#ifdef _SC_NGROUPS_MAX +#if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST return _SC_NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_OPEN_MAX")) -#ifdef _SC_OPEN_MAX +#if defined(_SC_OPEN_MAX) || HINT_SC_EXIST return _SC_OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_SAVED_IDS")) -#ifdef _SC_SAVED_IDS +#if defined(_SC_SAVED_IDS) || HINT_SC_EXIST return _SC_SAVED_IDS; #else goto not_there; #endif if (strEQ(name, "_SC_STREAM_MAX")) -#ifdef _SC_STREAM_MAX +#if defined(_SC_STREAM_MAX) || HINT_SC_EXIST return _SC_STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_TZNAME_MAX")) -#ifdef _SC_TZNAME_MAX +#if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST return _SC_TZNAME_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_VERSION")) -#ifdef _SC_VERSION +#if defined(_SC_VERSION) || HINT_SC_EXIST return _SC_VERSION; #else goto not_there; @@ -3102,7 +3132,9 @@ sigaction(sig, action, oldaction = 0) POSIX::SigAction action POSIX::SigAction oldaction CODE: - +#ifdef WIN32 + RETVAL = not_here("sigaction"); +#else # This code is really grody because we're trying to make the signal # interface look beautiful, which is hard. @@ -3181,6 +3213,7 @@ sigaction(sig, action, oldaction = 0) sv_setiv(*svp, oact.sa_flags); } } +#endif OUTPUT: RETVAL diff --git a/ext/POSIX/hints/bsdos.pl b/ext/POSIX/hints/bsdos.pl new file mode 100644 index 0000000000..62732ac7b9 --- /dev/null +++ b/ext/POSIX/hints/bsdos.pl @@ -0,0 +1,3 @@ +# BSD platforms have extra fields in struct tm that need to be initialized. +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/POSIX/hints/freebsd.pl b/ext/POSIX/hints/freebsd.pl new file mode 100644 index 0000000000..62732ac7b9 --- /dev/null +++ b/ext/POSIX/hints/freebsd.pl @@ -0,0 +1,3 @@ +# BSD platforms have extra fields in struct tm that need to be initialized. +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/POSIX/hints/linux.pl b/ext/POSIX/hints/linux.pl index 7994f24023..f1d19814ae 100644 --- a/ext/POSIX/hints/linux.pl +++ b/ext/POSIX/hints/linux.pl @@ -2,4 +2,4 @@ # Thanks to Bart Schuller <schuller@Lunatech.com> # See Message-ID: <19971009002636.50729@tanglefoot> # XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DHINT_SC_EXIST' ; diff --git a/ext/POSIX/hints/netbsd.pl b/ext/POSIX/hints/netbsd.pl new file mode 100644 index 0000000000..62732ac7b9 --- /dev/null +++ b/ext/POSIX/hints/netbsd.pl @@ -0,0 +1,3 @@ +# BSD platforms have extra fields in struct tm that need to be initialized. +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/POSIX/hints/openbsd.pl b/ext/POSIX/hints/openbsd.pl new file mode 100644 index 0000000000..62732ac7b9 --- /dev/null +++ b/ext/POSIX/hints/openbsd.pl @@ -0,0 +1,3 @@ +# BSD platforms have extra fields in struct tm that need to be initialized. +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/SDBM_File/sdbm/Makefile.PL b/ext/SDBM_File/sdbm/Makefile.PL index 24074afb85..6003628247 100644 --- a/ext/SDBM_File/sdbm/Makefile.PL +++ b/ext/SDBM_File/sdbm/Makefile.PL @@ -37,5 +37,11 @@ config :: lint: lint -abchx $(LIBSRCS) + +# This is a workaround, the problem is that our old GNU make exports +# variables into the environment so $(MYEXTLIB) is set in here to this +# value which can not be built. +sdbm/libsdbm.a: + true '; } diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 823e704ed8..09b41d3fce 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -757,7 +757,10 @@ pack_sockaddr_un(pathname) STRLEN len; Zero( &sun_ad, sizeof sun_ad, char ); sun_ad.sun_family = AF_UNIX; - strncpy(sun_ad.sun_path, pathname, sizeof sun_ad.sun_path); + len = strlen(pathname); + if (len > sizeof(sun_ad.sun_path)) + len = sizeof(sun_ad.sun_path); + Copy( pathname, sun_ad.sun_path, len, char ); ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad)); #else ST(0) = (SV *) not_here("pack_sockaddr_un"); diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index cf7069c45d..c8bca0db71 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -32,7 +32,132 @@ Thread - multithreading =head1 DESCRIPTION -The C<Threads> module provides multithreading. +The C<Thread> module provides multithreading support for perl. + +=head1 FUNCTIONS + +=over 8 + +=item new \&start_sub + +=item new \&start_sub, LIST + +C<new> starts a new thread of execution in the referenced subroutine. The +optional list is passed as parameters to the subroutine. Execution +continues in both the subroutine and the code after the C<new> call. + +C<new Thread> returns a thread object representing the newly created +thread. + +=item lock VARIABLE + +C<lock> places a lock on a variable until the lock goes out of scope. If +the variable is locked by another thread, the C<lock> call will block until +it's available. C<lock> is recursive, so multiple calls to C<lock> are +safe--the variable will remain locked until the outermost lock on the +variable goes out of scope. + +Locks on variables only affect C<lock> calls--they do I<not> affect normal +access to a variable. (Locks on subs are different, and covered in a bit) +If you really, I<really> want locks to block access, then go ahead and tie +them to something and manage this yourself. This is done on purpose. While +managing access to variables is a good thing, perl doesn't force you out of +its living room... + +If a container object, such as a hash or array, is locked, all the elements +of that container are not locked. For example, if a thread does a C<lock +@a>, any other thread doing a C<lock($a[12])> won't block. + +You may also C<lock> a sub, using C<lock &sub>. Any calls to that sub from +another thread will block until the lock is released. This behaviour is not +equvalent to C<use attrs qw(locked)> in the sub. C<use attrs qw(locked)> +serializes access to a subroutine, but allows different threads +non-simultaneous access. C<lock &sub>, on the other hand, will not allow +I<any> other thread access for the duration of the lock. + +Finally, C<lock> will traverse up references exactly I<one> level. +C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not. + +=item async BLOCK; + +C<async> creates a thread to execute the block immediately following +it. This block is treated as an anonymous sub, and so must have a +semi-colon after the closing brace. Like C<new Thread>, C<async> returns a +thread object. + +=item Thread->self + +The C<Thread-E<gt>self> function returns a thread object that represents +the thread making the C<Thread-E<gt>self> call. + +=item Thread->list + +C<Thread-E<gt>list> returns a list of thread objects for all running and +finished but un-C<join>ed threads. + +=item cond_wait VARIABLE + +The C<cond_wait> function takes a B<locked> variable as a parameter, +unlocks the variable, and blocks until another thread does a C<cond_signal> +or C<cond_broadcast> for that same locked variable. The variable that +C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. +If there are multiple threads C<cond_wait>ing on the same variable, all but +one will reblock waiting to reaquire the lock on the variable. (So if +you're only using C<cond_wait> for synchronization, give up the lock as +soon as possible) + +=item cond_signal VARIABLE + +The C<cond_signal> function takes a locked variable as a parameter and +unblocks one thread that's C<cond_wait>ing on that variable. If more than +one thread is blocked in a C<cond_wait> on that variable, only one (and +which one is indeterminate) will be unblocked. + +If there are no threads blocked in a C<cond_wait> on the variable, the +signal is discarded. + +=item cond_broadcast VARIABLE + +The C<cond_broadcast> function works similarly to C<cond_wait>. +C<cond_broadcast>, though, will unblock B<all> the threads that are blocked +in a C<cond_wait> on the locked variable, rather than only one. + +=back + +=head1 METHODS + +=over 8 + +=item join + +C<join> waits for a thread to end and returns any values the thread exited +with. C<join> will block until the thread has ended, though it won't block +if the thread has already terminated. + +If the thread being C<join>ed C<die>d, the error it died with will be +returned at this time. If you don't want the thread performing the C<join> +to die as well, you should either wrap the C<join> in an C<eval> or use the +C<eval> thread method instead of C<join>. + +=item eval + +The C<eval> method wraps an C<eval> around a C<join>, and so waits for a +thread to exit, passing along any values the thread might have returned. +Errors, of course, get placed into C<$@>. + +=item tid + +The C<tid> method returns the tid of a thread. The tid is a monotonically +increasing integer assigned when a thread is created. The main thread of a +program will have a tid of zero, while subsequent threads will have tids +assigned starting with one. + +=head1 LIMITATIONS + +The sequence number used to assign tids is a simple integer, and no +checking is done to make sure the tid isn't currently in use. If a program +creates more than 2^32 - 1 threads in a single run, threads may be assigned +duplicate tids. This limitation may be lifted in a future version of Perl. =head1 SEE ALSO diff --git a/global.sym b/global.sym index 854b23087c..1ce7a688d3 100644 --- a/global.sym +++ b/global.sym @@ -24,6 +24,7 @@ dec_amg di div_amg div_ass_amg +do_binmode ds eq_amg exp_amg @@ -311,6 +312,7 @@ fetch_io filter_add filter_del filter_read +find_script find_threadsv fold_constants force_ident @@ -390,11 +392,14 @@ magic_get magic_getarylen magic_getdefelem magic_getglob +magic_getnkeys magic_getpack magic_getpos magic_getsig +magic_getsubstr magic_gettaint magic_getuvar +magic_getvec magic_len magic_mutexfree magic_nextpack @@ -86,10 +86,18 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) { dTHR; register GP *gp; + bool doproto = SvTYPE(gv) > SVt_NULL; + char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; sv_upgrade((SV*)gv, SVt_PVGV); - if (SvLEN(gv)) - Safefree(SvPVX(gv)); + if (SvLEN(gv)) { + if (proto) { + SvPVX(gv) = NULL; + SvLEN(gv) = 0; + SvPOK_off(gv); + } else + Safefree(SvPVX(gv)); + } Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); @@ -102,6 +110,27 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) GvNAMELEN(gv) = len; if (multi) GvMULTI_on(gv); + if (doproto) { /* Replicate part of newSUB here. */ + ENTER; + start_subparse(0,0); /* Create CV in compcv. */ + GvCV(gv) = compcv; + LEAVE; + + GvCVGEN(gv) = 0; + sub_generation++; + CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); + CvFILEGV(GvCV(gv)) = curcop->cop_filegv; + CvSTASH(GvCV(gv)) = curstash; +#ifdef USE_THREADS + CvOWNER(GvCV(gv)) = 0; + New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(GvCV(gv))); +#endif /* USE_THREADS */ + if (proto) { + sv_setpv((SV*)GvCV(gv), proto); + Safefree(proto); + } + } } STATIC void @@ -414,11 +443,11 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) len = namend - name; if (len > 0) { + char smallbuf[256]; char *tmpbuf; - char autobuf[64]; - if (len < sizeof(autobuf) - 2) - tmpbuf = autobuf; + if (len + 3 < sizeof smallbuf) + tmpbuf = smallbuf; else New(601, tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); @@ -433,7 +462,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) else GvMULTI_on(gv); } - if (tmpbuf != autobuf) + if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!gv || gv == (GV*)&sv_undef) return Nullgv; @@ -565,13 +594,15 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) gv_init_sv(gv, sv_type); } return gv; + } else if (add & GV_NOINIT) { + return gv; } /* Adding a new symbol */ - if (add & 4) + if (add & GV_ADDWARN) warn("Had to create %s unexpectedly", nambeg); - gv_init(gv, stash, name, len, add & 2); + gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); GvFLAGS(gv) |= add_gvflags; @@ -598,7 +629,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); /* NOTE: No support for tied ISA */ - if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); @@ -677,13 +709,28 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) #endif goto magicalize; + case '!': + if(len > 1) + break; + if(sv_type > SVt_PV) { + HV* stash = gv_stashpvn("Errno",5,FALSE); + if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + dSP; + PUTBACK; + perl_require_pv("Errno.pm"); + SPAGAIN; + stash = gv_stashpvn("Errno",5,FALSE); + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) + croak("Can't use %%! because Errno.pm is not avaliable"); + } + } + goto magicalize; case '#': case '*': if (dowarn && len == 1 && sv_type == SVt_PV) warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': - case '!': case '^': case '~': case '=': @@ -830,7 +877,7 @@ gv_check(HV *stash) } else if (isALPHA(*HeKEY(entry))) { gv = (GV*)HeVAL(entry); - if (GvMULTI(gv)) + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); @@ -130,3 +130,4 @@ HV *GvHVn(); #define GV_ADD 0x01 #define GV_ADDMULTI 0x02 #define GV_ADDWARN 0x04 +#define GV_NOINIT 0x10 /* 8 is used without a symbolic constant */ @@ -119,7 +119,7 @@ typedef unsigned short U16; #define U16_MAX PERL_USHORT_MAX #define U16_MIN PERL_USHORT_MIN -#if BYTEORDER > 0x4321 +#if LONGSIZE > 4 typedef int I32; typedef unsigned int U32; # define I32_MAX PERL_INT_MAX @@ -263,6 +263,9 @@ typedef U16 line_t; */ #ifndef lint + +#define NEWSV(x,len) newSV(len) + #ifndef LEAKTEST #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))) @@ -274,7 +277,6 @@ typedef U16 line_t; #define Renewc(v,n,t,c) \ (v = (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Safefree(d) safefree((Malloc_t)(d)) -#define NEWSV(x,len) newSV(len) #else /* LEAKTEST */ @@ -287,7 +289,6 @@ typedef U16 line_t; #define Renewc(v,n,t,c) \ (v = (c*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Safefree(d) safexfree((Malloc_t)(d)) -#define NEWSV(x,len) newSV(x,len) #define MAXXCOUNT 1400 #define MAXY_SIZE 80 diff --git a/hints/aix.sh b/hints/aix.sh index a29466e4f8..21dc888a83 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -66,7 +66,7 @@ case "$osvers" in lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc' ;; *) -lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' +lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' ;; esac diff --git a/hints/beos.sh b/hints/beos.sh new file mode 100644 index 0000000000..d8d4fd0515 --- /dev/null +++ b/hints/beos.sh @@ -0,0 +1,45 @@ +# BeOS hints file +# $Id: beos.sh,v 1.1 1998/02/16 03:51:45 dogcow Exp $ + +if [ ! -f ../beos/nm ]; then mwcc -w all -o ../beos/nm ../beos/nm.c; fi + +prefix="/boot/home/config" + +cpp="mwcc -e" + +libpth='/boot/beos/system/lib /boot/home/config/lib' +usrinc='/boot/develop/headers/posix' +locinc='/boot/develop/headers/ /boot/home/config/include' + +libc='/boot/beos/system/lib/libroot.so' +libs=' ' + +d_bcmp='define' +d_bcopy='define' +d_bzero='define' +d_index='define' +#d_htonl='define' # It exists, but much hackery would be required to support. +# a bunch of extra includes would have to be added, and it's only used at +# one place in the non-socket perl code. + +#these are all in libdll.a, which my version of nm doesn't know how to parse. +#if I can get it to both do that, and scan multiple library files, perhaps +#these can be gotten rid of. + +usemymalloc='n' +# Hopefully, Be's malloc knows better than perl's. + +d_link='undef' +dont_use_nlink='define' +# no posix (aka hard) links for us! + +d_syserrlst='undef' +# the array syserrlst[] is useless for the most part. +# large negative numbers really kind of suck in arrays. + +#d_socket='undef' +# Sockets really don't work with the current version of perl and the +# current BeOS sockets; I suspect that a new module a la GSAR's WIN32 port +# will be required. + +export PATH="$PATH:$PWD/beos" diff --git a/hints/bsdos.sh b/hints/bsdos.sh index c89a0a9833..0896e264ba 100644 --- a/hints/bsdos.sh +++ b/hints/bsdos.sh @@ -3,7 +3,7 @@ # 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 +# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0) # SYSV IPC tested Ok so I re-enabled. # # To override the compiler on the command line: @@ -33,6 +33,9 @@ libswanted="$*" 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 @@ -85,4 +88,22 @@ case "$osvers" in libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" ;; +4.0*) + # ELF dynamic link libraries starting in 4.0 (???) + useshrplib='true' + so='so' + dlext='so' + + case "$cc" in + '') cc='cc' # cc is gcc2 in 4.0 + cccdlflags="-fPIC" + ccdlflags=" " ;; + esac + + case "$ld" in + '') ld='ld' + lddlflags="-shared -x $lddlflags" ;; + esac + ;; esac + diff --git a/hints/dos_djgpp.sh b/hints/dos_djgpp.sh index ae6a7cab4c..73bae63dd2 100644 --- a/hints/dos_djgpp.sh +++ b/hints/dos_djgpp.sh @@ -7,7 +7,7 @@ archname='dos-djgpp' archobjs='djgpp.o' path_sep=\; -startsh="#!sh" +startsh="#! /bin/sh" cc='gcc' ld='gcc' @@ -23,8 +23,6 @@ firstmakefile='GNUmakefile' exe_ext='.exe' randbits=31 - -ln='cp' # no REAL ln on dos lns='cp' usenm='true' @@ -54,17 +52,6 @@ sitearch=$sitelib eagain='EAGAIN' rd_nodata='-1' -: set up the translation script tr - -cat > UU/tr <<EOSC -$startsh -case "\$1\$2" in -'[A-Z][a-z]') exec tr.exe '[:upper:]' '[:lower:]';; -'[a-z][A-Z]') exec tr.exe '[:lower:]' '[:upper:]';; -esac -exec tr.exe "\$@" -EOSC - if [ "X$usethreads" = "X$define" ]; then set `echo X "$libswanted "| sed -e 's/ c / gthreads c /'` shift diff --git a/hints/hpux.sh b/hints/hpux.sh index 9b272aef76..3e727d2d6f 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -43,8 +43,10 @@ # "ext.libs" file which is *probably* messing up the order. Often, # you can replace ext.libs with an empty file to fix the problem. # -# If you get a message about "too much defining", you might have to -# add the following to your ccflags: '-Wp,-H256000' +# If you get a message about "too much defining", as may happen +# in HPUX < 10, you might have to append a single entry to your +# ccflags: '-Wp,-H256000' +# NOTE: This is a single entry (-W takes the argument 'p,-H256000'). #-------------------------------------------------------------------- # Turn on the _HPUX_SOURCE flag to get many of the HP add-ons diff --git a/hints/irix_5.sh b/hints/irix_5.sh index e4d0347328..9d6e80246c 100644 --- a/hints/irix_5.sh +++ b/hints/irix_5.sh @@ -12,7 +12,7 @@ i_time='define' case "$cc" in *gcc*) ccflags="$ccflags -D_BSD_TYPES" ;; -*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" ;; +*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 4000" ;; esac lddlflags="-shared" diff --git a/hints/irix_6.sh b/hints/irix_6.sh index 9b54d2b842..40d42914de 100644 --- a/hints/irix_6.sh +++ b/hints/irix_6.sh @@ -169,7 +169,7 @@ EOF # libswanted. If that fails to be true in future, then this can be # changed to add pthread to the very end of libswanted. set `echo X "$libswanted "| sed -e 's/ c / pthread /'` - ld="cc" + ld="${cc:-cc}" shift libswanted="$*" usemymalloc='n' diff --git a/hints/machten.sh b/hints/machten.sh index 25b7062ea5..2ae79f17e3 100644 --- a/hints/machten.sh +++ b/hints/machten.sh @@ -13,6 +13,7 @@ # Martijn Koster <m.koster@webcrawler.com> # Richard Yeh <rcyeh@cco.caltech.edu> # +# Use of semctl() can crash system: disable -- Dominic Dunlop 980506 # Raise stack size further; slight tweaks to accomodate MT 4.1 # -- Dominic Dunlop <domo@computer.org> 980211 # Raise perl's stack size -- Dominic Dunlop <domo@tcp.ip.lu> 970922 @@ -53,6 +54,9 @@ alignbytes=8 # friends. Use setjmp and friends instead. expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='undef' +# semctl(.., .., IPC_STATUS, ..) hangs system: say we don't have semctl() +d_semctl='undef' + # Get rid of some extra libs which it takes Configure a tediously # long time never to find on MachTen set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \ @@ -75,11 +79,14 @@ dont_use_nlink=define cat <<'EOM' >&4 -Tests - io/fs test 4 and - op/stat test 3 -may fail since MachTen may not return a useful nlinks field to stat -on directories. +During Configure, you may see the message + +*** WHOA THERE!!! *** + The recommended value for $d_semctl on this machine was "undef"! + Keep the recommended value? [y] + +Select the default answer: semctl() is buggy, and perl should be built +without it. At the end of Configure, you will see a harmless message @@ -88,5 +95,12 @@ Hmm...You had some extra variables I don't know about...I'll try to keep 'em. Propagating recommended variable nmopts Read the File::Find documentation for more information about dont_use_nlink +Tests + io/fs test 4 and + op/stat test 3 +may fail since MachTen may not return a useful nlinks field to stat +on directories. + EOM -expr "$osvers" \< "4.1" && test -r ./broken-db.msg && . ./broken-db.msg +expr "$osvers" \< "4.1" >/dev/null && test -r ./broken-db.msg && \ + . ./broken-db.msg diff --git a/hints/netbsd.sh b/hints/netbsd.sh index 787f0f13bb..71d508448a 100644 --- a/hints/netbsd.sh +++ b/hints/netbsd.sh @@ -41,6 +41,14 @@ case "$osvers" in esac ;; esac +# netbsd 1.3 linker warns about setr[gu]id being deprecated. +# (setregid, setreuid, preferred?) +case "$osvers" in +1.3|1.3*) + d_setrgid="$undef" + d_setruid="$undef" + ;; +esac # netbsd had these but they don't really work as advertised, in the # versions listed below. if they are defined, then there isn't a @@ -64,3 +72,8 @@ case "$osvers" in d_setruid="$undef" ;; esac + +# vfork is ok on NetBSD. +case "$usevfork" in +'') usevfork=true ;; +esac diff --git a/hints/openbsd.sh b/hints/openbsd.sh new file mode 100644 index 0000000000..633ac35d54 --- /dev/null +++ b/hints/openbsd.sh @@ -0,0 +1,54 @@ +# hints/openbsd.sh +# +# hints file for OpenBSD; Todd Miller <millert@openbsd.org> +# Edited to allow Configure command-line overrides by +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# + +# OpenBSD has a better malloc than perl... +test "$usemymalloc" || usemymalloc='n' + +# Currently, vfork(2) is not a real win over fork(2) but this will +# change in a future release. +usevfork='true' + +# setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions +# in 4.4BSD. Configure will find these but they are just emulated +# and do not have the same semantics as in 4.3BSD. +d_setregid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' + +# +# Not all platforms support shared libs... +# +case `uname -m` in +alpha|mips|powerpc|vax) + d_dlopen=$undef + ;; +*) + d_dlopen=$define + d_dlerror=$define + # we use -fPIC here because -fpic is *NOT* enough for some of the + # extensions like Tk on some OpenBSD platforms (ie: sparc) + cccdlflags="-DPIC -fPIC $cccdlflags" + lddlflags="-Bforcearchive -Bshareable $lddlflags" + ;; +esac + +# OpenBSD doesn't need libcrypt but many folks keep a stub lib +# around for old NetBSD binaries. +libswanted=`echo $libswanted | sed 's/ crypt / /'` + +# Avoid telldir prototype conflict in pp_sys.c (OpenBSD uses const DIR *) +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +# Configure can't figure this out non-interactively +d_suidsafe='define' + +# cc is gcc so we can do better than -O +# Allow a command-line override, such as -Doptimize=-g +test "$optimize" || optimize='-O2' + +# end diff --git a/hints/os2.sh b/hints/os2.sh index 2293adf446..7a980bddce 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -23,6 +23,14 @@ if test -f $sh.exe; then sh=$sh.exe; fi startsh="#!$sh" cc='gcc' +# Make denser object files and DLL +case "X$optimize" in + X) + optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2 -s" + ld_dll_optimize="-s" + ;; +esac + # Get some standard things (indented to avoid putting in config.sh): oifs="$IFS" IFS=" ;" @@ -104,11 +112,11 @@ aout_obj_ext='.o' aout_lib_ext='.a' aout_ar='ar' aout_plibext='.a' -aout_lddlflags='-Zdll' +aout_lddlflags="-Zdll $ld_dll_optimize" if [ $emxcrtrev -ge 50 ]; then - aout_ldflags='-Zexe -Zsmall-conv' + aout_ldflags='-Zexe -Zsmall-conv -Zstack 32000' else - aout_ldflags='-Zexe' + aout_ldflags='-Zexe -Zstack 32000' fi # To get into config.sh: @@ -152,7 +160,7 @@ else else d_fork='undef' fi - lddlflags='-Zdll -Zomf -Zmt -Zcrtdll' + lddlflags="-Zdll -Zomf -Zmt -Zcrtdll $ld_dll_optimize" # Recursive regmatch may eat 2.5M of stack alone. ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000' if [ $emxcrtrev -ge 50 ]; then @@ -241,13 +249,6 @@ nm_opt='-p' d_getprior='define' d_setprior='define' -# Make denser object files and DLL -case "X$optimize" in - X) - optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2 -s" - ;; -esac - if [ "X$usethreads" = "X$define" ]; then ccflags="-Zmt $ccflags" cppflags="-Zmt $cppflags" # Do we really need to set this? diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index 047e4cf3b7..744b131fad 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -123,8 +123,10 @@ cat > UU/cc.cbu <<'EOSH' # If the C compiler is gcc: # - check the fixed-includes # - check as(1) and ld(1), they should not be GNU +# (GNU ad and ld 2.8.1 and later are reportedly ok, however.) # If the C compiler is not gcc: # - check as(1) and ld(1), they should not be GNU +# (GNU ad and ld 2.8.1 and later are reportedly ok, however.) # # Watch out in case they have not set $cc. @@ -236,9 +238,25 @@ if [ "X$usethreads" = "X$define" ]; then # as -lgdbm and such like. We assume here that -lc is present in # libswanted. If that fails to be true in future, then this can be # changed to add pthread to the very end of libswanted. - set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + # sched_yield is in -lposix4 + set `echo X "$libswanted "| sed -e 's/ c / posix4 pthread c /'` shift libswanted="$*" + + # On Solaris 2.6 x86 there is a bug with sigsetjmp() and siglongjmp() + # when linked with the threads library, such that whatever positive value + # you pass to siglongjmp(), sigsetjmp() returns 1. + # Thanks to Simon Parsons <S.Parsons@ftel.co.uk> for this report. + if test "`arch`" = i86pc -a "$osvers" = 2.6; then + d_sigaction=$undef + cat << 'EOM' >&2 + +You will see a *** WHOA THERE!!! *** message from Configure for +d_sigaction. Keep the recommended value. See hints/solaris_2.sh +for more information. + +EOM + fi fi # This is just a trick to include some useful notes. diff --git a/hints/svr4.sh b/hints/svr4.sh index 922736aa48..2939e4ec1f 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -1,15 +1,19 @@ # svr4 hints, System V Release 4.x -# Last modified 1995/01/28 by Tye McQueen, tye@metronet.com +# Last modified 1996/10/25 by Tye McQueen, tye@metronet.com +# Merged 1998/04/23 with perl5.004_04 distribution by +# Andy Dougherty <doughera@lafayette.edu> + # Use Configure -Dcc=gcc to use gcc. case "$cc" in '') cc='/bin/cc' test -f $cc || cc='/usr/ccs/bin/cc' ;; esac + # We include support for using libraries in /usr/ucblib, but the setting -# of libswanted excludes some libraries found there. You may want to -# prevent "ucb" from being removed from libswanted and see if perl will -# build on your system. +# of libswanted excludes some libraries found there. If you run into +# problems, you may have to remove "ucb" from libswanted. Just delete +# the comment '#' from the sed command below. ldflags='-L/usr/ccs/lib -L/usr/ucblib' ccflags='-I/usr/include -I/usr/ucbinclude' # Don't use problematic libraries: @@ -17,56 +21,103 @@ libswanted=`echo " $libswanted " | sed -e 's/ malloc / /'` # -e 's/ ucb / /'` # libmalloc.a - Probably using Perl's malloc() anyway. # libucb.a - Remove it if you have problems ld'ing. We include it because # it is needed for ODBM_File and NDBM_File extensions. + if [ -r /usr/ucblib/libucb.a ]; then # If using BSD-compat. library: - d_gconvert='undef' # Unusuable under UnixWare 1.1 [use gcvt() instead] + d_Gconvert='gcvt' # Try gcvt() before gconvert(). # Use the "native" counterparts, not the BSD emulation stuff: d_bcmp='undef' d_bcopy='undef' d_bzero='undef' d_safebcpy='undef' d_index='undef' d_killpg='undef' d_getprior='undef' d_setprior='undef' - d_setlinebuf='undef' d_setregid='undef' d_setreuid='undef' + d_setlinebuf='undef' + # d_setregid='undef' d_setreuid='undef' # ??? fi -d_suidsafe='define' # "./Configure -d" can't figure this out easilly -usevfork='false' -# Configure may fail to find lstat() since it's a static/inline -# function in <sys/stat.h> on Unisys U6000 SVR4, and possibly -# other SVR4 derivatives. -d_lstat=define +# UnixWare has /usr/lib/libc.so.1, /usr/lib/libc.so.1.1, and +# /usr/ccs/lib/libc.so. Configure chooses libc.so.1.1 while it +# appears that /usr/ccs/lib/libc.so contains more symbols: +# +# Try the following if you want to use nm-extraction. We'll just +# skip the nm-extraction phase, since searching for all the different +# library versions will be hard to keep up-to-date. +# +# if [ "" = "$libc" -a -f /usr/ccs/lib/libc.so -a \ +# -f /usr/lib/libc.so.1 -a -f /usr/lib/libc.so.1.1 ]; then +# if nm -h /usr/ccs/lib/libc.so | egrep '\<_?select$' >/dev/null; then +# if nm -h /usr/lib/libc.so.1 | egrep '\<_?select$'` >/dev/null || +# nm -h /usr/lib/libc.so.1.1 | egrep '\<_?select$'` >/dev/null; then +# : +# else +# libc=/usr/ccs/lib/libc.so +# fi +# fi +# fi +# +# Don't bother with nm. Just compile & link a small C program. +case "$usenm" in +'') usenm=false;; +esac + +# Broken C-Shell tests (Thanks to Tye McQueen): +# The OS-specific checks may be obsoleted by the this generic test. + sh_cnt=`sh -c 'echo /*' | wc -c` + csh_cnt=`csh -f -c 'glob /*' 2>/dev/null | wc -c` + csh_cnt=`expr 1 + $csh_cnt` +if [ "$sh_cnt" -ne "$csh_cnt" ]; then + echo "You're csh has a broken 'glob', disabling..." >&2 + d_csh='undef' +fi # UnixWare has a broken csh. The undocumented -X argument to uname is probably # a reasonable way of detecting UnixWare. Also in 2.1.1 the fields in -# FILE* got renamed! -uw_ver=`uname -v` -uw_isuw=`uname -X 2>&1 | grep Release` +# FILE* got renamed! Plus 1.1 can't cast large floats to 32-bit ints. +# Leave leading tabs so Configure doesn't propagate these variables + uw_ver=`uname -v` + uw_isuw=`uname -X 2>&1 | grep Release` +if [ "$uw_isuw" = "Release = 4.2" ]; then + case $uw_ver in + 1.1) + d_casti32='undef' + ;; + esac +fi if [ "$uw_isuw" = "Release = 4.2MP" ]; then case $uw_ver in 2.1) - d_csh='undef' - ;; + d_csh='undef' + ;; 2.1.*) - d_csh='undef' - stdio_cnt='((fp)->__cnt)' - d_stdio_cnt_lval='define' - stdio_ptr='((fp)->__ptr)' - d_stdio_ptr_lval='define' - ;; + d_csh='undef' + stdio_cnt='((fp)->__cnt)' + d_stdio_cnt_lval='define' + stdio_ptr='((fp)->__ptr)' + d_stdio_ptr_lval='define' + ;; esac fi # DDE SMES Supermax Enterprise Server case "`uname -sm`" in "UNIX_SV SMES") - if test "$cc" = '/bin/cc' -o "$gccversion" = "" - then - # for cc we need -K PIC (not -K pic) - cccdlflags="$cccdlflags -K PIC" - fi - # the *grent functions are in libgen. - libswanted="$libswanted gen" - # csh is broken (also) in SMES - d_csh='undef' + # the *grent functions are in libgen. + libswanted="$libswanted gen" + # csh is broken (also) in SMES + # This may already be detected by the generic test above. + d_csh='undef' + case "$cc" in + *gcc*) ;; + *) # for cc we need -K PIC (not -K pic) + cccdlflags="$cccdlflags -K PIC" ;; + esac + ;; esac +# Configure may fail to find lstat() since it's a static/inline function +# in <sys/stat.h> on Unisys U6000 SVR4, UnixWare 2.x, and possibly other +# SVR4 derivatives. (Though UnixWare has it in /usr/ccs/lib/libc.so.) +d_lstat=define + +d_suidsafe='define' # "./Configure -d" can't figure this out easilly + cat <<'EOM' >&4 If you wish to use dynamic linking, you must use diff --git a/hints/unicos.sh b/hints/unicos.sh index 7579eed65a..111cbb9fc7 100644 --- a/hints/unicos.sh +++ b/hints/unicos.sh @@ -1,10 +1,13 @@ case `uname -r` in 6.1*) shellflags="-m+65536" ;; esac -optimize="-O1" +case "$optimize" in +'') optimize="-O1" ;; +esac d_setregid='undef' d_setreuid='undef' case "$usemymalloc" in -'') usemymalloc='y' ;; +'') usemymalloc='y' + ccflags="$ccflags -DNO_RCHECK" + ;; esac - diff --git a/hints/unicosmk.sh b/hints/unicosmk.sh index 90784b5b39..f0b63cb0eb 100644 --- a/hints/unicosmk.sh +++ b/hints/unicosmk.sh @@ -1,3 +1,10 @@ -optimize="-O1" +case "$optimize" in +'') optimize="-O1" ;; +esac d_setregid='undef' d_setreuid='undef' +case "$usemymalloc" in +'') usemymalloc='y' + ccflags="$ccflags -DNO_RCHECK" + ;; +esac @@ -968,7 +968,7 @@ hv_iterinit(HV *hv) } xhv->xhv_riter = -1; xhv->xhv_eiter = Null(HE*); - return xhv->xhv_fill; /* should be xhv->xhv_keys? May change later */ + return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */ } HE * @@ -22,11 +22,12 @@ struct hek { char hek_key[1]; }; +/* This structure must match the beginning of struct xpvmg in sv.h. */ struct xpvhv { char * xhv_array; /* pointer to malloced string */ STRLEN xhv_fill; /* how full xhv_array currently is */ STRLEN xhv_max; /* subscript of last element of xhv_array */ - I32 xhv_keys; /* how many elements in the array */ + IV xhv_keys; /* how many elements in the array */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ diff --git a/installperl b/installperl index 07be34188f..3ec0f50063 100755 --- a/installperl +++ b/installperl @@ -26,6 +26,9 @@ sub mkpath { $mainperldir = "/usr/bin"; $exe_ext = $Config{exe_ext}; +# Allow ``make install PERLNAME=something_besides_perl'': +$perl = defined($ENV{PERLNAME}) ? $ENV{PERLNAME} : 'perl'; + while (@ARGV) { $nonono = 1 if $ARGV[0] eq '-n'; $versiononly = 1 if $ARGV[0] eq '-v'; @@ -35,21 +38,29 @@ while (@ARGV) { umask 022 unless $Is_VMS; @scripts = qw( utils/c2ph utils/h2ph utils/h2xs - utils/perlbug utils/perldoc utils/pl2pm utils/splain - x2p/s2p x2p/find2perl + utils/perlbug utils/perldoc utils/pl2pm utils/splain utils/perlcc + x2p/s2p x2p/find2perl pod/pod2man pod/pod2html pod/pod2latex pod/pod2text); if ($Is_VMS) { @scripts = map { "$_.Com" } @scripts; } @pods = (<pod/*.pod>); -%archpms = (Config => 1, FileHandle => 1, overload => 1); +%archpms = ( + Config => 1, FileHandle => 1, overload => 1, + 'File/Basename' => 1, # uses m//t +); if ($^O eq 'dos') { push(@scripts,'djgpp/fixpmain'); $archpms{config} = $archpms{filehand} = 1; } +if ((-e "testcompile") && (defined($ENV{'COMPILE'}))) +{ + push(@scripts, map("$_.exe", @scripts)); +} + find(sub { if ("$File::Find::dir/$_" =~ m{^ext/[^/]+/(.*)\.pm$}) { (my $pm = $1) =~ s{^lib/}{}; @@ -126,26 +137,26 @@ $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist"); # First we install the version-numbered executables. if ($Is_VMS) { - safe_unlink("$installbin/perl$exe_ext"); - copy("perl$exe_ext", "$installbin/perl$exe_ext"); - chmod(0755, "$installbin/perl$exe_ext"); - safe_unlink("$installbin/perlshr$exe_ext"); - copy("perlshr$exe_ext", "$installbin/perlshr$exe_ext"); - chmod(0755, "$installbin/perlshr$exe_ext"); + safe_unlink("$installbin/$perl$exe_ext"); + copy("perl$exe_ext", "$installbin/$perl$exe_ext"); + chmod(0755, "$installbin/$perl$exe_ext"); + safe_unlink("$installbin/${perl}shr$exe_ext"); + copy("perlshr$exe_ext", "$installbin/${perl}shr$exe_ext"); + chmod(0755, "$installbin/${perl}shr$exe_ext"); } elsif ($^O ne 'dos') { - safe_unlink("$installbin/perl$ver$exe_ext"); - copy("perl$exe_ext", "$installbin/perl$ver$exe_ext"); - chmod(0755, "$installbin/perl$ver$exe_ext"); + safe_unlink("$installbin/$perl$ver$exe_ext"); + copy("perl$exe_ext", "$installbin/$perl$ver$exe_ext"); + chmod(0755, "$installbin/$perl$ver$exe_ext"); } else { - safe_unlink("$installbin/perl.exe"); - copy("perl.exe", "$installbin/perl.exe"); + safe_unlink("$installbin/$perl.exe"); + copy("perl.exe", "$installbin/$perl.exe"); } -safe_unlink("$installbin/sperl$ver$exe_ext"); +safe_unlink("$installbin/s$perl$ver$exe_ext"); if ($d_dosuid) { - copy("suidperl$exe_ext", "$installbin/sperl$ver$exe_ext"); - chmod(04711, "$installbin/sperl$ver$exe_ext"); + copy("suidperl$exe_ext", "$installbin/s$perl$ver$exe_ext"); + chmod(04711, "$installbin/s$perl$ver$exe_ext"); } # Install library files. @@ -197,9 +208,9 @@ foreach $file (@corefiles) { # Make links to ordinary names if installbin directory isn't current directory. if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS) { - safe_unlink("$installbin/perl$exe_ext", "$installbin/suidperl$exe_ext"); - link("$installbin/perl$ver$exe_ext", "$installbin/perl$exe_ext"); - link("$installbin/sperl$ver$exe_ext", "$installbin/suidperl$exe_ext") + safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext"); + link("$installbin/$perl$ver$exe_ext", "$installbin/$perl$exe_ext"); + link("$installbin/s$perl$ver$exe_ext", "$installbin/suid$perl$exe_ext") if $d_dosuid; } @@ -209,9 +220,9 @@ $mainperl_is_instperl = 0; if (!$versiononly && !$nonono && $^O ne 'MSWin32' && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { - local($usrbinperl) = "$mainperldir/perl$exe_ext"; - local($instperl) = "$installbin/perl$exe_ext"; - local($expinstperl) = "$binexp/perl$exe_ext"; + local($usrbinperl) = "$mainperldir/$perl$exe_ext"; + local($instperl) = "$installbin/$perl$exe_ext"; + local($expinstperl) = "$binexp/$perl$exe_ext"; # First make sure $usrbinperl is not already the same as the perl we # just installed. @@ -341,11 +352,11 @@ if (!$versiononly) { # to $mainperldir (like SunOS) next if samepath($_, $binexp); next if ($mainperl_is_instperl && samepath($_, $mainperldir)); - push(@otherperls, "$_/perl$exe_ext") - if (-x "$_/perl$exe_ext" && ! -d "$_/perl$exe_ext"); + push(@otherperls, "$_/$perl$exe_ext") + if (-x "$_/$perl$exe_ext" && ! -d "$_/$perl$exe_ext"); } if (@otherperls) { - print STDERR "\nWarning: perl appears in your path in the following " . + print STDERR "\nWarning: $perl appears in your path in the following " . "locations beyond where\nwe just installed it:\n"; for (@otherperls) { print STDERR " ", $_, "\n"; diff --git a/interp.sym b/interp.sym index 62e603a1a8..de164d559a 100644 --- a/interp.sym +++ b/interp.sym @@ -42,14 +42,14 @@ doextract doswitches dowarn dumplvl -e_fp -e_tmpname +e_script endav envgv errgv eval_root eval_start -extralen +exitlist +exitlistlen fdpid filemode firstgv @@ -65,6 +65,7 @@ in_eval incgv initav inplace +sys_intern last_in_gv lastfd lastgotoprobe @@ -92,7 +93,7 @@ minus_c minus_l minus_n minus_p -modcount +modglobal multiline mystrk nrs diff --git a/intrpvar.h b/intrpvar.h index ad9bb81bf3..03435ac07b 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -31,8 +31,7 @@ PERLVAR(Isawstudy, bool) /* do fbm_instr on all strings */ PERLVAR(Isawvec, bool) PERLVAR(Iunsafe, bool) PERLVAR(Iinplace, char *) -PERLVAR(Ie_tmpname, char *) -PERLVAR(Ie_fp, PerlIO *) +PERLVAR(Ie_script, SV *) PERLVAR(Iperldb, U32) /* This value may be raised by extensions for testing purposes */ @@ -152,6 +151,15 @@ PERLVAR(Iors, char *) /* $\ */ PERLVAR(Iorslen, STRLEN) PERLVAR(Iofmt, char *) /* $# */ +/* interpreter atexit processing */ +PERLVARI(Iexitlist, PerlExitListEntry *, NULL) /* list of exit functions */ +PERLVARI(Iexitlistlen, I32, 0) /* length of same */ +PERLVAR(Imodglobal, HV *) /* per-interp module data */ + +#ifdef HAVE_INTERP_INTERN +PERLVAR(Isys_intern, struct interp_intern) /* platform internals */ +#endif + /* more statics moved here */ PERLVAR(Imh, HE) /* from hv.c */ PERLVAR(Imodcount, I32) /* from op.c */ diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index df54f15d36..471499adcb 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,12 +1,17 @@ package AutoSplit; -require 5.000; -require Exporter; - -use Config; -use Carp; +use Exporter (); +use Config qw(%Config); +use Carp qw(carp); +use File::Basename (); use File::Path qw(mkpath); +use strict; +use vars qw( + $VERSION @ISA @EXPORT @EXPORT_OK + $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime + ); +$VERSION = "1.0302"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -17,13 +22,9 @@ AutoSplit - split a package for autoloading =head1 SYNOPSIS - perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... - - use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime); - -for perl versions 5.002 and later: + autosplit($file, $dir, $keep, $check, $modtime); - perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ... + autosplit_lib_modules(@modules); =head1 DESCRIPTION @@ -37,16 +38,36 @@ class hierarchy, and creates the file F<autosplit.ix>. This file acts as both forward declaration of all package routines, and as timestamp for the last update of the hierarchy. -The remaining three arguments to C<autosplit> govern other options to the -autosplitter. If the third argument, I<$keep>, is false, then any pre-existing -C<*.al> files in the autoload directory are removed if they are no longer -part of the module (obsoleted functions). The fourth argument, I<$check>, -instructs C<autosplit> to check the module currently being split to ensure -that it does include a C<use> specification for the AutoLoader module, and -skips the module if AutoLoader is not detected. Lastly, the I<$modtime> -argument specifies that C<autosplit> is to check the modification time of the -module against that of the C<autosplit.ix> file, and only split the module -if it is newer. +The remaining three arguments to C<autosplit> govern other options to +the autosplitter. + +=over 2 + +=item $keep + +If the third argument, I<$keep>, is false, then any +pre-existing C<*.al> files in the autoload directory are removed if +they are no longer part of the module (obsoleted functions). +$keep defaults to 0. + +=item $check + +The +fourth argument, I<$check>, instructs C<autosplit> to check the module +currently being split to ensure that it does include a C<use> +specification for the AutoLoader module, and skips the module if +AutoLoader is not detected. +$check defaults to 1. + +=item $modtime + +Lastly, the I<$modtime> argument specifies +that C<autosplit> is to check the modification time of the module +against that of the C<autosplit.ix> file, and only split the module if +it is newer. +$modtime defaults to 1. + +=back Typical use of AutoSplit in the perl MakeMaker utility is via the command-line with: @@ -65,33 +86,49 @@ B<lib> relative to the current directory. Each file is sent to the autosplitter one at a time, to be split into the directory B<lib/auto>. In both usages of the autosplitter, only subroutines defined following the -perl special marker I<__END__> are split out into separate files. Some +perl I<__END__> token are split out into separate files. Some routines may be placed prior to this marker to force their immediate loading and parsing. -=head1 CAVEATS +=head2 Multiple packages + +As of version 1.01 of the AutoSplit module it is possible to have +multiple packages within a single file. Both of the following cases +are supported: + + package NAME; + __END__ + sub AAA { ... } + package NAME::option1; + sub BBB { ... } + package NAME::option2; + sub BBB { ... } -Currently, C<AutoSplit> cannot handle multiple package specifications -within one file. + package NAME; + __END__ + sub AAA { ... } + sub NAME::option1::BBB { ... } + sub NAME::option2::BBB { ... } =head1 DIAGNOSTICS -C<AutoSplit> will inform the user if it is necessary to create the top-level -directory specified in the invocation. It is preferred that the script or -installation process that invokes C<AutoSplit> have created the full directory -path ahead of time. This warning may indicate that the module is being split -into an incorrect path. +C<AutoSplit> will inform the user if it is necessary to create the +top-level directory specified in the invocation. It is preferred that +the script or installation process that invokes C<AutoSplit> have +created the full directory path ahead of time. This warning may +indicate that the module is being split into an incorrect path. -C<AutoSplit> will warn the user of all subroutines whose name causes potential -file naming conflicts on machines with drastically limited (8 characters or -less) file name length. Since the subroutine name is used as the file name, -these warnings can aid in portability to such systems. +C<AutoSplit> will warn the user of all subroutines whose name causes +potential file naming conflicts on machines with drastically limited +(8 characters or less) file name length. Since the subroutine name is +used as the file name, these warnings can aid in portability to such +systems. -Warnings are issued and the file skipped if C<AutoSplit> cannot locate either -the I<__END__> marker or a "package Name;"-style specification. +Warnings are issued and the file skipped if C<AutoSplit> cannot locate +either the I<__END__> marker or a "package Name;"-style specification. -C<AutoSplit> will also emit general diagnostics for inability to create -directories or files. +C<AutoSplit> will also emit general diagnostics for inability to +create directories or files. =cut @@ -102,21 +139,21 @@ $Keep = 0; $CheckForAutoloader = 1; $CheckModTime = 1; -$IndexFile = "autosplit.ix"; # file also serves as timestamp -$maxflen = 255; +my $IndexFile = "autosplit.ix"; # file also serves as timestamp +my $maxflen = 255; $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; if (defined (&Dos::UseLFN)) { $maxflen = Dos::UseLFN() ? 255 : 11; } -$Is_VMS = ($^O eq 'VMS'); +my $Is_VMS = ($^O eq 'VMS'); sub autosplit{ - my($file, $autodir, $k, $ckal, $ckmt) = @_; + my($file, $autodir, $keep, $ckal, $ckmt) = @_; # $file - the perl source file to be split (after __END__) # $autodir - the ".../auto" dir below which to write split subs # Handle optional flags: - $keep = $Keep unless defined $k; + $keep = $Keep unless defined $keep; $ckal = $CheckForAutoloader unless defined $ckal; $ckmt = $CheckModTime unless defined $ckmt; autosplit_file($file, $autodir, $keep, $ckal, $ckmt); @@ -139,7 +176,8 @@ sub autosplit_lib_modules{ $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); + autosplit_file("lib/$_", "lib/auto", + $Keep, $CheckForAutoloader, $CheckModTime); } 0; } @@ -147,60 +185,64 @@ sub autosplit_lib_modules{ # private functions -sub autosplit_file{ - my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; - my(@names); +sub autosplit_file { + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) + = @_; + my(@outfiles); local($_); + local($/) = "\n"; # where to write output files - $autodir = "lib/auto" unless $autodir; + $autodir ||= "lib/auto"; if ($Is_VMS) { - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||; $filename = VMS::Filespec::unixify($filename); # may have dirs } unless (-d $autodir){ mkpath($autodir,0,0755); - # We should never need to create the auto dir here. installperl - # (or similar) should have done it. Expecting it to exist is a valuable - # sanity check against autosplitting into some random directory by mistake. - print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n"; + # We should never need to create the auto dir + # here. installperl (or similar) should have done + # it. Expecting it to exist is a valuable sanity check against + # autosplitting into some random directory by mistake. + print "Warning: AutoSplit had to create top-level " . + "$autodir unexpectedly.\n"; } # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm$/); - open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; my($pm_mod_time) = (stat($filename))[9]; my($autoloader_seen) = 0; my($in_pod) = 0; + my($def_package,$last_package,$this_package,$fnr); while (<IN>) { # Skip pod text. + $fnr++; $in_pod = 1 if /^=/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # record last package name seen - $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; last if /^__END__/; } if ($check_for_autoloader && !$autoloader_seen){ - print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2); - return 0 + print "AutoSplit skipped $filename: no AutoLoader used\n" + if ($Verbose>=2); + return 0; } $_ or die "Can't find __END__ in $filename\n"; - $package or die "Can't find 'package Name;' in $filename\n"; + $def_package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; - if ($^O eq 'MSWin32') { - $modpname =~ s#::#\\#g; - } else { - $modpname =~ s#::#/#g; - } + my($modpname) = _modpname($def_package); - die "Package $package ($modpname.pm) does not match filename $filename" + # this _has_ to match so we have a reasonable timestamp file + die "Package $def_package ($modpname.pm) does not ". + "match filename $filename" unless ($filename =~ m/\Q$modpname.pm\E$/ or ($^O eq 'dos') or ($^O eq 'MSWin32') or $Is_VMS && $filename =~ m/$modpname.pm/i); @@ -210,14 +252,13 @@ sub autosplit_file{ if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ - print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + print "AutoSplit skipped ($al_idx_file newer than $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } - my($from) = ($Verbose>=2) ? "$filename => " : ""; - print "AutoSplitting $package ($from$autodir/$modpname)\n" + print "AutoSplitting $filename ($autodir/$modpname)\n" if $Verbose; unless (-d "$autodir/$modpname"){ @@ -231,69 +272,71 @@ sub autosplit_file{ # This is a problem because some systems silently truncate the file # names while others treat long file names as an error. - # We do not yet deal with multiple packages within one file. - # Ideally both of these styles should work. - # - # package NAME; - # __END__ - # sub AAA { ... } - # package NAME::option1; - # sub BBB { ... } - # package NAME::option2; - # sub BBB { ... } - # - # package NAME; - # __END__ - # sub AAA { ... } - # sub NAME::option1::BBB { ... } - # sub NAME::option2::BBB { ... } - # - # For now both of these produce warnings. - my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames - open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning - my(@subnames, %proto); + my(@subnames, $subname, %proto, %package); my @cache = (); my $caching = 1; + $last_package = ''; while (<IN>) { - next if /^=\w/ .. /^=cut/; - if (/^package ([\w:]+)\s*;/) { - warn "package $1; in AutoSplit section ignored. Not currently supported."; + $fnr++; + $in_pod = 1 if /^=/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + # the following (tempting) old coding gives big troubles if a + # cut is forgotten at EOF: + # next if /^=\w/ .. /^=cut/; + if (/^package\s+([\w:]+)\s*;/) { + $this_package = $def_package = $1; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { - print OUT "1;\n"; - my $subname = $1; - $proto{$1} = $2 || ''; - if ($subname =~ m/::/){ - warn "subs with package names not currently supported in AutoSplit section"; + print OUT "# end of $last_package\::$subname\n1;\n" + if $last_package; + $subname = $1; + my $proto = $2 || ''; + if ($subname =~ s/(.*):://){ + $this_package = $1; + } else { + $this_package = $def_package; } - push(@subnames, $subname); + my $fq_subname = "$this_package\::$subname"; + $package{$fq_subname} = $this_package; + $proto{$fq_subname} = $proto; + push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + $modpname = _modpname($this_package); + mkpath("$autodir/$modpname",0,0777); my($lpath) = "$autodir/$modpname/$lname.al"; my($spath) = "$autodir/$modpname/$sname.al"; - unless(open(OUT, ">$lpath")){ - open(OUT, ">$spath") or die "Can't create $spath: $!\n"; - push(@names, $Is83 ? lc $sname : $sname); - print " writing $spath (with truncated name)\n" if ($Verbose>=1); - }else{ - push(@names, $Is83 ? lc substr ($lname,0,8) : $lname); + my $path; + if (!$Is83 and open(OUT, ">$lpath")){ + $path=$lpath; print " writing $lpath\n" if ($Verbose>=2); + } else { + open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + $path=$spath; + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); } - print OUT "# NOTE: Derived from $filename. ", - "Changes made here will be lost.\n"; - print OUT "package $package;\n\n"; + push(@outfiles, $path); + print OUT <<EOT; +# NOTE: Derived from $filename. +# Changes made here will be lost when autosplit again. +# See AutoSplit.pm. +package $this_package; + +#line $fnr "$filename (autosplit into $path)" +EOT print OUT @cache; @cache = (); $caching = 0; } if($caching) { push(@cache, $_) if @cache || /\S/; - } - else { + } else { print OUT $_; } - if(/^}/) { + if(/^\}/) { if($caching) { print OUT @cache; @cache = (); @@ -301,70 +344,118 @@ sub autosplit_file{ print OUT "\n"; $caching = 1; } + $last_package = $this_package if defined $this_package; } - print OUT @cache,"1;\n"; + print OUT @cache,"1;\n# end of $last_package\::$subname\n"; close(OUT); close(IN); - + if (!$keep){ # don't keep any obsolete *.al files in the directory - my(%names); - @names{@names} = @names; - opendir(OUTDIR,"$autodir/$modpname"); - foreach(sort readdir(OUTDIR)){ - next unless /\.al$/; - my($subname) = m/(.*)\.al$/; - next if $names{substr($subname,0,$maxflen-3)}; - next if ($Is83 && $names{lc substr($subname,0,8)}); - my($file) = "$autodir/$modpname/$_"; - print " deleting $file\n" if ($Verbose>=2); - my($deleted,$thistime); # catch all versions on VMS - do { $deleted += ($thistime = unlink $file) } while ($thistime); - carp "Unable to delete $file: $!" unless $deleted; + my(%outfiles); + # @outfiles{@outfiles} = @outfiles; + # perl downcases all filenames on VMS (which upcases all filenames) so + # we'd better downcase the sub name list too, or subs with upper case + # letters in them will get their .al files deleted right after they're + # created. (The mixed case sub name wonn't match the all-lowercase + # filename, and so be cleaned up as a scrap file) + if ($Is_VMS or $Is83) { + %outfiles = map {lc($_) => lc($_) } @outfiles; + } else { + @outfiles{@outfiles} = @outfiles; + } + my(%outdirs,@outdirs); + for (@outfiles) { + $outdirs{File::Basename::dirname($_)}||=1; + } + for my $dir (keys %outdirs) { + opendir(OUTDIR,$dir); + foreach (sort readdir(OUTDIR)){ + next unless /\.al$/; + my($file) = "$dir/$_"; + $file = lc $file if $Is83; + next if $outfiles{$file}; + print " deleting $file\n" if ($Verbose>=2); + my($deleted,$thistime); # catch all versions on VMS + do { $deleted += ($thistime = unlink $file) } while ($thistime); + carp "Unable to delete $file: $!" unless $deleted; + } + closedir(OUTDIR); } - closedir(OUTDIR); } open(TS,">$al_idx_file") or carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; - print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; - print TS "package $package;\n"; - print TS map("sub $_$proto{$_} ;\n", @subnames); + print TS "# Index created by AutoSplit for $filename\n"; + print TS "# (file acts as timestamp)\n"; + $last_package = ''; + for my $fqs (@subnames) { + my($subname) = $fqs; + $subname =~ s/.*:://; + print TS "package $package{$fqs};\n" + unless $last_package eq $package{$fqs}; + print TS "sub $subname $proto{$fqs};\n"; + $last_package = $package{$fqs}; + } print TS "1;\n"; close(TS); - check_unique($package, $Maxlen, 1, @names); + _check_unique($filename, $Maxlen, 1, @outfiles); - @names; + @outfiles; } +sub _modpname ($) { + my($package) = @_; + my $modpname = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } + $modpname; +} -sub check_unique{ - my($module, $maxlen, $warn, @names) = @_; +sub _check_unique { + my($filename, $maxlen, $warn, @outfiles) = @_; my(%notuniq) = (); my(%shorts) = (); - my(@toolong) = grep(length > $maxlen, @names); - - foreach(@toolong){ - my($trunc) = substr($_,0,$maxlen); - $notuniq{$trunc}=1 if $shorts{$trunc}; - $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + my(@toolong) = grep( + length(File::Basename::basename($_)) + > $maxlen, + @outfiles + ); + + foreach (@toolong){ + my($dir) = File::Basename::dirname($_); + my($file) = File::Basename::basename($_); + my($trunc) = substr($file,0,$maxlen); + $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; + $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? + "$shorts{$dir}{$trunc}, $file" : $file; } if (%notuniq && $warn){ - print "$module: some names are not unique when truncated to $maxlen characters:\n"; - foreach(keys %notuniq){ - print " $shorts{$_} truncate to $_\n"; + print "$filename: some names are not unique when " . + "truncated to $maxlen characters:\n"; + foreach my $dir (sort keys %notuniq){ + print " directory $dir:\n"; + foreach my $trunc (sort keys %{$notuniq{$dir}}) { + print " $shorts{$dir}{$trunc} truncate to $trunc\n"; + } } } - %notuniq; } 1; __END__ # test functions so AutoSplit.pm can be applied to itself: -sub test1{ "test 1\n"; } -sub test2{ "test 2\n"; } -sub test3{ "test 3\n"; } -sub test4{ "test 4\n"; } - - +sub test1 ($) { "test 1\n"; } +sub test2 ($$) { "test 2\n"; } +sub test3 ($$$) { "test 3\n"; } +sub testtesttesttest4_1 { "test 4\n"; } +sub testtesttesttest4_2 { "duplicate test 4\n"; } +sub Just::Another::test5 { "another test 5\n"; } +sub test6 { return join ":", __FILE__,__LINE__; } +package Yet::Another::AutoSplit; +sub testtesttesttest4_1 ($) { "another test 4\n"; } +sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index e09bc92958..fe77dd0a61 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -82,6 +82,30 @@ Results will be printed to STDOUT as TITLE followed by the times. TITLE defaults to "timethis COUNT" if none is provided. STYLE determines the format of the output, as described for timestr() below. +The COUNT can be zero or negative: this means the I<minimum number of +CPU seconds> to run. A zero signifies the default of 3 seconds. For +example to run at least for 10 seconds: + + timethis(-10, $code) + +or to run two pieces of code tests for at least 3 seconds: + + timethese(0, { test1 => '...', test2 => '...'}) + +CPU seconds is, in UNIX terms, the user time plus the system time of +the process itself, as opposed to the real (wallclock) time and the +time spent by the child processes. Less than 0.1 seconds is not +accepted (-0.01 as the count, for example, will cause a fatal runtime +exception). + +Note that the CPU seconds is the B<minimum> time: CPU scheduling and +other operating system factors may complicate the attempt so that a +little bit more time is spent. The benchmark output will, however, +also tell the number of C<$code> runs/second, which should be a more +interesting number than the actually spent seconds. + +Returns a Benchmark object. + =item timethese ( COUNT, CODEHASHREF, [ STYLE ] ) The CODEHASHREF is a reference to a hash containing names as keys @@ -91,12 +115,14 @@ call timethis(COUNT, VALUE, KEY, STYLE) +The Count can be zero or negative, see timethis(). + =item timediff ( T1, T2 ) Returns the difference between two Benchmark times as a Benchmark object suitable for passing to timestr(). -=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ]] ) +=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] ) Returns a string that formats the times in the TIMEDIFF object in the requested STYLE. TIMEDIFF is expected to be a Benchmark object @@ -205,6 +231,9 @@ March 28th, 1997; by Hugo van der Sanden: added support for code references and the already documented 'debug' method; revamped documentation. +April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time +functionality. + =cut use Carp; @@ -237,7 +266,9 @@ sub disablecache { $cache = 0; } # --- Functions to process the 'time' data type -sub new { my @t = (time, times); print "new=@t\n" if $debug; bless \@t; } +sub new { my @t = (time, times, @_ == 2 ? $_[1] : 0); + print "new=@t\n" if $debug; + bless \@t; } sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } @@ -256,20 +287,21 @@ sub timediff { sub timestr { my($tr, $style, $f) = @_; my @t = @$tr; - warn "bad time value" unless @t==5; - my($r, $pu, $ps, $cu, $cs) = @t; + warn "bad time value (@t)" unless @t==6; + my($r, $pu, $ps, $cu, $cs, $n) = @t; my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); $f = $defaultfmt unless defined $f; # format a time in the required style, other formats may be added here $style ||= $defaultstyle; $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto'; my $s = "@t $style"; # default for unknown style - $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", + $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU secs)", @t,$t) if $style eq 'all'; - $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", - $r,$pu,$ps,$pt) if $style eq 'noc'; - $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", - $r,$cu,$cs,$ct) if $style eq 'nop'; + $s=sprintf("%$f CPU secs (%$f usr + %$f sys)", + $pt,$pu,$ps) if $style eq 'noc'; + $s=sprintf("%$f CPU secs (%$f cusr %$f csys)", + $ct,$cu,$cs) if $style eq 'nop'; + $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n; $s; } @@ -302,9 +334,9 @@ sub runloop { croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if $debug; - $t0 = &new; + $t0 = Benchmark->new(0); &$subref; - $t1 = &new; + $t1 = Benchmark->new($n); $td = &timediff($t1, $t0); timedebug("runloop:",$td); @@ -336,16 +368,98 @@ sub timeit { $wd; } + +my $default_for = 3; +my $min_for = 0.1; + +sub runfor { + my ($code, $tmax) = @_; + + if ( not defined $tmax or $tmax == 0 ) { + $tmax = $default_for; + } elsif ( $tmax < 0 ) { + $tmax = -$tmax; + } + + die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n" + if $tmax < $min_for; + + my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot ); + + # First find the minimum $n that gives a non-zero timing. + + my $nmin; + + for ($n = 1, $tc = 0; $tc <= 0; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->[1] + $td->[2]; + } + + $nmin = $n; + + my $ttot = 0; + my $tpra = 0.05 * $tmax; # Target/time practice. + + # Double $n until we have think we have practiced enough. + for ( $n = 1; $ttot < $tpra; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->cpu_p; + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + my $r; + + # Then iterate towards the $tmax. + while ( $ttot < $tmax ) { + $r = $tmax / $ttot - 1; # Linear approximation. + $n = int( $r * $n ); + $n = $nmin if $n < $nmin; + $td = timeit($n, $code); + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ]; +} + # --- Functions implementing high-level time-then-print utilities +sub n_to_for { + my $n = shift; + return $n == 0 ? $default_for : $n < 0 ? -$n : undef; +} + sub timethis{ my($n, $code, $title, $style) = @_; - my $t = timeit($n, $code); + my($t, $for, $forn); + + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + $t = timeit($n, $code); + $title = "timethis $n" unless defined $title; + } else { + $fort = n_to_for( $n ); + $t = runfor($code, $fort); + $title = "timethis for $fort" unless defined $title; + $forn = $t->[-1]; + } local $| = 1; - $title = "timethis $n" unless defined $title; $style = "" unless defined $style; printf("%10s: ", $title); - print timestr($t, $style),"\n"; + print timestr($t, $style, $defaultfmt),"\n"; + + $n = $forn if defined $forn; # A conservative warning to spot very silly tests. # Don't assume that your benchmark is ok simply because @@ -363,7 +477,19 @@ sub timethese{ unless ref $alt eq HASH; my @names = sort keys %$alt; $style = "" unless defined $style; - print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; + print "Benchmark: "; + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + print "timing $n iterations of"; + } else { + print "running"; + } + print " ", join(', ',@names); + unless ( $n > 0 ) { + my $for = n_to_for( $n ); + print ", each for at least $for CPU seconds"; + } + print "...\n"; # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc diff --git a/lib/Carp.pm b/lib/Carp.pm index 685a7933d0..6bac36446a 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -47,10 +47,20 @@ environment variable. # This package is heavily used. Be small. Be fast. Be good. +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# The $CarpLevel variable can be set to "strip off" extra caller levels for +# those times when Carp calls are buried inside other functions. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. +$Verbose = 0; # If true then make shortmess call longmess instead require Exporter; @ISA = ('Exporter'); @@ -58,30 +68,58 @@ require Exporter; @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + sub export_fail { shift; - if ($_[0] eq 'verbose') { - local $^W = 0; - *shortmess = \&longmess; - shift; - } + $Verbose = shift if $_[0] eq 'verbose'; return @_; } +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + sub longmess { my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; my ($pack,$file,$line,$sub,$hargs,$eval,$require); my (@a); + # + # crawl up the stack.... + # while (do { { package DB; @a = caller($i++) } } ) { - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" if ($error =~ m/\n$/) { $mess .= $error; } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" if (defined $eval) { - if ($require) { + if ($require) { $sub = "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; @@ -93,32 +131,48 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string if ($hargs) { - @a = @DB::args; # must get local copy of args - if ($MaxArgNums and @a > $MaxArgNums) { - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - $_ = "undef", next unless defined $_; - if (ref $_) { - $_ .= ''; - s/'/\\'/g; + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; } - else { - s/'/\\'/g; - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # dunno what this is for... + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' or '^<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } - $_ = "'$_'" unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - $sub .= '(' . join(', ', @a) . ')'; + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; } + # here's where the error message, $mess, gets constructed $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". $error = "called"; } # this kludge circumvents die's incorrect handling of NUL @@ -127,36 +181,71 @@ sub longmess { $$msg; } + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + sub shortmess { # Short-circuit &longmess if called via multiple packages + goto &longmess if $Verbose; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; my $i = 2; my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored my %isa = ($prevpack,1); + # merge all the caller's @ISA packages into %isa. @isa{@{"${prevpack}::ISA"}} = () if(defined @{"${prevpack}::ISA"}); + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored while (($pack,$file,$line) = caller($i++)) { if(defined @{$pack . "::ISA"}) { my @i = @{$pack . "::ISA"}; my %i; @i{@i} = (); + # merge any relevant packages into %isa @isa{@i,$pack} = () if(exists $i{$prevpack} || exists $isa{$pack}); } + # and here's where we do the ignoring... if the package in + # question is one of our caller's base or derived packages then + # we can ignore it (skip it) and go onto the next (but note that + # the continue { } block below gets called every time) next if(exists $isa{$pack}); + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. if ($extra-- > 0) { %isa = ($pack,1); @isa{@{$pack . "::ISA"}} = () if(defined @{$pack . "::ISA"}); } else { - # this kludge circumvents die's incorrect handling of NUL + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. (my $msg = "$error at $file line $line\n") =~ tr/\0//d; return $msg; } @@ -165,12 +254,23 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages $prevpack = $pack; } + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. goto &longmess; } -sub confess { die longmess @_; } -sub croak { die shortmess @_; } -sub carp { warn shortmess @_; } -sub cluck { warn longmess @_; } + +# the following four functions call longmess() or shortmess() depending on +# whether they should generate a full stack trace (confess() and cluck()) +# or simply report the caller's package (croak() and carp()), respectively. +# confess() and croak() die, carp() and cluck() warn. + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } 1; diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index 09ab196254..a39d1ac04a 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -180,7 +180,7 @@ sub struct { } elsif( defined $classes{$name} ){ if ( $CHECK_CLASS_MEMBERSHIP ) { - $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$type');\n"; + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; } } $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 652ee7e493..64798da00f 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -20,11 +20,21 @@ getcwd - get pathname of current working directory chdir "/tmp"; print $ENV{'PWD'}; + use Cwd 'abs_path'; + print abs_path($ENV{'PWD'}); + + use Cwd 'fast_abs_path'; + print fast_abs_path($ENV{'PWD'}); + =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algoritm as +getcwd(). (actually getcwd() is abs_path(".")) + The fastcwd() function looks the same as getcwd(), but runs faster. 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 @@ -35,6 +45,9 @@ 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 fast_abs_path() function looks the same as abs_path(), but runs faster. +And like fastcwd() is more dangerous. + 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 diff --git a/lib/English.pm b/lib/English.pm index bbb6bd7b28..1cbacd11f8 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -137,8 +137,8 @@ sub import { # Error status. *CHILD_ERROR = *? ; - *OS_ERROR = *! ; - *ERRNO = *! ; + *OS_ERROR = \$! ; + *ERRNO = \$! ; *EXTENDED_OS_ERROR = *^E ; *EVAL_ERROR = *@ ; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 992d178659..6a5c1847ac 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -81,10 +81,13 @@ sub install { #there are any files in arch. So we depend on having ./blib/arch #hardcoded here. my $targetroot = $hash{$source}; - if ($source eq "./blib/lib" and - exists $hash{"./blib/arch"} and - directory_not_empty("./blib/arch")) { - $targetroot = $hash{"./blib/arch"}; + if ($source eq "blib/lib" and + exists $hash{"blib/arch"} and + directory_not_empty("blib/arch")) { + $targetroot = $hash{"blib/arch"}; + print "Files found in blib/arch --> Installing files in " + . "blib/lib into architecture dependend library tree!\n" + ; #if $verbose>1; } chdir($source) or next; find(sub { diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 5c35dc7307..ccdffb8eea 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -182,6 +182,9 @@ sub _unix_os2_ext { } sub _win32_ext { + + require Text::ParseWords; + my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. @@ -206,14 +209,14 @@ sub _win32_ext { # compute $extralibs from $potential_libs my(@searchpath); # from "-L/path" entries in $potential_libs - my(@libpath) = split " ", $libpth; + my(@libpath) = Text::ParseWords::quotewords('\s+', 0, $libpth); my(@extralibs); my($fullname, $thislib, $thispth); my($pwd) = cwd(); # from Cwd.pm my($lib) = ''; my($found) = 0; - foreach $thislib (split ' ', $potential_libs){ + foreach $thislib (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { @@ -223,7 +226,7 @@ sub _win32_ext { } elsif (-d $thislib) { unless ($self->file_name_is_absolute($thislib)) { - warn "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); @@ -253,6 +256,9 @@ sub _win32_ext { unless $found_lib>0; } return ('','','','') unless $found; + + # make sure paths with spaces are properly quoted + @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; $lib = join(' ',@extralibs); warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; @@ -595,6 +601,17 @@ distinguish between them. LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS and LD_RUN_PATH are always empty (this may change in future). +=item * + +You must make sure that any paths and path components are properly +surrounded with double-quotes if they contain spaces. For example, +C<$potential_libs> could be (literally): + + "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" + +Note how the first and last entries are protected by quotes in order +to protect the spaces. + =back diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 65abfc2d99..5a603caa36 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -8,7 +8,6 @@ require Exporter; Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_OS2'; sub dlsyms { @@ -29,7 +28,8 @@ $self->{BASEEXT}.def: Makefile.PL '", "DLBASE" => "',$self->{DLBASE}, '", "DL_FUNCS" => ',neatvalue($funcs), ', "IMPORTS" => ',neatvalue($imports), - ', "DL_VARS" => ', neatvalue($vars), ');\' + ', "VERSION" => "',$self->{VERSION}, + '", "DL_VARS" => ', neatvalue($vars), ');\' '); } join('',@m); diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 2daa056067..3b5dbb3616 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1011,6 +1011,10 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} if ($^O eq 'solaris'); + # The IRIX linker also doesn't use LD_RUN_PATH + $ldrun = "-rpath $self->{LD_RUN_PATH}" + if ($^O eq 'irix'); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' @@ -1271,7 +1275,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; my($name, %dir, %xs, %c, %h, %ignore, %pl_files, %manifypods); local(%pm); #the sub in find() has to see this hash - $ignore{'test.pl'} = 1; + @ignore{qw(Makefile.PL test.pl)} = (1,1); $ignore{'makefile.pl'} = 1 if $Is_VMS; foreach $name ($self->lsdir($self->curdir)){ next if $name =~ /\#/; @@ -1289,13 +1293,16 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) unless $name =~ m/perlmain\.c/; # See MAP_TARGET } elsif ($name =~ /\.h$/i){ $h{$name} = 1; + } elsif ($name =~ /\.PL$/) { + ($pl_files{$name} = $name) =~ s/\.PL$// ; + } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem + local($/); open(PL,$name); my $txt = <PL>; close PL; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/\.pl$// ; + } + else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } } elsif ($name =~ /\.(p[ml]|pod)$/){ $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); - } elsif ($name =~ /\.PL$/ && $name ne "Makefile.PL") { - ($pl_files{$name} = $name) =~ s/\.PL$// ; - } elsif ($Is_VMS && $name =~ /\.pl$/ && $name ne 'makefile.pl' && - $name ne 'test.pl') { # case-insensitive filesystem - ($pl_files{$name} = $name) =~ s/\.pl$// ; } } @@ -1499,7 +1506,7 @@ sub init_main { $modfname = &DynaLoader::mod2fname(\@modparts); } - ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ; if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' @@ -1953,7 +1960,7 @@ pure_site_install :: }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ doc_perl_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -1962,7 +1969,7 @@ doc_perl_install :: >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -2327,7 +2334,7 @@ $tmp/perlmain.c: $makefilename}, q{ push @m, q{ doc_inst_perl: }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 29bfaf2e55..a1eae3799b 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -14,7 +14,7 @@ use VMS::Filespec; use File::Basename; use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; +$Revision = '5.42 (31-Mar-1997)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; @@ -90,8 +90,10 @@ are all macro, so that we can tell how long the expansion is, and avoid overrunning DCL's command buffer when MM[KS] is running. If optional second argument has a TRUE value, then the return string is -a VMS-syntax directory specification, otherwise it is a VMS-syntax file -specification. +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. =cut @@ -122,8 +124,10 @@ sub fixpath { $fixedpath = $path; $fixedpath = vmspath($fixedpath) if $force_path; } - # Convert names without directory or type to paths - if (!$force_path and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($fixedpath); } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } # Trim off root dirname if it's had other dirs inserted in front of it. $fixedpath =~ s/\.000000([\]>])/$1/; print "fixpath($path) = |$fixedpath|\n" if $Verbose >= 3; @@ -436,7 +440,7 @@ sub find_perl { } foreach $name (@snames){ if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } - else { push(@cand,$self->fixpath($name)); } + else { push(@cand,$self->fixpath($name,0)); } } } foreach $name (@cand) { @@ -639,9 +643,9 @@ sub constants { if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); + $self->{OBJECT} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{OBJECT}))); } - $self->{LDFROM} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); + $self->{LDFROM} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{LDFROM}))); # Fix up directory specs @@ -664,7 +668,7 @@ sub constants { # Fix up file specs foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) { next unless defined $self->{$macro}; - $self->{$macro} = $self->fixpath($self->{$macro}); + $self->{$macro} = $self->fixpath($self->{$macro},0); } foreach $macro (qw/ @@ -702,7 +706,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision FULLEXT VERSION_FROM OBJECT LDFROM / ) { next unless defined $self->{$tmp}; - push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n"; + push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n"; } for $tmp (qw/ @@ -716,7 +720,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(%tmp,$key); for $key (keys %{$self->{$tmp}}) { - $tmp{$self->fixpath($key)} = $self->fixpath($self->{$tmp}{$key}); + $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0); } $self->{$tmp} = \%tmp; } @@ -725,7 +729,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(@tmp,$val); for $val (@{$self->{$tmp}}) { - push(@tmp,$self->fixpath($val)); + push(@tmp,$self->fixpath($val,0)); } $self->{$tmp} = \@tmp; } @@ -1011,7 +1015,7 @@ sub tool_xsubpp { warn "Typemap $typemap not found.\n"; } else{ - push(@tmdeps, $self->fixpath($typemap)); + push(@tmdeps, $self->fixpath($typemap,0)); } } } @@ -1464,31 +1468,6 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) } -# sub installpm_x { # called by installpm perl file -# my($self, $dist, $inst, $splitlib) = @_; -# if ($inst =~ m!#!) { -# warn "Warning: MM[SK] would have problems processing this file: $inst, SKIPPED\n"; -# return ''; -# } -# $inst = $self->fixpath($inst); -# $dist = $self->fixpath($dist); -# my($instdir) = $inst =~ /([^\)]+\))[^\)]*$/ ? $1 : dirname($inst); -# my(@m); -# -# push(@m, " -# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists -# ",' $(NOECHO) $(RM_F) $(MMS$TARGET) -# $(NOECHO) $(CP) ',"$dist $inst",' -# $(CHMOD) 644 $(MMS$TARGET) -# '); -# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', -# $self->catdir($splitlib,'auto')."\n\n") -# if ($splitlib and $inst =~ /\.pm$/); -# push(@m,$self->dir_target($instdir)); -# -# join('',@m); -# } - =item manifypods (override) Use VMS-style quoting on command line, and VMS logical name @@ -1674,7 +1653,7 @@ clean :: if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@otherfiles, @{$self->{$key}}); } - else { push(@otherfiles, $attribs{FILES}); } + else { push(@otherfiles, $word); } } } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); @@ -1748,7 +1727,7 @@ realclean :: clean if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@allfiles, @{$self->{$key}}); } - else { push(@allfiles, $attribs{FILES}); } + else { push(@allfiles, $word); } } $line = ''; # Occasionally files are repeated several times from different sources @@ -2037,7 +2016,7 @@ $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl Set Default $(PERL_SRC) $(MMS)],$mmsquals,); if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { - my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm')); + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); $target =~ s/\Q$prefix/[/; push(@m," $target"); } @@ -2047,7 +2026,7 @@ $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl ]); } - push(@m, join(" ", map($self->fixpath($_),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") if %{$self->{XS}}; join('',@m); @@ -2330,8 +2309,8 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) push @m, ' # Fill in the target you want to produce if it\'s not perl -MAP_TARGET = ',$self->fixpath($target),' -MAP_SHRTARGET = ',$self->fixpath($shrtarget)," +MAP_TARGET = ',$self->fixpath($target,0),' +MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' # We use the linker options files created with each extension, rather than @@ -2339,7 +2318,7 @@ MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '',' MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : ''," MAP_EXTRA = $extralist -MAP_LIBPERL = ",$self->fixpath($libperl),' +MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 6735b034c0..168c98d7f2 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -1540,15 +1540,14 @@ Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'} -By default this will include *.pm and *.pl. If a lib directory -exists and is not listed in DIR (above) then any *.pm and *.pl files -it contains will also be included by default. Defining PM in the +By default this will include *.pm and *.pl and the files found in +the PMLIBDIRS directories. Defining PM in the Makefile.PL will override PMLIBDIRS. =item PMLIBDIRS Ref to array of subdirectories containing library files. Defaults to -[ 'lib', $(BASEEXT) ]. The directories will be scanned and any files +[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 8437346c91..55570892f8 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -242,7 +242,11 @@ sub ln { link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; - chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ ); + if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) { + unlink $dstFile; + return; + } + 1; } sub best { diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 2f2366a1c8..7e436384aa 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -7,7 +7,7 @@ use Exporter; use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = substr q$Revision: 1.16 $, 10; +$VERSION = substr q$Revision: 1.17 $, 10; sub Mksymlists { my(%spec) = @_; @@ -69,6 +69,8 @@ sub _write_aix { sub _write_os2 { my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; @@ -79,6 +81,7 @@ sub _write_os2 { open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); print DEF "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print DEF "DESCRIPTION 'Perl (v$]$threaded) module $data->{NAME} v$data->{VERSION}'\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 8828a52bfc..e21af92682 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -160,23 +160,27 @@ sub fileparse { if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/t); $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)/i) { - ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/t); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; } elsif ($fstype =~ /^MacOS/i) { - ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/t); } elsif ($fstype =~ /^AmigaOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/t); $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#t); + if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + ($basename,$dirpath) = ('',$fullname); + } $dirpath = './' unless $dirpath; } @@ -184,7 +188,7 @@ sub fileparse { $tail = ''; foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; - if ($basename =~ s/$pat//) { + if ($basename =~ s/$pat//t) { $taint .= substr($suffix,0,0); $tail = $1 . $tail; } @@ -222,30 +226,30 @@ sub dirname { } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /MSWin32/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /AmigaOS/i) { if ( $dirname =~ /:$/) { return $dirname } chop $dirname; - $dirname =~ s#[^:/]+$## unless length($basename); + $dirname =~ s#[^:/]+$##t unless length($basename); } else { $dirname =~ s:(.)/*$:$1:; unless( length($basename) ) { local($File::Basename::Fileparse_fstype) = $fstype; ($basename,$dirname) = fileparse $dirname; - $dirname =~ s:(.)/*$:$1:; + $dirname =~ s:(.)/*$:$1:t; } } diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index a39308b6c9..dca7f6aff3 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -137,13 +137,13 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print STDERR "Can't do $this.\n"; + $mess = "Can't do $this.\n"; } - if ($disposition eq 'die') { exit 1; } + die "$mess\n" if $disposition eq 'die'; + warn "$mess\n"; ++$warnings; } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 7abebc6544..1305d21e6b 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,10 +1,7 @@ package File::Find; require 5.000; require Exporter; -use Config; require Cwd; -require File::Basename; - =head1 NAME @@ -24,6 +21,17 @@ finddepth - traverse a directory structure depth-first =head1 DESCRIPTION +The first argument to find() is either a hash reference describing the +operations to be performed for each file, or a code reference. If it +is a hash reference, then the value for the key C<wanted> should be a +code reference. This code reference is called I<the wanted() +function> below. + +Currently the only other supported key for the above hash is +C<bydepth>, in presense of which the walk over directories is +performed depth-first. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1}> in the first argument of find(). + The wanted() function does whatever verifications you want. $File::Find::dir contains the current directory name, and $_ the current filename within that directory. $File::Find::name contains @@ -34,7 +42,7 @@ prune the tree. File::Find assumes that you don't alter the $_ variable. If you do then make sure you return it to its original value before exiting your function. -This library is primarily for the C<find2perl> tool, which when fed, +This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune @@ -75,9 +83,10 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find { +sub find_opt { my $wanted = shift; - my $cwd = Cwd::cwd(); + my $bydepth = $wanted->{bydepth}; + my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); # Localize these rather than lexicalizing them for backwards # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); @@ -87,27 +96,35 @@ sub find { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; $prune = 0; - &$wanted; + unless ($bydepth) { + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + $wanted->{wanted}->(); + } next if $prune; my $fixtopdir = $topdir; $fixtopdir =~ s,/$,, ; $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$fixtopdir,$topnlink); + &finddir($wanted,$fixtopdir,$topnlink, $bydepth); + if ($bydepth) { + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + $wanted->{wanted}->(); + } } else { warn "Can't cd to $topdir: $!\n"; } } else { + require File::Basename; unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } if (chdir($dir)) { $name = $topdir; - &$wanted; + $wanted->{wanted}->(); } else { warn "Can't cd to $dir: $!\n"; @@ -118,14 +135,14 @@ sub find { } sub finddir { - my($wanted, $nlink); + my($wanted, $nlink, $bydepth); local($dir, $name); - ($wanted, $dir, $nlink) = @_; + ($wanted, $dir, $nlink, $bydepth) = @_; my($dev, $ino, $mode, $subcount); # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); + opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); my(@filenames) = readdir(DIR); closedir(DIR); @@ -135,7 +152,7 @@ sub finddir { next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; - &$wanted; + $wanted->{wanted}->(); } } else { # This dir has subdirectories. @@ -143,9 +160,10 @@ sub finddir { for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; - $nlink = $prune = 0; + $nlink = 0; + $prune = 0 unless $bydepth; $name = "$dir/$_"; - &$wanted; + $wanted->{wanted}->() unless $bydepth; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. @@ -161,7 +179,7 @@ sub finddir { next if $prune; if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink); + &finddir($wanted,$name,$nlink, $bydepth); chdir '..'; } else { @@ -169,109 +187,26 @@ sub finddir { } } } + $wanted->{wanted}->() if $bydepth; } } } - -sub finddepth { - my $wanted = shift; - my $cwd = Cwd::cwd(); - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir,$topdev,$topino,$topmode,$topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$fixtopdir,$topnlink); - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); - } - if (chdir($dir)) { - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $dir: $!\n"; - } - } - chdir $cwd; - } +sub wrap_wanted { + my $wanted = shift; + defined &$wanted ? {wanted => $wanted} : $wanted; } -sub finddepthdir { - my($wanted, $nlink); - local($dir, $name); - ($wanted, $dir, $nlink) = @_; - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - &$wanted; - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $name = "$dir/$_"; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$name,$nlink); - chdir '..'; - } - else { - warn "Can't cd to $_: $!\n"; - } - } - } - &$wanted; - } - } +sub find { + my $wanted = shift; + find_opt(wrap_wanted($wanted), @_); } -# Set dont_use_nlink in your hint file if your system's stat doesn't -# report the number of links in a directory as an indication -# of the number of files. -# See, e.g. hints/machten.sh for MachTen 2.2. -$dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + find_opt($wanted, @_); +} # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { @@ -282,5 +217,14 @@ if ($^O eq 'VMS') { $dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; +# Set dont_use_nlink in your hint file if your system's stat doesn't +# report the number of links in a directory as an indication +# of the number of files. +# See, e.g. hints/machten.sh for MachTen 2.2. +unless ($dont_use_nlink) { + require Config; + $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +} + 1; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 6b5d5683f1..39f1ba1771 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -124,11 +124,15 @@ sub mkpath { $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT next if -d $path; # Logic wants Unix paths, so go with the flow. $path = VMS::Filespec::unixify($path) if $Is_VMS; my $parent = File::Basename::dirname($path); - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + # Allow for creation of new logical filesystems under VMS + if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { + push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { # allow for another process to have created it meanwhile diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 455fc63917..72ecdac1b6 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -249,6 +249,10 @@ It will also croak() if accidentally called in a scalar context. =back +There are many other functions available since FileHandle is descended +from IO::File, IO::Seekable, and IO::Handle. Please see those +respective pages for documentation on more functions. + =head1 SEE ALSO The B<IO> extension, diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 38b396771b..fe7e12f09b 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.13 1997-12-25 16:20:17+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Thu Dec 25 16:18:08 1997 -# Update Count : 647 +# Last Modified On: Fri Mar 13 11:05:28 1998 +# Update Count : 659 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1997 by Johan Vromans. +# This program is Copyright 1990,1998 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -32,10 +32,10 @@ package Getopt::Long; use strict; BEGIN { - require 5.003; + require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\d+)\.(\d+)/); + $VERSION = sprintf("%d.%02d", q$Revision: 2.16 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -87,7 +87,7 @@ sub GetOptions { $genprefix = $gen_prefix; # so we can call the same module many times $error = ''; - print STDERR ('GetOptions $Revision: 2.13 $ ', + print STDERR ('GetOptions $Revision: 2.16 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -127,7 +127,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $2 if $opt =~ /^$genprefix+(.*)$/; + $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -420,9 +420,9 @@ sub config (@) { foreach $opt ( @options ) { my $try = lc ($opt); my $action = 1; - if ( $try =~ /^no_?(.*)$/ ) { + if ( $try =~ /^no_?(.*)$/s ) { $action = 0; - $try = $1; + $try = $+; } if ( $try eq 'default' or $try eq 'defaults' ) { &$config_defaults () if $action; @@ -454,6 +454,21 @@ sub config (@) { elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { $passthrough = $action; } + elsif ( $try =~ /^prefix=(.+)$/ ) { + $gen_prefix = $1; + # Turn into regexp. Needs to be parenthesized! + $gen_prefix = "(" . quotemeta($gen_prefix) . ")"; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + $gen_prefix = $1; + # Parenthesize if needed. + $gen_prefix = "(" . $gen_prefix . ")" + unless $gen_prefix =~ /^\(.*\)$/; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } elsif ( $try eq 'debug' ) { $debug = $action; } @@ -476,9 +491,9 @@ $find_option = sub { print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug; - return 0 unless $opt =~ /^$genprefix(.*)$/; + return 0 unless $opt =~ /^$genprefix(.*)$/s; - $opt = $2; + $opt = $+; my ($starter) = $1; print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; @@ -488,7 +503,7 @@ $find_option = sub { # If it is a long option, it may include the value. if (($starter eq "--" || ($getopt_compat && !$bundling)) - && $opt =~ /^([^=]+)=(.*)$/ ) { + && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; $optarg = $2; print STDERR ("=> option \"", $opt, @@ -626,7 +641,7 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1); + ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### @@ -650,7 +665,7 @@ $find_option = sub { } elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) { + if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) { $arg = $1; $rest = $2; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; @@ -683,9 +698,9 @@ $find_option = sub { # and at least one digit following the point and 'e'. # [-]NN[.NN][eNN] if ( $bundling && defined $rest && - $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) { + $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) { $arg = $1; - $rest = $4; + $rest = $+; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) { @@ -940,6 +955,12 @@ identifier is $opt_ . The linkage specifier can be a reference to a scalar, a reference to an array, a reference to a hash or a reference to a subroutine. +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_size @opt_sizes $opt_bar /; + If a REF SCALAR is supplied, the new value is stored in the referenced variable. If the option occurs more than once, the previous value is overwritten. @@ -1228,6 +1249,16 @@ remaining options to some other program. This can be very confusing, especially when B<permute> is also set. +=item prefix + +The string that starts options. See also B<prefix_pattern>. + +=item prefix_pattern + +A Perl pattern that identifies the strings that introduce options. +Default is C<(--|-|\+)> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. + =item debug (default: reset) Enable copious debugging output. @@ -1262,7 +1293,7 @@ Johan Vromans E<lt>jvromans@squirrel.nlE<gt> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1997 by Johan Vromans. +This program is Copyright 1990,1998 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index 27882935f9..18b5739e92 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -27,6 +27,12 @@ switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_foo $opt_bar /; + For those of you who don't like additional variables being created, getopt() and getopts() will also accept a hash reference as an optional second argument. Hash keys will be x (where x is the switch name) with key values the value of diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 7551ad01a3..77fb5dd818 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -37,7 +37,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead sub stringify { my $n = ${$_[0]}; - $n =~ s/^\+//; + my $minus = ($n =~ s/^([+-])// && $1 eq '-'); $n =~ s/E//; $n =~ s/([-+]\d+)$//; @@ -52,6 +52,7 @@ sub stringify { } else { $n = '.' . ("0" x (abs($e) - $ln)) . $n; } + $n = "-$n" if $minus; # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 422dca42fd..013e55fadb 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,7 +171,7 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; + $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; @@ -185,8 +185,8 @@ sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { - last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + last unless @sy || $bar; + $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0); } @sx; } diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 8ff3e8964b..dafa27d781 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -3,6 +3,8 @@ package Pod::Html; use Pod::Functions; use Getopt::Long; # package for handling command-line parameters require Exporter; +use vars qw($VERSION); +$VERSION = 1.01; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; @@ -11,13 +13,15 @@ use Carp; use strict; +use Config; + =head1 NAME -Pod::HTML - module to convert pod files to HTML +Pod::Html - module to convert pod files to HTML =head1 SYNOPSIS - use Pod::HTML; + use Pod::Html; pod2html([options]); =head1 DESCRIPTION @@ -302,7 +306,7 @@ sub pod2html { for (my $i = 0; $i < @poddata; $i++) { if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s; + last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s; } } @@ -316,19 +320,22 @@ sub pod2html { warn "adopted '$title' as title for $podfile\n" if $verbose and $title; } - unless ($title) { + if ($title) { + $title =~ s/\s*\(.*\)//; + } else { warn "$0: no title for $podfile"; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; } print HTML <<END_OF_HEAD; - <HTML> - <HEAD> - <TITLE>$title</TITLE> - </HEAD> +<HTML> +<HEAD> +<TITLE>$title</TITLE> +<LINK REV="made" HREF="mailto:$Config{perladmin}"> +</HEAD> - <BODY> +<BODY> END_OF_HEAD @@ -368,9 +375,9 @@ END_OF_HEAD } else { next if @begin_stack && $begin_stack[-1] ne 'html'; - if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading process_head($1, $2); - } elsif (/^=item\s*(.*)/sm) { # =item text + } elsif (/^=item\s*(.*\S)/sm) { # =item text process_item($1); } elsif (/^=over\s*(.*)/) { # =over N process_over(); @@ -391,16 +398,16 @@ END_OF_HEAD next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; process_text(\$text, 1); - print HTML "$text\n<P>\n\n"; + print HTML "<P>\n$text"; } } # finish off any pending directives finish_list(); print HTML <<END_OF_TAIL; - </BODY> +</BODY> - </HTML> +</HTML> END_OF_TAIL # close the html file @@ -782,7 +789,7 @@ sub scan_headings { $index .= "\n" . ("\t" x $listdepth) . "<LI>" . "<A HREF=\"#" . htmlify(0,$title) . "\">" . - process_text(\$title, 0) . "</A>"; + html_escape(process_text(\$title, 0)) . "</A>"; } } @@ -823,8 +830,8 @@ sub scan_items { if ($1 eq "*") { # bullet list /\A=item\s+\*\s*(.*?)\s*\Z/s; $item = $1; - } elsif ($1 =~ /^[0-9]+/) { # numbered list - /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s; + } elsif ($1 =~ /^\d+/) { # numbered list + /\A=item\s+\d+\.?(.*?)\s*\Z/s; $item = $1; } else { # /\A=item\s+(.*?)\s*\Z/s; @@ -856,6 +863,7 @@ sub process_head { print HTML "<H$level>"; # unless $listlevel; #print HTML "<H$level>" unless $listlevel; my $convert = $heading; process_text(\$convert, 0); + $convert = html_escape($convert); print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; print HTML "</H$level>"; # unless $listlevel; print HTML "\n"; @@ -898,30 +906,36 @@ sub process_item { print HTML "<UL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A\*\s*(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\*\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(1,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } - } elsif ($text =~ /\A[0-9#]+/) { # numbered list + } elsif ($text =~ /\A[\d#]+/) { # numbered list if ($need_preamble) { push(@listend, "</OL>"); print HTML "<OL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A[0-9]+\.?(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1 if $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\d+\.?\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(0,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } } else { # all others @@ -930,18 +944,17 @@ sub process_item { print HTML "<DL>\n"; } - print HTML "<DT><STRONG>"; - print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" - if $text && !$items_named{($text =~ /(\S+)/)[0]}++; - # preceding craziness so that the duplicate leading bits in - # perlfunc work to find just the first one. otherwise - # open etc would have many names - $quote = 1; - #print HTML process_puretext($text, \$quote); - print HTML $text; - print HTML "</A>" if $text; - print HTML "</STRONG>"; - + print HTML '<DT>'; + if ($text =~ /(\S+)/) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($text); + } else { + my $name = 'item_' . htmlify(1,$text); + print HTML qq(<A NAME="$name">), html_escape($text), '</A>'; + } + print HTML '</STRONG>'; + } print HTML '<DD>'; } @@ -1276,12 +1289,15 @@ sub process_puretext { $word = qq(<A HREF="$word">$word</A>); } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { # looks like an e-mail address - $word = qq(<A HREF="MAILTO:$word">$word</A>); + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3); } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase? - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape; } else { - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; } } @@ -1443,6 +1459,7 @@ sub process_C { $s1 =~ s/\([^()]*\)//g; # delete parentheses $s2 = $s1; $s1 =~ s/\W//g; # delete bogus characters + $str = html_escape($str); # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. @@ -1512,7 +1529,7 @@ sub process_X { # after the entire pod file has been read and converted. # sub finish_list { - while ($listlevel >= 0) { + while ($listlevel > 0) { print HTML "</DL>\n"; $listlevel--; } @@ -1546,4 +1563,3 @@ BEGIN { } 1; - diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 6b0b5e7f23..83ba375742 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -193,7 +193,7 @@ sub findConsole { $console = "sys\$command"; } - if ($^O eq 'amigaos') { + if (($^O eq 'amigaos') || ($^O eq 'beos')) { $console = undef; } elsif ($^O eq 'os2') { @@ -310,7 +310,7 @@ sub ornaments { return $rl_term_set unless @_; $rl_term_set = shift; $rl_term_set ||= ',,,'; - $rl_term_set = 'us,ue,md,me' if $rl_term_set == 1; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; my @ts = split /,/, $rl_term_set, 4; eval { LoadTermCap }; unless (defined $terminal) { diff --git a/lib/Test.pm b/lib/Test.pm index b10d104ded..5f198c234c 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -2,8 +2,9 @@ use strict; package Test; use Test::Harness 1.1601 (); use Carp; -use vars qw($VERSION @ISA @EXPORT $ntest %todo %history $TestLevel); -$VERSION = '0.08'; +use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish + qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish +$VERSION = '1.04'; require Exporter; @ISA=('Exporter'); @EXPORT= qw(&plan &ok &skip $ntest); @@ -19,12 +20,17 @@ $ENV{REGRESSION_TEST} = $0; sub plan { croak "Test::plan(%args): odd number of arguments" if @_ & 1; + croak "Test::plan(): should not be called more than once" if $planned; my $max=0; for (my $x=0; $x < @_; $x+=2) { my ($k,$v) = @_[$x,$x+1]; if ($k =~ /^test(s)?$/) { $max = $v; } elsif ($k eq 'todo' or $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } + elsif ($k eq 'onfail') { + ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; + $ONFAIL = $v; + } else { carp "Test::plan(): skipping unrecognized directive '$k'" } } my @todo = sort { $a <=> $b } keys %todo; @@ -33,6 +39,7 @@ sub plan { } else { print "1..$max\n"; } + ++$planned; } sub to_value { @@ -40,79 +47,89 @@ sub to_value { (ref $v or '') eq 'CODE' ? $v->() : $v; } -# prototypes are not used for maximum flexibility - -# STDERR is NOT used for diagnostic output that should be fixed before -# the module is released. +# STDERR is NOT used for diagnostic output which should have been +# fixed before release. Is this appropriate? -sub ok { +sub ok ($;$$) { + croak "ok: plan before you test!" if !$planned; my ($pkg,$file,$line) = caller($TestLevel); my $repetition = ++$history{"$file:$line"}; my $context = ("$file at line $line". - ($repetition > 1 ? " (\#$repetition)" : '')); + ($repetition > 1 ? " fail \#$repetition" : '')); my $ok=0; - + my $result = to_value(shift); + my ($expected,$diag); if (@_ == 0) { - print "not ok $ntest\n"; - print "# test $context: DOESN'T TEST ANYTHING!\n"; + $ok = $result; } else { - my $result = to_value(shift); - my ($expected,$diag); - if (@_ == 0) { - $ok = $result; + $expected = to_value(shift); + # until regex can be manipulated like objects... + my ($regex,$ignore); + if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or + ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { + $ok = $result =~ /$regex/; } else { - $expected = to_value(shift); $ok = $result eq $expected; } - if ($todo{$ntest}) { - if ($ok) { - print "ok $ntest # Wow!\n"; + } + if ($todo{$ntest}) { + if ($ok) { + print "ok $ntest # Wow! ($context)\n"; + } else { + $diag = to_value(shift) if @_; + if (!$diag) { + print "not ok $ntest # (failure expected in $context)\n"; } else { - $diag = to_value(shift) if @_; + print "not ok $ntest # (failure expected: $diag)\n"; + } + } + } else { + print "not " if !$ok; + print "ok $ntest\n"; + + if (!$ok) { + my $detail = { 'repetition' => $repetition, 'package' => $pkg, + 'result' => $result }; + $$detail{expected} = $expected if defined $expected; + $diag = $$detail{diagnostic} = to_value(shift) if @_; + if (!defined $expected) { if (!$diag) { - print "not ok $ntest # (failure expected)\n"; + print STDERR "# Failed test $ntest in $context\n"; } else { - print "not ok $ntest # (failure expected: $diag)\n"; + print STDERR "# Failed test $ntest in $context: $diag\n"; } - } - } else { - print "not " if !$ok; - print "ok $ntest\n"; - - if (!$ok) { - $diag = to_value(shift) if @_; - if (!defined $expected) { - if (!$diag) { - print STDERR "# Failed $context\n"; - } else { - print STDERR "# Failed $context: $diag\n"; - } + } else { + my $prefix = "Test $ntest"; + print STDERR "# $prefix got: '$result' ($context)\n"; + $prefix = ' ' x (length($prefix) - 5); + if (!$diag) { + print STDERR "# $prefix Expected: '$expected'\n"; } else { - print STDERR "# Got: '$result' ($context)\n"; - if (!$diag) { - print STDERR "# Expected: '$expected'\n"; - } else { - print STDERR "# Expected: '$expected' ($diag)\n"; - } + print STDERR "# $prefix Expected: '$expected' ($diag)\n"; } } + push @FAILDETAIL, $detail; } } ++ $ntest; $ok; } -sub skip { +sub skip ($$;$$) { if (to_value(shift)) { print "ok $ntest # skip\n"; ++ $ntest; 1; } else { - local($TestLevel) += 1; #ignore this stack frame - ok(@_); + local($TestLevel) = $TestLevel+1; #ignore this stack frame + &ok; } } +END { + $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; +} + 1; __END__ @@ -124,7 +141,7 @@ __END__ use strict; use Test; - BEGIN { plan tests => 12, todo => [3,4] } + BEGIN { plan tests => 13, todo => [3,4] } ok(0); # failure ok(1); # success @@ -141,7 +158,8 @@ __END__ ok(0, int(rand(2)); # (just kidding! :-) my @list = (0,0); - ok(scalar(@list), 3, "\@list=".join(',',@list)); #extra diagnostics + ok @list, 3, "\@list=".join(',',@list); #extra diagnostics + ok 'segmentation fault', '/(?i)success/'; #regex match skip($feature_is_missing, ...); #do platform specific test @@ -175,10 +193,32 @@ test would be on the new feature list, not the TODO list). Packages should NOT be released with successful TODO tests. As soon as a TODO test starts working, it should be promoted to a normal test -and the new feature should be documented in the release notes. +and the newly minted feature should be documented in the release +notes. =back +=head1 ONFAIL + + BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } + +The test failures can trigger extra diagnostics at the end of the test +run. C<onfail> is passed an array ref of hash refs that describe each +test failure. Each hash will contain at least the following fields: +package, repetition, and result. (The file, line, and test number are +not included because their correspondance to a particular test is +fairly weak.) If the test had an expected value or a diagnostic +string, these will also be included. + +This optional feature might be used simply to print out the version of +your package and/or how to report problems. It might also be used to +generate extremely sophisticated diagnostics for a particular test +failure. It's not a panacea, however. Core dumps or other +unrecoverable errors will prevent the C<onfail> hook from running. +(It is run inside an END block.) Besides, C<onfail> is probably +over-kill in the majority of cases. (Your test code should be simpler +than the code it is testing, yes?) + =head1 SEE ALSO L<Test::Harness> and various test coverage analysis tools. diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 8102ff4cac..e2c47d62ad 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -68,7 +68,9 @@ sub runtests { my $s = $switches; $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/; $fh->close or print "can't close $test. $!\n"; - my $cmd = "$^X $s $test|"; + my $cmd = ($ENV{'COMPILE_TEST'})? +"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |" + : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; $fh->open($cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 62da1d273f..d3a89f03b8 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -1,140 +1,93 @@ package Text::ParseWords; -require 5.000; -use Carp; +use vars qw($VERSION @ISA @EXPORT); +$VERSION = "3.0"; -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; +require 5.000; -require Exporter; +use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(shellwords quotewords); +@EXPORT = qw(shellwords quotewords nested_quotewords parse_line); @EXPORT_OK = qw(old_shellwords); -=head1 NAME - -Text::ParseWords - parse text into an array of tokens - -=head1 SYNOPSIS - - use Text::ParseWords; - @words = "ewords($delim, $keep, @lines); - @words = &shellwords(@lines); - @words = &old_shellwords(@lines); - -=head1 DESCRIPTION -"ewords() accepts a delimiter (which can be a regular expression) -and a list of lines and then breaks those lines up into a list of -words ignoring delimiters that appear inside quotes. - -The $keep argument is a boolean flag. If true, the quotes are kept -with each word, otherwise quotes are stripped in the splitting process. -$keep also defines whether unprotected backslashes are retained. - -A &shellwords() replacement is included to demonstrate the new package. -This version differs from the original in that it will _NOT_ default -to using $_ if no arguments are given. I personally find the old behavior -to be a mis-feature. - -"ewords() works by simply jamming all of @lines into a single -string in $_ and then pulling off words a bit at a time until $_ -is exhausted. +sub shellwords { + local(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + return(quotewords('\s+', 0, @lines)); +} -=head1 AUTHORS -Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 -Basically an update and generalization of the old shellwords.pl. -Much code shamelessly stolen from the old version (author unknown). +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} -=cut -1; -__END__ -sub shellwords { - local(@lines) = @_; - $lines[$#lines] =~ s/\s+$//; - "ewords('\s+', 0, @lines); +sub nested_quotewords { + my($delim, $keep, @lines) = @_; + my($i, @allwords); + + for ($i = 0; $i < @lines; $i++) { + @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]); + return() unless (@{$allwords[$i]} || !length($lines[$i])); + } + return(@allwords); } -sub quotewords { - -# The inner "for" loop builds up each word (or $field) one $snippet -# at a time. A $snippet is a quoted string, a backslashed character, -# or an unquoted string. We fall out of the "for" loop when we reach -# the end of $_ or when we hit a delimiter. Falling out of the "for" -# loop, we push the $field we've been building up onto the list of -# @words we'll be returning, and then loop back and pull another word -# off of $_. -# -# The first two cases inside the "for" loop deal with quoted strings. -# The first case matches a double quoted string, removes it from $_, -# and assigns the double quoted string to $snippet in the body of the -# conditional. The second case handles single quoted strings. In -# the third case we've found a quote at the current beginning of $_, -# but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we croak with an error (which can -# be caught by eval()). -# -# The next case handles backslashed characters, and the next case is the -# exit case on reaching the end of the string or finding a delimiter. -# -# Otherwise, we've found an unquoted thing and we pull of characters one -# at a time until we reach something that could start another $snippet-- -# a quote of some sort, a backslash, or the delimiter. This one character -# at a time behavior was necessary if the delimiter was going to be a -# regexp (love to hear it if you can figure out a better way). - - my ($delim, $keep, @lines) = @_; - my (@words, $snippet, $field); - - local $_ = join ('', @lines); - - while (length) { - $field = ''; +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($quote, $quoted, $unquoted, $delim, $word, @pieces); - for (;;) { - $snippet = ''; + while (length($line)) { + ($quote, $quoted, $unquoted, $delim) = + $line =~ m/^(["']) # a $quote + ((?:\\.|[^\1\\])*?) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|$delimiter|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + /x; # extended layout - if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) { - $snippet = $1; - $snippet = qq|"$snippet"| if $keep; - } - elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) { - $snippet = $1; - $snippet = "'$snippet'" if $keep; - } - elsif (/^["']/) { - croak 'Unmatched quote'; - } - elsif (s/^\\(.)//) { - $snippet = $1; - $snippet = "\\$snippet" if $keep; - } - elsif (!length || s/^$delim//) { - last; - } - else { - while (length && !(/^$delim/ || /^['"\\]/)) { - $snippet .= substr ($_, 0, 1); - substr($_, 0, 1) = ''; - } - } + return() unless(length($&)); + $line = $'; - $field .= $snippet; + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/g; + $quoted =~ s/\\(.)/$1/g if ($quote eq '"'); + } + $word .= ($quote) ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); } - - push @words, $field; } - - return @words; + return(@pieces); } + sub old_shellwords { # Usage: @@ -154,13 +107,13 @@ sub old_shellwords { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { - croak "Unmatched double quote: $_"; + return(); } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { - croak "Unmatched single quote: $_"; + return(); } elsif (s/^\\(.)//) { $snippet = $1; @@ -178,3 +131,117 @@ sub old_shellwords { } @words; } + +1; + +__END__ + +=head1 NAME + +Text::ParseWords - parse text into an array of tokens or array of arrays + +=head1 SYNOPSIS + + use Text::ParseWords; + @lists = &nested_quotewords($delim, $keep, @lines); + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &parse_line($delim, $keep, $line); + @words = &old_shellwords(@lines); # DEPRECATED! + +=head1 DESCRIPTION + +The &nested_quotewords() and "ewords() functions accept a delimiter +(which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. "ewords() +returns all of the tokens in a single long list, while &nested_quotewords() +returns a list of token lists corresponding to the elements of @lines. +&parse_line() does tokenizing on a single string. The &*quotewords() +functions simply call &parse_lines(), so if you're only splitting +one line you can call &parse_lines() directly and save a function +call. + +The $keep argument is a boolean flag. If true, then the tokens are +split on the specified delimiter, but all other characters (quotes, +backslashes, etc.) are kept in the tokens. If $keep is false then the +&*quotewords() functions remove all quotes and backslashes that are +not themselves backslash-escaped or inside of single quotes (i.e., +"ewords() tries to interpret these characters just like the Bourne +shell). NB: these semantics are significantly different from the +original version of this module shipped with Perl 5.000 through 5.004. +As an additional feature, $keep may be the keyword "delimiters" which +causes the functions to preserve the delimiters in each string as +tokens in the token lists, in addition to preserving quote and +backslash characters. + +&shellwords() is written as a special case of "ewords(), and it +does token parsing with whitespace as a delimiter-- similar to most +Unix shells. + +=head1 EXAMPLES + +The sample program: + + use Text::ParseWords; + @words = "ewords('\s+', 0, q{this is "a test" of\ quotewords \"for you}); + $i = 0; + foreach (@words) { + print "$i: <$_>\n"; + $i++; + } + +produces: + + 0: <this> + 1: <is> + 2: <a test> + 3: <of quotewords> + 4: <"for> + 5: <you> + +demonstrating: + +=over 4 + +=item 0 +a simple word + +=item 1 +multiple spaces are skipped because of our $delim + +=item 2 +use of quotes to include a space in a word + +=item 3 +use of a backslash to include a space in a word + +=item 4 +use of a backslash to remove the special meaning of a double-quote + +=item 5 +another simple word (note the lack of effect of the +backslashed double-quote) + +=back + +Replacing C<"ewords('\s+', 0, q{this is...})> +with C<&shellwords(q{this is...})> +is a simpler way to accomplish the same thing. + +=head1 AUTHORS + +Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original +author unknown). Much of the code for &parse_line() (including the +primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>. + +Examples section another documentation provided by John Heidemann +<johnh@ISI.EDU> + +Bug reports, patches, and nagging provided by lots of folks-- thanks +everybody! Special thanks to Michael Schwern <schwern@envirolink.org> +for assuring me that a &nested_quotewords() would be useful, and to +Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about +error-checking (sort of-- you had to be there). + +=cut diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm index 0910a2ab34..0fe7fb93c2 100644 --- a/lib/Text/Wrap.pm +++ b/lib/Text/Wrap.pm @@ -1,71 +1,74 @@ package Text::Wrap; -require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug); +use strict; +use Exporter; -@ISA = (Exporter); +$VERSION = "97.02"; +@ISA = qw(Exporter); @EXPORT = qw(wrap); -@EXPORT_OK = qw($columns); +@EXPORT_OK = qw($columns $tabstop fill); -$VERSION = 97.011701; +use Text::Tabs qw(expand unexpand $tabstop); -use vars qw($VERSION $columns $debug); -use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; + $columns = 76; # <= screen width + $debug = 0; } -use Text::Tabs qw(expand unexpand); - sub wrap { - my ($ip, $xp, @t) = @_; - - my $r = ""; - my $t = expand(join(" ",@t)); - my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; - my $nl = ""; - - # remove up to a line length of things that aren't - # new lines and tabs. - - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) { - - # accept it. - $r .= unexpand($lead . $1); - - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $nl = $2; - - # repeat the above until there's none left - while ($t) { - if ( $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm ) { - print "\$2 is '$2'\n" if $debug; - $nl = $2; - $r .= unexpand("\n" . $lead . $1); - } elsif ($t =~ s/^([^\n]{$ll})//) { - $nl = "\n"; - $r .= unexpand("\n" . $lead . $1); - } - } - $r .= $nl; - } + my ($ip, $xp, @t) = @_; + + my @rv; + my $t = expand(join(" ",@t)); + + my $lead = $ip; + my $ll = $columns - length(expand($lead)) - 1; + my $nl = ""; + + $t =~ s/^\s+//; + while(length($t) > $ll) { + # remove up to a line length of things that + # aren't new lines and tabs. + if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { + my ($l,$r) = ($1,$2); + $l =~ s/\s+$//; + print "WRAP $lead$l..($r)\n" if $debug; + push @rv, unexpand($lead . $l), "\n"; + + } elsif ($t =~ s/^([^\n]{$ll})//) { + print "SPLIT $lead$1..\n" if $debug; + push @rv, unexpand($lead . $1),"\n"; + } + # recompute the leader + $lead = $xp; + $ll = $columns - length(expand($lead)) - 1; + $t =~ s/^\s+//; + } + print "TAIL $lead$t\n" if $debug; + push @rv, $lead.$t if $t ne ""; + return join '', @rv; +} - die "couldn't wrap '$t'" - if length($t) > $ll; - print "-----------$r---------\n" if $debug; +sub fill +{ + my ($ip, $xp, @raw) = @_; + my @para; + my $pp; - print "Finish up with '$lead', '$t'\n" if $debug; + for $pp (split(/\n\s+/, join("\n",@raw))) { + $pp =~ s/\s+/ /g; + my $x = wrap($ip, $xp, $pp); + push(@para, $x); + } - $r .= $lead . $t if $t ne ""; + # if paragraph_indent is the same as line_indent, + # separate paragraphs with blank lines - print "-----------$r---------\n" if $debug;; - return $r; + return join ($ip eq $xp ? "\n\n" : "\n", @para); } 1; @@ -81,9 +84,13 @@ Text::Wrap - line wrapping to form simple paragraphs print wrap($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns); + use Text::Wrap qw(wrap $columns $tabstop fill); $columns = 132; + $tabstop = 4; + + print fill($initial_tab, $subsequent_tab, @text); + print fill("", "", `cat book`); =head1 DESCRIPTION @@ -93,6 +100,12 @@ Indentation is controlled for the first line ($initial_tab) and all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns should be set to the full width of your output device. +Text::Wrap::fill() is a simple multi-paragraph formatter. It formats +each paragraph separately and then joins them together when it's done. It +will destory any whitespace in the original text. It breaks text into +paragraphs by looking for whitespace after a newline. In other respects +it acts like wrap(). + =head1 EXAMPLE print wrap("\t","","This is a bit of text that forms @@ -102,44 +115,11 @@ should be set to the full width of your output device. It's not clear what the correct behavior should be when Wrap() is presented with a word that is longer than a line. The previous -behavior was to die. Now the word is split at line-length. +behavior was to die. Now the word is now split at line-length. =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. +others. Updated by Jacqui Caren. =cut - -Latest change by Andreas Koenig <k@anna.in-berlin.de> - 1/17/97 - - print fill($initial_tab, $subsequent_tab, @text); - - print fill("", "", `cat book`); - -Text::Wrap::fill() is a simple multi-paragraph formatter. It formats -each paragraph separately and then joins them together when it's done. It -will destory any whitespace in the original text. It breaks text into -paragraphs by looking for whitespace after a newline. In other respects -it acts like wrap(). - -# Tim Pierce did a faster version of this: - -sub fill -{ - my ($ip, $xp, @raw) = @_; - my @para; - my $pp; - - for $pp (split(/\n\s+/, join("\n",@raw))) { - $pp =~ s/\s+/ /g; - my $x = wrap($ip, $xp, $pp); - push(@para, $x); - } - - # if paragraph_indent is the same as line_indent, - # separate paragraphs with blank lines - - return join ($ip eq $xp ? "\n\n" : "\n", @para); -} - diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 89fd61dd74..7ed18962e9 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -67,7 +67,7 @@ Return the (key, value) pair for the first key in the hash. =item NEXTKEY this, lastkey -Return the next (key, value) pair for the hash. +Return the next key for the hash. =item EXISTS this, key diff --git a/lib/base.pm b/lib/base.pm index e20a64bc9a..4c4fb8b86b 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -34,6 +34,9 @@ sub import { foreach my $base (@_) { unless (defined %{"$base\::"}) { eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (defined %{"$base\::"}) { require Carp; Carp::croak("Base class package \"$base\" is empty.\n", diff --git a/lib/chat2.pl b/lib/chat2.pl index 0d9a7d3d50..094d3dff21 100644 --- a/lib/chat2.pl +++ b/lib/chat2.pl @@ -275,7 +275,9 @@ sub print { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } - print S @_; + + local $out = join $, , @_; + syswrite(S, $out, length $out); if( $chat'debug ){ print STDERR "printed:"; print STDERR @_; diff --git a/lib/constant.pm b/lib/constant.pm index a0d4f9d5cd..464e20cd91 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -106,6 +106,15 @@ name as a constant. This is probably a Good Thing. Unlike constants in some languages, these cannot be overridden on the command line or via environment variables. +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will +be interpreted as a string. Use C<$hash{CONSTANT()}> or +C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from +kicking in. Similarly, since the C<=E<gt>> operator quotes a bareword +immediately to its left you have to say C<CONSTANT() =E<gt> 'value'> +instead of C<CONSTANT =E<gt> 'value'>. + =head1 AUTHOR Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from diff --git a/lib/integer.pm b/lib/integer.pm index a88ce6a77c..894931896f 100644 --- a/lib/integer.pm +++ b/lib/integer.pm @@ -12,11 +12,22 @@ integer - Perl pragma to compute arithmetic in integer instead of double =head1 DESCRIPTION -This tells the compiler that it's okay to use integer operations +This tells the compiler to use integer operations from here to the end of the enclosing BLOCK. On many machines, this doesn't matter a great deal for most computations, but on those without floating point hardware, it can make a big difference. +Note that this affects the operations, not the numbers. If you run this +code + + use integer; + $x = 1.5; + $y = $x + 1; + $z = -1.5; + +you'll be left with C<$x == 1.5>, C<$y == 2> and C<$z == -1>. The $z +case happens because unary C<-> counts as an operation. + See L<perlmod/Pragmatic Modules>. =cut diff --git a/lib/lib.pm b/lib/lib.pm index 4d32f96355..6e6e15e4ce 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -18,6 +18,10 @@ sub import { Carp::carp("Empty compile time value given to use lib"); # at foo.pl line ... } + if (-e && ! -d _) { + require Carp; + Carp::carp("Parameter to use lib must be directory, not file"); + } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a4a1b1aae6..3ca0adc3d5 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -178,7 +178,8 @@ $inhibit_exit = $option{PrintRet} = 1; globPrint PrintRet UsageOnly frame AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments - signalLevel warnLevel dieLevel inhibit_exit); + signalLevel warnLevel dieLevel inhibit_exit + ImmediateStop); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -194,6 +195,7 @@ $inhibit_exit = $option{PrintRet} = 1; AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, ); %optionAction = ( @@ -363,6 +365,9 @@ sub DB { } $single = 0; # return; # Would not print trace! + } elsif ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; } } $runnonstop = 0 if $single or $signal; # Disable it if interactive. @@ -1255,6 +1260,10 @@ sub postponed_sub { } sub postponed { + if ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; + } return &postponed_sub unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. # Cannot be done before the file is compiled @@ -1795,6 +1804,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<tkRunning>: run Tk while prompting (with ReadLine); I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; I<inhibit_exit> Allows stepping off the end of the script. + I<ImmediateStop> Debugger should stop as early as possible. The following options affect what happens with B<V>, B<X>, and B<x> commands: I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); I<compactDump>, I<veryCompact>: change style of array and hash dump; diff --git a/lib/strict.pm b/lib/strict.pm index 8492e933fd..940e8bf7ff 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -38,6 +38,7 @@ use symbolic references (see L<perlref>). =item C<strict vars> This generates a compile-time error if you access a variable that wasn't +declared via C<use vars>, localized via C<my()> or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L<perlfunc/my> and @@ -48,6 +49,10 @@ L<perlfunc/local>. my $foo = 10; # ok, my() var local $foo = 9; # blows up + package Cinna; + use vars qw/ $bar /; # Declares $bar in current package + $bar = 'HgS'; # ok, global declared via pragma + The local() generated a compile-time error because you just touched a global name without fully qualifying it. @@ -67,19 +72,22 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. =back -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut +$strict::VERSION = "1.01"; + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + sub bits { my $bits = 0; - my $sememe; - foreach $sememe (@_) { - $bits |= 0x00000002, next if $sememe eq 'refs'; - $bits |= 0x00000200, next if $sememe eq 'subs'; - $bits |= 0x00000400, next if $sememe eq 'vars'; - } + foreach my $s (@_){ $bits |= $bitmask{$s} || 0; }; $bits; } diff --git a/lib/subs.pm b/lib/subs.pm index 512bc9be9a..aa332a6785 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -20,7 +20,7 @@ C<use subs> declarations are not BLOCK-scoped. They are thus effective for the entire file in which they appear. You may not rescind such declarations with C<no vars> or C<no subs>. -See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. +See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>. =cut diff --git a/lib/vars.pm b/lib/vars.pm index 5723ac6c2c..5256d1199f 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -61,6 +61,6 @@ outside of the package), it can act as an acceptable substitute by pre-declaring global symbols, ensuring their availability to the later-loaded routines. -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut @@ -478,7 +478,8 @@ magic_get(SV *sv, MAGIC *mg) } sv_setpvn(sv,s,i); if (tainting) - tainted = was_tainted || RX_MATCH_TAINTED(rx); + tainted = (was_tainted || RX_MATCH_TAINTED(rx) || + (curpm->op_pmflags & PMf_TAINTMEM)); break; } } @@ -963,11 +964,33 @@ magic_setamagic(SV *sv, MAGIC *mg) #endif /* OVERLOAD */ int +magic_getnkeys(SV *sv, MAGIC *mg) +{ + HV *hv = (HV*)LvTARG(sv); + HE *entry; + I32 i = 0; + + if (hv) { + (void) hv_iterinit(hv); + if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P')) + i = HvKEYS(hv); + else { + /*SUPPRESS 560*/ + while (entry = hv_iternext(hv)) { + i++; + } + } + } + + sv_setiv(sv, (IV)i); + return 0; +} + +int magic_setnkeys(SV *sv, MAGIC *mg) { if (LvTARG(sv)) { hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); - LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */ } return 0; } @@ -1236,6 +1259,23 @@ magic_setglob(SV *sv, MAGIC *mg) } int +magic_getsubstr(SV *sv, MAGIC *mg) +{ + STRLEN len; + SV *lsv = LvTARG(sv); + char *tmps = SvPV(lsv,len); + I32 offs = LvTARGOFF(sv); + I32 rem = LvTARGLEN(sv); + + if (offs > len) + offs = len; + if (rem + offs > len) + rem = len - offs; + sv_setpvn(sv, tmps + offs, (STRLEN)rem); + return 0; +} + +int magic_setsubstr(SV *sv, MAGIC *mg) { STRLEN len; @@ -1271,6 +1311,72 @@ magic_settaint(SV *sv, MAGIC *mg) } int +magic_getvec(SV *sv, MAGIC *mg) +{ + SV *lsv = LvTARG(sv); + unsigned char *s; + unsigned long retnum; + STRLEN lsvlen; + I32 len; + I32 offset; + I32 size; + + if (!lsv) { + SvOK_off(sv); + return 0; + } + s = (unsigned char *) SvPV(lsv, lsvlen); + offset = LvTARGOFF(sv); + size = LvTARGLEN(sv); + len = (offset + size + 7) / 8; + + /* Copied from pp_vec() */ + + if (len > lsvlen) { + if (size <= 8) + retnum = 0; + else { + offset >>= 3; + if (size == 16) { + if (offset >= lsvlen) + retnum = 0; + else + retnum = (unsigned long) s[offset] << 8; + } + else if (size == 32) { + if (offset >= lsvlen) + retnum = 0; + else if (offset + 1 >= lsvlen) + retnum = (unsigned long) s[offset] << 24; + else if (offset + 2 >= lsvlen) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16); + else + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8); + } + } + } + else if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + sv_setuv(sv, (UV)retnum); + return 0; +} + +int magic_setvec(SV *sv, MAGIC *mg) { do_vecset(sv); /* XXX slurp this routine */ @@ -1289,7 +1395,7 @@ magic_getdefelem(SV *sv, MAGIC *mg) targ = HeVAL(he); } else { - AV* av = (AV*)LvTARG(sv); + AV* av = (AV*)LvTARG(sv); if ((I32)LvTARGOFF(sv) <= AvFILL(av)) targ = AvARRAY(av)[LvTARGOFF(sv)]; } @@ -540,6 +540,11 @@ find_threadsv(char *name) sawampersand = TRUE; SvREADONLY_on(sv); /* FALL THROUGH */ + + /* XXX %! tied to Errno.pm needs to be added here. + * See gv_fetchpv(). */ + /* case '!': */ + default: sv_magic(sv, 0, 0, name, 1); } @@ -1248,6 +1253,7 @@ mod(OP *o, I32 type) else if (!type) { o->op_private |= OPpLVAL_INTRO; o->op_flags &= ~OPf_SPECIAL; + hints |= HINT_BLOCK_SCOPE; } else if (type != OP_GREPSTART && type != OP_ENTERSUB) o->op_flags |= OPf_REF; @@ -1689,9 +1695,12 @@ fold_constants(register OP *o) if (type == OP_RV2GV) return newGVOP(OP_GV, 0, (GV*)sv); else { - if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) { + /* try to smush double to int, but don't smush -2.0 to -2 */ + if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && + type != OP_NEGATE) + { IV iv = SvIV(sv); - if ((double)iv == SvNV(sv)) { /* can we smush double to int */ + if ((double)iv == SvNV(sv)) { SvREFCNT_dec(sv); sv = newSViv(iv); } @@ -2428,6 +2437,7 @@ newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { + dTHR; modcount = 0; eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); @@ -2675,7 +2685,7 @@ new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) warnop = k2->op_type; break; @@ -2837,6 +2847,24 @@ newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block) || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr->op_flags & OPf_KIDS) { + OP *k1 = ((UNOP*)expr)->op_first; + OP *k2 = (k1) ? k1->op_sibling : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } } } @@ -2872,6 +2900,24 @@ newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *b || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr && (expr->op_flags & OPf_KIDS)) { + OP *k1 = ((UNOP*)expr)->op_first; + OP *k2 = (k1) ? k1->op_sibling : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } } if (!block) @@ -3313,7 +3359,8 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) { dTHR; char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch; - GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + GV *gv = gv_fetchpv(name ? name : "__ANON__", + GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV); char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; register CV *cv; I32 ix; @@ -3323,6 +3370,23 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) if (proto) SAVEFREEOP(proto); + if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had + maximum a prototype before. */ + if (SvTYPE(gv) > SVt_NULL) { + if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)) + warn("Runaway prototype"); + cv_ckproto((CV*)gv, NULL, ps); + } + if (ps) + sv_setpv((SV*)gv, ps); + else + sv_setiv((SV*)gv, -1); + SvREFCNT_dec(compcv); + compcv = NULL; + sub_generation++; + goto noblock; + } + if (!name || GvCVGEN(gv)) cv = Nullcv; else if (cv = GvCV(gv)) { @@ -3404,6 +3468,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) } } if (!block) { + noblock: copline = NOLINE; LEAVE_SCOPE(floor); return cv; @@ -3488,7 +3553,6 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) ENTER; SAVESPTR(compiling.cop_filegv); SAVEI16(compiling.cop_line); - SAVEI32(perldb); save_svref(&rs); sv_setsv(rs, nrs); @@ -4883,6 +4947,8 @@ peep(register OP *o) o->op_seq = op_seqmax++; if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && + o->op_next->op_sibling->op_type != OP_EXIT && + o->op_next->op_sibling->op_type != OP_WARN && o->op_next->op_sibling->op_type != OP_DIE) { line_t oldline = curcop->cop_line; @@ -181,9 +181,12 @@ struct pmop { REGEXP * op_pmregexp; /* compiled expression */ U16 op_pmflags; U16 op_pmpermflags; + U8 op_pmdynflags; }; -#define PMf_USED 0x0001 /* pm has been used once already */ +#define PMdf_USED 0x01 /* pm has been used once already */ + +#define PMf_TAINTMEM 0x0001 /* taint $1 etc. if target tainted */ #define PMf_ONCE 0x0002 /* use pattern only once per reset */ #define PMf_REVERSED 0x0004 /* Should be matched right->left */ /*#define PMf_ALL 0x0008*/ /* initial constant is whole pat */ @@ -2270,7 +2270,7 @@ EXT U32 opargs[] = { 0x00009c8e, /* oct */ 0x00009c8e, /* abs */ 0x00009c9c, /* length */ - 0x0091150c, /* substr */ + 0x0991150c, /* substr */ 0x0011151c, /* vec */ 0x0091151c, /* index */ 0x0091151c, /* rindex */ @@ -362,7 +362,7 @@ abs abs ck_fun fstu% S? # String stuff. length length ck_lengthconst istu% S? -substr substr ck_fun st@ S S S? +substr substr ck_fun st@ S S S? S? vec vec ck_fun ist@ S S S index index ck_index ist@ S S S? diff --git a/os2/Changes b/os2/Changes index a46b7a52a4..344939c891 100644 --- a/os2/Changes +++ b/os2/Changes @@ -166,3 +166,7 @@ after 5.004_03: after 5.004_53: Minimal thread support added. One needs to manually move pthread.h + +after 5.004_64: + Make DLL names different if thread-enabled. + Emit more informative internal DLL descriptions. diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 57d42602e9..fd3766e0d6 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -6,8 +6,17 @@ # Additional rules supported: perl_, aout_test, aout_install, use them # for a.out style perl (which may fork). +perl_version="5.00${PATCHLEVEL}_$SUBVERSION" +case "$archname" in + *-thread) dll_post=_thr + perl_version="${perl_version}-threaded";; + *) dll_post='' ;; +esac + $spitshell >>Makefile <<!GROK!THIS! +PERL_VERSION = $perl_version + AOUT_OPTIMIZE = $optimize AOUT_CCCMD = \$(CC) $aout_ccflags \$(AOUT_OPTIMIZE) AOUT_AR = $aout_ar @@ -18,17 +27,20 @@ AOUT_CLDFLAGS = $aout_ldflags AOUT_LIBPERL_DLL = libperl_dll$aout_lib_ext AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK -AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll +AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000 LD_OPT = $optimize +PERL_DLL_BASE = perl$dll_post +PERL_DLL = \$(PERL_DLL_BASE)\$(DLSUFFIX) + !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' -$(LIBPERL): perl.imp perl.dll perl5.def +$(LIBPERL): perl.imp $(PERL_DLL) perl5.def emximp -o $(LIBPERL) perl.imp -$(AOUT_LIBPERL_DLL): perl.imp perl.dll perl5.def +$(AOUT_LIBPERL_DLL): perl.imp $(PERL_DLL) perl5.def emximp -o $(AOUT_LIBPERL_DLL) perl.imp perl.imp: perl5.def @@ -38,12 +50,12 @@ perl.imp: perl5.def echo 'emx_malloc emxlibcm 402 ?' >> $@ echo 'emx_realloc emxlibcm 403 ?' >> $@ -perl.dll: $(obj) perl5.def perl$(OBJ_EXT) +$(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT) $(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def perl5.def: perl.linkexp - echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@ - echo DESCRIPTION "'Perl interpreter, export autogenerated'" >>$@ + echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE" > $@ + echo DESCRIPTION "'Perl interpreter v$(PERL_VERSION), export autogenerated'" >>$@ echo STACKSIZE 32768 >>$@ echo CODE LOADONCALL >>$@ echo DATA LOADONCALL NONSHARED MULTIPLE >>$@ @@ -68,7 +80,7 @@ perl.exports: perl.exp EXTERN.h perl.h $(CC) -DEMBED -E - | \ awk '{if ($$2 == "") print $$1}' | sort | uniq > $@ -perl.linkexp: perl.exports perl.map +perl.linkexp: perl.exports perl.map os2/os2.sym cat perl.exports os2/os2.sym perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp # We link miniperl statically, since .DLL depends on $(DYNALOADER) @@ -85,19 +97,19 @@ depend: os2ish.h dlfcn.h os2thread.h os2.c os2$(OBJ_EXT) : os2.c os2.c: os2/os2.c os2ish.h - cp $< $@ + cp -f $< $@ dl_os2.c: os2/dl_os2.c os2ish.h - cp $< $@ + cp -f $< $@ os2ish.h: os2/os2ish.h - cp $< $@ + cp -f $< $@ os2thread.h: os2/os2thread.h - cp $< $@ + cp -f $< $@ dlfcn.h: os2/dlfcn.h - cp $< $@ + cp -f $< $@ # This one is compiled OMF, so cannot fork(): @@ -40,16 +40,16 @@ const char *pthreads_states[] = { typedef struct { void *status; - pthread_cond_t cond; + perl_cond cond; enum pthreads_state state; } thread_join_t; thread_join_t *thread_join_data; int thread_join_count; -pthread_mutex_t start_thread_mutex; +perl_mutex start_thread_mutex; int -pthread_join(pthread_t tid, void **status) +pthread_join(perl_os_thread tid, void **status) { MUTEX_LOCK(&start_thread_mutex); switch (thread_join_data[tid].state) { @@ -117,7 +117,7 @@ pthread_startit(void *arg) } int -pthread_create(pthread_t *tid, const pthread_attr_t *attr, +pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, void *(*start_routine)(void*), void *arg) { void *args[2]; @@ -134,7 +134,7 @@ pthread_create(pthread_t *tid, const pthread_attr_t *attr, } int -pthread_detach(pthread_t tid) +pthread_detach(perl_os_thread tid) { MUTEX_LOCK(&start_thread_mutex); switch (thread_join_data[tid].state) { @@ -157,7 +157,7 @@ pthread_detach(pthread_t tid) /* This is a very bastardized version: */ int -os2_cond_wait(pthread_cond_t *c, pthread_mutex_t *m) +os2_cond_wait(perl_cond *c, perl_mutex *m) { int rc; if ((rc = DosResetEventSem(*c,&na)) && (rc != ERROR_ALREADY_RESET)) @@ -347,40 +347,37 @@ result(int flag, int pid) #endif } +#define EXECF_SPAWN 0 +#define EXECF_EXEC 1 +#define EXECF_TRUEEXEC 2 +#define EXECF_SPAWN_NOWAIT 3 + +/* Spawn/exec a program, revert to shell if needed. */ +/* global Argv[] contains arguments. */ + int -do_aspawn(really,mark,sp) +do_aspawn(really, flag, execf) SV *really; -register SV **mark; -register SV **sp; +U32 flag; +U32 execf; { dTHR; - register char **a; - char *tmps = NULL; - int rc; - int flag = P_WAIT, trueflag, err, secondtry = 0; - - if (sp > mark) { - New(1301,Argv, sp - mark + 3, char*); - a = Argv; - - if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); - } - - while (++mark <= sp) { - if (*mark) - *a++ = SvPVx(*mark, na); - else - *a++ = ""; - } - *a = Nullch; - - trueflag = flag; + int trueflag = flag; + int rc, secondtry = 0, err; + char *tmps; + char buf[256], *s = 0; + char *args[4]; + static char * fargs[4] + = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; + char **argsp = fargs; + char nargs = 4; + if (flag == P_WAIT) flag = P_NOWAIT; - if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path; + retry: + if (strEQ(Argv[0],"/bin/sh")) + Argv[0] = sh_path; if (Argv[0][0] != '/' && Argv[0][0] != '\\' && !(Argv[0][0] && Argv[0][1] == ':' @@ -388,18 +385,29 @@ register SV **sp; ) /* will swawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ /* We should check PERL_SH* and PERLLIB_* as well? */ - retry: - if (really && *(tmps = SvPV(really, na))) - rc = result(trueflag, spawnvp(flag,tmps,Argv)); - else - rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); - + if (!really || !*(tmps = SvPV(really, na))) + tmps = Argv[0]; +#if 0 + rc = result(trueflag, spawnvp(flag,tmps,Argv)); +#else + if (execf == EXECF_TRUEEXEC) + rc = execvp(tmps,Argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv); + else /* EXECF_SPAWN */ + rc = result(trueflag, + spawnvp(trueflag | P_NOWAIT,tmps,Argv)); +#endif if (rc < 0 && secondtry == 0 - && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */ + && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */ err = errno; if (err == ENOENT) { /* No such file. */ /* One reason may be that EMX added .exe. We suppose - that .exe-less files are automatically shellable. */ + that .exe-less files are automatically shellable. + It might have also been .cmd file without + extension. */ char *no_dir; (no_dir = strrchr(Argv[0], '/')) || (no_dir = strrchr(Argv[0], '\\')) @@ -409,34 +417,139 @@ register SV **sp; if (stat(Argv[0], &buffer) != -1) { /* File exists. */ /* Maybe we need to specify the full name here? */ goto doshell; + } else { + /* Try adding script extensions to the file name */ + char *scr; + if ((scr = find_script(Argv[0], TRUE, NULL, 0))) { + FILE *file = fopen(scr, "r"); + char *s = 0, *s1; + + Argv[0] = scr; + if (!file) + goto panic_file; + if (!fgets(buf, sizeof buf, file)) { + fclose(file); + goto panic_file; + } + if (fclose(file) != 0) { /* Failure */ + panic_file: + warn("Error reading \"%s\": %s", + scr, Strerror(errno)); + goto doshell; + } + if (buf[0] == '#') { + if (buf[1] == '!') + s = buf + 2; + } else if (buf[0] == 'e') { + if (strnEQ(buf, "extproc", 7) + && isSPACE(buf[7])) + s = buf + 8; + } else if (buf[0] == 'E') { + if (strnEQ(buf, "EXTPROC", 7) + && isSPACE(buf[7])) + s = buf + 8; + } + if (!s) + goto doshell; + s1 = s; + nargs = 0; + argsp = args; + while (1) { + while (isSPACE(*s)) + s++; + if (*s == 0) + break; + if (nargs == 4) { + nargs = -1; + break; + } + args[nargs++] = s; + while (*s && !isSPACE(*s)) + s++; + if (*s == 0) + break; + *s++ = 0; + } + if (nargs == -1) { + warn("Too many args on %.*s line of \"%s\"", + s1 - buf, buf, scr); + nargs = 4; + argsp = fargs; + } + goto doshell; + } } } + /* Restore errno */ + errno = err; } else if (err == ENOEXEC) { /* Need to send to shell. */ doshell: + { + char **a = Argv; + + while (a[1]) /* Get to the end */ + a++; while (a >= Argv) { - *(a + 2) = *a; + *(a + nargs) = *a; /* Argv was preallocated to be + long enough. */ a--; } - *Argv = sh_path; - *(Argv + 1) = "-c"; + while (nargs-- >= 0) + Argv[nargs] = argsp[nargs]; secondtry = 1; goto retry; + } } } if (rc < 0 && dowarn) - warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + warn("Can't %s \"%s\": %s\n", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + Argv[0], Strerror(err)); + if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) + && ((trueflag & 0xFF) == P_WAIT)) + rc = 255 << 8; /* Emulate the fork(). */ + + return rc; +} + +int +do_aspawn(really,mark,sp) +SV *really; +register SV **mark; +register SV **sp; +{ + dTHR; + register char **a; + char *tmps = NULL; + int rc; + int flag = P_WAIT, trueflag, err, secondtry = 0; + + if (sp > mark) { + New(1301,Argv, sp - mark + 3, char*); + a = Argv; + + if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { + ++mark; + flag = SvIVx(*mark); + } + + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, na); + else + *a++ = ""; + } + *a = Nullch; + + rc = do_spawn_ve(really, flag, EXECF_SPAWN); } else rc = -1; do_execfree(); return rc; } -#define EXECF_SPAWN 0 -#define EXECF_EXEC 1 -#define EXECF_TRUEEXEC 2 -#define EXECF_SPAWN_NOWAIT 3 - +/* Try converting 1-arg form to (usually shell-less) multi-arg form. */ int do_spawn2(cmd, execf) char *cmd; @@ -501,6 +614,8 @@ int execf; } else if (*s == '\\' && !seenspace) { continue; /* Allow backslashes in names */ } + /* We do not convert this to do_spawn_ve since shell + should be smart enough to start itself gloriously. */ doshell: if (execf == EXECF_TRUEEXEC) return execl(shell,shell,copt,cmd,(char*)0); @@ -523,7 +638,8 @@ int execf; } } - New(1303,Argv, (s - cmd) / 2 + 2, char*); + /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ + New(1303,Argv, (s - cmd + 11) / 2, char*); Cmd = savepvn(cmd, s-cmd); a = Argv; for (s = Cmd; *s;) { @@ -535,44 +651,9 @@ int execf; *s++ = '\0'; } *a = Nullch; - if (Argv[0]) { - int err; - - if (execf == EXECF_TRUEEXEC) - rc = execvp(Argv[0],Argv); - else if (execf == EXECF_EXEC) - rc = spawnvp(P_OVERLAY,Argv[0],Argv); - else if (execf == EXECF_SPAWN_NOWAIT) - rc = spawnvp(P_NOWAIT,Argv[0],Argv); - else - rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); - if (rc < 0) { - err = errno; - if (err == ENOENT) { /* No such file. */ - /* One reason may be that EMX added .exe. We suppose - that .exe-less files are automatically shellable. */ - char *no_dir; - (no_dir = strrchr(Argv[0], '/')) - || (no_dir = strrchr(Argv[0], '\\')) - || (no_dir = Argv[0]); - if (!strchr(no_dir, '.')) { - struct stat buffer; - if (stat(Argv[0], &buffer) != -1) { /* File exists. */ - /* Maybe we need to specify the full name here? */ - goto doshell; - } - } - } else if (err == ENOEXEC) { /* Need to send to shell. */ - goto doshell; - } - } - if (rc < 0 && dowarn) - warn("Can't %s \"%s\": %s", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - Argv[0], Strerror(err)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ - } else + if (Argv[0]) + rc = do_spawn_ve(NULL, 0, execf); + else rc = -1; if (news) Safefree(news); do_execfree(); @@ -643,7 +724,8 @@ char *mode; dup2(newfd, *mode == 'r'); /* Return std* back. */ close(newfd); } - close(p[that]); + if (p[that] == (*mode == 'r')) + close(p[that]); if (pid == -1) { close(p[this]); return NULL; @@ -881,6 +963,9 @@ mod2fname(sv) } avlen --; } +#ifdef USE_THREADS + sum++; /* Avoid conflict of DLLs in memory. */ +#endif fname[pos] = 'A' + (sum % 26); fname[pos + 1] = 'A' + (sum / 26 % 26); fname[pos + 2] = '\0'; diff --git a/os2/os2thread.h b/os2/os2thread.h index 44dec3f244..d56fe160dd 100644 --- a/os2/os2thread.h +++ b/os2/os2thread.h @@ -1,10 +1,16 @@ #include <sys/builtin.h> #include <sys/fmutex.h> #include <sys/rmutex.h> -typedef int pthread_t; -typedef _rmutex pthread_mutex_t; -/*typedef HEV pthread_cond_t;*/ -typedef unsigned long pthread_cond_t; -typedef int pthread_key_t; +typedef int perl_os_thread; + +typedef _rmutex perl_mutex; + +/*typedef HEV perl_cond;*/ /* Will include os2.h into all C files. */ +typedef unsigned long perl_cond; + +typedef int perl_key; + typedef unsigned long pthread_attr_t; #define PTHREADS_INCLUDED +#define pthread_attr_init(arg) 0 +#define pthread_attr_setdetachstate(arg1,arg2) 0 diff --git a/os2/perl2cmd.pl b/os2/perl2cmd.pl index e774f773d0..f9cc03bdac 100644 --- a/os2/perl2cmd.pl +++ b/os2/perl2cmd.pl @@ -23,7 +23,7 @@ foreach $file (<$idir/*>) { $base =~ s|.*/||; $file =~ s|/|\\|g ; print "Processing $file => $dir\\$base.cmd\n"; - system 'cmd.exe', '/c', "echo extproc perl -S >$dir\\$base.cmd"; + system 'cmd.exe', '/c', "echo extproc perl -S>$dir\\$base.cmd"; system 'cmd.exe', '/c', "type $file >> $dir\\$base.cmd"; } diff --git a/patchlevel.h b/patchlevel.h index be0c773a97..292d76f308 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,6 +1,6 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ #define PATCHLEVEL 4 -#define SUBVERSION 64 +#define SUBVERSION 65 /* local_patches -- list of locally applied less-than-subversion patches. @@ -88,6 +88,7 @@ static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *, int *fd)); static void usage _((char *)); static void validate_suid _((char *, char*, int)); +static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); #endif #ifdef PERL_OBJECT @@ -231,9 +232,10 @@ perl_construct(register PerlInterpreter *sv_interp) localpatches = local_patches; /* For possible -v */ #endif - PerlIO_init(); /* Hook to IO system */ + PerlIO_init(); /* Hook to IO system */ - fdpid = newAV(); /* for remembering popen pids by fd */ + fdpid = newAV(); /* for remembering popen pids by fd */ + modglobal = newHV(); /* pointers to per-interpreter module globals */ DEBUG( { New(51,debname,128,char); @@ -380,6 +382,12 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(parsehook); parsehook = Nullsv; + /* call exit list functions */ + while (exitlistlen-- > 0) + exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr); + + Safefree(exitlist); + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -417,12 +425,9 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(inplace); inplace = Nullch; - Safefree(e_tmpname); - e_tmpname = Nullch; - - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; + if (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } /* magical thingies */ @@ -589,6 +594,15 @@ perl_free(PerlInterpreter *sv_interp) #endif } +void +perl_atexit(void (*fn) (void *), void *ptr) +{ + Renew(exitlist, exitlistlen+1, PerlExitListEntry); + exitlist[exitlistlen].fn = fn; + exitlist[exitlistlen].ptr = ptr; + ++exitlistlen; +} + int #ifdef PERL_OBJECT CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) @@ -604,7 +618,6 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a char *validarg = ""; I32 oldscope; AV* comppadlist; - int e_tmpfd = -1; dJMPENV; int ret; int fdscript = -1; @@ -632,7 +645,6 @@ setuid perl scripts securely.\n"); #ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; #endif - e_tmpname = Nullch; if (do_undump) { @@ -696,6 +708,7 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case ' ': case '0': case 'F': case 'a': @@ -726,48 +739,21 @@ setuid perl scripts securely.\n"); case 'e': if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); - if (!e_fp) { -#ifdef HAS_UMASK - int oldumask = PerlLIO_umask(0177); -#endif - e_tmpname = savepv(TMPPATH); -#ifdef HAS_MKSTEMP - e_tmpfd = PerlLIO_mkstemp(e_tmpname); -#else /* use mktemp() */ - (void)PerlLIO_mktemp(e_tmpname); - if (!*e_tmpname) - croak("Cannot generate temporary filename"); -# if defined(HAS_OPEN3) && defined(O_EXCL) - e_tmpfd = open(e_tmpname, - O_WRONLY | O_CREAT | O_EXCL, - 0600); -# else - (void)UNLINK(e_tmpname); - /* Yes, potential race. But at least we can say we tried. */ - e_fp = PerlIO_open(e_tmpname,"w"); -# endif -#endif /* ifdef HAS_MKSTEMP */ -#if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL)) - if (e_tmpfd < 0) - croak("Cannot create temporary file \"%s\"", e_tmpname); - e_fp = PerlIO_fdopen(e_tmpfd,"w"); -#endif - if (!e_fp) - croak("Cannot create temporary file \"%s\"", e_tmpname); -#ifdef HAS_UMASK - (void)PerlLIO_umask(oldumask); -#endif + if (!e_script) { + e_script = newSVpv("",0); + filter_add(read_e_script, NULL); } if (*++s) - PerlIO_puts(e_fp,s); + sv_catpv(e_script, s); else if (argv[1]) { - PerlIO_puts(e_fp,argv[1]); + sv_catpv(e_script, argv[1]); argc--,argv++; } else croak("No code specified for -e"); - (void)PerlIO_putc(e_fp,'\n'); + sv_catpv(e_script, "\n"); break; + case 'I': /* -I handled both here and in moreswitches() */ forbid_setid("-I"); if (!*++s && (s=argv[1]) != Nullch) { @@ -902,16 +888,9 @@ print \" \\@INC:\\n @INC\\n\";"); if (!scriptname) scriptname = argv[0]; - if (e_fp) { - if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) { -#ifndef MULTIPLICITY - warn("Did you forget to compile with -DMULTIPLICITY?"); -#endif - croak("Can't write to temp file for -e: %s", Strerror(errno)); - } - e_fp = Nullfp; + if (e_script) { argc++,argv--; - scriptname = e_tmpname; + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } else if (scriptname == Nullch) { #ifdef MSDOS @@ -965,6 +944,9 @@ print \" \\@INC:\\n @INC\\n\";"); #endif init_predump_symbols(); + /* init_postdump_symbols not currently designed to be called */ + /* more than once (ENV isn't cleared first, for example) */ + /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -985,11 +967,9 @@ print \" \\@INC:\\n @INC\\n\";"); curcop->cop_line = 0; curstash = defstash; preprocess = FALSE; - if (e_tmpname) { - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - e_tmpfd = -1; + if (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } /* now that script is parsed, we can modify record separator */ @@ -1200,6 +1180,8 @@ perl_call_method(char *methname, I32 flags) XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; pp_method(ARGS); + if(op == &myop) + op = Nullop; return perl_call_sv(*stack_sp--, flags); } @@ -1244,7 +1226,8 @@ perl_call_sv(SV *sv, I32 flags) && (DBcv || (DBcv = GvCV(DBsub))) /* Try harder, since this may have been a sighandler, thus * curstash may be meaningless. */ - && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)) + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash) + && !(flags & G_NODEBUG)) op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { @@ -1502,7 +1485,7 @@ usage(char *name) /* XXX move this out into a module ? */ "-T turn on tainting checks", "-u dump core after parsing script", "-U allow unsafe operations", -"-v print version number and patchlevel of perl", +"-v print version number, patchlevel plus VERY IMPORTANT perl info", "-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", @@ -1595,8 +1578,11 @@ moreswitches(char *s) inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = inplace; *s && !isSPACE(*s); s++) ; - if (*s) + if (*s) { *s++ = '\0'; + if (*s == '-') /* Additional switches on #! line. */ + s++; + } return s; case 'I': /* -I handled both here and in parse_perl() */ forbid_setid("-I"); @@ -1729,7 +1715,10 @@ moreswitches(char *s) #endif printf("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); +GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ +Complete documentation for Perl, including FAQ lists, should be found on\n\ +this system using `man perl' or `perldoc perl'. If you have access to the\n\ +Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); PerlProc_exit(0); case 'w': dowarn = TRUE; @@ -1765,6 +1754,7 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") /* compliments of Tom Christiansen */ /* unexec() can be found in the Gnu emacs distribution */ +/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ void my_unexec(void) @@ -1772,18 +1762,16 @@ my_unexec(void) #ifdef UNEXEC SV* prog; SV* file; - int status; + int status = 1; extern int etext; - prog = newSVpv(BIN_EXP); + prog = newSVpv(BIN_EXP, 0); sv_catpv(prog, "/perl"); - file = newSVpv(origfilename); + file = newSVpv(origfilename, 0); sv_catpv(file, ".perldump"); - status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); - if (status) - PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", - SvPVX(prog), SvPVX(file)); + unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); + /* unexec prints msg to stderr in case of failure */ PerlProc_exit(status); #else # ifdef VMS @@ -1836,201 +1824,9 @@ STATIC void open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; - char *xfound = Nullch; - char *xfailed = Nullch; register char *s; - I32 len; - int retval; -#if defined(DOSISH) && !defined(OS2) && !defined(atarist) -# define SEARCH_EXTS ".bat", ".cmd", NULL -# define MAX_EXT_LEN 4 -#endif -#ifdef OS2 -# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL -# define MAX_EXT_LEN 4 -#endif -#ifdef VMS -# define SEARCH_EXTS ".pl", ".com", NULL -# define MAX_EXT_LEN 4 -#endif - /* additional extensions to try in each dir if scriptname not found */ -#ifdef SEARCH_EXTS - char *ext[] = { SEARCH_EXTS }; - int extidx = 0, i = 0; - char *curext = Nullch; -#else -# define MAX_EXT_LEN 0 -#endif - - /* - * If dosearch is true and if scriptname does not contain path - * delimiters, search the PATH for scriptname. - * - * If SEARCH_EXTS is also defined, will look for each - * scriptname{SEARCH_EXTS} whenever scriptname is not found - * while searching the PATH. - * - * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search - * proceeds as follows: - * If DOSISH or VMSISH: - * + look for ./scriptname{,.foo,.bar} - * + search the PATH for scriptname{,.foo,.bar} - * - * If !DOSISH: - * + look *only* in the PATH for scriptname{,.foo,.bar} (note - * this will not look in '.' if it's not in the PATH) - */ -#ifdef VMS -# ifdef ALWAYS_DEFTYPES - len = strlen(scriptname); - if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int hasdir, idx = 0, deftypes = 1; - bool seen_dot = 1; - - hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ; -# else - if (dosearch) { - int hasdir, idx = 0, deftypes = 1; - bool seen_dot = 1; - - hasdir = (strpbrk(scriptname,":[</") != Nullch) ; -# endif - /* The first time through, just add SEARCH_EXTS to whatever we - * already have, so we can check for default file types. */ - while (deftypes || - (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) - { - if (deftypes) { - deftypes = 0; - *tokenbuf = '\0'; - } - if ((strlen(tokenbuf) + strlen(scriptname) - + MAX_EXT_LEN) >= sizeof tokenbuf) - continue; /* don't search dir with too-long name */ - strcat(tokenbuf, scriptname); -#else /* !VMS */ - -#ifdef DOSISH - if (strEQ(scriptname, "-")) - dosearch = 0; - if (dosearch) { /* Look in '.' first. */ - char *cur = scriptname; -#ifdef SEARCH_EXTS - if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ - while (ext[i]) - if (strEQ(ext[i++],curext)) { - extidx = -1; /* already has an ext */ - break; - } - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&statbuf) >= 0) { - dosearch = 0; - scriptname = cur; -#ifdef SEARCH_EXTS - break; -#endif - } -#ifdef SEARCH_EXTS - if (cur == scriptname) { - len = strlen(scriptname); - if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) - break; - cur = strcpy(tokenbuf, scriptname); - } - } while (extidx >= 0 && ext[extidx] /* try an extension? */ - && strcpy(tokenbuf+len, ext[extidx++])); -#endif - } -#endif - - if (dosearch && !strchr(scriptname, '/') -#ifdef DOSISH - && !strchr(scriptname, '\\') -#endif - && (s = PerlEnv_getenv("PATH"))) { - bool seen_dot = 0; - - bufend = s + strlen(s); - while (s < bufend) { -#if defined(atarist) || defined(DOSISH) - for (len = 0; *s -# ifdef atarist - && *s != ',' -# endif - && *s != ';'; len++, s++) { - if (len < sizeof tokenbuf) - tokenbuf[len] = *s; - } - if (len < sizeof tokenbuf) - tokenbuf[len] = '\0'; -#else /* ! (atarist || DOSISH) */ - s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, - ':', - &len); -#endif /* ! (atarist || DOSISH) */ - if (s < bufend) - s++; - if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) - continue; /* don't search dir with too-long name */ - if (len -#if defined(atarist) || defined(DOSISH) - && tokenbuf[len - 1] != '/' - && tokenbuf[len - 1] != '\\' -#endif - ) - tokenbuf[len++] = '/'; - if (len == 2 && tokenbuf[0] == '.') - seen_dot = 1; - (void)strcpy(tokenbuf + len, scriptname); -#endif /* !VMS */ - -#ifdef SEARCH_EXTS - len = strlen(tokenbuf); - if (extidx > 0) /* reset after previous loop */ - extidx = 0; - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); - retval = PerlLIO_stat(tokenbuf,&statbuf); -#ifdef SEARCH_EXTS - } while ( retval < 0 /* not there */ - && extidx>=0 && ext[extidx] /* try an extension? */ - && strcpy(tokenbuf+len, ext[extidx++]) - ); -#endif - if (retval < 0) - continue; - if (S_ISREG(statbuf.st_mode) - && cando(S_IRUSR,TRUE,&statbuf) -#ifndef DOSISH - && cando(S_IXUSR,TRUE,&statbuf) -#endif - ) - { - xfound = tokenbuf; /* bingo! */ - break; - } - if (!xfailed) - xfailed = savepv(tokenbuf); - } -#ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) -#endif - seen_dot = 1; /* Disable message. */ - if (!xfound) - croak("Can't %s %s%s%s", - (xfailed ? "execute" : "find"), - (xfailed ? xfailed : scriptname), - (xfailed ? "" : " on PATH"), - (xfailed || seen_dot) ? "" : ", '.' not in PATH"); - if (xfailed) - Safefree(xfailed); - scriptname = xfound; - } + scriptname = find_script(scriptname, dosearch, NULL, 0); if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { char *s = scriptname + 8; @@ -2042,7 +1838,7 @@ open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) } else *fdscript = -1; - origfilename = savepv(e_tmpname ? "-e" : scriptname); + origfilename = savepv(e_script ? "-e" : scriptname); curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; @@ -2137,9 +1933,6 @@ sed %s -e \"/^[^#]/b\" \ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } - if (e_tmpname) { - e_fp = rsfp; - } if (!rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ @@ -2425,6 +2218,23 @@ find_beginning(void) } } + +STATIC I32 +read_e_script(int idx, SV *buf_sv, int maxlen) +{ + char *p, *nl; + FILTER_READ(idx+1, buf_sv, maxlen); + p = SvPVX(e_script); + nl = strchr(p, '\n'); + nl = (nl) ? nl+1 : SvEND(e_script); + if (nl-p == 0) + return 0; + sv_catpvn(buf_sv, p, nl-p); + sv_chop(e_script, nl); + return 1; +} + + STATIC void init_ids(void) { @@ -2724,7 +2534,7 @@ init_perllib(void) ARCHLIB PRIVLIB SITEARCH and SITELIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, FALSE); + incpush(APPLLIB_EXP, TRUE); #endif #ifdef ARCHLIB_EXP @@ -2882,7 +2692,6 @@ init_main_thread() SvLEN_set(thrsv, sizeof(thr)); *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ thr->oursv = thrsv; - curcop = &compiling; chopset = " \n-"; MUTEX_LOCK(&threads_mutex); @@ -3030,10 +2839,16 @@ my_failure_exit(void) STATUS_NATIVE_SET(vaxc$errno); } #else + int exitstatus; if (errno & 255) STATUS_POSIX_SET(errno); - else if (STATUS_POSIX == 0) - STATUS_POSIX_SET(255); + else { + exitstatus = STATUS_POSIX >> 8; + if (exitstatus & 255) + STATUS_POSIX_SET(exitstatus); + else + STATUS_POSIX_SET(255); + } #endif my_exit_jump(); } @@ -3046,14 +2861,9 @@ my_exit_jump(void) I32 gimme; SV **newsp; - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; + if (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } POPSTACK_TO(mainstack); @@ -3066,6 +2876,3 @@ my_exit_jump(void) JMPENV_JUMP(2); } - - - @@ -195,7 +195,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); #define SOFT_CAST(type) (type) #endif -#ifndef BYTEORDER +#ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */ # define BYTEORDER 0x1234 #endif @@ -800,12 +800,21 @@ Free_t Perl_free _((Malloc_t where)); # ifdef convex # define Quad_t long long # else -# if BYTEORDER > 0xFFFF +# if LONGSIZE == 8 # define Quad_t long # endif # endif #endif +/* XXX Experimental set-up for long long. Just add -DUSE_LONG_LONG + to your ccflags. --Andy Dougherty 4/1998 +*/ +#ifdef USE_LONG_LONG +# if defined(HAS_LONG_LONG) && LONGLONGSIZE == 8 +# define Quad_t long long +# endif +#endif + #ifdef Quad_t # define HAS_QUAD typedef Quad_t IV; @@ -1827,6 +1836,12 @@ public: void* operator new(size_t nSize, IPerlMem *pvtbl); #endif /* PERL_OBJECT */ +/* Interpreter exitlist entry */ +typedef struct exitlistentry { + void (*fn) _((void*)); + void *ptr; +} PerlExitListEntry; + #ifdef PERL_GLOBAL_STRUCT struct perl_vars { #include "perlvars.h" @@ -1989,13 +2004,15 @@ EXT MGVTBL vtbl_glob = {magic_getglob, 0, 0, 0}; EXT MGVTBL vtbl_mglob = {0, magic_setmglob, 0, 0, 0}; -EXT MGVTBL vtbl_nkeys = {0, magic_setnkeys, +EXT MGVTBL vtbl_nkeys = {magic_getnkeys, + magic_setnkeys, 0, 0, 0}; EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint, 0, 0, 0}; -EXT MGVTBL vtbl_substr = {0, magic_setsubstr, +EXT MGVTBL vtbl_substr = {magic_getsubstr, magic_setsubstr, 0, 0, 0}; -EXT MGVTBL vtbl_vec = {0, magic_setvec, +EXT MGVTBL vtbl_vec = {magic_getvec, + magic_setvec, 0, 0, 0}; EXT MGVTBL vtbl_pos = {magic_getpos, magic_setpos, @@ -2198,7 +2215,7 @@ enum { #endif /* OVERLOAD */ -#define PERLDB_ALL 0xff +#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */ #define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */ #define PERLDBf_LINE 0x02 /* Keep line #. */ #define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */ @@ -2206,6 +2223,8 @@ enum { later inspections. */ #define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */ #define PERLDBf_SINGLE 0x20 /* Start with single-step on. */ +#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */ +#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */ #define PERLDB_SUB (perldb && (perldb & PERLDBf_SUB)) #define PERLDB_LINE (perldb && (perldb & PERLDBf_LINE)) @@ -2213,6 +2232,8 @@ enum { #define PERLDB_INTER (perldb && (perldb & PERLDBf_INTER)) #define PERLDB_SUBLINE (perldb && (perldb & PERLDBf_SUBLINE)) #define PERLDB_SINGLE (perldb && (perldb & PERLDBf_SINGLE)) +#define PERLDB_SUB_NN (perldb && (perldb & (PERLDBf_NONAME))) +#define PERLDB_GOTO (perldb && (perldb & PERLDBf_GOTO)) #ifdef USE_LOCALE_NUMERIC diff --git a/perlsdio.h b/perlsdio.h index a539a0a3d9..efc52e1cd4 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -272,8 +272,14 @@ #define fputc(c,f) PerlIO_putc(f,c) #define fputs(s,f) PerlIO_puts(f,s) #define getc(f) PerlIO_getc(f) +#ifdef getc_unlocked +#undef getc_unlocked +#endif #define getc_unlocked(f) PerlIO_getc(f) #define putc(c,f) PerlIO_putc(f,c) +#ifdef putc_unlocked +#undef putc_unlocked +#endif #define putc_unlocked(c,f) PerlIO_putc(c,f) #define ungetc(c,f) PerlIO_ungetc(f,c) #if 0 diff --git a/plan9/config.plan9 b/plan9/config.plan9 index 463c0942fb..6916622bf3 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -1144,12 +1144,17 @@ * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ #define I_PWD /**/ #undef PWQUOTA /**/ #undef PWAGE /**/ #undef PWCHANGE /**/ #undef PWCLASS /**/ #undef PWEXPIRE /**/ +#define PWGECOS /**/ #undef PWCOMMENT /**/ /* I_STDDEF: diff --git a/pod/Makefile b/pod/Makefile index 7eeabd943b..16f90a1891 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -9,6 +9,7 @@ POD2HTML = pod2html \ all: $(CONVERTERS) man PERL = ../miniperl +REALPERL = ../perl POD = \ perl.pod \ @@ -238,9 +239,11 @@ toc: $(PERL) -I../lib pod2latex $*.pod clean: - rm -f $(MAN) $(HTML) $(TEX) + rm -f $(MAN) + rm -f $(HTML) + rm -f $(TEX) rm -f pod2html-*cache - rm -f *.aux *.log + rm -f *.aux *.log *.exe realclean: clean rm -f $(CONVERTERS) @@ -267,4 +270,7 @@ pod2text: pod2text.PL ../lib/Config.pm checkpods: checkpods.PL ../lib/Config.pm $(PERL) -I ../lib checkpods.PL +compile: all + $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' pod2latex pod2man pod2text checkpods -prog -verbose dcf -log ../compilelog; + diff --git a/pod/perl.pod b/pod/perl.pod index 41481a3bc4..a7e02f600e 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -21,6 +21,7 @@ of sections: perl Perl overview (this section) perldelta Perl changes since previous version perlfaq Perl frequently asked questions + perltoc Perl documentation table of contents perldata Perl data structures perlsyn Perl syntax diff --git a/pod/perlapio.pod b/pod/perlapio.pod index c963d232f6..f69e79502c 100644 --- a/pod/perlapio.pod +++ b/pod/perlapio.pod @@ -67,7 +67,7 @@ has been "tidied up a little". =item B<PerlIO *> -This takes the place of FILE *. Unlike FILE * it should be treated as +This takes the place of FILE *. Like FILE * it should be treated as opaque (it is probably safe to assume it is a pointer to something). =item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()> @@ -84,7 +84,7 @@ These correspond to fopen()/fdopen() arguments are the same. =item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)> -These are is fprintf()/vfprintf equivalents. +These are fprintf()/vfprintf() equivalents. =item B<PerlIO_stdoutf(fmt,...)> @@ -201,8 +201,8 @@ behaviour. =item B<PerlIO_setlinebuf(f)> This corresponds to setlinebuf(). Use is deprecated pending -further discussion. (Perl core uses it I<only> when "dumping" -is has nothing to do with $| auto-flush.) +further discussion. (Perl core uses it I<only> when "dumping"; +it has nothing to do with $| auto-flush.) =back diff --git a/pod/perlbook.pod b/pod/perlbook.pod index 9a725cb833..f5bf99dbba 100644 --- a/pod/perlbook.pod +++ b/pod/perlbook.pod @@ -12,13 +12,14 @@ an online order form. I<Programming Perl, Second Edition> is a reference work that covers nearly all of Perl, while I<Learning Perl, Second Edition> is a -tutorial that covers the most frequently used subset of the language. -You might also check out the very handy, inexpensive, and compact -I<Perl 5 Desktop Reference>, especially when the thought of lugging -the 676-page Camel around doesn't make much sense. I<Mastering -Regular Expressions>, by Jeffrey Friedl, is a reference work that -covers the art and implementation of regular expressions in various -languages including Perl. +tutorial that covers the most frequently used subset of the language, +and I<Advanced Perl Programming> is an indepth study of complex topics +including the internals of perl. You might also check out the very +handy, inexpensive, and compact I<Perl 5 Desktop Reference>, especially +when the thought of lugging the 676-page Camel around doesn't make much +sense. I<Mastering Regular Expressions>, by Jeffrey Friedl, is a +reference work that covers the art and implementation of regular +expressions in various languages including Perl. Programming Perl, Second Edition (the Camel Book): ISBN 1-56592-149-6 (English) @@ -26,6 +27,9 @@ languages including Perl. Learning Perl, Second Edition (the Llama Book): ISBN 1-56592-284-0 (English) + Advanced Perl Programming: + ISBN 1-56592-220-4 (English) + Perl 5 Desktop Reference (the reference card): ISBN 1-56592-187-9 (brief English) diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 865d3bf88d..37916ae6d8 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -1918,7 +1918,7 @@ refers to the last. =head2 Creating and calling an anonymous subroutine in C -As we've already shown, L<perl_call_sv> can be used to invoke an +As we've already shown, C<perl_call_sv> can be used to invoke an anonymous subroutine. However, our example showed how Perl script invoking an XSUB to preform this operation. Let's see how it can be done inside our C code: @@ -1931,8 +1931,9 @@ done inside our C code: perl_call_sv(cvrv, G_VOID|G_NOARGS); -L<perlguts/perl_eval_pv> is used to compile the anonymous subroutine, which -will be the return value as well. Once this code reference is in hand, it +C<perl_eval_pv> is used to compile the anonymous subroutine, which +will be the return value as well (read more about C<perl_eval_pv> in +L<perlguts/perl_eval_pv>). Once this code reference is in hand, it can be mixed in with all the previous examples we've shown. =head1 SEE ALSO diff --git a/pod/perldebug.pod b/pod/perldebug.pod index a02fd5c710..8f49541b40 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -63,7 +63,7 @@ it prints out the description for just that command. The special argument of C<h h> produces a more compact help listing, designed to fit together on one screen. -If the output the C<h> command (or any command, for that matter) scrolls +If the output of the C<h> command (or any command, for that matter) scrolls past your screen, either precede the command with a leading pipe symbol so it's run through your pager, as in @@ -281,7 +281,7 @@ The sequence of steps taken by the debugger is 4. prompt user if at a breakpoint or in single-step 5. evaluate line -For example, this will print out C<$foo> every time line +For example, this will print out $foo every time line 53 is passed: a 53 print "DB FOUND $foo\n" @@ -290,6 +290,14 @@ For example, this will print out C<$foo> every time line Delete all installed actions. +=item W [expr] + +Add a global watch-expression. + +=item W + +Delete all watch-expressions. + =item O [opt[=val]] [opt"val"] [opt?]... Set or query values of options. val defaults to 1. opt can @@ -392,6 +400,10 @@ Dump arrays holding debugged files. Dump symbol tables of packages. +=item C<DumpReused> + +Dump contents of "reused" addresses. + =item C<quote>, C<HighBit>, C<undefPrint> Change style of string dump. Default value of C<quote> is C<auto>, one @@ -655,8 +667,8 @@ C<main::pests> was called in a scalar context, also from I<camel_flea>, but from line 4. Note that if you execute C<T> command from inside an active C<use> -statement, the backtrace will contain both C<L<perlfunc/require>> -frame and an C<L<perlfunc/eval EXPR>>) frame. +statement, the backtrace will contain both C<require> +frame and an C<eval>) frame. =item Listing @@ -856,7 +868,7 @@ compile subname> for the same purpose. =head2 Debugger Customization -Most probably you not want to modify the debugger, it contains enough +Most probably you do not want to modify the debugger, it contains enough hooks to satisfy most needs. You may change the behaviour of debugger from the debugger itself, using C<O>ptions, from the command line via C<PERLDB_OPTS> environment variable, and from I<customization files>. @@ -954,14 +966,14 @@ application. =item * -The array C<@{"_<$filename"}> is the line-by-line contents of +The array C<@{"_E<lt>$filename"}> is the line-by-line contents of $filename for all the compiled files. Same for C<eval>ed strings which contain subroutines, or which are currently executed. The C<$filename> for C<eval>ed strings looks like C<(eval 34)>. =item * -The hash C<%{"_<$filename"}> contains breakpoints and action (it is +The hash C<%{"_E<lt>$filename"}> contains breakpoints and action (it is keyed by line number), and individual entries are settable (as opposed to the whole hash). Only true/false is important to Perl, though the values used by F<perl5db.pl> have the form @@ -969,22 +981,22 @@ C<"$break_condition\0$action">. Values are magical in numeric context: they are zeros if the line is not breakable. Same for evaluated strings which contain subroutines, or which are -currently executed. The C<$filename> for C<eval>ed strings looks like +currently executed. The $filename for C<eval>ed strings looks like C<(eval 34)>. =item * -The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for +The scalar C<${"_E<lt>$filename"}> contains C<"_E<lt>$filename">. Same for evaluated strings which contain subroutines, or which are currently -executed. The C<$filename> for C<eval>ed strings looks like C<(eval +executed. The $filename for C<eval>ed strings looks like C<(eval 34)>. =item * After each C<require>d file is compiled, but before it is executed, -C<DB::postponed(*{"_<$filename"})> is called (if subroutine +C<DB::postponed(*{"_E<lt>$filename"})> is called (if subroutine C<DB::postponed> exists). Here the $filename is the expanded name of -the C<require>d file (as found in values of C<%INC>). +the C<require>d file (as found in values of %INC). =item * diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 9443f386d9..4ec71c8eb5 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,1580 +1,27 @@ =head1 NAME -perldelta - what's new for perl5.004 +perldelta - what's new for perl5.005 =head1 DESCRIPTION -This document describes differences between the 5.003 release (as -documented in I<Programming Perl>, second edition--the Camel Book) and -this one. +This document describes differences between the 5.004 release and this one. -=head1 Supported Environments - -Perl5.004 builds out of the box on Unix, Plan 9, LynxOS, VMS, OS/2, -QNX, AmigaOS, and Windows NT. Perl runs on Windows 95 as well, but it -cannot be built there, for lack of a reasonable command interpreter. +=head1 Incompatible Changes =head1 Core Changes -Most importantly, many bugs were fixed, including several security -problems. See the F<Changes> file in the distribution for details. - -=head2 List assignment to %ENV works - -C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS -where it generates a fatal error). - -=head2 "Can't locate Foo.pm in @INC" error now lists @INC - -=head2 Compilation option: Binary compatibility with 5.003 - -There is a new Configure question that asks if you want to maintain -binary compatibility with Perl 5.003. If you choose binary -compatibility, you do not have to recompile your extensions, but you -might have symbol conflicts if you embed Perl in another application, -just as in the 5.003 release. By default, binary compatibility -is preserved at the expense of symbol table pollution. - -=head2 $PERL5OPT environment variable - -You may now put Perl options in the $PERL5OPT environment variable. -Unless Perl is running with taint checks, it will interpret this -variable as if its contents had appeared on a "#!perl" line at the -beginning of your script, except that hyphens are optional. PERL5OPT -may only be used to set the following switches: B<-[DIMUdmw]>. - -=head2 Limitations on B<-M>, B<-m>, and B<-T> options - -The C<-M> and C<-m> options are no longer allowed on the C<#!> line of -a script. If a script needs a module, it should invoke it with the -C<use> pragma. - -The B<-T> option is also forbidden on the C<#!> line of a script, -unless it was present on the Perl command line. Due to the way C<#!> -works, this usually means that B<-T> must be in the first argument. -Thus: - - #!/usr/bin/perl -T -w - -will probably work for an executable script invoked as C<scriptname>, -while: - - #!/usr/bin/perl -w -T - -will probably fail under the same conditions. (Non-Unix systems will -probably not follow this rule.) But C<perl scriptname> is guaranteed -to fail, since then there is no chance of B<-T> being found on the -command line before it is found on the C<#!> line. - -=head2 More precise warnings - -If you removed the B<-w> option from your Perl 5.003 scripts because it -made Perl too verbose, we recommend that you try putting it back when -you upgrade to Perl 5.004. Each new perl version tends to remove some -undesirable warnings, while adding new warnings that may catch bugs in -your scripts. - -=head2 Deprecated: Inherited C<AUTOLOAD> for non-methods - -Before Perl 5.004, C<AUTOLOAD> functions were looked up as methods -(using the C<@ISA> hierarchy), even when the function to be autoloaded -was called as a plain function (e.g. C<Foo::bar()>), not a method -(e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). - -Perl 5.005 will use method lookup only for methods' C<AUTOLOAD>s. -However, there is a significant base of existing code that may be using -the old behavior. So, as an interim step, Perl 5.004 issues an optional -warning when a non-method uses an inherited C<AUTOLOAD>. - -The simple rule is: Inheritance will not work when autoloading -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. - -=head2 Previously deprecated %OVERLOAD is no longer usable - -Using %OVERLOAD to define overloading was deprecated in 5.003. -Overloading is now defined using the overload pragma. %OVERLOAD is -still used internally but should not be used by Perl scripts. See -L<overload> for more details. - -=head2 Subroutine arguments created only when they're modified - -In Perl 5.004, nonexistent array and hash elements used as subroutine -parameters are brought into existence only if they are actually -assigned to (via C<@_>). - -Earlier versions of Perl vary in their handling of such arguments. -Perl versions 5.002 and 5.003 always brought them into existence. -Perl versions 5.000 and 5.001 brought them into existence only if -they were not the first argument (which was almost certainly a bug). -Earlier versions of Perl never brought them into existence. - -For example, given this code: - - undef @a; undef %a; - sub show { print $_[0] }; - sub change { $_[0]++ }; - show($a[2]); - change($a{b}); - -After this code executes in Perl 5.004, $a{b} exists but $a[2] does -not. In Perl 5.002 and 5.003, both $a{b} and $a[2] would have existed -(but $a[2]'s value would have been undefined). - -=head2 Group vector changeable with C<$)> - -The C<$)> special variable has always (well, in Perl 5, at least) -reflected not only the current effective group, but also the group list -as returned by the C<getgroups()> C function (if there is one). -However, until this release, there has not been a way to call the -C<setgroups()> C function from Perl. - -In Perl 5.004, assigning to C<$)> is exactly symmetrical with examining -it: The first number in its string value is used as the effective gid; -if there are any numbers after the first one, they are passed to the -C<setgroups()> C function (if there is one). - -=head2 Fixed parsing of $$<digit>, &$<digit>, etc. - -Perl versions before 5.004 misinterpreted any type marker followed by -"$" and a digit. For example, "$$0" was incorrectly taken to mean -"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. - -However, the developers of Perl 5.004 could not fix this bug completely, -because at least two widely-used modules depend on the old meaning of -"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the -old (broken) way inside strings; but it generates this message as a -warning. And in Perl 5.005, this special treatment will cease. - -=head2 Fixed localization of $<digit>, $&, etc. - -Perl versions before 5.004 did not always properly localize the -regex-related special variables. Perl 5.004 does localize them, as -the documentation has always said it should. This may result in $1, -$2, etc. no longer being set where existing programs use them. - -=head2 No resetting of $. on implicit close - -The documentation for Perl 5.0 has always stated that C<$.> is I<not> -reset when an already-open file handle is reopened with no intervening -call to C<close>. Due to a bug, perl versions 5.000 through 5.003 -I<did> reset C<$.> under that circumstance; Perl 5.004 does not. - -=head2 C<wantarray> may return undef - -The C<wantarray> operator returns true if a subroutine is expected to -return a list, and false otherwise. In Perl 5.004, C<wantarray> can -also return the undefined value if a subroutine's return value will -not be used at all, which allows subroutines to avoid a time-consuming -calculation of a return value if it isn't going to be used. - -=head2 C<eval EXPR> determines value of EXPR in scalar context - -Perl (version 5) used to determine the value of EXPR inconsistently, -sometimes incorrectly using the surrounding context for the determination. -Now, the value of EXPR (before being parsed by eval) is always determined in -a scalar context. Once parsed, it is executed as before, by providing -the context that the scope surrounding the eval provided. This change -makes the behavior Perl4 compatible, besides fixing bugs resulting from -the inconsistent behavior. This program: - - @a = qw(time now is time); - print eval @a; - print '|', scalar eval @a; - -used to print something like "timenowis881399109|4", but now (and in perl4) -prints "4|4". - -=head2 Changes to tainting checks - -A bug in previous versions may have failed to detect some insecure -conditions when taint checks are turned on. (Taint checks are used -in setuid or setgid scripts, or when explicitly turned on with the -C<-T> invocation option.) Although it's unlikely, this may cause a -previously-working script to now fail -- which should be construed -as a blessing, since that indicates a potentially-serious security -hole was just plugged. - -The new restrictions when tainting include: - -=over - -=item No glob() or <*> - -These operators may spawn the C shell (csh), which cannot be made -safe. This restriction will be lifted in a future version of Perl -when globbing is implemented without the use of an external program. - -=item No spawning if tainted $CDPATH, $ENV, $BASH_ENV - -These environment variables may alter the behavior of spawned programs -(especially shells) in ways that subvert security. So now they are -treated as dangerous, in the manner of $IFS and $PATH. - -=item No spawning if tainted $TERM doesn't look like a terminal name - -Some termcap libraries do unsafe things with $TERM. However, it would be -unnecessarily harsh to treat all $TERM values as unsafe, since only shell -metacharacters can cause trouble in $TERM. So a tainted $TERM is -considered to be safe if it contains only alphanumerics, underscores, -dashes, and colons, and unsafe if it contains other characters (including -whitespace). - -=back - -=head2 New Opcode module and revised Safe module - -A new Opcode module supports the creation, manipulation and -application of opcode masks. The revised Safe module has a new API -and is implemented using the new Opcode module. Please read the new -Opcode and Safe documentation. - -=head2 Embedding improvements - -In older versions of Perl it was not possible to create more than one -Perl interpreter instance inside a single process without leaking like a -sieve and/or crashing. The bugs that caused this behavior have all been -fixed. However, you still must take care when embedding Perl in a C -program. See the updated perlembed manpage for tips on how to manage -your interpreters. - -=head2 Internal change: FileHandle class based on IO::* classes - -File handles are now stored internally as type IO::Handle. The -FileHandle module is still supported for backwards compatibility, but -it is now merely a front end to the IO::* modules -- specifically, -IO::Handle, IO::Seekable, and IO::File. We suggest, but do not -require, that you use the IO::* modules in new code. - -In harmony with this change, C<*GLOB{FILEHANDLE}> is now just a -backward-compatible synonym for C<*GLOB{IO}>. - -=head2 Internal change: PerlIO abstraction interface - -It is now possible to build Perl with AT&T's sfio IO package -instead of stdio. See L<perlapio> for more details, and -the F<INSTALL> file for how to use it. - -=head2 New and changed syntax - -=over - -=item $coderef->(PARAMS) - -A subroutine reference may now be suffixed with an arrow and a -(possibly empty) parameter list. This syntax denotes a call of the -referenced subroutine, with the given parameters (if any). - -This new syntax follows the pattern of S<C<$hashref-E<gt>{FOO}>> and -S<C<$aryref-E<gt>[$foo]>>: You may now write S<C<&$subref($foo)>> as -S<C<$subref-E<gt>($foo)>>. All of these arrow terms may be chained; -thus, S<C<&{$table-E<gt>{FOO}}($bar)>> may now be written -S<C<$table-E<gt>{FOO}-E<gt>($bar)>>. - -=back - -=head2 New and changed builtin constants - -=over - -=item __PACKAGE__ - -The current package name at compile time, or the undefined value if -there is no current package (due to a C<package;> directive). Like -C<__FILE__> and C<__LINE__>, C<__PACKAGE__> does I<not> interpolate -into strings. - -=back - -=head2 New and changed builtin variables - -=over - -=item $^E - -Extended error message on some platforms. (Also known as -$EXTENDED_OS_ERROR if you C<use English>). - -=item $^H - -The current set of syntax checks enabled by C<use strict>. See the -documentation of C<strict> for more details. Not actually new, but -newly documented. -Because it is intended for internal use by Perl core components, -there is no C<use English> long name for this variable. - -=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 C<use English> long name for this variable. - -=back - -=head2 New and changed builtin functions - -=over - -=item delete on slices - -This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>) - -=item flock - -is now supported on more platforms, prefers fcntl to lockf when -emulating, and always flushes before (un)locking. - -=item printf and sprintf - -Perl now implements these functions itself; it doesn't use the C -library function sprintf() any more, except for floating-point -numbers, and even then only known flags are allowed. As a result, it -is now possible to know which conversions and flags will work, and -what they will do. - -The new conversions in Perl's sprintf() are: - - %i a synonym for %d - %p a pointer (the address of the Perl value, in hexadecimal) - %n special: *stores* the number of characters output so far - into the next variable in the parameter list - -The new flags that go between the C<%> and the conversion are: - - # prefix octal with "0", hex with "0x" - h interpret integer as C type "short" or "unsigned short" - V interpret integer as Perl's standard integer type - -Also, where a number would appear in the flags, an asterisk ("*") may -be used instead, in which case Perl uses the next item in the -parameter list as the given number (that is, as the field width or -precision). If a field width obtained through "*" is negative, it has -the same effect as the '-' flag: left-justification. - -See L<perlfunc/sprintf> for a complete list of conversion and flags. - -=item keys as an lvalue - -As an lvalue, C<keys> allows you to increase the number of hash buckets -allocated for the given hash. This can gain you a measure of efficiency if -you know the hash is going to get big. (This is similar to pre-extending -an array by assigning a larger number to $#array.) If you say - - keys %hash = 200; - -then C<%hash> will have at least 200 buckets allocated for it. These -buckets will be retained even if you do C<%hash = ()>; use C<undef -%hash> if you want to free the storage while C<%hash> is still in scope. -You can't shrink the number of buckets allocated for the hash using -C<keys> in this way (but you needn't worry about doing this by accident, -as trying has no effect). - -=item my() in Control Structures - -You can now use my() (with or without the parentheses) in the control -expressions of control structures such as: - - while (defined(my $line = <>)) { - $line = lc $line; - } continue { - print $line; - } - - if ((my $answer = <STDIN>) =~ /^y(es)?$/i) { - user_agrees(); - } elsif ($answer =~ /^n(o)?$/i) { - user_disagrees(); - } else { - chomp $answer; - die "`$answer' is neither `yes' nor `no'"; - } - -Also, you can declare a foreach loop control variable as lexical by -preceding it with the word "my". For example, in: - - foreach my $i (1, 2, 3) { - some_function(); - } - -$i is a lexical variable, and the scope of $i extends to the end of -the loop, but not beyond it. - -Note that you still cannot use my() on global punctuation variables -such as $_ and the like. - -=item pack() and unpack() - -A new format 'w' represents a BER compressed integer (as defined in -ASN.1). Its format is a sequence of one or more bytes, each of which -provides seven bits of the total value, with the most significant -first. Bit eight of each byte is set, except for the last byte, in -which bit eight is clear. - -If 'p' or 'P' are given undef as values, they now generate a NULL -pointer. - -Both pack() and unpack() now fail when their templates contain invalid -types. (Invalid types used to be ignored.) - -=item sysseek() - -The new sysseek() operator is a variant of seek() that sets and gets the -file's system read/write position, using the lseek(2) system call. It is -the only reliable way to seek before using sysread() or syswrite(). Its -return value is the new position, or the undefined value on failure. - -=item use VERSION - -If the first argument to C<use> is a number, it is treated as a version -number instead of a module name. If the version of the Perl interpreter -is less than VERSION, then an error message is printed and Perl exits -immediately. Because C<use> occurs at compile time, this check happens -immediately during the compilation process, unlike C<require VERSION>, -which waits until runtime for the check. This is often useful if you -need to check the current Perl version before C<use>ing library modules -which have changed in incompatible ways from older versions of Perl. -(We try not to do this more than we have to.) - -=item use Module VERSION LIST - -If the VERSION argument is present between Module and LIST, then the -C<use> will call the VERSION method in class Module with the given -version as an argument. The default VERSION method, inherited from -the UNIVERSAL class, croaks if the given version is larger than the -value of the variable $Module::VERSION. (Note that there is not a -comma after VERSION!) - -This version-checking mechanism is similar to the one currently used -in the Exporter module, but it is faster and can be used with modules -that don't use the Exporter. It is the recommended method for new -code. - -=item prototype(FUNCTION) - -Returns the prototype of a function as a string (or C<undef> if the -function has no prototype). FUNCTION is a reference to or the name of the -function whose prototype you want to retrieve. -(Not actually new; just never documented before.) - -=item srand - -The default seed for C<srand>, which used to be C<time>, has been changed. -Now it's a heady mix of difficult-to-predict system-dependent values, -which should be sufficient for most everyday purposes. - -Previous to version 5.004, calling C<rand> without first calling C<srand> -would yield the same sequence of random numbers on most or all machines. -Now, when perl sees that you're calling C<rand> and haven't yet called -C<srand>, it calls C<srand> with the default seed. You should still call -C<srand> manually if your code might ever be run on a pre-5.004 system, -of course, or if you want a seed other than the default. - -=item $_ as Default - -Functions documented in the Camel to default to $_ now in -fact do, and all those that do are so documented in L<perlfunc>. - -=item C<m//gc> does not reset search position on failure - -The C<m//g> match iteration construct has always reset its target -string's search position (which is visible through the C<pos> operator) -when a match fails; as a result, the next C<m//g> match after a failure -starts again at the beginning of the string. With Perl 5.004, this -reset may be disabled by adding the "c" (for "continue") modifier, -i.e. C<m//gc>. This feature, in conjunction with the C<\G> zero-width -assertion, makes it possible to chain matches together. See L<perlop> -and L<perlre>. - -=item C<m//x> ignores whitespace before ?*+{} - -The C<m//x> construct has always been intended to ignore all unescaped -whitespace. However, before Perl 5.004, whitespace had the effect of -escaping repeat modifiers like "*" or "?"; for example, C</a *b/x> was -(mis)interpreted as C</a\*b/x>. This bug has been fixed in 5.004. - -=item nested C<sub{}> closures work now - -Prior to the 5.004 release, nested anonymous functions didn't work -right. They do now. - -=item formats work right on changing lexicals - -Just like anonymous functions that contain lexical variables -that change (like a lexical index variable for a C<foreach> loop), -formats now work properly. For example, this silently failed -before (printed only zeros), but is fine now: - - my $i; - foreach $i ( 1 .. 10 ) { - write; - } - format = - my i is @# - $i - . - -However, it still fails (without a warning) if the foreach is within a -subroutine: - - my $i; - sub foo { - foreach $i ( 1 .. 10 ) { - write; - } - } - foo; - format = - my i is @# - $i - . - -=back - -=head2 New builtin methods - -The C<UNIVERSAL> package automatically contains the following methods that -are inherited by all other classes: - -=over - -=item isa(CLASS) - -C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS> - -C<isa> is also exportable and can be called as a sub with two arguments. This -allows the ability to check what a reference points to. Example: - - use UNIVERSAL qw(isa); - - if(isa($ref, 'ARRAY')) { - ... - } - -=item can(METHOD) - -C<can> checks to see if its object has a method called C<METHOD>, -if it does then a reference to the sub is returned; if it does not then -I<undef> is returned. - -=item VERSION( [NEED] ) - -C<VERSION> returns the version number of the class (package). If the -NEED argument is given then it will check that the current version (as -defined by the $VERSION variable in the given package) not less than -NEED; it will die if this is not the case. This method is normally -called as a class method. This method is called automatically by the -C<VERSION> form of C<use>. - - use A 1.2 qw(some imported subs); - # implies: - A->VERSION(1.2); - -=back - -B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and -C<isa> uses a very similar method and caching strategy. This may cause -strange effects if the Perl code dynamically changes @ISA in any package. - -You may add other methods to the UNIVERSAL class via Perl or XS code. -You do not need to C<use UNIVERSAL> in order to make these methods -available to your program. This is necessary only if you wish to -have C<isa> available as a plain subroutine in the current package. - -=head2 TIEHANDLE now supported - -See L<perltie> for other kinds of tie()s. - -=over - -=item TIEHANDLE classname, LIST - -This is the constructor for the class. That means it is expected to -return an object of some sort. The reference can be used to -hold some internal information. - - sub TIEHANDLE { - print "<shout>\n"; - my $i; - return bless \$i, shift; - } - -=item PRINT this, LIST - -This method will be triggered every time the tied handle is printed to. -Beyond its self reference it also expects the list that was passed to -the print function. - - sub PRINT { - $r = shift; - $$r++; - return print join( $, => map {uc} @_), $\; - } - -=item PRINTF this, LIST - -This method will be triggered every time the tied handle is printed to -with the C<printf()> function. -Beyond its self reference it also expects the format and list that was -passed to the printf function. - - sub PRINTF { - shift; - my $fmt = shift; - print sprintf($fmt, @_)."\n"; - } - -=item READ this LIST - -This method will be called when the handle is read from via the C<read> -or C<sysread> functions. - - sub READ { - $r = shift; - my($buf,$len,$offset) = @_; - print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset"; - } - -=item READLINE this - -This method will be called when the handle is read from. The method -should return undef when there is no more data. - - sub READLINE { - $r = shift; - return "PRINT called $$r times\n" - } - -=item GETC this - -This method will be called when the C<getc> function is called. - - sub GETC { print "Don't GETC, Get Perl"; return "a"; } - -=item DESTROY this - -As with the other types of ties, this method will be called when the -tied handle is about to be destroyed. This is useful for debugging and -possibly for cleaning up. - - sub DESTROY { - print "</shout>\n"; - } - -=back - -=head2 Malloc enhancements - -If perl is compiled with the malloc included with the perl distribution -(that is, if C<perl -V:d_mymalloc> is 'define') then you can print -memory statistics at runtime by running Perl thusly: - - env PERL_DEBUG_MSTATS=2 perl your_script_here - -The value of 2 means to print statistics after compilation and on -exit; with a value of 1, the statistics are printed only on exit. -(If you want the statistics at an arbitrary time, you'll need to -install the optional module Devel::Peek.) - -Three new compilation flags are recognized by malloc.c. (They have no -effect if perl is compiled with system malloc().) - -=over - -=item -DPERL_EMERGENCY_SBRK - -If this macro is defined, running out of memory need not be a fatal -error: a memory pool can allocated by assigning to the special -variable C<$^M>. See L<"$^M">. - -=item -DPACK_MALLOC - -Perl memory allocation is by bucket with sizes close to powers of two. -Because of these malloc overhead may be big, especially for data of -size exactly a power of two. If C<PACK_MALLOC> is defined, perl uses -a slightly different algorithm for small allocations (up to 64 bytes -long), which makes it possible to have overhead down to 1 byte for -allocations which are powers of two (and appear quite often). - -Expected memory savings (with 8-byte alignment in C<alignbytes>) is -about 20% for typical Perl usage. Expected slowdown due to additional -malloc overhead is in fractions of a percent (hard to measure, because -of the effect of saved memory on speed). - -=item -DTWO_POT_OPTIMIZE - -Similarly to C<PACK_MALLOC>, this macro improves allocations of data -with size close to a power of two; but this works for big allocations -(starting with 16K by default). Such allocations are typical for big -hashes and special-purpose scripts, especially image processing. - -On recent systems, the fact that perl requires 2M from system for 1M -allocation will not affect speed of execution, since the tail of such -a chunk is not going to be touched (and thus will not require real -memory). However, it may result in a premature out-of-memory error. -So if you will be manipulating very large blocks with sizes close to -powers of two, it would be wise to define this macro. - -Expected saving of memory is 0-100% (100% in applications which -require most memory in such 2**n chunks); expected slowdown is -negligible. - -=back - -=head2 Miscellaneous efficiency enhancements - -Functions that have an empty prototype and that do nothing but return -a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). - -Each unique hash key is only allocated once, no matter how many hashes -have an entry with that key. So even if you have 100 copies of the -same hash, the hash keys never have to be reallocated. - -=head1 Support for More Operating Systems - -Support for the following operating systems is new in Perl 5.004. - -=head2 Win32 - -Perl 5.004 now includes support for building a "native" perl under -Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 -and above) or the Borland C++ compiler (versions 5.02 and above). -The resulting perl can be used under Windows 95 (if it -is installed in the same directory locations as it got installed -in Windows NT). This port includes support for perl extension -building tools like L<MakeMaker> and L<h2xs>, so that many extensions -available on the Comprehensive Perl Archive Network (CPAN) can now be -readily built under Windows NT. See http://www.perl.com/ for more -information on CPAN, and L<README.win32> for more details on how to -get started with building this port. - -There is also support for building perl under the Cygwin32 environment. -Cygwin32 is a set of GNU tools that make it possible to compile and run -many UNIX programs under Windows NT by providing a mostly UNIX-like -interface for compilation and execution. See L<README.cygwin32> for -more details on this port, and how to obtain the Cygwin32 toolkit. - -=head2 Plan 9 - -See L<README.plan9>. - -=head2 QNX - -See L<README.qnx>. - -=head2 AmigaOS - -See L<README.amigaos>. - -=head1 Pragmata - -Six new pragmatic modules exist: - -=over - -=item use autouse MODULE => qw(sub1 sub2 sub3) - -Defers C<require MODULE> until someone calls one of the specified -subroutines (which must be exported by MODULE). This pragma should be -used with caution, and only when necessary. - -=item use blib - -=item use blib 'dir' - -Looks for MakeMaker-like I<'blib'> directory structure starting in -I<dir> (or current directory) and working back up to five levels of -parent directories. - -Intended for use on command line with B<-M> option as a way of testing -arbitrary scripts against an uninstalled version of a package. - -=item use constant NAME => VALUE - -Provides a convenient interface for creating compile-time constants, -See L<perlsub/"Constant Functions">. - -=item use locale - -Tells the compiler to enable (or disable) the use of POSIX locales for -builtin operations. - -When C<use locale> is in effect, the current LC_CTYPE locale is used -for regular expressions and case mapping; LC_COLLATE for string -ordering; and LC_NUMERIC for numeric formating in printf and sprintf -(but B<not> in print). LC_NUMERIC is always used in write, since -lexical scoping of formats is problematic at best. - -Each C<use locale> or C<no locale> affects statements to the end of -the enclosing BLOCK or, if not inside a BLOCK, to the end of the -current file. Locales can be switched and queried with -POSIX::setlocale(). - -See L<perllocale> for more information. - -=item use ops - -Disable unsafe opcodes, or any named opcodes, when compiling Perl code. - -=item use vmsish - -Enable VMS-specific language features. Currently, there are three -VMS-specific features available: 'status', which makes C<$?> and -C<system> return genuine VMS status values instead of emulating POSIX; -'exit', which makes C<exit> take a genuine VMS status value instead of -assuming that C<exit 1> is an error; and 'time', which makes all times -relative to the local time zone, in the VMS tradition. - -=back - =head1 Modules =head2 Required Updates -Though Perl 5.004 is compatible with almost all modules that work -with Perl 5.003, there are a few exceptions: - - Module Required Version for Perl 5.004 - ------ ------------------------------- - Filter Filter-1.12 - LWP libwww-perl-5.08 - Tk Tk400.202 (-w makes noise) - -Also, the majordomo mailing list program, version 1.94.1, doesn't work -with Perl 5.004 (nor with perl 4), because it executes an invalid -regular expression. This bug is fixed in majordomo version 1.94.2. - -=head2 Installation directories - -The I<installperl> script now places the Perl source files for -extensions in the architecture-specific library directory, which is -where the shared libraries for extensions have always been. This -change is intended to allow administrators to keep the Perl 5.004 -library directory unchanged from a previous version, without running -the risk of binary incompatibility between extensions' Perl source and -shared libraries. - -=head2 Module information summary - -Brand new modules, arranged by topic rather than strictly -alphabetically: - - CGI.pm Web server interface ("Common Gateway Interface") - CGI/Apache.pm Support for Apache's Perl module - CGI/Carp.pm Log server errors with helpful context - CGI/Fast.pm Support for FastCGI (persistent server process) - CGI/Push.pm Support for server push - CGI/Switch.pm Simple interface for multiple server types - - CPAN Interface to Comprehensive Perl Archive Network - CPAN::FirstTime Utility for creating CPAN configuration file - CPAN::Nox Runs CPAN while avoiding compiled extensions - - IO.pm Top-level interface to IO::* classes - IO/File.pm IO::File extension Perl module - IO/Handle.pm IO::Handle extension Perl module - IO/Pipe.pm IO::Pipe extension Perl module - IO/Seekable.pm IO::Seekable extension Perl module - IO/Select.pm IO::Select extension Perl module - IO/Socket.pm IO::Socket extension Perl module - - Opcode.pm Disable named opcodes when compiling Perl code - - ExtUtils/Embed.pm Utilities for embedding Perl in C programs - ExtUtils/testlib.pm Fixes up @INC to use just-built extension - - FindBin.pm Find path of currently executing program - - Class/Struct.pm Declare struct-like datatypes as Perl classes - File/stat.pm By-name interface to Perl's builtin stat - Net/hostent.pm By-name interface to Perl's builtin gethost* - Net/netent.pm By-name interface to Perl's builtin getnet* - Net/protoent.pm By-name interface to Perl's builtin getproto* - Net/servent.pm By-name interface to Perl's builtin getserv* - Time/gmtime.pm By-name interface to Perl's builtin gmtime - Time/localtime.pm By-name interface to Perl's builtin localtime - Time/tm.pm Internal object for Time::{gm,local}time - User/grent.pm By-name interface to Perl's builtin getgr* - User/pwent.pm By-name interface to Perl's builtin getpw* - - Tie/RefHash.pm Base class for tied hashes with references as keys - - UNIVERSAL.pm Base class for *ALL* classes - -=head2 Fcntl - -New constants in the existing Fcntl modules are now supported, -provided that your operating system happens to support them: - - F_GETOWN F_SETOWN - O_ASYNC O_DEFER O_DSYNC O_FSYNC O_SYNC - O_EXLOCK O_SHLOCK - -These constants are intended for use with the Perl operators sysopen() -and fcntl() and the basic database modules like SDBM_File. For the -exact meaning of these and other Fcntl constants please refer to your -operating system's documentation for fcntl() and open(). - -In addition, the Fcntl module now provides these constants for use -with the Perl operator flock(): - - LOCK_SH LOCK_EX LOCK_NB LOCK_UN - -These constants are defined in all environments (because where there is -no flock() system call, Perl emulates it). However, for historical -reasons, these constants are not exported unless they are explicitly -requested with the ":flock" tag (e.g. C<use Fcntl ':flock'>). - -=head2 IO - -The IO module provides a simple mechanism to load all of the IO modules at one -go. Currently this includes: - - IO::Handle - IO::Seekable - IO::File - IO::Pipe - IO::Socket - -For more information on any of these modules, please see its -respective documentation. - -=head2 Math::Complex - -The Math::Complex module has been totally rewritten, and now supports -more operations. These are overloaded: - - + - * / ** <=> neg ~ abs sqrt exp log sin cos atan2 "" (stringify) - -And these functions are now exported: - - pi i Re Im arg - log10 logn ln cbrt root - tan - csc sec cot - asin acos atan - acsc asec acot - sinh cosh tanh - csch sech coth - asinh acosh atanh - acsch asech acoth - cplx cplxe - -=head2 Math::Trig - -This new module provides a simpler interface to parts of Math::Complex for -those who need trigonometric functions only for real numbers. - -=head2 DB_File - -There have been quite a few changes made to DB_File. Here are a few of -the highlights: - -=over - -=item * - -Fixed a handful of bugs. - -=item * - -By public demand, added support for the standard hash function exists(). - -=item * - -Made it compatible with Berkeley DB 1.86. - -=item * - -Made negative subscripts work with RECNO interface. - -=item * - -Changed the default flags from O_RDWR to O_CREAT|O_RDWR and the default -mode from 0640 to 0666. - -=item * - -Made DB_File automatically import the open() constants (O_RDWR, -O_CREAT etc.) from Fcntl, if available. - -=item * - -Updated documentation. - -=back - -Refer to the HISTORY section in DB_File.pm for a complete list of -changes. Everything after DB_File 1.01 has been added since 5.003. - -=head2 Net::Ping - -Major rewrite - support added for both udp echo and real icmp pings. - -=head2 Object-oriented overrides for builtin operators - -Many of the Perl builtins returning lists now have -object-oriented overrides. These are: - - File::stat - Net::hostent - Net::netent - Net::protoent - Net::servent - Time::gmtime - Time::localtime - User::grent - User::pwent - -For example, you can now say - - use File::stat; - use User::pwent; - $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid); + XXX Any??? =head1 Utility Changes -=head2 pod2html - -=over - -=item Sends converted HTML to standard output - -The I<pod2html> utility included with Perl 5.004 is entirely new. -By default, it sends the converted HTML to its standard output, -instead of writing it to a file like Perl 5.003's I<pod2html> did. -Use the B<--outfile=FILENAME> option to write to a file. - -=back - -=head2 xsubpp - -=over - -=item C<void> XSUBs now default to returning nothing - -Due to a documentation/implementation bug in previous versions of -Perl, XSUBs with a return type of C<void> have actually been -returning one value. Usually that value was the GV for the XSUB, -but sometimes it was some already freed or reused value, which would -sometimes lead to program failure. - -In Perl 5.004, if an XSUB is declared as returning C<void>, it -actually returns no value, i.e. an empty list (though there is a -backward-compatibility exception; see below). If your XSUB really -does return an SV, you should give it a return type of C<SV *>. - -For backward compatibility, I<xsubpp> tries to guess whether a -C<void> XSUB is really C<void> or if it wants to return an C<SV *>. -It does so by examining the text of the XSUB: if I<xsubpp> finds -what looks like an assignment to C<ST(0)>, it assumes that the -XSUB's return type is really C<SV *>. - -=back - =head1 C Language API Changes -=over - -=item C<gv_fetchmethod> and C<perl_call_sv> - -The C<gv_fetchmethod> function finds a method for an object, just like -in Perl 5.003. The GV it returns may be a method cache entry. -However, in Perl 5.004, method cache entries are not visible to users; -therefore, they can no longer be passed directly to C<perl_call_sv>. -Instead, you should use the C<GvCV> macro on the GV to extract its CV, -and pass the CV to C<perl_call_sv>. - -The most likely symptom of passing the result of C<gv_fetchmethod> to -C<perl_call_sv> is Perl's producing an "Undefined subroutine called" -error on the I<second> call to a given method (since there is no cache -on the first call). - -=item C<perl_eval_pv> - -A new function handy for eval'ing strings of Perl code inside C code. -This function returns the value from the eval statement, which can -be used instead of fetching globals from the symbol table. See -L<perlguts>, L<perlembed> and L<perlcall> for details and examples. - -=item Extended API for manipulating hashes - -Internal handling of hash keys has changed. The old hashtable API is -still fully supported, and will likely remain so. The additions to the -API allow passing keys as C<SV*>s, so that C<tied> hashes can be given -real scalars as keys rather than plain strings (nontied hashes still -can only use strings as keys). New extensions must use the new hash -access functions and macros if they wish to use C<SV*> keys. These -additions also make it feasible to manipulate C<HE*>s (hash entries), -which can be more efficient. See L<perlguts> for details. - -=back - =head1 Documentation Changes -Many of the base and library pods were updated. These -new pods are included in section 1: - -=over - -=item L<perldelta> - -This document. - -=item L<perlfaq> - -Frequently asked questions. - -=item L<perllocale> - -Locale support (internationalization and localization). - -=item L<perltoot> - -Tutorial on Perl OO programming. - -=item L<perlapio> - -Perl internal IO abstraction interface. - -=item L<perlmodlib> - -Perl module library and recommended practice for module creation. -Extracted from L<perlmod> (which is much smaller as a result). - -=item L<perldebug> - -Although not new, this has been massively updated. - -=item L<perlsec> - -Although not new, this has been massively updated. - -=back - -=head1 New Diagnostics - -Several new conditions will trigger warnings that were -silent before. Some only affect certain platforms. -The following new warnings and errors outline these. -These messages are classified as follows (listed in -increasing order of desperation): - - (W) A warning (optional). - (D) A deprecation (optional). - (S) A severe warning (mandatory). - (F) A fatal error (trappable). - (P) An internal error you should never see (trappable). - (X) A very fatal error (nontrappable). - (A) An alien error message (not generated by Perl). - -=over - -=item "my" variable %s masks earlier declaration in same scope - -(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 -destroyed. - -=item %s argument is not a HASH element or slice - -(F) The argument to delete() must be either a hash element, such as - - $foo{$bar} - $ref->[12]->{"susie"} - -or a hash slice, such as - - @foo{$bar, $baz, $xyzzy} - @{$ref->[12]}{"susie", "queue"} - -=item Allocation too large: %lx - -(X) You can't allocate more than 64K on an MS-DOS machine. - -=item Allocation too large - -(F) You can't allocate more than 2^31+"small amount" bytes. - -=item Applying %s to %s will act on scalar(%s) - -(W) The pattern match (//), substitution (s///), and transliteration (tr///) -operators work on scalar values. If you apply one of them to an array -or a hash, it will convert the array or hash to a scalar value -- the -length of an array, or the population info of a hash -- and then work on -that scalar value. This is probably not what you meant to do. See -L<perlfunc/grep> and L<perlfunc/map> for alternatives. - -=item Attempt to free nonexistent shared string - -(P) Perl maintains a reference counted internal table of strings to -optimize the storage and access of hash keys and other strings. This -indicates someone tried to decrement the reference count of a string -that can no longer be found in the table. - -=item Attempt to use reference as lvalue in substr - -(W) You supplied a reference as the first argument to substr() used -as an lvalue, which is pretty strange. Perhaps you forgot to -dereference it first. See L<perlfunc/substr>. - -=item Bareword "%s" refers to nonexistent package - -(W) You used a qualified bareword of the form C<Foo::>, but -the compiler saw no other uses of that namespace before that point. -Perhaps you need to predeclare a package? - -=item Can't redefine active sort subroutine %s - -(F) Perl optimizes the internal handling of sort subroutines and keeps -pointers into them. You tried to redefine one such sort subroutine when it -was currently active, which is not allowed. If you really want to do -this, you should write C<sort { &func } @x> instead of C<sort func @x>. - -=item Can't use bareword ("%s") as %s ref while "strict refs" in use - -(F) Only hard references are allowed by "strict refs". Symbolic references -are disallowed. See L<perlref>. - -=item Cannot resolve method `%s' overloading `%s' in package `%s' - -(P) Internal error trying to resolve overloading specified by a method -name (as opposed to a subroutine reference). - -=item Constant subroutine %s redefined - -(S) You redefined a subroutine which had previously been eligible for -inlining. See L<perlsub/"Constant Functions"> for commentary and -workarounds. - -=item Constant subroutine %s undefined - -(S) You undefined a subroutine which had previously been eligible for -inlining. See L<perlsub/"Constant Functions"> for commentary and -workarounds. - -=item Copy method did not return a reference - -(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. - -=item Died - -(F) You passed die() an empty string (the equivalent of C<die "">) or -you called it with no args and both C<$@> and C<$_> were empty. - -=item Exiting pseudo-block via %s - -(W) You are exiting a rather special block construct (like a sort block or -subroutine) by unconventional means, such as a goto, or a loop control -statement. See L<perlfunc/sort>. - -=item Identifier too long - -(F) Perl limits identifiers (names for variables, functions, etc.) to -252 characters for simple names, somewhat more for compound names (like -C<$A::B>). You've exceeded Perl's limits. Future versions of Perl are -likely to eliminate these arbitrary limitations. - -=item Illegal character %s (carriage return) - -(F) A carriage return character was found in the input. This is an -error, and not a warning, because carriage return characters can break -multi-line strings, including here documents (e.g., C<print E<lt>E<lt>EOF;>). - -=item Illegal switch in PERL5OPT: %s - -(X) The PERL5OPT environment variable may only be used to set the -following switches: B<-[DIMUdmw]>. - -=item Integer overflow in hex number - -(S) The literal hex number you have specified is too big for your -architecture. On a 32-bit architecture the largest hex literal is -0xFFFFFFFF. - -=item Integer overflow in octal number - -(S) The literal octal number you have specified is too big for your -architecture. On a 32-bit architecture the largest octal literal is -037777777777. - -=item internal error: glob failed - -(P) Something went wrong with the external program(s) used for C<glob> -and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is -broken. If so, you should change all of the csh-related variables in -config.sh: If you have tcsh, make the variables refer to it as if it -were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all -empty (except that C<d_csh> should be C<'undef'>) so that Perl will -think csh is missing. In either case, after editing config.sh, run -C<./Configure -S> and rebuild Perl. - -=item Invalid conversion in %s: "%s" - -(W) Perl does not understand the given format conversion. -See L<perlfunc/sprintf>. - -=item Invalid type in pack: '%s' - -(F) The given character is not a valid pack type. See L<perlfunc/pack>. - -=item Invalid type in unpack: '%s' - -(F) The given character is not a valid unpack type. See L<perlfunc/unpack>. - -=item Name "%s::%s" used only once: possible typo - -(W) Typographical errors often show up as unique variable names. -If you had a good reason for having a unique name, then just mention -it again somehow to suppress the message (the C<use vars> pragma is -provided for just this purpose). - -=item Null picture in formline - -(F) The first argument to formline must be a valid format picture -specification. It was found to be empty, which probably means you -supplied it an uninitialized value. See L<perlform>. - -=item Offset outside string - -(F) You tried to do a read/write/send/recv operation with an offset -pointing outside the buffer. This is difficult to imagine. -The sole exception to this is that C<sysread()>ing past the buffer -will extend the buffer and zero pad the new area. - -=item Out of memory! - -(X|F) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. - -The request was judged to be small, so the possibility to trap it -depends on the way Perl was compiled. By default 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. In this case the -error is trappable I<once>. - -=item Out of memory during request for %s - -(F) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. However, -the request was judged large enough (compile-time default is 64K), so -a possibility to shut down by trapping this error is granted. - -=item panic: frexp - -(P) The library function frexp() failed, making printf("%f") impossible. - -=item Possible attempt to put comments in qw() list - -(W) qw() lists contain items separated by whitespace; as with literal -strings, comment characters are not ignored, but are instead treated -as literal data. (You may have used different delimiters than the -exclamation marks parentheses shown here; braces are also frequently -used.) - -You probably wrote something like this: - - @list = qw( - a # a comment - b # another comment - ); - -when you should have written this: - - @list = qw( - a - b - ); - -If you really want comments, build your list the -old-fashioned way, with quotes and commas: - - @list = ( - 'a', # a comment - 'b', # another comment - ); - -=item Possible attempt to separate words with commas - -(W) qw() lists contain items separated by whitespace; therefore commas -aren't needed to separate the items. (You may have used different -delimiters than the parentheses shown here; braces are also frequently -used.) - -You probably wrote something like this: - - qw! a, b, c !; - -which puts literal commas into some of the list items. Write it without -commas if you don't want them to appear in your data: - - qw! a b c !; - -=item Scalar value @%s{%s} better written as $%s{%s} - -(W) You've used a hash slice (indicated by @) to select a single element of -a hash. Generally it's better to ask for a scalar value (indicated by $). -The difference is that C<$foo{&bar}> always behaves like a scalar, both when -assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves -like a list when you assign to it, and provides a list context to its -subscript, which can do weird things if you're expecting only one subscript. - -=item Stub found while resolving method `%s' overloading `%s' in package `%s' - -(P) Overloading resolution over @ISA tree may be broken by importing stubs. -Stubs should never be implicitely created, but explicit calls to C<can> -may break this. - -=item Too late for "B<-T>" option - -(X) The #! line (or local equivalent) in a Perl script contains the -B<-T> option, but Perl was not invoked with B<-T> in its argument -list. This is an error because, by the time Perl discovers a B<-T> in -a script, it's too late to properly taint everything from the -environment. So Perl gives up. - -=item untie attempted while %d inner references still exist - -(W) A copy of the object returned from C<tie> (or C<tied>) was still -valid when C<untie> was called. - -=item Unrecognized character %s - -(F) The Perl parser has no idea what to do with the specified character -in your Perl script (or eval). Perhaps you tried to run a compressed -script, a binary program, or a directory as a Perl program. - -=item Unsupported function fork - -(F) Your version of executable does not support forking. - -Note that under some systems, like OS/2, there may be different flavors of -Perl executables, some of which may support fork, some not. Try changing -the name you call Perl by to C<perl_>, C<perl__>, and so on. - -=item Use of "$$<digit>" to mean "${$}<digit>" is deprecated - -(D) Perl versions before 5.004 misinterpreted any type marker followed -by "$" and a digit. For example, "$$0" was incorrectly taken to mean -"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. - -However, the developers of Perl 5.004 could not fix this bug completely, -because at least two widely-used modules depend on the old meaning of -"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the -old (broken) way inside strings; but it generates this message as a -warning. And in Perl 5.005, this special treatment will cease. - -=item Value of %s can be "0"; test with defined() - -(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>, -or C<readdir()> as a boolean value. Each of these constructs can return a -value of "0"; that would make the conditional expression false, which is -probably not what you intended. When using these constructs in conditional -expressions, test their values with the C<defined> operator. - -=item Variable "%s" may be unavailable - -(W) An inner (nested) I<anonymous> subroutine is inside a I<named> -subroutine, and outside that is another subroutine; and the anonymous -(innermost) subroutine is referencing a lexical variable defined in -the outermost subroutine. For example: - - sub outermost { my $a; sub middle { sub { $a } } } - -If the anonymous subroutine is called or referenced (directly or -indirectly) from the outermost subroutine, it will share the variable -as you would expect. But if the anonymous subroutine is called or -referenced when the outermost subroutine is not active, it will see -the value of the shared variable as it was before and during the -*first* call to the outermost subroutine, which is probably not what -you want. - -In these circumstances, it is usually best to make the middle -subroutine anonymous, using the C<sub {}> syntax. Perl has specific -support for shared variables in nested anonymous subroutines; a named -subroutine in between interferes with this feature. - -=item Variable "%s" will not stay shared - -(W) An inner (nested) I<named> subroutine is referencing a lexical -variable defined in an outer subroutine. - -When the inner subroutine is called, it will probably see the value of -the outer subroutine's variable as it was before and during the -*first* call to the outer subroutine; in this case, after the first -call to the outer subroutine is complete, the inner and outer -subroutines will no longer share a common value for the variable. In -other words, the variable will no longer be shared. - -Furthermore, if the outer subroutine is anonymous and references a -lexical variable outside itself, then the outer and inner subroutines -will I<never> share the given variable. - -This problem can usually be solved by making the inner subroutine -anonymous, using the C<sub {}> syntax. When inner anonymous subs that -reference variables in outer subroutines are called or referenced, -they are automatically rebound to the current values of such -variables. - -=item Warning: something's wrong - -(W) You passed warn() an empty string (the equivalent of C<warn "">) or -you called it with no args and C<$_> was empty. - -=item Ill-formed logical name |%s| in prime_env_iter - -(W) A warning peculiar to VMS. A logical name was encountered when preparing -to iterate over %ENV which violates the syntactic rules governing logical -names. Since it cannot be translated normally, it is skipped, and will not -appear in %ENV. This may be a benign occurrence, as some software packages -might directly modify logical name tables and introduce nonstandard names, -or it may indicate that a logical name table has been corrupted. - -=item Got an error from DosAllocMem - -(P) An error peculiar to OS/2. Most probably you're using an obsolete -version of Perl, and this should not happen anyway. - -=item Malformed PERLLIB_PREFIX - -(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form - - prefix1;prefix2 - -or - - prefix1 prefix2 - -with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix -of a builtin library search path, prefix2 is substituted. The error -may appear if components are not found, or are too long. See -"PERLLIB_PREFIX" in F<README.os2>. - -=item PERL_SH_DIR too long - -(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the -C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>. - -=item Process terminated by SIG%s - -(W) This is a standard message issued by OS/2 applications, while *nix -applications die in silence. It is considered a feature of the OS/2 -port. One can easily disable this by appropriate sighandlers, see -L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT" -in F<README.os2>. - -=back - =head1 BUGS If you find what you think is a bug, you might check the headers of @@ -1592,18 +39,10 @@ analysed by the Perl porting team. The F<Changes> file for exhaustive details on what changed. -The F<INSTALL> file for how to build Perl. This file has been -significantly updated for 5.004, so even veteran users should -look through it. +The F<INSTALL> file for how to build Perl. The F<README> file for general stuff. -The F<Copying> file for copyright information. +The F<Artistic> and F<Copying> files for copyright information. =head1 HISTORY - -Constructed by Tom Christiansen, grabbing material with permission -from innumerable contributors, with kibitzing by more than a few Perl -porters. - -Last update: Wed May 14 11:14:09 EDT 1997 diff --git a/pod/perldelta4.pod b/pod/perldelta4.pod new file mode 100644 index 0000000000..f1b6c8f096 --- /dev/null +++ b/pod/perldelta4.pod @@ -0,0 +1,1609 @@ +=head1 NAME + +perldelta - what's new for perl5.004 + +=head1 DESCRIPTION + +This document describes differences between the 5.003 release (as +documented in I<Programming Perl>, second edition--the Camel Book) and +this one. + +=head1 Supported Environments + +Perl5.004 builds out of the box on Unix, Plan 9, LynxOS, VMS, OS/2, +QNX, AmigaOS, and Windows NT. Perl runs on Windows 95 as well, but it +cannot be built there, for lack of a reasonable command interpreter. + +=head1 Core Changes + +Most importantly, many bugs were fixed, including several security +problems. See the F<Changes> file in the distribution for details. + +=head2 List assignment to %ENV works + +C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS +where it generates a fatal error). + +=head2 "Can't locate Foo.pm in @INC" error now lists @INC + +=head2 Compilation option: Binary compatibility with 5.003 + +There is a new Configure question that asks if you want to maintain +binary compatibility with Perl 5.003. If you choose binary +compatibility, you do not have to recompile your extensions, but you +might have symbol conflicts if you embed Perl in another application, +just as in the 5.003 release. By default, binary compatibility +is preserved at the expense of symbol table pollution. + +=head2 $PERL5OPT environment variable + +You may now put Perl options in the $PERL5OPT environment variable. +Unless Perl is running with taint checks, it will interpret this +variable as if its contents had appeared on a "#!perl" line at the +beginning of your script, except that hyphens are optional. PERL5OPT +may only be used to set the following switches: B<-[DIMUdmw]>. + +=head2 Limitations on B<-M>, B<-m>, and B<-T> options + +The C<-M> and C<-m> options are no longer allowed on the C<#!> line of +a script. If a script needs a module, it should invoke it with the +C<use> pragma. + +The B<-T> option is also forbidden on the C<#!> line of a script, +unless it was present on the Perl command line. Due to the way C<#!> +works, this usually means that B<-T> must be in the first argument. +Thus: + + #!/usr/bin/perl -T -w + +will probably work for an executable script invoked as C<scriptname>, +while: + + #!/usr/bin/perl -w -T + +will probably fail under the same conditions. (Non-Unix systems will +probably not follow this rule.) But C<perl scriptname> is guaranteed +to fail, since then there is no chance of B<-T> being found on the +command line before it is found on the C<#!> line. + +=head2 More precise warnings + +If you removed the B<-w> option from your Perl 5.003 scripts because it +made Perl too verbose, we recommend that you try putting it back when +you upgrade to Perl 5.004. Each new perl version tends to remove some +undesirable warnings, while adding new warnings that may catch bugs in +your scripts. + +=head2 Deprecated: Inherited C<AUTOLOAD> for non-methods + +Before Perl 5.004, C<AUTOLOAD> functions were looked up as methods +(using the C<@ISA> hierarchy), even when the function to be autoloaded +was called as a plain function (e.g. C<Foo::bar()>), not a method +(e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). + +Perl 5.005 will use method lookup only for methods' C<AUTOLOAD>s. +However, there is a significant base of existing code that may be using +the old behavior. So, as an interim step, Perl 5.004 issues an optional +warning when a non-method uses an inherited C<AUTOLOAD>. + +The simple rule is: Inheritance will not work when autoloading +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. + +=head2 Previously deprecated %OVERLOAD is no longer usable + +Using %OVERLOAD to define overloading was deprecated in 5.003. +Overloading is now defined using the overload pragma. %OVERLOAD is +still used internally but should not be used by Perl scripts. See +L<overload> for more details. + +=head2 Subroutine arguments created only when they're modified + +In Perl 5.004, nonexistent array and hash elements used as subroutine +parameters are brought into existence only if they are actually +assigned to (via C<@_>). + +Earlier versions of Perl vary in their handling of such arguments. +Perl versions 5.002 and 5.003 always brought them into existence. +Perl versions 5.000 and 5.001 brought them into existence only if +they were not the first argument (which was almost certainly a bug). +Earlier versions of Perl never brought them into existence. + +For example, given this code: + + undef @a; undef %a; + sub show { print $_[0] }; + sub change { $_[0]++ }; + show($a[2]); + change($a{b}); + +After this code executes in Perl 5.004, $a{b} exists but $a[2] does +not. In Perl 5.002 and 5.003, both $a{b} and $a[2] would have existed +(but $a[2]'s value would have been undefined). + +=head2 Group vector changeable with C<$)> + +The C<$)> special variable has always (well, in Perl 5, at least) +reflected not only the current effective group, but also the group list +as returned by the C<getgroups()> C function (if there is one). +However, until this release, there has not been a way to call the +C<setgroups()> C function from Perl. + +In Perl 5.004, assigning to C<$)> is exactly symmetrical with examining +it: The first number in its string value is used as the effective gid; +if there are any numbers after the first one, they are passed to the +C<setgroups()> C function (if there is one). + +=head2 Fixed parsing of $$<digit>, &$<digit>, etc. + +Perl versions before 5.004 misinterpreted any type marker followed by +"$" and a digit. For example, "$$0" was incorrectly taken to mean +"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. + +However, the developers of Perl 5.004 could not fix this bug completely, +because at least two widely-used modules depend on the old meaning of +"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the +old (broken) way inside strings; but it generates this message as a +warning. And in Perl 5.005, this special treatment will cease. + +=head2 Fixed localization of $<digit>, $&, etc. + +Perl versions before 5.004 did not always properly localize the +regex-related special variables. Perl 5.004 does localize them, as +the documentation has always said it should. This may result in $1, +$2, etc. no longer being set where existing programs use them. + +=head2 No resetting of $. on implicit close + +The documentation for Perl 5.0 has always stated that C<$.> is I<not> +reset when an already-open file handle is reopened with no intervening +call to C<close>. Due to a bug, perl versions 5.000 through 5.003 +I<did> reset C<$.> under that circumstance; Perl 5.004 does not. + +=head2 C<wantarray> may return undef + +The C<wantarray> operator returns true if a subroutine is expected to +return a list, and false otherwise. In Perl 5.004, C<wantarray> can +also return the undefined value if a subroutine's return value will +not be used at all, which allows subroutines to avoid a time-consuming +calculation of a return value if it isn't going to be used. + +=head2 C<eval EXPR> determines value of EXPR in scalar context + +Perl (version 5) used to determine the value of EXPR inconsistently, +sometimes incorrectly using the surrounding context for the determination. +Now, the value of EXPR (before being parsed by eval) is always determined in +a scalar context. Once parsed, it is executed as before, by providing +the context that the scope surrounding the eval provided. This change +makes the behavior Perl4 compatible, besides fixing bugs resulting from +the inconsistent behavior. This program: + + @a = qw(time now is time); + print eval @a; + print '|', scalar eval @a; + +used to print something like "timenowis881399109|4", but now (and in perl4) +prints "4|4". + +=head2 Changes to tainting checks + +A bug in previous versions may have failed to detect some insecure +conditions when taint checks are turned on. (Taint checks are used +in setuid or setgid scripts, or when explicitly turned on with the +C<-T> invocation option.) Although it's unlikely, this may cause a +previously-working script to now fail -- which should be construed +as a blessing, since that indicates a potentially-serious security +hole was just plugged. + +The new restrictions when tainting include: + +=over + +=item No glob() or <*> + +These operators may spawn the C shell (csh), which cannot be made +safe. This restriction will be lifted in a future version of Perl +when globbing is implemented without the use of an external program. + +=item No spawning if tainted $CDPATH, $ENV, $BASH_ENV + +These environment variables may alter the behavior of spawned programs +(especially shells) in ways that subvert security. So now they are +treated as dangerous, in the manner of $IFS and $PATH. + +=item No spawning if tainted $TERM doesn't look like a terminal name + +Some termcap libraries do unsafe things with $TERM. However, it would be +unnecessarily harsh to treat all $TERM values as unsafe, since only shell +metacharacters can cause trouble in $TERM. So a tainted $TERM is +considered to be safe if it contains only alphanumerics, underscores, +dashes, and colons, and unsafe if it contains other characters (including +whitespace). + +=back + +=head2 New Opcode module and revised Safe module + +A new Opcode module supports the creation, manipulation and +application of opcode masks. The revised Safe module has a new API +and is implemented using the new Opcode module. Please read the new +Opcode and Safe documentation. + +=head2 Embedding improvements + +In older versions of Perl it was not possible to create more than one +Perl interpreter instance inside a single process without leaking like a +sieve and/or crashing. The bugs that caused this behavior have all been +fixed. However, you still must take care when embedding Perl in a C +program. See the updated perlembed manpage for tips on how to manage +your interpreters. + +=head2 Internal change: FileHandle class based on IO::* classes + +File handles are now stored internally as type IO::Handle. The +FileHandle module is still supported for backwards compatibility, but +it is now merely a front end to the IO::* modules -- specifically, +IO::Handle, IO::Seekable, and IO::File. We suggest, but do not +require, that you use the IO::* modules in new code. + +In harmony with this change, C<*GLOB{FILEHANDLE}> is now just a +backward-compatible synonym for C<*GLOB{IO}>. + +=head2 Internal change: PerlIO abstraction interface + +It is now possible to build Perl with AT&T's sfio IO package +instead of stdio. See L<perlapio> for more details, and +the F<INSTALL> file for how to use it. + +=head2 New and changed syntax + +=over + +=item $coderef->(PARAMS) + +A subroutine reference may now be suffixed with an arrow and a +(possibly empty) parameter list. This syntax denotes a call of the +referenced subroutine, with the given parameters (if any). + +This new syntax follows the pattern of S<C<$hashref-E<gt>{FOO}>> and +S<C<$aryref-E<gt>[$foo]>>: You may now write S<C<&$subref($foo)>> as +S<C<$subref-E<gt>($foo)>>. All of these arrow terms may be chained; +thus, S<C<&{$table-E<gt>{FOO}}($bar)>> may now be written +S<C<$table-E<gt>{FOO}-E<gt>($bar)>>. + +=back + +=head2 New and changed builtin constants + +=over + +=item __PACKAGE__ + +The current package name at compile time, or the undefined value if +there is no current package (due to a C<package;> directive). Like +C<__FILE__> and C<__LINE__>, C<__PACKAGE__> does I<not> interpolate +into strings. + +=back + +=head2 New and changed builtin variables + +=over + +=item $^E + +Extended error message on some platforms. (Also known as +$EXTENDED_OS_ERROR if you C<use English>). + +=item $^H + +The current set of syntax checks enabled by C<use strict>. See the +documentation of C<strict> for more details. Not actually new, but +newly documented. +Because it is intended for internal use by Perl core components, +there is no C<use English> long name for this variable. + +=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 C<use English> long name for this variable. + +=back + +=head2 New and changed builtin functions + +=over + +=item delete on slices + +This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>) + +=item flock + +is now supported on more platforms, prefers fcntl to lockf when +emulating, and always flushes before (un)locking. + +=item printf and sprintf + +Perl now implements these functions itself; it doesn't use the C +library function sprintf() any more, except for floating-point +numbers, and even then only known flags are allowed. As a result, it +is now possible to know which conversions and flags will work, and +what they will do. + +The new conversions in Perl's sprintf() are: + + %i a synonym for %d + %p a pointer (the address of the Perl value, in hexadecimal) + %n special: *stores* the number of characters output so far + into the next variable in the parameter list + +The new flags that go between the C<%> and the conversion are: + + # prefix octal with "0", hex with "0x" + h interpret integer as C type "short" or "unsigned short" + V interpret integer as Perl's standard integer type + +Also, where a number would appear in the flags, an asterisk ("*") may +be used instead, in which case Perl uses the next item in the +parameter list as the given number (that is, as the field width or +precision). If a field width obtained through "*" is negative, it has +the same effect as the '-' flag: left-justification. + +See L<perlfunc/sprintf> for a complete list of conversion and flags. + +=item keys as an lvalue + +As an lvalue, C<keys> allows you to increase the number of hash buckets +allocated for the given hash. This can gain you a measure of efficiency if +you know the hash is going to get big. (This is similar to pre-extending +an array by assigning a larger number to $#array.) If you say + + keys %hash = 200; + +then C<%hash> will have at least 200 buckets allocated for it. These +buckets will be retained even if you do C<%hash = ()>; use C<undef +%hash> if you want to free the storage while C<%hash> is still in scope. +You can't shrink the number of buckets allocated for the hash using +C<keys> in this way (but you needn't worry about doing this by accident, +as trying has no effect). + +=item my() in Control Structures + +You can now use my() (with or without the parentheses) in the control +expressions of control structures such as: + + while (defined(my $line = <>)) { + $line = lc $line; + } continue { + print $line; + } + + if ((my $answer = <STDIN>) =~ /^y(es)?$/i) { + user_agrees(); + } elsif ($answer =~ /^n(o)?$/i) { + user_disagrees(); + } else { + chomp $answer; + die "`$answer' is neither `yes' nor `no'"; + } + +Also, you can declare a foreach loop control variable as lexical by +preceding it with the word "my". For example, in: + + foreach my $i (1, 2, 3) { + some_function(); + } + +$i is a lexical variable, and the scope of $i extends to the end of +the loop, but not beyond it. + +Note that you still cannot use my() on global punctuation variables +such as $_ and the like. + +=item pack() and unpack() + +A new format 'w' represents a BER compressed integer (as defined in +ASN.1). Its format is a sequence of one or more bytes, each of which +provides seven bits of the total value, with the most significant +first. Bit eight of each byte is set, except for the last byte, in +which bit eight is clear. + +If 'p' or 'P' are given undef as values, they now generate a NULL +pointer. + +Both pack() and unpack() now fail when their templates contain invalid +types. (Invalid types used to be ignored.) + +=item sysseek() + +The new sysseek() operator is a variant of seek() that sets and gets the +file's system read/write position, using the lseek(2) system call. It is +the only reliable way to seek before using sysread() or syswrite(). Its +return value is the new position, or the undefined value on failure. + +=item use VERSION + +If the first argument to C<use> is a number, it is treated as a version +number instead of a module name. If the version of the Perl interpreter +is less than VERSION, then an error message is printed and Perl exits +immediately. Because C<use> occurs at compile time, this check happens +immediately during the compilation process, unlike C<require VERSION>, +which waits until runtime for the check. This is often useful if you +need to check the current Perl version before C<use>ing library modules +which have changed in incompatible ways from older versions of Perl. +(We try not to do this more than we have to.) + +=item use Module VERSION LIST + +If the VERSION argument is present between Module and LIST, then the +C<use> will call the VERSION method in class Module with the given +version as an argument. The default VERSION method, inherited from +the UNIVERSAL class, croaks if the given version is larger than the +value of the variable $Module::VERSION. (Note that there is not a +comma after VERSION!) + +This version-checking mechanism is similar to the one currently used +in the Exporter module, but it is faster and can be used with modules +that don't use the Exporter. It is the recommended method for new +code. + +=item prototype(FUNCTION) + +Returns the prototype of a function as a string (or C<undef> if the +function has no prototype). FUNCTION is a reference to or the name of the +function whose prototype you want to retrieve. +(Not actually new; just never documented before.) + +=item srand + +The default seed for C<srand>, which used to be C<time>, has been changed. +Now it's a heady mix of difficult-to-predict system-dependent values, +which should be sufficient for most everyday purposes. + +Previous to version 5.004, calling C<rand> without first calling C<srand> +would yield the same sequence of random numbers on most or all machines. +Now, when perl sees that you're calling C<rand> and haven't yet called +C<srand>, it calls C<srand> with the default seed. You should still call +C<srand> manually if your code might ever be run on a pre-5.004 system, +of course, or if you want a seed other than the default. + +=item $_ as Default + +Functions documented in the Camel to default to $_ now in +fact do, and all those that do are so documented in L<perlfunc>. + +=item C<m//gc> does not reset search position on failure + +The C<m//g> match iteration construct has always reset its target +string's search position (which is visible through the C<pos> operator) +when a match fails; as a result, the next C<m//g> match after a failure +starts again at the beginning of the string. With Perl 5.004, this +reset may be disabled by adding the "c" (for "continue") modifier, +i.e. C<m//gc>. This feature, in conjunction with the C<\G> zero-width +assertion, makes it possible to chain matches together. See L<perlop> +and L<perlre>. + +=item C<m//x> ignores whitespace before ?*+{} + +The C<m//x> construct has always been intended to ignore all unescaped +whitespace. However, before Perl 5.004, whitespace had the effect of +escaping repeat modifiers like "*" or "?"; for example, C</a *b/x> was +(mis)interpreted as C</a\*b/x>. This bug has been fixed in 5.004. + +=item nested C<sub{}> closures work now + +Prior to the 5.004 release, nested anonymous functions didn't work +right. They do now. + +=item formats work right on changing lexicals + +Just like anonymous functions that contain lexical variables +that change (like a lexical index variable for a C<foreach> loop), +formats now work properly. For example, this silently failed +before (printed only zeros), but is fine now: + + my $i; + foreach $i ( 1 .. 10 ) { + write; + } + format = + my i is @# + $i + . + +However, it still fails (without a warning) if the foreach is within a +subroutine: + + my $i; + sub foo { + foreach $i ( 1 .. 10 ) { + write; + } + } + foo; + format = + my i is @# + $i + . + +=back + +=head2 New builtin methods + +The C<UNIVERSAL> package automatically contains the following methods that +are inherited by all other classes: + +=over + +=item isa(CLASS) + +C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS> + +C<isa> is also exportable and can be called as a sub with two arguments. This +allows the ability to check what a reference points to. Example: + + use UNIVERSAL qw(isa); + + if(isa($ref, 'ARRAY')) { + ... + } + +=item can(METHOD) + +C<can> checks to see if its object has a method called C<METHOD>, +if it does then a reference to the sub is returned; if it does not then +I<undef> is returned. + +=item VERSION( [NEED] ) + +C<VERSION> returns the version number of the class (package). If the +NEED argument is given then it will check that the current version (as +defined by the $VERSION variable in the given package) not less than +NEED; it will die if this is not the case. This method is normally +called as a class method. This method is called automatically by the +C<VERSION> form of C<use>. + + use A 1.2 qw(some imported subs); + # implies: + A->VERSION(1.2); + +=back + +B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and +C<isa> uses a very similar method and caching strategy. This may cause +strange effects if the Perl code dynamically changes @ISA in any package. + +You may add other methods to the UNIVERSAL class via Perl or XS code. +You do not need to C<use UNIVERSAL> in order to make these methods +available to your program. This is necessary only if you wish to +have C<isa> available as a plain subroutine in the current package. + +=head2 TIEHANDLE now supported + +See L<perltie> for other kinds of tie()s. + +=over + +=item TIEHANDLE classname, LIST + +This is the constructor for the class. That means it is expected to +return an object of some sort. The reference can be used to +hold some internal information. + + sub TIEHANDLE { + print "<shout>\n"; + my $i; + return bless \$i, shift; + } + +=item PRINT this, LIST + +This method will be triggered every time the tied handle is printed to. +Beyond its self reference it also expects the list that was passed to +the print function. + + sub PRINT { + $r = shift; + $$r++; + return print join( $, => map {uc} @_), $\; + } + +=item PRINTF this, LIST + +This method will be triggered every time the tied handle is printed to +with the C<printf()> function. +Beyond its self reference it also expects the format and list that was +passed to the printf function. + + sub PRINTF { + shift; + my $fmt = shift; + print sprintf($fmt, @_)."\n"; + } + +=item READ this LIST + +This method will be called when the handle is read from via the C<read> +or C<sysread> functions. + + sub READ { + $r = shift; + my($buf,$len,$offset) = @_; + print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset"; + } + +=item READLINE this + +This method will be called when the handle is read from. The method +should return undef when there is no more data. + + sub READLINE { + $r = shift; + return "PRINT called $$r times\n" + } + +=item GETC this + +This method will be called when the C<getc> function is called. + + sub GETC { print "Don't GETC, Get Perl"; return "a"; } + +=item DESTROY this + +As with the other types of ties, this method will be called when the +tied handle is about to be destroyed. This is useful for debugging and +possibly for cleaning up. + + sub DESTROY { + print "</shout>\n"; + } + +=back + +=head2 Malloc enhancements + +If perl is compiled with the malloc included with the perl distribution +(that is, if C<perl -V:d_mymalloc> is 'define') then you can print +memory statistics at runtime by running Perl thusly: + + env PERL_DEBUG_MSTATS=2 perl your_script_here + +The value of 2 means to print statistics after compilation and on +exit; with a value of 1, the statistics are printed only on exit. +(If you want the statistics at an arbitrary time, you'll need to +install the optional module Devel::Peek.) + +Three new compilation flags are recognized by malloc.c. (They have no +effect if perl is compiled with system malloc().) + +=over + +=item -DPERL_EMERGENCY_SBRK + +If this macro is defined, running out of memory need not be a fatal +error: a memory pool can allocated by assigning to the special +variable C<$^M>. See L<"$^M">. + +=item -DPACK_MALLOC + +Perl memory allocation is by bucket with sizes close to powers of two. +Because of these malloc overhead may be big, especially for data of +size exactly a power of two. If C<PACK_MALLOC> is defined, perl uses +a slightly different algorithm for small allocations (up to 64 bytes +long), which makes it possible to have overhead down to 1 byte for +allocations which are powers of two (and appear quite often). + +Expected memory savings (with 8-byte alignment in C<alignbytes>) is +about 20% for typical Perl usage. Expected slowdown due to additional +malloc overhead is in fractions of a percent (hard to measure, because +of the effect of saved memory on speed). + +=item -DTWO_POT_OPTIMIZE + +Similarly to C<PACK_MALLOC>, this macro improves allocations of data +with size close to a power of two; but this works for big allocations +(starting with 16K by default). Such allocations are typical for big +hashes and special-purpose scripts, especially image processing. + +On recent systems, the fact that perl requires 2M from system for 1M +allocation will not affect speed of execution, since the tail of such +a chunk is not going to be touched (and thus will not require real +memory). However, it may result in a premature out-of-memory error. +So if you will be manipulating very large blocks with sizes close to +powers of two, it would be wise to define this macro. + +Expected saving of memory is 0-100% (100% in applications which +require most memory in such 2**n chunks); expected slowdown is +negligible. + +=back + +=head2 Miscellaneous efficiency enhancements + +Functions that have an empty prototype and that do nothing but return +a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). + +Each unique hash key is only allocated once, no matter how many hashes +have an entry with that key. So even if you have 100 copies of the +same hash, the hash keys never have to be reallocated. + +=head1 Support for More Operating Systems + +Support for the following operating systems is new in Perl 5.004. + +=head2 Win32 + +Perl 5.004 now includes support for building a "native" perl under +Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 +and above) or the Borland C++ compiler (versions 5.02 and above). +The resulting perl can be used under Windows 95 (if it +is installed in the same directory locations as it got installed +in Windows NT). This port includes support for perl extension +building tools like L<MakeMaker> and L<h2xs>, so that many extensions +available on the Comprehensive Perl Archive Network (CPAN) can now be +readily built under Windows NT. See http://www.perl.com/ for more +information on CPAN and F<README.win32> in the perl distribution for more +details on how to get started with building this port. + +There is also support for building perl under the Cygwin32 environment. +Cygwin32 is a set of GNU tools that make it possible to compile and run +many UNIX programs under Windows NT by providing a mostly UNIX-like +interface for compilation and execution. See F<README.cygwin32> in the +perl distribution for more details on this port and how to obtain the +Cygwin32 toolkit. + +=head2 Plan 9 + +See F<README.plan9> in the perl distribution. + +=head2 QNX + +See F<README.qnx> in the perl distribution. + +=head2 AmigaOS + +See F<README.amigaos> in the perl distribution. + +=head1 Pragmata + +Six new pragmatic modules exist: + +=over + +=item use autouse MODULE => qw(sub1 sub2 sub3) + +Defers C<require MODULE> until someone calls one of the specified +subroutines (which must be exported by MODULE). This pragma should be +used with caution, and only when necessary. + +=item use blib + +=item use blib 'dir' + +Looks for MakeMaker-like I<'blib'> directory structure starting in +I<dir> (or current directory) and working back up to five levels of +parent directories. + +Intended for use on command line with B<-M> option as a way of testing +arbitrary scripts against an uninstalled version of a package. + +=item use constant NAME => VALUE + +Provides a convenient interface for creating compile-time constants, +See L<perlsub/"Constant Functions">. + +=item use locale + +Tells the compiler to enable (or disable) the use of POSIX locales for +builtin operations. + +When C<use locale> is in effect, the current LC_CTYPE locale is used +for regular expressions and case mapping; LC_COLLATE for string +ordering; and LC_NUMERIC for numeric formating in printf and sprintf +(but B<not> in print). LC_NUMERIC is always used in write, since +lexical scoping of formats is problematic at best. + +Each C<use locale> or C<no locale> affects statements to the end of +the enclosing BLOCK or, if not inside a BLOCK, to the end of the +current file. Locales can be switched and queried with +POSIX::setlocale(). + +See L<perllocale> for more information. + +=item use ops + +Disable unsafe opcodes, or any named opcodes, when compiling Perl code. + +=item use vmsish + +Enable VMS-specific language features. Currently, there are three +VMS-specific features available: 'status', which makes C<$?> and +C<system> return genuine VMS status values instead of emulating POSIX; +'exit', which makes C<exit> take a genuine VMS status value instead of +assuming that C<exit 1> is an error; and 'time', which makes all times +relative to the local time zone, in the VMS tradition. + +=back + +=head1 Modules + +=head2 Required Updates + +Though Perl 5.004 is compatible with almost all modules that work +with Perl 5.003, there are a few exceptions: + + Module Required Version for Perl 5.004 + ------ ------------------------------- + Filter Filter-1.12 + LWP libwww-perl-5.08 + Tk Tk400.202 (-w makes noise) + +Also, the majordomo mailing list program, version 1.94.1, doesn't work +with Perl 5.004 (nor with perl 4), because it executes an invalid +regular expression. This bug is fixed in majordomo version 1.94.2. + +=head2 Installation directories + +The I<installperl> script now places the Perl source files for +extensions in the architecture-specific library directory, which is +where the shared libraries for extensions have always been. This +change is intended to allow administrators to keep the Perl 5.004 +library directory unchanged from a previous version, without running +the risk of binary incompatibility between extensions' Perl source and +shared libraries. + +=head2 Module information summary + +Brand new modules, arranged by topic rather than strictly +alphabetically: + + CGI.pm Web server interface ("Common Gateway Interface") + CGI/Apache.pm Support for Apache's Perl module + CGI/Carp.pm Log server errors with helpful context + CGI/Fast.pm Support for FastCGI (persistent server process) + CGI/Push.pm Support for server push + CGI/Switch.pm Simple interface for multiple server types + + CPAN Interface to Comprehensive Perl Archive Network + CPAN::FirstTime Utility for creating CPAN configuration file + CPAN::Nox Runs CPAN while avoiding compiled extensions + + IO.pm Top-level interface to IO::* classes + IO/File.pm IO::File extension Perl module + IO/Handle.pm IO::Handle extension Perl module + IO/Pipe.pm IO::Pipe extension Perl module + IO/Seekable.pm IO::Seekable extension Perl module + IO/Select.pm IO::Select extension Perl module + IO/Socket.pm IO::Socket extension Perl module + + Opcode.pm Disable named opcodes when compiling Perl code + + ExtUtils/Embed.pm Utilities for embedding Perl in C programs + ExtUtils/testlib.pm Fixes up @INC to use just-built extension + + FindBin.pm Find path of currently executing program + + Class/Struct.pm Declare struct-like datatypes as Perl classes + File/stat.pm By-name interface to Perl's builtin stat + Net/hostent.pm By-name interface to Perl's builtin gethost* + Net/netent.pm By-name interface to Perl's builtin getnet* + Net/protoent.pm By-name interface to Perl's builtin getproto* + Net/servent.pm By-name interface to Perl's builtin getserv* + Time/gmtime.pm By-name interface to Perl's builtin gmtime + Time/localtime.pm By-name interface to Perl's builtin localtime + Time/tm.pm Internal object for Time::{gm,local}time + User/grent.pm By-name interface to Perl's builtin getgr* + User/pwent.pm By-name interface to Perl's builtin getpw* + + Tie/RefHash.pm Base class for tied hashes with references as keys + + UNIVERSAL.pm Base class for *ALL* classes + +=head2 Fcntl + +New constants in the existing Fcntl modules are now supported, +provided that your operating system happens to support them: + + F_GETOWN F_SETOWN + O_ASYNC O_DEFER O_DSYNC O_FSYNC O_SYNC + O_EXLOCK O_SHLOCK + +These constants are intended for use with the Perl operators sysopen() +and fcntl() and the basic database modules like SDBM_File. For the +exact meaning of these and other Fcntl constants please refer to your +operating system's documentation for fcntl() and open(). + +In addition, the Fcntl module now provides these constants for use +with the Perl operator flock(): + + LOCK_SH LOCK_EX LOCK_NB LOCK_UN + +These constants are defined in all environments (because where there is +no flock() system call, Perl emulates it). However, for historical +reasons, these constants are not exported unless they are explicitly +requested with the ":flock" tag (e.g. C<use Fcntl ':flock'>). + +=head2 IO + +The IO module provides a simple mechanism to load all of the IO modules at one +go. Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its +respective documentation. + +=head2 Math::Complex + +The Math::Complex module has been totally rewritten, and now supports +more operations. These are overloaded: + + + - * / ** <=> neg ~ abs sqrt exp log sin cos atan2 "" (stringify) + +And these functions are now exported: + + pi i Re Im arg + log10 logn ln cbrt root + tan + csc sec cot + asin acos atan + acsc asec acot + sinh cosh tanh + csch sech coth + asinh acosh atanh + acsch asech acoth + cplx cplxe + +=head2 Math::Trig + +This new module provides a simpler interface to parts of Math::Complex for +those who need trigonometric functions only for real numbers. + +=head2 DB_File + +There have been quite a few changes made to DB_File. Here are a few of +the highlights: + +=over + +=item * + +Fixed a handful of bugs. + +=item * + +By public demand, added support for the standard hash function exists(). + +=item * + +Made it compatible with Berkeley DB 1.86. + +=item * + +Made negative subscripts work with RECNO interface. + +=item * + +Changed the default flags from O_RDWR to O_CREAT|O_RDWR and the default +mode from 0640 to 0666. + +=item * + +Made DB_File automatically import the open() constants (O_RDWR, +O_CREAT etc.) from Fcntl, if available. + +=item * + +Updated documentation. + +=back + +Refer to the HISTORY section in DB_File.pm for a complete list of +changes. Everything after DB_File 1.01 has been added since 5.003. + +=head2 Net::Ping + +Major rewrite - support added for both udp echo and real icmp pings. + +=head2 Object-oriented overrides for builtin operators + +Many of the Perl builtins returning lists now have +object-oriented overrides. These are: + + File::stat + Net::hostent + Net::netent + Net::protoent + Net::servent + Time::gmtime + Time::localtime + User::grent + User::pwent + +For example, you can now say + + use File::stat; + use User::pwent; + $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid); + +=head1 Utility Changes + +=head2 pod2html + +=over + +=item Sends converted HTML to standard output + +The I<pod2html> utility included with Perl 5.004 is entirely new. +By default, it sends the converted HTML to its standard output, +instead of writing it to a file like Perl 5.003's I<pod2html> did. +Use the B<--outfile=FILENAME> option to write to a file. + +=back + +=head2 xsubpp + +=over + +=item C<void> XSUBs now default to returning nothing + +Due to a documentation/implementation bug in previous versions of +Perl, XSUBs with a return type of C<void> have actually been +returning one value. Usually that value was the GV for the XSUB, +but sometimes it was some already freed or reused value, which would +sometimes lead to program failure. + +In Perl 5.004, if an XSUB is declared as returning C<void>, it +actually returns no value, i.e. an empty list (though there is a +backward-compatibility exception; see below). If your XSUB really +does return an SV, you should give it a return type of C<SV *>. + +For backward compatibility, I<xsubpp> tries to guess whether a +C<void> XSUB is really C<void> or if it wants to return an C<SV *>. +It does so by examining the text of the XSUB: if I<xsubpp> finds +what looks like an assignment to C<ST(0)>, it assumes that the +XSUB's return type is really C<SV *>. + +=back + +=head1 C Language API Changes + +=over + +=item C<gv_fetchmethod> and C<perl_call_sv> + +The C<gv_fetchmethod> function finds a method for an object, just like +in Perl 5.003. The GV it returns may be a method cache entry. +However, in Perl 5.004, method cache entries are not visible to users; +therefore, they can no longer be passed directly to C<perl_call_sv>. +Instead, you should use the C<GvCV> macro on the GV to extract its CV, +and pass the CV to C<perl_call_sv>. + +The most likely symptom of passing the result of C<gv_fetchmethod> to +C<perl_call_sv> is Perl's producing an "Undefined subroutine called" +error on the I<second> call to a given method (since there is no cache +on the first call). + +=item C<perl_eval_pv> + +A new function handy for eval'ing strings of Perl code inside C code. +This function returns the value from the eval statement, which can +be used instead of fetching globals from the symbol table. See +L<perlguts>, L<perlembed> and L<perlcall> for details and examples. + +=item Extended API for manipulating hashes + +Internal handling of hash keys has changed. The old hashtable API is +still fully supported, and will likely remain so. The additions to the +API allow passing keys as C<SV*>s, so that C<tied> hashes can be given +real scalars as keys rather than plain strings (nontied hashes still +can only use strings as keys). New extensions must use the new hash +access functions and macros if they wish to use C<SV*> keys. These +additions also make it feasible to manipulate C<HE*>s (hash entries), +which can be more efficient. See L<perlguts> for details. + +=back + +=head1 Documentation Changes + +Many of the base and library pods were updated. These +new pods are included in section 1: + +=over + +=item L<perldelta> + +This document. + +=item L<perlfaq> + +Frequently asked questions. + +=item L<perllocale> + +Locale support (internationalization and localization). + +=item L<perltoot> + +Tutorial on Perl OO programming. + +=item L<perlapio> + +Perl internal IO abstraction interface. + +=item L<perlmodlib> + +Perl module library and recommended practice for module creation. +Extracted from L<perlmod> (which is much smaller as a result). + +=item L<perldebug> + +Although not new, this has been massively updated. + +=item L<perlsec> + +Although not new, this has been massively updated. + +=back + +=head1 New Diagnostics + +Several new conditions will trigger warnings that were +silent before. Some only affect certain platforms. +The following new warnings and errors outline these. +These messages are classified as follows (listed in +increasing order of desperation): + + (W) A warning (optional). + (D) A deprecation (optional). + (S) A severe warning (mandatory). + (F) A fatal error (trappable). + (P) An internal error you should never see (trappable). + (X) A very fatal error (nontrappable). + (A) An alien error message (not generated by Perl). + +=over + +=item "my" variable %s masks earlier declaration in same scope + +(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 +destroyed. + +=item %s argument is not a HASH element or slice + +(F) The argument to delete() must be either a hash element, such as + + $foo{$bar} + $ref->[12]->{"susie"} + +or a hash slice, such as + + @foo{$bar, $baz, $xyzzy} + @{$ref->[12]}{"susie", "queue"} + +=item Allocation too large: %lx + +(X) You can't allocate more than 64K on an MS-DOS machine. + +=item Allocation too large + +(F) You can't allocate more than 2^31+"small amount" bytes. + +=item Applying %s to %s will act on scalar(%s) + +(W) The pattern match (//), substitution (s///), and transliteration (tr///) +operators work on scalar values. If you apply one of them to an array +or a hash, it will convert the array or hash to a scalar value -- the +length of an array, or the population info of a hash -- and then work on +that scalar value. This is probably not what you meant to do. See +L<perlfunc/grep> and L<perlfunc/map> for alternatives. + +=item Attempt to free nonexistent shared string + +(P) Perl maintains a reference counted internal table of strings to +optimize the storage and access of hash keys and other strings. This +indicates someone tried to decrement the reference count of a string +that can no longer be found in the table. + +=item Attempt to use reference as lvalue in substr + +(W) You supplied a reference as the first argument to substr() used +as an lvalue, which is pretty strange. Perhaps you forgot to +dereference it first. See L<perlfunc/substr>. + +=item Bareword "%s" refers to nonexistent package + +(W) You used a qualified bareword of the form C<Foo::>, but +the compiler saw no other uses of that namespace before that point. +Perhaps you need to predeclare a package? + +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really want to do +this, you should write C<sort { &func } @x> instead of C<sort func @x>. + +=item Can't use bareword ("%s") as %s ref while "strict refs" in use + +(F) Only hard references are allowed by "strict refs". Symbolic references +are disallowed. See L<perlref>. + +=item Cannot resolve method `%s' overloading `%s' in package `%s' + +(P) Internal error trying to resolve overloading specified by a method +name (as opposed to a subroutine reference). + +=item Constant subroutine %s redefined + +(S) You redefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + +=item Constant subroutine %s undefined + +(S) You undefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + +=item Copy method did not return a reference + +(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. + +=item Died + +(F) You passed die() an empty string (the equivalent of C<die "">) or +you called it with no args and both C<$@> and C<$_> were empty. + +=item Exiting pseudo-block via %s + +(W) You are exiting a rather special block construct (like a sort block or +subroutine) by unconventional means, such as a goto, or a loop control +statement. See L<perlfunc/sort>. + +=item Identifier too long + +(F) Perl limits identifiers (names for variables, functions, etc.) to +252 characters for simple names, somewhat more for compound names (like +C<$A::B>). You've exceeded Perl's limits. Future versions of Perl are +likely to eliminate these arbitrary limitations. + +=item Illegal character %s (carriage return) + +(F) A carriage return character was found in the input. This is an +error, and not a warning, because carriage return characters can break +multi-line strings, including here documents (e.g., C<print E<lt>E<lt>EOF;>). + +=item Illegal switch in PERL5OPT: %s + +(X) The PERL5OPT environment variable may only be used to set the +following switches: B<-[DIMUdmw]>. + +=item Integer overflow in hex number + +(S) The literal hex number you have specified is too big for your +architecture. On a 32-bit architecture the largest hex literal is +0xFFFFFFFF. + +=item Integer overflow in octal number + +(S) The literal octal number you have specified is too big for your +architecture. On a 32-bit architecture the largest octal literal is +037777777777. + +=item internal error: glob failed + +(P) Something went wrong with the external program(s) used for C<glob> +and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is +broken. If so, you should change all of the csh-related variables in +config.sh: If you have tcsh, make the variables refer to it as if it +were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all +empty (except that C<d_csh> should be C<'undef'>) so that Perl will +think csh is missing. In either case, after editing config.sh, run +C<./Configure -S> and rebuild Perl. + +=item Invalid conversion in %s: "%s" + +(W) Perl does not understand the given format conversion. +See L<perlfunc/sprintf>. + +=item Invalid type in pack: '%s' + +(F) The given character is not a valid pack type. See L<perlfunc/pack>. + +=item Invalid type in unpack: '%s' + +(F) The given character is not a valid unpack type. See L<perlfunc/unpack>. + +=item Name "%s::%s" used only once: possible typo + +(W) Typographical errors often show up as unique variable names. +If you had a good reason for having a unique name, then just mention +it again somehow to suppress the message (the C<use vars> pragma is +provided for just this purpose). + +=item Null picture in formline + +(F) The first argument to formline must be a valid format picture +specification. It was found to be empty, which probably means you +supplied it an uninitialized value. See L<perlform>. + +=item Offset outside string + +(F) You tried to do a read/write/send/recv operation with an offset +pointing outside the buffer. This is difficult to imagine. +The sole exception to this is that C<sysread()>ing past the buffer +will extend the buffer and zero pad the new area. + +=item Out of memory! + +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +The request was judged to be small, so the possibility to trap it +depends on the way Perl was compiled. By default 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. In this case the +error is trappable I<once>. + +=item Out of memory during request for %s + +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so +a possibility to shut down by trapping this error is granted. + +=item panic: frexp + +(P) The library function frexp() failed, making printf("%f") impossible. + +=item Possible attempt to put comments in qw() list + +(W) qw() lists contain items separated by whitespace; as with literal +strings, comment characters are not ignored, but are instead treated +as literal data. (You may have used different delimiters than the +parentheses shown here; braces are also frequently used.) + +You probably wrote something like this: + + @list = qw( + a # a comment + b # another comment + ); + +when you should have written this: + + @list = qw( + a + b + ); + +If you really want comments, build your list the +old-fashioned way, with quotes and commas: + + @list = ( + 'a', # a comment + 'b', # another comment + ); + +=item Possible attempt to separate words with commas + +(W) qw() lists contain items separated by whitespace; therefore commas +aren't needed to separate the items. (You may have used different +delimiters than the parentheses shown here; braces are also frequently +used.) + +You probably wrote something like this: + + qw! a, b, c !; + +which puts literal commas into some of the list items. Write it without +commas if you don't want them to appear in your data: + + qw! a b c !; + +=item Scalar value @%s{%s} better written as $%s{%s} + +(W) You've used a hash slice (indicated by @) to select a single element of +a hash. Generally it's better to ask for a scalar value (indicated by $). +The difference is that C<$foo{&bar}> always behaves like a scalar, both when +assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves +like a list when you assign to it, and provides a list context to its +subscript, which can do weird things if you're expecting only one subscript. + +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importing stubs. +Stubs should never be implicitely created, but explicit calls to C<can> +may break this. + +=item Too late for "B<-T>" option + +(X) The #! line (or local equivalent) in a Perl script contains the +B<-T> option, but Perl was not invoked with B<-T> in its argument +list. This is an error because, by the time Perl discovers a B<-T> in +a script, it's too late to properly taint everything from the +environment. So Perl gives up. + +=item untie attempted while %d inner references still exist + +(W) A copy of the object returned from C<tie> (or C<tied>) was still +valid when C<untie> was called. + +=item Unrecognized character %s + +(F) The Perl parser has no idea what to do with the specified character +in your Perl script (or eval). Perhaps you tried to run a compressed +script, a binary program, or a directory as a Perl program. + +=item Unsupported function fork + +(F) Your version of executable does not support forking. + +Note that under some systems, like OS/2, there may be different flavors of +Perl executables, some of which may support fork, some not. Try changing +the name you call Perl by to C<perl_>, C<perl__>, and so on. + +=item Use of "$$<digit>" to mean "${$}<digit>" is deprecated + +(D) Perl versions before 5.004 misinterpreted any type marker followed +by "$" and a digit. For example, "$$0" was incorrectly taken to mean +"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. + +However, the developers of Perl 5.004 could not fix this bug completely, +because at least two widely-used modules depend on the old meaning of +"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the +old (broken) way inside strings; but it generates this message as a +warning. And in Perl 5.005, this special treatment will cease. + +=item Value of %s can be "0"; test with defined() + +(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>, +or C<readdir()> as a boolean value. Each of these constructs can return a +value of "0"; that would make the conditional expression false, which is +probably not what you intended. When using these constructs in conditional +expressions, test their values with the C<defined> operator. + +=item Variable "%s" may be unavailable + +(W) An inner (nested) I<anonymous> subroutine is inside a I<named> +subroutine, and outside that is another subroutine; and the anonymous +(innermost) subroutine is referencing a lexical variable defined in +the outermost subroutine. For example: + + sub outermost { my $a; sub middle { sub { $a } } } + +If the anonymous subroutine is called or referenced (directly or +indirectly) from the outermost subroutine, it will share the variable +as you would expect. But if the anonymous subroutine is called or +referenced when the outermost subroutine is not active, it will see +the value of the shared variable as it was before and during the +*first* call to the outermost subroutine, which is probably not what +you want. + +In these circumstances, it is usually best to make the middle +subroutine anonymous, using the C<sub {}> syntax. Perl has specific +support for shared variables in nested anonymous subroutines; a named +subroutine in between interferes with this feature. + +=item Variable "%s" will not stay shared + +(W) An inner (nested) I<named> subroutine is referencing a lexical +variable defined in an outer subroutine. + +When the inner subroutine is called, it will probably see the value of +the outer subroutine's variable as it was before and during the +*first* call to the outer subroutine; in this case, after the first +call to the outer subroutine is complete, the inner and outer +subroutines will no longer share a common value for the variable. In +other words, the variable will no longer be shared. + +Furthermore, if the outer subroutine is anonymous and references a +lexical variable outside itself, then the outer and inner subroutines +will I<never> share the given variable. + +This problem can usually be solved by making the inner subroutine +anonymous, using the C<sub {}> syntax. When inner anonymous subs that +reference variables in outer subroutines are called or referenced, +they are automatically rebound to the current values of such +variables. + +=item Warning: something's wrong + +(W) You passed warn() an empty string (the equivalent of C<warn "">) or +you called it with no args and C<$_> was empty. + +=item Ill-formed logical name |%s| in prime_env_iter + +(W) A warning peculiar to VMS. A logical name was encountered when preparing +to iterate over %ENV which violates the syntactic rules governing logical +names. Since it cannot be translated normally, it is skipped, and will not +appear in %ENV. This may be a benign occurrence, as some software packages +might directly modify logical name tables and introduce nonstandard names, +or it may indicate that a logical name table has been corrupted. + +=item Got an error from DosAllocMem + +(P) An error peculiar to OS/2. Most probably you're using an obsolete +version of Perl, and this should not happen anyway. + +=item Malformed PERLLIB_PREFIX + +(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form + + prefix1;prefix2 + +or + + prefix1 prefix2 + +with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix +of a builtin library search path, prefix2 is substituted. The error +may appear if components are not found, or are too long. See +"PERLLIB_PREFIX" in F<README.os2>. + +=item PERL_SH_DIR too long + +(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the +C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>. + +=item Process terminated by SIG%s + +(W) This is a standard message issued by OS/2 applications, while *nix +applications die in silence. It is considered a feature of the OS/2 +port. One can easily disable this by appropriate sighandlers, see +L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT" +in F<README.os2>. + +=back + +=head1 BUGS + +If you find what you think is a bug, you might check the headers of +recently posted articles in the comp.lang.perl.misc newsgroup. +There may also be information at http://www.perl.com/perl/, the Perl +Home Page. + +If you believe you have an unreported bug, please run the B<perlbug> +program included with your release. Make sure you trim your bug down +to a tiny but sufficient test case. Your bug report, along with the +output of C<perl -V>, will be sent off to <F<perlbug@perl.com>> to be +analysed by the Perl porting team. + +=head1 SEE ALSO + +The F<Changes> file for exhaustive details on what changed. + +The F<INSTALL> file for how to build Perl. This file has been +significantly updated for 5.004, so even veteran users should +look through it. + +The F<README> file for general stuff. + +The F<Copying> file for copyright information. + +=head1 HISTORY + +Constructed by Tom Christiansen, grabbing material with permission +from innumerable contributors, with kibitzing by more than a few Perl +porters. + +Last update: Wed May 14 11:14:09 EDT 1997 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 96f5c671ea..d51551756a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1094,6 +1094,13 @@ a goto, or a loop control statement. (W) You are exiting a substitution by unconventional means, such as a return, a goto, or a loop control statement. +=item Explicit blessing to '' (assuming package main) + +(W) You are blessing a reference to a zero length string. This has +the effect of blessing the reference into the package main. This is +usually not what you want. Consider providing a default target +package, e.g. bless($ref, $p or 'MyPackage'); + =item Fatal VMS error at %s, line %d (P) An error peculiar to VMS. Something untoward happened in a VMS system @@ -1272,6 +1279,12 @@ don't take to this kindly. (W) You may have tried to use an 8 or 9 in a octal number. Interpretation of the octal number stopped before the 8 or 9. +=item Illegal hex digit ignored + +(W) You may have tried to use a character other than 0 - 9 or A - F in a +hexadecimal number. Interpretation of the hexadecimal number stopped +before the illegal character. + =item Illegal switch in PERL5OPT: %s (X) The PERL5OPT environment variable may only be used to set the @@ -1919,7 +1932,7 @@ was string. (P) The lexer got into a bad state while processing a case modifier. -=item Pareneses missing around "%s" list +=item Parentheses missing around "%s" list (W) You said something like @@ -1957,8 +1970,7 @@ the BSD version, which takes a pid. (W) qw() lists contain items separated by whitespace; as with literal strings, comment characters are not ignored, but are instead treated as literal data. (You may have used different delimiters than the -exclamation marks parentheses shown here; braces are also frequently -used.) +parentheses shown here; braces are also frequently used.) You probably wrote something like this: @@ -2075,6 +2087,18 @@ to use parens. In any case, a hash requires key/value B<pairs>. %hash = ( one => 1, two => 2, ); # right %hash = qw( one 1 two 2 ); # also fine +=item Reference found where even-sized list expected + +(W) You gave a single reference where Perl was expecting a list with +an even number of elements (for assignment to a hash). This +usually means that you used the anon hash constructor when you meant +to use parens. In any case, a hash requires key/value B<pairs>. + + %hash = { one => 1, two => 2, }; # WRONG + %hash = [ qw/ an anon array / ]; # WRONG + %hash = ( one => 1, two => 2, ); # right + %hash = qw( one 1 two 2 ); # also fine + =item Reference miscount in sv_replace() (W) The internal sv_replace() function was handed a new SV with a @@ -2183,6 +2207,7 @@ or possibly some other missing operator, such as a comma. Check your logic flow. =item Sequence (? incomplete + (F) A regular expression ended with an incomplete extension (?. See L<perlre>. @@ -2565,6 +2590,11 @@ have been defined yet. See L<perlfunc/sort>. (F) The format indicated doesn't seem to exist. Perhaps it's really in another package? See L<perlform>. +=item Undefined value assigned to typeglob + +(W) An undefined value was assigned to a typeglob, a la C<*foo = undef>. +This does nothing. It's possible that you really mean C<undef *foo>. + =item unexec of %s into %s failed! (F) The unexec() routine failed for some reason. See your local FSF @@ -2636,7 +2666,7 @@ the name you call Perl by to C<perl_>, C<perl__>, and so on. =item Unsupported function %s -(F) This machines doesn't implement the indicated function, apparently. +(F) This machine doesn't implement the indicated function, apparently. At least, Configure doesn't think so. =item Unsupported socket function "%s" called @@ -2696,7 +2726,7 @@ a split() explicitly to an array (or list). (D) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are looked up as methods (using the C<@ISA> hierarchy) even when the subroutines to be autoloaded were called as plain functions (e.g. C<Foo::bar()>), not -as methods (e.g. C<Foo->bar()> or C<$obj->bar()>). +as methods (e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). This bug will be rectified in Perl 5.005, which will use method lookup only for methods' C<AUTOLOAD>s. However, there is a significant base @@ -2711,7 +2741,7 @@ 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';>. +C<use AutoLoader 'AUTOLOAD';>. =item Use of %s is deprecated diff --git a/pod/perldsc.pod b/pod/perldsc.pod index 48750dd5de..cd689e37bc 100644 --- a/pod/perldsc.pod +++ b/pod/perldsc.pod @@ -305,7 +305,7 @@ debugger includes several new features, including command line editing as well as the C<x> command to dump out complex data structures. For example, given the assignment to $LoL above, here's the debugger output: - DB<1> X $LoL + DB<1> x $LoL $LoL = ARRAY(0x13b5a0) 0 ARRAY(0x1f0a24) 0 'fred' @@ -324,8 +324,6 @@ example, given the assignment to $LoL above, here's the debugger output: 2 'elroy' 3 'judy' -There's also a lowercase B<x> command which is nearly the same. - =head1 CODE EXAMPLES Presented with little comment (these will get their own manpages someday) diff --git a/pod/perlembed.pod b/pod/perlembed.pod index 32096789ec..689050c466 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -12,7 +12,7 @@ Do you want to: =item B<Use C from Perl?> -Read L<perlcall> and L<perlxs>. +Read L<perlxs>, L<perlxstut> and L<h2xs>. =item B<Use a Unix program from Perl?> @@ -20,8 +20,7 @@ Read about back-quotes and about C<system> and C<exec> in L<perlfunc>. =item B<Use Perl from Perl?> -Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlfunc/require> -and L<perlfunc/use>. +Read about do(), eval(), require(), and use() in L<perlfunc>. =item B<Use C from C?> @@ -35,27 +34,49 @@ Read on... =head2 ROADMAP -L<Compiling your C program> +Compiling your C program There's one example in each of the nine sections: -L<Adding a Perl interpreter to your C program> +=over 4 -L<Calling a Perl subroutine from your C program> +=item * -L<Evaluating a Perl statement from your C program> +Adding a Perl interpreter to your C program -L<Performing Perl pattern matches and substitutions from your C program> +=item * -L<Fiddling with the Perl stack from your C program> +Calling a Perl subroutine from your C program -L<Maintaining a persistent interpreter> +=item * -L<Maintaining multiple interpreter instances> +Evaluating a Perl statement from your C program -L<Using Perl modules, which themselves use C libraries, from your C program> +=item * -L<Embedding Perl under Win32> +Performing Perl pattern matches and substitutions from your C program + +=item * + +Fiddling with the Perl stack from your C program + +=item * + +Maintaining a persistent interpreter + +=item * + +Maintaining multiple interpreter instances + +=item * + +Using Perl modules, which themselves use C libraries, from your C program + +=item * + +Embedding Perl under Win32 + +=back =head2 Compiling your C program @@ -96,7 +117,7 @@ Execute this statement for a hint about where to find CORE: perl -MConfig -e 'print $Config{archlib}' Here's how you'd compile the example in the next section, -L<Adding a Perl interpreter to your C program>, on my Linux box: +Adding a Perl interpreter to your C program, on my Linux box: % gcc -O2 -Dbool=char -DHAS_BOOL -I/usr/local/include -I/usr/local/lib/perl5/i586-linux/5.003/CORE @@ -199,8 +220,8 @@ calling I<perl_run()>. =head2 Calling a Perl subroutine from your C program To call individual Perl subroutines, you can use any of the B<perl_call_*> -functions documented in the L<perlcall> manpage. -In this example we'll use I<perl_call_argv>. +functions documented in L<perlcall>. +In this example we'll use perl_call_argv(). That's shown below, in a program I'll call I<showtime.c>. @@ -257,21 +278,20 @@ If you want to pass arguments to the Perl subroutine, you can add strings to the C<NULL>-terminated C<args> list passed to I<perl_call_argv>. For other data types, or to examine return values, you'll need to manipulate the Perl stack. That's demonstrated in the -last section of this document: L<Fiddling with the Perl stack from -your C program>. +last section of this document: Fiddling with the Perl stack from +your C program. =head2 Evaluating a Perl statement from your C program Perl provides two API functions to evaluate pieces of Perl code. -These are L<perlguts/perl_eval_sv()> and L<perlguts/perl_eval_pv()>. +These are perl_eval_sv() and perl_eval_pv(). Arguably, these are the only routines you'll ever need to execute snippets of Perl code from within your C program. Your code can be as long as you wish; it can contain multiple statements; it can employ -L<perlfunc/use>, L<perlfunc/require> and L<perlfunc/do> to include -external Perl files. +use(), require(), and do() to include external Perl files. -I<perl_eval_pv()> lets us evaluate individual Perl strings, and then +perl_eval_pv() lets us evaluate individual Perl strings, and then extract variables for coercion into C types. The following program, I<string.c>, executes three Perl strings, extracting an C<int> from the first, a C<float> from the second, and a C<char *> from the third. @@ -320,7 +340,7 @@ I<SvPV()> to create a string: In the example above, we've created a global variable to temporarily store the computed value of our eval'd expression. It is also possible and in most cases a better strategy to fetch the return value -from L<perl_eval_pv> instead. Example: +from perl_eval_pv() instead. Example: ... SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE); @@ -626,10 +646,10 @@ troubles. One way to avoid namespace collisions in this scenario is to translate the filename into a guaranteed-unique package name, and then compile -the code into that package using L<perlfunc/eval>. In the example +the code into that package using eval(). In the example below, each file will only be compiled once. Or, the application might choose to clean out the symbol table associated with the file -after it's no longer needed. Using L<perlcall/perl_call_argv>, We'll +after it's no longer needed. Using perl_call_argv(), We'll call the subroutine C<Embed::Persistent::eval_file> which lives in the file C<persistent.pl> and pass the filename and boolean cleanup/cache flag as arguments. @@ -640,7 +660,7 @@ conditions that cause Perl's symbol table to grow. You might want to add some logic that keeps track of the process size, or restarts itself after a certain number of requests, to ensure that memory consumption is minimized. You'll also want to scope your variables -with L<perlfunc/my> whenever possible. +with my() whenever possible. package Embed::Persistent; diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index bbc361a5ba..0f73eea978 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -169,7 +169,7 @@ include alt.sources; see their FAQ for details. =head2 Perl Books -A number books on Perl and/or CGI programming are available. A few of +A number of books on Perl and/or CGI programming are available. A few of these are good, some are ok, but many aren't worth your money. Tom Christiansen maintains a list of these books, some with extensive reviews, at http://www.perl.com/perl/critiques/index.html. @@ -314,7 +314,7 @@ to join or leave this list. =item Perl-Packrats Discussion related to archiving of perl materials, particularly the -Comprehensive PerlArchive Network (CPAN). Subscribe by emailing +Comprehensive Perl Archive Network (CPAN). Subscribe by emailing majordomo@cis.ufl.edu: subscribe perl-packrats diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 65ebafdea5..7a307594da 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -85,7 +85,7 @@ perl-mode for emacs can provide a remarkable amount of help with most (but not all) code, and even less programmable editors can provide significant assistance. -If you are using to using vgrind program for printing out nice code to +If you are used to using vgrind program for printing out nice code to a laser printer, you can take a stab at this using http://www.perl.com/CPAN/doc/misc/tips/working.vgrind.entry, but the results are not particularly satisfying for sophisticated code. @@ -260,7 +260,7 @@ module written in C can. With the FCGI module (from CPAN), a Perl executable compiled with sfio (see the F<INSTALL> file in the distribution) and the mod_fastcgi module (available from http://www.fastcgi.com/) each of your perl scripts becomes a permanent -CGI daemon processes. +CGI daemon process. Both of these solutions can have far-reaching effects on your system and on the way you write your CGI scripts, so investigate them with diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index a5b505c4a7..4c38d906ba 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -559,7 +559,7 @@ quite a lot of space by using bit strings instead: @articles = ( 1..10, 150..2000, 2017 ); undef $read; - grep (vec($read,$_,1) = 1, @articles); + for (@articles) { vec($read,$_,1) = 1 } Now check whether C<vec($read,$n,1)> is true for some C<$n>. diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index 03d5e6a797..5d71f648de 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -802,7 +802,7 @@ files. =head2 Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? This is elaborately and painstakingly described in the "Far More Than -You Every Wanted To Know" in +You Ever Wanted To Know" in http://www.perl.com/CPAN/doc/FMTEYEWTK/file-dir-perms . The executive summary: learn how your filesystem works. The diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 283aa2bb34..d62ee36621 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -669,7 +669,7 @@ before Perl has seen that such a package exists. It's wisest to make sure your packages are all defined before you start using them, which will be taken care of if you use the C<use> statement instead of C<require>. If not, make sure to use arrow notation (eg, -C<Guru->find("Samy")>) instead. Object notation is explained in +C<Guru-E<gt>find("Samy")>) instead. Object notation is explained in L<perlobj>. =head2 How can I find out my current package? diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index f4d3c12f6f..dbc1bcd10e 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -269,7 +269,7 @@ http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl . In general, you may not be able to. The Time::HiRes module (available from CPAN) provides this functionality for some systems. -In general, you may not be able to. But if you system supports both the +In general, you may not be able to. But if your system supports both the syscall() function in Perl as well as a system call like gettimeofday(2), then you may be able to do something like this: @@ -758,8 +758,9 @@ If your version of perl is compiled without dynamic loading, then you just need to replace step 3 (B<make>) with B<make perl> and you will get a new F<perl> binary with your extension linked in. -See L<ExtUtils::MakeMaker> for more details on building extensions, -the question "How do I keep my own module/library directory?" +See L<ExtUtils::MakeMaker> for more details on building extensions +and an answer to the question "How do I keep my own module/library +directory?" =head2 How do I keep my own module/library directory? @@ -778,7 +779,7 @@ See Perl's L<lib> for more information. =head2 How do I add the directory my program lives in to the module/library search path? use FindBin; - use lib "$FindBin:Bin"; + use lib "$FindBin::Bin"; use your_own_modules; =head2 How do I add a directory to my include path at runtime? diff --git a/pod/perlform.pod b/pod/perlform.pod index 7e540b8ff6..0b2a68c3d4 100644 --- a/pod/perlform.pod +++ b/pod/perlform.pod @@ -20,8 +20,8 @@ apart from all the other "types" in Perl. This means that if you have a function named "Foo", it is not the same thing as having a format named "Foo". However, the default name for the format associated with a given filehandle is the same as the name of the filehandle. Thus, the default -format for STDOUT is name "STDOUT", and the default format for filehandle -TEMP is name "TEMP". They just look the same. They aren't. +format for STDOUT is named "STDOUT", and the default format for filehandle +TEMP is named "TEMP". They just look the same. They aren't. Output record formats are declared as follows: diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index f509f61553..28a3ba152d 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -657,7 +657,7 @@ Breaks the binding between a DBM file and a hash. [This function has been superseded by the tie() function.] -This binds a dbm(3), ndbm(3), sdbm(3), gdbm(), or Berkeley DB file to a +This binds a dbm(3), ndbm(3), sdbm(3), gdbm(3), or Berkeley DB file to a hash. HASH is the name of the hash. (Unlike normal open, the first argument is I<NOT> a filehandle, even though it looks like one). DBNAME is the name of the database (without the F<.dir> or F<.pag> extension if @@ -863,7 +863,9 @@ is just like except that it's more efficient, more concise, keeps track of the current filename for error messages, and searches all the B<-I> libraries if the file isn't in the current directory (see also the @INC -array in L<perlvar/Predefined Names>). It's the same, however, in that it does +array in L<perlvar/Predefined Names>). It is also different in how +code evaluated with C<do FILENAME> doesn't see lexicals in the enclosing +scope like C<eval STRING> does. It's the same, however, in that it does reparse the file every time you call it, so you probably don't want to do this inside a loop. @@ -1074,11 +1076,22 @@ in case 6. =item exec LIST +=item exec PROGRAM LIST + 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). +Since it's a common mistake to use system() instead of exec(), Perl +warns you if there is a following statement which isn't die(), warn() +or exit() (if C<-w> is set - but you always do that). If you +I<really> want to follow an exec() with some other statement, you +can use one of these styles to avoid the warning: + + exec ('foo') or print STDERR "couldn't exec foo"; + { exec ('foo') }; print STDERR "couldn't exec foo"; + 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 there is only one scalar argument, the argument is checked for shell @@ -1182,6 +1195,12 @@ that doesn't implement flock(2), fcntl(2) locking, or lockf(3). flock() is Perl's portable file locking interface, although it locks only entire files, not records. +On many platforms (including most versions or clones of Unix), locks +established by flock() are B<merely advisory>. This means that files +locked with flock() may be modified by programs which do not also use +flock(). Windows NT and OS/2, however, are among the platforms which +supply mandatory locking. See your local documentation for details. + OPERATION is one of LOCK_SH, LOCK_EX, or LOCK_UN, possibly combined with LOCK_NB. These constants are traditionally valued 1, 2, 8 and 4, but you can use the symbolic names if import them from the Fcntl module, @@ -1269,7 +1288,7 @@ you're done. You should reopen those to /dev/null if it's any issue. =item format -Declare a picture format with use by the write() function. For +Declare a picture format for use by the write() function. For example: format Something = @@ -1442,7 +1461,7 @@ system library. Within a list context, the return values from the various get routines are as follows: ($name,$passwd,$uid,$gid, - $quota,$comment,$gcos,$dir,$shell) = getpw* + $quota,$comment,$gcos,$dir,$shell,$expire) = getpw* ($name,$passwd,$gid,$members) = getgr* ($name,$aliases,$addrtype,$length,@addrs) = gethost* ($name,$aliases,$addrtype,$net) = getnet* @@ -1463,6 +1482,22 @@ lookup by name, in which case you get the other thing, whatever it is. $name = getgrent etc. +In I<getpw*()> the fields $quota, $comment, and $expire are special +cases in the sense that in many systems they are unsupported. If the +$quota is unsupported, it is an empty scalar. If it is supported, it +usually encodes the disk quota. If the $comment field is unsupported, +it is an empty scalar. If it is supported it usually encodes some +administrative comment about the user. In some systems the $quota +field may be $change or $age, fields that have to do with password +aging. In some systems the $comment field may be $class. The $expire +field, if present, encodes the expiration period of the account or the +password. For the availability and the exact meaning of these fields +in your system, please consult your getpwnam(3) documentation and your +<pwd.h> file. You can also find out from within Perl which meaning +your $quota and $comment fields have and whether you have the $expire +field by using the Config module and the values d_pwquota, d_pwage, +d_pwchange, d_pwcomment, and d_pwexpire. + The $members value returned by I<getgr*()> is a space separated list of the login names of the members of the group. @@ -1574,7 +1609,7 @@ 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. Similarly, grep returns aliases into the original list, -much like the way that L<Foreach Loops>'s index variable aliases the list +much like the way that a for 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. @@ -1786,8 +1821,8 @@ subroutine, C<eval{}>, or C<do>. If more than one value is listed, the list must be placed in parentheses. See L<perlsub/"Temporary Values via local()"> for details, including issues with tied arrays and hashes. -But you really probably want to be using my() instead, because local() isn't -what most people think of as "local"). See L<perlsub/"Private Variables +You really probably want to be using my() instead, because local() isn't +what most people think of as "local". See L<perlsub/"Private Variables via my()"> for details. =item localtime EXPR @@ -1811,10 +1846,18 @@ 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. +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. To +get somewhat similar but locale dependent date strings, set up your +locale environment variables appropriately (please see L<perllocale>) +and try for example + + use POSIX qw(strftime) + $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime; + +Note that the C<%a> and C<%b>, the short forms of the day of the week +and the month of the year, may not necessarily be three characters wide. =item log EXPR @@ -2359,7 +2402,8 @@ you will have to use a block returning its value instead: =item printf FORMAT, LIST -Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>. The first argument +Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>, except that $\ +(the output record separator) is not appended. The first argument of the list will be interpreted as the printf format. If C<use locale> is in effect, the character used for the decimal point in formatted real numbers is affected by the LC_NUMERIC locale. See L<perllocale>. @@ -2490,7 +2534,7 @@ operator is discussed in more detail in L<perlop/"I/O Operators">. Receives a message on a socket. Attempts to receive LENGTH bytes of data into variable SCALAR from the specified SOCKET filehandle. -Actually does a C recvfrom(), so that it can returns the address of the +Actually does a C recvfrom(), so that it can return the address of the sender. Returns the undefined value if there's an error. SCALAR will be grown or shrunk to the length actually read. Takes the same flags as the system call of the same name. @@ -2601,8 +2645,26 @@ replaces "F<::>" with "F</>" in the filename for you, to make it easy to load standard modules. This form of loading of modules does not risk altering your namespace. -For a yet-more-powerful import facility, see L</use> and -L<perlmod>. +In other words, if you try this: + + require Foo::Bar ; # a splendid bareword + +The require function will actually look for the "Foo/Bar.pm" file in the +directories specified in the @INC array. + +But if you try this : + + $class = 'Foo::Bar'; + require $class ; # $class is not a bareword +or + require "Foo::Bar" ; # not a bareword because of the "" + +The require function will look for the "Foo::Bar" file in the @INC array and +will complain about not finding "Foo::Bar" there. In this case you can do : + + eval "require $class"; + +For a yet-more-powerful import facility, see L</use> and L<perlmod>. =item reset EXPR @@ -2936,9 +2998,10 @@ function, or use this relation: =item sleep Causes the script to sleep for EXPR seconds, or forever if no EXPR. -May be interrupted by sending the process a SIGALRM. Returns the -number of seconds actually slept. You probably cannot mix alarm() and -sleep() calls, because sleep() is often implemented using alarm(). +May be interrupted if the process receives a signal such as SIGALRM. +Returns the number of seconds actually slept. You probably cannot +mix alarm() and sleep() calls, because sleep() is often implemented +using alarm(). On some older systems, it may sleep up to a full second less than what you requested, depending on how it counts seconds. Most modern systems @@ -2946,7 +3009,7 @@ always sleep the full amount. For delays of finer granularity than one second, you may use Perl's syscall() interface to access setitimer(2) if your system supports it, -or else see L</select()> below. +or else see L</select()> above. See also the POSIX module's sigpause() function. @@ -2976,9 +3039,10 @@ specified, it gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. (The C<E<lt>=E<gt>> and C<cmp> operators are extremely useful in such routines.) SUBNAME may be a -scalar variable name, in which case the value provides the name of the -subroutine to use. In place of a SUBNAME, you can provide a BLOCK as -an anonymous, in-line sort subroutine. +scalar variable name (unsubscripted), in which case the value provides +the name of (or a reference to) the actual subroutine to use. In place +of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort +subroutine. In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a @@ -3094,10 +3158,12 @@ sanity checks in the interest of speed. =item splice ARRAY,OFFSET Removes the elements designated by OFFSET and LENGTH from an array, and -replaces them with the elements of LIST, if any. Returns the elements -removed from the array. The array grows or shrinks as necessary. If -LENGTH is omitted, removes everything from OFFSET onward. The -following equivalences hold (assuming C<$[ == 0>): +replaces them with the elements of LIST, if any. In a list context, +returns the elements removed from the array. In a scalar context, +returns the last element removed, or C<undef> if no elements are +removed. The array grows or shrinks as necessary. If LENGTH is +omitted, removes everything from OFFSET onward. The following +equivalences hold (assuming C<$[ == 0>): push(@a,$x,$y) splice(@a,$#a+1,0,$x,$y) pop(@a) splice(@a,-1) @@ -3138,9 +3204,9 @@ 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 +If LIMIT is specified and is positive, splits into no more than that +many fields (though it may split into fewer). If LIMIT is unspecified +or zero, 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. @@ -3252,7 +3318,7 @@ and the conversion letter: + prefix positive number with a plus sign - left-justify within the field 0 use zeros, not spaces, to right-justify - # prefix octal with "0", hex with "0x" + # prefix non-zero octal with "0", non-zero hex with "0x" number minimum field width .number "precision": digits after decimal point for floating-point, max length for string, minimum length for integer @@ -3289,7 +3355,7 @@ omitted, uses a semi-random value based on the current time and process ID, among other things. In versions of Perl prior to 5.004 the default seed was just the current time(). This isn't a particularly good seed, so many old programs supply their own seed value (often C<time ^ $$> or -C<time ^ ($$ + ($$ << 15))>), but that isn't necessary any more. +C<time ^ ($$ + ($$ E<lt>E<lt> 15))>), but that isn't necessary any more. In fact, it's usually not necessary to call srand() at all, because if it is not called explicitly, it is called implicitly at the first use of @@ -3439,6 +3505,8 @@ a NAME, it's an anonymous function declaration, and does actually return a value: the CODE ref of the closure you just created. See L<perlsub> and L<perlref> for details. +=item substr EXPR,OFFSET,LEN,REPLACEMENT + =item substr EXPR,OFFSET,LEN =item substr EXPR,OFFSET @@ -3461,6 +3529,12 @@ something longer than LEN, the string will grow to accommodate it. To keep the string the same length you may need to pad or chop your value using sprintf(). +An alternative to using substr() as an lvalue is to specify the +replacement string as the 4th argument. This allows you to replace +parts of the EXPR and return what was there before in one operation. +In this case LEN can be C<undef> if you want to affect everything to +the end of the string. + =item symlink OLDFILE,NEWFILE Creates a new filename symbolically linked to the old filename. @@ -3478,13 +3552,17 @@ unimplemented, produces a fatal error. The arguments are interpreted as follows: if a given argument is numeric, the argument is passed as an int. If not, the pointer to the string value is passed. You are responsible to make sure a string is pre-extended long enough to -receive any result that might be written into a string. If your +receive any result that might be written into a string. You can't use a +string literal (or other read-only string) as an argument to syscall() +because Perl has to assume that any string pointer might be written +through. If your integer arguments are not literals and have never been interpreted in a numeric context, you may need to add 0 to them to force them to look like numbers. require 'syscall.ph'; # may need to run h2ph - syscall(&SYS_write, fileno(STDOUT), "hi there\n", 9); + $s = "hi there\n"; + syscall(&SYS_write, fileno(STDOUT), $s, length $s); Note that Perl supports passing of up to only 14 arguments to your system call, which in practice should usually suffice. @@ -3493,7 +3571,7 @@ 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. +check the value of C<$!> 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 @@ -3562,6 +3640,8 @@ the new position. =item system LIST +=item system PROGRAM LIST + Does exactly the same thing as "exec LIST" except that a fork is done first, and the parent process waits for the child process to complete. Note that argument processing varies depending on the number of @@ -3571,6 +3651,9 @@ returned by the wait() call. To get the actual exit value divide by the output from a command, for that you should use merely backticks or qx//, as described in L<perlop/"`STRING`">. +Like exec(), system() allows you to lie to a program about its name if +you use the "system PROGRAM LIST" syntax. Again, see L</exec>. + Because system() and backticks block SIGINT and SIGQUIT, killing the program they're running doesn't actually interrupt your program. @@ -3582,15 +3665,20 @@ Here's a more elaborate example of analysing the return value from system() on a Unix system to check for all possibilities, including for signals and core dumps. - $rc = 0xffff & system @args; + $! = 0; + $rc = system @args; printf "system(%s) returned %#04x: ", "@args", $rc; if ($rc == 0) { print "ran with normal exit\n"; } elsif ($rc == 0xff00) { - print "command failed: $!\n"; + # Note that $! can be an empty string if the command that + # system() tried to execute was not found, not executable, etc. + # These errors occur in the child process after system() has + # forked, so the errno value is not visible in the parent. + printf "command failed: %s\n", ($! || "Unknown system() error"); } - elsif ($rc > 0x80) { + elsif (($rc & 0xff) == 0) { $rc >>= 8; print "ran with non-zero exit status $rc\n"; } @@ -3728,7 +3816,8 @@ The transliteration operator. Same as y///. See L<perlop>. Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified length. Produces a fatal error if truncate isn't implemented -on your system. +on your system. Returns TRUE if successful, the undefined value +otherwise. =item uc EXPR @@ -3755,7 +3844,8 @@ If EXPR is omitted, uses $_. =item umask Sets the umask for the process to EXPR and returns the previous value. -If EXPR is omitted, merely returns the current umask. Remember that a +If EXPR is omitted, merely returns the current umask. If umask(2) is +not implemented on your system, returns C<undef>. Remember that a umask is a number, usually given in octal; it is I<not> a string of octal digits. See also L</oct>, if all you have is a string. @@ -3764,19 +3854,21 @@ digits. See also L</oct>, if all you have is a string. =item undef Undefines the value of EXPR, which must be an lvalue. Use only on a -scalar value, an entire array, an entire hash, or a subroutine name (using -"&"). (Using undef() will probably not do what you expect on most -predefined variables or DBM list values, so don't do that.) Always -returns the undefined value. You can omit the EXPR, in which case -nothing is undefined, but you still get an undefined value that you -could, for instance, return from a subroutine, assign to a variable or -pass as a parameter. Examples: +scalar value, an array (using "@"), a hash (using "%"), a subroutine +(using "&"), or a typeglob (using "*"). (Saying C<undef $hash{$key}> +will probably not do what you expect on most predefined variables or +DBM list values, so don't do that; see L<delete>.) Always returns the +undefined value. You can omit the EXPR, in which case nothing is +undefined, but you still get an undefined value that you could, for +instance, return from a subroutine, assign to a variable or pass as a +parameter. Examples: undef $foo; undef $bar{'blurfl'}; # Compare to: delete $bar{'blurfl'}; undef @ary; undef %hash; undef &mysub; + undef *xyz; # destroys $xyz, @xyz, %xyz, &xyz, etc. return (wantarray ? (undef, $errmsg) : undef) if $they_blew_it; select undef, undef, undef, 0.25; ($a, $b, undef, $c) = &foo; # Ignore third value returned @@ -3925,7 +4017,8 @@ Changes the access and modification times on each file of a list of files. The first two elements of the list must be the NUMERICAL access and modification times, in that order. Returns the number of files successfully changed. The inode modification time of each file is set -to the current time. Example of a "touch" command: +to the current time. This code has the same effect as the "touch" +command if the files already exist: #!/usr/bin/perl $now = time; @@ -4000,6 +4093,13 @@ for no value (void context). Produces a message on STDERR just like die(), but doesn't exit or throw an exception. +If LIST is empty and $@ already contains a value (typically from a +previous eval) that value is used after appending "\t...caught" +to $@. This is useful for staying almost, but not entirely similar to +die(). + +If $@ is empty then the string "Warning: Something's wrong" is used. + No message is printed if there is a C<$SIG{__WARN__}> handler installed. It is the handler's responsibility to deal with the message as it sees fit (like, for instance, converting it into a die()). Most diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 9b7cab627e..c27883ffcc 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -51,6 +51,7 @@ To change the value of an *already-existing* SV, there are seven routines: void sv_setpv(SV*, char*); void sv_setpvn(SV*, char*, int) void sv_setpvf(SV*, const char*, ...); + void sv_setpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool); void sv_setsv(SV*, SV*); Notice that you can choose to specify the length of the string to be @@ -58,13 +59,25 @@ assigned by using C<sv_setpvn>, C<newSVpvn>, or C<newSVpv>, or you may allow Perl to calculate the length by using C<sv_setpv> or by specifying 0 as the second argument to C<newSVpv>. Be warned, though, that Perl will determine the string's length by using C<strlen>, which depends on the -string terminating with a NUL character. The arguments of C<sv_setpvf> -are processed like C<sprintf>, and the formatted output becomes the value. +string terminating with a NUL character. + +The arguments of C<sv_setpvf> are processed like C<sprintf>, and the +formatted output becomes the value. + +C<sv_setpvfn> is an analogue of C<vsprintf>, but it allows you to specify +either a pointer to a variable argument list or the address and length of +an array of SVs. The last argument points to a boolean; on return, if that +boolean is true, then locale-specific information has been used to format +the string, and the string's contents are therefore untrustworty (see +L<perlsec>). This pointer may be NULL if that information is not +important. Note that this function requires you to specify the length of +the format. + The C<sv_set*()> functions are not generic enough to operate on values that have "magic". See L<Magic Virtual Tables> later in this document. -All SVs that will contain strings should, but need not, be terminated -with a NUL character. If it is not NUL-terminated there is a risk of +All SVs that contain strings should be terminated with a NUL character. +If it is not NUL-terminated there is a risk of core dumps and corruptions from code which passes the string to C functions or system calls which expect a NUL-terminated string. Perl's own functions typically add a trailing NUL for this reason. @@ -127,16 +140,20 @@ you can use the following functions: void sv_catpv(SV*, char*); void sv_catpvn(SV*, char*, int); void sv_catpvf(SV*, const char*, ...); + void sv_catpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool); void sv_catsv(SV*, SV*); The first function calculates the length of the string to be appended by using C<strlen>. In the second, you specify the length of the string yourself. The third function processes its arguments like C<sprintf> and -appends the formatted output. The fourth function extends the string -stored in the first SV with the string stored in the second SV. It also -forces the second SV to be interpreted as a string. The C<sv_cat*()> -functions are not generic enough to operate on values that have "magic". -See L<Magic Virtual Tables> later in this document. +appends the formatted output. The fourth function works like C<vsprintf>. +You can specify the address and length of an array of SVs instead of the +va_list argument. The fifth function extends the string stored in the first +SV with the string stored in the second SV. It also forces the second SV +to be interpreted as a string. + +The C<sv_cat*()> functions are not generic enough to operate on values that +have "magic". See L<Magic Virtual Tables> later in this document. If you know the name of a scalar variable, you can get a pointer to its SV by using the following: @@ -473,8 +490,25 @@ Perl calculate the string length. SV is blessed if C<classname> is non-null. SV* sv_setref_pvn(SV* rv, char* classname, PV iv, int length); - int sv_isa(SV* sv, char* name); - int sv_isobject(SV* sv); +Tests whether the SV is blessed into the specified class. It does not +check inheritance relationships. + + int sv_isa(SV* sv, char* name); + +Tests whether the SV is a reference to a blessed object. + + int sv_isobject(SV* sv); + +Tests whether the SV is derived from the specified class. SV can be either +a reference to a blessed object or a string containing a class name. This +is the function implementing the C<UNIVERSAL::isa> functionality. + + bool sv_derived_from(SV* sv, char* name); + +To check if you've got an object derived from a specific class you have +to write: + + if (sv_isobject(sv) && sv_derived_from(sv, class)) { ... } =head2 Creating New Variables @@ -580,8 +614,7 @@ including (but not limited to) the following: Scalar Value Array Value Hash Value - File Handle - Directory Handle + I/O Handle Format Subroutine @@ -1293,7 +1326,7 @@ This is converted to a tree similar to this one: / \ $b $c -(but slightly more complicated). This tree reflect the way Perl +(but slightly more complicated). This tree reflects the way Perl parsed your code, but has nothing to do with the execution order. There is an additional "thread" going through the nodes of the tree which shows the order of execution of the nodes. In our simplified @@ -1366,7 +1399,7 @@ and corresponding check routines is described in F<opcode.pl> (do not forget to run C<make regen_headers> if you modify this file). A check routine is called when the node is fully constructed except -for the execution-order thread. Since at this time there is no +for the execution-order thread. Since at this time there are no back-links to the currently constructed node, one can do most any operation to the top-level node, including freeing it and/or creating new nodes above/below it. @@ -1393,7 +1426,7 @@ created. =head2 Compile pass 2: context propagation When a context for a part of compile tree is known, it is propagated -down through the tree. Aat this time the context can have 5 values +down through the tree. At this time the context can have 5 values (instead of 2 for runtime context): void, boolean, scalar, list, and lvalue. In contrast with the pass 1 this pass is processed from top to bottom: a node's context determines the context for its children. @@ -1409,7 +1442,7 @@ of free()ing (i.e. their type is changed to OP_NULL). After the compile tree for a subroutine (or for an C<eval> or a file) is created, an additional pass over the code is performed. This pass is neither top-down or bottom-up, but in the execution order (with -additional compilications for conditionals). These optimizations are +additional complications for conditionals). These optimizations are done in the subroutine peep(). Optimizations performed at this stage are subject to the same restrictions as in the pass 2. @@ -1590,6 +1623,13 @@ to indicate the number of items on the stack. Sets up the C<ix> variable for an XSUB which has aliases. This is usually handled automatically by C<xsubpp>. +=item do_binmode + +Switches filehandle to binmode. C<iotype> is what C<IoTYPE(io)> would +contain. + + do_binmode(fp, iotype, TRUE); + =item ENTER Opening bracket on a callback. See C<LEAVE> and L<perlcall>. @@ -1661,7 +1701,7 @@ Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>. Returns the glob with the given C<name> and a defined subroutine or C<NULL>. The glob lives in the given C<stash>, or in the stashes -accessable via @ISA and @<UNIVERSAL>. +accessable via @ISA and @UNIVERSAL. The argument C<level> should be either 0 or -1. If C<level==0>, as a side-effect creates a glob with the given C<name> in the given @@ -1888,10 +1928,13 @@ 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. +Returns the number of keys in the hash (i.e. the same as C<HvKEYS(tb)>). +The return value is currently only meaningful for hashes without tie +magic. + +NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number +of hash buckets that happen to be in use. If you still need that +esoteric value, you can get it through the macro C<HvFILL(tb)>. =item hv_iterkey @@ -2667,6 +2710,14 @@ specified class. int sv_derived_from(SV* sv, char* class) +=item sv_derived_from + +Returns a boolean indicating whether the SV is derived from the specified +class. This is the function that implements C<UNIVERSAL::isa>. It works +for class names as well as for objects. + + bool sv_derived_from _((SV* sv, char* name)); + =item SvEND Returns a pointer to the last character in the string which is in the SV. @@ -2751,7 +2802,7 @@ B<private> setting. Use C<SvIOK>. =item sv_isa Returns a boolean indicating whether the SV is blessed into the specified -class. This does not know how to check for subtype, so it doesn't work in +class. This does not check for subtypes; use C<sv_derived_from> to verify an inheritance relationship. int sv_isa (SV* sv, char* name) @@ -2768,8 +2819,8 @@ will return false. Returns the integer which is in the SV. - int SvIV (SV* sv) - + int SvIV (SV* sv) + =item SvIVX Returns the integer which is stored in the SV. @@ -3281,6 +3332,25 @@ Like C<sv_usepvn>, but also handles 'set' magic. void sv_usepvn_mg (SV* sv, char* ptr, STRLEN len) +=item sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) + +Processes its arguments like C<vsprintf> and appends the formatted output +to an SV. Uses an array of SVs if the C style variable argument list is +missing (NULL). Indicates if locale information has been used for formatting. + + void sv_catpvfn _((SV* sv, const char* pat, STRLEN patlen, + va_list *args, SV **svargs, I32 svmax, + bool *used_locale)); + +=item sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) + +Works like C<vcatpvfn> but copies the text into the SV instead of +appending it. + + void sv_setpvfn _((SV* sv, const char* pat, STRLEN patlen, + va_list *args, SV **svargs, I32 svmax, + bool *used_locale)); + =item SvUV Returns the unsigned integer which is in the SV. diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 163fe03984..60f0a8de26 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -6,7 +6,7 @@ perlhist - the Perl history records =for RCS # -# $Id: perlhist.pod,v 1.29 1998/02/19 15:49:17 jhi Exp $ +# $Id: perlhist.pod,v 1.32 1998/04/04 12:20:50 jhi Exp $ # =end RCS @@ -18,8 +18,8 @@ This document aims to record the Perl source code releases. Perl history in brief, by Larry Wall: - Perl 0 introduced Perl to my officemates. - Perl 1 introduced Perl to the world, and changed /\(...\|...\)/ to + Perl 0 introduced Perl to my officemates. + Perl 1 introduced Perl to the world, and changed /\(...\|...\)/ to /(...|...)/. \(Dan Faigin still hasn't forgiven me. :-\) Perl 2 introduced Henry Spencer's regular expression package. Perl 3 introduced the ability to handle binary data (embedded nulls). @@ -269,6 +269,11 @@ the pumpking or the pumpkineer. 5.004_57 1998-Feb-03 5.004_58 1998-Feb-06 5.004_59 1998-Feb-13 + 5.004_60 1998-Feb-20 + 5.004_61 1998-Feb-27 + 5.004_62 1998-Mar-06 + 5.004_63 1998-Mar-17 + 5.004_64 1998-Apr-03 =head2 SELECTED RELEASE SIZES @@ -305,6 +310,7 @@ explained below. 5.004_53 1422 62 1295 141 438 70 394 162 1637 56 5.004_56 1501 66 1301 140 447 74 408 165 1648 57 5.004_59 1555 72 1317 142 448 74 424 171 1678 58 + 5.004_62 1602 77 1327 144 629 92 428 173 1674 58 The "core"..."doc" mean the following files from the Perl source code distribution. The glob notation ** means recursively, (.) means @@ -360,22 +366,22 @@ the Perl source distribution for somewhat more selected releases. ====================================================================== - 5.003_07 5.004 5.004_04 5.004_59 + 5.003_07 5.004 5.004_04 5.004_62 - Configure 217 1 225 1 225 1 240 1 + Configure 217 1 225 1 225 1 240 1 cygwin32 - - 23 5 23 5 23 5 - djgpp - - - - - - 15 5 + djgpp - - - - - - 14 5 eg 54 44 81 62 81 62 81 62 emacs 143 1 194 1 204 1 212 2 h2pl 12 12 12 12 12 12 12 12 - hints 90 62 129 69 132 71 139 72 - os2 117 42 121 42 127 42 134 44 + hints 90 62 129 69 132 71 144 72 + os2 117 42 121 42 127 42 127 44 plan9 79 15 82 15 82 15 82 15 - Porting 51 1 94 2 109 4 109 4 + Porting 51 1 94 2 109 4 203 6 qnx - - 1 2 1 2 1 2 - utils 97 7 112 8 118 8 123 8 - vms 505 27 518 34 524 34 536 34 - win32 - - 285 33 378 36 464 39 + utils 97 7 112 8 118 8 124 8 + vms 505 27 518 34 524 34 538 34 + win32 - - 285 33 378 36 470 39 x2p 280 19 281 19 281 19 281 19 =head2 SELECTED PATCH SIZES @@ -448,8 +454,9 @@ context diff output format. Jarkko Hietaniemi <F<jhi@iki.fi>>. Thanks to the collective memory of the Perlfolk. In addition to the -Keepers of the Pumpkin also Alan Champion, Andreas König, John +Keepers of the Pumpkin also Alan Champion, Andreas Knig, John Macdonald, Matthias Neeracher, Michael Peppler, Randal Schwartz, and Paul D. Smith sent corrections and additions. =cut + diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 030463c7a0..65818961d8 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -981,9 +981,6 @@ The C<kill> function in the parent's C<if> block is there to send a signal to our child process (current running in the C<else> block) as soon as the remote server has closed its end of the connection. -The C<kill> at the end of the parent's block is there to eliminate the -child process as soon as the server we connect to closes its end. - If the remote server sends data a byte at time, and you need that data immediately without waiting for a newline (which might not happen), you may wish to replace the C<while> loop in the parent with the @@ -1054,7 +1051,7 @@ you'll have to use the C<sysread> variant of the interactive client above. This server accepts one of five different commands, sending output back to the client. Note that unlike most network servers, this one only handles one incoming client at a time. Multithreaded servers are -covered in Chapter 6 of the Camel or in the perlipc(1) manpage. +covered in Chapter 6 of the Camel as well as later in this manpage. Here's the code. We'll diff --git a/pod/perllocale.pod b/pod/perllocale.pod index 70a32e4fe9..2a08835fe8 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -494,7 +494,7 @@ setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and The C<LC_CTYPE> locale also provides the map used in transliterating characters between lower and uppercase. This affects the case-mapping functions - lc(), lcfirst, uc() and ucfirst(); case-mapping -interpolation with C<\l>, C<\L>, C<\u> or <\U> in double-quoted strings +interpolation with C<\l>, C<\L>, C<\u> or C<\U> in double-quoted strings and in C<s///> substitutions; and case-independent regular expression pattern matching using the C<i> modifier. @@ -652,7 +652,7 @@ the locale: Scalar true/false (or less/equal/greater) result is never tainted. -=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or <\U>) +=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>) Result string containing interpolated material is tainted if C<use locale> is in effect. @@ -676,7 +676,7 @@ Has the same behavior as the match operator. Also, the left operand of C<=~> becomes tainted when C<use locale> in effect, if it is modified as a result of a substitution based on a regular expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of -case-mapping with C<\l>, C<\L>,C<\u> or <\U>. +case-mapping with C<\l>, C<\L>,C<\u> or C<\U>. =item B<In-memory formatting function> (sprintf()): @@ -754,7 +754,7 @@ of a match involving C<\w> when C<use locale> is in effect. A string that can suppress Perl's warning about failed locale settings at startup. Failure can occur if the locale support in the operating -system is lacking (broken) is some way - or if you mistyped the name of +system is lacking (broken) in some way - or if you mistyped the name of a locale when you set up your environment. If this environment variable is absent, or has a value which does not evaluate to integer zero - that is "0" or "" - Perl will complain about locale setting failures. @@ -906,11 +906,36 @@ operating system upgrade. =head1 SEE ALSO -L<POSIX (3)/isalnum>, L<POSIX (3)/isalpha>, L<POSIX (3)/isdigit>, -L<POSIX (3)/isgraph>, L<POSIX (3)/islower>, L<POSIX (3)/isprint>, -L<POSIX (3)/ispunct>, L<POSIX (3)/isspace>, L<POSIX (3)/isupper>, -L<POSIX (3)/isxdigit>, L<POSIX (3)/localeconv>, L<POSIX (3)/setlocale>, -L<POSIX (3)/strcoll>, L<POSIX (3)/strftime>, L<POSIX (3)/strtod>, +L<POSIX (3)/isalnum> + +L<POSIX (3)/isalpha> + +L<POSIX (3)/isdigit> + +L<POSIX (3)/isgraph> + +L<POSIX (3)/islower> + +L<POSIX (3)/isprint>, + +L<POSIX (3)/ispunct> + +L<POSIX (3)/isspace> + +L<POSIX (3)/isupper>, + +L<POSIX (3)/isxdigit> + +L<POSIX (3)/localeconv> + +L<POSIX (3)/setlocale>, + +L<POSIX (3)/strcoll> + +L<POSIX (3)/strftime> + +L<POSIX (3)/strtod>, + L<POSIX (3)/strxfrm> =head1 HISTORY diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index 14bb7ebfa4..6e4da5e307 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -998,8 +998,8 @@ Please remember to send me an updated entry for the Module list! =item Take care when changing a released module. -Always strive to remain compatible with previous released versions -(see 2.2 above) Otherwise try to add a mechanism to revert to the +Always strive to remain compatible with previous released versions. +Otherwise try to add a mechanism to revert to the old behaviour if people rely on it. Document incompatible changes. =back diff --git a/pod/perlop.pod b/pod/perlop.pod index 5d1aae79a6..538745dd6a 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -186,6 +186,11 @@ C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the smallest multiple of C<$b> that is not less than C<$a> (i.e. the result will be less than or equal to zero). +Note than when C<use integer> is in scope "%" give you direct access +to the modulus operator as implemented by your C compiler. This +operator is not as well defined for negative operands, but it will +execute faster. + Binary "x" is the repetition operator. In a scalar context, it returns a string consisting of the left operand repeated the number of times specified by the right operand. In a list context, if the left @@ -569,7 +574,7 @@ the same character fore and aft, but the 4 sorts of brackets 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 +C<q#foo#> is parsed as being the string C<foo>, while 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: @@ -599,7 +604,7 @@ a transliteration, the first ten of these sequences may be used. \Q quote regexp metacharacters till \E If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> -and <\U> is taken from the current locale. See L<perllocale>. +and C<\U> is taken from the current locale. See L<perllocale>. Patterns are subject to an additional level of interpretation as a regular expression. This is done as a second pass, after variables are @@ -651,6 +656,7 @@ Options are: m Treat string as multiple lines. o Compile pattern only once. s Treat string as single line. + t Taint $1 etc. if target string is tainted. x Use extended regular expressions. If "/" is the delimiter then the initial C<m> is optional. With the C<m> @@ -670,7 +676,7 @@ C</o> constitutes a promise that you won't change the variables in the pattern. If you change them, Perl won't even notice. If the PATTERN evaluates to a null string, the last -successfully executed regular expression is used instead. +successfully matched regular expression is used instead. If used in a context that requires a list value, a pattern match returns a list consisting of the subexpressions matched by the parentheses in the @@ -897,7 +903,7 @@ text is not evaluated as a command. If the PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the -replacement portion to be interpreter as a full-fledged Perl expression +replacement portion to be interpreted as a full-fledged Perl expression and eval()ed right then and there. It is, however, syntax checked at compile-time. @@ -1031,7 +1037,7 @@ an eval(): =head2 I/O Operators There are several I/O operators you should know about. -A string is enclosed by backticks (grave accents) first undergoes +A string enclosed by backticks (grave accents) first undergoes variable substitution just like a double quoted string. It is then interpreted as a command, and the output of that command is the value of the pseudo-literal, like in a shell. In a scalar context, a single @@ -1054,17 +1060,35 @@ Ordinarily you must assign that value to a variable, but there is one situation where an automatic assignment happens. I<If and ONLY if> the input symbol is the only thing inside the conditional of a C<while> or C<for(;;)> loop, the value is automatically assigned to the variable -C<$_>. The assigned value is then tested to see if it is defined. -(This may seem like an odd thing to you, but you'll use the construct -in almost every Perl script you write.) Anyway, the following lines -are equivalent to each other: +C<$_>. In these loop constructs, the assigned value (whether assignment +is automatic or explcit) is then tested to see if it is defined. +The defined test avoids problems where line has a string value +that would be treated as false by perl e.g. "" or "0" with no trailing +newline. (This may seem like an odd thing to you, but you'll use the +construct in almost every Perl script you write.) Anyway, the following +lines are equivalent to each other: while (defined($_ = <STDIN>)) { print; } + while ($_ = <STDIN>) { print; } while (<STDIN>) { print; } for (;<STDIN>;) { print; } print while defined($_ = <STDIN>); + print while ($_ = <STDIN>); print while <STDIN>; +and this also behaves similarly, but avoids the use of $_ : + + while (my $line = <STDIN>) { print $line } + +If you really mean such values to terminate the loop they should be +tested for explcitly: + + while (($_ = <STDIN>) ne '0') { ... } + while (<STDIN>) { last unless $_; ... } + +In other boolean contexts C<E<lt>I<filehandle>E<gt>> without explcit C<defined> +test or comparison will solicit a warning if C<-w> is in effect. + The filehandles STDIN, STDOUT, and STDERR are predefined. (The filehandles C<stdin>, C<stdout>, and C<stderr> will also work except in packages, where they would be interpreted as local identifiers rather @@ -1124,9 +1148,9 @@ Getopts modules or put a loop on the front like this: ... # code for each line } -The E<lt>E<gt> symbol will return FALSE only once. If you call it again after -this it will assume you are processing another @ARGV list, and if you -haven't set @ARGV, will input from STDIN. +The E<lt>E<gt> symbol will return C<undef> for end-of-file only once. +If you call it again after this it will assume you are processing another +@ARGV list, and if you haven't set @ARGV, will input from STDIN. If the string inside the angle brackets is a reference to a scalar variable (e.g., E<lt>$fooE<gt>), then that variable contains the name of the @@ -1174,9 +1198,12 @@ A glob evaluates its (embedded) argument only when it is starting a new list. All values must be read before it will start over. In a list context this isn't important, because you automatically get them all anyway. In a scalar context, however, the operator returns the next value -each time it is called, or a FALSE value if you've just run out. Again, -FALSE is returned only once. So if you're expecting a single value from -a glob, it is much better to say +each time it is called, or a C<undef> value if you've just run out. As +for filehandles an automatic C<defined> is generated when the glob +occurs in the test part of a C<while> or C<for> - because legal glob returns +(e.g. a file called F<0>) would otherwise terminate the loop. +Again, C<undef> is returned only once. So if you're expecting a single value +from a glob, it is much better to say ($file) = <blurch*>; diff --git a/pod/perlre.pod b/pod/perlre.pod index 373e1ca84e..68ce4b9bf7 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -34,6 +34,13 @@ line anywhere within the string, Treat string as single line. That is, change "." to match any character whatsoever, even a newline, which it normally would not match. +The /s and /m modifiers both override the C<$*> setting. That is, no matter +what C<$*> contains, /s (without /m) will force "^" to match only at the +beginning of the string and "$" to match only at the end (or just before a +newline at the end) of the string. Together, as /ms, they let the "." match +any character whatsoever, while yet allowing "^" and "$" to match, +respectively, just after and just before newlines within the string. + =item x Extend your pattern's legibility by permitting whitespace and comments. @@ -139,7 +146,7 @@ also work: \Q quote (disable) regexp metacharacters till \E If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> -and <\U> is taken from the current locale. See L<perllocale>. +and C<\U> is taken from the current locale. See L<perllocale>. In addition, Perl defines the following: @@ -238,7 +245,7 @@ non-alphanumeric characters: $pattern =~ s/(\W)/\\$1/g; Now it is much more common to see either the quotemeta() function or -the \Q escape sequence used to disable the metacharacters special +the C<\Q> escape sequence used to disable all metacharacters' special meanings like this: /$unquoted\Q$quoted\E$unquoted/ @@ -278,16 +285,17 @@ matches a word followed by a tab, without including the tab in C<$&>. A zero-width negative lookahead assertion. For example C</foo(?!bar)/> matches any occurrence of "foo" that isn't followed by "bar". Note however that lookahead and lookbehind are NOT the same thing. You cannot -use this for lookbehind: C</(?!foo)bar/> will not find an occurrence of -"bar" that is preceded by something which is not "foo". That's because -the C<(?!foo)> is just saying that the next thing cannot be "foo"--and -it's not, it's a "bar", so "foobar" will match. You would have to do -something like C</(?!foo)...bar/> for that. We say "like" because there's -the case of your "bar" not having three characters before it. You could -cover that this way: C</(?:(?!foo)...|^..?)bar/>. Sometimes it's still -easier just to say: +use this for lookbehind. + +If you are looking for a "bar" which isn't preceded by a "foo", C</(?!foo)bar/> +will not do what you want. That's because the C<(?!foo)> is just saying that +the next thing cannot be "foo"--and it's not, it's a "bar", so "foobar" will +match. You would have to do something like C</(?!foo)...bar/> for that. We +say "like" because there's the case of your "bar" not having three characters +before it. You could cover that this way: C</(?:(?!foo)...|^.{0,2})bar/>. +Sometimes it's still easier just to say: - if (/foo/ && $` =~ /bar$/) + if (/bar/ && $` !~ /foo$/) For lookbehind see below. @@ -387,7 +395,7 @@ Say, matches a chunk of non-parentheses, possibly included in parentheses themselves. -=item C<(?imsx)> +=item C<(?imstx)> One or more embedded pattern-match modifiers. This is particularly useful for patterns that are specified in a table somewhere, some of @@ -653,9 +661,18 @@ first alternative includes everything from the last pattern delimiter the last alternative contains everything from the last "|" to the next pattern delimiter. For this reason, it's common practice to include alternatives in parentheses, to minimize confusion about where they -start and end. Note however that "|" is interpreted as a literal with -square brackets, so if you write C<[fee|fie|foe]> you're really only -matching C<[feio|]>. +start and end. + +Note that alternatives are tried from left to right, so the first +alternative found for which the entire expression matches, is the one that +is chosen. This means that alternatives are not necessarily greedy. For +example: when mathing C<foo|foot> against "barefoot", only the "foo" +part will match, as that is the first alternative tried, and it successfully +matches the target string. (This might not seem important, but it is +important when you are capturing matched text using parentheses.) + +Also note that "|" is interpreted as a literal within square brackets, +so if you write C<[fee|fie|foe]> you're really only matching C<[feio|]>. Within a pattern, you may designate subpatterns for later reference by enclosing them in parentheses, and you may refer back to the I<n>th @@ -695,4 +712,10 @@ different things on the I<left> side of the C<s///>. =head2 SEE ALSO +L<perlop/"Regexp Quote-Like Operators">. + +L<perlfunc/pos>. + +L<perllocale>. + "Mastering Regular Expressions" (see L<perlbook>) by Jeffrey Friedl. diff --git a/pod/perlref.pod b/pod/perlref.pod index 6aa086088d..34c071fcfe 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -15,9 +15,9 @@ hashes, hashes of arrays, arrays of hashes of functions, and so on. Hard references are smart--they keep track of reference counts for you, automatically freeing the thing referred to when its reference count goes -to zero. (Note: The reference counts for values in self-referential or +to zero. (Note: the reference counts for values in self-referential or cyclic data structures may not go to zero without a little help; see -L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation. +L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation.) If that thing happens to be an object, the object is destructed. See L<perlobj> for more about objects. (In a sense, everything in Perl is an object, but we usually reserve the word for references to objects that @@ -120,6 +120,15 @@ reference to it, you have these options: sub hashem { +{ @_ } } # ok sub hashem { return { @_ } } # ok +On the other hand, if you want the other meaning, you can do this: + + sub showem { { @_ } } # ambiguous (currently ok, but may change) + sub showem { {; @_ } } # ok + sub showem { { return @_ } } # ok + +Note how the leading C<+{> and C<{;> always serve to disambiguate +the expression to mean either the HASH reference, or the BLOCK. + =item 4. A reference to an anonymous subroutine can be constructed by using diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 87173492d1..84ce270e3e 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -29,7 +29,8 @@ Specified line by line via B<-e> switches on the command line. =item 2. Contained in the file specified by the first filename on the command line. -(Note that systems supporting the #! notation invoke interpreters this way.) +(Note that systems supporting the #! notation invoke interpreters this +way. See L<Location of Perl>.) =item 3. @@ -72,7 +73,7 @@ The sequences "-*" and "- " are specifically ignored so that you could, if you were so inclined, say #!/bin/sh -- # -*- perl -*- -p - eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}' if $running_under_some_shell; to let Perl see the B<-p> switch. @@ -170,6 +171,19 @@ characters as control characters. There is no general solution to all of this. It's just a mess. +=head2 Location of Perl + +It may seem obvious to say, but Perl is useful only when users can +easily find it. When possible, it's good for both B</usr/bin/perl> and +B</usr/local/bin/perl> to be symlinks to the actual binary. If that +can't be done, system administrators are strongly encouraged to put +(symlinks to) perl and its accompanying utilities, such as perldoc, into +a directory typically found along a user's PATH, or in another obvious +and convenient place. + +In this documentation, C<#!/usr/bin/perl> on the first line of the script +will stand in for whatever method works on your system. + =head2 Switches A single-character switch may be combined with the following switch, if @@ -318,7 +332,7 @@ know when the filename has changed. It does, however, use ARGVOUT for the selected filehandle. Note that STDOUT is restored as the default output filehandle after the loop. -You can use C<eof> without parenthesis to locate the end of each input file, +You can use C<eof> without parentheses to locate the end of each input file, in case you want to append to each file, or reset line numbering (see example in L<perlfunc/eof>). @@ -448,7 +462,7 @@ original name fails, and if the name does not already end in one of those suffixes. If your Perl was compiled with DEBUGGING turned on, using the -Dp switch to Perl shows how the search progresses. -If the file supplied contains directory separators (i.e. it is an +If the filename supplied contains directory separators (i.e. it is an absolute or relative pathname), and if the file is not found, platforms that append file extensions will do so and try to look for the file with those extensions added, one by one. @@ -463,7 +477,7 @@ don't support #!. This example works on many platforms that have a shell compatible with Bourne shell: #!/usr/bin/perl - eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}' if $running_under_some_shell; The system ignores the first line and feeds the script to /bin/sh, @@ -473,24 +487,27 @@ starts up the Perl interpreter. On some systems $0 doesn't always contain the full pathname, so the B<-S> tells Perl to search for the script if necessary. After Perl locates the script, it parses the lines and ignores them because the variable $running_under_some_shell -is never true. A better construct than C<$*> would be C<${1+"$@"}>, which -handles embedded spaces and such in the filenames, but doesn't work if -the script is being interpreted by csh. To start up sh rather +is never true. If the script will be interpreted by csh, you will need +to replace C<${1+"$@"}> with C<$*>, even though that doesn't understand +embedded spaces (and such) in the argument list. To start up sh rather than csh, some systems may have to replace the #! line with a line containing just a colon, which will be politely ignored by Perl. Other systems can't control that, and need a totally devious construct that will work under any of csh, sh, or Perl, such as the following: - eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' - & eval 'exec /usr/bin/perl -S $0 $argv:q' + eval '(exit $?0)' && eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}' + & eval 'exec /usr/bin/perl -wS $0 $argv:q' if $running_under_some_shell; =item B<-T> -forces "taint" checks to be turned on so you can test them. Ordinarily these checks are -done only when running setuid or setgid. It's a good idea to turn -them on explicitly for programs run on another's behalf, such as CGI -programs. See L<perlsec>. +forces "taint" checks to be turned on so you can test them. Ordinarily +these checks are done only when running setuid or setgid. It's a good +idea to turn them on explicitly for programs run on another's behalf, +such as CGI programs. See L<perlsec>. Note that (for security reasons) +this option must be seen by Perl quite early; usually this means it must +appear early on the command line or in the #! line (for systems which +support that). =item B<-u> @@ -619,8 +636,8 @@ look in COMSPEC to find a shell fit for interactive use). =item PERL_DEBUG_MSTATS Relevant only if perl is compiled with the malloc included with the perl -distribution (that is, if C<perl -V:d_mymalloc> is 'define'), -if set, this causes memory statistics to be dumped after execution. If set +distribution (that is, if C<perl -V:d_mymalloc> is 'define'). +If set, this causes memory statistics to be dumped after execution. If set to an integer greater than one, also causes memory statistics to be dumped after compilation. diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 73884790b0..3fd903412d 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -36,7 +36,9 @@ 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 +files, directories, or processes. (B<Important exception>: If you pass +a list of arguments to either C<system> or C<exec>, the elements of +that list are B<NOT> checked for taintedness.) 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 @@ -88,7 +90,7 @@ For example: If you try to do something insecure, you will get a fatal error saying something like "Insecure dependency" or "Insecure PATH". Note that you can still write an insecure B<system> or B<exec>, but only by explicitly -doing something like the last example above. +doing something like the "considered secure" example above. =head2 Laundering and Detecting Tainted Data @@ -173,6 +175,14 @@ guarantee that the executable in question isn't itself going to turn around and execute some other program that is dependent on your PATH, it makes sure you set the PATH. +The PATH isn't the only environment variable which can cause problems. +Because some shells may use the variables IFS, CDPATH, ENV, and +BASH_ENV, Perl checks that those are either empty or untainted when +starting subprocesses. You may wish to add something like this to your +setid and taint-checking scripts. + + delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer + 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 diff --git a/pod/perlstyle.pod b/pod/perlstyle.pod index 5ad73cfafe..cf280ce1da 100644 --- a/pod/perlstyle.pod +++ b/pod/perlstyle.pod @@ -242,7 +242,7 @@ to fit on one line anyway. Always check the return codes of system calls. Good error messages should go to STDERR, include which program caused the problem, what the failed -system call and arguments were, and VERY IMPORTANT) should contain the +system call and arguments were, and (VERY IMPORTANT) should contain the standard system error message for what went wrong. Here's a simple but sufficient example: diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 16babd2092..7212bb5907 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -159,7 +159,7 @@ Do not, however, be tempted to do this: Because like its flat incoming parameter list, the return list is also flat. So all you have managed to do here is stored everything in @a and -made @b an empty list. See L</"Pass by Reference"> for alternatives. +made @b an empty list. See L<Pass by Reference> for alternatives. A subroutine may be called using the "&" prefix. The "&" is optional in modern Perls, and so are the parentheses if the subroutine has been @@ -504,6 +504,45 @@ like this: } [..normal %ENV behavior here..] +It's also worth taking a moment to explain what happens when you +localize a member of a composite type (i.e. an array or hash element). +In this case, the element is localized I<by name>. This means that +when the scope of the C<local()> ends, the saved value will be +restored to the hash element whose key was named in the C<local()>, or +the array element whose index was named in the C<local()>. If that +element was deleted while the C<local()> was in effect (e.g. by a +C<delete()> from a hash or a C<shift()> of an array), it will spring +back into existence, possibly extending an array and filling in the +skipped elements with C<undef>. For instance, if you say + + %hash = ( 'This' => 'is', 'a' => 'test' ); + @ary = ( 0..5 ); + { + local($ary[5]) = 6; + local($hash{'a'}) = 'drill'; + while (my $e = pop(@ary)) { + print "$e . . .\n"; + last unless $e > 3; + } + if (@ary) { + $hash{'only a'} = 'test'; + delete $hash{'a'}; + } + } + print join(' ', map { "$_ $hash{$_}" } sort keys %hash),".\n"; + print "The array has ",scalar(@ary)," elements: ", + join(', ', map { defined $_ ? $_ : 'undef' } @ary),"\n"; + +Perl will print + + 6 . . . + 4 . . . + 3 . . . + This is a test only a test. + The array has 6 elements: 0, 1, 2, undef, undef, 5 + +In short, be careful when manipulating the containers for composite types +whose elements have been localized. =head2 Passing Symbol Table Entries (typeglobs) diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 205be7d97a..1d0f5d694f 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -47,7 +47,7 @@ subroutine without defining it by saying C<sub name>, thus: Note that it functions as a list operator, not as a unary operator; so be careful to use C<or> instead of C<||> in this case. However, if you were to declare the subroutine as C<sub myname ($)>, then -C<myname> would functonion as a unary operator, so either C<or> or +C<myname> would function as a unary operator, so either C<or> or C<||> would work. Subroutines declarations can also be loaded up with the C<require> statement @@ -409,6 +409,18 @@ or $nothing = 1; } +or, using experimental C<EVAL blocks> of regular expressions +(see L<perlre/"(?{ code })">), + + / ^abc (?{ $abc = 1 }) + | + ^def (?{ $def = 1 }) + | + ^xyz (?{ $xyz = 1 }) + | + (?{ $nothing = 1 }) + /x; + or even, horrors, if (/^abc/) diff --git a/pod/perltoot.pod b/pod/perltoot.pod index 3a35c05b90..90ef81ae26 100644 --- a/pod/perltoot.pod +++ b/pod/perltoot.pod @@ -315,7 +315,7 @@ be made through methods. Perl doesn't impose restrictions on who gets to use which methods. The public-versus-private distinction is by convention, not syntax. (Well, unless you use the Alias module described below in -L</"Data Members as Variables">.) Occasionally you'll see method names beginning or ending +L<Data Members as Variables>.) Occasionally you'll see method names beginning or ending with an underscore or two. This marking is a convention indicating that the methods are private to that class alone and sometimes to its closest acquaintances, its immediate subclasses. But this distinction diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 02abc3b03b..9d861e3ae5 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -757,15 +757,11 @@ variable is localized subsequent to the assignment # perl4 prints: This is Perl 4 # perl5 prints: - # Another example - - *fred = *barney; # fred is aliased to barney - @barney = (1, 2, 4); - # @fred; - print "@fred"; # should print "1, 2, 4" +=item * (Globs) - # perl4 prints: 1 2 4 - # perl5 prints: In string, @fred now must be written as \@fred +Assigning C<undef> to a glob has no effect in Perl 5. In Perl 4 +it undefines the associated scalar (but may have other side effects +including SEGVs). =item * (Scalar String) diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 221947b508..2cb95afe05 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -413,6 +413,9 @@ C<$? & 255> gives which signal, if any, the process died from, and whether there was a core dump. (Mnemonic: similar to B<sh> and B<ksh>.) +Additionally, if the C<h_errno> variable is supported in C, its value +is returned via $? if any of the C<gethost*()> functions fail. + Note that if you have installed a signal handler for C<SIGCHLD>, the value of C<$?> will usually be wrong outside that handler. @@ -689,7 +692,7 @@ run-time only. This is a new mechanism and the details may change. 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. +$SIG{__WARN__} handlers). True if inside an eval, otherwise false. =item $BASETIME @@ -821,7 +824,7 @@ The C<__DIE__> handler is explicitly disabled during the call, so that you 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 +blocks/strings. See L<perlfunc/die> and L<perlvar/$^S> for how to circumvent this. Note that C<__DIE__>/C<__WARN__> handlers are very special in one diff --git a/pod/perlxs.pod b/pod/perlxs.pod index d065b94425..2f4be67a1e 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -25,6 +25,11 @@ linked. See L<perlxstut> for a tutorial on the whole extension creation process. +Note: For many extensions, Dave Beazley's SWIG system provides a +significantly more convenient mechanism for creating the XS glue +code. See L<http://www.cs.utah.edu/~beazley/SWIG> for more +information. + =head2 On The Road Many of the examples which follow will concentrate on creating an interface @@ -598,7 +603,7 @@ of $timep will either be undef or it will be a valid time. $timep = rpcb_gettime( "localhost" ); -The following XSUB uses the C<SV *> return type as a mneumonic only, +The following XSUB uses the C<SV *> return type as a mnemonic only, and uses a CODE: block to indicate to the compiler that the programmer has supplied all the necessary code. The sv_newmortal() call will initialize the return value to undef, making that diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL index 1d188099cb..ff8bca691f 100644 --- a/pod/pod2latex.PL +++ b/pod/pod2latex.PL @@ -475,6 +475,9 @@ while (<POD>) { elsif ($cmd eq 'pod') { ; # recognise the pod directive, as no op (hs) } + elsif ($cmd eq 'pod') { + ; # recognise the pod directive, as no op (hs) + } else { warn "Unrecognized directive: $cmd\n"; } diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 5e5dfb0b66..e7edf1f5e8 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -315,7 +315,7 @@ $cutting = 1; # We try first to get the version number from a local binary, in case we're # running an installed version of Perl to produce documentation from an # uninstalled newer version's pod files. -if ($^O ne 'plan9' && $^O ne 'dos') { +if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') { ($version,$patch) = `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/; } @@ -736,7 +736,7 @@ while (<>) { # first hide the escapes in case we need to # intuit something and get it wrong due to fmting - s/([A-Z]<[^<>]*>)/noremap($1)/ge; + 1 while s/([A-Z]<[^<>]*>)/noremap($1)/ge; # func() is a reference to a perl function s{ @@ -1050,10 +1050,6 @@ sub mkindex { my ($entry) = @_; my @entries = split m:\s*/\s*:, $entry; push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries; - for $entry (@entries) { - print qq("$entry" ); - } - print "\n"; return ''; } diff --git a/pod/roffitall b/pod/roffitall index cbd19af4fe..244048af2d 100644 --- a/pod/roffitall +++ b/pod/roffitall @@ -199,3 +199,4 @@ eval $run $toroff rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext" + @@ -46,7 +46,7 @@ typedef unsigned UBW; * have an integral type (except char) small enough to be represented * in a double without loss; that is, it has no 32-bit type. */ -#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) +#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP) # define BW_BITS 32 # define BW_MASK ((1 << BW_BITS) - 1) # define BW_SIGN (1 << (BW_BITS - 1)) @@ -324,7 +324,11 @@ PP(pp_pos) } LvTYPE(TARG) = '.'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; } @@ -444,8 +448,13 @@ PP(pp_refgen) { djSP; dMARK; if (GIMME != G_ARRAY) { - MARK[1] = *SP; - SP = MARK + 1; + if (++MARK <= SP) + *MARK = *SP; + else + *MARK = &sv_undef; + *MARK = refto(*MARK); + SP = MARK; + RETURN; } EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) @@ -504,8 +513,14 @@ PP(pp_bless) if (MAXARG == 1) stash = curcop->cop_stash; - else - stash = gv_stashsv(POPs, TRUE); + else { + SV *ssv = POPs; + STRLEN len; + char *ptr = SvPV(ssv,len); + if (dowarn && len == 0) + warn("Explicit blessing to '' (assuming package main)"); + stash = gv_stashpvn(ptr, len, TRUE); + } (void)sv_bless(TOPs, stash); RETURN; @@ -771,7 +786,17 @@ PP(pp_undef) break; case SVt_PVGV: if (SvFAKE(sv)) - sv_setsv(sv, &sv_undef); + SvSetMagicSV(sv, &sv_undef); + else { + GP *gp; + gp_free((GV*)sv); + Newz(602, gp, 1, GP); + GvGP(sv) = gp_ref(gp); + GvSV(sv) = NEWSV(72,0); + GvLINE(sv) = curcop->cop_line; + GvEGV(sv) = (GV*)sv; + GvMULTI_on(sv); + } break; default: if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { @@ -1770,6 +1795,7 @@ PP(pp_substr) djSP; dTARGET; SV *sv; I32 len; + I32 len_ok = 0; STRLEN curlen; I32 pos; I32 rem; @@ -1777,9 +1803,25 @@ PP(pp_substr) I32 lvalue = op->op_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; + char *repl = 0; + STRLEN repl_len; - if (MAXARG > 2) + SvTAINTED_off(TARG); /* decontaminate */ + if (MAXARG > 3) { + /* pop off replacement string */ + sv = POPs; + repl = SvPV(sv, repl_len); + /* pop off length */ + sv = POPs; + if (SvOK(sv)) { + len = SvIV(sv); + len_ok++; + } + } else if (MAXARG == 3) { len = POPi; + len_ok++; + } + pos = POPi; sv = POPs; PUTBACK; @@ -1788,7 +1830,7 @@ PP(pp_substr) pos -= arybase; rem = curlen-pos; fail = rem; - if (MAXARG > 2) { + if (len_ok) { if (len < 0) { rem += len; if (rem < 0) @@ -1800,7 +1842,7 @@ PP(pp_substr) } else { pos += curlen; - if (MAXARG < 3) + if (!len_ok) rem = curlen; else if (len >= 0) { rem = pos+len; @@ -1818,7 +1860,7 @@ PP(pp_substr) rem -= pos; } if (fail < 0) { - if (dowarn || lvalue) + if (dowarn || lvalue || repl) warn("substr outside of string"); RETPUSHUNDEF; } @@ -1844,10 +1886,16 @@ PP(pp_substr) } LvTYPE(TARG) = 'x'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } + else if (repl) + sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -1866,6 +1914,7 @@ PP(pp_vec) unsigned long retnum; I32 len; + SvTAINTED_off(TARG); /* decontaminate */ offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; if (offset < 0 || size < 1) @@ -1878,7 +1927,11 @@ PP(pp_vec) } LvTYPE(TARG) = 'v'; - LvTARG(TARG) = src; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); + } LvTARGOFF(TARG) = offset; LvTARGLEN(TARG) = size; } @@ -3213,6 +3266,13 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); +#ifdef __osf__ + /* Without the dummy below unpack("i", pack("i",-1)) + * return 0xFFffFFff instead of -1 for Digital Unix V4.0 + * cc with optimization turned on */ + (aint) ? + sv_setiv(sv, (IV)aint) : +#endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } @@ -89,11 +89,10 @@ PP(pp_regcomp) { else { t = SvPV(tmpstr, len); - /* JMR: Check against the last compiled regexp - To know for sure, we'd need the length of precomp. - But we don't have it, so we must ... take a guess. */ + /* Check against the last compiled regexp. */ if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || - memNE(pm->op_pmregexp->precomp, t, len + 1)) + pm->op_pmregexp->prelen != len || + memNE(pm->op_pmregexp->precomp, t, len)) { if (pm->op_pmregexp) { ReREFCNT_dec(pm->op_pmregexp); @@ -134,8 +133,8 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); - if (!cx->sb_rxtainted) - cx->sb_rxtainted = SvTAINTED(TOPs); + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) + cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* Are we done */ @@ -147,6 +146,7 @@ PP(pp_substcont) sv_catpvn(dstr, s, cx->sb_strend - s); TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx)); + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); Safefree(SvPVX(targ)); @@ -155,11 +155,15 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); SvPVX(dstr) = 0; sv_free(dstr); + + TAINT_IF(cx->sb_rxtainted & 1); + PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + (void)SvPOK_only(targ); + TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); @@ -654,8 +658,9 @@ PP(pp_sort) RETPUSHUNDEF; } + ENTER; + SAVEPPTR(sortcop); if (op->op_flags & OPf_STACKED) { - ENTER; if (op->op_flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ @@ -741,7 +746,6 @@ PP(pp_sort) POPSTACK(); CATCH_SET(oldcatch); } - LEAVE; } else { if (max > 1) { @@ -752,6 +756,7 @@ PP(pp_sort) : FUNC_NAME_TO_PTR(sv_cmp)); } } + LEAVE; stack_sp = ORIGMARK + max; return nextop; } @@ -913,14 +918,16 @@ block_gimme(void) return G_VOID; switch (cxstack[cxix].blk_gimme) { + case G_VOID: + return G_VOID; case G_SCALAR: return G_SCALAR; case G_ARRAY: return G_ARRAY; default: croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); - case G_VOID: - return G_VOID; + /* NOTREACHED */ + return 0; } } @@ -1039,29 +1046,33 @@ die_where(char *message) I32 gimme; SV **newsp; - if (in_eval & 4) { - SV **svp; - STRLEN klen = strlen(message); - - svp = hv_fetch(ERRHV, message, klen, TRUE); - if (svp) { - if (!SvIOK(*svp)) { - static char prefix[] = "\t(in cleanup) "; - SV *err = ERRSV; - sv_upgrade(*svp, SVt_IV); - (void)SvIOK_only(*svp); - if (!SvPOK(err)) - sv_setpv(err,""); - SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, klen); + if (message) { + if (in_eval & 4) { + SV **svp; + STRLEN klen = strlen(message); + + svp = hv_fetch(ERRHV, message, klen, TRUE); + if (svp) { + if (!SvIOK(*svp)) { + static char prefix[] = "\t(in cleanup) "; + SV *err = ERRSV; + sv_upgrade(*svp, SVt_IV); + (void)SvIOK_only(*svp); + if (!SvPOK(err)) + sv_setpv(err,""); + SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catpvn(err, message, klen); + } + sv_inc(*svp); } - sv_inc(*svp); } + else + sv_setpv(ERRSV, message); } else - sv_setpv(ERRSV, message); - + message = SvPVx(ERRSV, na); + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) { dounwind(-1); POPSTACK(); @@ -1877,14 +1888,26 @@ PP(pp_goto) mark++; } } - if (PERLDB_SUB && curstash != debstash) { + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * We do not care about using sv to call CV; * it's for informational purposes only. */ SV *sv = GvSV(DBsub); - save_item(sv); - gv_efullname3(sv, CvGV(cv), Nullch); + CV *gotocv; + + if (PERLDB_SUB_NN) { + SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + } else { + save_item(sv); + gv_efullname3(sv, CvGV(cv), Nullch); + } + if ( PERLDB_GOTO + && (gotocv = perl_get_cv("DB::goto", FALSE)) ) { + PUSHMARK( stack_sp ); + perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + stack_sp--; + } } RETURNOP(CvSTART(cv)); } @@ -2443,7 +2466,7 @@ PP(pp_require) SvREFCNT_dec(namesv); if (!tryrsfp) { if (op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); + SV *msg = sv_2mortal(newSVpvf("Can't locate '%s' in @INC", name)); SV *dirmsgsv = NEWSV(0, 0); AV *ar = GvAVn(incgv); I32 i; @@ -251,6 +251,7 @@ PP(pp_aelemfast) djSP; AV *av = GvAV((GV*)cSVOP->op_sv); SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); + EXTEND(SP, 1); PUSHs(svp ? *svp : &sv_undef); RETURN; } @@ -791,7 +792,7 @@ PP(pp_match) DIE("panic: do_match"); TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) RETURN; @@ -887,7 +888,7 @@ play_it_again: { curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -952,7 +953,7 @@ yup: /* Confirmed by check_substr */ ++BmUSEFUL(rx->check_substr); curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; Safefree(rx->subbase); rx->subbase = Nullch; if (global) { @@ -1476,6 +1477,7 @@ PP(pp_subst) s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + rxtainted = tainted << 1; TAINT_NOT; force_it: @@ -1562,7 +1564,7 @@ PP(pp_subst) curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); if (rx->subbase) { m = orig + (rx->startp[0] - rx->subbase); d = orig + (rx->endp[0] - rx->subbase); @@ -1603,12 +1605,11 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(&sv_yes); } else { - rxtainted = 0; do { if (iters++ > maxiters) DIE("Substitution loop"); @@ -1632,11 +1633,12 @@ PP(pp_subst) SvCUR_set(TARG, d - SvPVX(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; mg_set(TARG); @@ -1653,7 +1655,7 @@ PP(pp_subst) s = SvPV_force(TARG, len); goto force_it; } - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); curpm = pm; @@ -1684,8 +1686,6 @@ PP(pp_subst) } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase)); sv_catpvn(dstr, s, strend - s); - TAINT_IF(rxtainted); - (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); @@ -1694,11 +1694,14 @@ PP(pp_subst) SvPVX(dstr) = 0; sv_free(dstr); + TAINT_IF(rxtainted & 1); + SPAGAIN; + PUSHs(sv_2mortal(newSViv((I32)iters))); + (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); - SPAGAIN; - PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; } @@ -1800,27 +1803,35 @@ STATIC CV * get_db_sub(SV **svp, CV *cv) { dTHR; - SV *oldsv = *svp; - GV *gv; + SV *dbsv = GvSV(DBsub); + + if (!PERLDB_SUB_NN) { + GV *gv = CvGV(cv); - *svp = GvSV(DBsub); - save_item(*svp); - gv = CvGV(cv); - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) - && (gv = (GV*)oldsv) ))) { - /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(*svp, newRV((SV*)cv)); + save_item(dbsv); + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) + && (gv = (GV*)*svp) ))) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + sv_setsv(dbsv, newRV((SV*)cv)); + } + else { + gv_efullname3(dbsv, gv, Nullch); + } } else { - gv_efullname3(*svp, gv, Nullch); + SvUPGRADE(dbsv, SVt_PVIV); + SvIOK_on(dbsv); + SAVEIV(SvIVX(dbsv)); + SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */ } - cv = GvCV(DBsub); + if (CvXSUB(cv)) curcopdb = curcop; + cv = GvCV(DBsub); return cv; } @@ -1989,8 +2000,9 @@ PP(pp_entersub) * (3) instead of (2) so we'd have to clone. Would the fact * that we released the mutex more quickly make up for this? */ - svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE); - if (svp) { + if (threadnum && + (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; @@ -290,10 +290,11 @@ PP(pp_warn) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - (void)SvUPGRADE(ERRSV, SVt_PV); - if (SvPOK(ERRSV) && SvCUR(ERRSV)) - sv_catpv(ERRSV, "\t...caught"); - tmps = SvPV(ERRSV, na); + SV *error = ERRSV; + (void)SvUPGRADE(error, SVt_PV); + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...caught"); + tmps = SvPV(error, na); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -305,6 +306,8 @@ PP(pp_die) { djSP; dMARK; char *tmps; + SV *tmpsv = Nullsv; + char *pat = "%s"; if (SP - MARK != 1) { dTARGET; do_join(TARG, &sv_no, MARK, SP); @@ -312,17 +315,26 @@ PP(pp_die) SP = MARK + 1; } else { - tmps = SvPV(TOPs, na); + tmpsv = TOPs; + tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, na); } if (!tmps || !*tmps) { - (void)SvUPGRADE(ERRSV, SVt_PV); - if (SvPOK(ERRSV) && SvCUR(ERRSV)) - sv_catpv(ERRSV, "\t...propagated"); - tmps = SvPV(ERRSV, na); + SV *error = ERRSV; + (void)SvUPGRADE(error, SVt_PV); + if(tmpsv ? SvROK(tmpsv) : SvROK(error)) { + if(tmpsv) + SvSetSV(error,tmpsv); + pat = Nullch; + } + else { + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...propagated"); + tmps = SvPV(error, na); + } } if (!tmps || !*tmps) tmps = "Died"; - DIE("%s", tmps); + DIE(pat, tmps); } /* I/O. */ @@ -464,7 +476,7 @@ PP(pp_umask) TAINT_PROPER("umask"); XPUSHi(anum); #else - DIE(no_func, "Unsupported function umask"); + XPUSHs(&sv_undef) #endif RETURN; } @@ -485,40 +497,10 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; -#ifdef DOSISH -#ifdef atarist - if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) - RETPUSHYES; - else - RETPUSHUNDEF; -#else - if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { -#if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - ((FILE*)fp)->flags |= _F_BIN; -#endif + if (do_binmode(fp,IoTYPE(io),TRUE)) RETPUSHYES; - } else RETPUSHUNDEF; -#endif -#else -#if defined(USEMYBINMODE) - if (my_binmode(fp,IoTYPE(io)) != NULL) - RETPUSHYES; - else - RETPUSHUNDEF; -#else - RETPUSHYES; -#endif -#endif - } @@ -599,7 +581,8 @@ PP(pp_untie) { djSP; SV * sv ; - sv = POPs; + + sv = POPs; if (dowarn) { MAGIC * mg ; @@ -2603,6 +2586,13 @@ PP(pp_chdir) if (svp) tmps = SvPV(*svp, na); } +#ifdef VMS + if (!tmps || !*tmps) { + svp = hv_fetch(GvHVn(envgv), "SYS$LOGIN", 9, FALSE); + if (svp) + tmps = SvPV(*svp, na); + } +#endif TAINT_PROPER("chdir"); PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS @@ -4124,41 +4114,55 @@ PP(pp_gpwent) if (pwent) { PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_passwd); + PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setiv(sv, (IV)pwent->pw_uid); + PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setiv(sv, (IV)pwent->pw_gid); + + /* pw_change, pw_quota, and pw_age are mutually exclusive. */ PUSHs(sv = sv_mortalcopy(&sv_no)); #ifdef PWCHANGE sv_setiv(sv, (IV)pwent->pw_change); #else -#ifdef PWQUOTA +# ifdef PWQUOTA sv_setiv(sv, (IV)pwent->pw_quota); -#else -#ifdef PWAGE +# else +# ifdef PWAGE sv_setpv(sv, pwent->pw_age); +# endif +# endif #endif -#endif -#endif + + /* pw_class and pw_comment are mutually exclusive. */ PUSHs(sv = sv_mortalcopy(&sv_no)); #ifdef PWCLASS sv_setpv(sv, pwent->pw_class); #else -#ifdef PWCOMMENT +# ifdef PWCOMMENT sv_setpv(sv, pwent->pw_comment); +# endif #endif -#endif + PUSHs(sv = sv_mortalcopy(&sv_no)); +#ifdef PWGECOS sv_setpv(sv, pwent->pw_gecos); +#endif #ifndef INCOMPLETE_TAINTS + /* pw_gecos is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); #endif + PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_dir); + PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pwent->pw_shell); + #ifdef PWEXPIRE PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setiv(sv, (IV)pwent->pw_expire); @@ -4300,7 +4304,7 @@ PP(pp_getlogin) PP(pp_syscall) { -#ifdef HAS_SYSCALL +#ifdef HAS_SYSCALL djSP; dMARK; dORIGMARK; dTARGET; register I32 items = SP - MARK; unsigned long a[20]; @@ -4514,4 +4518,3 @@ int operation; } #endif /* LOCKF_EMULATE_FLOCK */ - @@ -115,6 +115,7 @@ VIRTUAL OP* die _((const char* pat,...)); VIRTUAL OP* die_where _((char* message)); VIRTUAL void dounwind _((I32 cxix)); VIRTUAL bool do_aexec _((SV* really, SV** mark, SV** sp)); +VIRTUAL int do_binmode _((PerlIO *fp, int iotype, int flag)); VIRTUAL void do_chop _((SV* asv, SV* sv)); VIRTUAL bool do_close _((GV* gv, bool not_implicit)); VIRTUAL bool do_eof _((GV* gv)); @@ -166,6 +167,7 @@ void dump_packsubs _((HV* stash)); void dump_sub _((GV* gv)); VIRTUAL void fbm_compile _((SV* sv, U32 flags)); VIRTUAL char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); +VIRTUAL char* find_script _((char *scriptname, bool dosearch, char **search_ext, I32 flags)); #ifdef USE_THREADS VIRTUAL PADOFFSET find_threadsv _((char *name)); #endif @@ -243,11 +245,14 @@ VIRTUAL int magic_get _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getarylen _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getdefelem _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getglob _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_getnkeys _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getpack _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getpos _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getsig _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_getsubstr _((SV* sv, MAGIC* mg)); VIRTUAL int magic_gettaint _((SV* sv, MAGIC* mg)); VIRTUAL int magic_getuvar _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_getvec _((SV* sv, MAGIC* mg)); VIRTUAL U32 magic_len _((SV* sv, MAGIC* mg)); #ifdef USE_THREADS VIRTUAL int magic_mutexfree _((SV* sv, MAGIC* mg)); @@ -362,11 +367,7 @@ VIRTUAL SV* newRV _((SV* pref)); #if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS) || defined(PERL_OBJECT)) VIRTUAL SV* newRV_noinc _((SV *sv)); #endif -#ifdef LEAKTEST -VIRTUAL SV* newSV _((I32 x, STRLEN len)); -#else VIRTUAL SV* newSV _((STRLEN len)); -#endif VIRTUAL OP* newSVREF _((OP* o)); VIRTUAL OP* newSVOP _((I32 type, I32 flags, SV* sv)); VIRTUAL SV* newSViv _((IV i)); @@ -401,6 +402,7 @@ VIRTUAL void peep _((OP* o)); #ifndef PERL_OBJECT PerlInterpreter* perl_alloc _((void)); #endif +VIRTUAL void perl_atexit _((void(*fn)(void *), void*)); VIRTUAL I32 perl_call_argv _((char* sub_name, I32 flags, char** argv)); VIRTUAL I32 perl_call_method _((char* methname, I32 flags)); VIRTUAL I32 perl_call_pv _((char* sub_name, I32 flags)); @@ -115,7 +115,6 @@ static regnode *reg_node _((U8)); static regnode *regpiece _((I32 *)); static void reginsert _((U8, regnode *)); static void regoptail _((regnode *, regnode *)); -static void regset _((char *, I32)); static void regtail _((regnode *, regnode *)); static char* nextchar _((void)); @@ -1118,8 +1117,11 @@ reg(I32 paren, I32 *flagp) break; default: --regparse; - while (*regparse && strchr("iogcmsx", *regparse)) - pmflag(®flags, *regparse++); + while (*regparse && strchr("iogcmsx", *regparse)) { + if (*regparse != 'o') + pmflag(®flags, *regparse); + ++regparse; + } unknown: if (*regparse != ')') FAIL2("Sequence (?%c...) not recognized", *regparse); @@ -1813,15 +1815,6 @@ regwhite(char *p, char *e) return p; } -STATIC void -regset(char *opnd, register I32 c) -{ - if (SIZE_ONLY) - return; - c &= 0xFF; - opnd[1 + (c >> 3)] |= (1 << (c & 7)); -} - STATIC regnode * regclass(void) { @@ -1885,63 +1878,67 @@ regclass(void) Class = UCHARAT(regparse++); switch (Class) { case 'w': - if (regflags & PMf_LOCALE) { - if (!SIZE_ONLY) + if (!SIZE_ONLY) { + if (regflags & PMf_LOCALE) *opnd |= ANYOF_ALNUML; - } - else { - for (Class = 0; Class < 256; Class++) - if (isALNUM(Class)) - regset(opnd, Class); + else { + for (Class = 0; Class < 256; Class++) + if (isALNUM(Class)) + ANYOF_SET(opnd, Class); + } } lastclass = 1234; continue; case 'W': - if (regflags & PMf_LOCALE) { - if (!SIZE_ONLY) + if (!SIZE_ONLY) { + if (regflags & PMf_LOCALE) *opnd |= ANYOF_NALNUML; - } - else { - for (Class = 0; Class < 256; Class++) - if (!isALNUM(Class)) - regset(opnd, Class); + else { + for (Class = 0; Class < 256; Class++) + if (!isALNUM(Class)) + ANYOF_SET(opnd, Class); + } } lastclass = 1234; continue; case 's': - if (regflags & PMf_LOCALE) { - if (!SIZE_ONLY) + if (!SIZE_ONLY) { + if (regflags & PMf_LOCALE) *opnd |= ANYOF_SPACEL; - } - else { - for (Class = 0; Class < 256; Class++) - if (isSPACE(Class)) - regset(opnd, Class); + else { + for (Class = 0; Class < 256; Class++) + if (isSPACE(Class)) + ANYOF_SET(opnd, Class); + } } lastclass = 1234; continue; case 'S': - if (regflags & PMf_LOCALE) { - if (!SIZE_ONLY) + if (!SIZE_ONLY) { + if (regflags & PMf_LOCALE) *opnd |= ANYOF_NSPACEL; - } - else { - for (Class = 0; Class < 256; Class++) - if (!isSPACE(Class)) - regset(opnd, Class); + else { + for (Class = 0; Class < 256; Class++) + if (!isSPACE(Class)) + ANYOF_SET(opnd, Class); + } } lastclass = 1234; continue; case 'd': - for (Class = '0'; Class <= '9'; Class++) - regset(opnd, Class); + if (!SIZE_ONLY) { + for (Class = '0'; Class <= '9'; Class++) + ANYOF_SET(opnd, Class); + } lastclass = 1234; continue; case 'D': - for (Class = 0; Class < '0'; Class++) - regset(opnd, Class); - for (Class = '9' + 1; Class < 256; Class++) - regset(opnd, Class); + if (!SIZE_ONLY) { + for (Class = 0; Class < '0'; Class++) + ANYOF_SET(opnd, Class); + for (Class = '9' + 1; Class < 256; Class++) + ANYOF_SET(opnd, Class); + } lastclass = 1234; continue; case 'n': @@ -1994,13 +1991,31 @@ regclass(void) continue; /* do it next time */ } } - for ( ; lastclass <= Class; lastclass++) - regset(opnd, lastclass); + if (!SIZE_ONLY) { + for ( ; lastclass <= Class; lastclass++) + ANYOF_SET(opnd, lastclass); + } lastclass = Class; } if (*regparse != ']') FAIL("unmatched [] in regexp"); nextchar(); + /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */ + if (!SIZE_ONLY && (*opnd & (0xFF ^ ANYOF_INVERT)) == ANYOF_FOLD) { + for (Class = 0; Class < 256; ++Class) { + if (ANYOF_TEST(opnd, Class)) { + I32 cf = fold[Class]; + ANYOF_SET(opnd, cf); + } + } + *opnd &= ~ANYOF_FOLD; + } + /* optimize inverted simple patterns (e.g. [^a-z]) */ + if (!SIZE_ONLY && (*opnd & 0xFF) == ANYOF_INVERT) { + for (Class = 0; Class < 32; ++Class) + opnd[1 + Class] ^= 0xFF; + *opnd = 0; + } return ret; } @@ -370,6 +370,13 @@ typedef char* regnode; #define ANYOF_SPACEL 0x02 #define ANYOF_NSPACEL 0x01 +/* Utility macros for bitmap of ANYOF */ +#define ANYOF_BYTE(p,c) (p)[1 + (((c) >> 3) & 31)] +#define ANYOF_BIT(c) (1 << ((c) & 7)) +#define ANYOF_SET(p,c) (ANYOF_BYTE(p,c) |= ANYOF_BIT(c)) +#define ANYOF_CLEAR(p,c) (ANYOF_BYTE(p,c) &= ~ANYOF_BIT(c)) +#define ANYOF_TEST(p,c) (ANYOF_BYTE(p,c) & ANYOF_BIT(c)) + #ifdef REGALIGN_STRUCT #define ANY_SKIP ((33 - 1)/sizeof(regnode) + 1) #else @@ -74,10 +74,12 @@ static I32 regmatch _((regnode *prog)); static I32 regrepeat _((regnode *p, I32 max)); static I32 regrepeat_hard _((regnode *p, I32 max, I32 *lp)); static I32 regtry _((regexp *prog, char *startpos)); + static bool reginclass _((char *p, I32 c)); static CHECKPOINT regcppush _((I32 parenfloor)); static char * regcppop _((void)); #endif +#define REGINCLASS(p,c) (*(p) ? reginclass(p,c) : ANYOF_TEST(p,c)) STATIC CHECKPOINT regcppush(I32 parenfloor) @@ -383,7 +385,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, cha case ANYOF: Class = (char *) OPERAND(c); while (s < strend) { - if (reginclass(Class, *s)) { + if (REGINCLASS(Class, *s)) { if (tmp && regtry(prog, s)) goto got_it; else @@ -850,7 +852,7 @@ regmatch(regnode *prog) s = (char *) OPERAND(scan); if (nextchr < 0) nextchr = UCHARAT(locinput); - if (!reginclass(s, nextchr)) + if (!REGINCLASS(s, nextchar)) sayNO; if (!nextchr && locinput >= regeol) sayNO; @@ -1623,7 +1625,7 @@ regrepeat(regnode *p, I32 max) scan++; break; case ANYOF: - while (scan < loceol && reginclass(opnd, *scan)) + while (scan < loceol && REGINCLASS(opnd, *scan)) scan++; break; case ALNUM: @@ -1734,7 +1736,7 @@ reginclass(register char *p, register I32 c) bool match = FALSE; c &= 0xFF; - if (p[1 + (c >> 3)] & (1 << (c & 7))) + if (ANYOF_TEST(p, c)) match = TRUE; else if (flags & ANYOF_FOLD) { I32 cf; @@ -1744,7 +1746,7 @@ reginclass(register char *p, register I32 c) } else cf = fold[c]; - if (p[1 + (cf >> 3)] & (1 << (cf & 7))) + if (ANYOF_TEST(p, cf)) match = TRUE; } @@ -1760,7 +1762,7 @@ reginclass(register char *p, register I32 c) } } - return match ^ ((flags & ANYOF_INVERT) != 0); + return (flags & ANYOF_INVERT) ? !match : match; } @@ -1912,8 +1912,11 @@ sv_setsv(SV *dstr, register SV *sstr) switch (stype) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: if (dtype != SVt_IV && dtype < SVt_PVIV) { if (dtype < SVt_IV) @@ -2215,7 +2218,12 @@ sv_setsv(SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); } else { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (dowarn) + warn("Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } @@ -2427,11 +2435,7 @@ sv_catpv_mg(register SV *sv, register char *ptr) } SV * -#ifdef LEAKTEST -newSV(I32 x, STRLEN len) -#else newSV(STRLEN len) -#endif { register SV *sv; @@ -2640,10 +2644,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } i = littlelen - len; if (i > 0) { /* string might grow */ @@ -3703,7 +3714,7 @@ sv_reset(register char *s, HV *stash) if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -199,6 +199,7 @@ struct xpvnv { double xnv_nv; /* numeric value, if any */ }; +/* These structure must match the beginning of struct xpvhv in hv.h. */ struct xpvmg { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ @@ -17,6 +17,7 @@ chdir 't' if -f 't/TEST'; die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe'; +#$ENV{PERL_DESTRUCT_LEVEL} = '2'; $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($#ARGV == -1) { @@ -38,12 +39,34 @@ else { close(CONFIG); } -$bad = 0; -$good = 0; -$total = @ARGV; -$files = 0; -$totmax = 0; -while ($test = shift) { +%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); + +_testprogs('perl', @ARGV); +_testprogs('compile', @ARGV) if (-e "../testcompile"); + +sub _testprogs +{ + $type = shift @_; + @tests = @_; + + + print " +-------------------------------------------------------------------------------- +TESTING COMPILER +-------------------------------------------------------------------------------- +" if ($type eq 'compile'); + + $bad = 0; + $good = 0; + $total = @tests; + $files = 0; + $totmax = 0; +while ($test = shift @tests) { + + if ( $infinite{$test} && $type eq 'compile' ) { + print STDERR "$test creates infinite loop! Skipping.\n"; + next; + } if ($test =~ /^$/) { next; } @@ -52,7 +75,14 @@ while ($test = shift) { print "$te" . '.' x (18 - length($te)); if ($sharpbang) { -x $test || (print "isn't executable.\n"); - open(RESULTS,"./$test |") || (print "can't run.\n"); + + if ($type eq 'perl') + { open(RESULTS, "./$test |") || (print "can't run.\n"); } + else + { + open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test -run -verbose dcf -log ../compilelog |") + || (print "can't compile.\n"); + } } else { open(SCRIPT,"$test") || die "Can't run $test.\n"; $_ = <SCRIPT>; @@ -66,7 +96,16 @@ while ($test = shift) { } else { $switch = ''; } - open(RESULTS,"./perl$switch $test |") || (print "can't run.\n"); + + if ($type eq 'perl') + { + open(RESULTS,"./perl$switch $test |") || (print "can't run.\n"); + } + else + { + open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test -run -verbose dcf -log ../compilelog |") + || (print "can't compile.\n"); + } } $ok = 0; $next = 0; @@ -129,16 +168,21 @@ if ($bad == 0) { ### Since not all tests were successful, you may want to run some ### of them individually and examine any diagnostic messages they ### produce. See the INSTALL document's section on "make test". + ### If you are testing the compiler, then ignore this message + ### and run + ### ./perl harness + ### in the directory ./t. SHRDLU warn <<'SHRDLU' if $good / $total > 0.8; ### ### Since most tests were successful, you have a good chance to ### get information with better granularity by running - ### ./perl harness + ### ./perl harness ### in directory ./t. SHRDLU } ($user,$sys,$cuser,$csys) = times; print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); +} exit ($bad != 0); diff --git a/t/base/lex.t b/t/base/lex.t index 31bb056b5b..045cb22eb0 100755 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -2,7 +2,7 @@ # $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ -print "1..28\n"; +print "1..30\n"; $x = 'x'; @@ -104,9 +104,15 @@ print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n"; print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n"; print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n"; -print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 27\n" : "not ok 27\n"); +# MJD 19980425 +($X, @X) = qw(a b c d); +print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n"; +print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n"; -$foo = "not ok 28\n"; +print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n"); + + +$foo = "not ok 30\n"; $foo =~ s/^not /substr(<<EOF, 0, 0)/e; Ignored EOF @@ -17,4 +17,17 @@ $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; @tests = @ARGV; @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests; + Test::Harness::runtests @tests; + +%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); + +@tests = grep (!$infinite{$_}, @tests); + +if (-e "../testcompile") +{ + print "The tests ", join(' ', keys(%infinite)), + " generate infinite loops! Skipping!\n"; + + $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; +} diff --git a/t/io/pipe.t b/t/io/pipe.t index efeda80551..4a7cb7a423 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -13,7 +13,7 @@ BEGIN { } $| = 1; -print "1..10\n"; +print "1..12\n"; open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); print PIPE "Xk 1\n"; @@ -25,6 +25,7 @@ if (open(PIPE, "-|")) { s/^not //; print; } + close PIPE; # avoid zombies which disrupt test 12 } else { print STDOUT "not ok 3\n"; @@ -40,6 +41,7 @@ if ($pid = fork) { y/A-Z/a-z/; print; } + close READER; # avoid zombies which disrupt test 12 } else { die "Couldn't fork" unless defined $pid; @@ -66,18 +68,21 @@ sleep 1; print "ok 8\n"; # VMS doesn't like spawning subprocesses that are still connected to -# STDOUT. Someone should modify tests #9 and #10 to work with VMS. +# STDOUT. Someone should modify tests #9 to #12 to work with VMS. if ($^O eq 'VMS') { print "ok 9\n"; print "ok 10\n"; + print "ok 11\n"; + print "ok 12\n"; exit; } -if ($Config{d_sfio} || $^O eq machten) { +if ($Config{d_sfio} || $^O eq machten || $^O eq beos) { # Sfio doesn't report failure when closing a broken pipe # that has pending output. Go figure. MachTen doesn't either, # but won't write to broken pipes, so nothing's pending at close. + # BeOS will not write to broken pipes, either. print "ok 9\n"; } else { @@ -108,3 +113,21 @@ elsif ($? == 0) { else { print "ok 10\n"; } + +# check that status for the correct process is collected +my $zombie = fork or exit 37; +my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; +$SIG{ALRM} = sub { return }; +alarm(1); +my $close = close FH; +if ($? == 13*256 && ! length $close && ! $!) { + print "ok 11\n"; +} else { + print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; +}; +my $wait = wait; +if ($? == 37*256 && $wait == $zombie && ! $!) { + print "ok 12\n"; +} else { + print "not ok 12\n# pid=$wait \$?=$? \$!=", $!+0, ":$!\n"; +} diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index 3ab609cecc..0391b7b490 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -12,7 +12,7 @@ use Fcntl; print "1..12\n"; -unlink <Op_dbmx.*>; +unlink <Op_dbmx*>; umask(0); print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) @@ -20,7 +20,7 @@ print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { - ($Dfile) = <Op_dbmx.*>; + ($Dfile) = <Op_dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { print "ok 2 # Skipped: different file permission semantics\n"; @@ -33,7 +33,7 @@ else { while (($key,$value) = each(%h)) { $i++; } -print (!$i ? "ok 3\n" : "not ok 3\n"); +print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n"); $h{'goner1'} = 'snork'; diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 8a23fb6d7d..e4bde30040 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -29,6 +29,7 @@ print "ok 1\n"; print "not " unless $foo eq "ok 3\n"; print "ok 2\n"; +binmode STDOUT; # Copy::copy works in binary mode copy "copy-$$", \*STDOUT; unlink "copy-$$" or die "unlink: $!"; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 21e29a2d7f..cd2e9771c7 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -5,9 +5,10 @@ BEGIN { @INC = '../lib'; } -print "1..1\n"; +print "1..2\n"; use File::Find; # hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); +finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 0971e7803f..9fab56b237 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -55,11 +55,14 @@ if($pid = fork()) { # This can fail if localhost is undefined or the # special 'loopback' address 127.0.0.1 is not configured # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', PeerAddr => 'localhost' - ) or die "$!"; + ) + or die "$! (maybe your system does not have the 'localhost' address defined)"; $sock->autoflush(1); diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 3e16714118..014e12dc58 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -30,9 +30,13 @@ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); # This can fail if localhost is undefined or the # special 'loopback' address 127.0.0.1 is not configured # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; print "ok 1\n"; diff --git a/t/lib/parsewords.t b/t/lib/parsewords.t index 47a75881dc..21ed0d3eae 100755 --- a/t/lib/parsewords.t +++ b/t/lib/parsewords.t @@ -5,24 +5,77 @@ BEGIN { @INC = '../lib'; } -print "1..4\n"; - use Text::ParseWords; -@words = shellwords(qq(foo "bar quiz" zoo)); -#print join(";", @words), "\n"; +print "1..15\n"; +@words = shellwords(qq(foo "bar quiz" zoo)); print "not " if $words[0] ne 'foo'; print "ok 1\n"; - print "not " if $words[1] ne 'bar quiz'; print "ok 2\n"; - print "not " if $words[2] ne 'zoo'; print "ok 3\n"; -# Test quotewords() with other parameters -@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:)); -#print join(";", @words), "\n"; -print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo); +# Test quotewords() with other parameters and null last field +@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); print "ok 4\n"; + +# Test $keep eq 'delimiters' and last field zero +@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); +print "ok 5\n"; + +# Big ol' nasty test (thanks, Joerk!) +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; + +# First with $keep == 1 +$result = join('|', parse_line('\s+', 1, $string)); +print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; +print "ok 6\n"; + +# Now, $keep == 0 +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; +print "ok 7\n"; + +# Now test single quote behavior +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg'; +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg'; +print "ok 8\n"; + +# Make sure @nested_quotewords does the right thing +@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); +print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); +print "ok 9\n"; + +# Now test error return +$string = 'foo bar baz"bach blech boop'; + +@words = shellwords($string); +print "not " if (@words); +print "ok 10\n"; + +@words = parse_line('s+', 0, $string); +print "not " if (@words); +print "ok 11\n"; + +@words = quotewords('s+', 0, $string); +print "not " if (@words); +print "ok 12\n"; + +@words = nested_quotewords('s+', 0, $string); +print "not " if (@words); +print "ok 13\n"; + +# Now test empty fields +$result = join('|', parse_line(':', 0, 'foo::0:"":::')); +print "not " unless ($result eq 'foo||0||||'); +print "ok 14\n"; + +# Test for 0 in quotes without $keep +$result = join('|', parse_line(':', 0, ':"0":')); +print "not " unless ($result eq '|0|'); +print "ok 15\n"; diff --git a/t/lib/posix.t b/t/lib/posix.t index d63e695f02..c071c3b067 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -16,6 +16,8 @@ use strict subs; $| = 1; print "1..18\n"; +$Is_W32 = $^O eq 'MSWin32'; + $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; @@ -31,6 +33,12 @@ close $writer; print <$reader>; close $reader; +if ($Is_W32) { + for (6..11) { + print "ok $_ # skipped, no sigaction support on win32\n"; + } +} +else { $sigset = new POSIX::SigSet 1,3; delset $sigset 1; if (!ismember $sigset 1) { print "ok 6\n" } @@ -53,6 +61,7 @@ sub SigHUP { sub SigINT { print "ok 10\n"; } +} print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; diff --git a/t/lib/timelocal.t b/t/lib/timelocal.t index 938ca695b1..100e0768aa 100755 --- a/t/lib/timelocal.t +++ b/t/lib/timelocal.t @@ -11,7 +11,7 @@ use Time::Local; @time = ( #year,mon,day,hour,min,sec - [1970, 1, 1, 00, 00, 00], + [1970, 1, 2, 00, 00, 00], [1980, 2, 28, 12, 00, 00], [1980, 2, 29, 12, 00, 00], [1999, 12, 31, 23, 59, 59], diff --git a/t/op/defins.t b/t/op/defins.t new file mode 100755 index 0000000000..5dd614d4b8 --- /dev/null +++ b/t/op/defins.t @@ -0,0 +1,144 @@ +#!./perl -w + +# +# test auto defined() test insertion +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $SIG{__WARN__} = sub { $warns++; warn $_[0] }; + print "1..14\n"; +} + +print "not " if $warns; +print "ok 1\n"; + +open(FILE,">./0"); +print FILE "1\n"; +print FILE "0"; +close(FILE); + +open(FILE,"<./0"); +my $seen = 0; +my $dummy; +while (my $name = <FILE>) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 2\n"; + +seek(FILE,0,0); +$seen = 0; +my $line = ''; +do + { + $seen++ if $line eq '0'; + } while ($line = <FILE>); + +print "not " unless $seen; +print "ok 3\n"; + + +seek(FILE,0,0); +$seen = 0; +while (($seen ? $dummy : $name) = <FILE>) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 4\n"; + +seek(FILE,0,0); +$seen = 0; +my %where; +while ($where{$seen} = <FILE>) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 5\n"; + +opendir(DIR,'.'); +$seen = 0; +while (my $name = readdir(DIR)) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 6\n"; + +rewinddir(DIR); +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = readdir(DIR)) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 7\n"; + +rewinddir(DIR); +$seen = 0; +while ($where{$seen} = readdir(DIR)) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 8\n"; + +$seen = 0; +while (my $name = glob('*')) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 9\n"; + +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = glob('*')) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 10\n"; + +$seen = 0; +while ($where{$seen} = glob('*')) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 11\n"; + +unlink("./0"); + +my %hash = (0 => 1, 1 => 2); + +$seen = 0; +while (my $name = each %hash) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 12\n"; + +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = each %hash) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 13\n"; + +$seen = 0; +while ($where{$seen} = each %hash) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 14\n"; + diff --git a/t/op/die.t b/t/op/die.t new file mode 100755 index 0000000000..795d856564 --- /dev/null +++ b/t/op/die.t @@ -0,0 +1,26 @@ +#!./perl + +print "1..6\n"; + +$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; + +$err = "ok 1\n"; +eval { + die $err; +}; + +print "not " unless $@ eq $err; +print "ok 2\n"; + +$x = [3]; +eval { die $x; }; + +print "not " unless $x->[0] == 4; +print "ok 4\n"; + +eval { + eval { + die [ 5 ]; + }; + die if $@; +}; diff --git a/t/op/die_exit.t b/t/op/die_exit.t new file mode 100755 index 0000000000..b5760d6fa0 --- /dev/null +++ b/t/op/die_exit.t @@ -0,0 +1,50 @@ +#!./perl + +# +# Verify that C<die> return the return code +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -e '../lib'; +} +my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; + +use strict; + +my %tests = ( + 1 => [ 0, 0], + 2 => [ 0, 1], + 3 => [ 0, 127], + 4 => [ 0, 128], + 5 => [ 0, 255], + 6 => [ 0, 256], + 7 => [ 0, 512], + 8 => [ 1, 0], + 9 => [ 1, 1], + 10 => [ 1, 256], + 11 => [ 128, 0], + 12 => [ 128, 1], + 13 => [ 128, 256], + 14 => [ 255, 0], + 15 => [ 255, 1], + 16 => [ 255, 256], +); + +my $max = keys %tests; + +print "1..$max\n"; + +foreach my $test (1 .. $max) { + my($bang, $query) = @{$tests{$test}}; + my $exit = + ($^O eq 'MSWin32' + ? system qq($perl -e "\$! = $bang; \$? = $query; die;" 2> nul) + : system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null)); + + printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query + unless $exit == (($bang || ($query >> 8) || 255) << 8); + print "ok $test\n"; +} + diff --git a/t/op/exec.t b/t/op/exec.t index 7dfcd6177f..506fc09fbd 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -6,6 +6,7 @@ $| = 1; # flush stdout if ($^O eq 'MSWin32') { print "# exec is unsupported on Win32\n"; + # XXX the system tests could be written to use ./perl and so work on Win32 print "1..0\n"; exit(0); } @@ -16,6 +17,7 @@ print "not ok 1\n" if system "echo ok \\1"; # shell interpreted print "not ok 2\n" if system "echo ok 2"; # split and directly called print "not ok 3\n" if system "echo", "ok", "3"; # directly called +# these should probably be rewritten to match the examples in perlfunc.pod if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..13\n"; +print "1..16\n"; # type coersion on assignment $foo = 'foo'; @@ -65,3 +65,21 @@ if (defined $baa) { { package Foo::Bar } print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; + +# test undef operator clearing out entire glob +$foo = 'stuff'; +@foo = qw(more stuff); +%foo = qw(even more random stuff); +undef *foo; +print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; + +# test warnings from assignment of undef to glob +{ + my $msg; + local $SIG{__WARN__} = sub { $msg = $_[0] }; + local $^W = 1; + *foo = 'bar'; + print $msg ? "not ok" : "ok", " 15\n"; + *foo = undef; + print $msg ? "ok" : "not ok", " 16\n"; +} diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t index 741982622b..6343a2a8d5 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -1,11 +1,12 @@ #!./perl -use strict; - BEGIN { chdir 't' if -d 't'; + @INC = '../lib'; } +use strict; + use vars qw{ @warnings }; BEGIN { diff --git a/t/op/ipcmsg.t b/t/op/ipcmsg.t new file mode 100755 index 0000000000..ab2b0737e9 --- /dev/null +++ b/t/op/ipcmsg.t @@ -0,0 +1,142 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + IPC_PRIVATE + IPC_RMID + IPC_NOWAIT + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_msgget'} eq 'define' && + $Config{'d_msgctl'} eq 'define' && + $Config{'d_msgsnd'} eq 'define' && + $Config{'d_msgrcv'} eq 'define') { + print "1..0\n"; + exit; + } + + use strict; + + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file,$level) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + if(not defined $path and $level == 0) { + warn "Cannot find '$file'"; + return; + } + + local(*F); + open(F,$path) or return; + $level = 1 unless defined $level; + my $indent = " " x $level; + print "#$indent open $path\n"; + while(<F>) { + s#/\*.*(\*/|$)##; + + if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) { + print "#${indent} include $1\n"; + process_file($1,$level+1); + print "#${indent} done include $1\n"; + print "#${indent} back in $path\n"; + } + + s/(?:\([^)]*\)\s*)//; + + if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) { + print "#${indent} define $1 $2\n"; + $define{$1} = $2; + } + } + close(F); + print "#$indent close $path\n"; + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach my $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "# $d undefined\n"; + print "1..0\n"; + exit; + } + { + no strict 'refs'; + ${ $d } = eval $define{$d}; + } + } +} + +use strict; + +print "1..6\n"; + +my $msg = msgget($IPC_PRIVATE, $S_IRWXU | $S_IRWXG | $S_IRWXO) + || die "msgget failed: $!\n"; + +print "ok 1\n"; + +#Putting a message on the queue +my $msgtype = 1; +my $msgtext = "hello"; + +msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; +print "ok 2\n"; + +my $data; +msgctl($msg,$IPC_STAT,$data) or print "not "; +print "ok 3\n"; + +print "not " unless length($data); +print "ok 4\n"; + +my $msgbuf; +msgrcv($msg,$msgbuf,256,0,$IPC_NOWAIT) or print "not "; +print "ok 5\n"; + +my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); + +print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); +print "ok 6\n"; + +msgctl($msg,$IPC_RMID,0); + diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t new file mode 100755 index 0000000000..f71f810570 --- /dev/null +++ b/t/op/ipcsem.t @@ -0,0 +1,159 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + GETALL + SETALL + IPC_PRIVATE + IPC_CREAT + IPC_RMID + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_semget'} eq 'define' && + $Config{'d_semctl'} eq 'define') { + print "1..0\n"; + exit; + } + + use strict; + + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file,$level) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + if(not defined $path and $level == 0) { + warn "Cannot find '$file'"; + return; + } + + local(*F); + open(F,$path) or return; + $level = 1 unless defined $level; + my $indent = " " x $level; + print "#$indent open $path\n"; + while(<F>) { + s#/\*.*(\*/|$)##; + + if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) { + print "#${indent} include $1\n"; + process_file($1,$level+1); + print "#${indent} done include $1\n"; + print "#${indent} back in $path\n"; + } + + s/(?:\([^)]*\)\s*)//; + + if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) { + print "#${indent} define $1 $2\n"; + $define{$1} = $2; + } + } + close(F); + print "#$indent close $path\n"; + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach my $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "# $d undefined\n"; + print "1..0\n"; + exit; + } + { + no strict 'refs'; + ${ $d } = eval $define{$d}; + } + } +} + +use strict; + +# This test doesn't seem to work properly yet so skip it for _65 +print "1..0\n"; +exit; + + +print "1..10\n"; + +my $sem = semget($IPC_PRIVATE, 10, $S_IRWXU | $S_IRWXG | $S_IRWXO | $IPC_CREAT) + || die "semget: $!\n"; + +print "ok 1\n"; + +my $data; +semctl($sem,0,$IPC_STAT,$data) or print "not "; +print "ok 2\n"; + +print "not " unless length($data); +print "ok 3\n"; + +semctl($sem,0,$SETALL,pack("s*",(0) x 10)) or print "not "; +print "ok 4\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 5\n"; + +print "not " unless length($data); +print "ok 6\n"; + +my @data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0000000000"; +print "ok 7\n"; + +$data[2] = 1; +semctl($sem,0,$SETALL,pack("s*",@data)) or print "not "; +print "ok 8\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 9\n"; + +@data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0010000000"; +print "ok 10\n"; + +semctl($sem,0,$IPC_RMID,undef); + diff --git a/t/op/misc.t b/t/op/misc.t index 582ffa7905..9ab6831859 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -368,6 +368,11 @@ EXPECT 1 2 ######## +-w +sub testme { my $a = "test"; { local $a = "new test"; print $a }} +EXPECT +Can't localize lexical variable $a at - line 2. +######## package X; sub ascalar { my $r; bless \$r } sub DESTROY { print "destroyed\n" }; diff --git a/t/op/pack.t b/t/op/pack.t index f9a89a3ec0..de5fcff218 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -2,7 +2,7 @@ # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ -print "1..29\n"; +print "1..30\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -100,3 +100,9 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ } # undef should give null pointer print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); +# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives +# 4294967295 instead of -1) +# see #ifdef __osf__ in pp.c pp_unpack +# Test 30: +print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); + diff --git a/t/op/pos.t b/t/op/pos.t new file mode 100755 index 0000000000..46811b7bbc --- /dev/null +++ b/t/op/pos.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\n"; + +$x='banana'; +$x=~/.a/g; +if (pos($x)==2) {print "ok 1\n"} else {print "not ok 1\n";} + +$x=~/.z/gc; +if (pos($x)==2) {print "ok 2\n"} else {print "not ok 2\n";} + +sub f { my $p=$_[0]; return $p } + +$x=~/.a/g; +if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} + diff --git a/t/op/runlevel.t b/t/op/runlevel.t index b5e5dbb08c..bff26e4b71 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -188,6 +188,8 @@ sub sortfn { print "---- ".join(', ', @x)."\n"; EXPECT sortfn 4, 5, 6 +sortfn 4, 5, 6 +sortfn 4, 5, 6 ---- 1, 2, 3 ######## @a = (3, 2, 1); diff --git a/t/op/stat.t b/t/op/stat.t index 9d4b3a6787..c7cd0961f3 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -45,7 +45,12 @@ else { if ($Is_MSWin32 || $Is_Dos || $Config{dont_use_nlink} || $nlink == 2) {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";} -if ($Is_MSWin32 || $Is_Dos || ($mtime && $mtime != $ctime) || $cwd =~ m#/afs/# || $^O eq 'amigaos') { +if ( ($mtime && $mtime != $ctime) + || $Is_MSWin32 + || $Is_Dos + || ($cwd eq '/tmp' and $mtime && $mtime==$ctime) # Solaris tmpfs bug + || $cwd =~ m#/afs/# + || $^O eq 'amigaos') { print "ok 4\n"; } else { @@ -53,7 +58,7 @@ else { print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; } -print "#4 :$mtime: != :$ctime:\n"; +print "#4 :$mtime: should != :$ctime:\n"; unlink "Op.stat.tmp"; if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } diff --git a/t/op/subst.t b/t/op/subst.t index 4fd00d5067..248aa71b9d 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..68\n"; +print "1..69\n"; $x = 'foo'; $_ = "x"; @@ -267,3 +267,6 @@ $_="baacbaa"; tr/a/b/s; print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n"; +# XXX TODO: Most tests above don't test return values of the ops. They should. +$_ = "ab"; +print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n"); diff --git a/t/op/substr.t b/t/op/substr.t index bb655f5209..967016a8d0 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $ - -print "1..97\n"; +print "1..100\n"; #P = start of string Q = start of substr R = end of substr S = end of string @@ -178,3 +176,13 @@ for (0,1) { # check no spurious warnings print $w ? "not ok 97\n" : "ok 97\n"; + +# check new replacement syntax +$a = "abcxyz"; +print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +print "ok 98\n"; +print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +print "ok 99\n"; +print "not " unless substr($a, 3, undef, "") eq "xyz" && $a eq "abc"; +print "ok 100\n"; + diff --git a/t/op/taint.t b/t/op/taint.t index e18f123e9d..2b9da86b3f 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -83,7 +83,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..140\n"; +print "1..145\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -121,7 +121,10 @@ print "1..140\n"; } my $tmp; - unless ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { + if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { + print "# all directories are writeable\n"; + } + else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } qw(/tmp /var/tmp /usr/tmp /sys$scratch), @ENV{qw(TMP TEMP)})[0] @@ -184,12 +187,16 @@ print "1..140\n"; test 20, not tainted $foo; test 21, $foo eq 'bar'; + $foo = $1 if ('bar' . $TAINT) =~ /(.+)/t; + test 22, tainted $foo; + test 23, $foo eq 'bar'; + my $pi = 4 * atan2(1,1) + $TAINT0; - test 22, tainted $pi; + test 24, tainted $pi; ($pi) = $pi =~ /(\d+\.\d+)/; - test 23, not tainted $pi; - test 24, sprintf("%.5f", $pi) eq '3.14159'; + test 25, not tainted $pi; + test 26, sprintf("%.5f", $pi) eq '3.14159'; } # How about command-line arguments? The problem is that we don't @@ -205,21 +212,21 @@ print "1..140\n"; }; close PROG; print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 25, !$?, "Exited with status $?"; + test 27, !$?, "Exited with status $?"; unlink $arg; } # Reading from a file should be tainted { my $file = './TEST'; - test 26, open(FILE, $file), "Couldn't open '$file': $!"; + test 28, open(FILE, $file), "Couldn't open '$file': $!"; my $block; sysread(FILE, $block, 100); my $line = <FILE>; close FILE; - test 27, tainted $block; - test 28, tainted $line; + test 29, tainted $block; + test 30, tainted $line; } # Globs should be forbidden, except under VMS, @@ -229,122 +236,122 @@ if ($Is_VMS) { } else { my @globs = eval { <*> }; - test 29, @globs == 0 && $@ =~ /^Insecure dependency/; + test 31, @globs == 0 && $@ =~ /^Insecure dependency/; @globs = eval { glob '*' }; - test 30, @globs == 0 && $@ =~ /^Insecure dependency/; + test 32, @globs == 0 && $@ =~ /^Insecure dependency/; } # Output of commands should be tainted { my $foo = `$echo abc`; - test 31, tainted $foo; + test 33, tainted $foo; } # Certain system variables should be tainted { - test 32, all_tainted $^X, $0; + test 34, all_tainted $^X, $0; } # Results of matching should all be untainted { my $foo = "abcdefghi" . $TAINT; - test 33, tainted $foo; + test 35, tainted $foo; $foo =~ /def/; - test 34, not any_tainted $`, $&, $'; + test 36, not any_tainted $`, $&, $'; $foo =~ /(...)(...)(...)/; - test 35, not any_tainted $1, $2, $3, $+; + test 37, not any_tainted $1, $2, $3, $+; my @bar = $foo =~ /(...)(...)(...)/; - test 36, not any_tainted @bar; + test 38, not any_tainted @bar; - test 37, tainted $foo; # $foo should still be tainted! - test 38, $foo eq "abcdefghi"; + test 39, tainted $foo; # $foo should still be tainted! + test 40, $foo eq "abcdefghi"; } # Operations which affect files can't use tainted data. { - test 39, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 40, $@ =~ /^Insecure dependency/, $@; + test 41, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 42, $@ =~ /^Insecure dependency/, $@; # There is no feature test in $Config{} for truncate, # so we allow for the possibility that it's missing. - test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - - test 43, eval { rename '', $TAINT } eq '', 'rename'; - test 44, $@ =~ /^Insecure dependency/, $@; + test 43, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 44, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - test 45, eval { unlink $TAINT } eq '', 'unlink'; + test 45, eval { rename '', $TAINT } eq '', 'rename'; test 46, $@ =~ /^Insecure dependency/, $@; - test 47, eval { utime $TAINT } eq '', 'utime'; + test 47, eval { unlink $TAINT } eq '', 'unlink'; test 48, $@ =~ /^Insecure dependency/, $@; + test 49, eval { utime $TAINT } eq '', 'utime'; + test 50, $@ =~ /^Insecure dependency/, $@; + if ($Config{d_chown}) { - test 49, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 50, $@ =~ /^Insecure dependency/, $@; + test 51, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 52, $@ =~ /^Insecure dependency/, $@; } else { - for (49..50) { print "ok $_ # Skipped: chown() is not available\n" } + for (51..52) { print "ok $_ # Skipped: chown() is not available\n" } } if ($Config{d_link}) { - test 51, eval { link $TAINT, '' } eq '', 'link'; - test 52, $@ =~ /^Insecure dependency/, $@; + test 53, eval { link $TAINT, '' } eq '', 'link'; + test 54, $@ =~ /^Insecure dependency/, $@; } else { - for (51..52) { print "ok $_ # Skipped: link() is not available\n" } + for (53..54) { print "ok $_ # Skipped: link() is not available\n" } } if ($Config{d_symlink}) { - test 53, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 54, $@ =~ /^Insecure dependency/, $@; + test 55, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 56, $@ =~ /^Insecure dependency/, $@; } else { - for (53..54) { print "ok $_ # Skipped: symlink() is not available\n" } + for (55..56) { print "ok $_ # Skipped: symlink() is not available\n" } } } # Operations which affect directories can't use tainted data. { - test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 56, $@ =~ /^Insecure dependency/, $@; - - test 57, eval { rmdir $TAINT } eq '', 'rmdir'; + test 57, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; test 58, $@ =~ /^Insecure dependency/, $@; - test 59, eval { chdir $TAINT } eq '', 'chdir'; + test 59, eval { rmdir $TAINT } eq '', 'rmdir'; test 60, $@ =~ /^Insecure dependency/, $@; + test 61, eval { chdir $TAINT } eq '', 'chdir'; + test 62, $@ =~ /^Insecure dependency/, $@; + if ($Config{d_chroot}) { - test 61, eval { chroot $TAINT } eq '', 'chroot'; - test 62, $@ =~ /^Insecure dependency/, $@; + test 63, eval { chroot $TAINT } eq '', 'chroot'; + test 64, $@ =~ /^Insecure dependency/, $@; } else { - for (61..62) { print "ok $_ # Skipped: chroot() is not available\n" } + for (63..64) { print "ok $_ # Skipped: chroot() is not available\n" } } } # Some operations using files can't use tainted data. { my $foo = "imaginary library" . $TAINT; - test 63, eval { require $foo } eq '', 'require'; - test 64, $@ =~ /^Insecure dependency/, $@; + test 65, eval { require $foo } eq '', 'require'; + test 66, $@ =~ /^Insecure dependency/, $@; my $filename = "./taintB$$"; # NB: $filename isn't tainted! END { unlink $filename if defined $filename } $foo = $filename . $TAINT; unlink $filename; # in any case - test 65, eval { open FOO, $foo } eq '', 'open for read'; - test 66, $@ eq '', $@; # NB: This should be allowed - test 67, $! == ($Config{"archname"} !~ "djgpp" ? 2 : 22); # File not found + test 67, eval { open FOO, $foo } eq '', 'open for read'; + test 68, $@ eq '', $@; # NB: This should be allowed + test 69, $! == 2; # File not found - test 68, eval { open FOO, "> $foo" } eq '', 'open for write'; - test 69, $@ =~ /^Insecure dependency/, $@; + test 70, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 71, $@ =~ /^Insecure dependency/, $@; } # Commands to the system can't use tainted data @@ -352,67 +359,67 @@ else { my $foo = $TAINT; if ($^O eq 'amigaos') { - for (70..73) { print "ok $_ # Skipped: open('|') is not available\n" } + for (72..75) { print "ok $_ # Skipped: open('|') is not available\n" } } else { - test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; - test 71, $@ =~ /^Insecure dependency/, $@; - - test 72, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 72, eval { open FOO, "| $foo" } eq '', 'popen to'; test 73, $@ =~ /^Insecure dependency/, $@; - } - test 74, eval { exec $TAINT } eq '', 'exec'; - test 75, $@ =~ /^Insecure dependency/, $@; + test 74, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 75, $@ =~ /^Insecure dependency/, $@; + } - test 76, eval { system $TAINT } eq '', 'system'; + test 76, eval { exec $TAINT } eq '', 'exec'; test 77, $@ =~ /^Insecure dependency/, $@; + test 78, eval { system $TAINT } eq '', 'system'; + test 79, $@ =~ /^Insecure dependency/, $@; + $foo = "*"; taint_these $foo; - test 78, eval { `$echo 1$foo` } eq '', 'backticks'; - test 79, $@ =~ /^Insecure dependency/, $@; + test 80, eval { `$echo 1$foo` } eq '', 'backticks'; + test 81, $@ =~ /^Insecure dependency/, $@; if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 80, join('', eval { glob $foo } ) ne '', 'globbing'; - test 81, $@ eq '', $@; + test 82, join('', eval { glob $foo } ) ne '', 'globbing'; + test 83, $@ eq '', $@; } else { - for (80..81) { print "ok $_ # Skipped: this is not VMS\n"; } + for (82..83) { print "ok $_ # Skipped: this is not VMS\n"; } } } # Operations which affect processes can't use tainted data. { - test 82, eval { kill 0, $TAINT } eq '', 'kill'; - test 83, $@ =~ /^Insecure dependency/, $@; + test 84, eval { kill 0, $TAINT } eq '', 'kill'; + test 85, $@ =~ /^Insecure dependency/, $@; if ($Config{d_setpgrp}) { - test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 85, $@ =~ /^Insecure dependency/, $@; + test 86, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 87, $@ =~ /^Insecure dependency/, $@; } else { - for (84..85) { print "ok $_ # Skipped: setpgrp() is not available\n" } + for (86..87) { print "ok $_ # Skipped: setpgrp() is not available\n" } } if ($Config{d_setprior}) { - test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 87, $@ =~ /^Insecure dependency/, $@; + test 88, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 89, $@ =~ /^Insecure dependency/, $@; } else { - for (86..87) { print "ok $_ # Skipped: setpriority() is not available\n" } + for (88..89) { print "ok $_ # Skipped: setpriority() is not available\n" } } } # Some miscellaneous operations can't use tainted data. { if ($Config{d_syscall}) { - test 88, eval { syscall $TAINT } eq '', 'syscall'; - test 89, $@ =~ /^Insecure dependency/, $@; + test 90, eval { syscall $TAINT } eq '', 'syscall'; + test 91, $@ =~ /^Insecure dependency/, $@; } else { - for (88..89) { print "ok $_ # Skipped: syscall() is not available\n" } + for (90..91) { print "ok $_ # Skipped: syscall() is not available\n" } } { @@ -421,17 +428,17 @@ else { local *FOO; my $temp = "./taintC$$"; END { unlink $temp } - test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + test 92, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 92, $@ =~ /^Insecure dependency/, $@; + test 93, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 94, $@ =~ /^Insecure dependency/, $@; if ($Config{d_fcntl}) { - test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 94, $@ =~ /^Insecure dependency/, $@; + test 95, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 96, $@ =~ /^Insecure dependency/, $@; } else { - for (93..94) { print "ok $_ # Skipped: fcntl() is not available\n" } + for (95..96) { print "ok $_ # Skipped: fcntl() is not available\n" } } close FOO; @@ -442,65 +449,65 @@ else { { my $foo = 'abc' . $TAINT; my $fooref = \$foo; - test 95, not tainted $fooref; - test 96, tainted $$fooref; - test 97, tainted $foo; + test 97, not tainted $fooref; + test 98, tainted $$fooref; + test 99, tainted $foo; } # Some tests involving assignment { my $foo = $TAINT0; my $bar = $foo; - test 98, all_tainted $foo, $bar; - test 99, tainted($foo = $bar); - test 100, tainted($bar = $bar); - test 101, tainted($bar += $bar); - test 102, tainted($bar -= $bar); - test 103, tainted($bar *= $bar); - test 104, tainted($bar++); - test 105, tainted($bar /= $bar); - test 106, tainted($bar += 0); - test 107, tainted($bar -= 2); - test 108, tainted($bar *= -1); - test 109, tainted($bar /= 1); - test 110, tainted($bar--); - test 111, $bar == 0; + test 100, all_tainted $foo, $bar; + test 101, tainted($foo = $bar); + test 102, tainted($bar = $bar); + test 103, tainted($bar += $bar); + test 104, tainted($bar -= $bar); + test 105, tainted($bar *= $bar); + test 106, tainted($bar++); + test 107, tainted($bar /= $bar); + test 108, tainted($bar += 0); + test 109, tainted($bar -= 2); + test 110, tainted($bar *= -1); + test 111, tainted($bar /= 1); + test 112, tainted($bar--); + test 113, $bar == 0; } # Test assignment and return of lists { my @foo = ("A", "tainted" . $TAINT, "B"); - test 112, not tainted $foo[0]; - test 113, tainted $foo[1]; - test 114, not tainted $foo[2]; + test 114, not tainted $foo[0]; + test 115, tainted $foo[1]; + test 116, not tainted $foo[2]; my @bar = @foo; - test 115, not tainted $bar[0]; - test 116, tainted $bar[1]; - test 117, not tainted $bar[2]; + test 117, not tainted $bar[0]; + test 118, tainted $bar[1]; + test 119, not tainted $bar[2]; my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 118, not tainted $baz[0]; - test 119, tainted $baz[1]; - test 120, not tainted $baz[2]; + test 120, not tainted $baz[0]; + test 121, tainted $baz[1]; + test 122, not tainted $baz[2]; my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 121, not tainted $plugh[0]; - test 122, tainted $plugh[1]; - test 123, not tainted $plugh[2]; + test 123, not tainted $plugh[0]; + test 124, tainted $plugh[1]; + test 125, not tainted $plugh[2]; my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 124, not tainted ((&$nautilus)[0]); - test 125, tainted ((&$nautilus)[1]); - test 126, not tainted ((&$nautilus)[2]); + test 126, not tainted ((&$nautilus)[0]); + test 127, tainted ((&$nautilus)[1]); + test 128, not tainted ((&$nautilus)[2]); my @xyzzy = &$nautilus; - test 127, not tainted $xyzzy[0]; - test 128, tainted $xyzzy[1]; - test 129, not tainted $xyzzy[2]; + test 129, not tainted $xyzzy[0]; + test 130, tainted $xyzzy[1]; + test 131, not tainted $xyzzy[2]; my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 130, not tainted ((&$red_october)[0]); - test 131, tainted ((&$red_october)[1]); - test 132, not tainted ((&$red_october)[2]); + test 132, not tainted ((&$red_october)[0]); + test 133, tainted ((&$red_october)[1]); + test 134, not tainted ((&$red_october)[2]); my @corge = &$red_october; - test 133, not tainted $corge[0]; - test 134, tainted $corge[1]; - test 135, not tainted $corge[2]; + test 135, not tainted $corge[0]; + test 136, tainted $corge[1]; + test 137, not tainted $corge[2]; } # Test for system/library calls returning string data of dubious origin. @@ -510,7 +517,7 @@ else { setpwent(); my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); - test 136,( not tainted $getpwent[0] + test 138,( not tainted $getpwent[0] and not tainted $getpwent[1] and not tainted $getpwent[2] and not tainted $getpwent[3] @@ -521,17 +528,17 @@ else { and not tainted $getpwent[8]); endpwent(); } else { - print "ok 136 # Skipped: getpwent() is not available\n"; + print "ok 138 # Skipped: getpwent() is not available\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; + test 139, tainted $readdir; closedir(OP); } else { - print "ok 137 # Skipped: readdir() is not available\n"; + print "ok 139 # Skipped: readdir() is not available\n"; } if ($Config{d_readlink} && $Config{d_symlink}) { @@ -539,10 +546,10 @@ else { unlink($symlink); symlink("/something/naughty", $symlink) or die "symlink: $!\n"; my $readlink = readlink($symlink); - test 138, tainted $readlink; + test 140, tainted $readlink; unlink($symlink); } else { - print "ok 138 # Skipped: readlink() or symlink() is not available\n"; + print "ok 140 # Skipped: readlink() or symlink() is not available\n"; } } @@ -550,9 +557,22 @@ else { { my $why = "y"; my $j = "x" | $why; - test 139, not tainted $j; + test 141, not tainted $j; $why = $TAINT."y"; $j = "x" | $why; - test 140, tainted $j; + test 142, tainted $j; } +# test target of substitution (regression bug) +{ + my $why = $TAINT."y"; + $why =~ s/y/z/; + test 143, tainted $why; + + my $z = "[z]"; + $why =~ s/$z/zee/; + test 144, tainted $why; + + $why =~ s/e/'-'.$$/ge; + test 145, tainted $why; +} diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 8875f7caa6..bd5267d720 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -19,6 +19,9 @@ eval { $have_setlocale++; }; +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i; + print "1..", ($have_setlocale ? 102 : 98), "\n"; use vars qw($a @@ -1,4 +1,10 @@ -/* Per-thread variables */ +/* Don't forget to re-run embed.pl to propagate changes! */ + +/* Per-thread variables + The 'T' prefix is only needed for vars that need appropriate #defines +generated when built with or without USE_THREADS. (It is also used +to generate the appropriate the export list for win32.) */ + /* Important ones in the first cache line (if alignment is done right) */ PERLVAR(Tstack_sp, SV **) @@ -78,10 +84,14 @@ PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */ PERLVAR(Tav_fetch_sv, SV *) PERLVAR(Thv_fetch_sv, SV *) PERLVAR(Thv_fetch_ent_mh, HE) +PERLVAR(Tmodcount, I32) /* XXX Sort stuff, firstgv secongv and so on? */ /* XXX What about regexp stuff? */ +/* Note that the variables below are all explicitly referenced in the code +as thr->whatever and therefore don't need the 'T' prefix. */ + #ifdef USE_THREADS PERLVAR(oursv, SV *) @@ -36,10 +36,12 @@ #endif #ifndef YIELD -# ifdef HAS_PTHREAD_YIELD -# define YIELD pthread_yield() -# else +# ifdef HAS_SCHED_YIELD # define YIELD sched_yield() +# else +# ifdef HAS_PTHREAD_YIELD +# define YIELD pthread_yield() +# endif # endif #endif @@ -181,7 +181,7 @@ missingterm(char *s) char q; if (s) { char *nl = strrchr(s,'\n'); - if (nl) + if (nl) *nl = '\0'; } else if (multi_close < 32 || multi_close == 127) { @@ -403,8 +403,6 @@ skipspace(register char *s) PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); - if (e_fp == rsfp) - e_fp = Nullfp; rsfp = Nullfp; return s; } @@ -758,6 +756,12 @@ sublex_done(void) processing a pattern (lex_inpat is true), a transliteration (lex_inwhat & OP_TRANS is true), or a double-quoted string. + Returns a pointer to the character scanned up to. Iff this is + advanced from the start pointer supplied (ie if anything was + successfully parsed), will leave an OP for the substring scanned + in yylval. Caller must intuit reason for not parsing further + by looking at the next characters herself. + In patterns: backslashes: double-quoted style: \r and \n @@ -825,17 +829,11 @@ scan_const(char *start) bool dorange = FALSE; /* are we in a translit range? */ I32 len; /* ? */ - /* - leave is the set of acceptably-backslashed characters. - - I do *not* understand why there's the double hook here. - */ + /* leaveit is the set of acceptably-backslashed characters */ char *leaveit = lex_inpat ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#" - : (lex_inwhat & OP_TRANS) - ? "" - : ""; + : ""; while (s < send || dorange) { /* get transliterations out of the way (they're most literal) */ @@ -1022,7 +1020,7 @@ scan_const(char *start) Renew(SvPVX(sv), SvLEN(sv), char); } - /* ??? */ + /* return the substring (via yylval) only if we parsed anything */ if (s > bufptr) yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); else @@ -1068,7 +1066,7 @@ intuit_more(register char *s) else { int weight = 2; /* let's weigh the evidence */ char seen[256]; - unsigned char un_char = 0, last_un_char; + unsigned char un_char = 255, last_un_char; char *send = strchr(s,']'); char tmpbuf[sizeof tokenbuf * 4]; @@ -1134,6 +1132,8 @@ intuit_more(register char *s) weight += 30; if (strchr("zZ79~",s[1])) weight += 30; + if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) + weight -= 5; /* cope with negative subscript */ break; default: if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) && @@ -1783,8 +1783,6 @@ yylex(void) PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); - if (e_fp == rsfp) - e_fp = Nullfp; rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { @@ -4848,6 +4846,8 @@ void pmflag(U16 *pmfl, int ch) *pmfl |= PMf_MULTILINE; else if (ch == 's') *pmfl |= PMf_SINGLELINE; + else if (ch == 't') + *pmfl |= PMf_TAINTMEM; else if (ch == 'x') *pmfl |= PMf_EXTENDED; } @@ -4869,7 +4869,7 @@ scan_pat(char *start) pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogcmsx", *s)) + while (*s && strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); pm->op_pmpermflags = pm->op_pmflags; @@ -4914,13 +4914,15 @@ scan_subst(char *start) multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); - while (*s && strchr("iogcmsex", *s)) { + while (*s) { if (*s == 'e') { s++; es++; } - else + else if (strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); + else + break; } if (es) { @@ -5076,7 +5078,7 @@ scan_heredoc(register char *s) } sv_setpvn(tmpstr,d+1,s-d); s += len - 1; - curcop->cop_line++; /* the preceding stmt passes a newline */ + curcop->cop_line++; /* the preceding stmt passes a newline */ sv_catpvn(herewas,s,bufend-s); sv_setsv(linestr,herewas); @@ -1279,7 +1279,7 @@ die(pat, va_alist) #else va_start(args); #endif - message = mess(pat, &args); + message = pat ? mess(pat, &args) : Nullch; va_end(args); #ifdef USE_THREADS @@ -1300,9 +1300,14 @@ die(pat, va_alist) SV *msg; ENTER; - msg = newSVpv(message, 0); - SvREADONLY_on(msg); - SAVEFREESV(msg); + if(message) { + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } PUSHSTACK(SI_DIEHOOK); PUSHMARK(SP); @@ -2086,6 +2091,7 @@ my_pclose(PerlIO *ptr) int status; SV **svp; int pid; + int pid2; bool close_failed; int saved_errno; #ifdef VMS @@ -2120,8 +2126,8 @@ my_pclose(PerlIO *ptr) rsignal_save(SIGINT, SIG_IGN, &istat); rsignal_save(SIGQUIT, SIG_IGN, &qstat); do { - pid = wait4pid(pid, &status, 0); - } while (pid == -1 && errno == EINTR); + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); rsignal_restore(SIGHUP, &hstat); rsignal_restore(SIGINT, &istat); rsignal_restore(SIGQUIT, &qstat); @@ -2129,7 +2135,7 @@ my_pclose(PerlIO *ptr) SETERRNO(saved_errno, saved_vaxc_errno); return -1; } - return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status)); + return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); } #endif /* !DOSISH */ @@ -2389,7 +2395,7 @@ scan_hex(char *start, I32 len, I32 *retlen) register char *s = start; register UV retval = 0; bool overflowed = FALSE; - char *tmp; + char *tmp = s; while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) { register UV n = retval << 4; @@ -2400,10 +2406,218 @@ scan_hex(char *start, I32 len, I32 *retlen) retval = n | ((tmp - hexdigit) & 15); s++; } + if (dowarn && !tmp) { + warn("Illegal hex digit ignored"); + } *retlen = s - start; return retval; } +char* +find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) +{ + dTHR; + char *xfound = Nullch; + char *xfailed = Nullch; + register char *s; + I32 len; + int retval; +#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +# define SEARCH_EXTS ".bat", ".cmd", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef OS2 +# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef VMS +# define SEARCH_EXTS ".pl", ".com", NULL +# define MAX_EXT_LEN 4 +#endif + /* additional extensions to try in each dir if scriptname not found */ +#ifdef SEARCH_EXTS + char *exts[] = { SEARCH_EXTS }; + char **ext = search_ext ? search_ext : exts; + int extidx = 0, i = 0; + char *curext = Nullch; +#else +# define MAX_EXT_LEN 0 +#endif + + /* + * If dosearch is true and if scriptname does not contain path + * delimiters, search the PATH for scriptname. + * + * If SEARCH_EXTS is also defined, will look for each + * scriptname{SEARCH_EXTS} whenever scriptname is not found + * while searching the PATH. + * + * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search + * proceeds as follows: + * If DOSISH or VMSISH: + * + look for ./scriptname{,.foo,.bar} + * + search the PATH for scriptname{,.foo,.bar} + * + * If !DOSISH: + * + look *only* in the PATH for scriptname{,.foo,.bar} (note + * this will not look in '.' if it's not in the PATH) + */ + +#ifdef VMS +# ifdef ALWAYS_DEFTYPES + len = strlen(scriptname); + if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { + int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; + + hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ; +# else + if (dosearch) { + int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; + + hasdir = (strpbrk(scriptname,":[</") != Nullch) ; +# endif + /* The first time through, just add SEARCH_EXTS to whatever we + * already have, so we can check for default file types. */ + while (deftypes || + (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) + { + if (deftypes) { + deftypes = 0; + *tokenbuf = '\0'; + } + if ((strlen(tokenbuf) + strlen(scriptname) + + MAX_EXT_LEN) >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + strcat(tokenbuf, scriptname); +#else /* !VMS */ + +#ifdef DOSISH + if (strEQ(scriptname, "-")) + dosearch = 0; + if (dosearch) { /* Look in '.' first. */ + char *cur = scriptname; +#ifdef SEARCH_EXTS + if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ + while (ext[i]) + if (strEQ(ext[i++],curext)) { + extidx = -1; /* already has an ext */ + break; + } + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Looking for %s\n",cur)); + if (PerlLIO_stat(cur,&statbuf) >= 0) { + dosearch = 0; + scriptname = cur; +#ifdef SEARCH_EXTS + break; +#endif + } +#ifdef SEARCH_EXTS + if (cur == scriptname) { + len = strlen(scriptname); + if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) + break; + cur = strcpy(tokenbuf, scriptname); + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++])); +#endif + } +#endif + + if (dosearch && !strchr(scriptname, '/') +#ifdef DOSISH + && !strchr(scriptname, '\\') +#endif + && (s = PerlEnv_getenv("PATH"))) { + bool seen_dot = 0; + + bufend = s + strlen(s); + while (s < bufend) { +#if defined(atarist) || defined(DOSISH) + for (len = 0; *s +# ifdef atarist + && *s != ',' +# endif + && *s != ';'; len++, s++) { + if (len < sizeof tokenbuf) + tokenbuf[len] = *s; + } + if (len < sizeof tokenbuf) + tokenbuf[len] = '\0'; +#else /* ! (atarist || DOSISH) */ + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ + if (s < bufend) + s++; + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + if (len +#if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' + && tokenbuf[len - 1] != '\\' +#endif + ) + tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; + (void)strcpy(tokenbuf + len, scriptname); +#endif /* !VMS */ + +#ifdef SEARCH_EXTS + len = strlen(tokenbuf); + if (extidx > 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); + retval = PerlLIO_stat(tokenbuf,&statbuf); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++]) + ); +#endif + if (retval < 0) + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) +#ifndef DOSISH + && cando(S_IXUSR,TRUE,&statbuf) +#endif + ) + { + xfound = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tokenbuf); + } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) +#endif + seen_dot = 1; /* Disable message. */ + if (!xfound) + scriptname = NULL; +/* croak("Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */ + if (xfailed) + Safefree(xfailed); + scriptname = xfound; + } + return scriptname; +} + + #ifdef USE_THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ diff --git a/utils/Makefile b/utils/Makefile index 3c343c82b7..2df16d8060 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -1,13 +1,18 @@ PERL = ../miniperl +REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc +plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe -all: $(plextract) +all: $(plextract) + +compile: all + $(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; $(plextract): $(PERL) -I../lib $@.PL @@ -26,10 +31,12 @@ pl2pm: pl2pm.PL ../config.sh splain: splain.PL ../config.sh ../lib/diagnostics.pm +perlcc: perlcc.PL ../config.sh + clean: realclean: - rm -rf $(plextract) pstruct + rm -rf $(plextract) pstruct $(plextractexe) clobber: realclean diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 5c17e97ca0..730c2259e7 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -1,7 +1,7 @@ #!/usr/local/bin/perl use Config; -use File::Basename qw(&basename &dirname); +use File::Basename qw(basename dirname); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -38,8 +38,9 @@ use Config; use File::Path qw(mkpath); use Getopt::Std; -getopts('d:rlh'); - +getopts('Dd:rlha'); +die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); +@inc_dirs = inc_dirs() if $opt_a; my $Exit = 0; @@ -76,14 +77,21 @@ while (defined ($file = next_file())) { if ($file eq '-') { open(IN, "-"); open(OUT, ">-"); - } - else { + } else { ($outfile = $file) =~ s/\.h$/.ph/ || next; print "$file -> $outfile\n"; if ($file =~ m|^(.*)/|) { $dir = $1; mkpath "$Dest_dir/$dir"; } + + if ($opt_a) { # automagic mode: locate header file in @inc_dirs + foreach (@inc_dirs) { + chdir $_; + last if -f $file; + } + } + open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; } @@ -94,6 +102,7 @@ while (defined ($file = next_file())) { $_ .= <IN>; chop; } + print OUT "# $_\n" if $opt_D; if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments @@ -103,7 +112,7 @@ while (defined ($file = next_file())) { redo; } } - if (s/^#\s*//) { + if (s/^\s*#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; @@ -122,98 +131,146 @@ while (defined ($file = next_file())) { } s/^\s+//; expr(); - $new =~ s/(["\\])/\\$1/g; + $new =~ s/(["\\])/\\$1/g; #"]); + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t, - "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; } - } - else { - print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; + } else { + print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; } %curargs = (); - } - else { + } else { s/^\s+//; expr(); $new = 1 if $new eq ''; + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } - } - else { - print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; + } else { + print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } - } - elsif (/^include\s*<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; + } elsif (/^(include|import)\s*[<"](.*)[>"]/) { + ($incl = $2) =~ s/\.h$/.ph/; print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; + } elsif(/^include_next\s*[<"](.*)[>"]/) { + ($incl = $1) =~ s/\.h$/.ph/; + # should've read up on #include_next properly before attempting + # to implement it... + # + #print OUT $t, "{\n"; + #$tab += 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "my(\$INC) = shift(\@INC);\n"; + #print OUT $t, "require '$incl';\n"; + #print OUT $t, "unshift(\@INC, \$INC);}\n"; + #$tab -= 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "}\n"; + # + # try this instead: + print OUT ($t, "my(\$i) = 0;\n"); + print OUT ($t, "if(exists(\$INC{$incl})) {\n"); $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; + print OUT ($t, "++\$i while (\$i <= \$#INC", + " and \$INC[\$i].'/$incl' ne \$INC{'$incl'});\n"); + print OUT ($t, "\$i = 0 if \$INC[\$i].'/$incl' ne", + " \$INC{'$incl'};\n"); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT ($t, "}\n"); + print OUT ($t, + "eval(\"require '\" . ", + "(\$i ? \$INC[\$i].'/' : '') . \"\$incl';\");"); + # any better? require is smart enough not to try and include a + # file twice, i believe, so require-ing the same actual file + # should end up just being a null operation... + } elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if(defined(&$1)) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { + } elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"unless(defined(&$1)) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } elsif (s/^if\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; - print OUT $t,"if ($new) {\n"; + print OUT $t,"if($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { + } elsif (s/^elif\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; + print OUT $t,"}\n elsif($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { + } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; + print OUT $t,"} else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { + } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; + } elsif(/^undef\s+(\w+)/) { + print OUT $t, "undef(&$1) if defined(&$1);\n"; + } elsif(/^error\s+(.*)/) { + print OUT $t, "die(\"$1\");\n"; + } elsif(/^warning\s+(.*)/) { + print OUT $t, "warn(\"$1\");\n"; + } elsif(/^ident\s+(.*)/) { + print OUT $t, "# $1\n"; } } } print OUT "1;\n"; + + $is_converted{$file} = 1; + queue_includes_from($file) if ($opt_a); } exit $Exit; +sub reindent($) { + my($text) = shift; + $text =~ s/\n/\n /g; + $text =~ s/ /\t/g; + $text; +} + sub expr { + if(keys(%curargs)) { + my($joined_args) = join('|', keys(%curargs)); + } while ($_ ne '') { - s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator - s/^\&//; # hack for things that take the address of + s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator + s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; @@ -222,8 +279,7 @@ sub expr { s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; - } - else { + } else { $new .= "ord('$1')"; } next; @@ -260,11 +316,22 @@ sub expr { } s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. }; - # struct/union member: - s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do { + # struct/union member, including arrays: + s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { $id = $1; - $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g; - $new .= ' ($' . $id . ')'; + $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; + $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); + while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { + my($index) = $1; + $index =~ s/\s//g; + if(exists($curargs{$index})) { + $index = "\$$index"; + } else { + $index = "&$index"; + } + $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; + } + $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; @@ -272,41 +339,33 @@ sub expr { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; - } - elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { + } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { while (s/^\s+(\w+)//) { $id .= ' ' . $1; } $isatype{$id} = 1; } if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { + $new .= "\$$id"; + $new .= '->' if /^[\[\{]/; + } elsif ($id eq 'defined') { $new .= 'defined'; - } - elsif (/^\(/) { + } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat $new .= " &$id"; - } - elsif ($isatype{$id}) { + } elsif ($isatype{$id}) { if ($new =~ /{\s*$/) { $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { + } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { $new =~ s/\(\s*$//; s/^[\s*]*\)//; - } - else { + } else { $new .= q(').$id.q('); } - } - else { + } else { if ($inif && $new !~ /defined\s*\($/) { $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; - } - elsif (/^\[/) { - $new .= ' $' . $id; - } - else { + } elsif (/^\[/) { + $new .= " \$$id"; + } else { $new .= ' &' . $id; } } @@ -334,6 +393,8 @@ sub next_file } else { print STDERR "Skipping directory `$file'\n"; } + } elsif ($opt_a) { + return $file; } else { print STDERR "Skipping `$file': not a file or directory\n"; } @@ -388,7 +449,7 @@ sub link_if_possible # Make sure that the link _links_ to something: if (! -e "$Dest_dir/$target") { - mkdir("$Dest_dir/$target", 0755) or + mkpath("$Dest_dir/$target", 0755) or print STDERR "Could not create $Dest_dir/$target/\n"; } } else { @@ -398,6 +459,41 @@ sub link_if_possible } +# Push all #included files in $file onto our stack, except for STDIN +# and files we've already processed. +sub queue_includes_from +{ + my ($file) = @_; + my $line; + + return if ($file eq "-"); + + open HEADER, $file or return; + while (defined($line = <HEADER>)) { + while (/\\$/) { # Handle continuation lines + chop $line; + $line .= <HEADER>; + } + + if ($line =~ /^#\s*include\s+<(.*?)>/) { + push(@ARGV, $1) unless $is_converted{$1}; + } + } + close HEADER; +} + + +# Determine include directories; $Config{usrinc} should be enough for (all +# non-GCC?) C compilers, but gcc uses an additional include directory. +sub inc_dirs +{ + my $from_gcc = `$Config{cc} -v 2>&1`; + $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s; + + length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc}); +} + + 1; ############################################################################## @@ -409,7 +505,7 @@ h2ph - convert .h C header files to .ph Perl header files =head1 SYNOPSIS -B<h2ph [-d destination directory] [-r] [-l] [headerfiles]> +B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]> =head1 DESCRIPTION @@ -442,7 +538,15 @@ beneath the default Perl library location (C<$Config{'installsitsearch'}>). =item -r Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> -on all files in those directories (and their subdirectories, etc.). +on all files in those directories (and their subdirectories, etc.). B<-r> +and B<-a> are mutually exclusive. + +=item -a + +Run automagically; convert B<headerfiles>, as well as any B<.h> files +which they include. This option will search for B<.h> files in all +directories which your C compiler ordinarily uses. B<-a> and B<-r> are +mutually exclusive. =item -l @@ -463,6 +567,11 @@ you will see the slightly more helpful However, the B<.ph> files almost double in size when built using B<-h>. +=item -D + +Include the code from the B<.h> file as a comment in the B<.ph> file. +This is primarily used for debugging I<h2ph>. + =back =head1 ENVIRONMENT diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 800329103a..97d3ceded3 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -486,6 +486,7 @@ sub AUTOLOAD { my \$constname; (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); if (\$! != 0) { if (\$! =~ /Invalid/) { @@ -496,7 +497,7 @@ sub AUTOLOAD { croak "Your vendor has not defined $module macro \$constname"; } } - eval "sub \$AUTOLOAD { \$val }"; + *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 724df6b449..68ff2901d5 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -17,7 +17,7 @@ chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -open OUT,">$file" or die "Can't create $file: $!"; +open OUT, ">$file" or die "Can't create $file: $!"; # extract patchlevel.h information @@ -27,7 +27,7 @@ my $patchlevel_date = (stat PATCH_LEVEL)[9]; while (<PATCH_LEVEL>) { last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; -}; +} my @patches; while (<PATCH_LEVEL>) { @@ -37,11 +37,9 @@ while (<PATCH_LEVEL>) { s/"?,?$//; s/(['\\])/\\$1/g; 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; +} +my $patch_desc = "'" . join("',\n '", @patches) . "'"; +my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; close PATCH_LEVEL; @@ -65,7 +63,7 @@ my \$config_tag1 = '$] - $Config{cf_time}'; my \$patchlevel_date = $patchlevel_date; my \$patch_tags = '$patch_tags'; my \@patches = ( - $patch_desc + $patch_desc ); !GROK!THIS! @@ -75,21 +73,18 @@ print OUT <<'!NO!SUBS!'; use Config; use Getopt::Std; - -BEGIN { - eval "use Mail::Send;"; - $::HaveSend = ($@ eq ""); - eval "use Mail::Util;"; - $::HaveUtil = ($@ eq ""); -}; - - use strict; sub paraprint; +BEGIN { + eval "use Mail::Send;"; + $::HaveSend = ($@ eq ""); + eval "use Mail::Util;"; + $::HaveUtil = ($@ eq ""); +}; -my($Version) = "1.20"; +my $Version = "1.22"; # 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. @@ -114,33 +109,32 @@ my($Version) = "1.20"; # 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 +# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05 +# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10 # TODO: - Allow the user to re-name the file on mail failure, and -# make sure failure (transmission-wise) of Mail::Send is +# make sure failure (transmission-wise) of Mail::Send is # accounted for. # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, + $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; } - -if($::opt_d) { Dump(*STDOUT); exit; } - -if(!-t STDIN) { - paraprint <<EOF; -Please use perlbug interactively. If you want to +if ($::opt_h) { Help(); exit; } +if ($::opt_d) { Dump(*STDOUT); exit; } +if (!-t STDIN) { + paraprint <<EOF; +Please use perlbug interactively. If you want to include a file, you can use the -f switch. EOF - die "\n"; + die "\n"; } - -if(!-t STDOUT) { Dump(*STDOUT); exit; } +if (!-t STDOUT) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile; @@ -150,108 +144,114 @@ Send(); exit; sub Init { - - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - - getopts("dhva:s:b:f:r:e:SCc:to:"); - - - # This comment is needed to notify metaconfig that we are - # using the $perladmin, $cf_by, and $cf_time definitions. - - - # -------- Configuration --------- - - # perlbug address - $perlbug = 'perlbug@perl.com'; - - - # Test address - $testaddress = 'perlbug-test@perl.com'; - - # Target address - $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); - - # Users address, used in message and in Reply-To header - $from = $::opt_r || ""; - - # Include verbose configuration information - $verbose = $::opt_v || 0; - - # Subject of bug-report message - $subject = $::opt_s || ""; - - # Send a file - $usefile = ($::opt_f || 0); - - # File to send as report - $file = $::opt_f || ""; - - # Body of report - $body = $::opt_b || ""; - - # Editor - $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} || - ($Is_VMS ? "edit/tpu" : $Is_MSWin32 ? "notepad" : "vi") - ); - - # OK - send "OK" report for build on this system - $ok = 0; - if ( $::opt_o ) { - if ( $::opt_o eq 'k' or $::opt_o eq 'kay' ) { - my $age = time - $patchlevel_date; - if ( $::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { - my $date = localtime $patchlevel_date; - print <<"EOF"; -\"perlbug -ok\" does not report on Perl versions which are more than -60 days old. This Perl version was constructed on $date. -If you really want to report this, use \"perlbug -okay\". + # -------- Setup -------- + + $Is_MSWin32 = $^O eq 'MSWin32'; + $Is_VMS = $^O eq 'VMS'; + + getopts("dhva:s:b:f:r:e:SCc:to:n:"); + + # This comment is needed to notify metaconfig that we are + # using the $perladmin, $cf_by, and $cf_time definitions. + + # -------- Configuration --------- + + # perlbug address + $perlbug = 'perlbug@perl.com'; + + # Test address + $testaddress = 'perlbug-test@perl.com'; + + # Target address + $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); + + # Users address, used in message and in Reply-To header + $from = $::opt_r || ""; + + # Include verbose configuration information + $verbose = $::opt_v || 0; + + # Subject of bug-report message + $subject = $::opt_s || ""; + + # Send a file + $usefile = ($::opt_f || 0); + + # File to send as report + $file = $::opt_f || ""; + + # Body of report + $body = $::opt_b || ""; + + # Editor + $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} + || ($Is_VMS && "edit/tpu") + || ($Is_MSWin32 && "notepad") + || "vi"; + + # Not OK - provide build failure template by finessing OK report + if ($::opt_n) { + if (substr($::opt_n, 0, 2) eq 'ok' ) { + $::opt_o = substr($::opt_n, 1); + } else { + Help(); + exit(); + } + } + + # OK - send "OK" report for build on this system + $ok = 0; + if ($::opt_o) { + if ($::opt_o eq 'k' or $::opt_o eq 'kay') { + my $age = time - $patchlevel_date; + if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { + my $date = localtime $patchlevel_date; + print <<"EOF"; +"perlbug -ok" and "perlbug -nok" do not report on Perl versions which +are more than 60 days old. This Perl version was constructed on +$date. If you really want to report this, use +"perlbug -okay" or "perlbug -nokay". EOF - exit(); - }; - # force these options - $::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 $] ${patch_tags}on" - ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $::opt_b = 1; - $body = "Perl reported to build OK on this system.\n"; - $ok = 1; - } - else { - Help(); exit(); } + # force these options + unless ($::opt_n) { + $::opt_S = 1; # don't prompt for send + $::opt_b = 1; # we have a body + $body = "Perl reported to build OK on this system.\n"; + } + $::opt_C = 1; # don't send a copy to the local admin + $::opt_s = 1; # we have a subject line + $subject = ($::opt_n ? 'Not ' : '') + . "OK: perl $] ${patch_tags}on" + ." $::Config{'archname'} $::Config{'osvers'} $subject"; + $ok = 1; + } else { + Help(); + exit(); } - - # Possible administrator addresses, in order of confidence - # (Note that cf_email is not mentioned to metaconfig, since - # we don't really want it. We'll just take it if we have to.) - # - # This has to be after the $ok stuff above because of the way - # that $::opt_C is forced. - $cc = ($::opt_C ? "" : ( - $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by} - )); - - # My username - $me = ( $Is_MSWin32 - ? $ENV{'USERNAME'} - : ( $^O eq 'os2' - ? $ENV{'USER'} || $ENV{'LOGNAME'} - : eval { getpwuid($<) }) ); # May be missing - -} + } + # Possible administrator addresses, in order of confidence + # (Note that cf_email is not mentioned to metaconfig, since + # we don't really want it. We'll just take it if we have to.) + # + # This has to be after the $ok stuff above because of the way + # that $::opt_C is forced. + $cc = $::opt_C ? "" : ( + $::opt_c || $::Config{'perladmin'} + || $::Config{'cf_email'} || $::Config{'cf_by'} + ); + + # My username + $me = $Is_MSWin32 ? $ENV{'USERNAME'} + : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} + : eval { getpwuid($<) }; # May be missing +} # sub Init sub Query { - - # Explain what perlbug is - if ( ! $ok ) { + # Explain what perlbug is + unless ($ok) { paraprint <<EOF; This program provides an easy way to create a message reporting a bug in perl, and e-mail it to $address. It is *NOT* intended for @@ -263,156 +263,121 @@ and any solutions to such problems, to the people who maintain perl. If you're just looking for help with perl, try posting to the Usenet newsgroup comp.lang.perl.misc. If you're looking for help with using perl with CGI, try posting to comp.infosystems.www.programming.cgi. - EOF } - - # Prompt for subject of message, if needed - if(! $subject) { - paraprint <<EOF; -First of all, please provide a subject for the -message. It should be a concise description of + # Prompt for subject of message, if needed + unless ($subject) { + paraprint <<EOF; +First of all, please provide a subject for the +message. It should be a concise description of the bug or problem. "perl bug" or "perl problem" is not a concise description. - EOF - print "Subject: "; - - $subject = <>; - chop $subject; - - my($err)=0; - while( $subject =~ /^\s*$/ ) { - print "\nPlease enter a subject: "; - $subject = <>; - chop $subject; - if($err++>5) { - die "Aborting.\n"; - } - } + print "Subject: "; + $subject = <>; + + my $err = 0; + while ($subject !~ /\S/) { + print "\nPlease enter a subject: "; + $subject = <>; + if ($err++ > 5) { + die "Aborting.\n"; + } } - - - # Prompt for return address, if needed - if( !$from) { - - # Try and guess return address - my($domain); - - if($::HaveUtil) { - $domain = Mail::Util::maildomain(); - } elsif ($Is_MSWin32) { - $domain = $ENV{'USERDOMAIN'}; + chop $subject; + } + + # Prompt for return address, if needed + unless ($from) { + # Try and guess return address + my $guess; + + $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || ''; + unless ($guess) { + my $domain; + if ($::HaveUtil) { + $domain = Mail::Util::maildomain(); + } elsif ($Is_MSWin32) { + $domain = $ENV{'USERDOMAIN'}; + } else { + require Sys::Hostname; + $domain = Sys::Hostname::hostname(); + } + if ($domain) { + if ($Is_VMS && !$::Config{'d_socket'}) { + $guess = "$domain\:\:$me"; } else { - require Sys::Hostname; - $domain = Sys::Hostname::hostname(); + $guess = "$me\@$domain" if $domain; } - - my($guess); - - if( !$domain) { - $guess = ""; - } elsif ($Is_VMS && !$::Config{'d_socket'}) { - $guess = "$domain\:\:$me"; - } else { - $guess = "$me\@$domain" if $domain; - $guess = "$me\@unknown.addresss" unless $domain; - } - - $guess = $ENV{'REPLYTO'} if defined($ENV{'REPLYTO'}); - $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'}); - - if( $guess ) { - if ( ! $ok ) { - paraprint <<EOF; - + } + } + if ($guess) { + unless ($ok) { + paraprint <<EOF; Your e-mail address will be useful if you need to be contacted. If the default shown is not your full internet e-mail address, please correct it. - EOF - } - } else { - paraprint <<EOF; - -So that you may be contacted if necessary, please enter + } + } else { + paraprint <<EOF; +So that you may be contacted if necessary, please enter your full internet e-mail address here. - EOF - } - - if ( $ok && $guess ne '' ) { - # use it - $from = $guess; - } - else { - # verify it - print "Your address [$guess]: "; - - $from = <>; - chop $from; - - if($from eq "") { $from = $guess } - } - } - - #if( $from =~ /^(.*)\@(.*)$/ ) { - # $mailname = $1; - # $maildomain = $2; - #} - - if( $from eq $cc or $me eq $cc ) { - # Try not to copy ourselves - $cc = "yourself"; - } - - # Prompt for administrator address, unless an override was given - if( !$::opt_C and !$::opt_c ) { - paraprint <<EOF; + if ($ok && $guess) { + # use it + $from = $guess; + } else { + # verify it + print "Your address [$guess]: "; + $from = <>; + chop $from; + $from = $guess if $from eq ''; + } + } + if ($from eq $cc or $me eq $cc) { + # Try not to copy ourselves + $cc = "yourself"; + } + # Prompt for administrator address, unless an override was given + if( !$::opt_C and !$::opt_c ) { + paraprint <<EOF; A copy of this report can be sent to your local -perl administrator. If the address is wrong, please +perl administrator. If the address is wrong, please correct it, or enter 'none' or 'yourself' to not send a copy. - EOF + print "Local perl administrator [$cc]: "; + my $entry = scalar <>; + chop $entry; - print "Local perl administrator [$cc]: "; - - my($entry) = scalar(<>); - chop $entry; - - if($entry ne "") { - $cc = $entry; - if($me eq $cc) { $cc = "" } - } - + if ($entry ne "") { + $cc = $entry; + $cc = '' if $me eq $cc; } + } - if($cc =~ /^(none|yourself|me|myself|ourselves)$/i) { $cc = "" } - - $andcc = " and $cc" if $cc; + $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; + $andcc = " and $cc" if $cc; + # Prompt for editor, if no override is given editor: - - # Prompt for editor, if no override is given - if(! $::opt_e and ! $::opt_f and ! $::opt_b) { - paraprint <<EOF; - - + unless ($::opt_e || $::opt_f || $::opt_b) { + paraprint <<EOF; Now you need to supply the bug report. Try to make -the report concise but descriptive. Include any +the report concise but descriptive. Include any relevant detail. If you are reporting something that does not work as you think it should, please -try to include example of both the actual +try to include example of both the actual result, and what you expected. Some information about your local -perl configuration will automatically be included +perl configuration will automatically be included at the end of the report. If you are using any unusual version of perl, please try and confirm exactly which versions are relevant. @@ -424,96 +389,71 @@ the name of the editor you would like to use. If you would like to use a prepared file, type "file", and you will be asked for the filename. - EOF - - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - $usefile = 0; - if($entry eq "file") { - $usefile = 1; - } elsif($entry ne "") { - $ed = $entry; - } + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + + $usefile = 0; + if ($entry eq "file") { + $usefile = 1; + } elsif ($entry ne "") { + $ed = $entry; } + } + # Generate scratch file to edit report in + $filename = filename(); - # Generate scratch file to edit report in - - { - my($dir) = ($Is_VMS ? 'sys$scratch:' : - (($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} : '/tmp/')); - $filename = "bugrep0$$"; - $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; - $filename++ while -e "$dir$filename"; - $filename = "$dir$filename"; - } - - - # Prompt for file to read report from, if needed - - if( $usefile and ! $file) { + # Prompt for file to read report from, if needed + if ($usefile and !$file) { filename: - paraprint <<EOF; - + paraprint <<EOF; What is the name of the file that contains your report? - EOF + print "Filename: "; + my $entry = scalar <>; + chop $entry; - print "Filename: "; - - my($entry) = scalar(<>); - chop($entry); - - if($entry eq "") { - paraprint <<EOF; - -No filename? I'll let you go back and choose an editor again. - + if ($entry eq "") { + paraprint <<EOF; +No filename? I'll let you go back and choose an editor again. EOF - goto editor; - } - - if(!-f $entry or !-r $entry) { - paraprint <<EOF; - + goto editor; + } + + unless (-f $entry and -r $entry) { + paraprint <<EOF; I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of the file? If you don't want to send a file, just enter a blank line and you can get back to the editor selection. - EOF - goto filename; - } - $file = $entry; - + goto filename; } + $file = $entry; + } + # Generate report + open(REP,">$filename"); + my $reptype = $ok ? "build failure" : "bug"; - # Generate report - - open(REP,">$filename"); - - my $reptype = $ok ? "success" : "bug"; - - print REP <<EOF; + print REP <<EOF; This is a $reptype report for perl from $from, generated with the help of perlbug $Version running under perl $]. EOF - if($body) { - print REP $body; - } elsif($usefile) { - open(F,"<$file") or die "Unable to read report file from `$file': $!\n"; - while(<F>) { - print REP $_ - } - close(F); - } else { - print REP <<EOF; + if ($body) { + print REP $body; + } elsif ($usefile) { + open(F, "<$file") + or die "Unable to read report file from `$file': $!\n"; + while (<F>) { + print REP $_ + } + close(F); + } else { + print REP <<EOF; ----------------------------------------------------------------- [Please enter your report here] @@ -523,164 +463,138 @@ EOF [Please do not change anything below this line] ----------------------------------------------------------------- EOF - } - - Dump(*REP); - close(REP); - - # read in the report template once so that - # we can track whether the user does any editing. - # yes, *all* whitespace is ignored. - open(REP, "<$filename"); - while (<REP>) { - s/\s+//g; - $REP{$_}++; - } - close(REP); - -} + } + Dump(*REP); + close(REP); + + # read in the report template once so that + # we can track whether the user does any editing. + # yes, *all* whitespace is ignored. + open(REP, "<$filename"); + while (<REP>) { + s/\s+//g; + $REP{$_}++; + } + close(REP); +} # sub Query sub Dump { - local(*OUT) = @_; - - print REP "\n---\n"; + local(*OUT) = @_; - 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 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; + print OUT <<EOF; Site configuration information for perl $]: EOF + if ($::Config{cf_by} and $::Config{cf_time}) { + print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; + } + print OUT Config::myconfig; - if( $::Config{cf_by} and $::Config{cf_time}) { - print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; - } - - print OUT Config::myconfig; - - if (@patches) { - print OUT join "\n\t", "Locally applied patches:", @patches; - print OUT "\n"; - }; + if (@patches) { + print OUT join "\n ", "Locally applied patches:", @patches; + print OUT "\n"; + }; - print OUT <<EOF; + print OUT <<EOF; --- \@INC for perl $]: EOF - for my $i (@INC) { - print OUT "\t$i\n"; - } + for my $i (@INC) { + print OUT " $i\n"; + } - print OUT <<EOF; + print OUT <<EOF; --- Environment for perl $]: EOF - for my $env (sort - (qw(PATH LD_LIBRARY_PATH - LANG PERL_BADLANG - SHELL HOME LOGDIR), - grep { /^(?:PERL|LC_)/ } keys %ENV)) { - print OUT " $env", - exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', - "\n"; - } - if($verbose) { - print OUT "\nComplete configuration data for perl $]:\n\n"; - my($value); - foreach (sort keys %::Config) { - $value = $::Config{$_}; - $value =~ s/'/\\'/g; - print OUT "$_='$value'\n"; - } + for my $env (sort + (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR), + grep /^(?:PERL|LC_)/, keys %ENV) + ) { + print OUT " $env", + exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', + "\n"; + } + if ($verbose) { + print OUT "\nComplete configuration data for perl $]:\n\n"; + my $value; + foreach (sort keys %::Config) { + $value = $::Config{$_}; + $value =~ s/'/\\'/g; + print OUT "$_='$value'\n"; } -} + } +} # sub Dump sub Edit { - # Edit the report - - if($usefile) { - $usefile = 0; - paraprint <<EOF; - + # Edit the report + if ($usefile || $body) { + paraprint <<EOF; Please make sure that the name of the editor you want to use is correct. - EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - } - } - -tryagain: - if(!$usefile and !$body) { - my $sts = system("$ed $filename"); - if($sts) { - #print "\nUnable to run editor!\n"; - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + $ed = $entry unless $entry eq ''; + } +tryagain: + my $sts = system("$ed $filename"); + if ($sts) { + paraprint <<EOF; The editor you chose (`$ed') could apparently not be run! Did you mistype the name of your editor? If so, please -correct it here, otherwise just press Enter. - +correct it here, otherwise just press Enter. EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - goto tryagain; - } else { - - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + if ($entry ne "") { + $ed = $entry; + goto tryagain; + } else { + paraprint <<EOF; You may want to save your report to a file, so you can edit and mail it yourself. EOF - } - } - } - - return if $ok; - # Check that we have a report that has some, eh, report in it. - - my $unseen = 0; - - open(REP, "<$filename"); - # a strange way to check whether any significant editing - # have been done: check whether any new non-empty lines - # have been added. Yes, the below code ignores *any* space - # in *any* line. - while (<REP>) { - s/\s+//g; - $unseen++ if ($_ ne '' and not exists $REP{$_}); } + } - while ($unseen == 0) { - paraprint <<EOF; + return if ($ok and not $::opt_n) || $body; + # Check that we have a report that has some, eh, report in it. + my $unseen = 0; + + open(REP, "<$filename"); + # a strange way to check whether any significant editing + # have been done: check whether any new non-empty lines + # have been added. Yes, the below code ignores *any* space + # in *any* line. + while (<REP>) { + s/\s+//g; + $unseen++ if $_ ne '' and not exists $REP{$_}; + } + while ($unseen == 0) { + paraprint <<EOF; I am sorry but it looks like you did not report anything. - EOF - print "Action (Retry Edit/Cancel) "; - my ($action) = scalar(<>); - if ($action =~ /^[re]/i) { # <R>etry <E>dit - goto tryagain; - } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit - Cancel(); - } - } - -} + print "Action (Retry Edit/Cancel) "; + my ($action) = scalar(<>); + if ($action =~ /^[re]/i) { # <R>etry <E>dit + goto tryagain; + } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit + Cancel(); + } + } +} # sub Edit sub Cancel { 1 while unlink($filename); # remove all versions under VMS @@ -689,227 +603,211 @@ sub Cancel { } sub NowWhat { - - # Report is done, prompt for further action - if( !$::opt_S ) { - while(1) { - - paraprint <<EOF; - - -Now that you have completed your report, would you like to send -the message to $address$andcc, display the message on + # Report is done, prompt for further action + if( !$::opt_S ) { + while(1) { + paraprint <<EOF; +Now that you have completed your report, would you like to send +the message to $address$andcc, display the message on the screen, re-edit it, or cancel without sending anything? You may also save the message as a file to mail at another time. - EOF - - print "Action (Send/Display/Edit/Cancel/Save to File): "; - my($action) = scalar(<>); - chop $action; - - if( $action =~ /^(f|sa)/i ) { # <F>ile/<Sa>ve - print "\n\nName of file to save message in [perlbug.rep]: "; - my($file) = scalar(<>); - chop $file; - if($file eq "") { $file = "perlbug.rep" } - - open(FILE,">$file"); - open(REP,"<$filename"); - print FILE "To: $address\nSubject: $subject\n"; - print FILE "Cc: $cc\n" if $cc; - print FILE "Reply-To: $from\n" if $from; - print FILE "\n"; - while(<REP>) { print FILE } - close(REP); - close(FILE); - - print "\nMessage saved in `$file'.\n"; - exit; - - } elsif( $action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow - # Display the message - open(REP,"<$filename"); - while(<REP>) { print $_ } - close(REP); - } elsif( $action =~ /^se/i ) { # <S>end - # Send the message - print "\ -Are you certain you want to send this message? -Please type \"yes\" if you are: "; - my($reply) = scalar(<STDIN>); - chop($reply); - if( $reply eq "yes" ) { - last; - } else { - paraprint <<EOF; - + print "Action (Send/Display/Edit/Cancel/Save to File): "; + my $action = scalar <>; + chop $action; + + if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve + print "\n\nName of file to save message in [perlbug.rep]: "; + my $file = scalar <>; + chop $file; + $file = "perlbug.rep" if $file eq ""; + + open(FILE, ">$file"); + open(REP, "<$filename"); + print FILE "To: $address\nSubject: $subject\n"; + print FILE "Cc: $cc\n" if $cc; + print FILE "Reply-To: $from\n" if $from; + print FILE "\n"; + while (<REP>) { print FILE } + close(REP); + close(FILE); + + print "\nMessage saved in `$file'.\n"; + exit; + } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow + # Display the message + open(REP, "<$filename"); + while (<REP>) { print $_ } + close(REP); + } elsif ($action =~ /^se/i) { # <S>end + # Send the message + print "Are you certain you want to send this message?\n" + . 'Please type "yes" if you are: '; + my $reply = scalar <STDIN>; + chop $reply; + if ($reply eq "yes") { + last; + } else { + paraprint <<EOF; That wasn't a clear "yes", so I won't send your message. If you are sure your message should be sent, type in "yes" (without the quotes) at the confirmation prompt. - EOF - - } - } elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit - # edit the message - Edit(); - #system("$ed $filename"); - } elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit - Cancel(); - } elsif( $action =~ /^s/ ) { - paraprint <<EOF; - + } + } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit + # edit the message + Edit(); + } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit + Cancel(); + } elsif ($action =~ /^s/) { + paraprint <<EOF; I'm sorry, but I didn't understand that. Please type "send" or "save". EOF - } - - } + } } -} - + } +} # sub NowWhat sub Send { + # Message has been accepted for transmission -- Send the message + if ($::HaveSend) { + $msg = new Mail::Send Subject => $subject, To => $address; + $msg->cc($cc) if $cc; + $msg->add("Reply-To",$from) if $from; + + $fh = $msg->open; + open(REP, "<$filename"); + while (<REP>) { print $fh $_ } + close(REP); + $fh->close; + + print "\nMessage sent.\n"; + } elsif ($Is_VMS) { + if ( ($address =~ /@/ and $address !~ /^\w+%"/) or + ($cc =~ /@/ and $cc !~ /^\w+%"/) ) { + my $prefix; + foreach (qw[ IN MX SMTP UCX PONY WINS ], '') { + $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"}; + } + $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; + $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; + } + $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; + my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); + if ($sts) { + die <<EOF; +Can't spawn off mail + (leaving bug report in $filename): $sts +EOF + } + } else { + my $sendmail = ""; + for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { + $sendmail = $_, last if -e $_; + } + if ($^O eq 'os2' and $sendmail eq "") { + my $path = $ENV{PATH}; + $path =~ s:\\:/: ; + my @path = split /$Config{'path_sep'}/, $path; + for (@path) { + $sendmail = "$_/sendmail", last if -e "$_/sendmail"; + $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; + } + } - # Message has been accepted for transmission -- Send the message - - if($::HaveSend) { - - $msg = new Mail::Send Subject => $subject, To => $address; - - $msg->cc($cc) if $cc; - $msg->add("Reply-To",$from) if $from; - - $fh = $msg->open; - - open(REP,"<$filename"); - while(<REP>) { print $fh $_ } - close(REP); - - $fh->close; - - print "\nMessage sent.\n"; - } else { - if ($Is_VMS) { - if ( ($address =~ /@/ and $address !~ /^\w+%"/) or - ($cc =~ /@/ and $cc !~ /^\w+%"/) ){ - my($prefix); - foreach (qw[ IN MX SMTP UCX PONY WINS ],'') { - $prefix = "$_%",last if $ENV{"MAIL\$PROTOCOL_$_"}; - } - $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; - $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; - } - $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; - my($sts) = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); - if ($sts) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" } - } else { - my($sendmail) = ""; - - foreach (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) - { - $sendmail = $_, last if -e $_; - } - - if ($^O eq 'os2' and $sendmail eq "") { - my $path = $ENV{PATH}; - $path =~ s:\\:/: ; - my @path = split /$Config{path_sep}/, $path; - for (@path) { - $sendmail = "$_/sendmail", last - if -e "$_/sendmail"; - $sendmail = "$_/sendmail.exe", last - if -e "$_/sendmail.exe"; - } - } - - paraprint(<<"EOF"), die "\n" if $sendmail eq ""; - + paraprint(<<"EOF"), die "\n" if $sendmail eq ""; I am terribly sorry, but I cannot find sendmail, or a close equivalent, and the perl package Mail::Send has not been installed, so I can't send your bug report. We apologize for the inconvenience. So you may attempt to find some way of sending your message, it has been left in the file `$filename'. - EOF - - open(SENDMAIL,"|$sendmail -t") || die "'|$sendmail -t' failed: $|"; - print SENDMAIL "To: $address\n"; - print SENDMAIL "Subject: $subject\n"; - print SENDMAIL "Cc: $cc\n" if $cc; - print SENDMAIL "Reply-To: $from\n" if $from; - print SENDMAIL "\n\n"; - open(REP,"<$filename"); - while(<REP>) { print SENDMAIL $_ } - close(REP); - - if (close(SENDMAIL)) { - print "\nMessage sent.\n"; - } else { - warn "\nSendmail returned status '",$?>>8,"'\n"; - } - } - - } - - 1 while unlink($filename); # remove all versions under VMS + open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!"; + print SENDMAIL "To: $address\n"; + print SENDMAIL "Subject: $subject\n"; + print SENDMAIL "Cc: $cc\n" if $cc; + print SENDMAIL "Reply-To: $from\n" if $from; + print SENDMAIL "\n\n"; + open(REP, "<$filename"); + while (<REP>) { print SENDMAIL $_ } + close(REP); -} + if (close(SENDMAIL)) { + print "\nMessage sent.\n"; + } else { + warn "\nSendmail returned status '", $? >> 8, "'\n"; + } + } + 1 while unlink($filename); # remove all versions under VMS +} # sub Send sub Help { - print <<EOF; + print <<EOF; -A program to help generate bug reports about perl5, and mail them. +A program to help generate bug reports about perl5, and mail them. It is designed to be used interactively. Normally no arguments will be needed. - + Usage: $0 [-v] [-a address] [-s subject] [-b body | -f file ] [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] - +$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay] + Simplest usage: run "$0", and follow the prompts. Options: -v Include Verbose configuration data in the report - -f File containing the body of the report. Use this to + -f File containing the body of the report. Use this to quickly send a prepared message. -S Send without asking for confirmation. -a Address to send the report to. Defaults to `$address'. -c Address to send copy of report to. Defaults to `$cc'. -C Don't send copy to administrator. - -s Subject to include with the message. You will be prompted + -s Subject to include with the message. You will be prompted if you don't supply one on the command line. -b Body of the report. If not included on the command line, or in a file with -f, you will get a chance to edit the message. -r Your return address. The program will ask you to confirm this if you don't give it here. - -e Editor to use. + -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) + -d Data mode (the default if you redirect or pipe output.) 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). Only use -ok if *everything* was ok. - If there were *any* problems at all then don't use -ok. + (use alone or with -v). Only use -ok if *everything* was ok: + if there were *any* problems at all, use -nok. -okay As -ok but allow report from old builds. - -h Print this help message. - + -nok Report unsuccessful build on this system to perl porters + (use alone or with -v). You must describe what went wrong + in the body of the report which you will be asked to edit. + -nokay As -nok but allow report from old builds. + -h Print this help message. + EOF } +sub filename { + my $dir = $Is_VMS ? 'sys$scratch:' + : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} + : '/tmp/'; + $filename = "bugrep0$$"; + $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; + $filename++ while -e "$dir$filename"; + $filename = "$dir$filename"; +} + sub paraprint { my @paragraphs = split /\n{2,}/, "@_"; print "\n\n"; for (@paragraphs) { # implicit local $_ - s/(\S)\s*\n/$1 /g; - write; - print "\n"; + s/(\S)\s*\n/$1 /g; + write; + print "\n"; } - } - format STDOUT = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ @@ -929,12 +827,13 @@ S<[ B<-b> I<body> | B<-f> I<file> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> -B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-ok> | B<okay> ]> +B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> +S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that -come with it, and mail them. +come with it, and mail them. If you have found a bug with a non-standard port (one that was not part of the I<standard distribution>), a binary distribution, or a @@ -1073,7 +972,7 @@ with B<-v> to get more complete data. =item B<-e> -Editor to use. +Editor to use. =item B<-f> @@ -1097,6 +996,21 @@ system is less than 60 days old. As B<-ok> except it will report on older systems. +=item B<-nok> + +Report unsuccessful build on this system. Forces B<-C>. Forces and +supplies a value for B<-s>, then requires you to edit the report +and say what went wrong. Alternatively, a prepared report may be +supplied using B<-f>. Only prompts for a return address if it +cannot guess it (for use with B<make>). Honors return address +specified with B<-r>. You can use this with B<-v> to get more +complete data. Only makes a report if this system is less than 60 +days old. + +=item B<-nokay> + +As B<-nok> except it will report on older systems. + =item B<-r> Your return address. The program will ask you to confirm its default @@ -1126,8 +1040,9 @@ Include verbose configuration data in the report. Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>), -Charles F. Randall (E<lt>cfr@pobox.comE<gt>) and -Mike Guy (E<lt>mjtg@cam.a.ukE<gt>). +Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy +(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>) +and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>). =head1 SEE ALSO diff --git a/utils/perlcc.PL b/utils/perlcc.PL new file mode 100644 index 0000000000..af7488f484 --- /dev/null +++ b/utils/perlcc.PL @@ -0,0 +1,935 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. +# Wanted: $archlibexp + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +use Config; +use strict; +use FileHandle; +use File::Basename qw(&basename &dirname); + +use Getopt::Long; + +$Getopt::Long::bundling_override = 1; +$Getopt::Long::passthrough = 0; +$Getopt::Long::ignore_case = 0; + +my $options = {}; +my $_fh; + +main(); + +sub main +{ + + GetOptions + ( + $options, "L:s", + "I:s", + "C:s", + "o:s", + "e:s", + "regex:s", + "verbose:s", + "log:s", + "argv:s", + "gen", + "sav", + "run", + "prog", + "mod" + ); + + + my $key; + + local($") = "|"; + + _usage() if (!_checkopts()); + push(@ARGV, _maketempfile()) if ($options->{'e'}); + + _usage() if (!@ARGV); + + my $file; + foreach $file (@ARGV) + { + _print(" +-------------------------------------------------------------------------------- +Compiling $file: +-------------------------------------------------------------------------------- +", 36 ); + _doit($file); + } +} + +sub _doit +{ + my ($file) = @_; + + my ($program_ext, $module_ext) = _getRegexps(); + my ($obj, $objfile, $so, $type); + + if ( + (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext")) + || (defined($options->{'prog'}) || defined($options->{'run'})) + ) + { + $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c"; + $type = 'program'; + + $obj = ($options->{'o'})? $options->{'o'} : + _getExecutable( $file,$program_ext); + + return() if (!$obj); + + } + elsif (($file =~ m"@$module_ext") || ($options->{'mod'})) + { + die "Shared objects are not supported on Win32 yet!!!!\n" + if ($Config{'osname'} eq 'MSWin32'); + + $obj = ($options->{'o'})? $options->{'o'} : + _getExecutable($file, $module_ext); + $so = "$obj.so"; + $type = 'sharedlib'; + return() if (!$obj); + } + else + { + _error("noextension", $file, $program_ext, $module_ext); + return(); + } + + if ($type eq 'program') + { + _print("Making C($objfile) for $file!\n", 36 ); + + my $errcode = _createCode($objfile, $file); + (_print( "ERROR: In generating code for $file!\n", -1), return()) + if ($errcode); + + _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'}); + my $errcode = _compileCode($file, $objfile, $obj) + if (!$options->{'gen'}); + + if ($errcode) + { + _print( "ERROR: In compiling code for $objfile !\n", -1); + my $ofile = File::Basename::basename($objfile); + $ofile =~ s"\.c$"\.o"s; + + _removeCode("$ofile"); + return() + } + + _runCode($obj) if ($options->{'run'}); + + _removeCode($objfile) if (!$options->{'sav'} || + ($options->{'e'} && !$options->{'C'})); + + _removeCode($file) if ($options->{'e'}); + + _removeCode($obj) if (($options->{'e'} && + ((!$options->{'sav'}) || !$options->{'o'})) || + ($options->{'run'} && (!$options->{'sav'}))); + } + else + { + _print( "Making C($objfile) for $file!\n", 36 ); + my $errcode = _createCode($objfile, $file, $obj); + (_print( "ERROR: In generating code for $file!\n", -1), return()) + if ($errcode); + + _print( "Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'}); + + my $errorcode = + _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'}); + + (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) + if ($errcode); + } +} + +sub _getExecutable +{ + my ($sourceprog, $ext) = @_; + my ($obj); + + if (defined($options->{'regex'})) + { + eval("(\$obj = \$sourceprog) =~ $options->{'regex'}"); + return(0) if (_error('badeval', $@)); + return(0) if (_error('equal', $obj, $sourceprog)); + } + elsif (defined ($options->{'ext'})) + { + ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g; + return(0) if (_error('equal', $obj, $sourceprog)); + } + elsif (defined ($options->{'run'})) + { + $obj = "perlc$$"; + } + else + { + ($obj = $sourceprog) =~ s"@$ext""g; + return(0) if (_error('equal', $obj, $sourceprog)); + } + return($obj); +} + +sub _createCode +{ + my ( $generated_cfile, $file, $final_output ) = @_; + my $return; + + local($") = " -I"; + + if (@_ == 2) # compiling a program + { + _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36); + $return = _run("$ -I@INC -MO=CC,-o$generated_cfile $file", 9); + $return; + } + else # compiling a shared object + { + _print( + "$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file\n", 36); + $return = + _run("$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file", 9); + $return; + } +} + +sub _compileCode +{ + my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_; + my @return; + + if (@_ == 3) # just compiling a program + { + $return[0] = + _ccharness($sourceprog, "-o", $output_executable, $generated_cfile); + $return[0]; + } + else + { + my $object_file = $generated_cfile; + $object_file =~ s"\.c$"\.o"; + + $return[0] = _ccharness($sourceprog, "-c", $generated_cfile); + $return[1] = _ccharness + ( + $sourceprog, "-shared","-o", + $shared_object, $object_file + ); + return(1) if (grep ($_, @return)); + return(0); + } +} + +sub _runCode +{ + my ($executable) = @_; + _print("$executable $options->{'argv'}\n", 36); + _run("$executable $options->{'argv'}", -1 ); +} + +sub _removeCode +{ + my ($file) = @_; + unlink($file) if (-e $file); +} + +sub _ccharness +{ + my (@args) = @_; + local($") = " "; + + my $sourceprog = shift(@args); + my ($libdir, $incdir); + + if (-d "$Config{installarchlib}/CORE") + { + $libdir = "-L$Config{installarchlib}/CORE"; + $incdir = "-I$Config{installarchlib}/CORE"; + } + else + { + $libdir = "-L.."; + $incdir = "-I.."; + } + + $libdir .= " -L$options->{L}" if (defined($options->{L})); + $incdir .= " -I$options->{L}" if (defined($options->{L})); + + my $linkargs; + + if (!grep(/^-[cS]$/, @ARGV)) + { + $linkargs = sprintf("%s $libdir -lperl %s",@Config{qw(ldflags libs)}); + } + + my @sharedobjects = _getSharedObjects($sourceprog); + + my $cccmd = + "$Config{cc} $Config{ccflags} $incdir @sharedobjects @args $linkargs"; + + + _print ("$cccmd\n", 36); + _run("$cccmd", 18 ); +} + +sub _getSharedObjects +{ + my ($sourceprog) = @_; + my ($tmpfile, $incfile); + my (@return); + local($") = " -I"; + + if ($Config{'osname'} eq 'MSWin32') + { + # _addstuff; + } + else + { + my ($tmpprog); + ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; + $tmpfile = "/tmp/$tmpprog.tst"; + $incfile = "/tmp/$tmpprog.val"; + } + + my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n"; + my $fd2 = + new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n"; + + my $perl = <$fd2>; # strip off header; + + print $fd +<<"EOF"; + use FileHandle; + my \$fh3 = new FileHandle("> $incfile") + || die "Couldn't open $incfile\\n"; + + my \$key; + foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; } + close(\$fh3); + exit(); +EOF + + print $fd ( <$fd2> ); + close($fd); + + _print("$ -I@INC $tmpfile\n", 36); + _run("$ -I@INC $tmpfile", 9 ); + + my $fd = new FileHandle ("$incfile"); + my @lines = <$fd>; + + unlink($tmpfile); + unlink($incfile); + + my $line; + my $autolib; + + foreach $line (@lines) + { + chomp($line); + my ($modname, $modpath) = split(':', $line); + my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)"); + + if ($autolib = _lookforAuto($dir, $file)) + { + push(@return, $autolib); + } + } + + return(@return); +} + +sub _maketempfile +{ + my $return; + +# if ($Config{'osname'} eq 'MSWin32') +# { $return = "C:\\TEMP\\comp$$.p"; } +# else +# { $return = "/tmp/comp$$.p"; } + + $return = "comp$$.p"; + + my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n"; + print $fd $options->{'e'}; + close($fd); + + return($return); +} + + +sub _lookforAuto +{ + my ($dir, $file) = @_; + + my $relshared; + my $return; + + ($relshared = $file) =~ s"(.*)\.pm"$1"; + + my ($tmp, $modname) = ($relshared =~ m"(?:(.*)[\\/]){0,1}(.*)"s); + + $relshared .= + ($Config{'osname'} eq 'MSWin32')? "\\$modname.dll" : "/$modname.so"; + + + + if (-e ($return = "$Config{'installarchlib'}/auto/$relshared") ) + { + return($return); + } + elsif (-e ($return = "$Config{'installsitearch'}/auto/$relshared")) + { + return($return); + } + elsif (-e ($return = "$dir/arch/auto/$relshared")) + { + return($return); + } + else + { + return(undef); + } +} + +sub _getRegexps # make the appropriate regexps for making executables, +{ # shared libs + + my ($program_ext, $module_ext) = ([],[]); + + + @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) : + ('.p$', '.pl$', '.bat$'); + + + @$module_ext = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) : + ('.pm$'); + + + _mungeRegexp( $program_ext ); + _mungeRegexp( $module_ext ); + + return($program_ext, $module_ext); +} + +sub _mungeRegexp +{ + my ($regexp) = @_; + + grep(s"(^|[^\\])\."$1\x0\\."g, @$regexp); + grep(s"(^|[^\x0])\\\."$1\."g, @$regexp); + grep(s"\x0""g, @$regexp); +} + + +sub _error +{ + my ($type, @args) = @_; + + if ($type eq 'equal') + { + + if ($args[0] eq $args[1]) + { + _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1); + return(1); + } + } + elsif ($type eq 'badeval') + { + if ($args[0]) + { + _print ("ERROR: $args[0]\n", -1); + return(1); + } + } + elsif ($type eq 'noextension') + { + my $progext = join(',', @{$args[1]}); + my $modext = join(',', @{$args[2]}); + + $progext =~ s"\\""g; + $modext =~ s"\\""g; + + $progext =~ s"\$""g; + $modext =~ s"\$""g; + + _print + ( +" +ERROR: '$args[0]' does not have a proper extension! Proper extensions are: + + PROGRAM: $progext + SHARED OBJECT: $modext + +Use the '-prog' flag to force your files to be interpreted as programs. +Use the '-mod' flag to force your files to be interpreted as modules. +", -1 + ); + return(1); + } + + return(0); +} + +sub _checkopts +{ + my @errors; + local($") = "\n"; + + if ($options->{'log'}) + { + $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n"); + } + + if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} )) + { + push(@errors, +"ERROR: The '-sav' and '-C' options are incompatible when you have more than + one input file! ('-C' explicitly names resulting C code, '-sav' saves it, + and hence, with more than one file, the c code will be overwritten for + each file that you compile)\n"); + } + if (($options->{'o'}) && (@ARGV > 1)) + { + push(@errors, +"ERROR: The '-o' option is incompatible when you have more than one input file! + (-o explicitly names the resulting executable, hence, with more than + one file the names clash)\n"); + } + + if ($options->{'e'} && $options->{'sav'} && !$options->{'o'} && + !$options->{'C'}) + { + push(@errors, +"ERROR: You need to specify where you are going to save the resulting + executable or C code, when using '-sav' and '-e'. Use '-o' or '-C'.\n"); + } + + if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) + && $options->{'gen'}) + { + push(@errors, +"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. + '-gen' says to stop at C generation, and the other three modify the + compilation and/or running process!\n"); + } + + if ($options->{'run'} && $options->{'mod'}) + { + push(@errors, +"ERROR: Can't run modules that you are compiling! '-run' and '-mod' are + incompatible!\n"); + } + + if ($options->{'e'} && @ARGV) + { + push (@errors, +"ERROR: The option '-e' needs to be all by itself without any other + file arguments!\n"); + } + if ($options->{'e'} && !($options->{'o'} || $options->{'run'})) + { + $options->{'run'} = 1; + } + + if (!defined($options->{'verbose'})) + { + $options->{'verbose'} = ($options->{'log'})? 64 : 7; + } + + my $verbose_error; + + if ($options->{'verbose'} =~ m"[^tagfcd]" && + !( $options->{'verbose'} eq '0' || + ($options->{'verbose'} < 64 && $options->{'verbose'} > 0))) + { + $verbose_error = 1; + push(@errors, +"ERROR: Illegal verbosity level. Needs to have either the letters + 't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n"); + } + + $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")? + ($options->{'verbose'} =~ m"d") * 32 + + ($options->{'verbose'} =~ m"c") * 16 + + ($options->{'verbose'} =~ m"f") * 8 + + ($options->{'verbose'} =~ m"t") * 4 + + ($options->{'verbose'} =~ m"a") * 2 + + ($options->{'verbose'} =~ m"g") * 1 + : $options->{'verbose'}; + + if (!$verbose_error && ( $options->{'log'} && + !( + ($options->{'verbose'} & 8) || + ($options->{'verbose'} & 16) || + ($options->{'verbose'} & 32 ) + ) + ) + ) + { + push(@errors, +"ERROR: The verbosity level '$options->{'verbose'}' does not output anything + to a logfile, and you specified '-log'!\n"); + } # } + + if (!$verbose_error && ( !$options->{'log'} && + ( + ($options->{'verbose'} & 8) || + ($options->{'verbose'} & 16) || + ($options->{'verbose'} & 32) || + ($options->{'verbose'} & 64) + ) + ) + ) + { + push(@errors, +"ERROR: The verbosity level '$options->{'verbose'}' requires that you also + specify a logfile via '-log'\n"); + } # } + + + (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors); + return(1); +} + +sub _print +{ + my ($text, $flag ) = @_; + + my $logflag = int($flag/8) * 8; + my $regflag = $flag % 8; + + if ($flag == -1 || ($flag & $options->{'verbose'})) + { + my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1) + && $options->{'log'}); + + my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); + + if ($doreg) { print( STDERR $text ); } + if ($dolog) { print $_fh $text; } + } +} + +sub _run +{ + my ($command, $flag) = @_; + + my $logflag = ($flag != -1)? int($flag/8) * 8 : 0; + my $regflag = $flag % 8; + + if ($flag == -1 || ($flag & $options->{'verbose'})) + { + my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'}); + my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); + + if ($doreg && !$dolog) + { system("$command"); } + + elsif ($doreg && $dolog) + { my $text = `$command 2>&1`; print $_fh $text; print STDERR $text;} + else + { my $text = `$command 2>&1`; print $_fh $text; } + } + else + { + `$command 2>&1`; + } + return($?); +} + +sub _usage +{ + _print + ( + <<"EOF" + +Usage: $0 <file_list> + + Flags with arguments + -L < extra library dirs for installation (form of 'dir1:dir2') > + -I < extra include dirs for installation (form of 'dir1:dir2') > + -C < explicit name of resulting C code > + -o < explicit name of resulting executable > + -e < to compile 'one liners'. Need executable name (-o) or '-run'> + -regex < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe > + -verbose < verbose level (1-63, or following letters 'gatfcd' > + -argv < arguments for the executables to be run via '-run' or '-e' > + + Boolean flags + -gen ( to just generate the c code. Implies '-sav' ) + -sav ( to save intermediate c code, (and executables with '-run')) + -run ( to run the compiled program on the fly, as were interpreted.) + -prog ( to indicate that the files on command line are programs ) + -mod ( to indicate that the files on command line are modules ) + +EOF +, -1 + + ); + exit(255); +} + + +__END__ + +=head1 NAME + +perlcc - frontend for perl compiler + +=head1 SYNOPSIS + + %prompt perlcc a.p # compiles into executable 'a' + + %prompt perlcc A.pm # compile into 'A.so' + + %prompt perlcc a.p -o execute # compiles 'a.p' into 'execute'. + + %prompt perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on + # the fly + + %prompt perlcc a.p -o execute -run -argv 'arg1 arg2 arg3' + # compiles into execute, runs with + # arg1 arg2 arg3 as @ARGV + + %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe' + # compiles into 'a.exe','b.exe','c.exe'. + + %prompt perlcc a.p -log compilelog # compiles into 'a', saves compilation + # info into compilelog, as well + # as mirroring to screen + + %prompt perlcc a.p -log compilelog -verbose cdf + # compiles into 'a', saves compilation + # info into compilelog, being silent + # on screen. + + %prompt perlcc a.p -C a.c -gen # generates C code (into a.c) and + # stops without compile. + + %prompt perlcc a.p -L ../lib a.c + # Compiles with the perl libraries + # inside ../lib included. + +=head1 DESCRIPTION + +'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p' +compiles the code inside a.p into a standalone executable, and +perlcc A.pm will compile into a shared object, A.so, suitable for inclusion +into a perl program via "use A". + +There are quite a few flags to perlcc which help with such issues as compiling +programs in bulk, testing compiled programs for compatibility with the +interpreter, and controlling. + +=head1 OPTIONS + +=over 4 + +=item -L < library_directories > + +Adds directories in B<library_directories> to the compilation command. + +=item -I < include_directories > + +Adds directories inside B<include_directories> to the compilation command. + +=item -C < c_code_name > + +Explicitly gives the name B<c_code_name> to the generated c code which is to +be compiled. Can only be used if compiling one file on the command line. + +=item -o < executable_name > + +Explicitly gives the name B<executable_name> to the executable which is to be +compiled. Can only be used if compiling one file on the command line. + +=item -e < perl_line_to_execute> + +Compiles 'one liners', in the same way that B<perl -e> runs text strings at +the command line. Default is to have the 'one liner' be compiled, and run all +in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, +rather than throwing it away. Use '-argv' to pass arguments to the executable +created. + +=item -regex <rename_regex> + +Gives a rule B<rename_regex> - which is a legal perl regular expression - to +create executable file names. + +=item -verbose <verbose_level> + +Show exactly what steps perlcc is taking to compile your code. You can change +the verbosity level B<verbose_level> much in the same way that the '-D' switch +changes perl's debugging level, by giving either a number which is the sum of +bits you want or a list of letters representing what you wish to see. Here are +the verbosity levels so far : + + Bit 1(g): Code Generation Errors to STDERR + Bit 2(a): Compilation Errors to STDERR + Bit 4(t): Descriptive text to STDERR + Bit 8(f): Code Generation Errors to file (B<-log> flag needed) + Bit 16(c): Compilation Errors to file (B<-log> flag needed) + Bit 32(d): Descriptive text to file (B<-log> flag needed) + +If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring +all of perlcc's output to both the screen and to a log file). If no B<-log> +tag is given, then the default verbose level is 7 (ie: outputting all of +perlcc's output to STDERR). + +NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to +both a file, and to the screen! Suggestions are welcome on how to overcome this +difficulty, but for now it simply does not work properly, and hence will only go +to the screen. + +=item -log <logname> + +Opens, for append, a logfile to save some or all of the text for a given +compile command. No rewrite version is available, so this needs to be done +manually. + +=item -argv <arguments> + +In combination with '-run' or '-e', tells perlcc to run the resulting +executable with the string B<arguments> as @ARGV. + +=item -sav + +Tells perl to save the intermediate C code. Usually, this C code is the name +of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c', +for example. If used with the '-e' operator, you need to tell perlcc where to +save resulting executables. + +=item -gen + +Tells perlcc to only create the intermediate C code, and not compile the +results. Does an implicit B<-sav>, saving the C code rather than deleting it. + +=item -run + +Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE +B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS +ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING. + +=item -prog + +Indicate that the programs at the command line are programs, and should be +compiled as such. B<perlcc> will automatically determine files to be +programs if they have B<.p>, B<.pl>, B<.bat> extensions. + +=item -mod + +Indicate that the programs at the command line are modules, and should be +compiled as such. B<perlcc> will automatically determine files to be +modules if they have the extension B<.pm>. + +=back + +=head1 ENVIRONMENT + +Most of the work of B<perlcc> is done at the command line. However, you can +change the heuristic which determines what is a module and what is a program. +As indicated above, B<perlcc> assumes that the extensions: + +.p$, .pl$, and .bat$ + +indicate a perl program, and: + +.pm$ + +indicate a library, for the purposes of creating executables. And furthermore, +by default, these extensions will be replaced (and dropped ) in the process of +creating an executable. + +To change the extensions which are programs, and which are modules, set the +environmental variables: + +PERL_SCRIPT_EXT +PERL_MODULE_EXT + +These two environmental variables take colon-separated, legal perl regular +expressions, and are used by perlcc to decide which objects are which. +For example: + +setenv PERL_SCRIPT_EXT '.prl$:.perl$' +prompt% perlcc sample.perl + +will compile the script 'sample.perl' into the executable 'sample', and + +setenv PERL_MODULE_EXT '.perlmod$:.perlmodule$' + +prompt% perlcc sample.perlmod + +will compile the module 'sample.perlmod' into the shared object +'sample.so' + +NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT +is a literal '.', and not a wild-card. To get a true wild-card, you need to +backslash the '.'; as in: + +setenv PERL_SCRIPT_EXT '\.\.\.\.\.' + +which would have the effect of compiling ANYTHING (except what is in +PERL_MODULE_EXT) into an executable with 5 less characters in its name. + +=head1 FILES + +'perlcc' uses a temporary file when you use the B<-e> option to evaluate +text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is +perlc$$.p.c, and the temporary executable is perlc$$. + +When you use '-run' and don't save your executable, the temporary executable is +perlc$$ + +=head1 BUGS + +perlcc currently cannot compile shared objects on Win32. This should be fixed +by perl5.005. + +=cut + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 3a6059b4fd..60983b29a4 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -48,8 +48,9 @@ if(@ARGV<1) { $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die <<EOF; -Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName +Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName $me -f PerlFunc + $me -q FAQKeywords The -h option prints more help. Also try "perldoc perldoc" to get aquainted with the system. @@ -73,18 +74,22 @@ sub usage{ die <<EOF; perldoc [options] PageName|ModuleName|ProgramName... perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex Options: -h Display this help message + -r Recursive search (slow) + -i Ignore case -t Display pod using pod2text instead of pod2man and nroff (-t is the default on win32) -u Display unformatted pod text - -m Display modules file in its entirety - -l Display the modules file name + -m Display module's file in its entirety + -l Display the module's file name -F Arguments are file names, not modules -v Verbosely describe what's going on -X use index if present (looks for pod.idx at $Config{archlib}) + PageName|ModuleName... is the name of a piece of documentation that you want to look at. You may either give a descriptive name of the page (as in the case of @@ -95,7 +100,11 @@ PageName|ModuleName... BuiltinFunction is the name of a perl function. Will extract documentation from `perlfunc'. - + +FAQRegex + is a regex. Will search perlfaq[1-9] for and extract any + questions that match. + Any switches in the PERLDOC environment variable will be used before the command line arguments. The optional pod index file contains a list of filenames, one per line. @@ -108,7 +117,7 @@ use Text::ParseWords; unshift(@ARGV,shellwords($ENV{"PERLDOC"})); -getopts("mhtluvFf:X") || usage; +getopts("mhtluvriFf:Xq") || usage; usage if $opt_h || $opt_h; # avoid -w warning @@ -125,6 +134,8 @@ if ($opt_t) { require Pod::Text; import Pod::Text; } if ($opt_f) { @pages = ("perlfunc"); +} elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); } else { @pages = @ARGV; } @@ -155,16 +166,19 @@ sub containspod { } 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 $Is_Dos or $^O eq 'os2') { - return $file if -f $file and -r _; + my($dir,$file) = @_; + my $path = join('/',$dir,$file); + return $path if -f $path and -r _; + if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { + # on a case-forgiving file system or if case is important + # that is it all we can do warn "Ignored $file: unreadable\n" if -f _; return ''; } local *DIR; local($")="/"; - my(@p,$p,$cip); + my @p = ($dir); + my($p,$cip); foreach $p (split(/\//, $file)){ my $try = "@p/$p"; stat $try; @@ -200,17 +214,19 @@ sub minus_f_nocase { warn "Ignored $file: unreadable\n" if -f _; } } - return; # is not a file + return ""; } sub check_file { - my($file) = @_; + my($dir,$file) = @_; if ($opt_m) { - return minus_f_nocase($file) ? $file : ""; + return minus_f_nocase($dir,$file); } else { - return minus_f_nocase($file) && containspod($file) ? $file : ""; + my $path = minus_f_nocase($dir,$file); + return $path if containspod($path); } + return ""; } @@ -227,17 +243,17 @@ sub searchfor { 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") + 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") + $ret = check_file $dir,"$s.com") or ( $^O eq 'os2' and - $ret = check_file "$dir/$s.cmd") + $ret = check_file $dir,"$s.cmd") or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and - $ret = check_file "$dir/$s.bat") - or ( $ret = check_file "$dir/pod/$s.pod") - or ( $ret = check_file "$dir/pod/$s") + $ret = check_file $dir,"$s.bat") + or ( $ret = check_file "$dir/pod","$s.pod") + or ( $ret = check_file "$dir/pod",$s) ) { return $ret; } @@ -302,7 +318,7 @@ foreach (@pages) { @searchdirs = grep(!/^\.$/,@INC); - @files= searchfor(1,$_,@searchdirs); + @files= searchfor(1,$_,@searchdirs) if $opt_r; if( @files ) { print STDERR "Loosely found as @files\n" if $opt_v; } else { @@ -352,6 +368,7 @@ if ($Is_MSWin32) { if ($^O eq 'os2') { require POSIX; $tmp = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; } else { $tmp = "/tmp/perldoc1.$$"; } @@ -391,14 +408,23 @@ if ($opt_f) { ++$found if /^\w/; # found descriptive text } if (@pod) { + my $lines = $ENV{LINES} || 24; + if ($opt_t) { open(FORMATTER, "| pod2text") || die "Can't start filter"; print FORMATTER "=over 8\n\n"; print FORMATTER @pod; print FORMATTER "=back\n"; close(FORMATTER); - } else { + } elsif (@pod < $lines-2) { print @pod; + } else { + foreach $pager (@pagers) { + open (PAGER, "| $pager") or next; + print PAGER @pod ; + close(PAGER) or next; + last; + } } } else { die "No documentation for perl function `$opt_f' found\n"; @@ -406,6 +432,39 @@ if ($opt_f) { exit; } +if ($opt_q) { + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + my @pod; + + while (<>) { + if (/^=head2\s+.*$opt_q/oi) { + $found = 1; + push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; + } elsif (/^=head2/) { + $found = 0; + } + next unless $found; + push @pod, $_; + } + + if (@pod) { + if ($opt_t) { + open(FORMATTER, "| pod2text") || die "Can't start filter"; + print FORMATTER "=over 8\n\n"; + print FORMATTER @pod; + print FORMATTER "=back\n"; + close(FORMATTER); + } else { + print @pod; + } + } else { + die "No documentation for perl function `$opt_f' found\n"; + } + exit; +} + foreach (@found) { if($opt_t) { @@ -539,7 +598,10 @@ command line arguments. C<perldoc> also searches directories specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not defined) and C<PATH> environment variables. (The latter is so that embedded pods for executables, such as -C<perldoc> itself, are available.) +C<perldoc> itself, are available.) C<perldoc> will use, in order of +preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or +C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not +used if C<perldoc> was told to display plain text or unformatted pod.) =head1 AUTHOR diff --git a/vms/config.vms b/vms/config.vms index 35abbdb00f..9614ea60c3 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -11,7 +11,7 @@ * Version: 5.005 */ -/* Configuration time: 7-Mar-1998 16:30 +/* Configuration time: 4-Apr-1998 21:30 * Configured by: Charles Bailey bailey@newman.upenn.edu * Target system: VMS */ @@ -76,7 +76,7 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00463" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00464" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ @@ -257,6 +257,16 @@ # define LONG_DOUBLESIZE 8 /**/ #endif +/* LONGLONGSIZE: + * This symbol contains the size of a long long, so that the + * C preprocessor can make decisions based on it. It is only + * defined if the system supports long long. + */ +#undef HAS_LONG_LONG /**/ +#ifdef HAS_LONG_LONG +#define LONGLONGSIZE 8 /**/ +#endif + /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to create and open a unique temporary file. @@ -822,6 +832,7 @@ #undef PWCHANGE /**/ #undef PWCLASS /**/ #undef PWEXPIRE /**/ +#define PWGECOS /**/ #define PWCOMMENT /**/ /* I_STDDEF: @@ -1029,7 +1040,7 @@ * have select(), of course. */ #if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && defined(DECCRTL_SOCKETS) -#define Select_fd_set_t fd_set * /**/ +#define Select_fd_set_t fd_set * /* config-skip */ #else #define Select_fd_set_t int * /* config-skip */ #endif @@ -2105,6 +2116,38 @@ */ #define HAS_ENDSERVENT /*config-skip*/ +/* HAS_GETHOST_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for gethostent(), gethostbyname(), and + * gethostbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETHOST_PROTOS /*config-skip*/ + +/* HAS_GETNET_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getnetent(), getnetbyname(), and + * getnetbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETNET_PROTOS /*config-skip*/ + +/* HAS_GETPROTO_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getprotoent(), getprotobyname(), and + * getprotobyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETPROTO_PROTOS /*config-skip*/ + +/* HAS_GETSERV_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getservent(), getservbyname(), and + * getservbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETSERV_PROTOS /*config-skip*/ + #else /* VMS_DO_SOCKETS */ #undef HAS_SOCKET /*config-skip*/ @@ -2133,6 +2176,10 @@ #undef HAS_GETSERVENT /*config-skip*/ #undef HAS_SETSERVENT /*config-skip*/ #undef HAS_ENDSERVENT /*config-skip*/ +#undef HAS_GETHOST_PROTOS /*config-skip*/ +#undef HAS_GETNET_PROTOS /*config-skip*/ +#undef HAS_GETPROTO_PROTOS /*config-skip*/ +#undef HAS_GETSERV_PROTOS /*config-skip*/ #endif /* !VMS_DO_SOCKETS */ diff --git a/vms/descrip.mms b/vms/descrip.mms index 00a5c0b425..eb1a5a34e5 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -347,7 +347,7 @@ all : base extras x2p archcorefiles preplibrary perlpods .endif base : miniperl perl @ $(NOOP) -extras : Fcntl IO Opcode attrs B $(POSIX) $(THREAD) SDBM_File libmods utils podxform +extras : Fcntl IO Opcode attrs Stdio DCLsym B $(POSIX) $(THREAD) SDBM_File libmods utils podxform @ $(NOOP) libmods : $(LIBPREREQ) @ $(NOOP) @@ -462,6 +462,10 @@ $(ARCHDIR)config.pm : [.lib]config.pm @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm +[.ext.dynaloader]dynaloader.pm : [.ext.dynaloader]dynaloader.pm_pl + $(MINIPERL) $(MMS$SOURCE) + @ Rename/Log dynaloader.pm [.ext.dynaloader] + Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) @ $(NOOP) @@ -512,6 +516,50 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) [.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +Stdio : [.lib.vms]Stdio.pm [.lib.auto.vms.Stdio]Stdio$(E) [.t.lib]vms_stdio.t + @ $(NOOP) + +[.lib.vms]Stdio.pm : [.vms.ext.stdio]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] + @ Set Default [.vms.ext.Stdio] + $(MMS) + @ Set Default [---] + +[.lib.auto.vms.Stdio]Stdio$(E) : [.vms.ext.Stdio]Descrip.MMS + @ Set Default [.vms.ext.Stdio] + $(MMS) + @ Set Default [---] + +[.t.lib]vms_stdio.t : [.vms.ext.Stdio]test.pl + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) + +# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> +# ${@} necessary to distract different versions of MM[SK]/make +[.vms.ext.stdio]Descrip.MMS : [.vms.ext.Stdio]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) + $(MINIPERL) "-I[---.lib]" -e "chdir('[.vms.ext.Stdio]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[---.lib]" "INST_ARCHLIB=[---.lib]" + +DCLsym : [.lib.vms]DCLsym.pm [.lib.auto.vms.DCLsym]DCLsym$(E) [.t.lib]vms_dclsym.t + @ $(NOOP) + +[.lib.vms]DCLsym.pm : [.vms.ext.dclsym]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] + @ Set Default [.vms.ext.DCLsym] + $(MMS) + @ Set Default [---] + +[.lib.auto.vms.DCLsym]DCLsym$(E) : [.vms.ext.DCLsym]Descrip.MMS + @ Set Default [.vms.ext.DCLsym] + $(MMS) + @ Set Default [---] + +[.t.lib]vms_dclsym.t : [.vms.ext.DCLsym]test.pl + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) + +# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> +# ${@} necessary to distract different versions of MM[SK]/make +[.vms.ext.DCLsym]Descrip.MMS : [.vms.ext.DCLsym]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) + $(MINIPERL) "-I[---.lib]" -e "chdir('[.vms.ext.DCLsym]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[---.lib]" "INST_ARCHLIB=[---.lib]" + attrs : [.lib]attrs.pm [.lib.auto.attrs]attrs$(E) @ $(NOOP) @@ -779,14 +827,14 @@ B : [.lib]B.pm [.lib]O.pm [.lib.B]Asmdata.pm [.lib.B]Assembler.pm [.lib.B]Bblock [.lib]perlbug.com : [.utils]perlbug.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]perlbug.com $(MMS$TARGET) + Copy/Log [.utils]perlbug.com $(MMS$TARGET) [.utils]pl2pm.com : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) [.lib]splain.com : [.utils]splain.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]splain.com $(MMS$TARGET) + Copy/Log [.utils]splain.com $(MMS$TARGET) [.x2p]find2perl.com : [.x2p]find2perl.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) @@ -826,22 +874,22 @@ B : [.lib]B.pm [.lib]O.pm [.lib.B]Asmdata.pm [.lib.B]Assembler.pm [.lib.B]Bblock [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2html.com $(MMS$TARGET) + Copy/Log [.pod]pod2html.com $(MMS$TARGET) [.lib.pod]pod2latex.com : [.pod]pod2latex.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2latex.com $(MMS$TARGET) + Copy/Log [.pod]pod2latex.com $(MMS$TARGET) [.lib.pod]pod2man.com : [.pod]pod2man.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2man.com $(MMS$TARGET) + Copy/Log [.pod]pod2man.com $(MMS$TARGET) [.lib.pod]pod2text.com : [.pod]pod2text.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2text.com $(MMS$TARGET) + Copy/Log [.pod]pod2text.com $(MMS$TARGET) preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM) @ Write Sys$Output "Autosplitting Perl library . . ." @@ -1066,6 +1114,9 @@ perly$(O) : perly.c, perly.h, $(h) test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t - @[.VMS]Test.Com "$(E)" +install : + $(MINIPERL) installperl + archify : all @ Write Sys$Output "Moving files to architecture-specific locations for $(ARCH)" archroot = "$(ARCHAUTO)" - "]" + "...]" @@ -1313,6 +1364,7 @@ tidy : cleanlis - If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar - If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O) - If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C + - If F$Search("[.Ext.Socket]Socket.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C - If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode] - If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C - If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O) @@ -1328,6 +1380,7 @@ tidy : cleanlis - If F$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* - If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com + - If F$Search("[.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.pod]*.com - If F$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com - If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com @@ -1358,9 +1411,15 @@ clean : tidy - $(MMS) clean Set Default [--] .endif - Set Default [.ext.SDBM_File] - - $(MMS) clean - Set Default [--] + Set Default [.ext.SDBM_File] + - $(MMS) clean + Set Default [--] + Set Default [.vms.ext.Stdio] + - $(MMS) clean + Set Default [---] + Set Default [.vms.ext.DCLsym] + - $(MMS) clean + Set Default [---] - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);* - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* @@ -1381,6 +1440,7 @@ clean : tidy - If F$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;* - If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;* - If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);* + - If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log [.pod]*.com;* realclean : clean Set Default [.ext.Fcntl] @@ -1408,9 +1468,15 @@ realclean : clean - $(MMS) realclean Set Default [--] .endif - Set Default [.ext.SDBM_File] - - $(MMS) realclean - Set Default [--] + Set Default [.ext.SDBM_File] + - $(MMS) realclean + Set Default [--] + Set Default [.vms.ext.Stdio] + - $(MMS) clean + Set Default [---] + Set Default [.vms.ext.DCLsym] + - $(MMS) clean + Set Default [---] - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);* - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);" diff --git a/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL index 8e6f5bce40..84ab2be2b5 100644 --- a/vms/ext/DCLsym/Makefile.PL +++ b/vms/ext/DCLsym/Makefile.PL @@ -1,3 +1,4 @@ use ExtUtils::MakeMaker; -WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' ); +WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm', + 'MAN3PODS' => ' '); diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm index b0b1414599..4a539c2701 100644 --- a/vms/ext/Filespec.pm +++ b/vms/ext/Filespec.pm @@ -266,6 +266,7 @@ sub fileify ($) { my($path) = @_; if (!$path) { return undef } + if ($path eq '/') { return 'sys$disk:[000000]'; } if ($path =~ /(.+)\.([^:>\]]*)$/) { $path = $1; if ($2 !~ /^dir(?:;1)?$/i) { return undef } diff --git a/vms/ext/Stdio/Makefile.PL b/vms/ext/Stdio/Makefile.PL index e5ea988818..f5599f8a96 100644 --- a/vms/ext/Stdio/Makefile.PL +++ b/vms/ext/Stdio/Makefile.PL @@ -1,3 +1,5 @@ use ExtUtils::MakeMaker; -WriteMakefile( 'VERSION_FROM' => 'Stdio.pm' ); +WriteMakefile( 'VERSION_FROM' => 'Stdio.pm', + 'MAN3PODS' => ' ', # pods will be built later + ); diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 0a7b47e514..9744be04f2 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -87,6 +87,7 @@ newFH(FILE *fp, char type) { HV *stash; IO *io; + dTHR; /* Find stash for VMS::Stdio. We don't do this once at boot * to allow for possibility of threaded Perl with per-thread * symbol tables. This code (through io = ...) is really diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 05644917b6..779396be73 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -96,6 +96,7 @@ some/where/... vmsify [.some.where...] .. vmsify [-] ../.. vmsify [--] .../ vmsify [...] +/ vmsify sys$disk:[000000] # Fileifying directory specs down:[the.garden.path] fileify down:[the.garden]path.dir;1 @@ -135,6 +136,7 @@ down:[the.garden.path...] unixpath /down/the/garden/path/.../ [.down.the.garden]path.dir unixpath down/the/garden/path/ down/the/garden/path vmspath [.down.the.garden.path] path vmspath [.path] +/ vmspath sys$disk:[000000] # Redundant characters in Unix paths //some/where//over/../the.rainbow vmsify some:[where]the.rainbow diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 4e0cf31655..45f50cad5f 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -190,6 +190,10 @@ foreach (@ARGV) { print OUT "netdb_name_type=",$dosock ? "'char *'\n" : "'undef'\n"; print OUT "netdb_host_type=",$dosock ? "'char *'\n" : "'undef'\n"; print OUT "netdb_hlen_type=",$dosock ? "'int'\n" : "'undef'\n"; + print OUT "d_gethostprotos=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_getnetprotos=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_getservprotos=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_getprotoprotos=",$dosock ? "'define'\n" : "'undef'\n"; if ($dosock and $cctype eq 'decc' and $ccflags =~ /DECCRTL_SOCKETS/) { print OUT "selecttype='fd_set'\n"; diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 4aa68008d5..89c4bbf623 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -663,12 +663,20 @@ list logical names. For instance, if you say Perl will print C<ONCE UPON A TIME THERE WAS>. -The %ENV keys C<home>, C<path>,C<term>, and C<user> -return the CRTL "environment variables" of the same -names, if these logical names are not defined. The -key C<default> returns the current default device +The key C<default> returns the current default device and directory specification, regardless of whether -there is a logical name DEFAULT defined.. +there is a logical name DEFAULT defined. If you try to +read an element of %ENV for which there is no corresponding +logical name, and for which no corresponding CLI symbol +exists (this is to identify "blocking" symbols only; to +manipulate CLI symbols, see L<VMS::DCLSym>) then the key +will be looked up in the CRTL-local environment array, and +the corresponding value, if any returned. This lets you +get at C-specific keys like C<home>, C<path>,C<term>, and +C<user>, as well as other keys which may have been passed +directly into the C-specific array if Perl was called from +another C program using the version of execve() or execle() +present in recent revisions of the DECCRTL. Setting an element of %ENV defines a supervisor-mode logical name in the process logical name table. C<Undef>ing or @@ -680,6 +688,23 @@ logical name translation after the deletion, so an inner-mode logical name or a name in another logical name table will replace the logical name just deleted. It is not possible at present to define a search list logical name via %ENV. +It is also not possible to delete an element from the +C-local environ array. + +Note that if you want to pass on any elements of the +C-local environ array to a subprocess which isn't +started by fork/exec, or isn't running a C program, you +can "promote" them to logical names in the current +process, which will then be inherited by all subprocesses, +by saying + + foreach my $key (qw[C-local keys you want promoted]) { + my $temp = $ENV{$key}; # read from C-local array + $ENV{$key} = $temp; # and define as logical name + } + +(You can't just say C<$ENV{$key} = $ENV{$key}>, since the +Perl optimizer is smart enough to elide the expression.) At present, the first time you iterate over %ENV using C<keys>, or C<values>, you will incur a time penalty as all diff --git a/vms/test.com b/vms/test.com index affc6a83c7..f131088dda 100644 --- a/vms/test.com +++ b/vms/test.com @@ -21,8 +21,17 @@ $ EndIf $ EndIf $ Set Message /Facility/Severity/Identification/Text $ -$ exe = ".Exe" -$ If p1.nes."" Then exe = p1 +$ exe = ".Exe" +$ If p1.nes."" Then exe = p1 +$ If F$Extract(0,1,exe) .nes. "." +$ Then +$ Write Sys$Error "" +$ Write Sys$Error "The first parameter passed to Test.Com must be the file type used for the" +$ Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited" +$ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line." +$ Write Sys$Error "" +$ Exit 44 +$ EndIf $! Pick up a copy of perl to use for the tests $ Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]Perl'exe' []Perl. @@ -103,7 +112,7 @@ use Config; # insists on stat()ing a file descriptor before it'll use it. push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc'; -@opexcl=('exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t'); +@opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t'); @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl); foreach $file (@exclist) { $skip{$file}++; } @@ -196,7 +196,7 @@ prime_env_iter(void) # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */ #endif unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED; - unsigned long int retsts, substs = 0, wakect = 0; + unsigned long int i, retsts, substs = 0, wakect = 0; STRLEN eqvlen; SV *oldrs, *linesv, *eqvsv; $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:"); @@ -212,12 +212,18 @@ prime_env_iter(void) /* Perform a dummy fetch as an lval to insure that the hash table is * set up. Otherwise, the hv_store() will turn into a nullop. */ (void) hv_fetch(envhv,"DEFAULT",7,TRUE); - /* Also, set up the four "special" keys that the CRTL defines, - * whether or not underlying logical names exist. */ - (void) hv_fetch(envhv,"HOME",4,TRUE); - (void) hv_fetch(envhv,"TERM",4,TRUE); - (void) hv_fetch(envhv,"PATH",4,TRUE); - (void) hv_fetch(envhv,"USER",4,TRUE); + /* Also, set up any "special" keys that the CRTL defines, + * either by itself or becasue we were called from a C program + * using exec[lv]e() */ + for (i = 0; environ[i]; i++) { + if (!(start = strchr(environ[i],'='))) { + warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]); + } + else { + start++; + (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0); + } + } /* Now, go get the logical names */ create_mbx(&chan,&mbxdsc); diff --git a/win32/Makefile b/win32/Makefile index 29e92d15ec..05e3c3a467 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1,4 +1,3 @@ -# # Makefile to build perl on Windowns NT using Microsoft NMAKE. # Works with MS command line compilers from VC++ etc. # @@ -31,12 +30,14 @@ OBJECT = -DPERL_OBJECT # # if you have the source for des_fcrypt(), uncomment this and make sure the -# file exists (see README.win32) +# file exists (see README.win32). File should be located at the perl +# top level directory. #CRYPT_SRC = des_fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) +# Specify the full pathname of the library. #CRYPT_LIB = des_fcrypt.lib # @@ -48,6 +49,9 @@ OBJECT = -DPERL_OBJECT # # set the install locations of the compiler include/libraries +# (you'll need to quote the value if it contains spaces: i.e. +# CCHOME = "f:\Program Files\vc" +# #CCHOME = f:\msvc20 CCHOME = $(MSVCDIR) CCINCDIR = $(CCHOME)\include @@ -476,7 +480,7 @@ $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl $(XCOPY) *.h $(COREDIR)\*.* $(RCOPY) include $(COREDIR)\*.* $(MINIPERL) -I..\lib config_h.PL || $(MAKE) $(MAKEFLAGS) $(CONFIGPM) - + $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(LINK32) -subsystem:console -out:$@ @<< $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ) @@ -689,12 +693,18 @@ realclean: clean -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) -rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) -install : all doc utils +install : all installbare installutils installhtml + +installbare : $(PERLEXE) ..\installperl $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* + +installutils : utils $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_BIN)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* + +installhtml : doc $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) diff --git a/win32/config.bc b/win32/config.bc index 0364c329dd..fe9f297b4b 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -159,10 +159,10 @@ d_mkfifo='undef' d_mkstemp='undef' d_mktime='define' d_msg='undef' -d_msgctl='define' -d_msgget='define' -d_msgrcv='define' -d_msgsnd='define' +d_msgctl='undef' +d_msgget='undef' +d_msgrcv='undef' +d_msgsnd='undef' d_mymalloc='undef' d_nice='undef' d_oldpthreads='undef' @@ -181,6 +181,7 @@ d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' +d_pwgecos='undef' d_pwquota='undef' d_readdir='define' d_readlink='undef' @@ -194,9 +195,9 @@ d_sched_yield='undef' d_seekdir='define' d_select='define' d_sem='undef' -d_semctl='define' -d_semget='define' -d_semop='define' +d_semctl='undef' +d_semget='undef' +d_semop='undef' d_setegid='undef' d_seteuid='undef' d_setgrps='undef' @@ -222,9 +223,9 @@ d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' -d_shmctl='define' -d_shmdt='define' -d_shmget='define' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' d_sigaction='undef' d_sigsetjmp='undef' d_socket='define' diff --git a/win32/config.gc b/win32/config.gc index ec41c2ec68..5e732ab3f2 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -159,10 +159,10 @@ d_mkfifo='undef' d_mkstemp='undef' d_mktime='define' d_msg='undef' -d_msgctl='define' -d_msgget='define' -d_msgrcv='define' -d_msgsnd='define' +d_msgctl='undef' +d_msgget='undef' +d_msgrcv='undef' +d_msgsnd='undef' d_mymalloc='undef' d_nice='undef' d_oldpthreads='undef' @@ -181,6 +181,7 @@ d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' +d_pwgecos='undef' d_pwquota='undef' d_readdir='define' d_readlink='undef' @@ -194,9 +195,9 @@ d_sched_yield='undef' d_seekdir='define' d_select='define' d_sem='undef' -d_semctl='define' -d_semget='define' -d_semop='define' +d_semctl='undef' +d_semget='undef' +d_semop='undef' d_setegid='undef' d_seteuid='undef' d_setgrps='undef' @@ -222,9 +223,9 @@ d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' -d_shmctl='define' -d_shmdt='define' -d_shmget='define' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' d_sigaction='undef' d_sigsetjmp='undef' d_socket='define' diff --git a/win32/config.vc b/win32/config.vc index 62cd537c78..1fdbcbfbc2 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -159,10 +159,10 @@ d_mkfifo='undef' d_mkstemp='undef' d_mktime='define' d_msg='undef' -d_msgctl='define' -d_msgget='define' -d_msgrcv='define' -d_msgsnd='define' +d_msgctl='undef' +d_msgget='undef' +d_msgrcv='undef' +d_msgsnd='undef' d_mymalloc='undef' d_nice='undef' d_oldpthreads='undef' @@ -181,6 +181,7 @@ d_pwchange='undef' d_pwclass='undef' d_pwcomment='undef' d_pwexpire='undef' +d_pwgecos='undef' d_pwquota='undef' d_readdir='define' d_readlink='undef' @@ -194,9 +195,9 @@ d_sched_yield='undef' d_seekdir='define' d_select='define' d_sem='undef' -d_semctl='define' -d_semget='define' -d_semop='define' +d_semctl='undef' +d_semget='undef' +d_semop='undef' d_setegid='undef' d_seteuid='undef' d_setgrps='undef' @@ -222,9 +223,9 @@ d_sfio='undef' d_shm='undef' d_shmat='undef' d_shmatprototype='undef' -d_shmctl='define' -d_shmdt='define' -d_shmget='define' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' d_sigaction='undef' d_sigsetjmp='undef' d_socket='define' diff --git a/win32/config_H.bc b/win32/config_H.bc index 9a8043d4a4..2e645a8e99 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -924,6 +924,10 @@ * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. @@ -934,6 +938,7 @@ /*#define PWCHANGE /**/ /*#define PWCLASS /**/ /*#define PWEXPIRE /**/ +/*#define PWGECOS /**/ /*#define PWCOMMENT /**/ /* I_SFIO: diff --git a/win32/config_H.gc b/win32/config_H.gc index b9486c8616..44aafe7c4c 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -924,6 +924,10 @@ * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. @@ -934,6 +938,7 @@ /*#define PWCHANGE /**/ /*#define PWCLASS /**/ /*#define PWEXPIRE /**/ +/*#define PWGECOS /**/ /*#define PWCOMMENT /**/ /* I_SFIO: diff --git a/win32/config_H.vc b/win32/config_H.vc index bdce05ee95..07e6e235c5 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -924,6 +924,10 @@ * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. @@ -934,6 +938,7 @@ /*#define PWCHANGE /**/ /*#define PWCLASS /**/ /*#define PWEXPIRE /**/ +/*#define PWGECOS /**/ /*#define PWCOMMENT /**/ /* I_SFIO: diff --git a/win32/makedef.pl b/win32/makedef.pl index e688eb5075..acaa64b232 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -254,6 +254,8 @@ if ($define{'MYMALLOC'}) unless ($define{'USE_THREADS'}) { skip_symbols [qw( +Perl_getTHR +Perl_setTHR Perl_condpair_magic Perl_thr_key Perl_sv_mutex @@ -432,6 +434,7 @@ __DATA__ perl_init_i18nl10n perl_init_ext perl_alloc +perl_atexit perl_construct perl_destruct perl_free @@ -448,6 +451,11 @@ perl_call_sv perl_require_pv perl_eval_pv perl_eval_sv +perl_new_ctype +perl_new_collate +perl_new_numeric +perl_set_numeric_standard +perl_set_numeric_local boot_DynaLoader Perl_thread_create win32_errno diff --git a/win32/makefile.mk b/win32/makefile.mk index cd2a95adae..d7476452a8 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -36,12 +36,14 @@ OBJECT *= -DPERL_OBJECT # # if you have the source for des_fcrypt(), uncomment this and make sure the -# file exists (see README.win32) +# file exists (see README.win32). File should be located at the perl +# top level directory. #CRYPT_SRC *= des_fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) +# Specify the full pathname of the library. #CRYPT_LIB *= des_fcrypt.lib # @@ -53,6 +55,9 @@ OBJECT *= -DPERL_OBJECT # # set the install locations of the compiler include/libraries +# (you'll need to quote the value if it contains spaces: i.e. +# CCHOME *= "f:\Program Files\vc" +# #CCHOME *= f:\msdev\vc CCHOME *= C:\bc5 #CCHOME *= D:\packages\mingw32 @@ -135,7 +140,7 @@ LIBFILES = $(CRYPT_LIB) import32.lib $(LIBC) odbc32.lib odbccp32.lib OPTIMIZE = -v $(RUNTIME) -DDEBUGGING LINK_DBG = -v .ELSE -OPTIMIZE = -5 -O2 $(RUNTIME) +OPTIMIZE = -O2 $(RUNTIME) LINK_DBG = .ENDIF @@ -165,8 +170,8 @@ SUBSYS = console CXX_FLAG = -xc++ LIBC = -lcrtdll -LIBFILES = $(CRYPT_LIB) -ladvapi32 -luser32 -lwsock32 -lmingw32 -lgcc \ - -lmoldname $(LIBC) -lkernel32 +LIBFILES = $(CRYPT_LIB) -ladvapi32 -luser32 -lnetapi32 -lwsock32 -lmingw32 \ + -lgcc -lmoldname $(LIBC) -lkernel32 .IF "$(CFG)" == "Debug" OPTIMIZE = -g -O2 $(RUNTIME) -DDEBUGGING @@ -199,7 +204,7 @@ RUNTIME = -MT RUNTIME = -MD .ENDIF -INCLUDES = -I.\include -I. -I.. +INCLUDES = -I.\include -I. -I.. #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX DEFINES = -DWIN32 -D_CONSOLE $(BUILDOPT) $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE @@ -750,6 +755,11 @@ $(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) +$(POSIX_DLL): $(PERLEXE) $(POSIX).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + $(IO_DLL): $(PERLEXE) $(IO).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -800,6 +810,8 @@ distclean: clean -del /f $(EXTENSION_C) -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat + -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc pstruct *.bat + -cd ..\x2p && del /f find2perl s2p *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new -del /f ..\lib\Config.pm .IF "$(PERL95EXE)" != "" @@ -811,14 +823,18 @@ distclean: clean -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) -rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) -install : all doc utils +installbare : $(PERLEXE) ..\installperl .IF "$(PERL95EXE)" != "" $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* .ENDIF + +installutils : utils $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_BIN)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* + +installhtml : doc $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) diff --git a/win32/win32.c b/win32/win32.c index 674b047446..d4be76a7bd 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -112,48 +112,29 @@ static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); -char * w32_perlshell_tokens = Nullch; -char ** w32_perlshell_vec; -long w32_perlshell_items = -1; -DWORD w32_platform = (DWORD)-1; -char w32_perllib_root[MAX_PATH+1]; HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; -#ifndef __BORLANDC__ -long w32_num_children = 0; -HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS]; -#endif - -#ifndef FOPEN_MAX -# if defined(_NSTREAM_) -# define FOPEN_MAX _NSTREAM_ -# elsif defined(_NFILE_) -# define FOPEN_MAX _NFILE_ -# elsif defined(_NFILE) -# define FOPEN_MAX _NFILE -# endif -#endif - -#ifndef USE_CRT_POPEN -int w32_popen_pids[FOPEN_MAX]; -#endif +static DWORD w32_platform = (DWORD)-1; #ifdef USE_THREADS # ifdef USE_DECLSPEC_THREAD __declspec(thread) char strerror_buffer[512]; __declspec(thread) char getlogin_buffer[128]; +__declspec(thread) char w32_perllib_root[MAX_PATH+1]; # ifdef HAVE_DES_FCRYPT __declspec(thread) char crypt_buffer[30]; # endif # else # define strerror_buffer (thr->i.Wstrerror_buffer) # define getlogin_buffer (thr->i.Wgetlogin_buffer) +# define w32_perllib_root (thr->i.Ww32_perllib_root) # define crypt_buffer (thr->i.Wcrypt_buffer) # endif #else -char strerror_buffer[512]; -char getlogin_buffer[128]; +static char strerror_buffer[512]; +static char getlogin_buffer[128]; +static char w32_perllib_root[MAX_PATH+1]; # ifdef HAVE_DES_FCRYPT -char crypt_buffer[30]; +static char crypt_buffer[30]; # endif #endif @@ -1113,7 +1094,7 @@ win32_utime(const char *filename, struct utimbuf *times) DllExport int win32_wait(int *status) { -#ifdef __BORLANDC__ +#ifdef USE_RTL_WAIT return wait(status); #else /* XXX this wait emulation only knows about processes @@ -1638,7 +1619,7 @@ win32_pipe(int *pfd, unsigned int size, int mode) DllExport FILE* win32_popen(const char *command, const char *mode) { -#ifdef USE_CRT_POPEN +#ifdef USE_RTL_POPEN return _popen(command, mode); #else int p[2]; @@ -1698,7 +1679,7 @@ win32_popen(const char *command, const char *mode) /* close saved handle */ win32_close(oldfd); - w32_popen_pids[p[parent]] = childpid; + sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); /* we have an fd, return a file stream */ return (win32_fdopen(p[parent], (char *)mode)); @@ -1713,7 +1694,7 @@ cleanup: } return (NULL); -#endif /* USE_CRT_POPEN */ +#endif /* USE_RTL_POPEN */ } /* @@ -1723,13 +1704,22 @@ cleanup: DllExport int win32_pclose(FILE *pf) { -#ifdef USE_CRT_POPEN +#ifdef USE_RTL_POPEN return _pclose(pf); #else - int fd, childpid, status; - fd = win32_fileno(pf); - childpid = w32_popen_pids[fd]; +#ifndef USE_RTL_WAIT + int child; +#endif + + int childpid, status; + SV *sv; + + sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE); + if (SvIOK(sv)) + childpid = SvIVX(sv); + else + childpid = 0; if (!childpid) { errno = EBADF; @@ -1737,7 +1727,18 @@ win32_pclose(FILE *pf) } win32_fclose(pf); - w32_popen_pids[fd] = 0; + SvIVX(sv) = 0; + +#ifndef USE_RTL_WAIT + for (child = 0 ; child < w32_num_children ; ++child) { + if (w32_child_pids[child] == (HANDLE)childpid) { + Copy(&w32_child_pids[child+1], &w32_child_pids[child], + (w32_num_children-child-1), HANDLE); + w32_num_children--; + break; + } + } +#endif /* wait for the child */ if (cwait(&status, childpid, WAIT_CHILD) == -1) @@ -1749,7 +1750,7 @@ win32_pclose(FILE *pf) return (status); #endif -#endif /* USE_CRT_OPEN */ +#endif /* USE_RTL_POPEN */ } DllExport int @@ -1844,8 +1845,13 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) { int status; +#ifndef USE_RTL_WAIT + if (mode == P_NOWAIT && w32_num_children >= MAXIMUM_WAIT_OBJECTS) + return -1; +#endif + status = spawnvp(mode, cmdname, (char * const *) argv); -#ifndef __BORLANDC__ +#ifndef USE_RTL_WAIT /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId * while VC RTL returns pinfo.hProcess. For purposes of the custom * implementation of win32_wait(), we assume the latter. @@ -3050,6 +3056,13 @@ Perl_init_os_extras() char *file = __FILE__; dXSUB_SYS; + w32_perlshell_tokens = Nullch; + w32_perlshell_items = -1; + w32_fdpid = newAV(); /* XXX needs to be in Perl_win32_init()? */ +#ifndef USE_RTL_WAIT + w32_num_children = 0; +#endif + /* these names are Activeware compatible */ newXS("Win32::GetCwd", w32_GetCwd, file); newXS("Win32::SetCwd", w32_SetCwd, file); @@ -3126,7 +3139,7 @@ Perl_win32_init(int *argcp, char ***argvp) #if !defined(_ALPHA_) && !defined(__GNUC__) _control87(MCW_EM, MCW_EM); #endif - MALLOC_INIT; + MALLOC_INIT; } #ifdef USE_BINMODE_SCRIPTS diff --git a/win32/win32.h b/win32/win32.h index 1930e391da..021cc48186 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -138,6 +138,8 @@ struct tms { #pragma warn -csu /* "comparing signed and unsigned values" */ #pragma warn -pro /* "call to function with no prototype" */ +#define USE_RTL_WAIT /* Borland has a working wait() */ + /* Borland is picky about a bare member function name used as its ptr */ #ifdef PERL_OBJECT #define FUNC_NAME_TO_PTR(name) &(name) @@ -248,6 +250,28 @@ EXT void win32_strip_return(struct sv *sv); #define win32_strip_return(sv) NOOP #endif +#define HAVE_INTERP_INTERN +struct interp_intern { + char * w32_perlshell_tokens; + char ** w32_perlshell_vec; + long w32_perlshell_items; + struct av * w32_fdpid; +#ifndef USE_RTL_WAIT + long w32_num_children; + HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS]; +#endif +}; + +#define w32_perlshell_tokens (sys_intern.w32_perlshell_tokens) +#define w32_perlshell_vec (sys_intern.w32_perlshell_vec) +#define w32_perlshell_items (sys_intern.w32_perlshell_items) +#define w32_fdpid (sys_intern.w32_fdpid) + +#ifndef USE_RTL_WAIT +# define w32_num_children (sys_intern.w32_num_children) +# define w32_child_pids (sys_intern.w32_child_pids) +#endif + /* * Now Win32 specific per-thread data stuff */ @@ -261,6 +285,7 @@ struct thread_intern { char Wstrerror_buffer[512]; struct servent Wservent; char Wgetlogin_buffer[128]; + char Ww32_perllib_root[MAX_PATH+1]; # ifdef USE_SOCKETS_AS_HANDLES int Winit_socktype; # endif diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index bf7495a39b..30201bdeda 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -61,6 +61,7 @@ FIRSTMAKEFILE = $firstmakefile cat >>Makefile <<'!NO!SUBS!' +REALPERL = ../perl CCCMD = `sh $(shellflags) cflags $@` public = a2p s2p find2perl @@ -76,6 +77,8 @@ shextract = Makefile cflags pl = find2perl.PL s2p.PL plextract = find2perl s2p +plexe = find2perl.exe s2p.exe +plc = find2perl.c s2p.c addedbyconf = $(shextract) $(plextract) @@ -94,6 +97,9 @@ lintflags = -phbvxac all: $(public) $(private) $(util) touch all +compile: all + $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; + a2p: $(obj) a2p$(OBJ_EXT) $(CC) $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs) -o a2p @@ -116,7 +122,7 @@ a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h \ $(CCCMD) $(LARGE) a2p.c clean: - rm -f a2p *$(OBJ_EXT) + rm -f a2p *$(OBJ_EXT) $(plexe) $(plc) realclean: clean rm -f *.orig core $(addedbyconf) all malloc.c diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index c23fc923a8..ea13c710f9 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -26,7 +26,7 @@ print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; + if \$running_under_some_shell; \$startperl = "$Config{startperl}"; \$perlpath = "$Config{perlpath}"; !GROK!THIS! @@ -34,10 +34,16 @@ $Config{startperl} # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; + # # Modified September 26, 1993 to provide proper handling of years after 1999 # Tom Link <tml+@pitt.edu> # University of Pittsburgh +# +# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow +# Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au> +# University of Adelaide, Adelaide, South Australia +# while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); @@ -47,6 +53,8 @@ for (@roots) { $_ = "e($_); } $roots = join(',', @roots); $indent = 1; +$stat = 'lstat'; +$decl = ''; while (@ARGV) { $_ = shift; @@ -60,6 +68,12 @@ while (@ARGV) { $indent--; $out .= &tab . ")"; } + elsif ($_ eq 'follow') { + $stat = 'stat'; + $decl = '%already_seen = ();'; + $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&'; + $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)'; + } elsif ($_ eq '!') { $out .= &tab . "!"; next; @@ -178,7 +192,7 @@ while (@ARGV) { $file = shift; $newername = 'AGE_OF' . $file; $newername =~ s/[^\w]/_/g; - $newername = '$' . $newername; + $newername = "\$$newername"; $out .= "(-M _ < $newername)"; $initnewer .= "$newername = -M " . "e($file) . ";\n"; } @@ -278,10 +292,10 @@ require "$find.pl"; # Traverse desired filesystems +$decl &$find($roots); $flushall exit; - sub wanted { $out; } @@ -312,10 +326,11 @@ END } if ($initls) { - print <<'END'; + print <<"INTERP", <<'END'; sub ls { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP $pname = $name; @@ -380,7 +395,7 @@ END } if ($initcpio) { -print <<'END'; +print <<'START', <<"INTERP", <<'END'; sub cpio { local($nc,$fh) = @_; local($text); @@ -390,8 +405,10 @@ sub cpio { $size = 0; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); +START + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP if (-f _) { open(IN, "./$_\0") || do { warn "Couldn't open $name: $!\n"; @@ -465,14 +482,16 @@ END } if ($inittar) { -print <<'END'; +print <<'START', <<"INTERP", <<'END'; sub tar { local($fh) = @_; local($linkname,$header,$l,$slop); local($linkflag) = "\0"; - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); +START + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP $nm = $name; if ($nlink > 1) { if ($linkname = $linkseen{$fh,$dev,$ino}) { @@ -561,13 +580,13 @@ sub tab { } else { if ($saw_or) { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + $tabstring .= <<"ENDOFSTAT" . $tabstring; +(\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) && ENDOFSTAT } else { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + $tabstring .= <<"ENDOFSTAT" . $tabstring; +((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) && ENDOFSTAT } $statdone = 1; |