diff options
| author | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-10-08 10:19:27 +0000 |
|---|---|---|
| committer | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-10-08 10:19:27 +0000 |
| commit | 93af7a870f71dbbb13443b4087703de0221add17 (patch) | |
| tree | e767c53d4d4f1783640e5410f94655e45b58b3d0 | |
| parent | c116a00cf797ec2e6795338ee18b88d975e760c5 (diff) | |
| parent | 2269e8ecc334a5a77bdb915666547431c0171402 (diff) | |
| download | perl-93af7a870f71dbbb13443b4087703de0221add17.tar.gz | |
Merge maint-5.004 branch (5.004_03) with mainline.
MANIFEST is out of sync.
p4raw-id: //depot/perl@114
173 files changed, 6919 insertions, 2138 deletions
@@ -48,6 +48,1036 @@ And the Keepers of the Patch Pumpkin: ---------------- +Version 5.004_03 Maintenance release 3 for 5.004 +---------------- + +"To err is human, to forgive divine." + -- Alexander Pope + + + HEADLINES FOR THIS MAINTENANCE RELEASE + + Fixed 5.004_02 compilation failure on VMS. + Fixed Configure (non)errors being displayed to user. + Better support for Windows 95. + Assorted documentation and hint file improvements. + perl --foo no longer silently ignored. + + + ------ BUILD PROCESS ------ + + Title: "Show Configure failure reason even with -s" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970812141623.14256K-100000@newton.phys> + Files: Configure + + Title: "Configure can stop without fully explaining itself" + From: Jim Anderson <jander@ml.com> + Msg-ID: <199708111328.JAA28976@nsd15.ny-swaps-develop.ml.com>, + <199708111952.PAA29346@nsd15.ny-swaps-develop.ml.com> + Files: Configure + + ------ CORE LANGUAGE ------ + + Title: "typos in perl -h output" + From: "Richard A. Wells" <Rwells@uhs.harvard.edu> + Msg-ID: <6D0BF914BC@gateuhs.harvard.edu> + Files: perl.c + + Title: "Some perldb -> PERLDB_* macro changes were missed" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199708100323.XAA27155@monk.mps.ohio-state.edu> + Files: pp_ctl.c + + Title: "Further fix to lseek's in lockf_emulate_flock" + From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no> + Msg-ID: <199708060031.CAA07387@bombur2.uio.no>, + <199708102225.AAA16970@bombur2.uio.no> + Files: pp_sys.c + + Title: "GNU style perl --version (or any other --foo) ignored" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Kenneth Albanowski + <kjahds@kjahds.com>, Stephen McCamant <alias@mcs.com> + Msg-ID: <E0wx8MO-0007BS-00@ursa.cus.cam.ac.uk>, + <Pine.LNX.3.93.970813122557.9443C-100000@kjahds.com>, + <m0wy8nl-000EYgC@alias-2.pr.mcs.net> + Files: pod/perldiag.pod perl.c + + Title: "seen_dot declaration in perl.c needed for VMS" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708072033.QAA09167@aatma.engin.umich.edu> + Files: perl.c + + ------ DOCUMENTATION ------ + + Title: "[PATCH] -D info in perlrun", "[PATCH] Re: -D info in perlrun" + From: Stephen McCamant <alias@mcs.com>, ilya@math.ohio-state.edu (Ilya + Zakharevich) + Msg-ID: <1997Aug10.195832.2224477@hmivax.humgen.upenn.edu>, + <m0wxNNL-000EYgC@alias-2.pr.mcs.net>, + <m0wxz6l-000EYgC@alias-2.pr.mcs.net> + Files: pod/perlrun.pod + + Title: "perlop pod inconsistent in presentation of regexp options" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Hans Mulder <hansm@icgned.nl>, + jmr@whirlwind.fmr.com + Msg-ID: <199708061404.KAA06717@whirlwind.fmr.com>, + <199708081505.LAA09810@whirlwind.fmr.com>, + <1997Aug7.160530.2196011@hmivax.humgen.upenn.edu>, + <E0wwnqc-00057s-00@ursa.cus.cam.ac.uk>, + <E0wwswg-00017x-00@ursa.cus.cam.ac.uk> + Files: pod/perlop.pod + + Title: "pod2man generated .IX lines upset whatis on Solaris" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, jmr@whirlwind.fmr.com (John + Redford) + Msg-ID: <E0wxoUZ-0006Ee-00@ursa.cus.cam.ac.uk> + Files: pod/pod2man.PL + + Title: "The description of the \Q metacharacter is confusing to novices" + From: aml@world.std.com (Andrew M. Langmead) + Msg-ID: <199708101946.AA06339@world.std.com> + Files: pod/perlre.pod + + Title: "doc patch for pack("p",undef) packing a NULL pointer" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9708102159.AA11726@claudius.bfsec.bt.co.uk> + Files: pod/perldelta.pod pod/perlfunc.pod + + Title: "perlfunc.pod error" + From: Tom Christiansen <tchrist@jhereg.perl.com> + Msg-ID: <199708102235.QAA18420@jhereg.perl.com> + Files: pod/perlfunc.pod + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "patch for documentation error in FileCache.pm" + From: Mike Stok <mike@stok.co.uk>, mikebo@tellabs.com + Msg-ID: <Pine.LNX.3.95.970810143321.437C-100000@stok.co.uk> + Files: lib/FileCache.pm + + Title: "[PATCH] 5.004_02: Complex/Trig: update" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199708081842.VAA31214@alpha.hut.fi> + Files: lib/Math/Complex.pm lib/Math/Trig.pm t/lib/complex.t + + Title: "CPAN Use of uninitialized value in newest perl" + From: tom@amber.ssd.hcsc.com (Tom Horsley) + Msg-ID: <9708091738.AA16435@amber.ssd.hcsc.com> + Files: lib/CPAN.pm + + ------ PORTABILITY - WIN32 ------ + + Title: "[PATCH] /x is not a valid shell switch on Win95" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708121720.NAA14760@aatma.engin.umich.edu> + Files: win32/win32.c + + Title: "[PATCH] Win95-proofing pl2bat" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708121733.NAA14888@aatma.engin.umich.edu> + Files: MANIFEST win32/Makefile win32/makefile.mk win32/bin/pl2bat.pl + win32/bin/runperl.pl win32/bin/search.pl + win32/bin/webget.pl + + Title: "[PATCH] [OK] Perl5.004_02 on Alpha NT" + From: wmiddlet@adobe.com (William Middleton) + Msg-ID: <199708072100.OAA13141@ducks> + Files: win32/win32.c + + ------ PORTABILITY - OTHER ------ + + Title: "Improve dual-universe comments in hints/sunos_4_1.sh" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970812170358.14488E-100000@newton.phys> + Files: hints/sunos_4_1.sh + + Title: "Dynamic Loading on MkLinux (osname=linux,archname=ppc-linux)" + From: Chris Nandor <pudge@pobox.com>, Shimpei Yamashita + <shimpei@socrates.patnet.caltech.edu> + Msg-ID: <33EF1634.B36B6500@pobox.com> + Files: hints/linux.sh + + Title: "5.004_02 Configure - worrying but normal errors displayed to user" + From: Paul Marquess <pmarquess@bfsec.bt.co.uk>, pmarquess@bfsec.bt.co.uk + (Paul Marquess) + Msg-ID: <01BCA3DE.E257BFC0.pmarquess@bfsec.bt.co.uk>, + <9708102159.AA11726@claudius.bfsec.bt.co.uk> + Files: Configure os2/diff.configure + + Title: "Minor glitch with Perl 5.004_01 on SunOS 4.1.3 (groupstype)" + From: thad@thadlabs.com (Thad Floryan) + Msg-ID: <9708111415.AA03808@thadlabs.com> + Files: hints/sunos_4_1.sh + + Title: "SCO Openserver 5.0.4 - add comment to hint file re compiler bug" + From: Bill Glicker <billg@burrelles.com> + Msg-ID: <Pine.SCO.3.96.970811153021.18457A-100000@laura.burrelles.com> + Files: hints/sco.sh + + ------ UTILITIES ------ + + Title: "perlbug -d non-interactive (with patch)" + From: Ted Ashton <ashted@southern.edu> + Msg-ID: <199708071418.KAA15711@ns.southern.edu> + Files: utils/perlbug.PL + + + +---------------- +Version 5.004_02 Maintenance release 2 for 5.004 +---------------- + +"When you work you are a flute through whose + heart the whispering of the hours turns to music." + -- from The Prophet by Kahlil Gibran + + + HEADLINES FOR THIS MAINTENANCE RELEASE + + Major memory growth bug fixed. + Object destruction is more timely and orderly. + Further major enhancements to Win32 support, including: + Win32 binary compatibility between Visual C++ and Borland C++. + The -S option is now more useful on dos/Win32 (see perlrun). + Implicit -p print now checks for write errors. + DB_File now sub-classable (and other fixes). + Memory usage stats available with perl's malloc (see perldelta). + 'use UNIVERSAL;' deprecated (see perldelta). + Internal integer to string conversions are faster. + Carp can be forced to give stack traces (see perldoc Carp). + Many other bug fixes and enhancements. + + + ------ BUILD PROCESS ------ + + Title: "[PATCH] m2t3: Configure: cf_time always in C locale" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199708061827.VAA09623@alpha.hut.fi> + Files: Configure + + Title: "Configure can't find open3 on NeXTstep" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, hans@icgned.nl + (Hans Mulder) + Msg-ID: <9706271816.AA10551@ icgned.icgned.nl > + Files: Configure + + Title: "Don't use undef value in Config::myconfig" + From: "Andreas J. Koenig" <k@sissy.in-berlin.de>, Chip Salzenberg + <salzench@nielsenmedia.com> + Msg-ID: <199706271525.RAA13517@sissy.in-berlin.de> + Files: configpm + + Title: "make Configure recognize powerux hint (perl5.004_01)" + From: tom@amber.ssd.hcsc.com (Tom Horsley) + Msg-ID: <9707301938.AA08352@amber.ssd.hcsc.com> + Files: Configure + + Title: "[PATCH]: HP-UX 10 w/o transition links" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199706181851.AA093329906@hpcc123.corp.hp.com>, + <199706231650.AA070364627@hpcc123.corp.hp.com> + Files: Configure + + Title: "INSTALL updates for GNU ld and __inet_* errors" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Files: INSTALL + + ------ CORE LANGUAGE ------ + + Title: "[PATCH] Additional patch for "Can't execute ..."" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707191651.MAA04897@monk.mps.ohio-state.edu> + Files: pod/perldiag.pod perl.c + + Title: "[PATCH] Band-aid fix for local([@%]$x)" + From: Stephen McCamant <alias@mcs.com> + Msg-ID: <m0wsb7J-000EYPC@alias-2.pr.mcs.net> + Files: pod/perldiag.pod op.c pp_hot.c t/op/local.t + + Title: "[PATCH] Re: Bug in Regular Expressions when using colon as + delimiter" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0wtbhv-0005Mm-00@ursa.cus.cam.ac.uk> + Files: pod/perldiag.pod regcomp.c t/op/re_tests t/op/regexp.t + + Title: "[PATCH] Re: Can't pack literals as pointers" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708012250.SAA20278@aatma.engin.umich.edu> + Files: pod/perldiag.pod pod/perlfunc.pod pp.c t/op/pack.t + + Title: "[PATCH] Do not constant-fold ops that depend on locale if C<use + locale>" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199707210519.BAA13785@nielsenmedia.com> + Files: op.c + + Title: "Eval fails in certain situations (eval "{'...")" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707211753.NAA14940@aatma.engin.umich.edu> + Files: t/comp/term.t toke.c + + Title: "Fix memory leak on eval 'sub {}'" + From: Chip Salzenberg <chip@rio.atlantic.net> + Files: pp_ctl.c + + Title: "stringify looses integerness" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <hbu4l96z2.fsf@bergen.sn.no> + Files: sv.c + + Title: "Fix intolerance of a space between "print" and opening paren" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707011421.KAA15836@aatma.engin.umich.edu> + Files: toke.c + + Title: "[PATCH] Re: Calling Perl from within C from within Perl" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706301842.OAA05569@aatma.engin.umich.edu> + Files: perl.c + + Title: "UNIVERSAL.pm and import methods (tests)" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0whfHh-0007bW-00@ursa.cus.cam.ac.uk> + Files: t/op/universal.t universal.c + + Title: "Avoid core dump on some paren'd regexp matches", "One-liner regex + causes SEGV on 5.003 under HP-UX and Linux" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199706261236.NAA03472@crypt.compulink.co.uk>, + <199707061144.MAA04443@crypt.compulink.co.uk> + Files: regexec.c t/op/re_tests + + Title: "Forbid negative splice offset beyond array start" + From: "John L. Allen" <allen@gateway.grumman.com>, Chip Salzenberg + <chip@rio.atlantic.net> + Msg-ID: <Pine.SOL.3.91.970625111744.19300A-100000@gateway> + Files: pp.c + + Title: "Forbid "goto" into middle of foreach loop" + From: Chip Salzenberg <chip@rio.atlantic.net> + Files: pod/perldiag.pod pp_ctl.c + + Title: "Fix C<qq #hi#>" + From: Chip Salzenberg <chip@rio.atlantic.net> + Files: toke.c + + Title: "bless file handles as FileHandle if loaded else IO::Handle" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <hyb80drrz.fsf@bergen.sn.no> + Files: gv.c lib/FileHandle.pm + + Title: "infinite recursion in malloc() with some compile flags" + From: Hans Mulder <hansmu@xs4all.nl> + Msg-ID: <199706240050.CAA10550@xs2.xs4all.nl> + Files: malloc.c + + Title: "sv_vcatpvfn hogs memory [Patch included]" + From: Matthias Neeracher <neeri@iis.ee.ethz.ch> + Msg-ID: <199706211521.RAA12778@solar.ethz.ch> + Files: sv.c + + Title: "Fix '-' flag on sprintf() of floats" + From: Chip Salzenberg <chip@rio.atlantic.net>, Jarkko Hietaniemi + <jhi@iki.fi> + Msg-ID: <199705270646.JAA02510@alpha.hut.fi> + Files: sv.c + + Title: "Free temps before calling END blocks", "Too late destruction" + From: Chip Salzenberg <chip@rio.atlantic.net> + Msg-ID: <m33erfv5hx.fsf@chany-p100.emwp.com> + Files: perl.c + + Title: "Fix C<print $foo x 2> parsing" + From: "Chuck D. Phillips (NON-HP Employee)" <cdp@hpescdp.fc.hp.com>, Chip + Salzenberg <chip@rio.atlantic.net> + Msg-ID: <199706121737.KAA00503@palrel3.hp.com> + Files: toke.c + + Title: "Fix lockf_emulate_flock() positioning" + From: Chip Salzenberg <chip@rio.atlantic.net>, gen@atd.rdc.ricoh.co.jp + Msg-ID: <199706091132.UAA00895@wampa.atd.rdc.ricoh.co.jp> + Files: pp_sys.c + + Title: "Don't use atol() for unsigned values", "signedness problem in + pack("N", "value");" + From: Chip Salzenberg <chip@rio.atlantic.net>, Roger Espel Llima + <espel@llaic.univ-bpclermont.fr> + Msg-ID: <19970531200007.40218@llaic.univ-bpclermont.fr> + Files: sv.c + + Title: "Don't warn about "${foo}" in string, even if &foo exists" + From: Chip Salzenberg <chip@rio.atlantic.net> + Files: toke.c + + Title: "[PATCH] -p does not check for failure of implicit print" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v0311070aafea3fa83061@[194.51.248.75]> + Files: pod/perldiag.pod pod/perlrun.pod toke.c + + Title: "Fix double form() in XS version check" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707150010.UAA00816@monk.mps.ohio-state.edu> + Files: XSUB.h + + Title: "Constant-fold sprintf()" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Files: opcode.pl + + Title: "[PATCH] Fix double form() in XS version check" + From: Chip Salzenberg <salzench@nielsenmedia.com> + Msg-ID: <199707210518.BAA13771@nielsenmedia.com> + Files: XSUB.h + + Title: "[PATCH] Make DEBUGGING_MSTATS info consistent" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu> + Msg-ID: <Pine.SUN.3.96.970731131529.3740A-100000@newton.phys> + Files: INSTALL pod/perldelta.pod perl.h + + Title: "Minor Win32 glitch with -S flag" + From: Warren Jones <wjones@tc.fluke.com> + Msg-ID: <97Jun19.150511pdt.35717-2@gateway.fluke.com> + Files: perl.c + + Title: "Slightly safer signals" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: mg.c perl.c + + Title: "Time::Local patch (plus perl.c and filehand.t)" + From: ilya@math.ohio-state.edu (Ilya Zakharevich) + Files: lib/Time/Local.pm perl.c t/lib/filehand.t + + Title: "[PATCH] Weirdness in sv_peek()" + From: Stephen McCamant <alias@mcs.com> + Msg-ID: <m0wsEMU-000EYLC@alias-2.pr.mcs.net>, + <m0wsf7Y-000EYPC@alias-2.pr.mcs.net> + Files: sv.c + + Title: "Win32 UNC path causes autoload to fail" + From: Warren Jones <wjones@tc.fluke.com> + Msg-ID: <97Jun18.163826pdt.35714-1@gateway.fluke.com> + Files: pp_ctl.c + + Title: "[PATCH]: reduced malloc patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707150829.EAA01291@monk.mps.ohio-state.edu> + Files: av.c + + Title: "[PATCH] $\1 and serious bug in evalling" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707262127.RAA12883@monk.mps.ohio-state.edu> + Files: pp_ctl.c + + Title: "Faster int to string conversion", "[PATCH} Re: memory leak in buffer + safety code" + From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden + <hv@crypt.compulink.co.uk>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199707140912.KAA09935@crypt.compulink.co.uk>, + <199707142050.QAA20976@rio.atlantic.net>, + <199707182035.VAA20990@crypt.compulink.co.uk>, + <9707151040.AA02883@toad.ig.co.uk> + Files: global.sym sv.c + + Title: "object never destructs" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707131955.PAA29655@aatma.engin.umich.edu> + Files: scope.c t/op/ref.t + + Title: "[PATCH] -S flag fixes for DOSISH platforms", "[RESEND] [PATCH] -S + flag fixes for DOSISH platforms" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707250043.UAA02385@aatma.engin.umich.edu>, + <199707301828.OAA19508@aatma.engin.umich.edu> + Files: pod/perldiag.pod pod/perlrun.pod perl.c + + Title: "Perldb internal flag rehaul" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: pod/perldebug.pod pod/perlvar.pod perl.h gv.c mg.c op.c perl.c + pp_ctl.c pp_hot.c pp_sys.c sv.c toke.c + + Title: "[PATCH] Re: q and escaping paired delimiters" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Kenneth Albanowski + <kjahds@kjahds.com> + Msg-ID: <199707280516.BAA14055@aatma.engin.umich.edu>, + <Pine.LNX.3.93.970727172201.350K-100000@kjahds.com>, + <Pine.LNX.3.93.970728013540.350U-100000@kjahds.com> + Files: t/base/lex.t toke.c + + Title: "Enable PERL_DEBUG_MSTATS without -DDEBUGGING_MSTATS" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707150829.EAA01291@monk.mps.ohio-state.edu> + Files: malloc.c perl.c + + Title: "semctl broken under Linux" + From: Andreas Schwab <schwab@LS5.informatik.uni-dortmund.de>, Andreas + Schwab <schwab@issan.informatik.uni-dortmund.de>, Graham + Barr <gbarr@ti.com>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <33C38291.2D9302DA@ti.com>, + <9707040912.AA03470@issan.informatik.uni-dortmund.de>, + <9707041538.AA08946@toad.ig.co.uk>, + <9707070924.AA11774@issan.informatik.uni-dortmund.de>, + <9707090933.AA19012@issan.informatik.uni-dortmund.de> + Files: doio.c + + Title: "[PATCH] m2t2: problem in NetBSD 1.2D with sfio" + From: Jarkko Hietaniemi <jhi@iki.fi> + Files: perl.h + + Title: "fix substr fix (tests 27 etc)", "perl5.004_02 trial 1 available + (with substr bug and still some" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Hugo van der Sanden + <hv@crypt.compulink.co.uk>, Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199707301759.SAA02899@crypt.compulink.co.uk>, + <199707302228.BAA18032@alpha.hut.fi>, + <199707310929.KAA06515@crypt.compulink.co.uk>, + <E0wtruH-0002JM-00@ursa.cus.cam.ac.uk> + Files: pp.c + + Title: "Fwd: substr("foo", -1000)", "substr: warn if substring doesn't + intersect original at all" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199707100655.JAA14924@alpha.hut.fi>, + <E0wm1JG-0000UY-00@taurus.cus.cam.ac.uk> + Files: pod/perlfunc.pod pp.c t/op/substr.t + + Title: "[PATCH] work around compiler bug on CX/UX (perl5.004_01)" + From: tom@amber.ssd.hcsc.com (Tom Horsley) + Msg-ID: <9707301934.AA18594@amber.ssd.hcsc.com> + Files: hints/cxux.sh pp.c + + ------ DOCUMENTATION ------ + + Title: "Duplicates in perlguts.pod" + From: hans@icgned.nl (Hans Mulder) + Msg-ID: <9707082346.AA13231@ icgned.icgned.nl > + Files: pod/perlguts.pod + + Title: "Better "Can't locate auto/%s.al in @INC" error documentation" + From: ilya@math.ohio-state.edu (Ilya Zakharevich) + Msg-ID: <1997Jun24.195847.2091744@hmivax.humgen.upenn.edu> + Files: pod/perldiag.pod + + Title: "new perlembed.pod:match.c" + From: Doug MacEachern <dougm@opengroup.org> + Msg-ID: <199707170355.XAA21370@postman.opengroup.org> + Files: pod/perlembed.pod + + Title: "Document bug fix in localization of $1 etc." + From: Chip Salzenberg <salzench@nielsenmedia.com> + Files: pod/perldelta.pod + + Title: "[PATCH] Major goof in XS Tutorial regarding subdirs" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707260920.FAA12453@monk.mps.ohio-state.edu> + Files: pod/perlxstut.pod + + Title: "[PATCH] Magic info in perlguts, take 2" + From: Stephen McCamant <alias@mcs.com> + Msg-ID: <m0wr6P8-000EYLC@alias-2.pr.mcs.net> + Files: pod/perlguts.pod + + Title: "[BUG:PATCH] Missing semicolon message wrong in perldiag" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0welEn-0002vT-00@taurus.cus.cam.ac.uk>, + <E0wfRJU-0006Aw-00@taurus.cus.cam.ac.uk> + Files: pod/perldiag.pod + + Title: "[PATCH] Updates to perlguts (repost)" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707152223.SAA00776@monk.mps.ohio-state.edu> + Files: pod/perlguts.pod + + Title: "[BUG:47:LOG] Dropped "and" in pod2man" + From: hans@icgned.nl (Hans Mulder) + Msg-ID: <9707082355.AA13254@ icgned.icgned.nl > + Files: pod/pod2man.PL + + Title: "[BUG] perlembed.pod:power.c example" + From: Doug MacEachern <dougm@opengroup.org> + Msg-ID: <199707181344.JAA10565@postman.opengroup.org> + Files: pod/perlembed.pod + + Title: "[PATCH] arguments swapped in perlapio.pod" + From: Hans Mulder <hansmu@xs4all.nl> + Msg-ID: <199706240049.CAA10534@xs2.xs4all.nl> + Files: pod/perlapio.pod + + Title: "[PATCH] cool quote for perldebug" + From: Greg Bacon <gbacon@adtrn-srv4.adtran.com> + Msg-ID: <199707292140.QAA28579@adtrn-srv4.adtran.com> + Files: pod/perldebug.pod + + Title: "[PATCH] multiline commands in qx//" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707212350.TAA18496@aatma.engin.umich.edu> + Files: pod/perlfunc.pod pod/perlop.pod + + Title: "patch to 5.004_01 perltrap.pod" + From: jmm@revenge.elegant.com (John Macdonald) + Msg-ID: <9706231525.AA22790@revenge.elegant.com> + Files: pod/perltrap.pod + + Title: "perl4 to perl5.004 converion with debugger problem" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0wdKJY-00010w-00@taurus.cus.cam.ac.uk> + Files: pod/perltrap.pod + + Title: "done3/perlbook.pod" + From: Randal Schwartz <merlyn@gadget.cscaper.com> + Files: pod/perlbook.pod + + Title: "[PATCH] readline and readpipe are undocumented" + From: Hans Mulder <hansmu@xs4all.nl> + Files: pod/perlfunc.pod + + Title: "Document use of - in a regex char class." + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03102804afd578bcef2c@[194.51.248.88]> + Files: pod/perlre.pod + + Title: "[PATCH] splitpod broken in 5.004_01" + From: Hans Mulder <hansmu@xs4all.nl>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199706240048.CAA10515@xs2.xs4all.nl>, + <9706241612.AA09119@toad.ig.co.uk> + Files: pod/splitpod + + ------ LIBRARY AND EXTENSIONS ------ + + Title: "Carp::cluck() and -MCarp=verbose" + From: Tim.Bunce@ig.co.uk, epeschko@elmer.tci.com (Ed Peschko) + Msg-ID: <199708060607.AAA16681@den-mdev1.tci.com>, + <199708062105.PAA09878@den-mdev1.tci.com> + Files: lib/Carp.pm + + Title: "Warning from calls using "use Shell"" + From: Andrew Pimlott <pimlott@abel.math.harvard.edu> + Msg-ID: <Pine.SOL.3.91.970806173903.7320H-100000@abel> + Files: lib/Shell.pm + + Title: "confessing a carp" + From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden + <hv@crypt.compulink.co.uk>, Nick Ing-Simmons + <nick@ni-s.u-net.com>, Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <199708052155.WAA25393@crypt.compulink.co.uk>, + <199708060721.IAA30894@crypt.compulink.co.uk>, + <199708061533.LAA01313@rio.atlantic.net>, + <33E79BE2.4E6F@ni-s.u-net.com>, + <33E8E3C5.62C@ni-s.u-net.com>, + <9708051619.AA13764@toad.ig.co.uk> + Files: lib/Carp.pm + + Title: "[BUG:PATCH] dumpvar.pl parses some references incorrectly" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0wwAjQ-0004l6-00@ursa.cus.cam.ac.uk> + Files: lib/dumpvar.pl + + Title: "[PATCH] m2t3: minor doc patch (to obsolete I18N::Collate)" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199708060732.KAA02675@alpha.hut.fi> + Files: lib/I18N/Collate.pm + + Title: "[PATCH] Binary installers for Perl modules" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707210006.UAA06165@monk.mps.ohio-state.edu> + Files: lib/ExtUtils/Install.pm + + Title: "m2t2 broke CPAN.pm :-(" + From: a.koenig@kulturbox.de (Andreas J. Koenig) + Files: lib/CPAN.pm lib/Bundle/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm + + Title: "[PATCH] CPAN.pm on OS/2" + From: "Andreas J. Koenig" <k@anna.in-berlin.de>, Ilya Zakharevich + <ilya@math.ohio-state.edu> + Msg-ID: <199707180415.AAA03180@monk.mps.ohio-state.edu>, + <199707181407.QAA12920@anna.in-berlin.de> + Files: lib/CPAN.pm + + Title: "Docs of IO::Handle [PATCH]" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707222307.TAA08380@monk.mps.ohio-state.edu> + Files: ext/IO/lib/IO/Handle.pm + + Title: "Exporter errors give wrong location" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0wdJra-0000n8-00@taurus.cus.cam.ac.uk> + Files: lib/Exporter.pm + + Title: "[PATCH] Exporter new export_to_level method" + From: epeschko@elmer.tci.com (Ed Peschko) + Files: lib/Exporter.pm + + Title: "DB_File produces spurious output when trapping __DIE__" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9706302125.AA28254@claudius.bfsec.bt.co.uk> + Files: ext/DB_File/DB_File.pm + + Title: "Remove 'use UNIVERSAL;', switch to UNIVERSAL::isa()" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0whaZJ-0007BA-00@ursa.cus.cam.ac.uk> + Files: lib/Class/Struct.pm lib/File/Compare.pm lib/File/Copy.pm + + Title: "perl5.004 Time::Local still broken" + From: Mathias Koerber <mathias@dnssec1.singnet.com.sg> + Msg-ID: <199706260452.MAA22647@dnssec1.singnet.com.sg> + Files: lib/Time/Local.pm + + Title: "Sys::Hostname should localize $SIG{__DIE__}" + From: Ken Shan <ken@digitas.harvard.edu> + Msg-ID: <199707070357.XAA18065@digitas.harvard.edu> + Files: lib/Sys/Hostname.pm + + Title: "xsubpp patch" + From: John Tobey <jtobey@user1.channel1.com> + Msg-ID: <199707010221.CAA01234@remote133> + Files: lib/ExtUtils/xsubpp + + Title: "DB_File 1.15 patch" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9707192117.AA01973@claudius.bfsec.bt.co.uk> + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DB_File/typemap + t/lib/db-btree.t t/lib/db-hash.t t/lib/db-recno.t + + Title: "Problems with setvbuf" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707250040.UAA11000@monk.mps.ohio-state.edu> + Files: ext/IO/IO.xs + + Title: "[PATCH] Repost of fork() debugger patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707252101.RAA11846@monk.mps.ohio-state.edu> + Files: lib/perl5db.pl lib/Term/ReadLine.pm + + Title: "IO::File and DB_File pollutes namespace with Fcntl constants" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <h205qyijy.fsf@bergen.sn.no> + Files: ext/IO/lib/IO/File.pm + + Title: "[MM] [PATCH] Re: Liblist problems for MSWin32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706182152.RAA20273@aatma.engin.umich.edu> + Files: lib/ExtUtils/Liblist.pm + + Title: "Net::hostent documentation error" + From: gnat@frii.com + Msg-ID: <199707082222.QAA24728@elara.frii.com> + Files: lib/Net/hostent.pm + + Title: "PATCH: make DBM*_File modules sub-classable" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9707121854.AA19472@claudius.bfsec.bt.co.uk> + Files: ext/GDBM_File/typemap ext/NDBM_File/typemap + ext/ODBM_File/ODBM_File.xs ext/SDBM_File/typemap + t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t + + Title: "Sys::Syslog patch to allow unix domain sockets" + From: Sean Robinson <robinson_s@sc.maricopa.edu> + Msg-ID: <33B31342.7EB16A44@sc.maricopa.edu> + Files: lib/Sys/Syslog.pm + + Title: "'use UNIVERSAL;' deprecated, do C<UNIVERSAL::isa()> instead", + "UNIVERSAL.pm and import methods" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Gisle Aas <aas@bergen.sn.no>, + Graham Barr <gbarr@ti.com>, Gurusamy Sarathy + <gsar@engin.umich.edu>, Hugo van der Sanden + <hv@crypt.compulink.co.uk> + Msg-ID: <199706271701.NAA25664@aatma.engin.umich.edu>, + <199706271904.UAA00120@crypt.compulink.co.uk>, + <199706272054.QAA28913@aatma.engin.umich.edu>, + <199706301554.LAA03763@aatma.engin.umich.edu>, + <33B22248.7D7C1985@ti.com>, + <E0wf5TN-0006ps-00@taurus.cus.cam.ac.uk>, + <E0wguTR-0005bs-00@ursa.cus.cam.ac.uk>, + <E0whaZJ-0007BA-00@ursa.cus.cam.ac.uk>, + <E0whfHh-0007bW-00@ursa.cus.cam.ac.uk>, + <E0wiyUG-00073j-00@taurus.cus.cam.ac.uk>, + <hiuyv6q9k.fsf@bergen.sn.no> + Files: lib/Class/Struct.pm lib/File/Compare.pm lib/File/Copy.pm + t/op/universal.t universal.c + + Title: "[MM] Small patch to MakeMaker, new release" + From: "Andreas J. Koenig" <k@anna.in-berlin.de> + Msg-ID: <199706281603.SAA10869@anna.in-berlin.de> + Files: lib/ExtUtils/Command.pm lib/ExtUtils/Install.pm + lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm + lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm + + Title: "ExtUtils-Embed upgrade" + From: Doug MacEachern <dougm@opengroup.org> + Files: lib/ExtUtils/Embed.pm + + Title: "[PATCH] icmp tweak for IO::Socket" + From: Nick.Ing-Simmons@tiuk.ti.com + Msg-ID: <199707041240.NAA21484@pluto.tiuk.ti.com> + Files: ext/IO/lib/IO/Socket.pm + + Title: "Allow concurrent mkdir in File::Path::mkpath" + From: schattev@imb-jena.de (Ruben Schattevoy) + Msg-ID: <199707300943.LAA21574@kant.imb-jena.de> + Files: lib/File/Path.pm + + Title: "CPAN.pm, $VERSION and nested (bundled) modules." + From: a.koenig@kulturbox.de (Andreas J. Koenig) + Files: lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm + lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm + lib/ExtUtils/Mksymlists.pm + + Title: "[PATCH] perl debugger, win32, and emacs" + From: Jay Rogers <jay@rgrs.com> + Msg-ID: <199707311759.NAA13276@crooked-i.mitre.org> + Files: lib/perl5db.pl + + Title: "[PATCH] pod2html mangles C<&foo(42);>" + From: Hans Mulder <hansmu@xs4all.nl> + Msg-ID: <199706250057.CAA10162@xs1.xs4all.nl> + Files: lib/Pod/Html.pm + + Title: "[PATCH] posix.xs broken on VMS 7.1" + From: Dan Sugalski <sugalsd@lbcc.cc.or.us> + Msg-ID: <3.0.2.32.19970718095755.00875ba0@stargate.lbcc.cc.or.us> + Files: ext/POSIX/POSIX.xs + + Title: "MM_Unix.pm nits for Win32 DMAKE" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708032051.QAA14248@aatma.engin.umich.edu> + Files: lib/ExtUtils/MM_Unix.pm + + Title: "Sys::Hostname -w unclean in trial 2" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708032055.QAA14278@aatma.engin.umich.edu> + Files: lib/Sys/Hostname.pm + + Title: "(3) File::Find::find()/finddepth() bugs with toplevel paths" + From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com> + Msg-ID: <199707040045.RAA24459@mailgate2.boeing.com> + Files: lib/File/Find.pm + + ------ OTHER CHANGES ------ + + Title: "EMERGENCY_SBRK or PERL_EMERGENCY_SBRK ?" + From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, + ilya@math.ohio-state.edu (Ilya Zakharevich) + Msg-ID: <1997Aug1.191631.2167470@hmivax.humgen.upenn.edu>, + <Pine.SUN.3.96.970801134400.4393F-100000@newton.phys> + Files: + Files: + + ------ PORTABILITY - WIN32 ------ + + Title: "[PATCH] Embedding threaded apps in perl.dll" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707261518.LAA24346@aatma.engin.umich.edu>, + <199707301833.OAA19570@aatma.engin.umich.edu> + Files: win32/win32.c + + Title: "Minor fix for pl2bat.bat", "[PATCH] Re: Minor fix for pl2bat.bat" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Warren Jones + <wjones@tc.fluke.com> + Msg-ID: <199707061843.OAA23874@aatma.engin.umich.edu>, + <97Jun24.115804pdt.35752-2@gateway.fluke.com> + Files: win32/bin/pl2bat.bat + + Title: "WIN32 Build - pod2xxx.bat Missing?", "[PATCH] Re: WIN32 Build - + pod2xxx.bat Missing?" + From: Chris Williams <chrisw@netinfo.com.au>, Gurusamy Sarathy + <gsar@engin.umich.edu> + Msg-ID: <199707011423.KAA15855@aatma.engin.umich.edu>, + <33B8B962.D96FA1F5@netinfo.com.au> + Files: win32/Makefile win32/makefile.mk + + Title: "[PATCH] Win32 sitelib intuition from DLL location" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706231647.MAA23260@aatma.engin.umich.edu> + Files: win32/win32.h win32/config_h.PL win32/win32.c + + Title: "[PATCH] binary coexistence on win32", "[RESEND] [PATCH] binary + coexistence on win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707250109.VAA02666@aatma.engin.umich.edu>, + <199707301829.OAA19516@aatma.engin.umich.edu> + Files: lib/ExtUtils/Mksymlists.pm win32/win32.h win32/win32io.h + win32/win32iop.h win32/makedef.pl win32/win32.c + win32/win32io.c + + Title: "[PATCH] docs for win32 utilities" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707250045.UAA02510@aatma.engin.umich.edu> + Files: win32/bin/pl2bat.bat win32/bin/runperl.bat + + Title: "[PATCH] exec() fixed on win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706241525.LAA06554@aatma.engin.umich.edu> + Files: win32/win32.h win32/win32io.h win32/win32iop.h README.win32 doio.c + win32/config_H.bc win32/config_H.vc win32/makedef.pl + win32/win32.c win32/win32io.c + + Title: "[PATCH] getenv() after my_setenv() gets old entry on Win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706231700.NAA23400@aatma.engin.umich.edu> + Files: win32/win32.h win32/win32.c + + Title: "[PATCH] getservby*() calls fail on Windows NT" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199706231654.MAA23276@aatma.engin.umich.edu> + Files: win32/win32sck.c + + Title: "[PATCH] minor win32 scribbles" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Hugo van der Sanden + <hv@crypt.compulink.co.uk> + Msg-ID: <199707262307.TAA28410@aatma.engin.umich.edu>, + <199707270832.JAA19399@crypt.compulink.co.uk> + Files: pod/perldelta.pod README.win32 win32/Makefile win32/config.bc + win32/config.vc win32/makefile.mk + + Title: "[PATCH] trial2: some batch files won't run" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708040226.WAA17301@aatma.engin.umich.edu> + Files: win32/bin/pl2bat.bat win32/bin/runperl.bat + + Title: "[PATCH] win32 docs and runperl.bat" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707070446.AAA29560@aatma.engin.umich.edu> + Files: MANIFEST README.win32 win32/bin/pl2bat.bat win32/bin/runperl.bat + + Title: "[PATCH] win32 extras and embedding" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707250232.WAA03421@aatma.engin.umich.edu>, + <199707301831.OAA19528@aatma.engin.umich.edu> + Files: dosish.h win32/win32.h perl.c win32/config.bc win32/config_H.bc + win32/makedef.pl win32/perllib.c win32/win32.c + + Title: "[PATCH] win32 tweaks" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707042150.RAA01065@aatma.engin.umich.edu> + Files: win32/win32.h win32/win32.c + + Title: "[PATCH] win32_stat() fixes (2nd try)" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708040137.VAA16810@aatma.engin.umich.edu> + Files: t/op/stat.t win32/win32iop.h win32/win32.c + + ------ PORTABILITY - OTHER ------ + + Title: "Additional OS/2 patches" + From: Gurusamy Sarathy <gsar@engin.umich.edu>, Ilya Zakharevich + <ilya@math.ohio-state.edu> + Msg-ID: <199708020823.EAA19521@monk.mps.ohio-state.edu>, + <199708021424.KAA28561@aatma.engin.umich.edu>, + <199708042108.RAA27671@aatma.engin.umich.edu> + Files: README.os2 os2/Changes perl.c + + Title: "Additional patch is needed for os2/diff.configure" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199708020745.DAA19483@monk.mps.ohio-state.edu> + Files: os2/diff.configure + + Title: "Assorted OS/2 fixes" + From: ilya@math.ohio-state.edu (Ilya Zakharevich) + Msg-ID: <1997Jun16.163234.2091727@hmivax.humgen.upenn.edu> + Files: hints/os2.sh os2/diff.configure os2/os2ish.h README.os2 os2/Changes + os2/Makefile.SHs os2/os2.c util.c + + Title: "[PATCH] Changes for VMS 7.1 support" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>, Dan Sugalski + <sugalsd@lbcc.cc.or.us> + Msg-ID: <01ILDXUH0J1W00026U@hmivax.humgen.upenn.edu>, + <3.0.2.32.19970718095935.0087a2d0@stargate.lbcc.cc.or.us> + Files: vms/sockadapt.h vms/config.vms vms/sockadapt.c + + Title: "[PATCH] Easier TCP stack selection for VMS" + From: Dan Sugalski <sugalsd@lbcc.cc.or.us> + Msg-ID: <3.0.1.32.19970624151939.00994490@stargate.lbcc.cc.or.us> + Files: vms/descrip.mms + + Title: "Minor VMS patches" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01ILCUO6XXTE000WFK@hmivax.humgen.upenn.edu> + Files: lib/ExtUtils/MM_VMS.pm vms/vmsish.h vms/descrip.mms vms/test.com + vms/vms.c vms/ext/filespec.t + + Title: "[PATCH] Two un-disabled tests for VMS" + From: Dan Sugalski <sugalsd@lbcc.cc.or.us> + Msg-ID: <3.0.2.32.19970718095842.00879220@stargate.lbcc.cc.or.us> + Files: vms/test.com + + Title: "fixes for hints/svr4 for UnixWare >= 2.1.1" + From: John Hughes <john@titanic.atlantech.com> + Msg-ID: <199707021230.OAA24230@titanic.AtlanTech.COM> + Files: hints/svr4.sh + + Title: "make depend loop fix and minor OS/2 improvements to build process" + From: ilya@math.ohio-state.edu (Ilya Zakharevich) + Files: Makefile.SH hints/os2.sh os2/Makefile.SHs + + ------ TESTS ------ + + Title: "Add xor tests to test suite" + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Msg-ID: <199706250730.IAA06097@crypt.compulink.co.uk> + Files: t/comp/cmdopt.t + + Title: "[PATCH] enable some tests on Win32" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199707250029.UAA02351@aatma.engin.umich.edu> + Files: t/op/magic.t + + Title: "Fix up problems with *DBM tests" + From: Paul Marquess <pmarquess@bfsec.bt.co.uk> + Files: t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t + + ------ UTILITIES ------ + + Title: "[PATCH] m2t3: utils/perlbug.PL: -ok report is not a bug" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199708071022.NAA13008@alpha.hut.fi> + Files: utils/perlbug.PL + + Title: "perlbug - check sendmail and fix win32 tmp path" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199708060349.XAA15895@aatma.engin.umich.edu> + Files: utils/perlbug.PL + + Title: "OK: perl <some_version> on <some_system> (corrected)", "enhancements + to perlbug -ok" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Stephen McCamant <alias@mcs.com> + Msg-ID: <E0wukVt-0006Da-00@ursa.cus.cam.ac.uk>, + <E0wvMQl-00055y-00@ursa.cus.cam.ac.uk>, + <m0wv81x-000EYPC@alias-2.pr.mcs.net> + Files: utils/Makefile utils/perlbug.PL + + Title: "perlbug -ok [PATCH]" + From: "Charles F. Randall" <crandall@free.click-n-call.com> + Msg-ID: <199706181824.MAA04082@free.click-n-call.com> + Files: utils/perlbug.PL + + Title: "perlbug broken" + From: Andreas Schwab <schwab@issan.informatik.uni-dortmund.de> + Msg-ID: <9707040912.AA03466@issan.informatik.uni-dortmund.de> + Files: utils/perlbug.PL + + Title: "[PATCH] perlbug under OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707180333.XAA03102@monk.mps.ohio-state.edu> + Files: utils/perlbug.PL + + Title: "perldoc doesn't grok Win32 UNC paths" + From: Warren Jones <wjones@tc.fluke.com> + Msg-ID: <97Jun17.184420pdt.35728-1@gateway.fluke.com>, + <97Jun18.165618pdt.35713-1@gateway.fluke.com> + Files: utils/perldoc.PL + + Title: "[PATCH] perldoc under OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199707180340.XAA03114@monk.mps.ohio-state.edu> + Files: utils/perldoc.PL + + Title: "h2ph corrections to avoid redefined sub warnings" + From: wdconsta <wdconsta@cs.adelaide.edu.au> + Msg-ID: <Pine.SV4.3.93.970708143446.23808A-100000@florence.teaching.cs.adelaide.edu.au> + Files: utils/h2ph.PL + + + +---------------- Version 5.004_01 Maintenance release 1 for 5.004 ---------------- @@ -740,7 +740,7 @@ loclibpth="/usr/local/lib /opt/local/lib /usr/gnu/lib" loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" : general looking path for locating libraries -glibpth="/shlib /usr/shlib /lib/pa1.1 /usr/lib/large" +glibpth="/shlib /usr/shlib /usr/lib/pa1.1 /usr/lib/large" glibpth="$glibpth /lib /usr/lib $xlibpth" glibpth="$glibpth /lib/large /usr/lib/small /lib/small" glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib" @@ -1781,6 +1781,10 @@ EOM bsd386) osname=bsd386 osvers=`$uname -r` ;; + powerux | power_ux | powermax_os | powermaxos | \ + powerunix | power_unix) osname=powerux + osvers="$3" + ;; next*) osname=next ;; solaris) osname=solaris case "$3" in @@ -2049,7 +2053,7 @@ esac : who configured the system -cf_time=`$date 2>&1` +cf_time=`LC_ALL=C; export LC_ALL; $date 2>&1` cf_by=`(logname) 2>/dev/null` case "$cf_by" in "") cf_by=`(whoami) 2>/dev/null` @@ -3815,17 +3819,17 @@ if sh -c "$cc $optimize $ccflags -o try try.c $ldflags $libs" >>try.msg 2>&1; th dflt=n else echo "The program compiled OK, but exited with status $?." >>try.msg - rp="You have a problem. Shall I abort Configure" + rp="You have a problem. Shall I abort Configure (and explain the problem)" dflt=y fi else echo "I can't compile the test program." >>try.msg - rp="You have a BIG problem. Shall I abort Configure" + rp="You have a BIG problem. Shall I abort Configure (and explain the problem)" dflt=y fi case "$dflt" in y) - $cat try.msg + $cat try.msg >&4 case "$knowitall" in '') echo "(The supplied flags might be incorrect with this C compiler.)" @@ -6383,7 +6387,7 @@ main() { EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ - $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then + $cc $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then h_sysfile=true; echo "<sys/file.h> defines the O_* constants..." >&4 if ./open3; then @@ -6394,7 +6398,7 @@ if $test `./findhdr sys/file.h` && \ val="$undef" fi elif $test `./findhdr fcntl.h` && \ - $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then + $cc $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then h_fcntl=true; echo "<fcntl.h> defines the O_* constants..." >&4 if ./open3; then @@ -123,6 +123,10 @@ are simplified. For example, if you use prefix=/opt/perl, then Configure will suggest /opt/perl/lib instead of /opt/perl/lib/perl5/. +NOTE: You must not specify an installation directory that is below +your perl source directory. If you do, installperl will attempt +infinite recursion. + 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 @@ -661,20 +665,9 @@ In a future version of perl, these might be enabled by default. =over 4 -=item -DDEBUGGING_MSTATS - -If DEBUGGING_MSTATS is defined, you can extract malloc -statistics from the Perl interpreter. The overhead this imposes is not -large (perl just twiddles integers at malloc/free/sbrk time). When you -run perl with the environment variable PERL_DEBUG_MSTATS set to -either 1 or 2, the interpreter will dump statistics to stderr at exit -time and (with a value of 2) after compilation. If you install the -Devel::Peek module you can get the statistics whenever you like by -invoking its mstat() function. +=item -DPERL_EMERGENCY_SBRK -=item -DEMERGENCY_SBRK - -If EMERGENCY_SBRK is defined, running out of memory need not be a +If PERL_EMERGENCY_SBRK is defined, running out of memory need not be a fatal error: a memory pool can allocated by assigning to the special variable $^M. See perlvar(1) for more details. @@ -986,6 +979,10 @@ invoke Configure with for Solaris systems. For a SunOS system, you must use -B/bin/ instead. +Alternatively, recent versions of GNU ld reportedly work if you +include C<-Wl,-export-dynamic> in the ccdlflags variable in +config.sh. + =item ld.so.1: ./perl: fatal: relocation error: If you get this message on SunOS or Solaris, and you're using gcc, @@ -1045,6 +1042,18 @@ problem is probably that Configure failed to detect your system's fork() function. Follow the procedure in the previous items on L<"vsprintf"> and L<"nm extraction">. +=item __inet_* errors + +If you receive unresolved symbol errors during Perl build and/or test +referring to __inet_* symbols, check to see whether BIND 8.1 is +installed. It installs a /usr/local/include/arpa/inet.h that refers to +these symbols. Versions of BIND later than 8.1 do not install inet.h +in that location and avoid the errors. You should probably update to a +newer version of BIND. If you can't, you can either link with the +updated resolver library provided with BIND 8.1 or rename +/usr/local/bin/arpa/inet.h during the Perl build and test process to +avoid the problem. + =item Optimizer If you can't compile successfully, try turning off your compiler's @@ -1145,10 +1154,14 @@ Machines with half-implemented dbm routines will need to #undef I_ODBM =head1 make test -This will run the regression tests on the perl you just made. If it -doesn't say "All tests successful" then something went wrong. See the -file t/README in the t subdirectory. Note that you can't run the -tests in background if this disables opening of /dev/tty. +This will run the regression tests on the perl you just made (you +should run plain 'make' before 'make test' otherwise you won't have a +complete build). If 'make test' doesn't say "All tests successful" +then something went wrong. See the file t/README in the t subdirectory. + +If you want to run make test in the background you should +Note that you can't run the tests in background if this disables +opening of /dev/tty. 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 @@ -1410,4 +1423,4 @@ feedback from the perl5-porters@perl.org folks. =head1 LAST MODIFIED -$Id: INSTALL,v 1.18 1997/05/29 18:24:10 doughera Exp $ +$Id: INSTALL,v 1.22 1997/08/01 15:39:14 doughera Released $ @@ -827,10 +827,10 @@ win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/TEST Win32 port win32/autosplit.pl Win32 port win32/bin/network.pl Win32 port -win32/bin/pl2bat.bat Win32 port -win32/bin/search.bat Win32 port -win32/bin/test.bat Win32 port -win32/bin/webget.bat Win32 port +win32/bin/pl2bat.pl wrap perl scripts into batch files +win32/bin/runperl.pl run perl script via batch file namesake +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.vc Win32 base line config.sh (Visual C++ build) diff --git a/Makefile.SH b/Makefile.SH index e18c3d6ba9..f2c5260be1 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -359,9 +359,18 @@ install.perl: all installperl install.man: all installman ./perl installman -# Not implemented yet. -#install.html: all installhtml -# ./perl installhtml +# XXX Experimental. Hardwired values, but useful for testing. +# Eventually Configure could ask for some of these values. +install.html: all installhtml + ./perl installhtml \ + --podroot=. --podpath=. --recurse \ + --htmldir=$(privlib)/html \ + --htmlroot=$(privlib)/html \ + --splithead=pod/perlipc \ + --splititem=pod/perlfunc \ + --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ + --verbose + # I now supply perly.c with the kits, so the following section is # used only if you force byacc to run by saying @@ -475,9 +484,9 @@ lint: perly.c $(c) # Need to unset during recursion to go out of loop -MAKEDEPEND = makedepend +MAKEDEPEND = Makefile makedepend -$(FIRSTMAKEFILE): Makefile $(MAKEDEPEND) +$(FIRSTMAKEFILE): $(MAKEDEPEND) $(MAKE) depend MAKEDEPEND= config.h: config_h.SH config.sh @@ -514,6 +523,11 @@ minitest: miniperl - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \ && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t </dev/tty +# handy way to run perlbug -ok without having to install and run the +# installed perlbug. We don't re-run the tests here - we trust the user. +ok: + ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' + clist: $(c) echo $(c) | tr ' ' '\012' >.clist diff --git a/Porting/makerel b/Porting/makerel index 0476ab52b3..bc472eee36 100644 --- a/Porting/makerel +++ b/Porting/makerel @@ -35,6 +35,13 @@ print "Cross-checking the MANIFEST...\n"; ($missfile, $missentry) = fullcheck(); warn "Can't make a release with MANIFEST files missing.\n" if @$missfile; warn "Can't make a release with files not listed in MANIFEST.\n" if @$missentry; +if ("@$missentry" =~ m/\.orig\b/) { + # Handy listing of find command and .orig files from patching work. + # I tend to run 'xargs rm' and copy and paste the file list. + my $cmd = "find . -name '*.orig' -print"; + print "$cmd\n"; + system($cmd); +} die "Aborted.\n" if @$missentry or @$missfile; print "\n"; diff --git a/Porting/patchls b/Porting/patchls index b3e968de4b..f4de529f46 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -18,18 +18,19 @@ use Text::Tabs qw(expand unexpand); use strict; sub usage { -die qq{ - +die q{ patchls [options] patchfile [ ... ] - -i Invert: for each patched file list which patch files patch it - -h no filename headers (like grep), only the listing - -l no listing (like grep), only the filename headers - -c Categorise the patch and sort by category (perl specific) - -m print formatted Meta-information (Subject,From,Msg-ID etc) - -p N strip N levels of directory Prefix (like patch), else automatic - -v more verbose (-d for noisy debugging) - + -i Invert: for each patched file list which patch files patch it. + -h no filename headers (like grep), only the listing. + -l no listing (like grep), only the filename headers. + -c Categorise the patch and sort by category (perl specific). + -m print formatted Meta-information (Subject,From,Msg-ID etc). + -p N strip N levels of directory Prefix (like patch), else automatic. + -v more verbose (-d for noisy debugging). + -f F only list patches which patch files matching regexp F + (F has $ appended unless it contains a /). + -I just gather and display summary Information about the patches. } } @@ -43,20 +44,23 @@ $::opt_i = 0; $::opt_h = 0; $::opt_l = 0; $::opt_c = 0; +$::opt_f = ''; +$::opt_I = 0; usage unless @ARGV; -getopts("mihlvcp:") or usage; +getopts("mihlvcp:f:I") or usage; my %cat_title = ( - 'TEST' => 'TESTS', + 'BUILD' => 'BUILD PROCESS', + 'CORE' => 'CORE LANGUAGE', 'DOC' => 'DOCUMENTATION', - 'UTIL' => 'UTILITIES', - 'PORT' => 'PORTABILITY', 'LIB' => 'LIBRARY AND EXTENSIONS', - 'CORE' => 'CORE LANGUAGE', - 'BUILD' => 'BUILD PROCESS', - 'OTHER' => 'OTHER', + 'PORT1' => 'PORTABILITY - WIN32', + 'PORT2' => 'PORTABILITY - OTHER', + 'TEST' => 'TESTS', + 'UTIL' => 'UTILITIES', + 'OTHER' => 'OTHER CHANGES', ); my %ls; @@ -94,10 +98,10 @@ foreach my $argv (@ARGV) { unless (/^([-+*]{3}) / || /^(Index):/) { # not an interesting patch line but possibly meta-information next unless $::opt_m; - $ls->{From}{$1}=1 if /^From: (.*\S)/i; - $ls->{Title}{$1}=1 if /^Subject: (?:Re: )?(.*\S)/i; - $ls->{'Msg-ID'}{$1}=1 if /^Message-Id: (.*\S)/i; - $ls->{Date}{$1}=1 if /^Date: (.*\S)/i; + $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; next; } $type = $1; @@ -141,6 +145,41 @@ my @ls = sort { $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in} } values %ls; +if ($::opt_f) { # filter out patches based on -f <regexp> + my $out; + $::opt_f .= '$' unless $::opt_f =~ m:/:; + @ls = grep { + my @out = keys %{$_->{out}}; + my $match = 0; + for $out (@out) { + ++$match if $out =~ m/$::opt_f/o; + } + $match; + } @ls; +} + +if ($::opt_I) { + my $n_patches = 0; + my($in,$out); + my %all_out; + foreach $in (@ls) { + next unless $in->{is_in}; + ++$n_patches; + my @outs = keys %{$in->{out}}; + @all_out{@outs} = ($in->{in}) x @outs; + } + my @all_out = sort keys %all_out; + my @missing = grep { ! -f $_ } @all_out; + print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n"; + if ($::opt_v and @missing) { + print "Missing files:\n"; + foreach $out (@missing) { + printf " %-20s\t%s\n", $out, $all_out{$out}; + } + } + exit 0+@missing; +} + unless ($::opt_c and $::opt_m) { foreach $ls (@ls) { next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; @@ -151,7 +190,8 @@ else { my $c = ''; foreach $ls (@ls) { next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; - print "\n $cat_title{$ls->{category}}\n" if $ls->{category} ne $c; + print "\n ------ $cat_title{$ls->{category}} ------\n" + if $ls->{category} ne $c; $c = $ls->{category}; unless ($::opt_i) { list_files_by_patch($ls); @@ -194,6 +234,8 @@ sub add_file { sub trim_name { # reduce/tidy file paths from diff lines my $name = shift; $name = "$name ($in)" if $name eq "/dev/null"; + $name =~ s:\\:/:g; # adjust windows paths + $name =~ s://:/:g; # simplify (and make win \\share into absolute path) if (defined $::opt_p) { # strip on -p levels of directory prefix my $dc = $::opt_p; @@ -202,7 +244,7 @@ sub trim_name { # reduce/tidy file paths from diff lines else { # try to strip off leading path to perl directory # if absolute path, strip down to any *perl* directory first $name =~ s:^/.*?perl.*?/::i; - $name =~ s:.*perl[-_]?5\.[-_a-z0-9.]+/::i; + $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i; $name =~ s:^\./::; } return $name; @@ -239,7 +281,9 @@ sub list_files_by_patch { sub my_wrap { - return expand(wrap(@_)); + my $txt = eval { expand(wrap(@_)) }; # die's on long lines! + return $txt unless $@; + return expand("@_"); } @@ -253,17 +297,18 @@ sub categorize_files { $c{TEST} += 5,next if m:^t/:; $c{DOC} += 5,next if m:^pod/:; $c{UTIL} += 10,next if m:^(utils|x2p|h2pl)/:; - $c{PORT} += 15,next - if m:^(cygwin32|os2|plan9|qnx|vms|win32)/: + $c{PORT1}+= 15,next if m:^win32:; + $c{PORT2} += 15,next + if m:^(cygwin32|os2|plan9|qnx|vms)/: or m:^(hints|Porting|ext/DynaLoader)/: or m:^README\.:; $c{LIB} += 10,next if m:^(lib|ext)/:; $c{'CORE'} += 15,next - if m:^[^/]+[\._]([chH]|sym)$:; + if m:^[^/]+[\._]([chH]|sym|pl)$:; $c{BUILD} += 10,next if m:^[A-Z]+$: or m:^[^/]+\.SH$: - or m:^(install|configure):i; + or m:^(install|configure|configpm):i; print "Couldn't categorise $_\n" if $::opt_v; $c{OTHER} += 1; } diff --git a/README.os2 b/README.os2 index 4cef16f0aa..667423c382 100644 --- a/README.os2 +++ b/README.os2 @@ -290,6 +290,9 @@ There are also endless possibilities to use I<executable extensions> of *nixish shell (like F<sh.exe> supplied in the binary distribution), you need to follow the syntax specified in L<perlrun/"Switches">. +Note that B<-S> switch enables a search with additional extensions +F<.cmd>, F<.btm>, F<.bat>, F<.pl> as well. + =head2 Starting OS/2 (and DOS) programs under Perl This is what system() (see L<perlfunc/system>), C<``> (see @@ -1082,8 +1085,13 @@ eventually). =item -Since L<flock(3)> is present in EMX, but is not functional, the same is -true for perl. Here is the list of things which may be "broken" on +Since L<flock(3)> is present in EMX, but is not functional, it is +emulated by perl. To disable the emulations, set environment variable +C<USE_PERL_FLOCK=0>. + +=item + +Here is the list of things which may be "broken" on EMX (from EMX docs): =over @@ -1099,7 +1107,7 @@ L<sock_init(3)> is not required and not implemented. =item * -L<flock(3)> is not yet implemented (dummy function). +L<flock(3)> is not yet implemented (dummy function). (Perl has a workaround.) =item * @@ -1155,6 +1163,12 @@ a dummy implementation. C<os2_stat> special-cases F</dev/tty> and F</dev/con>. +=item C<flock> + +Since L<flock(3)> is present in EMX, but is not functional, it is +emulated by perl. To disable the emulations, set environment variable +C<USE_PERL_FLOCK=0>. + =back =head1 Perl flavors @@ -1334,6 +1348,12 @@ memory handling code is buggy. Specific for EMX port. Gives the directory part of the location for F<sh.exe>. +=head2 C<USE_PERL_FLOCK> + +Specific for EMX port. Since L<flock(3)> is present in EMX, but is not +functional, it is emulated by perl. To disable the emulations, set +environment variable C<USE_PERL_FLOCK=0>. + =head2 C<TMP> or C<TEMP> Specific for EMX port. Used as storage place for temporary files, most diff --git a/README.win32 b/README.win32 index 8d14a2da4c..1f8dd07f5f 100644 --- a/README.win32 +++ b/README.win32 @@ -24,7 +24,7 @@ found in the top-level directory where the Perl distribution was extracted. Make sure you read and understand the terms under which this software is being distributed. -Also make sure you read the L<BUGS AND CAVEATS> section below for the +Also make sure you read L<BUGS AND CAVEATS> below for the known limitations of this port. The INSTALL file in the perl top-level has much information that is @@ -142,6 +142,10 @@ perl.dll, and perlglob.exe at the perl toplevel, and various other extension dll's under the lib\auto directory. If the build fails for any reason, make sure you have done the previous steps correctly. +The build process may produce "harmless" compiler warnings (more or +less copiously, depending on how picky your compiler gets). The +maintainers are aware of these warnings, thankyouverymuch. :) + When building using Visual C++, a perl95.exe will also get built. This executable is only needed on Windows95, and should be used instead of perl.exe, and then only if you want sockets to work properly on Windows95. @@ -290,7 +294,7 @@ This pipes "foo" to the pager and writes "bar" in the file "blurch": perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less -Discovering the usage of the "command.com" shell on Windows95 +Discovering the usefulness of the "command.com" shell on Windows95 is left as an exercise to the reader :) =item Building Extensions @@ -337,7 +341,7 @@ all of the Activeware extensions and most other Win32 extensions from CPAN in source form, along with many added bugfixes, and with MakeMaker support. This bundle is available at: - http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.06.tar.gz + http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.08.tar.gz See the README in that distribution for building and installation instructions. Look for later versions that may be available at the @@ -348,6 +352,76 @@ distributing their work in MakeMaker compatible form subsequent to the 5.004 release of perl, at which point the need for a dedicated bundle such as the above should diminish. +=item Running Perl Scripts + +Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to +indicate to the OS that it should execute the file using perl. +Win32 has no comparable means to indicate arbitrary files are +executables. + +Instead, all available methods to execute plain text files on +Win32 rely on the file "extension". There are three methods +to use this to execute perl scripts: + +=over 8 + +=item 1 + +There is a facility called "file extension associations" that will +work in Windows NT 4.0. This can be manipulated via the two +commands "assoc" and "ftype" that come standard with Windows NT +4.0. Type "ftype /?" for a complete example of how to set this +up for perl scripts (Say what? You thought Windows NT wasn't +perl-ready? :). + +=item 2 + +Since file associations don't work everywhere, and there are +reportedly bugs with file associations where it does work, the +old method of wrapping the perl script to make it look like a +regular batch file to the OS, may be used. The install process +makes available the "pl2bat.bat" script which can be used to wrap +perl scripts into batch files. For example: + + pl2bat foo.pl + +will create the file "FOO.BAT". Note "pl2bat" strips any +.pl suffix and adds a .bat suffix to the generated file. + +If you use the 4DOS/NT or similar command shell, note that +"pl2bat" uses the "%*" variable in the generated batch file to +refer to all the command line arguments, so you may need to make +sure that construct works in batch files. As of this writing, +4DOS/NT users will need a "ParameterChar = *" statement in their +4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT +startup file to enable this to work. + +=item 3 + +Using "pl2bat" has a few problems: the file name gets changed, +so scripts that rely on C<$0> to find what they must do may not +run properly; running "pl2bat" replicates the contents of the +original script, and so this process can be maintenance intensive +if the originals get updated often. A different approach that +avoids both problems is possible. + +A script called "runperl.bat" is available that can be copied +to any filename (along with the .bat suffix). For example, +if you call it "foo.bat", it will run the file "foo" when it is +executed. Since you can run batch files on Win32 platforms simply +by typing the name (without the extension), this effectively +runs the file "foo", when you type either "foo" or "foo.bat". +With this method, "foo.bat" can even be in a different location +than the file "foo", as long as "foo" is available somewhere on +the PATH. If your scripts are on a filesystem that allows symbolic +links, you can even avoid copying "runperl.bat". + +Here's a diversion: copy "runperl.bat" to "runperl", and type +"runperl". Explain the observed behavior, or lack thereof. :) +Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH + +=back + =item Miscellaneous Things A full set of HTML documentation is installed, so you should be @@ -374,18 +448,20 @@ time because some details are still in flux and there may be changes in any of these areas: build process, installation structure, supported utilities/modules, and supported perl functionality. In particular, functionality specific to the Win32 environment may -ultimately be supported as either core modules or extensions. This -means that you should be prepared to recompile extensions when binary -incompatibilites arise due to changes in the internal structure of -the code. - -The DLLs produced by the two supported compilers are incompatible -with each other due to the conventions they use to export symbols, -and due to differences in the Runtime libraries that they provide. -This means that extension binaries built under either compiler will -only work with the perl binaries built under the same compiler. -If you know of a robust, freely available C Runtime that can -be used under win32, let us know. +ultimately be supported as either core modules or extensions. The +beta status implies, among other things, that you should be prepared +to recompile extensions when binary incompatibilites arise due to +changes in the internal structure of the code. + +An effort has been made to ensure that the DLLs produced by the two +supported compilers are compatible with each other (despite the +best efforts of the compiler vendors). Extension binaries produced +by one compiler should also coexist with a perl binary built by +a different compiler. In order to accomplish this, PERL.DLL provides +a layer of runtime code that uses the C Runtime that perl was compiled +with. Extensions which include "perl.h" will transparently access +the functions in this layer, thereby ensuring that both perl and +extensions use the same runtime functions. If you have had prior exposure to Perl on Unix platforms, you will notice this port exhibits behavior different from what is documented. Most of the @@ -404,13 +480,19 @@ bogus. =item * -The following functions are currently unavailable: C<fork()>, C<exec()>, +The following functions are currently unavailable: C<fork()>, C<dump()>, C<chown()>, C<link()>, C<symlink()>, C<chroot()>, C<setpgrp()>, C<getpgrp()>, C<setpriority()>, C<getpriority()>, C<syscall()>, C<fcntl()>. This list is possibly very incomplete. =item * +crypt() is not available due to silly export restrictions. It may +become available when the laws change. Meanwhile, look in CPAN for +extensions that provide it. + +=item * + Various C<socket()> related calls are supported, but they may not behave as on Unix platforms. @@ -440,7 +522,12 @@ returned values or effects may be bogus. =item * Signal handling may not behave as on Unix platforms (where it -doesn't exactly "behave", either :). +doesn't exactly "behave", either :). For instance, calling C<die()> +or C<exit()> from signal handlers will cause an exception, since most +implementations of C<signal()> on Win32 are severely crippled. +Thus, signals may work only for simple things like setting a flag +variable in the handler. Using signals under this port should +currently be considered unsupported. =item * @@ -473,6 +560,8 @@ Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt> =back +This document is maintained by Gurusamy Sarathy. + =head1 SEE ALSO L<perl> @@ -488,7 +577,7 @@ sundry hacks since then. Borland support was added in 5.004_01 (Gurusamy Sarathy). -Last updated: 11 June 1997 +Last updated: 25 July 1997 =cut @@ -47,7 +47,6 @@ Vague possibilities ref function in list context data prettyprint function? (or is it, as I suspect, a lib routine?) make tr/// return histogram in list context? - undef wantarray in void context Loop control on do{} et al Explicit switch statements built-in globbing @@ -44,13 +44,15 @@ Sv = ST(1); \ else { \ /* XXX GV_ADDWARN */ \ - Sv = perl_get_sv(vn = form("%s::XS_VERSION", module), FALSE); \ + Sv = perl_get_sv(form("%s::%s", module, \ + vn = "XS_VERSION"), FALSE); \ if (!Sv || !SvOK(Sv)) \ - Sv = perl_get_sv(vn = form("%s::VERSION", module), FALSE); \ + Sv = perl_get_sv(form("%s::%s", module, \ + vn = "VERSION"), FALSE); \ } \ if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv, na)))) \ - croak("%s object version %s does not match $%s %_", \ - module, XS_VERSION, vn, Sv); \ + croak("%s object version %s does not match $%s::%s %_", \ + module, XS_VERSION, module, vn, Sv); \ } STMT_END #else # define XS_VERSION_BOOTCHECK @@ -256,17 +256,19 @@ register SV **strp; av = (AV*)NEWSV(8,0); sv_upgrade((SV *) av,SVt_PVAV); - New(4,ary,size+1,SV*); - AvALLOC(av) = ary; AvFLAGS(av) = AVf_REAL; - SvPVX(av) = (char*)ary; - AvFILL(av) = size - 1; - AvMAX(av) = size - 1; - for (i = 0; i < size; i++) { - assert (*strp); - ary[i] = NEWSV(7,0); - sv_setsv(ary[i], *strp); - strp++; + if (size) { /* `defined' was returning undef for size==0 anyway. */ + New(4,ary,size,SV*); + AvALLOC(av) = ary; + SvPVX(av) = (char*)ary; + AvFILL(av) = size - 1; + AvMAX(av) = size - 1; + for (i = 0; i < size; i++) { + assert (*strp); + ary[i] = NEWSV(7,0); + sv_setsv(ary[i], *strp); + strp++; + } } return av; } @@ -79,7 +79,8 @@ my $summary_expanded = 0; sub myconfig { return $summary if $summary_expanded; - $summary =~ s/\$(\w+)/$Config{$1}/ge; + $summary =~ s{\$(\w+)} + { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge; $summary_expanded = 1; $summary; } @@ -948,7 +948,7 @@ do_execfree() } } -#ifndef OS2 +#if !defined(OS2) && !defined(WIN32) bool do_exec(cmd) @@ -1039,7 +1039,7 @@ char *cmd; return FALSE; } -#endif /* OS2 */ +#endif /* OS2 || WIN32 */ I32 apply(type,mark,sp) @@ -1373,29 +1373,25 @@ SV **sp; infosize = sizeof(struct semid_ds); else if (cmd == GETALL || cmd == SETALL) { + struct semid_ds semds; #ifdef __linux__ /* XXX Need metaconfig test */ -/* linux uses : - int semctl (int semid, int semnun, int cmd, union semun arg) - +/* 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 semds; - if (semctl(id, 0, IPC_STAT, semds) == -1) + union semun semun; + semun.buf = &semds; + if (semctl(id, 0, IPC_STAT, semun) == -1) #else - struct semid_ds semds; if (semctl(id, 0, IPC_STAT, &semds) == -1) #endif return -1; getinfo = (cmd == GETALL); -#ifdef __linux__ /* XXX Need metaconfig test */ - infosize = semds.buf->sem_nsems * sizeof(short); -#else infosize = semds.sem_nsems * sizeof(short); -#endif /* "short" is technically wrong but much more portable than guessing about u_?short(_t)? */ } @@ -11,10 +11,11 @@ void Perl_DJGPP_init(); # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ Perl_DJGPP_init(); } STMT_END #else /* DJGPP */ -# define PERL_SYS_INIT(c,v) # ifdef WIN32 +# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v) # define BIT_BUCKET "nul" # else +# define PERL_SYS_INIT(c,v) # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ # endif #endif /* DJGPP */ @@ -1066,6 +1066,7 @@ #define sv_setptrobj Perl_sv_setptrobj #define sv_setpv Perl_sv_setpv #define sv_setpvf Perl_sv_setpvf +#define sv_setpviv Perl_sv_setpviv #define sv_setpvn Perl_sv_setpvn #define sv_setref_iv Perl_sv_setref_iv #define sv_setref_nv Perl_sv_setref_nv diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index e097046718..9ed5185c6d 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 31st May 1997 -# version 1.15 +# last modified 8th Oct 1997 +# version 1.16 # # Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -98,7 +98,6 @@ sub NotHere croak ref($self) . " does not define the method ${method}" ; } -sub DESTROY { undef %{$_[0]} } sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } @@ -212,17 +211,13 @@ sub AUTOLOAD { } -# import borrowed from IO::File -# exports Fcntl constants if available. -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export $pkg, $callpkg, @_; - eval { - require Fcntl; - Exporter::export 'Fcntl', $callpkg, '/^O_/'; - }; -} +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; bootstrap DB_File $VERSION; @@ -1668,6 +1663,21 @@ ordinary array to a HASH or BTREE database. =item 1.15 +Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined +value" warning with db_get and db_seq. + +Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the O_* +constants from Fcntl. + +Removed the DESTROY method from the DB_File::HASHINFO module. + +Previously DB_File hard-wired the class name of any object that it +created to "DB_File". This makes sub-classing difficult. Now DB_File +creats objects in the namespace of the package it has been inherited +into. + +=item 1.16 + Minor changes to DB_File.xs to support multithreaded perl. =back diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index cc70b5d7b9..bd0c933329 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 31st May 1997 - version 1.15 + last modified 8th Oct 1997 + version 1.16 All comments/suggestions/problems are welcome @@ -42,7 +42,9 @@ 1.13 - Tidied up a few casts. 1.14 - Made it illegal to tie an associative array to a RECNO database and an ordinary array to a HASH or BTREE database. - 1.15 - Minor additions to DB_File.xs to support multithreaded perl. + 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.16 - Minor additions to DB_File.xs to support multithreaded perl. */ @@ -51,6 +53,9 @@ #include "XSUB.h" #include <db.h> +/* #ifdef DB_VERSION_MAJOR */ +/* #include <db_185.h> */ +/* #endif */ #include <fcntl.h> @@ -88,7 +93,7 @@ typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; -/* #define TRACE */ +/* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) @@ -1066,7 +1071,7 @@ int db_get(db, key, value, flags=0) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; @@ -1102,7 +1107,7 @@ int db_seq(db, key, value, flags) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 5ca9c54f72..a6212243de 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -34,3 +34,5 @@ T_dbtkeydatum OutputKey($arg, $var) T_dbtdatum OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index 67043102a5..04404b7ee9 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -335,9 +335,9 @@ 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. It is anticipated that any -glue that may be developed in the future will be implemented in a -separate dynamically loaded module. +library function or supplying arguments. A ExtUtils::DynaLib module +is available from CPAN sites which performs that function for some +common system types. DynaLoader Interface Summary diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index a6b0e5faa8..a9b73d8b81 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 2eb16f40ec..e558d5c4e0 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -271,6 +271,8 @@ setvbuf(handle, buf, type, size) CODE: /* Should check HAS_SETVBUF once Configure tests for that */ #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (!handle) /* Try input stream. */ + handle = IoIFP(sv_2io(ST(0))); if (handle) RETVAL = setvbuf(handle, buf, type, size); else { diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index b1aecffb5d..de7fabc6f2 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -115,24 +115,17 @@ require DynaLoader; @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); -$VERSION = "1.0602"; +$VERSION = "1.06021"; @EXPORT = @IO::Seekable::EXPORT; -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export $pkg, $callpkg, @_; - - # - # If the Fcntl extension is available, - # export its constants for sysopen(). - # - eval { - require Fcntl; - Exporter::export 'Fcntl', $callpkg, '/^O_/'; - }; -} +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; ################################################ diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index f270f3ff98..39e32f05ab 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -20,6 +20,7 @@ IO::Handle - supply object methods for I/O handles $fh->print("Some text\n"); } + use IO::Handle '_IOLBF'; $fh->setvbuf($buffer_var, _IOLBF, 1024); undef $fh; # automatically closes the file if it's open @@ -151,7 +152,8 @@ C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter specifies a scalar variable to use as a buffer. WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called -again, or memory corruption may result! +again, or memory corruption may result! Note that you need to import +the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Lastly, there is a special method for working under B<-T> and setuid/gid scripts: diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 171042cccc..ab1917031d 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -380,6 +380,7 @@ IO::Socket::INET->register_domain( AF_INET ); my %socket_type = ( tcp => SOCK_STREAM, udp => SOCK_DGRAM, + icmp => SOCK_RAW, ); =head2 IO::Socket::INET @@ -557,7 +558,7 @@ sub configure { } else { return _error($fh,'Cannot determine remote port') - unless($rport || $type == SOCK_DGRAM); + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); if($type == SOCK_STREAM || defined $raddr) { return _error($fh,'Bad peer address') diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index a6b0e5faa8..a9b73d8b81 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index d23b318e0d..b57e560bd3 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -73,7 +73,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode) } RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "ODBM_File"); + sv_setptrobj(ST(0), RETVAL, dbtype); } void diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index f723db796a..a09eafe37a 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -40,7 +40,7 @@ #include <sys/stat.h> #include <sys/types.h> #include <time.h> -#include <unistd.h> +#include <unistd.h> /* see hints/sunos_4_1.sh */ #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -55,7 +55,10 @@ # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") -# if __VMS_VER < 70000000 +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +# define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */ +# include <utsname.h> +#else /* The default VMS emulation of Unix signals isn't very POSIXish */ typedef int sigset_t; # define sigpending(a) (not_here("sigpending"),0) @@ -125,9 +128,7 @@ # define sa_handler sv_handler # define sa_mask sv_mask # define sigsuspend(set) sigpause(*set) -# else -# define HAS_TZNAME /* shows up in VMS 7.0 */ -# endif /* __VMS_VER < 70000000 */ +# endif /* __VMS_VER >= 70000000 or Dec C 5.6 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index a6b0e5faa8..a9b73d8b81 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/global.sym b/global.sym index a51b822a25..023cd6a1a2 100644 --- a/global.sym +++ b/global.sym @@ -1139,6 +1139,7 @@ sv_setiv sv_setnv sv_setptrobj sv_setpv +sv_setpviv sv_setpvn sv_setref_iv sv_setref_nv @@ -80,7 +80,7 @@ char *name; sv_setpv(GvSV(gv), name); if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) GvMULTI_on(gv); - if (perldb) + if (PERLDB_LINE) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; } @@ -834,7 +834,9 @@ newIO() sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); + iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); + if (!iogv) + iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } @@ -1350,7 +1352,7 @@ int flags; ENTER; SAVEOP(); op = (OP *) &myop; - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(ARGS); diff --git a/hints/cxux.sh b/hints/cxux.sh index 42bfe5d579..e3ac086e23 100644 --- a/hints/cxux.sh +++ b/hints/cxux.sh @@ -61,16 +61,18 @@ libswanted=`echo ' '$libswanted' ' | sed -e 's/ malloc / /'` # glibpth="/usr/sde/elf/usr/lib $glibpth" -# Need to use Concurrent cc for most of these options to be meaningful (if you -# want to get this to work with gcc, you're on your own :-). Passing +# Need to use Concurrent cc for most of these options to be meaningful (if +# you want to get this to work with gcc, you're on your own :-). Passing # -Bexport to the linker when linking perl is important because it leaves # the interpreter internal symbols visible to the shared libs that will be -# loaded on demand (and will try to reference those symbols). The -u -# option to drag 'sigaction' into the perl main program is to make sure -# it gets defined for the posix shared library (for some reason sigaction -# is static, rather than being defined in libc.so.1). +# loaded on demand (and will try to reference those symbols). The -u option +# to drag 'sigaction' into the perl main program is to make sure it gets +# defined for the posix shared library (for some reason sigaction is static, +# rather than being defined in libc.so.1). The 88110compat option makes sure +# the code will run on both 88100 and 88110 machines. The define is added to +# trigger a work around for a compiler bug which shows up in pp.c. # -cc='/bin/cc -Xa' +cc='/bin/cc -Xa -Qtarget=M88110compat -DCXUX_BROKEN_CONSTANT_CONVERT' cccdlflags='-Zelf -Zpic' ccdlflags='-Zelf -Zlink=dynamic -Wl,-Bexport -u sigaction' lddlflags='-Zlink=so' diff --git a/hints/hpux.sh b/hints/hpux.sh index ab04e9b82e..c2500d0c37 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -1,7 +1,7 @@ #! /bin/sh # hints/hpux.sh -# Perl Configure hints file for Hewlett Packard HP-UX 9.x and 10.x +# Perl Configure hints file for Hewlett-Packard's HP-UX 9.x and 10.x # (Hopefully, 7.x through 11.x.) # # This file is based on hints/hpux_9.sh, Perl Configure hints file for @@ -21,7 +21,7 @@ # Don't assume every OS != 10 is < 10, (e.g., 11). # From: Chuck Phillips <cdp@fc.hp.com> -# This version: April 27, 1997 +# This version: August 15, 1997 # Current maintainer: Jeff Okamoto <okamoto@corp.hp.com> #-------------------------------------------------------------------- @@ -121,6 +121,7 @@ else # ASSUMPTION: Only CPU identifiers contain no lowercase letters. archname=`getcontext | tr ' ' '\012' | grep -v '[a-z]' | grep -v MC688 | sed -e 's/HP-//' -e 1q`; + selecttype='int *' fi @@ -151,7 +152,6 @@ ccdlflags="-Wl,-E -Wl,-B,deferred $ccdlflags" usemymalloc='y' alignbytes=8 -selecttype='int *' # For native nm, you need "-p" to produce BSD format output. nm_opt='-p' diff --git a/hints/linux.sh b/hints/linux.sh index 54bc12295c..8ff7f5d747 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -183,6 +183,17 @@ else echo 'Your csh is really tcsh. Good.' fi +# Shimpei Yamashita <shimpei@socrates.patnet.caltech.edu> +# Message-Id: <33EF1634.B36B6500@pobox.com> +# +# MkLinux (osname=linux,archname=ppc-linux), which differs slightly from other +# linuces, needs special flags passed in order for dynamic loading to work. +# instead of the recommended: +# ccdlflags='-rdynamic' +# +# it should be: +# ccdlflags='-Wl,-E' + if [ "X$usethreads" != "X" ]; then ccflags="-D_REENTRANT -DUSE_THREADS $ccflags" cppflags="-D_REENTRANT -DUSE_THREADS $cppflags" diff --git a/hints/os2.sh b/hints/os2.sh index c442a08086..b468f2de41 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -28,7 +28,28 @@ startsh="#!$sh" sysman=`../UU/loc . /man/man1 c:/man/man1 c:/usr/man/man1 d:/man/man1 d:/usr/man/man1 e:/man/man1 e:/usr/man/man1 f:/man/man1 f:/usr/man/man1 g:/man/man1 g:/usr/man/man1 /usr/man/man1` cc='gcc' usrinc='/emx/include' -libemx="`../UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h:/emx/lib /emx/lib`" +emxpath="`../UU/loc . /emx c:/emx d:/emx e:/emx f:/emx g:/emx h:/emx /emx`" + +libemx="$emxpath/lib" +if test ! -d "$libemx"; then + if test -d "$LIBRARY_PATH"; then + usrinc="$LIBRARY_PATH" + else + libemx="`../UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h:/emx/lib /emx/lib`" + fi +fi + +if test -d "$emxpath/include"; then + usrinc="$emxpath/include" +else + if test -d "$C_INCLUDE_PATH"; then + usrinc="$C_INCLUDE_PATH" + else + usrinc="`../UU/loc . X c:/emx/include d:/emx/include e:/emx/include f:/emx/include g:/emx/include h:/emx/include /emx/include`" + fi +fi + +rsx="`../UU/loc rsx.exe undef $pth`" if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi @@ -66,8 +87,8 @@ fi aout_ldflags="$aout_ldflags" aout_d_fork='define' -aout_ccflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK' -aout_cppflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK' +aout_ccflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK' +aout_cppflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK' aout_use_clib='c' aout_usedl='undef' aout_archobjs="os2.o dl_os2.o" @@ -189,9 +210,14 @@ nm_opt='-p' d_getprior='define' d_setprior='define' -####### All the rest is commented +# 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 -# The next two are commented. pdksh handles #! +# The next two are commented. pdksh handles #!, extproc gives no path part. # sharpbang='extproc ' # shsharp='false' diff --git a/hints/sco.sh b/hints/sco.sh index 6062fbeb2e..cef1c0c942 100644 --- a/hints/sco.sh +++ b/hints/sco.sh @@ -67,6 +67,7 @@ icc)# Apparently, SCO's cc gives rather verbose warnings 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;; 5) ccflags="$ccflags -belf -w0 -U M_XENIX" optimize="-O1" # -g -O1 will not work + # optimize="-O0" may be needed for pack test to pass. lddlflags='-G -L/usr/local/lib' ldflags=' -W l,-Bexport -L/usr/local/lib' dlext='so' diff --git a/hints/sunos_4_1.sh b/hints/sunos_4_1.sh index 16ea47aa0c..07cd89fc7b 100644 --- a/hints/sunos_4_1.sh +++ b/hints/sunos_4_1.sh @@ -25,7 +25,9 @@ d_tzname='undef' # The gcc fix-includes script exposes those incorrect prototypes. # There may be other examples as well. Volunteers are welcome to # track them all down :-). In the meantime, we'll just skip unistd.h -# for SunOS. +# for SunOS in most of the code. The POSIX extension is built with +# unistd.h because, even though unistd.h has problems, if used with +# care, it helps create a better POSIX extension. i_unistd='undef' cat << 'EOM' >&4 @@ -39,12 +41,31 @@ EOM # the problem. Other BSD platforms may have similar problems. POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' -# check if user is in a bsd or system 5 type environment +# The correct setting of groupstype depends on which version of the C +# library is used. If you are in the 'System V environment' +# (i.e. you have /usr/5bin ahead of /usr/bin in your PATH), and +# you use Sun's cc compiler, then you'll pick up /usr/5bin/cc, which +# links against the C library in /usr/5lib. This library has +# groupstype='gid_t'. +# If you are in the normal BSDish environment, then you'll pick up +# /usr/ucb/cc, which links against the C library in /usr/lib. That +# library has groupstype='int'. +# +# If you are using gcc, it links against the C library in /usr/lib +# independent of whether or not you are in the 'System V environment'. +# If you want to use the System V libraries, then you need to +# manually set groupstype='gid_t' and add explicit references to +# /usr/5lib when Configure prompts you for where to look for libraries. +# +# Check if user is in a bsd or system 5 type environment if cat -b /dev/null 2>/dev/null then # bsd groupstype='int' else # sys5 - groupstype='gid_t' + case "$cc" in + *gcc*) groupstype='int';; # gcc doesn't do anything special + *) groupstype='gid_t';; # /usr/5bin/cc pulls in /usr/5lib/ stuff. + esac fi # If you get the message "unresolved symbol '__lib_version' " while diff --git a/hints/svr4.sh b/hints/svr4.sh index dbae40d641..922736aa48 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -33,12 +33,23 @@ usevfork='false' d_lstat=define # UnixWare has a broken csh. The undocumented -X argument to uname is probably -# a reasonable way of detecting UnixWare +# 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` -if [ "$uw_isuw" = "Release = 4.2MP" -a \ - \( "$uw_ver" = "2.1" -o "$uw_ver" = "2.1.1" \) ]; then - d_csh='undef' +if [ "$uw_isuw" = "Release = 4.2MP" ]; then + case $uw_ver in + 2.1) + 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' + ;; + esac fi # DDE SMES Supermax Enterprise Server diff --git a/installhtml b/installhtml index 72564d1aa8..b677cc29db 100755 --- a/installhtml +++ b/installhtml @@ -1,4 +1,6 @@ -#!/usr/bin/perl -w +#!./perl -w + +# This file should really be a extracted from a .PL use lib 'lib'; # use source library if present @@ -93,14 +95,14 @@ The following command-line is an example of the one we use to convert perl documentation: ./installhtml --podpath=lib:ext:pod:vms \ - --podroot=/usr/src/perl \ - --htmldir=/perl/nmanual \ - --htmlroot=/perl/nmanual \ - --splithead=pod/perlipc \ - --splititem=pod/perlfunc \ - --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ - --recurse \ - --verbose + --podroot=/usr/src/perl \ + --htmldir=/perl/nmanual \ + --htmlroot=/perl/nmanual \ + --splithead=pod/perlipc \ + --splititem=pod/perlfunc \ + --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ + --recurse \ + --verbose =head1 AUTHOR diff --git a/lib/Bundle/CPAN.pm b/lib/Bundle/CPAN.pm index 2a05deef59..062aab287d 100644 --- a/lib/Bundle/CPAN.pm +++ b/lib/Bundle/CPAN.pm @@ -1,6 +1,6 @@ package Bundle::CPAN; -$VERSION = '0.02'; +$VERSION = '0.03'; 1; @@ -16,17 +16,27 @@ C<perl -MCPAN -e 'install Bundle::CPAN'> =head1 CONTENTS -CPAN +MD5 + +Data::Dumper # Bundle::libnet may have problems to work without it + +Bundle::libnet + +Term::ReadKey + +Term::ReadLine::Perl # sorry, I'm discriminating the ::Gnu module CPAN::WAIT +CPAN + =head1 DESCRIPTION This bundle includes CPAN.pm as the base module and CPAN::WAIT, the first plugin for CPAN that was developed even before there was an API. After installing this bundle, it is recommended to quit the current -session and start again in a new process. +session and start again in a new process to enable Term::ReadLine. =head1 AUTHOR diff --git a/lib/CPAN.pm b/lib/CPAN.pm index c8b7b28301..8271076bef 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,11 +1,12 @@ package CPAN; -use vars qw{$META $Signal $Cwd $End $Suppress_readline}; +use vars qw{$Try_autoload + $META $Signal $Cwd $End $Suppress_readline %Dontload}; -$VERSION = '1.2401'; +$VERSION = '1.27'; -# $Id: CPAN.pm,v 1.139 1997/03/31 22:43:23 k Exp $ +# $Id: CPAN.pm,v 1.160 1997/07/28 12:21:56 k Exp $ -# my $version = substr q$Revision: 1.139 $, 10; # only used during development +# my $version = substr q$Revision: 1.160 $, 10; # only used during development use Carp (); use Config (); @@ -22,10 +23,6 @@ use Safe (); use Text::ParseWords (); use Text::Wrap; -my $getcwd; -$getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; -$Cwd = Cwd->$getcwd(); - END { $End++; &cleanup; } %CPAN::DEBUG = qw( @@ -55,15 +52,264 @@ use strict qw(vars); # MakeMaker, gives us # catfile and catdir -$META ||= new CPAN; # In case we reeval ourselves we - # need a || - -@EXPORT = qw( +@EXPORT = qw( autobundle bundle expand force get install make readme recompile shell test clean ); +#-> sub CPAN::AUTOLOAD ; +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + CPAN::Shell->$l(@_); + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; + } else { + warn "not OK: $@"; + } + warn "CPAN doesn't know how to autoload $AUTOLOAD :-( +Nothing Done. +"; + sleep 1; + CPAN::Shell->h; + } +} + +#-> sub CPAN::shell ; +sub shell { + $Suppress_readline ||= ! -t STDIN; + + my $prompt = "cpan> "; + local($^W) = 1; + unless ($Suppress_readline) { + require Term::ReadLine; +# import Term::ReadLine; + $term = Term::ReadLine->new('CPAN Monitor'); + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + + no strict; + $META->checklock(); + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + my $rl_avail = $Suppress_readline ? "suppressed" : + ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : + "available (try ``install Bundle::CPAN'')"; + + print qq{ +cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) +Readline support $rl_avail + +} unless $CPAN::Config->{'inhibit_startup_message'} ; + while () { + if ($Suppress_readline) { + print $prompt; + last unless defined ($_ = <> ); + chomp; + } else { + last unless defined ($_ = $term->readline($prompt)); + } + s/^\s+//; + next if /^$/; + $_ = 'h' if $_ eq '?'; + if (/^\!/) { + s/^\!//; + my($eval) = $_; + package CPAN::Eval; + use vars qw($import_done); + CPAN->import(':DEFAULT') unless $import_done++; + CPAN->debug("eval[$eval]") if $CPAN::DEBUG; + eval($eval); + warn $@ if $@; + } elsif (/^q(?:uit)?$/i) { + last; + } elsif (/./) { + my(@line); + if ($] < 5.00322) { # parsewords had a bug until recently + @line = split; + } else { + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next if $@; + } + $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; + my $command = shift @line; + eval { CPAN::Shell->$command(@line) }; + warn $@ if $@; + } + } continue { + &cleanup, die "Goodbye\n" if $Signal; + chdir $cwd; + print "\n"; + } +} + +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); +use File::Find; + +package CPAN::Config; +import ExtUtils::MakeMaker 'neatvalue'; +use vars qw(%can $dot_cpan); + +%can = ( + 'commit' => "Commit changes to disk", + 'defaults' => "Reload defaults from disk", + 'init' => "Interactive setting of all options", +); + +package CPAN::FTP; +use vars qw($Ua); +@CPAN::FTP::ISA = qw(CPAN::Debug); + +package CPAN::Complete; +@CPAN::Complete::ISA = qw(CPAN::Debug); + +package CPAN::Index; +use vars qw($last_time $date_of_03); +@CPAN::Index::ISA = qw(CPAN::Debug); +$last_time ||= 0; +$date_of_03 ||= 0; + +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); + +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::InfoObj); + +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); + +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Module); + +package CPAN::Module; +@CPAN::Module::ISA = qw(CPAN::InfoObj); +package CPAN::Shell; +use vars qw($AUTOLOAD $redef @ISA); +@CPAN::Shell::ISA = qw(CPAN::Debug); + +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + my($autoload) = $AUTOLOAD; + $autoload =~ s/.*:://; + if ($autoload =~ /^w/) { + if ($CPAN::META->has_inst('CPAN::WAIT')) { + CPAN::WAIT->wh; + } else { + print STDERR qq{ +Commands starting with "w" require CPAN::WAIT to be installed. +Please consider installing CPAN::WAIT to use the fulltext index. +For this you just need to type + install CPAN::WAIT +} + } + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; + } else { + warn "not OK: $@"; + } + warn "CPAN::Shell doesn't know how to autoload $autoload :-( +Nothing Done. +"; + sleep 1; + CPAN::Shell->h; + } +} + +#-> CPAN::Shell::try_dot_al +sub try_dot_al { + my($class,$autoload) = @_; + return unless $CPAN::Try_autoload; + # I don't see how to re-use that from the AutoLoader... + my($name,$ok); + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; + $pkg =~ s|::|/|g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; + $name = undef unless (-r $name); + } + unless (defined $name) + { + $name = "auto/$autoload.al"; + $name =~ s|::|/|g; + } + } + my $save = $@; + eval {local $SIG{__DIE__};require $name}; + if ($@) { + if (substr($autoload,-9) eq '::DESTROY') { + *$autoload = sub {}; + $ok = 1; + } else { + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {local $SIG{__DIE__};require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + Carp::croak $@; + } else { + $ok = 1; + } + } + } else { + $ok = 1; + } + $@ = $save; + my $lm = Carp::longmess(); +# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug + return $ok; +} + +# This should be left to a runtime evaluation +eval {require CPAN::WAIT;}; +unless ($@) { + unshift @ISA, "CPAN::WAIT"; +} + +#### autoloader is experimental +#### to try it we have to set $Try_autoload and uncomment +#### the use statement and uncomment the __END__ below +#### You also need AutoSplit 1.01 available. MakeMaker will +#### then build CPAN with all the AutoLoad stuff. +# use AutoLoader; +# $Try_autoload = 1; + +if ($CPAN::Try_autoload) { + for my $p (qw( + CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete + CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP + CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module + )) { + *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; + } +} + + +package CPAN; + +$META ||= CPAN->new; # In case we reeval ourselves we + # need a || + +# Do this after you have set up the whole inheritance +CPAN::Config->load unless defined $CPAN::No_Config_is_ok; + +1; + +# __END__ # uncomment this and AutoSplit version 1.01 will split it #-> sub CPAN::autobundle ; sub autobundle; @@ -77,29 +323,11 @@ sub force; sub install; #-> sub CPAN::make ; sub make; -#-> sub CPAN::shell ; -sub shell; #-> sub CPAN::clean ; sub clean; #-> sub CPAN::test ; sub test; -#-> sub CPAN::AUTOLOAD ; -sub AUTOLOAD { - my($l) = $AUTOLOAD; - $l =~ s/.*:://; - my(%EXPORT); - @EXPORT{@EXPORT} = ''; - if (exists $EXPORT{$l}){ - CPAN::Shell->$l(@_); - } else { - warn "CPAN doesn't know how to autoload $AUTOLOAD :-( -Nothing Done. -"; - CPAN::Shell->h; - } -} - #-> sub CPAN::all ; sub all { my($mgr,$class) = @_; @@ -190,6 +418,12 @@ sub DESTROY { &cleanup; # need an eval? } +#-> sub CPAN::cwd ; +sub cwd {Cwd::cwd();} + +#-> sub CPAN::getcwd ; +sub getcwd {Cwd::getcwd();} + #-> sub CPAN::exists ; sub exists { my($mgr,$class,$id) = @_; @@ -199,71 +433,63 @@ sub exists { exists $META->{$class}{$id}; } -#-> sub CPAN::hasFTP ; -sub hasFTP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasFTP'} = $arg; - } elsif (not defined $self->{'hasFTP'}) { - eval {require Net::FTP;}; - $self->{'hasFTP'} = $@ ? 0 : 1; - } - return $self->{'hasFTP'}; -} +#-> sub CPAN::has_inst +sub has_inst { + my($self,$mod,$message) = @_; + Carp::croak("CPAN->has_inst() called without an argument") + unless defined $mod; + if (defined $message && $message eq "no") { + $Dontload{$mod}||=1; + return 0; + } elsif (exists $Dontload{$mod}) { + return 0; + } + my $file = $mod; + $file =~ s|::|/|g; + $file =~ s|/|\\|g if $^O eq 'MSWin32'; + $file .= ".pm"; + if (exists $INC{$file} && $INC{$file}) { +# warn "$file in %INC"; #debug + return 1; + } elsif ( my($obj) = CPAN::Shell->expand('Module',$mod) ) { + if ($obj->inst_file) { + require $file; + print "CPAN: $mod successfully required\n"; -#-> sub CPAN::hasLWP ; -sub hasLWP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasLWP'} = $arg; - } elsif (not defined $self->{'hasLWP'}) { - eval {require LWP;}; - $LWP::VERSION ||= 0; - $self->{'hasLWP'} = $LWP::VERSION >= 4.98; - } - return $self->{'hasLWP'}; -} + if ($mod eq "CPAN::WAIT") { + push @CPAN::Shell::ISA, CPAN::WAIT unless $@; + } + warn $@ if $@; + return $@ ? 0 : 1; + } elsif ($mod eq "MD5"){ + print qq{ + CPAN: MD5 security checks disabled because MD5 not installed. + Please consider installing the MD5 module -#-> sub CPAN::hasMD5 ; -sub hasMD5 { - my($self,$arg) = @_; - if (defined $arg) { - $self->{'hasMD5'} = $arg; - } elsif (not defined $self->{'hasMD5'}) { - eval {require MD5;}; - if ($@) { - print "MD5 security checks disabled because MD5 not installed. - Please consider installing the MD5 module\n"; - $self->{'hasMD5'} = 0; - } else { - $self->{'hasMD5'}++; +}; + sleep 2; } - } - return $self->{'hasMD5'}; -} + } elsif (eval { require $file }) { + # we can still have luck, if the program is fed with a bogus + # database or what + return 1; + } elsif ($mod eq "Net::FTP") { + warn qq{ + Please, install Net::FTP as soon as possible. CPAN.pm installs it for you + if you just type + install Bundle::libnet + Thank you. -#-> sub CPAN::hasWAIT ; -sub hasWAIT { - my($self,$arg) = @_; - if (defined $arg) { - $self->{'hasWAIT'} = $arg; - } elsif (not defined $self->{'hasWAIT'}) { - eval {require CPAN::WAIT;}; - if ($@) { - $self->{'hasWAIT'} = 0; - } else { - $self->{'hasWAIT'} = 1; - } +}; + sleep 2; } - return $self->{'hasWAIT'}; + return 0; } #-> sub CPAN::instance ; sub instance { my($mgr,$class,$id) = @_; - ### CPAN::Index->reload; ### not faster: unless time - $CPAN::Index::last_time > 60; CPAN::Index->reload; - ### Carp::croak "instance called without class argument" unless $class; $id ||= ""; $META->{$class}{$id} ||= $class->new(ID => $id ); } @@ -285,96 +511,9 @@ sub cleanup { return unless -f $META->{'LOCK'}; unlink $META->{'LOCK'}; print STDERR "Lockfile removed.\n"; -# my $mess = Carp::longmess(@_); -# die @_; -} - -#-> sub CPAN::shell ; -sub shell { - $Suppress_readline ||= ! -t STDIN; - - my $prompt = "cpan> "; - local($^W) = 1; - unless ($Suppress_readline) { - require Term::ReadLine; -# import Term::ReadLine; - $term = new Term::ReadLine 'CPAN Monitor'; - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::complete'; - } - - no strict; - $META->checklock(); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = Cwd->$getcwd(); - my $rl_avail = $Suppress_readline ? "suppressed" : - ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : - "available (get Term::ReadKey and Term::ReadLine::Perl ". - "or get Term::ReadLine::Gnu)"; - - print qq{ -cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) -Readline support $rl_avail - -} unless $CPAN::Config->{'inhibit_startup_message'} ; - while () { - if ($Suppress_readline) { - print $prompt; - last unless defined ($_ = <> ); - chomp; - } else { -# if (defined($CPAN::ANDK) && $CPAN::DEBUG) { # !$CPAN::ANDK++;$CPAN::DEBUG=1024 -# my($report,$item); -# $report = ""; -# for $item (qw/ReadLine IN OUT MinLine findConsole Features/) { -# $report .= sprintf "%-15s", $item; -# $report .= $term->$item() || ""; -# $report .= "\n"; -# } -# print $report; -# CPAN->debug($report); -# } - last unless defined ($_ = $term->readline($prompt)); - } - s/^\s//; - next if /^$/; - $_ = 'h' if $_ eq '?'; - if (/^\!/) { - s/^\!//; - my($eval) = $_; - package CPAN::Eval; - use vars qw($import_done); - CPAN->import(':DEFAULT') unless $import_done++; - CPAN->debug("eval[$eval]") if $CPAN::DEBUG; - eval($eval); - warn $@ if $@; - } elsif (/^q(?:uit)?$/i) { - last; - } elsif (/./) { - my(@line); - if ($] < 5.00322) { # parsewords had a bug until recently - @line = split; - } else { - eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next if $@; - } - $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; - my $command = shift @line; - eval { CPAN::Shell->$command(@line) }; - warn $@ if $@; - } - } continue { - &cleanup, die if $Signal; - chdir $cwd; - print "\n"; - } } package CPAN::CacheMgr; -use vars qw($Du); -@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); -use File::Find; #-> sub CPAN::CacheMgr::as_string ; sub as_string { @@ -419,11 +558,12 @@ sub dir { #-> sub CPAN::CacheMgr::entries ; sub entries { my($self,$dir) = @_; + return unless defined $dir; $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my($cwd) = Cwd->$getcwd(); + my($cwd) = CPAN->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); @@ -517,10 +657,16 @@ sub debug { # eg readline ($caller) = caller(0); $caller =~ s/.*:://; -# print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; -# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; + $arg = "" unless defined $arg; + my $rest = join ":", map { defined $_ ? $_ : "UNDEF" } @rest; +# print "caller[$caller]\n"; +# print "func[$func]\n"; +# print "line[$line]\n"; +# print "rest[@rest]\n"; +# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]\n"; +# print "CPAN::DEBUG[$CPAN::DEBUG]\n"; if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ - if (ref $arg) { + if ($arg and ref $arg) { eval { require Data::Dumper }; if ($@) { print $arg->as_string; @@ -528,20 +674,12 @@ sub debug { print Data::Dumper::Dumper($arg); } } else { - print "Debug($caller:$func,$line,@rest): $arg\n" + print "Debug($caller:$func,$line,[$rest]): $arg\n" } } } package CPAN::Config; -import ExtUtils::MakeMaker 'neatvalue'; -use vars qw(%can); - -%can = ( - 'commit' => "Commit changes to disk", - 'defaults' => "Reload defaults from disk", - 'init' => "Interactive setting of all options", -); #-> sub CPAN::Config::edit ; sub edit { @@ -580,7 +718,8 @@ sub edit { } else { $CPAN::Config->{$o} = $args[0] if defined $args[0]; print " $o "; - print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; + print defined $CPAN::Config->{$o} ? + $CPAN::Config->{$o} : "UNDEFINED"; } } } @@ -608,8 +747,9 @@ Please specify a filename where to save the configuration or try my $msg = <<EOF unless $configpm =~ /MyConfig/; # This is CPAN.pm's systemwide configuration file. This file provides -# defaults for users, and the values can be changed in a per-user configuration -# file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm. +# defaults for users, and the values can be changed in a per-user +# configuration file. The user-config file is being looked for as +# ~/.cpan/CPAN/MyConfig.pm. EOF $msg ||= "\n"; @@ -654,7 +794,6 @@ sub init { 1; } -my $dot_cpan; #-> sub CPAN::Config::load ; sub load { my($self) = shift; @@ -664,8 +803,9 @@ sub load { eval {require CPAN::MyConfig;}; # where you can override system wide settings return unless @miss = $self->not_loaded; require CPAN::FirstTime; - my($configpm,$fh,$redo); + my($configpm,$fh,$redo,$theycalled); $redo ||= ""; + $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { $configpm = $INC{"CPAN/Config.pm"}; $redo++; @@ -720,7 +860,7 @@ sub load { We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -} if $redo ; +} if $redo && ! $theycalled; print qq{ $configpm initialized. }; @@ -770,8 +910,8 @@ EOF undef; #don't reprint CPAN::Config } -#-> sub CPAN::Config::complete ; -sub complete { +#-> sub CPAN::Config::cpl ; +sub cpl { my($word,$line,$pos) = @_; $word ||= ""; my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); @@ -779,34 +919,6 @@ sub complete { } package CPAN::Shell; -use vars qw($AUTOLOAD $redef @ISA); -@CPAN::Shell::ISA = qw(CPAN::Debug); -if ($CPAN::META->hasWAIT) { - unshift @ISA, "CPAN::WAIT"; -} -# private function ro re-eval this module (handy during development) -#-> sub CPAN::Shell::AUTOLOAD ; -sub AUTOLOAD { - my($autoload) = $AUTOLOAD; - $autoload =~ s/.*:://; - if ($autoload =~ /^w/) { - if ($CPAN::META->hasWAIT) { - CPAN::WAIT->wh; - return; - } else { - print STDERR qq{ -Commands starting with "w" require CPAN::WAIT to be installed. -Please consider installing CPAN::WAIT to use the fulltext index. -Type "install CPAN::WAIT" and restart CPAN.pm. -} - } - } else { - warn "CPAN::Shell doesn't know how to autoload $autoload :-( -Nothing Done. -"; - } - CPAN::Shell->h; -} #-> sub CPAN::Shell::h ; sub h { @@ -847,7 +959,7 @@ sub a { print shift->format_result('Author',@_);} sub b { my($self,@which) = @_; CPAN->debug("which[@which]") if $CPAN::DEBUG; - my($incdir,$bdir,$dh); + my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { $bdir = $CPAN::META->catdir($incdir,"Bundle"); if ($dh = DirHandle->new($bdir)) { # may fail @@ -1297,8 +1409,6 @@ sub clean { shift->rematein('clean',@_); } sub look { shift->rematein('look',@_); } package CPAN::FTP; -use vars qw($Ua); -@CPAN::FTP::ISA = qw(CPAN::Debug); #-> sub CPAN::FTP::ftp_get ; sub ftp_get { @@ -1331,15 +1441,22 @@ sub ftp_get { } #-> sub CPAN::FTP::localize ; +# sorry for the ugly code here, I'll clean it up as soon as Net::FTP +# is in the core sub localize { my($self,$file,$aslocal,$force) = @_; $force ||= 0; Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal; - $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG; + $self->debug("file[$file] aslocal[$aslocal] force[$force]") + if $CPAN::DEBUG; return $aslocal if -f $aslocal && -r _ && ! $force; - rename $aslocal, "$aslocal.bak" if -f $aslocal; + my($restore) = 0; + if (-f $aslocal){ + rename $aslocal, "$aslocal.bak"; + $restore++; + } my($aslocal_dir) = File::Basename::dirname($aslocal); File::Path::mkpath($aslocal_dir); @@ -1349,10 +1466,10 @@ sub localize { to insufficient permissions.\n} unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require LWP::UserAgent; unless ($Ua) { - $Ua = new LWP::UserAgent; + $Ua = LWP::UserAgent->new; my($var); $Ua->proxy('ftp', $var) if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'}; @@ -1373,12 +1490,12 @@ sub localize { $self->debug("localizing[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require URI::URL; - my $u = new URI::URL $url; + my $u = URI::URL->new($url); $l = $u->path; } else { # works only on Unix, is poorly constructed, but - # hopefully better than nothing. + # hopefully better than nothing. # RFC 1738 says fileurl BNF is # fileurl = "file://" [ host | "localhost" ] "/" fpath # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code @@ -1394,7 +1511,7 @@ sub localize { } } - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { print "Fetching $url with LWP\n"; my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { @@ -1404,7 +1521,7 @@ sub localize { if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # that's the nice and easy way thanks to Graham my($host,$dir,$getfile) = ($1,$2,$3); - if ($CPAN::META->hasFTP) { + if ($CPAN::META->has_inst('Net::FTP')) { $dir =~ s|/+|/|g; $self->debug("Going to fetch file [$getfile] from dir [$dir] @@ -1412,13 +1529,6 @@ sub localize { as local [$aslocal]") if $CPAN::DEBUG; CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; warn "Net::FTP failed for some reason\n"; - } else { - warn qq{ - Please, install Net::FTP as soon as possible. Just type - install Net::FTP - Thank you. - -} } } @@ -1430,7 +1540,7 @@ sub localize { # does ncftp handle http? for $funkyftp ($CPAN::Config->{'lynx'},$CPAN::Config->{'ncftp'}) { next unless defined $funkyftp; - next unless -x $funkyftp; + next if $funkyftp =~ /^\s*$/; my($want_compressed); print( qq{ @@ -1442,8 +1552,12 @@ Trying with $funkyftp to get $source_switch = "-source" if $funkyftp =~ /\blynx$/; $source_switch = "-c" if $funkyftp =~ /\bncftp$/; my($system) = "$funkyftp $source_switch '$url' > $aslocal"; + $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); - if (($wstatus = system($system)) == 0) { + if (($wstatus = system($system)) == 0 + && + -s $aslocal # lynx returns 0 on my system even if it fails + ) { if ($want_compressed) { $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; if (system($system) == 0) { @@ -1465,9 +1579,11 @@ Trying with $funkyftp to get } } else { my $estatus = $wstatus >> 8; + my $size = -s $aslocal; print qq{ System call "$system" -returned status $estatus (wstat $wstatus) +returned status $estatus (wstat $wstatus), left +$aslocal with size $size }; } } @@ -1581,8 +1697,8 @@ Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" print "Can't access URL $url.\n\n"; my(@mess,$mess); - push @mess, "LWP" unless CPAN->hasLWP; - push @mess, "Net::FTP" unless CPAN->hasFTP; + push @mess, "LWP" unless CPAN->has_inst('LWP'); + push @mess, "Net::FTP" unless CPAN->has_inst('Net::FTP'); my($ext); for $ext (qw/lynx ncftp ftp/) { $CPAN::Config->{$ext} ||= ""; @@ -1596,7 +1712,7 @@ Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" print Text::Wrap::wrap("","",$mess), "\n"; } print "Cannot fetch $file\n"; - if (-f "$aslocal.bak") { + if ($restore) { rename "$aslocal.bak", $aslocal; print "Trying to get away with old file:\n"; print $self->ls($aslocal); @@ -1615,7 +1731,7 @@ sub ls { my($perms,%user,%group); my $pname = $name; - if (defined $blocks) { + if ($blocks) { $blocks = int(($blocks + 1) / 2); } else { @@ -1728,10 +1844,9 @@ sub contains { } package CPAN::Complete; -@CPAN::Complete::ISA = qw(CPAN::Debug); -#-> sub CPAN::Complete::complete ; -sub complete { +#-> sub CPAN::Complete::cpl ; +sub cpl { my($word,$line,$pos) = @_; $word ||= ""; $line ||= ""; @@ -1753,44 +1868,44 @@ sub complete { } elsif ( $line !~ /^[\!abdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { - @return = completex('CPAN::Author',$word); + @return = cplx('CPAN::Author',$word); } elsif ($line =~ /^b\s/) { - @return = completex('CPAN::Bundle',$word); + @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { - @return = completex('CPAN::Distribution',$word); + @return = cplx('CPAN::Distribution',$word); } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { - @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word)); + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { - @return = complete_any($word); + @return = cpl_any($word); } elsif ($line =~ /^reload\s/) { - @return = complete_reload($word,$line,$pos); + @return = cpl_reload($word,$line,$pos); } elsif ($line =~ /^o\s/) { - @return = complete_option($word,$line,$pos); + @return = cpl_option($word,$line,$pos); } else { @return = (); } return @return; } -#-> sub CPAN::Complete::completex ; -sub completex { +#-> sub CPAN::Complete::cplx ; +sub cplx { my($class, $word) = @_; grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); } -#-> sub CPAN::Complete::complete_any ; -sub complete_any { +#-> sub CPAN::Complete::cpl_any ; +sub cpl_any { my($word) = shift; return ( - completex('CPAN::Author',$word), - completex('CPAN::Bundle',$word), - completex('CPAN::Distribution',$word), - completex('CPAN::Module',$word), + cplx('CPAN::Author',$word), + cplx('CPAN::Bundle',$word), + cplx('CPAN::Distribution',$word), + cplx('CPAN::Module',$word), ); } -#-> sub CPAN::Complete::complete_reload ; -sub complete_reload { +#-> sub CPAN::Complete::cpl_reload ; +sub cpl_reload { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; @@ -1800,8 +1915,8 @@ sub complete_reload { return grep /^\Q$word\E/, @ok if @words == 2 && $word; } -#-> sub CPAN::Complete::complete_option ; -sub complete_option { +#-> sub CPAN::Complete::cpl_option ; +sub cpl_option { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; @@ -1813,17 +1928,13 @@ sub complete_option { } elsif ($words[1] eq 'index') { return (); } elsif ($words[1] eq 'conf') { - return CPAN::Config::complete(@_); + return CPAN::Config::cpl(@_); } elsif ($words[1] eq 'debug') { return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; } } package CPAN::Index; -use vars qw($last_time $date_of_03); -@CPAN::Index::ISA = qw(CPAN::Debug); -$last_time ||= 0; -$date_of_03 ||= 0; #-> sub CPAN::Index::force_reload ; sub force_reload { @@ -1845,7 +1956,7 @@ sub reload { my($debug,$t2); $last_time = $time; - $cl->read_authindex($cl->reload_x( + $cl->rd_authindex($cl->reload_x( "authors/01mailrc.txt.gz", "01mailrc.gz", $force)); @@ -1853,7 +1964,7 @@ sub reload { $debug = "timing reading 01[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modpacks($cl->reload_x( + $cl->rd_modpacks($cl->reload_x( "modules/02packages.details.txt.gz", "02packag.gz", $force)); @@ -1861,7 +1972,7 @@ sub reload { $debug .= "02[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modlist($cl->reload_x( + $cl->rd_modlist($cl->reload_x( "modules/03modlist.data.gz", "03mlist.gz", $force)); @@ -1875,14 +1986,18 @@ sub reload { sub reload_x { my($cl,$wanted,$localname,$force) = @_; $force ||= 0; - CPAN::Config->load; # we should guarantee loading wherever we rely on Config XXX - my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname); + CPAN::Config->load; # we should guarantee loading wherever we rely + # on Config XXX + my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'}, + $localname); if ( -f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force ) { my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; +# use Devel::Symdump; +# print Devel::Symdump->isa_tree, "\n"; $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. qq{day$s. I\'ll use that.}); return $abs_wanted; @@ -1892,8 +2007,8 @@ sub reload_x { return CPAN::FTP->localize($wanted,$abs_wanted,$force); } -#-> sub CPAN::Index::read_authindex ; -sub read_authindex { +#-> sub CPAN::Index::rd_authindex ; +sub rd_authindex { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -1912,8 +2027,8 @@ sub read_authindex { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modpacks ; -sub read_modpacks { +#-> sub CPAN::Index::rd_modpacks ; +sub rd_modpacks { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -1924,6 +2039,7 @@ sub read_modpacks { while (<$fh>) { chomp; my($mod,$version,$dist) = split; +$dist = '' unless defined $dist; ### $version =~ s/^\+//; # if it as a bundle, instatiate a bundle object @@ -1987,8 +2103,8 @@ sub read_modpacks { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modlist ; -sub read_modlist { +#-> sub CPAN::Index::rd_modlist ; +sub rd_modlist { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -2018,7 +2134,6 @@ sub read_modlist { } package CPAN::InfoObj; -@CPAN::InfoObj::ISA = qw(CPAN::Debug); #-> sub CPAN::InfoObj::new ; sub new { my $this = bless {}, shift; %$this = @_; $this } @@ -2070,7 +2185,6 @@ sub author { } package CPAN::Author; -@CPAN::Author::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Author::as_glimpse ; sub as_glimpse { @@ -2095,7 +2209,6 @@ sub fullname { shift->{'FULLNAME'} } sub email { shift->{'EMAIL'} } package CPAN::Distribution; -@CPAN::Distribution::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Distribution::called_for ; sub called_for { @@ -2131,34 +2244,33 @@ sub get { my $packagedir; $self->debug("local_file[$local_file]") if $CPAN::DEBUG; - if ($CPAN::META->hasMD5) { + if ($CPAN::META->has_inst('MD5')) { + $self->debug("MD5 is installed, verifying"); $self->verifyMD5; + } else { + $self->debug("MD5 is NOT installed"); + } + $self->debug("Removing tmp") if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; + chdir "tmp"; + $self->debug("Changed directory to tmp") if $CPAN::DEBUG; + if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ + $self->untar_me($local_file); + } elsif ( $local_file =~ /\.zip$/i ) { + $self->unzip_me($local_file); + } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) { + $self->pm2dir_me($local_file); + } else { + $self->{archived} = "NO"; } - if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){ - $self->debug("Removing tmp") if $CPAN::DEBUG; - File::Path::rmtree("tmp"); - mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!"; + chdir ".."; + if ($self->{archived} ne 'NO') { chdir "tmp"; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - if ($local_file =~ /z$/i){ - $self->{archived} = "tar"; - if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")== 0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } elsif ($local_file =~ /zip$/i) { - $self->{archived} = "zip"; - if (system("$CPAN::Config->{unzip} $local_file") == 0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } # Let's check if the package has its own directory. - opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC?? - closedir DIR; + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? + $dh->close; my ($distdir,$packagedir); if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; @@ -2179,8 +2291,8 @@ sub get { } } $self->{'build_dir'} = $packagedir; - chdir ".."; + $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; File::Path::rmtree("tmp"); @@ -2198,22 +2310,59 @@ sub get { my $fh = FileHandle->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl"); my $cf = $self->called_for || "unknown"; - $fh->print(qq{ -# This Makefile.PL has been autogenerated by the module CPAN.pm + $fh->print( +qq{# This Makefile.PL has been autogenerated by the module CPAN.pm +# because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ + use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); + }); print qq{Package comes without Makefile.PL.\n}. qq{ Writing one on our own (calling it $cf)\n}; } } - } else { - $self->{archived} = "NO"; } return $self; } +sub untar_me { + my($self,$local_file) = @_; + $self->{archived} = "tar"; + my $system = "$CPAN::Config->{gzip} --decompress --stdout " . + "$local_file | $CPAN::Config->{tar} xvf -"; + if (system($system)== 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub unzip_me { + my($self,$local_file) = @_; + $self->{archived} = "zip"; + my $system = "$CPAN::Config->{unzip} $local_file"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub pm2dir_me { + my($self,$local_file) = @_; + $self->{archived} = "pm"; + my $to = File::Basename::basename($local_file); + $to =~ s/\.(gz|Z)$//; + my $system = "$CPAN::Config->{gzip} --decompress --stdout $local_file > $to"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + #-> sub CPAN::Distribution::new ; sub new { my($class,%att) = @_; @@ -2243,7 +2392,7 @@ Please define it with "o conf shell <your shell>" $dir = $self->dir; my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = Cwd->$getcwd(); + my $pwd = CPAN->$getcwd(); chdir($dir); print qq{Working directory is $dir.\n}; system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error"; @@ -2283,111 +2432,105 @@ sub verifyMD5 { $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; print join "", map {" $_\n"} @e and return if @e; } - my($local_file); - my(@local) = split("/",$self->{ID}); - my($basename) = pop @local; + my($lc_want,$lc_file,@local,$basename); + @local = split("/",$self->{ID}); + pop @local; push @local, "CHECKSUMS"; - my($local_wanted) = - CPAN->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - @local - ); + $lc_want = + CPAN->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @local); local($") = "/"; if ( - -f $local_wanted + -f $lc_want && - $self->MD5_check_file($local_wanted,$basename) + $self->MD5_check_file($lc_want) ) { return $self->{MD5_STATUS} = "OK"; } - $local_file = CPAN::FTP->localize( - "authors/id/@local", - $local_wanted, - 'force>:-{'); - my($checksum_pipe); - if ($local_file) { - # fine - } else { + $lc_file = CPAN::FTP->localize("authors/id/@local", + $lc_want,'force>:-{'); + unless ($lc_file) { $local[-1] .= ".gz"; - $local_file = CPAN::FTP->localize( - "authors/id/@local", - "$local_wanted.gz", - 'force>:-{' - ); - my $system = "$CPAN::Config->{gzip} --decompress $local_file"; - system($system) == 0 or die "Could not uncompress $local_file"; - $local_file =~ s/\.gz$//; + $lc_file = CPAN::FTP->localize("authors/id/@local", + "$lc_want.gz",'force>:-{'); + my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); + system(@system) == 0 or die "Could not uncompress $lc_file"; + $lc_file =~ s/\.gz$//; } - $self->MD5_check_file($local_file,$basename); + $self->MD5_check_file($lc_file); } #-> sub CPAN::Distribution::MD5_check_file ; sub MD5_check_file { - my($self,$lfile,$basename) = @_; - my($cksum); - my $fh = new FileHandle; - local($/) = undef; - if (open $fh, $lfile){ + my($self,$chk_file) = @_; + my($cksum,$file,$basename); + $file = $self->{localfile}; + $basename = File::Basename::basename($file); + my $fh = FileHandle->new; + local($/); + if (open $fh, $chk_file){ my $eval = <$fh>; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); - Carp::confess($@) if $@; - if ($cksum->{$basename}->{md5}) { - $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") - if $CPAN::DEBUG; - my $file = $self->{localfile}; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|"; - if ( - open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5}) - or - open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) - ){ - print "Checksum for $file ok\n"; - return $self->{MD5_STATUS} = "OK"; - } else { - print join( - "", - qq{Checksum mismatch for distribution file. }, - qq{Please investigate.\n\n} - ); - print $self->as_string; - print $CPAN::META->instance( - 'CPAN::Author', - $self->{CPAN_USERID} - )->as_string; - my $wrap = qq{I\'d recommend removing $self->{'localfile'}}. - qq{, put another URL at the top of the list of URLs to }. - qq{visit, and restart CPAN.pm. If all this doesn\'t help, }. - qq{please contact the author or your CPAN site admin}; - print Text::Wrap::wrap("","",$wrap); - print "\n\n"; - sleep 3; - return; - } - close $fh if fileno($fh); + if ($@) { + rename $chk_file, "$chk_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $chk_file for reading"; + } + if ($cksum->{$basename}->{md5}) { + $self->debug("Found checksum for $basename:" . + "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; + my $pipe = "$CPAN::Config->{gzip} --decompress ". + "--stdout $file|"; + if ( + open($fh, $file) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{md5}) + or + open($fh, $pipe) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) + ){ + print "Checksum for $file ok\n"; + return $self->{MD5_STATUS} = "OK"; } else { - $self->{MD5_STATUS} ||= ""; - if ($self->{MD5_STATUS} eq "NIL") { - print "\nNo md5 checksum for $basename in local $lfile."; - print "Removing $lfile\n"; - unlink $lfile or print "Could not unlink: $!"; - sleep 1; - } - $self->{MD5_STATUS} = "NIL"; + print qq{Checksum mismatch for distribution file. }. + qq{Please investigate.\n\n}; + print $self->as_string; + print $CPAN::META->instance( + 'CPAN::Author', + $self->{CPAN_USERID} + )->as_string; + my $wrap = qq{I\'d recommend removing $file. It seems to +be a bogus file. Maybe you have configured your \`urllist\' with a +bad URL. Please check this array with \`o conf urllist\', and +retry.}; + print Text::Wrap::wrap("","",$wrap); + print "\n\n"; + sleep 3; return; } + close $fh if fileno($fh); } else { - Carp::carp "Could not open $lfile for reading"; + $self->{MD5_STATUS} ||= ""; + if ($self->{MD5_STATUS} eq "NIL") { + print "\nNo md5 checksum for $basename in local $chk_file."; + print "Removing $chk_file\n"; + unlink $chk_file or print "Could not unlink: $!"; + sleep 1; + } + $self->{MD5_STATUS} = "NIL"; + return; } } #-> sub CPAN::Distribution::eq_MD5 ; sub eq_MD5 { my($self,$fh,$expectMD5) = @_; - my $md5 = new MD5; + my $md5 = MD5->new; $md5->addfile($fh); my $hexdigest = $md5->hexdigest; $hexdigest eq $expectMD5; @@ -2412,7 +2555,7 @@ sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = Cwd->$getcwd(); + my $pwd = CPAN->$getcwd(); my $candidate = $CPAN::META->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { @@ -2626,7 +2769,6 @@ sub dir { } package CPAN::Bundle; -@CPAN::Bundle::ISA = qw(CPAN::Module); #-> sub CPAN::Bundle::as_string ; sub as_string { @@ -2656,7 +2798,7 @@ sub contains { $parsefile = $to; } my @result; - my $fh = new FileHandle; + my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; @@ -2685,7 +2827,7 @@ sub find_bundle_file { unless (-f $manifest) { require ExtUtils::Manifest; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = Cwd->$getcwd(); + my $cwd = CPAN->$getcwd(); chdir $where; ExtUtils::Manifest::mkmanifest(); chdir $cwd; @@ -2710,7 +2852,7 @@ sub inst_file { ($me = $self->id) =~ s/.*://; $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm"); return $self->{'INST_FILE'} = $inst_file if -f $inst_file; -# $inst_file = +# $inst_file = $self->SUPER::inst_file; # return $self->{'INST_FILE'} = $inst_file if -f $inst_file; # return $self->{'INST_FILE'}; # even if undefined? @@ -2764,7 +2906,6 @@ sub readme { } package CPAN::Module; -@CPAN::Module::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Module::as_glimpse ; sub as_glimpse { @@ -2966,10 +3107,10 @@ sub inst_version { $have; } -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +package CPAN; 1; + __END__ =head1 NAME @@ -3048,13 +3189,13 @@ item is displayed. If the search finds one item, we display the result of object-E<gt>as_string, but if we find more than one, we display each as object-E<gt>as_glimpse. E.g. - cpan> a ANDK + cpan> a ANDK Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König - cpan> a /andk/ + cpan> a /andk/ Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König @@ -3072,11 +3213,11 @@ be. Is it a distribution file (recognized by embedded slashes), this file is being processed. Is it a module, CPAN determines the distribution file where this module is included and processes that. -Any C<make>, C<test>, and C<readme> are run unconditionally. A +Any C<make>, C<test>, and C<readme> are run unconditionally. A install <distribution_file> -also is run unconditionally. But for +also is run unconditionally. But for install <module> @@ -3146,7 +3287,7 @@ perl breaks binary compatibility. If one of the modules that CPAN uses is in turn depending on binary compatibility (so you cannot run CPAN commands), then you should try the CPAN::Nox module for recovery. -=head2 The 4 Classes: Authors, Bundles, Modules, Distributions +=head2 The 4 C<CPAN::*> Classes: Author, Bundle, Module, Distribution Although it may be considered internal, the class hierarchie does matter for both users and programmer. CPAN.pm deals with above @@ -3177,7 +3318,7 @@ BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if you would like to install version 1.23_90, you need to know where the distribution file resides on CPAN relative to the authors/id/ directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz, -so he would have say +so he would have to say install BAR/Foo-1.23_90.tar.gz @@ -3192,9 +3333,9 @@ functions in the calling package (C<install(...)>). There's currently only one class that has a stable interface, CPAN::Shell. All commands that are available in the CPAN shell are -methods of the class CPAN::Shell. The commands that produce listings -of modules (C<r>, C<autobundle>, C<u>) return a list of the IDs of all -modules within the list. +methods of the class CPAN::Shell. Each of the commands that produce +listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the +IDs of all modules within the list. =over 2 @@ -3202,13 +3343,15 @@ modules within the list. The IDs of all objects available within a program are strings that can be expanded to the corresponding real objects with the -C<CPAN::Shell-E<gt>expand()> method. Expand returns a list of -CPAN::Module objects according to the C<@things> arguments given. In -scalar context it only returns the first element of the list. +C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a +list of CPAN::Module objects according to the C<@things> arguments +given. In scalar context it only returns the first element of the +list. =item Programming Examples -This enables the programmer to do operations like these: +This enables the programmer to do operations that combine +functionalities that are available in the shell. # install everything that is outdated on my disk: perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' @@ -3219,8 +3362,17 @@ This enables the programmer to do operations like these: $obj->install; } + # list all modules on my disk that have no VERSION number + for $mod (CPAN::Shell->expand("Module","/./")){ + next unless $mod->inst_file; + next if $mod->inst_version; + print "No VERSION in ", $mod->id, "\n"; + } + =back +=head2 Methods in the four + =head2 Cache Manager Currently the cache manager only keeps track of the build directory diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 8ac180dc71..3e572d67ae 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -15,7 +15,7 @@ use ExtUtils::MakeMaker qw(prompt); use FileHandle (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.18 $, 10; +$VERSION = substr q$Revision: 1.20 $, 10; =head1 NAME @@ -126,20 +126,33 @@ those. }; - my(@path) = split($Config{path_sep},$ENV{PATH}); + my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; my $prog; for $prog (qw/gzip tar unzip make lynx ncftp ftp/){ - my $path = $CPAN::Config->{$prog} || find_exe($prog,[@path]) || $prog; + my $path = $CPAN::Config->{$prog} || ""; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } else { + $path = ''; + } + $path ||= find_exe($prog,[@path]); + warn "Warning: $prog not found in PATH\n" unless -e $path; $ans = prompt("Where is your $prog program?",$path) || $path; $CPAN::Config->{$prog} = $ans; } my $path = $CPAN::Config->{'pager'} || $ENV{PAGER} || find_exe("less",[@path]) || find_exe("more",[@path]) || "more"; - $ans = prompt("What is your favorite pager program?",$path) || $path; + $ans = prompt("What is your favorite pager program?",$path); $CPAN::Config->{'pager'} = $ans; - $path = $CPAN::Config->{'shell'} || $ENV{SHELL} || ""; - $ans = prompt("What is your favorite shell?",$path) || $path; + $path = $CPAN::Config->{'shell'}; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } + $path ||= $ENV{SHELL}; + $ans = prompt("What is your favorite shell?",$path); $CPAN::Config->{'shell'} = $ans; # @@ -185,7 +198,7 @@ the default and recommended setting. $default = $CPAN::Config->{inactivity_timeout} || 0; $CPAN::Config->{inactivity_timeout} = - prompt("Timout for inacivity during Makefile.PL?",$default); + prompt("Timeout for inacivity during Makefile.PL?",$default); # @@ -268,12 +281,11 @@ the \$CPAN::Config takes precedence. sub find_exe { my($exe,$path) = @_; - my($dir,$MY); - $MY = {}; - bless $MY, 'MY'; + my($dir); + #warn "in find_exe exe[$exe] path[@$path]"; for $dir (@$path) { - my $abs = $MY->catfile($dir,$exe); - if ($MY->maybe_command($abs)) { + my $abs = MM->catfile($dir,$exe); + if (MM->maybe_command($abs)) { return $abs; } } diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm index dc561977c4..23ad760b87 100644 --- a/lib/CPAN/Nox.pm +++ b/lib/CPAN/Nox.pm @@ -2,8 +2,8 @@ BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} use CPAN; -$CPAN::META->hasMD5(0); -$CPAN::META->hasLWP(0); +$CPAN::META->has_inst('MD5','no'); +$CPAN::META->has_inst('LWP','no'); @EXPORT = @CPAN::EXPORT; *AUTOLOAD = \&CPAN::AUTOLOAD; diff --git a/lib/Carp.pm b/lib/Carp.pm index c0cfe08d44..351f83bdf5 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -2,9 +2,12 @@ package Carp; =head1 NAME -carp - warn of errors (from perspective of caller) +carp - warn of errors (from perspective of caller) -croak - die of errors (from perspective of caller) +cluck - warn of errors with stack backtrace + (not exported by default) + +croak - die of errors (from perspective of caller) confess - die of errors with stack backtrace @@ -13,6 +16,9 @@ confess - die of errors with stack backtrace use Carp; croak "We're outta here!"; + use Carp qw(cluck); + cluck "This is how we got here!"; + =head1 DESCRIPTION The Carp routines are useful in your own modules because @@ -22,10 +28,24 @@ routine Foo() that has a carp() in it, then the carp() will report the error as occurring where Foo() was called, not where carp() was called. +=head2 Forcing a Stack Trace + +As a debugging aid, you can force Carp to treat a croak as a confess +and a carp as a cluck across I<all> modules. In other words, force a +detailed stack trace to be given. This can be very helpful when trying +to understand why, or from where, a warning or error is being generated. + +This feature is enabled by 'importing' the non-existant symbol +'verbose'. You would typically enable it by saying + + perl -MCarp=verbose script.pl + +or by including the string C<MCarp=verbose> in the L<PERL5OPT> +environment variable. + =cut -# This package implements handy routines for modules that wish to throw -# exceptions outside of the current package. +# This package is heavily used. Be small. Be fast. Be good. $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. @@ -35,6 +55,19 @@ $MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; @ISA = Exporter; @EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(cluck verbose); +@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +sub export_fail { + shift; + if ($_[0] eq 'verbose') { + local $^W = 0; + *shortmess = \&longmess; + shift; + } + return @_; +} + sub longmess { my $error = join '', @_; @@ -138,5 +171,6 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages sub confess { die longmess @_; } sub croak { die shortmess @_; } sub carp { warn shortmess @_; } +sub cluck { warn longmess @_; } 1; diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index eca2c6c5e3..09ab196254 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -146,9 +146,6 @@ sub struct { # Create accessor methods. - if ( $got_class && $CHECK_CLASS_MEMBERSHIP ) { - $out .= " use UNIVERSAL;\n"; - } my( $pre, $pst, $sel ); $cnt = 0; foreach $name (@methods){ diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 66459b8af0..3f42e407e0 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -108,7 +108,8 @@ sub export { last; } } elsif ($sym !~ s/^&// || !$exports{$sym}) { - warn qq["$sym" is not exported by the $pkg module]; + require Carp; + Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; } } @@ -137,8 +138,9 @@ sub export { if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { - warn qq["$sym" is not implemented by the $pkg module ], - "on this architecture"; + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); } if (@failed) { require Carp; @@ -165,6 +167,15 @@ sub export { } } +sub export_to_level +{ + my $pkg = shift; + my ($level, $junk) = (shift, shift); # need to get rid of first arg + # we know it already. + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); @@ -172,6 +183,7 @@ sub import { } + # Utility functions sub _push_tags { @@ -346,6 +358,53 @@ You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the specifications are being processed and what is actually being imported into modules. +=head2 Exporting without using Export's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Export's import method. The export_to_level +method looks like: + +MyPackage->export_to_level($where_to_export, @what_to_export); + +where $where_to_export is an integer telling how far up the calling stack +to export your symbols, and @what_to_export is an array telling what +symbols *to* export (usually this is @_). + +For example, suppose that you have a module, A, which already has an +import function: + +package A; + +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; # not a very useful import method +} + +and you want to Export symbol $A::b back to the module that called +package A. Since Exporter relies on the import method to work, via +inheritance, as it stands Exporter::import() will never get called. +Instead, say the following: + +package A; +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; + A->export_to_level(1, @_); +} + +This will export the symbols one level 'above' the current package - ie: to +the program or module that used package A. + +Note: Be careful not to modify '@_' at all before you call export_to_level +- or people using your package will get very unexplained results! + + =head2 Module Version Checking The Exporter module will convert an attempt to import a number from a diff --git a/lib/ExtUtils/Command.pm b/lib/ExtUtils/Command.pm index bdf32d4218..d37d0f3c25 100644 --- a/lib/ExtUtils/Command.pm +++ b/lib/ExtUtils/Command.pm @@ -10,7 +10,7 @@ require Exporter; use vars qw(@ISA @EXPORT $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); -$VERSION = '1.00'; +$VERSION = '1.01'; =head1 NAME @@ -18,16 +18,16 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 SYNOPSIS - perl -MExtUtils::command -e cat files... > destination - perl -MExtUtils::command -e mv source... destination - perl -MExtUtils::command -e cp source... destination - perl -MExtUtils::command -e touch files... - perl -MExtUtils::command -e rm_f file... - perl -MExtUtils::command -e rm_rf directories... - perl -MExtUtils::command -e mkpath directories... - perl -MExtUtils::command -e eqtime source destination - perl -MExtUtils::command -e chmod mode files... - perl -MExtUtils::command -e test_f file + perl -MExtUtils::Command -e cat files... > destination + perl -MExtUtils::Command -e mv source... destination + perl -MExtUtils::Command -e cp source... destination + perl -MExtUtils::Command -e touch files... + perl -MExtUtils::Command -e rm_f file... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e chmod mode files... + perl -MExtUtils::Command -e test_f file =head1 DESCRIPTION diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index 0db3ecfcc4..04ce1763da 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -17,11 +17,7 @@ use vars qw(@ISA @EXPORT $VERSION ); use strict; -$VERSION = sprintf("%d.%02d", q$Revision: 1.2501 $ =~ /(\d+)\.(\d+)/); -#for the namespace change -$Devel::embed::VERSION = "99.99"; - -sub Version { $VERSION; } +$VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&xsinit &ldopts @@ -35,6 +31,18 @@ sub Version { $VERSION; } $Verbose = 0; $lib_ext = $Config{lib_ext} || '.a'; +sub is_cmd { $0 eq '-e' } + +sub my_return { + my $val = shift; + if(is_cmd) { + print $val; + } + else { + return $val; + } +} + sub xsinit { my($file, $std, $mods) = @_; my($fh,@mods,%seen); @@ -213,24 +221,23 @@ sub ldopts { print STDERR "ldopts: '$linkage'\n" if $Verbose; return $linkage if scalar @_; - print "$linkage\n"; + my_return("$linkage\n"); } sub ccflags { - print " $Config{ccflags} "; + my_return(" $Config{ccflags} "); } sub ccdlflags { - print " $Config{ccdlflags} "; + my_return(" $Config{ccdlflags} "); } sub perl_inc { - print " -I$Config{archlibexp}/CORE "; + my_return(" -I$Config{archlibexp}/CORE "); } sub ccopts { - ccflags; - perl_inc; + ccflags . perl_inc; } sub canon { diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index bdf154375f..ff5dbf1517 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -1,14 +1,14 @@ package ExtUtils::Install; -$VERSION = substr q$Revision: 1.16 $, 10; -# $Date: 1996/12/17 00:31:26 $ +$VERSION = substr q$Revision: 1.19 $, 10; +# $Date: 1997/08/01 08:39:37 $ use Exporter; use Carp (); -use Config (); +use Config qw(%Config); use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); -@EXPORT = ('install','uninstall','pm_to_blib'); +@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; @@ -144,6 +144,28 @@ sub install { } } +sub install_default { + @_ < 2 or die "install_default should be called with 0 or 1 argument"; + my $FULLEXT = @_ ? shift : $ARGV[0]; + defined $FULLEXT or die "Do not know to where to write install log"; + my $INST_LIB = MM->catdir(MM->curdir,"blib","lib"); + my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch"); + my $INST_BIN = MM->catdir(MM->curdir,'blib','bin'); + my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script'); + my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1'); + my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3'); + install({ + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + },1,0,0); +} + sub my_cmp { my($one,$two) = @_; local(*F,*T); @@ -192,7 +214,7 @@ sub inc_uninstall { my $MY = {}; bless $MY, 'MY'; my %seen_dir = (); - foreach $dir (@INC, @PERL_ENV_LIB, @Config::Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { + foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = $MY->catfile($dir,$libdir,$file); @@ -333,6 +355,20 @@ be merged into the written file. The read and the written file may be identical, but on AFS it is quite likely, people are installing to a different directory than the one where the files later appear. +install_default() takes one or less arguments. If no arguments are +specified, it takes $ARGV[0] as if it was specified as an argument. +The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>. +This function calls install() with the same arguments as the defaults +the MakeMaker would use. + +The argumement-less form is convenient for install scripts like + + perl -MExtUtils::Install -e install_default Tk/Canvas + +Assuming this command is executed in a directory with populated F<blib> +directory, it will proceed as if the F<blib> was build by MakeMaker on +this machine. This is useful for binary distributions. + uninstall() takes as first argument a file containing filenames to be unlinked. The second argument is a verbose switch, the third is a no-don't-really-do-it-now switch. diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 9d15fe9edf..fed25ae13b 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -2,7 +2,7 @@ package ExtUtils::Liblist; use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.2201 $, 10; +$VERSION = substr q$Revision: 1.25 $, 10; use Config; use Cwd 'cwd'; @@ -15,7 +15,7 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $Verbose) = @_; + my($self,$potential_libs, $verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. @@ -24,7 +24,7 @@ sub _unix_os2_ext { $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; - print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; @@ -50,7 +50,7 @@ sub _unix_os2_ext { my($ptype) = $1; unless (-d $thislib){ print STDOUT "$ptype$thislib ignored, directory does not exist\n" - if $Verbose; + if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { @@ -125,10 +125,10 @@ sub _unix_os2_ext { # # , the compilation tools expand the environment variables.) } else { - print STDOUT "$thislib not found in $thispth\n" if $Verbose; + print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose; + print STDOUT "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; @@ -183,7 +183,7 @@ sub _unix_os2_ext { } sub _win32_ext { - my($self, $potential_libs, $Verbose) = @_; + my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) @@ -202,7 +202,7 @@ sub _win32_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } - print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; # compute $extralibs from $potential_libs @@ -219,7 +219,7 @@ sub _win32_ext { # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { print STDOUT "-L$thislib ignored, directory does not exist\n" - if $Verbose; + if $verbose; next; } elsif (-d $thislib) { @@ -238,10 +238,10 @@ sub _win32_ext { my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$thislib")) { - print STDOUT "$thislib not found in $thispth\n" if $Verbose; + print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'$thislib' found at $fullname\n" if $Verbose; + print STDOUT "'$thislib' found at $fullname\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); @@ -370,7 +370,7 @@ sub _vms_ext { if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; - print STDOUT "\tFound as $cand (really $ctest), type $ctype\n" if $verbose > 1; + print STDOUT "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } @@ -403,7 +403,7 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($self, $potential_libs, $Verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);> =head1 DESCRIPTION diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index f24c5d0eb2..85b0c1bbe5 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -8,8 +8,8 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.114 $, 10; -# $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $ +$VERSION = substr q$Revision: 1.118 $, 10; +# $Id: MM_Unix.pm,v 1.118 1997/08/01 09:42:52 k Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); @@ -181,6 +181,7 @@ sub ExtUtils::MM_Unix::export_list ; sub ExtUtils::MM_Unix::extliblist ; sub ExtUtils::MM_Unix::file_name_is_absolute ; sub ExtUtils::MM_Unix::find_perl ; +sub ExtUtils::MM_Unix::fixin ; sub ExtUtils::MM_Unix::force ; sub ExtUtils::MM_Unix::guess_name ; sub ExtUtils::MM_Unix::has_link_code ; @@ -1103,6 +1104,86 @@ specified by @ExtUtils::MakeMaker::MM_Sections. =over 2 +=item fixin + +Inserts the sharpbang or equivalent magic number to a script + +=cut + +sub fixin { # stolen from the pink Camel book, more or less + my($self,@files) = @_; + my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/; + my($file,$interpreter); + for $file (@files) { + local(*FIXIN); + local(*FIXOUT); + open(FIXIN, $file) or Carp::croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp(my $line = <FIXIN>); + next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + # Now figure out the interpreter name. + my($cmd,$arg) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + if ($cmd eq "perl") { + $interpreter = $Config{perlpath}; + } else { + my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; + $interpreter = ''; + my($dir); + foreach $dir (@absdirs) { + if ($self->maybe_command($cmd)) { + warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; + $interpreter = $self->catfile($dir,$cmd); + } + } + } + # Figure out how to invoke interpreter on this machine. + + my($shb) = ""; + if ($interpreter) { + print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + $shb .= qq{ +eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' + if 0; # not running under some shell +}; + } else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + next; + } + + unless ( rename($file, "$file.bak") ) { + warn "Can't modify $file"; + next; + } + unless ( open(FIXOUT,">$file") ) { + warn "Can't create new $file: $!\n"; + next; + } + my($dev,$ino,$mode) = stat FIXIN; + $mode = 0755 unless $dev; + chmod $mode, $file; + + # Print out the new #! line (or equivalent). + local $\; + undef $/; + print FIXOUT $shb, <FIXIN>; + close FIXIN; + close FIXOUT; + unlink "$file.bak"; + } continue { + chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; + } +} + =item force (o) Just writes FORCE: @@ -1280,7 +1361,6 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) # my $fh = new FileHandle; local *FH; my($ispod)=0; - # one day test, if $/ can be set to '' safely (is the bug fixed that was in 5.001m?) # if ($fh->open("<$name")) { if (open(FH,"<$name")) { # while (<$fh>) { @@ -1297,7 +1377,9 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $ispod = 1; } if( $ispod ) { - $manifypods{$name} = $self->catfile('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)'); + $manifypods{$name} = + $self->catfile('$(INST_MAN1DIR)', + basename($name).'.$(MAN1EXT)'); } } } @@ -1901,22 +1983,27 @@ sub installbin { $fromto{$from}=$to; } @to = values %fromto; - push(@m, " + push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} +FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ + -e "MY->fixin(shift)" + all :: @to + $self->{NOECHO}\$(NOOP) realclean :: $self->{RM_F} @to -"); +}); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " -$to: $from $self->{MAKEFILE} ".$self->catfile($todir,'.exists')." +$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to + \$(FIXIN) $to "; } join "", @m; @@ -2430,18 +2517,21 @@ sub parse_version { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; - next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; - \$$1=undef; do { + local $1$2; + \$$2=undef; do { $_ - }; \$$1 + }; \$$2 }; local($^W) = 0; - $result = eval($eval) || 0; + $result = eval($eval); die "Could not eval '$eval' in $parsefile: $@" if $@; + $result = "undef" unless defined $result; last; } close FH; @@ -2632,6 +2722,7 @@ sub processPL { foreach $plfile (sort keys %{$self->{PL_FILES}}) { push @m, " all :: $self->{PL_FILES}->{$plfile} + $self->{NOECHO}\$(NOOP) $self->{PL_FILES}->{$plfile} :: $plfile \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index da2a7638ca..dc3b4ceca6 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -96,7 +96,7 @@ sub fixpath { } my($fixedpath,$prefix,$name); - if ($path =~ m#^\$\(.+\)$# || $path =~ m#[/:>\]]#) { + if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])$/) { $fixedpath = vmspath($self->eliminate_macros($path)); } @@ -105,7 +105,9 @@ sub fixpath { } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { - my($vmspre) = vmspath($self->eliminate_macros("\$($prefix)")) || ''; # is it a dir or just a name? + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 6d1746c31f..5511e3d1e4 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -2,10 +2,10 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$Version = $VERSION = "5.4002"; +$Version = $VERSION = "5.42"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) -($Revision = substr(q$Revision: 1.211 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.216 $, 10)) =~ s/\s+$//; @@ -1157,6 +1157,11 @@ Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. +=item CCFLAGS + +String that will be included in the compiler call command line between +the arguments INC and OPTIMIZE. + =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from @@ -1257,6 +1262,10 @@ Perl binary able to run this extension. Ref to array of *.h file names. Similar to C. +=item IMPORTS + +IMPORTS is only used on OS/2. + =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> @@ -1564,15 +1573,17 @@ routine requires that the file named by VERSION_FROM contains one single line to compute the version number. The first line in the file that contains the regular expression - /\$(([\w\:\']*)\bVERSION)\b.*\=/ + /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B<after> the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; - ( $VERSION ) = '$Revision: 1.211 $ ' =~ /\$Revision:\s+([^\s]+)/; + *VERSION = \'1.01'; + ( $VERSION ) = '$Revision: 1.216 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; + *FOO::VERSION = \'1.11'; but these will fail: @@ -1580,9 +1591,16 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; -The file named in VERSION_FROM is added as a dependency to Makefile to -guarantee, that the Makefile contains the correct VERSION macro after -a change of the file. +The file named in VERSION_FROM is not added as a dependency to +Makefile. This is not really correct, but it would be a major pain +during development to have to rewrite the Makefile for any smallish +change in that file. If you want to make sure that the Makefile +contains the correct VERSION macro after any change of the file, you +would have to do something like + + depend => { Makefile => '$(VERSION_FROM)' } + +See attribute C<depend> below. =item XS diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 73dc81d069..350136455f 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.13 $, 10; +$VERSION = substr q$Revision: 1.16 $, 10; sub Mksymlists { my(%spec) = @_; @@ -106,16 +106,28 @@ sub _write_win32 { open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); - print DEF "LIBRARY $data->{DLBASE}\n"; + # put library name in quotes (it could be a keyword, like 'Alias') + print DEF "LIBRARY \"$data->{DLBASE}\"\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from different compilers + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 if ($Config::Config{'cc'} =~ /^bcc/i) { - for (@{$data->{DL_VARS}}) { $_ = "$_ = _$_" } - for (@{$data->{FUNCLIST}}) { $_ = "$_ = _$_" } + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "_$_", "$_ = _$_"; + } } - print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; - print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + else { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "$_", "_$_ = $_"; + } + } + print DEF join("\n ",@syms, "\n") if @syms; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; my ($name, $exp); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 6c83e1b2b0..ac1378dce2 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,7 +6,7 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs =head1 DESCRIPTION @@ -55,6 +55,10 @@ Disables the run time test that determines if the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. +=item B<-nolinenumbers> + +Prevents the inclusion of `#line' directives in the output. + =back =head1 ENVIRONMENT @@ -83,7 +87,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9402"; +$XSUBPP_version = "1.9504"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -96,7 +100,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; @@ -104,6 +108,7 @@ $except = ""; $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; +$WantLineNumbers = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -115,6 +120,8 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; + $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; + $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; @@ -239,13 +246,59 @@ sub check_keyword { } +if ($WantLineNumbers) { + { + package xsubpp::counter; + sub TIEHANDLE { + my ($class, $cfile) = @_; + my $buf = ""; + $SECTION_END_MARKER = "#line --- \"$cfile\""; + $line_no = 1; + bless \$buf; + } + + sub PRINT { + my $self = shift; + for (@_) { + $$self .= $_; + while ($$self =~ s/^([^\n]*\n)//) { + my $line = $1; + ++ $line_no; + $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; + print STDOUT $line; + } + } + } + + sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); + } + + sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print STDOUT $$self; + } + } + + my $cfile = $filename; + $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; + tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); + select PSEUDO_STDOUT; +} + sub print_section { - my $count = 0; - $_ = shift(@line) while !/\S/ && @line; + # the "do" is required for right semantics + do { $_ = shift(@line) } while !/\S/ && @line; + + print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") + if $WantLineNumbers && !/^\s*#\s*line\b/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - print line_directive() unless ($count++); print "$_\n"; } + print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } sub process_keyword($) @@ -255,7 +308,6 @@ sub process_keyword($) &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; - print line_directive(); } sub CASE_handler { @@ -332,7 +384,6 @@ sub OUTPUT_handler { unless defined($args_match{$outarg}); blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $var_types{$outarg} ; - print line_directive(); if ($outcode) { print "\t$outcode\n"; } else { @@ -650,7 +701,10 @@ print <<EOM ; */ EOM -print "#line 1 \"$filename\"\n"; + + +print("#line 1 \"$filename\"\n") + if $WantLineNumbers; while (<$FH>) { last if ($Module, $Package, $Prefix) = @@ -787,7 +841,9 @@ while (fetch_para()) { if (check_keyword("BOOT")) { &check_cpp; - push (@BootCode, $_, line_directive(), @line, "") ; + push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") + if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; + push (@BootCode, @line, "") ; next PARAGRAPH ; } @@ -1005,7 +1061,6 @@ EOF } elsif ($gotRETVAL || $wantRETVAL) { &generate_output($ret_type, 0, 'RETVAL'); } - print line_directive(); # do cleanup process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; @@ -1064,11 +1119,11 @@ EOF if ($ProtoThisXSUB) { $newXS = "newXSproto"; - if ($ProtoThisXSUB == 2) { + if ($ProtoThisXSUB eq 2) { # User has specified empty prototype $proto = ', ""' ; } - elsif ($ProtoThisXSUB != 1) { + elsif ($ProtoThisXSUB ne 1) { # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; } @@ -1135,8 +1190,9 @@ EOF if (@BootCode) { - print "\n /* Initialisation Section */\n" ; - print grep (s/$/\n/, @BootCode) ; + print "\n /* Initialisation Section */\n\n" ; + @line = @BootCode; + print_section(); print "\n /* End of Initialisation Section */\n\n" ; } @@ -1158,15 +1214,6 @@ sub output_init { eval qq/print " $init\\\n"/; } -sub line_directive -{ - # work out the line number - my $line_no = $line_no[@line_no - @line -1] ; - - return "#line $line_no \"$filename\"\n" ; - -} - sub Warn { # work out the line number diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm index a76eb1ff59..2f9c45c4c6 100644 --- a/lib/File/Compare.pm +++ b/lib/File/Compare.pm @@ -5,7 +5,6 @@ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); require Exporter; use Carp; -use UNIVERSAL qw(isa); $VERSION = '1.1001'; @ISA = qw(Exporter); @@ -34,7 +33,8 @@ sub compare { croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); - if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) { + if (ref($from) && + (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { *FROM = *$from; } elsif (ref(\$from) eq 'GLOB') { *FROM = $from; @@ -45,7 +45,8 @@ sub compare { $fromsize = -s FROM; } - if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) { + if (ref($to) && + (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { *TO = *$to; } elsif (ref(\$to) eq 'GLOB') { *TO = $to; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index b1baa207b3..e95168e24b 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -9,7 +9,6 @@ package File::Copy; use strict; use Carp; -use UNIVERSAL qw(isa); use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big © &syscopy &cp &mv); @@ -48,11 +47,13 @@ sub copy { my $from_a_handle = (ref($from) ? (ref($from) eq 'GLOB' - || isa($from, 'GLOB') || isa($from, 'IO::Handle')) + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) : (ref(\$from) eq 'GLOB')); my $to_a_handle = (ref($to) ? (ref($to) eq 'GLOB' - || isa($to, 'GLOB') || isa($to, 'IO::Handle')) + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) : (ref(\$to) eq 'GLOB')); if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 1faea50158..1d565f2871 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -78,18 +78,22 @@ sub find { # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; + $prune = 0; &$wanted; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; - &finddir($wanted,$fixtopdir,$topnlink); + if (!$prune) { + my $fixtopdir = $topdir; + $fixtopdir =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; + $fixtopdir =~ s/\\dir$// if $Is_NT; + &finddir($wanted,$fixtopdir,$topnlink); + } } else { warn "Can't cd to $topdir: $!\n"; @@ -169,7 +173,8 @@ sub finddepth { # compatibility. local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { @@ -190,6 +195,7 @@ sub finddepth { unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } + $name = $topdir; chdir $dir && &$wanted; } chdir $cwd; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index fe56ae5365..43856dfe7b 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -130,7 +130,10 @@ sub mkpath { my $parent = File::Basename::dirname($path); push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); print "mkdir $path\n" if $verbose; - mkdir($path,$mode) || croak "mkdir $path: $!"; + unless (mkdir($path,$mode)) { + # allow for another process to have created it meanwhile + croak "mkdir $path: $!" unless -d $path; + } push(@created, $path); } @created; diff --git a/lib/FileCache.pm b/lib/FileCache.pm index 4fd63315f9..e1c5ec4c8a 100644 --- a/lib/FileCache.pm +++ b/lib/FileCache.pm @@ -19,7 +19,7 @@ maximum. =head1 BUGS F<sys/param.h> lies with its C<NOFILE> define on some systems, -so you may have to set $cacheout::maxopen yourself. +so you may have to set $FileCache::cacheout_maxopen yourself. =cut diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 0b5d9edcb4..0264b61f15 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -93,6 +93,11 @@ sub pipe { ($r, $w); } +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + 1; __END__ diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 6961dc2f1c..580ca39785 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -1,14 +1,26 @@ -#-----------------------------------------------------------------------# -# NOTE! This module is deprecated (obsolete) after the Perl release # -# 5.003_06 as the functionality has been integrated into the Perl core. # -#-----------------------------------------------------------------------# - package I18N::Collate; =head1 NAME I18N::Collate - compare 8-bit scalar data according to the current locale + *** + + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale + + HAS BEEN DEPRECATED + + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. + + See the perllocale manual page for further information. + + *** + =head1 SYNOPSIS use I18N::Collate; @@ -116,16 +128,18 @@ sub new { warn <<___EOD___; *** - WARNING: starting from the Perl version 5.003_06 the I18N::Collate - interface for comparing 8-bit scalar data according to the current locale + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale HAS BEEN DEPRECATED - (that is, please do not use it anymore for any new applications and please - migrate the old applications away from it) because its functionality was - integrated into the Perl core language in the release 5.003_06. + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. - See pod/perllocale.pod for further information. + See the perllocale manual page for further information. *** ___EOD___ diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index 43caa03763..f6d45cee85 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -20,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS - $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH + $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH, 'some cmd and args', 'optarg', ...); =head1 DESCRIPTION diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 7a4617c65a..33c60231aa 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -511,6 +511,27 @@ sub exp { } # +# _logofzero +# +# Die on division by zero. +# +sub _logofzero { + my $mess = "$_[0]: Logarithm of zero.\n"; + + if (defined $_[1]) { + $mess .= "(Because in the definition of $_[0], the argument "; + $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "is 0)\n"; + } + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# # (log) # # Compute log(z). @@ -659,7 +680,19 @@ sub cotan { Math::Complex::cot(@_) } sub acos { my ($z) = @_; $z = cplx($z, 0) unless ref $z; - return ~i * log($z + (Re($z) * Im($z) > 0 ? 1 : -1) * sqrt($z*$z - 1)); + my ($re, $im) = @{$z->cartesian}; + return atan2(sqrt(1 - $re * $re), $re) + if ($im == 0 and abs($re) <= 1.0); + my $acos = ~i * log($z + sqrt($z*$z - 1)); + if ($im == 0 || + (abs($re) < 1 && abs($im) < 1) || + (abs($re) > 1 && abs($im) > 1 + && !($re > 1 && $im > 1) + && !($re < -1 && $im < -1))) { + # this rule really, REALLY, must be simpler + return -$acos; + } + return $acos; } # @@ -670,6 +703,9 @@ sub acos { sub asin { my ($z) = @_; $z = cplx($z, 0) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return atan2($re, sqrt(1 - $re * $re)) + if ($im == 0 and abs($re) <= 1.0); return ~i * log(i * $z + sqrt(1 - $z*$z)); } @@ -681,7 +717,8 @@ sub asin { sub atan { my ($z) = @_; $z = cplx($z, 0) unless ref $z; - _divbyzero "atan($z)", "i - $z" if ($z == i); + _divbyzero "atan(i)" if ( $z == i); + _divbyzero "atan(-i)" if (-$z == i); return i/2*log((i + $z) / (i - $z)); } @@ -693,18 +730,35 @@ sub atan { sub asec { my ($z) = @_; _divbyzero "asec($z)", $z if ($z == 0); - return acos(1 / $z); + $z = cplx($z, 0) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 && abs($re) >= 1.0) { + my $ire = 1 / $re; + return atan2(sqrt(1 - $ire * $ire), $ire); + } + my $asec = acos(1 / $z); + return ~$asec if $re < 0 && $re > -1 && $im == 0; + return -$asec if $im && !($re > 0 && $im > 0) && !($re < 0 && $im < 0); + return $asec; } # # acsc # -# Computes the arc cosecant sec(z) = asin(1 / z). +# Computes the arc cosecant acsc(z) = asin(1 / z). # sub acsc { my ($z) = @_; _divbyzero "acsc($z)", $z if ($z == 0); - return asin(1 / $z); + $z = cplx($z, 0) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 && abs($re) >= 1.0) { + my $ire = 1 / $re; + return atan2($ire, sqrt(1 - $ire * $ire)); + } + my $acsc = asin(1 / $z); + return ~$acsc if $re < 0 && $re > -1 && $im == 0; + return $acsc; } # @@ -717,13 +771,15 @@ sub acosec { Math::Complex::acsc(@_) } # # acot # -# Computes the arc cotangent acot(z) = -i/2 log((i+z) / (z-i)) +# Computes the arc cotangent acot(z) = atan(1 / z) # sub acot { my ($z) = @_; + _divbyzero "acot($z)" if ($z == 0); $z = cplx($z, 0) unless ref $z; - _divbyzero "acot($z)", "$z - i" if ($z == i); - return i/-2 * log((i + $z) / ($z - i)); + _divbyzero "acot(i)", if ( $z == i); + _divbyzero "acot(-i)" if (-$z == i); + return atan(1 / $z); } # @@ -838,11 +894,14 @@ sub cotanh { Math::Complex::coth(@_) } # # acosh # -# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)). +# Computes the arc hyperbolic cosine acosh(z) = log(z +- sqrt(z*z-1)). # sub acosh { my ($z) = @_; $z = cplx($z, 0) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return log($re + sqrt(cplx($re*$re - 1, 0))) + if ($im == 0 && $re < 0); return log($z + sqrt($z*$z - 1)); } @@ -864,10 +923,14 @@ sub asinh { # sub atanh { my ($z) = @_; - _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); + _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); + _logofzero 'atanh(-1)' if ($z == -1); $z = cplx($z, 0) unless ref $z; - my $cz = (1 + $z) / (1 - $z); - return log($cz) / 2; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 && $re > 1) { + return cplx(atanh(1 / $re), pi/2); + } + return log((1 + $z) / (1 - $z)) / 2; } # @@ -878,6 +941,12 @@ sub atanh { sub asech { my ($z) = @_; _divbyzero 'asech(0)', $z if ($z == 0); + $z = cplx($z, 0) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 && $re < 0) { + my $ire = 1 / $re; + return log($ire + sqrt(cplx($ire*$ire - 1, 0))); + } return acosh(1 / $z); } @@ -906,10 +975,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; - _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); + _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); + _logofzero 'acoth(-1)' if ($z == -1); $z = cplx($z, 0) unless ref $z; - my $cz = (1 + $z) / ($z - 1); - return log($cz) / 2; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 and abs($re) < 1) { + return cplx(acoth(1/$re) , pi/2); + } + return log((1 + $z) / ($z - 1)) / 2; } # @@ -1295,7 +1368,7 @@ numbers: acsc(z) = asin(1 / z) asec(z) = acos(1 / z) - acot(z) = -i/2 * log((i+z) / (z-i)) + acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i)) sinh(z) = 1/2 (exp(z) - exp(-z)) cosh(z) = 1/2 (exp(z) + exp(-z)) @@ -1437,18 +1510,26 @@ The division (/) and the following functions acoth cannot be computed for all arguments because that would mean dividing -by zero. These situations cause fatal runtime errors looking like this +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this cot(0): Division by zero. (Because in the definition of cot(0), the divisor sin(0) is 0) Died at ... -For the C<csc>, C<cot>, C<asec>, C<acsc>, C<csch>, C<coth>, C<asech>, -C<acsch>, the argument cannot be C<0> (zero). For the C<atanh>, -C<acoth>, the argument cannot be C<1> (one). For the C<atan>, C<acot>, -the argument cannot be C<i> (the imaginary unit). For the C<tan>, -C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * pi>, where -I<k> is any integer. +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<atan>, C<acot>, the argument cannot be C<i> (the imaginary unit). +For the C<atan>, C<acoth>, the argument cannot be C<-i> (the negative +imaginary unit). For the C<tan>, C<sec>, C<tanh>, C<sech>, the +argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. =head1 BUGS diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index c9c045d15d..a1cbb07234 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -150,17 +150,24 @@ The following functions acoth cannot be computed for all arguments because that would mean dividing -by zero. These situations cause fatal runtime errors looking like this +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this cot(0): Division by zero. (Because in the definition of cot(0), the divisor sin(0) is 0) Died at ... -For the C<csc>, C<cot>, C<asec>, C<acsc>, C<csch>, C<coth>, C<asech>, -C<acsch>, the argument cannot be C<0> (zero). For the C<atanh>, -C<acoth>, the argument cannot be C<1> (one). For the C<tan>, C<sec>, -C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * pi>, where I<k> is -any integer. +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * +pi>, where I<k> is any integer. =head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm index dfca789817..96b090dae5 100644 --- a/lib/Net/hostent.pm +++ b/lib/Net/hostent.pm @@ -76,9 +76,9 @@ This module's default exports override the core gethostbyname() and gethostbyaddr() functions, replacing them with versions that return "Net::hostent" objects. This object has methods that return the similarly named structure field name from the C's hostent structure from F<netdb.h>; -namely name, aliases, addrtype, length, and addresses. The aliases and -addresses methods return array reference, the rest scalars. The addr -method is equivalent to the zeroth element in the addresses array +namely name, aliases, addrtype, length, and addr_list. The aliases and +addr_list methods return array reference, the rest scalars. The addr +method is equivalent to the zeroth element in the addr_list array reference. You may also import all the structure fields directly into your namespace diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 82453344d8..ffeb0b2136 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -761,7 +761,7 @@ sub scan_headings { # scan for =head directives, note their name, and build an index # pointing to each of them. foreach my $line (@data) { - if ($line =~ /^\s*=(head)([1-6])\s+(.*)/) { + if ($line =~ /^=(head)([1-6])\s+(.*)/) { ($tag,$which_head, $title) = ($1,$2,$3); chomp($title); $$sections{htmlify(0,$title)} = 1; @@ -788,7 +788,7 @@ sub scan_headings { # get rid of bogus lists $index =~ s,\t*<UL>\s*</UL>\n,,g; - $ignore = 1; # retore old value; + $ignore = 1; # restore old value; return $index; } diff --git a/lib/Shell.pm b/lib/Shell.pm index bb44b5398b..f4ef431cc5 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -21,7 +21,7 @@ AUTOLOAD { my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; eval qq { - sub $AUTOLOAD { + *$AUTOLOAD = sub { if (\@_ < 1) { `$cmd`; } diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index 92207acb2b..d23310a5af 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -39,7 +39,7 @@ sub hostname { if ($^O eq 'VMS') { # method 2 - no sockets ==> return DECnet node name - eval {my($test) = gethostbyname('me')}; # returns 'me' on most systems + eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] }; if ($@) { return $host = $ENV{'SYS$NODE'}; } # method 3 - has someone else done the job already? It's common for the @@ -69,6 +69,7 @@ sub hostname { # method 2 - syscall is preferred since it avoids tainting problems eval { + local $SIG{__DIE__}; { package main; require "syscall.ph"; @@ -79,16 +80,19 @@ sub hostname { # method 3 - trusty old hostname command || eval { + local $SIG{__DIE__}; $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) || eval { + local $SIG{__DIE__}; $host = `uname -n 2>/dev/null`; ## sysVish } # method 5 - Apollo pre-SR10 || eval { + local $SIG{__DIE__}; ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); } diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 9efcfbf3c4..f6d9c3547e 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -54,6 +54,19 @@ is replaced with C<"$!"> (the latest error message). Sets log mask I<$mask_priority> and returns the old mask. +=item setlogsock $sock_type + +Sets the socket type to be used for the next call to +C<openlog()> or C<syslog()>. + +A value of 'unix' will connect to the UNIX domain socket returned +by C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect +to an INET socket returned by getservbyname(). +Any other value croaks. + +The default is for the INET socket to be used. + + =item closelog Closes the log file. @@ -70,9 +83,12 @@ Note that C<openlog> now takes three arguments, just like C<openlog(3)>. closelog(); syslog('debug', 'this is the last test'); + + setlogsock('unix'); openlog("$program $$", 'ndelay', 'user'); syslog('notice', 'fooprogram: this is really done'); + setlogsock('inet'); $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) @@ -86,7 +102,9 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. +UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> +with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. =cut @@ -114,6 +132,17 @@ sub setlogmask { $oldmask; } +sub setlogsock { + local($setsock) = shift; + if (lc($setsock) eq 'unix') { + $sock_unix = 1; + } elsif (lc($setsock) eq 'inet') { + undef($sock_unix); + } else { + croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + } +} + sub syslog { local($priority) = shift; local($mask) = shift; @@ -172,7 +201,7 @@ sub syslog { $message = sprintf ($mask, @_); $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { @@ -203,12 +232,19 @@ sub connect { my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; + unless ( $sock_unix ) { + my $udp = getprotobyname('udp'); + my $syslog = getservbyname('syslog','udp'); + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); + socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } else { + my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; + socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "open: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 105e6dd536..b6923dd1e7 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -105,14 +105,33 @@ support reacher set of commands. All these commands are callable via method interface and have names which conform to standard conventions with the leading C<rl_> stripped. -The stub package included with the perl distribution allows two -additional methods: C<tkRunning> and C<ornaments>. The first one +The stub package included with the perl distribution allows some +additional methods: + +=over 12 + +=item C<tkRunning> + makes Tk event loop run when waiting for user input (i.e., during -C<readline> method), the second one makes the command line stand out -by using termcap data. The argument to C<ornaments> should be 0, 1, -or a string of a form "aa,bb,cc,dd". Four components of this string -should be names of I<terminal capacities>, first two will be issued to -make the prompt standout, last two to make the input line standout. +C<readline> method). + +=item C<ornaments> + +makes the command line stand out by using termcap data. The argument +to C<ornaments> should be 0, 1, or a string of a form +C<"aa,bb,cc,dd">. Four components of this string should be names of +I<terminal capacities>, first two will be issued to make the prompt +standout, last two to make the input line standout. + +=item C<newTTY> + +takes two arguments which are input filehandle and output filehandle. +Switches to use these filehandles. + +=back + +One can check whether the currently loaded ReadLine package supports +these methods by checking for corresponding C<Features>. =head1 EXPORTS @@ -206,12 +225,22 @@ sub new { bless [$FIN, $FOUT]; } } + +sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); +} + sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } sub Attribs { {} } -my %features = (tkRunning => 1, ornaments => 1); +my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 0119f9ddb8..d2d70dab20 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -48,11 +48,30 @@ BEGIN { $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - my $t = time; - my @lt = localtime($t); - my @gt = gmtime($t); +} + +sub timegm { + $ym = pack(C2, @_[5,4]); + $cheat = $cheat{$ym} || &cheat; + return -1 if $cheat<0 and $^O ne 'VMS'; + $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; +} + +sub timelocal { + my $t = &timegm; + my $tt = $t; + + my (@lt) = localtime($t); + my (@gt) = gmtime($t); + if ($t < $DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) { + # Wrap error, too early a date + # Try a safer date + $tt = $DAY; + @lt = localtime($tt); + @gt = gmtime($tt); + } - $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; + my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; my($lday,$gday) = ($lt[7],$gt[7]); if($lt[5] > $gt[5]) { @@ -65,20 +84,11 @@ BEGIN { $tzsec += ($gt[7] - $lt[7]) * $DAY; } - $tzsec += $HR if($lt[8]); -} - -sub timegm { - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0 and $^O ne 'VMS'; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; -} - -sub timelocal { - $time = &timegm + $tzsec; + $tzsec += $HR if($lt[8]); + + $time = $t + $tzsec; return -1 if $cheat<0 and $^O ne 'VMS'; - @test = localtime($time); + @test = localtime($time + ($tt - $t)); $time -= $HR if $test[2] != $_[2]; $time; } diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index 6d832c4bea..dc02423029 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -1,7 +1,10 @@ package UNIVERSAL; +# UNIVERSAL should not contain any extra subs/methods beyond those +# that it exists to define. The use of Exporter below is a historical +# accident that should be fixed sometime. require Exporter; -@ISA = qw(Exporter); +*import = \&Exporter::import; @EXPORT_OK = qw(isa can); 1; @@ -13,12 +16,11 @@ UNIVERSAL - base class for ALL classes (blessed references) =head1 SYNOPSIS - use UNIVERSAL qw(isa); - - $yes = isa($ref, "HASH"); $io = $fd->isa("IO::Handle"); $sub = $obj->can('print'); + $yes = UNIVERSAL::isa($ref, "HASH"); + =head1 DESCRIPTION C<UNIVERSAL> is the base class which all bless references will inherit from, @@ -54,11 +56,11 @@ C<VERSION> can be called as either a static or object method call. =back -C<UNIVERSAL> also optionally exports the following subroutines +The C<isa> and C<can> methods can also be called as subroutines =over 4 -=item isa ( VAL, TYPE ) +=item UNIVERSAL::isa ( VAL, TYPE ) C<isa> returns I<true> if the first argument is a reference and either of the following statements is true. @@ -76,7 +78,7 @@ C<VAL> is a reference to a C<TYPE> of perl variable (er 'HASH') =back -=item can ( VAL, METHOD ) +=item UNIVERSAL::can ( VAL, METHOD ) If C<VAL> is a blessed reference which has a method called C<METHOD>, C<can> returns a reference to the subroutine. If C<VAL> is not @@ -85,4 +87,11 @@ I<undef> is returned. =back +These subroutines should I<not> be imported via S<C<use UNIVERSAL qw(...)>>. +If you want simple local access to them you can do + + *isa = \&UNIVERSAL::isa; + +to import isa into your package. + =cut diff --git a/lib/blib.pm b/lib/blib.pm index 8af1727d8f..2dd7802f4b 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -38,6 +38,8 @@ Nick Ing-Simmons nik@tiuk.ti.com use Cwd; +use vars qw($VERSION); +$VERSION = '1.00'; sub import { diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index 1fa8246da7..c32bc2fb5e 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -117,9 +117,9 @@ sub unwrap { # Check for reused addresses if (ref $v) { - ($address) = $v =~ /(0x[0-9a-f]+)/ ; + ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; if (defined $address) { - ($type) = $v =~ /=(.*?)\(/ ; + ($type) = $v =~ /=(.*?)\([^=]+$/ ; $address{$address}++ ; if ( $address{$address} > 1 ) { print "${sp}-> REUSED_ADDRESS\n" ; @@ -135,7 +135,7 @@ sub unwrap { } } - if ( ref $v eq 'HASH' or $type eq 'HASH') { + if ( UNIVERSAL::isa($v, 'HASH') ) { @sortKeys = sort keys(%$v) ; undef $more ; $tHashDepth = $#sortKeys ; @@ -168,7 +168,7 @@ sub unwrap { } print "$sp empty hash\n" unless @sortKeys; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { $tArrayDepth = $#{$v} ; undef $more ; $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 @@ -198,13 +198,13 @@ sub unwrap { } print "$sp empty array\n" unless @$v; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { print "$sp-> "; DumpElem $$v, $s; - } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) { + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { print "$sp-> "; dumpsub (0, $v); - } elsif (ref $v eq 'GLOB') { + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { print "$sp-> ",&stringify($$v,1),"\n"; if ($globPrint) { $s += 3; diff --git a/lib/ftp.pl b/lib/ftp.pl index e671348105..fd78162a40 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -88,15 +88,9 @@ # Initial revision # -eval { require 'chat2.pl' }; -die qq{$@ -The obsolete and problematic chat2.pl library has been removed from the -Perl distribution at the request of it's author. You can either get a -copy yourself or, preferably, fetch the new and much better Net::FTP -package from a CPAN ftp site. -} if $@ && $@ =~ /locate chat2.pl/; -die $@ if $@; -eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; +require 'chat2.pl'; # into main +eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" + || die "socket.ph missing: $!\n"; package ftp; diff --git a/lib/perl5db.pl b/lib/perl5db.pl index c09238d16c..469ebff023 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -296,6 +296,10 @@ if ($notty) { $console = "sys\$command"; } + if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) { + $console = undef; + } + # Around a bug: if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2 $console = undef; @@ -428,6 +432,7 @@ sub DB { @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), + ($term_pid == $$ or &resetterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { @@ -1062,7 +1067,7 @@ sub DB { $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; - } else { + } elsif ($term_pid == $$) { print $OUT "\n"; } } continue { # CMD: @@ -1386,6 +1391,29 @@ sub setterm { $term->SetHistory(@hist); } ornaments($ornaments) if defined $ornaments; + $term_pid = $$; +} + +sub resetterm { # We forked, so we need a different TTY + $term_pid = $$; + if (defined &get_fork_TTY) { + &get_fork_TTY; + } elsif (not defined $fork_TTY + and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' + and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { + # Possibly _inside_ XTERM + open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\ + sleep 10000000' |]; + $fork_TTY = <XT>; + chomp $fork_TTY; + } + if (defined $fork_TTY) { + TTY($fork_TTY); + undef $fork_TTY; + } else { + print $OUT "Forked, but do not know how to change a TTY.\n", + "Define \$DB::fork_TTY or get_fork_TTY().\n"; + } } sub readline { @@ -1511,8 +1539,21 @@ sub warn { } sub TTY { - if ($term) { - &warn("Too late to set TTY, enabled on next `R'!\n") if @_; + if (@_ and $term and $term->Features->{newTTY}) { + my ($in, $out) = shift; + if ($in =~ /,/) { + ($in, $out) = split /,/, $in, 2; + } else { + $out = $in; + } + open IN, $in or die "cannot open `$in' for read: $!"; + open OUT, ">$out" or die "cannot open `$out' for write: $!"; + $term->newTTY(\*IN, \*OUT); + $IN = \*IN; + $OUT = \*OUT; + return $tty = $in; + } elsif ($term and @_) { + &warn("Too late to set TTY, enabled on next `R'!\n"); } $tty = shift if @_; $tty or $console; @@ -2,6 +2,10 @@ * */ +#if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS) +# define DEBUGGING_MSTATS +#endif + #ifndef lint # if defined(DEBUGGING) && !defined(NO_RCHECK) # define RCHECK @@ -789,6 +793,9 @@ int size; #ifdef PERL_CORE reqsize = size; /* just for the DEBUG_m statement */ #endif +#ifdef PACK_MALLOC + size = (size + 0x7ff) & ~0x7ff; +#endif if (size <= Perl_sbrk_oldsize) { got = Perl_sbrk_oldchunk; Perl_sbrk_oldchunk += size; @@ -804,6 +811,9 @@ int size; small = 1; } got = (IV)SYSTEM_ALLOC(size); +#ifdef PACK_MALLOC + got = (got + 0x7ff) & ~0x7ff; +#endif if (small) { /* Chunk is small, register the rest for future allocs. */ Perl_sbrk_oldchunk = got + reqsize; @@ -1371,14 +1371,7 @@ MAGIC* mg; osname = Nullch; break; case '\020': /* ^P */ - i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - if (i != perldb) { - if (perldb) - oldlastpm = curpm; - else - curpm = oldlastpm; - } - perldb = i; + perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '\024': /* ^T */ #ifdef BIG_TIME @@ -1699,6 +1692,21 @@ char *sig; return 0; } +static SV* sig_sv; + +static void +unwind_handler_stack(p) + void *p; +{ + U32 flags = *(U32*)p; + + if (flags & 1) + savestack_ix -= 5; /* Unprotect save in progress. */ + /* cxstack_ix-- Not needed, die already unwound it. */ + if (flags & 64) + SvREFCNT_dec(sig_sv); +} + Signal_t sighandler(sig) int sig; @@ -1707,15 +1715,56 @@ int sig; dSP; GV *gv; HV *st; - SV *sv; + SV *sv, *tSv = Sv; CV *cv; AV *oldstack; - + OP *myop = op; + U32 flags = 0; + I32 o_save_i = savestack_ix, type; + CONTEXT *cx; + XPV *tXpv = Xpv; + + if (savestack_ix + 15 <= savestack_max) + flags |= 1; + if (cxstack_ix < cxstack_max - 2) + flags |= 2; + if (markstack_ptr < markstack_max - 2) + flags |= 4; + if (retstack_ix < retstack_max - 2) + flags |= 8; + if (scopestack_ix < scopestack_max - 3) + flags |= 16; + + if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */ + cxstack_ix++; /* Protect from overwrite. */ + cx = &cxstack[cxstack_ix]; + type = cx->cx_type; /* Can be during partial write. */ + cx->cx_type = CXt_NULL; /* Make it safe for unwind. */ + } if (!psig_ptr[sig]) die("Signal SIG%s received, but no signal handler set.\n", sig_name[sig]); - cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); + /* Max number of items pushed there is 3*n or 4. We cannot fix + infinity, so we fix 4 (in fact 5): */ + if (flags & 1) { + savestack_ix += 5; /* Protect save in progress. */ + o_save_i = savestack_ix; + SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags); + } + if (flags & 4) + markstack_ptr++; /* Protect mark. */ + if (flags & 8) { + retstack_ix++; + retstack[retstack_ix] = NULL; + } + if (flags & 16) + scopestack_ix += 1; + /* sv_2cv is too complicated, try a simpler variant first: */ + if (!SvROK(psig_ptr[sig]) || !(cv = (CV*)SvRV(psig_ptr[sig])) + || SvTYPE(cv) != SVt_PVCV) + cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); + if (!cv || !CvROOT(cv)) { if (dowarn) warn("SIG%s handler \"%s\" not defined.\n", @@ -1728,9 +1777,11 @@ int sig; AvFILL(signalstack) = 0; SWITCHSTACK(curstack, signalstack); - if(psig_name[sig]) + if(psig_name[sig]) { sv = SvREFCNT_inc(psig_name[sig]); - else { + flags |= 64; + sig_sv = sv; + } else { sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); } @@ -1741,6 +1792,23 @@ int sig; perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); - + if (flags & 1) + savestack_ix -= 8; /* Unprotect save in progress. */ + if (flags & 2) { + cxstack[cxstack_ix].cx_type = type; + cxstack_ix -= 1; + } + if (flags & 4) + markstack_ptr--; + if (flags & 8) + retstack_ix--; + if (flags & 16) + scopestack_ix -= 1; + if (flags & 64) + SvREFCNT_dec(sv); + op = myop; /* Apparently not needed... */ + + Sv = tSv; /* Restore global temporaries. */ + Xpv = tXpv; return; } @@ -1110,6 +1110,8 @@ I32 type; case OP_RV2AV: case OP_RV2HV: + if (!type && cUNOPo->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { modcount = 10000; return o; /* Treat \(@foo) like ordinary list. */ @@ -1131,7 +1133,7 @@ I32 type; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) - croak("Can't localize a reference"); + croak("Can't localize through a reference"); ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_GV: @@ -1450,7 +1452,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS || perldb || tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1537,7 +1539,7 @@ OP *o; compcv = 0; /* Register with debugger */ - if (perldb) { + if (PERLDB_INTER) { CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -1607,6 +1609,16 @@ register OP *o; if (!(opargs[type] & OA_FOLDCONST)) goto nope; + switch (type) { + case OP_SPRINTF: + case OP_UCFIRST: + case OP_LCFIRST: + case OP_UC: + case OP_LC: + if (o->op_private & OPpLOCALE) + goto nope; + } + if (error_count) goto nope; /* Don't try to run w/ errors */ @@ -2532,7 +2544,7 @@ OP *o; register COP *cop; Newz(1101, cop, 1, COP); - if (perldb && curcop->cop_line && curstash != debstash) { + if (PERLDB_LINE && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = ppaddr[ OP_DBSTATE ]; } @@ -2563,7 +2575,7 @@ OP *o; cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); @@ -3447,7 +3459,7 @@ OP *block; if (name) { char *s; - if (perldb && curstash != debstash) { + if (PERLDB_SUBLINE && curstash != debstash) { SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); static GV *db_postponed; @@ -4642,7 +4654,7 @@ OP *o; } } o->op_private |= (hints & HINT_STRICT_REFS); - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { if (proto) { @@ -342,7 +342,7 @@ vec vec ck_fun ist S S S index index ck_index ist S S S? rindex rindex ck_index ist S S S? -sprintf sprintf ck_fun_locale mst S L +sprintf sprintf ck_fun_locale mfst S L formline formline ck_fun ms S L ord ord ck_fun ifstu S? chr chr ck_fun fstu S? diff --git a/os2/Changes b/os2/Changes index 15fad979f3..146ce87142 100644 --- a/os2/Changes +++ b/os2/Changes @@ -143,3 +143,18 @@ after 5.003_27: environment). Known problems: $$ does not work - is 0, waitpid returns immediately, thus Perl cannot wait for completion of started programs. + +after 5.004_01: + flock emulation added (disable by setting env PERL_USE_FLOCK=0), + thanks to Rocco Caputo; + RSX bug with missing waitpid circomvented; + -S bug with full path with \ corrected. + +before 5.004_02: + -S switch to perl enables a search with additional extensions + .cmd, .btm, .bat, .pl as well. This means that if you have + mycmd.pl or mycmd.bat on PATH, + perl -S mycmd + will work. Perl will also look in the current directory first. + Moreover, a bug with \; in PATH being non-separator is fixed. + diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 6b07e72dba..493aeab8c5 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -19,6 +19,8 @@ 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 +LD_OPT = $optimize + !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' @@ -36,7 +38,7 @@ perl.imp: perl5.def echo 'emx_realloc emxlibcm 403 ?' >> $@ perl.dll: $(obj) perl5.def perl$(OBJ_EXT) - $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def + $(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def perl5.def: perl.linkexp echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@ @@ -54,6 +56,7 @@ perl5.def: perl.linkexp echo ' "dlerror"' >>$@ echo ' "my_tmpfile"' >>$@ echo ' "my_tmpnam"' >>$@ + echo ' "my_flock"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then @@ -77,10 +80,13 @@ perl.exports: perl.exp EXTERN.h perl.h perl.linkexp: perl.exports perl.map cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp -perl.map: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o dummy.exe miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map - awk '{if ($$3 == "") print $$2}' <dummy.map | sort | uniq > perl.map - rm dummy.exe dummy.map +# We link miniperl statically, since .DLL depends on $(DYNALOADER) + +perl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) + $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map + awk '{if ($$3 == "") print $$2}' <miniperl.map | sort | uniq > perl.map + rm miniperl.map + @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest depend: os2ish.h dlfcn.h @@ -99,12 +105,6 @@ os2ish.h: os2/os2ish.h dlfcn.h: os2/dlfcn.h cp $< $@ -# We link miniperl statically, since .DLL depends on $(DYNALOADER) - -miniperl: $& miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) - @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest - # This one is compiled OMF, so cannot fork(): perl___: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs diff --git a/os2/diff.configure b/os2/diff.configure index e63a8a105d..9f42dc139f 100644 --- a/os2/diff.configure +++ b/os2/diff.configure @@ -1,6 +1,6 @@ ---- Configure.dist Fri Feb 28 10:45:27 1997 -+++ Configure Fri Feb 28 10:45:31 1997 -@@ -1481,7 +1481,7 @@ +--- Configure.orig Fri Aug 1 23:12:26 1997 ++++ Configure Fri Aug 1 23:20:24 1997 +@@ -1489,7 +1489,7 @@ *) echo "I don't know where '$file' is, and my life depends on it." >&4 echo "Go find a public domain implementation or fix your PATH setting!" >&4 @@ -9,7 +9,7 @@ ;; esac done -@@ -1490,7 +1490,9 @@ +@@ -1498,7 +1498,9 @@ say=offhand for file in $trylist; do xxx=`./loc $file $file $pth` @@ -20,7 +20,7 @@ eval _$file=$xxx case "$xxx" in /*) -@@ -3178,7 +3180,7 @@ +@@ -3198,7 +3200,7 @@ exit(0); } EOM @@ -29,7 +29,7 @@ gccversion=`./gccvers` case "$gccversion" in '') echo "You are not using GNU cc." ;; -@@ -3381,6 +3383,12 @@ +@@ -3401,6 +3403,12 @@ *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac @@ -42,7 +42,7 @@ else echo "No -l$thislib." fi -@@ -3930,7 +3938,7 @@ +@@ -3950,7 +3958,7 @@ esac ;; esac @@ -51,7 +51,16 @@ case "$libs" in '') ;; *) for thislib in $libs; do -@@ -4136,6 +4144,10 @@ +@@ -3972,6 +3980,8 @@ + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : ++ elif try=`./loc $thislib$lib_ext X $libpth`; $test -f "$try"; then ++ : + elif try=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$try"; then + : + else +@@ -4156,6 +4166,10 @@ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun @@ -62,7 +71,7 @@ else nm -p $* 2>/dev/null >libc.tmp $grep fprintf libc.tmp > libc.ptf -@@ -4146,23 +4158,33 @@ +@@ -4166,23 +4180,33 @@ eval $xrun else echo " " @@ -103,7 +112,26 @@ done echo "Ok." >&4 else -@@ -5871,7 +5893,7 @@ +@@ -5611,15 +5635,15 @@ + EOCP + : check sys/file.h first, no particular reason here + if $test `./findhdr sys/file.h` && \ +- $cc $cppflags -DI_SYS_FILE access.c -o access >/dev/null 2>&1 ; then ++ $cc $ldflags $cppflags -DI_SYS_FILE access.c -o access >/dev/null 2>&1 ; then + h_sysfile=true; + echo "<sys/file.h> defines the *_OK access constants." >&4 + elif $test `./findhdr fcntl.h` && \ +- $cc $cppflags -DI_FCNTL access.c -o access >/dev/null 2>&1 ; then ++ $cc $ldflags $cppflags -DI_FCNTL access.c -o access >/dev/null 2>&1 ; then + h_fcntl=true; + echo "<fcntl.h> defines the *_OK access constants." >&4 + elif $test `./findhdr unistd.h` && \ +- $cc $cppflags -DI_UNISTD access.c -o access >/dev/null 2>&1 ; then ++ $cc $ldflags $cppflags -DI_UNISTD access.c -o access >/dev/null 2>&1 ; then + echo "<unistd.h> defines the *_OK access constants." >&4 + else + echo "I can't find the four *_OK access constants--I'll use mine." >&4 +@@ -5913,7 +5937,7 @@ exit(result); } EOCP @@ -112,7 +140,7 @@ ./try yyy=$? else -@@ -5952,7 +5974,7 @@ +@@ -5994,7 +6018,7 @@ } EOCP @@ -121,7 +149,7 @@ ./try castflags=$? else -@@ -5991,7 +6013,7 @@ +@@ -6033,7 +6057,7 @@ exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } EOF @@ -130,25 +158,25 @@ echo "Your vsprintf() returns (int)." >&4 val2="$undef" else -@@ -6336,7 +6358,7 @@ +@@ -6381,7 +6405,7 @@ EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ -- $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then -+ $cc $cppflags $ldflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then +- $cc $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then ++ $cc $ldflags $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then h_sysfile=true; echo "<sys/file.h> defines the O_* constants..." >&4 if ./open3; then -@@ -6347,7 +6369,7 @@ +@@ -6392,7 +6416,7 @@ val="$undef" fi elif $test `./findhdr fcntl.h` && \ -- $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then -+ $cc "-DI_FCNTL" $ldflags open3.c -o open3 >/dev/null 2>&1 ; then +- $cc $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then ++ $cc $ldflags $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then h_fcntl=true; echo "<fcntl.h> defines the O_* constants..." >&4 if ./open3; then -@@ -6853,7 +6875,7 @@ +@@ -6898,7 +6922,7 @@ y*|true) usemymalloc='y' mallocsrc='malloc.c' @@ -157,7 +185,7 @@ d_mymalloc="$define" case "$libs" in *-lmalloc*) -@@ -8111,7 +8133,7 @@ +@@ -8156,7 +8180,7 @@ printf("%d\n", (char *)&try.bar - (char *)&try.foo); } EOCP @@ -166,7 +194,7 @@ dflt=`./try` else dflt='8' -@@ -8159,7 +8181,7 @@ +@@ -8204,7 +8228,7 @@ } EOCP xxx_prompt=y @@ -175,7 +203,31 @@ dflt=`./try` case "$dflt" in [1-4][1-4][1-4][1-4]|12345678|87654321) -@@ -8692,7 +8714,7 @@ +@@ -8711,18 +8735,18 @@ + $cc $ccflags -c bar1.c >/dev/null 2>&1 + $cc $ccflags -c bar2.c >/dev/null 2>&1 + $cc $ccflags -c foo.c >/dev/null 2>&1 +-ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1 ++$ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1 + if $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then +- echo "ar appears to generate random libraries itself." ++ echo "$ar appears to generate random libraries itself." + orderlib=false + ranlib=":" +-elif ar ts bar$lib_ext >/dev/null 2>&1 && ++elif $ar ts bar$lib_ext >/dev/null 2>&1 && + $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then +- echo "a table of contents needs to be added with 'ar ts'." ++ echo "a table of contents needs to be added with '$ar ts'." + orderlib=false +- ranlib="ar ts" ++ ranlib="$ar ts" + else + case "$ranlib" in + :) ranlib='';; +@@ -8794,7 +8818,7 @@ '') $echo $n ".$c" if $cc $ccflags \ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ @@ -184,7 +236,7 @@ set X $i_time $i_systime $i_systimek $sysselect $s_timeval shift flags="$*" -@@ -8761,7 +8783,7 @@ +@@ -8863,7 +8887,7 @@ #endif } EOCP @@ -193,7 +245,7 @@ d_fds_bits="$define" d_fd_set="$define" echo "Well, your system knows about the normal fd_set typedef..." >&4 -@@ -8778,7 +8800,7 @@ +@@ -8880,7 +8904,7 @@ $cat <<'EOM' Hmm, your compiler has some difficulty with fd_set. Checking further... EOM @@ -202,7 +254,7 @@ d_fds_bits="$undef" d_fd_set="$define" echo "Well, your system has some sort of fd_set available..." >&4 -@@ -9525,7 +9547,7 @@ +@@ -9627,7 +9651,7 @@ else echo "false" fi @@ -211,7 +263,7 @@ EOP chmod +x varargs -@@ -9852,7 +9874,7 @@ +@@ -9954,7 +9978,7 @@ echo " " echo "Stripping down executable paths..." >&4 for file in $loclist $trylist; do @@ -1196,3 +1196,116 @@ my_tmpfile () return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but grants TMP. */ } + +#undef flock + +/* This code was contributed by Rocco Caputo. */ +int +my_flock(int handle, int op) +{ + FILELOCK rNull, rFull; + ULONG timeout, handle_type, flag_word; + APIRET rc; + int blocking, shared; + static int use_my = -1; + + if (use_my == -1) { + char *s = getenv("USE_PERL_FLOCK"); + if (s) + use_my = atoi(s); + else + use_my = 1; + } + if (!(_emx_env & 0x200) || !use_my) + return flock(handle, op); /* Delegate to EMX. */ + + // is this a file? + if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || + (handle_type & 0xFF)) + { + errno = EBADF; + return -1; + } + // set lock/unlock ranges + rNull.lOffset = rNull.lRange = rFull.lOffset = 0; + rFull.lRange = 0x7FFFFFFF; + // set timeout for blocking + timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1; + // shared or exclusive? + shared = (op & LOCK_SH) ? 1 : 0; + // do not block the unlock + if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) { + rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + break; // not an error + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + } + // lock may block + if (op & (LOCK_SH | LOCK_EX)) { + // for blocking operations + for (;;) { + rc = + DosSetFileLocks( + handle, + &rNull, + &rFull, + timeout, + shared + ); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + if (!blocking) { + errno = EWOULDBLOCK; + return -1; + } + break; + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + // give away timeslice + DosSleep(1); + } + } + + errno = 0; + return 0; +} diff --git a/os2/os2ish.h b/os2/os2ish.h index a1b6db9d68..b62e3d04d4 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -15,6 +15,7 @@ #define HAS_KILL #define HAS_WAIT #define HAS_DLERROR +#define HAS_WAITPID_RUNTIME (_emx_env & 0x200) /* USEMYBINMODE * This symbol, if defined, indicates that the program should @@ -125,6 +126,7 @@ char *my_tmpnam (char *); #define fwrite1 fwrite #define my_getenv(var) getenv(var) +#define flock my_flock void *emx_calloc (size_t, size_t); void emx_free (void *); @@ -631,6 +631,7 @@ setuid perl scripts securely.\n"); /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); @@ -797,12 +798,23 @@ print \" \\@INC:\\n @INC\\n\";"); cddir = savepv(s); break; case '-': + if (*++s) { /* catch use of gnu style long options */ + if (strEQ(s, "version")) { + s = "v"; + goto reswitch; + } + if (strEQ(s, "help")) { + s = "h"; + goto reswitch; + } + croak("Unrecognized switch: --%s (-h will show valid options)",s); + } argc--,argv++; goto switch_end; case 0: break; default: - croak("Unrecognized switch: -%s",s); + croak("Unrecognized switch: -%s (-h will show valid options)",s); } } switch_end: @@ -883,7 +895,7 @@ print \" \\@INC:\\n @INC\\n\";"); boot_core_UNIVERSAL(); if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ -#ifdef VMS +#if defined(VMS) || defined(WIN32) init_os_extras(); #endif @@ -931,7 +943,7 @@ print \" \\@INC:\\n @INC\\n\";"); LEAVE; FREETMPS; -#ifdef DEBUGGING_MSTATS +#ifdef MYMALLOC if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); #endif @@ -965,11 +977,11 @@ PerlInterpreter *sv_interp; /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); - FREETMPS; -#ifdef DEBUGGING_MSTATS +#ifdef MYMALLOC if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif @@ -1004,8 +1016,8 @@ PerlInterpreter *sv_interp; PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); my_exit(0); } - if (perldb && DBsingle) - sv_setiv(DBsingle, 1); + if (PERLDB_SINGLE && DBsingle) + sv_setiv(DBsingle, 1); if (initav) call_list(oldscope, initav); } @@ -1143,6 +1155,7 @@ I32 flags; /* See G_* flags in cop.h */ bool oldcatch = CATCH_GET; dJMPENV; int ret; + OP* oldop = op; if (flags & G_DISCARD) { ENTER; @@ -1164,7 +1177,7 @@ I32 flags; /* See G_* flags in cop.h */ oldmark = TOPMARK; oldscope = scopestack_ix; - if (perldb && curstash != debstash + if (PERLDB_SUB && curstash != debstash /* Handle first BEGIN of -d. */ && (DBcv || (DBcv = GvCV(DBsub))) /* Try harder, since this may have been a sighandler, thus @@ -1265,6 +1278,7 @@ I32 flags; /* See G_* flags in cop.h */ FREETMPS; LEAVE; } + op = oldop; return retval; } @@ -1283,7 +1297,8 @@ I32 flags; /* See G_* flags in cop.h */ I32 oldscope; dJMPENV; int ret; - + OP* oldop = op; + if (flags & G_DISCARD) { ENTER; SAVETMPS; @@ -1354,6 +1369,7 @@ I32 flags; /* See G_* flags in cop.h */ FREETMPS; LEAVE; } + op = oldop; return retval; } @@ -1420,10 +1436,10 @@ char *name; printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); - printf("\n -Idirectory specify @INC/#include directory (may be used more then once)"); - printf("\n -l[octal] enable line ending processing, specifies line teminator"); + printf("\n -Idirectory specify @INC/#include directory (may be used more than once)"); + printf("\n -l[octal] enable line ending processing, specifies line terminator"); printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); - printf("\n -n assume 'while (<>) { ... }' loop arround your script"); + printf("\n -n assume 'while (<>) { ... }' loop around your script"); printf("\n -p assume loop like -n but print line also like sed"); printf("\n -P run script through C preprocessor before compilation"); printf("\n -s enable some switch parsing for switches after script name"); @@ -1433,7 +1449,7 @@ char *name; printf("\n -U allow unsafe operations"); printf("\n -v print version number and patchlevel of perl"); printf("\n -V[:variable] print perl configuration information"); - printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT."); + printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended."); printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); } @@ -1480,7 +1496,7 @@ char *s; s += strlen(s); } if (!perldb) { - perldb = TRUE; + perldb = PERLDB_ALL; init_debugger(); } return s; @@ -1725,6 +1741,8 @@ init_main_stash() defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); GvMULTI_on(errgv); + (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ + sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ sv_setpvn(GvSV(errgv), "", 0); curstash = defstash; compiling.cop_stash = defstash; @@ -1754,6 +1772,10 @@ SV *sv; # 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 @@ -1761,14 +1783,35 @@ SV *sv; /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS char *ext[] = { SEARCH_EXTS }; - int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ + 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: + * + 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 if (dosearch) { int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; hasdir = (strpbrk(scriptname,":[</") != Nullch) ; /* The first time through, just add SEARCH_EXTS to whatever we @@ -1785,38 +1828,81 @@ SV *sv; continue; /* don't search dir with too-long name */ strcat(tokenbuf, scriptname); #else /* !VMS */ - if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) { - bufend = s + strlen(s); - while (s < bufend) { -#ifndef atarist - s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + #ifdef DOSISH - ';', -#else - ':', + 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 - &len); -#else /* atarist */ - for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) { + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Looking for %s\n",cur)); + if (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 = 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'; -#endif /* atarist */ +#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] != '/' -#endif #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 */ @@ -1849,8 +1935,16 @@ SV *sv; if (!xfailed) xfailed = savepv(tokenbuf); } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0)) +#endif + seen_dot = 1; /* Disable message. */ if (!xfound) - croak("Can't execute %s", xfailed ? xfailed : scriptname ); + 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; @@ -2371,6 +2465,7 @@ static void init_lexer() { tmpfp = rsfp; + rsfp = Nullfp; lex_start(linestr); rsfp = tmpfp; subname = newSVpv("main",4); @@ -2706,10 +2801,10 @@ AV* list; /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); - FREETMPS; JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; @@ -383,8 +383,14 @@ typedef pthread_key_t perl_key; # include <netinet/in.h> #endif +#if defined(SF_APPEND) && defined(USE_SFIO) && defined(I_SFIO) +/* <sfio.h> defines SF_APPEND and <sys/stat.h> might define SF_APPEND + * (the neo-BSD seem to do this). */ +# undef SF_APPEND +#endif + #ifdef I_SYS_STAT -#include <sys/stat.h> +# include <sys/stat.h> #endif /* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives @@ -1310,11 +1316,6 @@ typedef Sighandler_t Sigsave_t; # ifndef register # define register # endif -# ifdef MYMALLOC -# ifndef DEBUGGING_MSTATS -# define DEBUGGING_MSTATS -# endif -# endif # define PAD_SV(po) pad_sv(po) # define RUNOPS_DEFAULT runops_debug #else @@ -2237,6 +2238,22 @@ enum { #endif /* OVERLOAD */ +#define PERLDB_ALL 0xff +#define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */ +#define PERLDBf_LINE 0x02 /* Keep line #. */ +#define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */ +#define PERLDBf_INTER 0x08 /* Preserve more data for + later inspections. */ +#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */ +#define PERLDBf_SINGLE 0x20 /* Start with single-step on. */ + +#define PERLDB_SUB (perldb && (perldb & PERLDBf_SUB)) +#define PERLDB_LINE (perldb && (perldb & PERLDBf_LINE)) +#define PERLDB_NOOPT (perldb && (perldb & PERLDBf_NOOPT)) +#define PERLDB_INTER (perldb && (perldb & PERLDBf_INTER)) +#define PERLDB_SUBLINE (perldb && (perldb & PERLDBf_SUBLINE)) +#define PERLDB_SINGLE (perldb && (perldb & PERLDBf_SINGLE)) + #ifdef USE_LOCALE_COLLATE EXT U32 collation_ix; /* Collation generation index */ EXT char * collation_name; /* Name of current collation */ diff --git a/pod/perlapio.pod b/pod/perlapio.pod index d88e44509c..0db385e388 100644 --- a/pod/perlapio.pod +++ b/pod/perlapio.pod @@ -99,12 +99,12 @@ are different, there is only one "count" and order has =item B<PerlIO_close(f)> -=item B<PerlIO_puts(s,f)>, B<PerlIO_putc(c,f)> +=item B<PerlIO_puts(f,s)>, B<PerlIO_putc(f,c)> These correspond to fputs() and fputc(). Note that arguments have been revised to have "file" first. -=item B<PerlIO_ungetc(c,f)> +=item B<PerlIO_ungetc(f,c)> This corresponds to ungetc(). Note that arguments have been revised to have "file" first. diff --git a/pod/perlbook.pod b/pod/perlbook.pod index 8005e81d29..9a725cb833 100644 --- a/pod/perlbook.pod +++ b/pod/perlbook.pod @@ -11,27 +11,23 @@ web-connected, you can even mosey on over to http://www.ora.com/ for an online order form. I<Programming Perl, Second Edition> is a reference work that covers -nearly all of Perl, while I<Learning Perl> 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. +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. Programming Perl, Second Edition (the Camel Book): ISBN 1-56592-149-6 (English) - Learning Perl (the Llama Book): - ISBN 1-56592-042-2 (English) - ISBN 4-89502-678-1 (Japanese) - ISBN 2-84177-005-2 (French) - ISBN 3-930673-08-8 (German) + Learning Perl, Second Edition (the Llama Book): + ISBN 1-56592-284-0 (English) Perl 5 Desktop Reference (the reference card): ISBN 1-56592-187-9 (brief English) Mastering Regular Expressions (the Hip Owl Book): ISBN 1-56592-257-3 (English) - -A new edition of Learning Perl is due mid/late 1997. diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 1b206fb96d..a02fd5c710 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -8,6 +8,15 @@ First of all, have you tried using the B<-w> switch? =head1 The Perl Debugger +"As soon as we started programming, we found to our +surprise that it wasn't as easy to get programs right +as we had thought. Debugging had to be discovered. +I can remember the exact instant when I realized that +a large part of my life from then on was going to be +spent in finding mistakes in my own programs." + +I< --Maurice Wilkes, 1949> + If you invoke Perl with the B<-d> switch, your script runs under the Perl source debugger. This works like an interactive Perl environment, prompting for debugger commands that let you examine @@ -933,7 +942,7 @@ package DB, Perl sets the array @DB::args to contain the arguments the corresponding stack frame was called with. If perl is run with B<-d> option, the following additional features -are enabled: +are enabled (cf. L<perlvar/$^P>): =over @@ -1008,16 +1017,13 @@ in the package C<DB>.) =back -Note that no subroutine call is possible until C<&DB::sub> is defined -(for subroutines outside of package C<DB>). (This restriction is -recently lifted.) - -(In fact, for the standard debugger the same is true if C<$DB::deep> -(how many levels of recursion deep into the debugger you can go before -a mandatory break) is not defined.) +Note that if C<&DB::sub> needs some external data to be setup for it +to work, no subroutine call is possible until this is done. For the +standard debugger C<$DB::deep> (how many levels of recursion deep into +the debugger you can go before a mandatory break) gives an example of +such a dependency. -With the recent updates the minimal possible debugger consists of one -line +The minimal working debugger consists of one line sub DB::DB {} diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 4c944825bb..8d191e82d7 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -147,6 +147,13 @@ because at least two widely-used modules depend on the old meaning of 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> @@ -285,7 +292,7 @@ there is no C<use English> long name for this variable. 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 -DEMERGENCY_SBRK and used Perl's malloc. Then +compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then $^M = 'a' x (1<<16); @@ -395,6 +402,9 @@ 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.) @@ -495,6 +505,21 @@ before (printed only zeros), but is fine now: $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 @@ -631,24 +656,23 @@ possibly for cleaning up. =head2 Malloc enhancements -Four new compilation flags are recognized by malloc.c. (They have no -effect if perl is compiled with system malloc().) - -=over - -=item -DDEBUGGING_MSTATS - -If perl is compiled with C<DEBUGGING_MSTATS> defined, you can print +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 ares printed only on exit. +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.) -=item -DEMERGENCY_SBRK +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 @@ -705,7 +729,8 @@ Support for the following operating systems is new in Perl 5.004. 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). The resulting perl can be used under Windows 95 (if it +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 @@ -719,8 +744,6 @@ 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. -This port has not been as well tested as the "native" port described -above (which is not as well tested as we'd like either :) =head2 Plan 9 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 1b0f92e31f..a4d9356977 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -23,7 +23,7 @@ L<perlfunc/eval>. Some of these messages are generic. Spots that vary are denoted with a %s, just as in a printf format. Note that some messages start with a %s! -The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after. +The symbols C<"%(-?@> sort before the letters, while C<[> and C<\> sort after. =over 4 @@ -143,6 +143,12 @@ Perl yourself. instead of Perl. Check the #! line, or manually feed your script into Perl yourself. +=item (Missing semicolon on previous line?) + +(S) This is an educated guess made in conjunction with the message "%s +found where operator expected". Don't automatically put a semicolon on +the previous line just because you saw this message. + =item B<-P> not allowed for setuid/setgid script (F) The script would have to be opened by the C preprocessor by name, @@ -153,6 +159,12 @@ which provides a race condition that breaks security. (F) Perl can't peek at the stdio buffer of filehandles when it doesn't know about your kind of stdio. You'll have to use a filename instead. +=item C<-p> destination: %s + +(F) An error occurred during the implicit output invoked by the C<-p> +command-line switch. (This output goes to STDOUT unless you've +redirected it with select().) + =item 500 Server error See Server error. @@ -265,6 +277,15 @@ could indicate that SvREFCNT_dec() was called too many times, or that SvREFCNT_inc() was called too few times, or that the SV was mortalized when it shouldn't have been, or that memory has been corrupted. +=item Attempt to pack pointer to temporary value + +(W) You tried to pass a temporary value (like the result of a +function, or a computed expression) to the "p" pack() template. This +means the result contains a pointer to a location that could become +invalid anytime, even before the end of the current statement. Use +literals or global values as arguments to the "p" pack() template to +avoid this warning. + =item Attempt to use reference as lvalue in substr (W) You supplied a reference as the first argument to substr() used @@ -374,6 +395,11 @@ like a block, except that it isn't a proper block. This usually occurs if you tried to jump out of a sort() block or subroutine, which is a no-no. See L<perlfunc/goto>. +=item Can't "goto" into the middle of a foreach loop + +(F) A "goto" statement was executed to jump into the middle of a +foreach loop. You can't get there from here. See L<perlfunc/goto>. + =item Can't "last" outside a block (F) A "last" statement was executed to break out of the current block, @@ -543,8 +569,19 @@ mention "perl" on the #! line somewhere. =item Can't execute %s +(F) You used the B<-S> switch, but the copies of the script to execute found +in the PATH did not have correct permissions. + +=item Can't find %s on PATH, '.' not in PATH + (F) You used the B<-S> switch, but the script to execute could not be found -in the PATH, or at least not with the correct permissions. +in the PATH, or at least not with the correct permissions. The script +exists in the current directory, but PATH prohibits running it. + +=item Can't find %s on PATH + +(F) You used the B<-S> switch, but the script to execute could not be found +in the PATH. =item Can't find label %s @@ -597,12 +634,12 @@ call for another. It can't manufacture one out of whole cloth. In general you should be calling it out of only an AUTOLOAD routine anyway. See L<perlfunc/goto>. -=item Can't localize a reference +=item Can't localize through a reference -(F) You said something like C<local $$ref>, which is not allowed because -the compiler can't determine whether $ref will end up pointing to anything -with a symbol table entry, and a symbol table entry is necessary to -do a local. +(F) You said something like C<local $$ref>, which Perl can't currently +handle, because when it goes to restore the old value of whatever $ref +pointed to after the scope of the local() is finished, it can't be +sure that $ref will still be a reference. =item Can't localize lexical variable %s @@ -611,6 +648,13 @@ lexical variable using "my". This is not allowed. If you want to localize a package variable of the same name, qualify it with the package name. +=item Can't locate auto/%s.al in @INC + +(F) A function (or method) was called in a package which allows autoload, +but there is no function to autoload. Most probable causes are a misprint +in a function/method name or a failure to C<AutoSplit> the file, say, by +doing C<make install>. + =item Can't locate %s in @INC (F) You said to do (or require, or use) a file that couldn't be found @@ -656,8 +700,11 @@ buffer. =item Can't open %s: %s -(S) An inplace edit couldn't open the original file for the indicated reason. -Usually this is because you don't have read permission for the file. +(S) The implicit opening of a file through use of the C<E<lt>E<gt>> +filehandle, either implicitly under the C<-n> or C<-p> command-line +switches, or explicitly, failed for the indicated reason. Usually this +is because you don't have read permission for a file which you named +on the command line. =item Can't open bidirectional pipe @@ -1342,12 +1389,6 @@ found where operator expected". Often the missing operator is a comma. As a general rule, you'll find it's missing near the place you were last editing. -=item Missing semicolon on previous line? - -(S) This is an educated guess made in conjunction with the message "%s -found where operator expected". Don't automatically put a semicolon on -the previous line just because you saw this message. - =item Modification of a read-only value attempted (F) You tried, directly or indirectly, to change the value of a @@ -2070,6 +2111,10 @@ or possibly some other missing operator, such as a comma. (W) The filehandle you're sending to got itself closed sometime before now. Check your logic flow. +=item Sequence (? incomplete +(F) A regular expression ended with an incomplete extension (?. +See L<perlre>. + =item Sequence (?#... not terminated (F) A regular expression comment must be terminated by a closing @@ -2491,7 +2536,7 @@ script, a binary program, or a directory as a Perl program. (F) You specified a signal name to the kill() function that was not recognized. Say C<kill -l> in your shell to see the valid signal names on your system. -=item Unrecognized switch: -%s +=item Unrecognized switch: -%s (-h will show valid options) (F) You specified an illegal option to Perl. Don't do that. (If you think you didn't do that, check the #! line to see if it's diff --git a/pod/perlembed.pod b/pod/perlembed.pod index de10860987..c43ed556aa 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -332,155 +332,173 @@ variables and we've simplified our code as well. =head2 Performing Perl pattern matches and substitutions from your C program -The I<perl_eval_pv()> function lets us evaluate strings of Perl code, so we can +The I<perl_eval_sv()> function lets us evaluate chunks of Perl code, so we can define some functions that use it to "specialize" in matches and substitutions: I<match()>, I<substitute()>, and I<matches()>. - char match(char *string, char *pattern); + char match(SV *string, char *pattern); Given a string and a pattern (e.g., C<m/clasp/> or C</\b\w*\b/>, which in your C program might appear as "/\\b\\w*\\b/"), match() returns 1 if the string matches the pattern and 0 otherwise. - int substitute(char *string[], char *pattern); + int substitute(SV **string, char *pattern); -Given a pointer to a string and an C<=~> operation (e.g., +Given a pointer to an C<SV> and an C<=~> operation (e.g., C<s/bob/robert/g> or C<tr[A-Z][a-z]>), substitute() modifies the string -according to the operation, returning the number of substitutions +within the C<AV> at according to the operation, returning the number of substitutions made. - int matches(char *string, char *pattern, char **matches[]); + int matches(SV *string, char *pattern, AV **matches); -Given a string, a pattern, and a pointer to an empty array of strings, +Given an C<SV>, a pattern, and a pointer to an empty C<AV>, matches() evaluates C<$string =~ $pattern> in an array context, and -fills in I<matches> with the array elements (allocating memory as it -does so), returning the number of matches found. +fills in I<matches> with the array elements, returning the number of matches found. Here's a sample program, I<match.c>, that uses all three (long lines have been wrapped here): - #include <EXTERN.h> - #include <perl.h> - - static PerlInterpreter *my_perl; - - /** match(string, pattern) - ** - ** Used for matches in a scalar context. - ** - ** Returns 1 if the match was successful; 0 otherwise. - **/ - char match(char *string, char *pattern) - { - char *command; - command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37); - sprintf(command, "$string = '%s'; $return = $string =~ %s", - string, pattern); - perl_eval_pv(command, TRUE); - free(command); - return SvIV(perl_get_sv("return", FALSE)); - } - /** substitute(string, pattern) - ** - ** Used for =~ operations that modify their left-hand side (s/// and tr///) - ** - ** Returns the number of successful matches, and - ** modifies the input string if there were any. - **/ - int substitute(char *string[], char *pattern) - { - char *command; - STRLEN length; - command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35); - sprintf(command, "$string = '%s'; $ret = ($string =~ %s)", - *string, pattern); - perl_eval_pv(command, TRUE); - free(command); - *string = SvPV(perl_get_sv("string", FALSE), length); - return SvIV(perl_get_sv("ret", FALSE)); - } - /** matches(string, pattern, matches) - ** - ** Used for matches in an array context. - ** - ** Returns the number of matches, - ** and fills in **matches with the matching substrings (allocates memory!) - **/ - int matches(char *string, char *pattern, char **match_list[]) - { - char *command; - SV *current_match; - AV *array; + #include <EXTERN.h> + #include <perl.h> + + /** my_perl_eval_sv(code, error_check) + ** kinda like perl_eval_sv(), + ** but we pop the return value off the stack + **/ + SV* my_perl_eval_sv(SV *sv, I32 croak_on_error) + { + dSP; + SV* retval; + + PUSHMARK(sp); + perl_eval_sv(sv, G_SCALAR); + + SPAGAIN; + retval = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return retval; + } + + /** match(string, pattern) + ** + ** Used for matches in a scalar context. + ** + ** Returns 1 if the match was successful; 0 otherwise. + **/ + + I32 match(SV *string, char *pattern) + { + SV *command = newSV(0), *retval; + + sv_setpvf(command, "my $string = '%s'; $string =~ %s", + SvPV(string,na), pattern); + + retval = my_perl_eval_sv(command, TRUE); + SvREFCNT_dec(command); + + return SvIV(retval); + } + + /** substitute(string, pattern) + ** + ** Used for =~ operations that modify their left-hand side (s/// and tr///) + ** + ** Returns the number of successful matches, and + ** modifies the input string if there were any. + **/ + + I32 substitute(SV **string, char *pattern) + { + SV *command = newSV(0), *retval; + + sv_setpvf(command, "$string = '%s'; ($string =~ %s)", + SvPV(*string,na), pattern); + + retval = my_perl_eval_sv(command, TRUE); + SvREFCNT_dec(command); + + *string = perl_get_sv("string", FALSE); + return SvIV(retval); + } + + /** matches(string, pattern, matches) + ** + ** Used for matches in an array context. + ** + ** Returns the number of matches, + ** and fills in **matches with the matching substrings + **/ + + I32 matches(SV *string, char *pattern, AV **match_list) + { + SV *command = newSV(0); I32 num_matches; - STRLEN length; - int i; - command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38); - sprintf(command, "$string = '%s'; @array = ($string =~ %s)", - string, pattern); - perl_eval_pv(command, TRUE); - free(command); - array = perl_get_av("array", FALSE); - num_matches = av_len(array) + 1; /** assume $[ is 0 **/ - *match_list = (char **) malloc(sizeof(char *) * num_matches); - for (i = 0; i <= num_matches; i++) { - current_match = av_shift(array); - (*match_list)[i] = SvPV(current_match, length); - } + + sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)", + SvPV(string,na), pattern); + + my_perl_eval_sv(command, TRUE); + SvREFCNT_dec(command); + + *match_list = perl_get_av("array", FALSE); + num_matches = av_len(*match_list) + 1; /** assume $[ is 0 **/ + return num_matches; - } - main (int argc, char **argv, char **env) - { + } + + main (int argc, char **argv, char **env) + { + PerlInterpreter *my_perl = perl_alloc(); char *embedding[] = { "", "-e", "0" }; - char *text, **match_list; - int num_matches, i; - int j; - my_perl = perl_alloc(); - perl_construct( my_perl ); + AV *match_list; + I32 num_matches, i; + SV *text = newSV(0); + + perl_construct(my_perl); perl_parse(my_perl, NULL, 3, embedding, NULL); - perl_run(my_perl); - - text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/ - sprintf(text, "%s", "When he is at a convenience store and the bill \ - comes to some amount like 76 cents, Maynard is aware that there is \ - something he *should* do, something that will enable him to get back \ - a quarter, but he has no idea *what*. He fumbles through his red \ - squeezey changepurse and gives the boy three extra pennies with his \ - dollar, hoping that he might luck into the correct amount. The boy \ - gives him back two of his own pennies and then the big shiny quarter \ - that is his prize. -RICHH"); + + sv_setpv(text, "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*. He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount. The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH"); + if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/ - printf("match: Text contains the word 'quarter'.\n\n"); + printf("match: Text contains the word 'quarter'.\n\n"); else - printf("match: Text doesn't contain the word 'quarter'.\n\n"); + printf("match: Text doesn't contain the word 'quarter'.\n\n"); + if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/ - printf("match: Text contains the word 'eighth'.\n\n"); + printf("match: Text contains the word 'eighth'.\n\n"); else - printf("match: Text doesn't contain the word 'eighth'.\n\n"); + printf("match: Text doesn't contain the word 'eighth'.\n\n"); + /** Match all occurrences of /wi../ **/ num_matches = matches(text, "m/(wi..)/g", &match_list); printf("matches: m/(wi..)/g found %d matches...\n", num_matches); + for (i = 0; i < num_matches; i++) - printf("match: %s\n", match_list[i]); + printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),na)); printf("\n"); - for (i = 0; i < num_matches; i++) { - free(match_list[i]); - } - free(match_list); + /** Remove all vowels from text **/ num_matches = substitute(&text, "s/[aeiou]//gi"); if (num_matches) { - printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", - num_matches); - printf("Now text is: %s\n\n", text); + printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", + num_matches); + printf("Now text is: %s\n\n", SvPV(text,na)); } + /** Attempt a substitution **/ if (!substitute(&text, "s/Perl/C/")) { - printf("substitute: s/Perl/C...No substitution made.\n\n"); + printf("substitute: s/Perl/C...No substitution made.\n\n"); } - free(text); + + SvREFCNT_dec(text); + perl_destruct_level = 1; perl_destruct(my_perl); perl_free(my_perl); - } + } which produces the output (again, long lines have been wrapped here) @@ -560,15 +578,12 @@ deep breath... int main (int argc, char **argv, char **env) { - char *my_argv[2]; + char *my_argv[] = { "", "power.pl" }; my_perl = perl_alloc(); perl_construct( my_perl ); - my_argv[1] = (char *) malloc(10); - sprintf(my_argv[1], "power.pl"); - - perl_parse(my_perl, NULL, argc, my_argv, NULL); + perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL); perl_run(my_perl); PerlPower(3, 4); /*** Compute 3 ** 4 ***/ @@ -995,7 +1010,7 @@ Dov Grobgeld, and Ilya Zakharevich. Check out Doug's article on embedding in Volume 1, Issue 4 of The Perl Journal. Info about TPJ is available from http://tpj.com. -April 14, 1997 +July 17, 1997 Some of this material is excerpted from Jon Orwant's book: I<Perl 5 Interactive>, Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index a28487ac1d..4f3341d911 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -633,7 +633,7 @@ their own password: print "ok\n"; } -Of course, typing in your own password to whomever asks you +Of course, typing in your own password to whoever asks you for it is unwise. =item dbmclose HASH @@ -1032,17 +1032,19 @@ in case 6. The exec() function executes a system command I<AND NEVER RETURNS>, unless the command does not exist and is executed directly instead of -via C</bin/sh -c> (see below). Use system() instead of exec() if you -want it to return. +via your system's command shell (see below). Use system() instead of +exec() if you want it to return. 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 -metacharacters. If there are any, the entire argument is passed to -C</bin/sh -c> for parsing. If there are none, the argument is split -into words and passed directly to execvp(), which is more efficient. -Note: exec() and system() do not flush your output buffer, so you may -need to set C<$|> to avoid lost output. Examples: +metacharacters, and if there are any, the entire argument is passed to +the system's command shell for parsing (this is C</bin/sh -c> on Unix +platforms, but varies on other platforms). If there are no shell +metacharacters in the argument, it is split into words and passed +directly to execvp(), which is more efficient. Note: exec() and +system() do not flush your output buffer, so you may need to set C<$|> +to avoid lost output. Examples: exec '/bin/echo', 'Your arguments are: ', @ARGV; exec "sort $outfile | uniq"; @@ -1061,6 +1063,10 @@ or, more directly, exec {'/bin/csh'} '-sh'; # pretend it's a login shell +When the arguments get executed via the system shell, results will +be subject to its quirks and capabilities. See L<perlop/"`STRING`"> +for details. + =item exists EXPR Returns TRUE if the specified hash key exists in its hash array, even @@ -2150,8 +2156,13 @@ types gobble just one value, but pack it as a string of length count, padding with nulls or spaces as necessary. (When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) Likewise, the "b" and "B" fields pack a string that many bits long. The "h" and "H" fields pack a -string that many nybbles long. The "P" packs a pointer to a structure of -the size indicated by the length. Real numbers (floats and doubles) are +string that many nybbles long. The "p" type packs a pointer to a null- +terminated string. You are responsible for ensuring the string is not a +temporary value (which can potentially get deallocated before you get +around to using the packed result). The "P" packs a pointer to a structure +of the size indicated by the length. A NULL pointer is created if the +corresponding value for "p" or "P" is C<undef>. +Real numbers (floats and doubles) are in the native machine format only; due to the multiplicity of floating formats around, and the lack of a standard "network" representation, no facility for interchange has been made. This means that packed floating @@ -2371,6 +2382,16 @@ chdir() there, it would have been testing the wrong file. @dots = grep { /^\./ && -f "$some_dir/$_" } readdir(DIR); closedir DIR; +=item readline EXPR + +Reads from the file handle EXPR. In scalar context, a single line +is read and returned. In list context, reads until end-of-file is +reached and returns a list of lines (however you've defined lines +with $/ or $INPUT_RECORD_SEPARATOR). +This is the internal function implementing the C<E<lt>EXPRE<gt>> +operator, but you can use it directly. The C<E<lt>EXPRE<gt>> +operator is discussed in more detail in L<perlop/"I/O Operators">. + =item readlink EXPR =item readlink @@ -2380,6 +2401,17 @@ implemented. If not, gives a fatal error. If there is some system error, returns the undefined value and sets C<$!> (errno). If EXPR is omitted, uses $_. +=item readpipe EXPR + +EXPR is interpolated and then executed as a system command. +The collected standard output of the command is returned. +In scalar context, it comes back as a single (potentially +multi-line) string. In list context, returns a list of lines +(however you've defined lines with $/ or $INPUT_RECORD_SEPARATOR). +This is the internal function implementing the C<qx/EXPR/> +operator, but you can use it directly. The C<qx/EXPR/> +operator is discussed in more detail in L<perlop/"I/O Operators">. + =item recv SOCKET,SCALAR,LEN,FLAGS Receives a message on a socket. Attempts to receive LENGTH bytes of @@ -3336,11 +3368,15 @@ L<perlref> for details. Extracts a substring out of EXPR and returns it. First character is at offset 0, or whatever you've set C<$[> to (but don't do that). -If OFFSET is negative, starts +If OFFSET is negative (or more precisely, less than C<$[>), starts that far from the end of the string. If LEN is omitted, returns everything to the end of the string. If LEN is negative, leaves that many characters off the end of the string. +If you specify a substring which is partly outside the string, the part +within the string is returned. If the substring is totally outside +the string a warning is produced. + You can use the substr() function as an lvalue, in which case EXPR must be an lvalue. If you assign something shorter than LEN, the string will shrink, and if you assign @@ -3480,6 +3516,10 @@ signals and core dumps. } $ok = ($rc != 0); +When the arguments get executed via the system shell, results will +be subject to its quirks and capabilities. See L<perlop/"`STRING`"> +for details. + =item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET =item syswrite FILEHANDLE,SCALAR,LENGTH diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 28c196017c..ecf8610756 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -765,52 +765,71 @@ the various routines for the various magical types begin with C<magic_>. The current kinds of Magic Virtual Tables are: - mg_type MGVTBL Type of magical + mg_type MGVTBL Type of magic ------- ------ ---------------------------- - \0 vtbl_sv Regexp??? - A vtbl_amagic Operator Overloading - a vtbl_amagicelem Operator Overloading - c 0 Used in Operator Overloading - B vtbl_bm Boyer-Moore??? + \0 vtbl_sv Special scalar variable + A vtbl_amagic %OVERLOAD hash + a vtbl_amagicelem %OVERLOAD hash element + c (none) Holds overload table (AMT) on stash + B vtbl_bm Boyer-Moore (fast string search) E vtbl_env %ENV hash e vtbl_envelem %ENV hash element - g vtbl_mglob Regexp /g flag??? + f vtbl_fm Formline ('compiled' format) + g vtbl_mglob m//g target / study()ed string I vtbl_isa @ISA array i vtbl_isaelem @ISA array element - L 0 (but sets RMAGICAL) Perl Module/Debugger??? - l vtbl_dbline Debugger? + k vtbl_nkeys scalar(keys()) lvalue + L (none) Debugger %_<filename + l vtbl_dbline Debugger %_<filename element o vtbl_collxfrm Locale transformation - P vtbl_pack Tied Array or Hash - p vtbl_packelem Tied Array or Hash element - q vtbl_packelem Tied Scalar or Handle - S vtbl_sig Signal Hash - s vtbl_sigelem Signal Hash element + P vtbl_pack Tied array or hash + p vtbl_packelem Tied array or hash element + q vtbl_packelem Tied scalar or handle + S vtbl_sig %SIG hash + s vtbl_sigelem %SIG hash element t vtbl_taint Taintedness - U vtbl_uvar ??? - v vtbl_vec Vector - x vtbl_substr Substring??? - y vtbl_itervar Shadow "foreach" iterator variable - * vtbl_glob GV??? - # vtbl_arylen Array Length - . vtbl_pos $. scalar variable - ~ None Used by certain extensions + U vtbl_uvar Available for use by extensions + v vtbl_vec vec() lvalue + x vtbl_substr substr() lvalue + y vtbl_defelem Shadow "foreach" iterator variable / + smart parameter vivification + * vtbl_glob GV (typeglob) + # vtbl_arylen Array length ($#ary) + . vtbl_pos pos() lvalue + ~ (none) Available for use by extensions When an uppercase and lowercase letter both exist in the table, then the uppercase letter is used to represent some kind of composite type (a list or a hash), and the lowercase letter is used to represent an element of that composite type. -The '~' magic type is defined specifically for use by extensions and -will not be used by perl itself. Extensions can use ~ magic to 'attach' -private information to variables (typically objects). This is especially -useful because there is no way for normal perl code to corrupt this -private information (unlike using extra elements of a hash object). +The '~' and 'U' magic types are defined specifically for use by +extensions and will not be used by perl itself. Extensions can use +'~' magic to 'attach' private information to variables (typically +objects). This is especially useful because there is no way for +normal perl code to corrupt this private information (unlike using +extra elements of a hash object). + +Similarly, 'U' magic can be used much like tie() to call a C function +any time a scalar's value is used or changed. The C<MAGIC>'s +C<mg_ptr> field points to a C<ufuncs> structure: + + struct ufuncs { + I32 (*uf_val)(IV, SV*); + I32 (*uf_set)(IV, SV*); + IV uf_index; + }; + +When the SV is read from or written to, the C<uf_val> or C<uf_set> +function will be called with C<uf_index> as the first arg and a +pointer to the SV as the second. -Note that because multiple extensions may be using ~ magic it is -important for extensions to take extra care with it. Typically only -using it on objects blessed into the same class as the extension -is sufficient. It may also be appropriate to add an I32 'signature' -at the top of the private data area and check that. +Note that because multiple extensions may be using '~' or 'U' magic, +it is important for extensions to take extra care to avoid conflict. +Typically only using the magic on objects blessed into the same class +as the extension is sufficient. For '~' magic, it may also be +appropriate to add an I32 'signature' at the top of the private data +area and check that. =head2 Finding Magic @@ -885,6 +904,150 @@ This overhead will be comparatively small if the TIE methods are themselves substantial, but if they are only a few statements long, the overhead will not be insignificant. +=head2 Localizing changes + +Perl has a very handy construction + + { + local $var = 2; + ... + } + +This construction is I<approximately> equivalent to + + { + my $oldvar = $var; + $var = 2; + ... + $var = $oldvar; + } + +The biggest difference is that the first construction would +reinstate the initial value of $var, irrespective of how control exits +the block: C<goto>, C<return>, C<die>/C<eval> etc. It is a little bit +more efficient as well. + +There is a way to achieve a similar task from C via Perl API: create a +I<pseudo-block>, and arrange for some changes to be automatically +undone at the end of it, either explicit, or via a non-local exit (via +die()). A I<block>-like construct is created by a pair of +C<ENTER>/C<LEAVE> macros (see L<perlcall/EXAMPLE/"Returning a +Scalar">). Such a construct may be created specially for some +important localized task, or an existing one (like boundaries of +enclosing Perl subroutine/block, or an existing pair for freeing TMPs) +may be used. (In the second case the overhead of additional +localization must be almost negligible.) Note that any XSUB is +automatically enclosed in an C<ENTER>/C<LEAVE> pair. + +Inside such a I<pseudo-block> the following service is available: + +=over + +=item C<SAVEINT(int i)> + +=item C<SAVEIV(IV i)> + +=item C<SAVEI32(I32 i)> + +=item C<SAVELONG(long i)> + +These macros arrange things to restore the value of integer variable +C<i> at the end of enclosing I<pseudo-block>. + +=item C<SAVESPTR(s)> + +=item C<SAVEPPTR(p)> + +These macros arrange things to restore the value of pointers C<s> and +C<p>. C<s> must be a pointer of a type which survives conversion to +C<SV*> and back, C<p> should be able to survive conversion to C<char*> +and back. + +=item C<SAVEFREESV(SV *sv)> + +The refcount of C<sv> would be decremented at the end of +I<pseudo-block>. This is similar to C<sv_2mortal>, which should (?) be +used instead. + +=item C<SAVEFREEOP(OP *op)> + +The C<OP *> is op_free()ed at the end of I<pseudo-block>. + +=item C<SAVEFREEPV(p)> + +The chunk of memory which is pointed to by C<p> is Safefree()ed at the +end of I<pseudo-block>. + +=item C<SAVECLEARSV(SV *sv)> + +Clears a slot in the current scratchpad which corresponds to C<sv> at +the end of I<pseudo-block>. + +=item C<SAVEDELETE(HV *hv, char *key, I32 length)> + +The key C<key> of C<hv> is deleted at the end of I<pseudo-block>. The +string pointed to by C<key> is Safefree()ed. If one has a I<key> in +short-lived storage, the corresponding string may be reallocated like +this: + + SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + +=item C<SAVEDESTRUCTOR(f,p)> + +At the end of I<pseudo-block> the function C<f> is called with the +only argument (of type C<void*>) C<p>. + +=item C<SAVESTACK_POS()> + +The current offset on the Perl internal stack (cf. C<SP>) is restored +at the end of I<pseudo-block>. + +=back + +The following API list contains functions, thus one needs to +provide pointers to the modifiable data explicitly (either C pointers, +or Perlish C<GV *>s). Where the above macros take C<int>, a similar +function takes C<int *>. + +=over + +=item C<SV* save_scalar(GV *gv)> + +Equivalent to Perl code C<local $gv>. + +=item C<AV* save_ary(GV *gv)> + +=item C<HV* save_hash(GV *gv)> + +Similar to C<save_scalar>, but localize C<@gv> and C<%gv>. + +=item C<void save_item(SV *item)> + +Duplicates the current value of C<SV>, on the exit from the current +C<ENTER>/C<LEAVE> I<pseudo-block> will restore the value of C<SV> +using the stored value. + +=item C<void save_list(SV **sarg, I32 maxsarg)> + +A variant of C<save_item> which takes multiple arguments via an array +C<sarg> of C<SV*> of length C<maxsarg>. + +=item C<SV* save_svref(SV **sptr)> + +Similar to C<save_scalar>, but will reinstate a C<SV *>. + +=item C<void save_aptr(AV **aptr)> + +=item C<void save_hptr(HV **hptr)> + +Similar to C<save_svref>, but localize C<AV *> and C<HV *>. + +=back + +The C<Alias> module implements localization of the basic types within the +I<caller's scope>. People who are interested in how to localize things in +the containing scope should take a look there too. + =head1 Subroutines =head2 XSUBs and the Argument Stack @@ -1405,11 +1568,6 @@ 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 dXSI32 - -Sets up the C<ix> variable for an XSUB which has aliases. This is usually -handled automatically by C<xsubpp>. - =item ENTER Opening bracket on a callback. See C<LEAVE> and L<perlcall>. @@ -2364,14 +2522,6 @@ C<sv2>. I32 sv_cmp _((SV* sv1, SV* sv2)); -=item sv_cmp - -Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the -string in C<sv1> is less than, equal to, or greater than the string in -C<sv2>. - - I32 sv_cmp _((SV* sv1, SV* sv2)); - =item SvCUR Returns the length of the string which is in the SV. See C<SvLEN>. @@ -2390,12 +2540,6 @@ Auto-decrement of the value in the SV. void sv_dec _((SV* sv)); -=item sv_dec - -Auto-decrement of the value in the SV. - - void sv_dec _((SV* sv)); - =item SvEND Returns a pointer to the last character in the string which is in the SV. @@ -2453,12 +2597,6 @@ Tells an SV that it is an integer and disables all other OK bits. SvIOK_on (SV* sv) -=item SvIOK_only - -Tells an SV that it is an integer and disables all other OK bits. - - SvIOK_on (SV* sv) - =item SvIOKp Returns a boolean indicating whether the SV contains an integer. Checks the @@ -2506,12 +2644,6 @@ Returns the length of the string in the SV. Use C<SvCUR>. STRLEN sv_len _((SV* sv)); -=item sv_len - -Returns the length of the string in the SV. Use C<SvCUR>. - - STRLEN sv_len _((SV* sv)); - =item sv_magic Adds magic to an SV. @@ -2585,12 +2717,6 @@ Tells an SV that it is a double and disables all other OK bits. SvNOK_on (SV* sv) -=item SvNOK_only - -Tells an SV that it is a double and disables all other OK bits. - - SvNOK_on (SV* sv) - =item SvNOKp Returns a boolean indicating whether the SV contains a double. Checks the @@ -2634,12 +2760,6 @@ Tells an SV that it is a string and disables all other OK bits. SvPOK_on (SV* sv) -=item SvPOK_only - -Tells an SV that it is a string and disables all other OK bits. - - SvPOK_on (SV* sv) - =item SvPOKp Returns a boolean indicating whether the SV contains a character string. @@ -3050,7 +3170,8 @@ Jeff Okamoto <F<okamoto@corp.hp.com>> With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil -Bowers, Matthew Green, Tim Bunce, Spider Boardman, and Ulrich Pfeifer. +Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, and +Stephen McCamant. API Listing by Dean Roehrich <F<roehrich@cray.com>>. diff --git a/pod/perlop.pod b/pod/perlop.pod index 32a0827cb3..56859029bf 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -702,7 +702,7 @@ each time it matches, and FALSE when it eventually runs out of matches. the search at that point. You can actually find the current match position of a string or set it using the pos() function; see L<perlfunc/pos>.) A failed match normally resets the search position to -the beginning of the string, but you can avoid that by adding the "c" +the beginning of the string, but you can avoid that by adding the C</c> modifier (e.g. C<m//gc>). Modifying the target string also resets the search position. @@ -808,6 +808,24 @@ with $/ or $INPUT_RECORD_SEPARATOR). $today = qx{ date }; +Note that how the string gets evaluated is entirely subject to the +command interpreter on your system. On most platforms, you will have +to protect shell metacharacters if you want them treated literally. +On some platforms (notably DOS-like ones), the shell may not be +capable of dealing with multiline commands, so putting newlines in +the string may not get you what you want. You may be able to evaluate +multiple commands in a single line by separating them with the command +separator character, if your shell supports that (e.g. C<;> on many Unix +shells; C<&> on the Windows NT C<cmd> shell). + +Beware that some command shells may place restrictions on the length +of the command line. You must ensure your strings don't exceed this +limit after any necessary interpolations. See the platform-specific +release notes for more details about your particular environment. + +Also realize that using this operator frequently leads to unportable +programs. + See L<"I/O Operators"> for more discussion. =item qw/STRING/ diff --git a/pod/perlre.pod b/pod/perlre.pod index 2b24379c8b..14892a8846 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -136,7 +136,7 @@ also work: \L lowercase till \E (think vi) \U uppercase till \E (think vi) \E end case modification (think vi) - \Q quote regexp metacharacters till \E + \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>. @@ -226,19 +226,20 @@ you've used them once, use them at will, because you've already paid the price. You will note that all backslashed metacharacters in Perl are -alphanumeric, such as C<\b>, C<\w>, C<\n>. Unlike some other regular expression -languages, there are no backslashed symbols that aren't alphanumeric. -So anything that looks like \\, \(, \), \E<lt>, \E<gt>, \{, or \} is always -interpreted as a literal character, not a metacharacter. This makes it -simple to quote a string that you want to use for a pattern but that -you are afraid might contain metacharacters. Quote simply all the +alphanumeric, such as C<\b>, C<\w>, C<\n>. Unlike some other regular +expression languages, there are no backslashed symbols that aren't +alphanumeric. So anything that looks like \\, \(, \), \E<lt>, \E<gt>, +\{, or \} is always interpreted as a literal character, not a +metacharacter. This was once used in a common idiom to disable or +quote the special meanings of regular expression metacharacters in a +string that you want to use for a pattern. Simply quote all the non-alphanumeric characters: $pattern =~ s/(\W)/\\$1/g; -You can also use the builtin quotemeta() function to do this. -An even easier way to quote metacharacters right in the match operator -is to say +Now it is much more common to see either the quotemeta() function or +the \Q escape sequence used to disable the metacharacters special +meanings like this: /$unquoted\Q$quoted\E$unquoted/ @@ -515,7 +516,11 @@ in C<[]>, which will match any one of the characters in the list. If the first character after the "[" is "^", the class matches any character not in the list. Within a list, the "-" character is used to specify a range, so that C<a-z> represents all the characters between "a" and "z", -inclusive. +inclusive. If you want "-" itself to be a member of a class, put it +at the start or end of the list, or escape it with a backslash. (The +following all specify the same class of three characters: C<[-az]>, +C<[az-]>, and C<[a\-z]>. All are different from C<[a-z]>, which +specifies a class containing twenty-six characters.) Characters may be specified using a metacharacter syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, diff --git a/pod/perlrun.pod b/pod/perlrun.pod index de7116d939..1e3279e374 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -224,33 +224,33 @@ runs the script under the control of a debugging or tracing module installed as Devel::foo. E.g., B<-d:DProf> executes the script using the Devel::DProf profiler. See L<perldebug>. -=item B<-D>I<number> +=item B<-D>I<letters> -=item B<-D>I<list> +=item B<-D>I<number> sets debugging flags. To watch how it executes your script, use -B<-D14>. (This works only if debugging is compiled into your -Perl.) Another nice value is B<-D1024>, which lists your compiled -syntax tree. And B<-D512> displays compiled regular expressions. As an -alternative specify a list of letters instead of numbers (e.g., B<-D14> is +B<-Dtls>. (This works only if debugging is compiled into your +Perl.) Another nice value is B<-Dx>, which lists your compiled +syntax tree. And B<-Dr> displays compiled regular expressions. As an +alternative, specify a number instead of list of letters (e.g., B<-D14> is equivalent to B<-Dtls>): - 1 p Tokenizing and Parsing - 2 s Stack Snapshots - 4 l Label Stack Processing - 8 t Trace Execution - 16 o Operator Node Construction - 32 c String/Numeric Conversions - 64 P Print Preprocessor Command for -P - 128 m Memory Allocation - 256 f Format Processing - 512 r Regular Expression Parsing - 1024 x Syntax Tree Dump - 2048 u Tainting Checks - 4096 L Memory Leaks (not supported anymore) - 8192 H Hash Dump -- usurps values() - 16384 X Scratchpad Allocation - 32768 D Cleaning Up + 1 p Tokenizing and parsing + 2 s Stack snapshots + 4 l Context (loop) stack processing + 8 t Trace execution + 16 o Method and overloading resolution + 32 c String/numeric conversions + 64 P Print preprocessor command for -P + 128 m Memory allocation + 256 f Format processing + 512 r Regular expression parsing and execution + 1024 x Syntax tree dump + 2048 u Tainting checks + 4096 L Memory leaks (not supported anymore) + 8192 H Hash dump -- usurps values() + 16384 X Scratchpad allocation + 32768 D Cleaning up =item B<-e> I<commandline> @@ -376,8 +376,10 @@ B<awk>: } Note that the lines are not printed by default. See B<-p> to have -lines printed. Here is an efficient way to delete all files older than -a week: +lines printed. If a file named by an argument cannot be opened for +some reason, Perl warns you about it, and moves on to the next file. + +Here is an efficient way to delete all files older than a week: find . -mtime +7 -print | perl -nle 'unlink;' @@ -396,11 +398,14 @@ makes it iterate over filename arguments somewhat like B<sed>: while (<>) { ... # your script goes here } continue { - print; + print or die "-p destination: $!\n"; } -Note that the lines are printed automatically. To suppress printing -use the B<-n> switch. A B<-p> overrides a B<-n> switch. +If a file named by an argument cannot be opened for some reason, Perl +warns you about it, and moves on to the next file. Note that the +lines are printed automatically. An error occuring during printing is +treated as fatal. To suppress printing use the B<-n> switch. A B<-p> +overrides a B<-n> switch. C<BEGIN> and C<END> blocks may be used to capture control before or after the implicit loop, just as in awk. @@ -426,9 +431,27 @@ prints "true" if and only if the script is invoked with a B<-xyz> switch. =item B<-S> makes Perl use the PATH environment variable to search for the -script (unless the name of the script starts with a slash). Typically -this is used to emulate #! startup on machines that don't support #!, -in the following manner: +script (unless the name of the script contains directory separators). +On some platforms, this also makes Perl append suffixes to the +filename while searching for it. For example, on Win32 platforms, +the ".bat" and ".cmd" suffixes are appended if a lookup for the +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 +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. + +On DOS-like platforms, if the script does not contain directory +separators, it will first be searched for in the current directory +before being searched for on the PATH. On Unix platforms, the +script will be searched for strictly on the PATH. + +Typically this is used to emulate #! startup on platforms that +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+"$@"}' diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 989c1efe01..74b0029d73 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -911,7 +911,7 @@ LIST, READLINE this, GETC this, DESTROY this =item Malloc enhancements --DDEBUGGING_MSTATS, -DEMERGENCY_SBRK, -DPACK_MALLOC, -DTWO_POT_OPTIMIZE +-DDEBUGGING_MSTATS, -DPERL_EMERGENCY_SBRK, -DPACK_MALLOC, -DTWO_POT_OPTIMIZE =item Miscellaneous efficiency enhancements diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 786dcda607..9382789969 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -438,6 +438,12 @@ whether this should be classed as a bug or not. # perl4 prints: x=10 # perl5 prints: Can't find string terminator "'" anywhere before EOF +You can avoid this problem, and remain compatible with perl4, if you +always explicitly include the package name: + + $x = 10 ; + print "x=${main'x}\n" ; + Also see precedence traps, for parsing C<$:>. =item * BugFix @@ -923,7 +929,9 @@ Perl4-to-Perl5 traps involving precedence order. =item * Precedence -LHS vs. RHS when both sides are getting an op. +LHS vs. RHS of any assignment operator. LHS is evaluated first +in perl4, second in perl5; this can affect the relationship +between side-effects in sub-expressions. @arr = ( 'left', 'right' ); $a{shift @arr} = shift @arr; @@ -999,18 +1007,6 @@ concatenation precedence over filetest operator? # perl4 prints: no output # perl5 prints: Can't modify -e in concatenation -=item * Precedence - -Assignment to value takes precedence over assignment to key in -perl5 when using the shift operator on both sides. - - @arr = ( 'left', 'right' ); - $a{shift @arr} = shift @arr; - print join( ' ', keys %a ); - - # perl4 prints: left - # perl5 prints: right - =back =head2 General Regular Expression Traps using s///, etc. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 198e5c12a3..6487fdda36 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -619,9 +619,39 @@ is identical to C<$Config{'osname'}>. =item $^P -The internal flag that the debugger clears so that it doesn't debug -itself. You could conceivably disable debugging yourself by clearing -it. +The internal variable for debugging support. Different bits mean the +following (subject to change): + +=over 6 + +=item 0x01 + +Debug subroutine enter/exit. + +=item 0x02 + +Line-by-line debugging. + +=item 0x04 + +Switch off optimizations. + +=item 0x08 + +Preserve more data for future interactive inspections. + +=item 0x10 + +Keep info about source lines on which a subroutine is defined. + +=item 0x20 + +Start with single-step on. + +=back + +Note that some bits may be relevent at compile-time only, some at +run-time only. This is a new mechanism and the details may change. =item $BASETIME @@ -753,7 +783,7 @@ L<perlfunc/die>, L<perlfunc/warn> and L<perlfunc/eval>. 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 -DEMERGENCY_SBRK and used Perl's malloc. Then +compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then $^M = 'a' x (1<<16); diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index cdd4344b78..9ebfe82a97 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -529,12 +529,12 @@ and a new replacement subroutine too: sub MY::postamble { ' $(MYEXTLIB): mylib/Makefile - cd mylib && $(MAKE) + cd mylib && $(MAKE) $(PASTHRU) '; } (Note: Most makes will require that there be a tab character that indents -the line "cd mylib && $(MAKE)", similarly for the Makefile in the +the line C<cd mylib && $(MAKE) $(PASTHRU)>, similarly for the Makefile in the subdirectory.) Let's also fix the MANIFEST file so that it accurately reflects the contents diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 2c1837a37a..46f47a8870 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -310,6 +310,7 @@ Tom Christiansen such that Larry probably doesn't recognize it anymore. $/ = ""; $cutting = 1; +@Indices = (); # 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 @@ -555,13 +556,14 @@ END print <<"END"; .TH $name $section "$RP" "$date" "$center" -.IX Title "$name $section" .UC END +push(@Indices, qq{.IX Title "$name $section"}); + while (($name, $desc) = each %namedesc) { for ($name, $desc) { s/^\s+//; s/\s+$//; } - print qq(.IX Name "$name - $desc"\n); + push(@Indices, qq(.IX Name "$name - $desc"\n)); } print <<'END'; @@ -727,9 +729,9 @@ while (<>) { # trofficate backslashes; must do it before what happens below s/\\/noremap('\\e')/ge; -# protect leading periods and quotes against *roff -# mistaking them for directives -s/^(?:[A-Z]<)?[.']/\\&$&/gm; + # protect leading periods and quotes against *roff + # mistaking them for directives + s/^(?:[A-Z]<)?[.']/\\&$&/gm; # first hide the escapes in case we need to # intuit something and get it wrong due to fmting @@ -883,11 +885,11 @@ s/^(?:[A-Z]<)?[.']/\\&$&/gm; s/\s+$//; delete $wanna_see{$_} if exists $wanna_see{$_}; print qq{.SH "$_"\n}; - print qq{.IX Header "$_"\n}; + push(@Indices, qq{.IX Header "$_"\n}); } elsif ($Cmd eq 'head2') { print qq{.Sh "$_"\n}; - print qq{.IX Subsection "$_"\n}; + push(@Indices, qq{.IX Subsection "$_"\n}); } elsif ($Cmd eq 'over') { push(@indent,$indent); @@ -906,7 +908,7 @@ s/^(?:[A-Z]<)?[.']/\\&$&/gm; s/[^"]""([^"]+?)""[^"]/'$1'/g; # here do something about the $" in perlvar? print STDOUT qq{.Ip "$_" $indent\n}; - print qq{.IX Item "$_"\n}; + push(@Indices, qq{.IX Item "$_"\n}); } elsif ($Cmd eq 'pod') { # this is just a comment @@ -939,6 +941,8 @@ if (%wanna_see && !$lax) { $oops++; } +foreach (@Indices) { print "$_\n"; } + exit; #exit ($oops != 0); @@ -1042,7 +1046,7 @@ sub makespace { sub mkindex { my ($entry) = @_; my @entries = split m:\s*/\s*:, $entry; - print ".IX Xref "; + push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries; for $entry (@entries) { print qq("$entry" ); } @@ -1101,6 +1105,7 @@ sub clear_noremap { sub internal_lrefs { local($_) = shift; + local $trailing_and = s/and\s+$// ? "and " : ""; s{L</([^>]+)>}{$1}g; my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); @@ -1114,6 +1119,7 @@ sub internal_lrefs { $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) . " elsewhere in this document "; # terminal space to avoid words running together (pattern used strips terminal spaces) + $retstr .= $trailing_and; return $retstr; diff --git a/pod/splitpod b/pod/splitpod index 889dfa215a..fd38e51acf 100755 --- a/pod/splitpod +++ b/pod/splitpod @@ -12,23 +12,29 @@ while (<>) { if (s/=item (\S+)/$1/) { #$cur = "POSIX::" . $1; + $next{$cur} = $1; $cur = $1; $syn{$cur} .= $_; next; } else { #s,L</,L<POSIX/,g; s,L</,L<perlfunc/,g; - push @{$pod{$cur} ||= []}, $_ if $cur; + push @{$pod{$cur}}, $_ if $cur; } } for $f ( keys %syn ) { - $type = $Type{$f} || next; + next unless $Type{$f}; $flavor = $Flavor{$f}; $orig = $f; ($name = $f) =~ s/\W//g; + + # deal with several functions sharing a description + $func = $orig; + $func = $next{$func} until $pod{$func}; + my $body = join "", @{$pod{$func}}; + # deal with unbalanced =over and =back cause by the split - my $body = $pod{$orig}; my $has_over = $body =~ /^=over/; my $has_back = $body =~ /^=back/; $body =~ s/^=over\s*//m if $has_over and !$has_back; @@ -16,6 +16,17 @@ #include "perl.h" /* + * The compiler on Concurrent CX/UX systems has a subtle bug which only + * seems to show up when compiling pp.c - it generates the wrong double + * precision constant value for (double)UV_MAX when used inline in the body + * of the code below, so this makes a static variable up front (which the + * compiler seems to get correct) and uses it in place of UV_MAX below. + */ +#ifdef CXUX_BROKEN_CONSTANT_CONVERT +static double UV_MAX_cxux = ((double)UV_MAX); +#endif + +/* * Types used in bitwise operations. * * Normally we'd just use IV and UV. However, some hardware and @@ -1621,37 +1632,56 @@ PP(pp_substr) STRLEN curlen; I32 pos; I32 rem; + I32 fail; I32 lvalue = op->op_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; if (MAXARG > 2) len = POPi; - pos = POPi - arybase; + pos = POPi; sv = POPs; tmps = SvPV(sv, curlen); - if (pos < 0) { - pos += curlen + arybase; - if (pos < 0 && MAXARG < 3) - pos = 0; + if (pos >= arybase) { + pos -= arybase; + rem = curlen-pos; + fail = rem; + if (MAXARG > 2) { + if (len < 0) { + rem += len; + if (rem < 0) + rem = 0; + } + else if (rem > len) + rem = len; + } } - if (pos < 0 || pos > curlen) { - if (dowarn || lvalue) + else { + pos += curlen; + if (MAXARG < 3) + rem = curlen; + else if (len >= 0) { + rem = pos+len; + if (rem > (I32)curlen) + rem = curlen; + } + else { + rem = curlen+len; + if (rem < pos) + rem = pos; + } + if (pos < 0) + pos = 0; + fail = rem; + rem -= pos; + } + if (fail < 0) { + if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } else { - if (MAXARG < 3) - len = curlen; - else if (len < 0) { - len += curlen - pos; - if (len < 0) - len = 0; - } tmps += pos; - rem = curlen - pos; /* rem=how many bytes left*/ - if (rem > len) - rem = len; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { @@ -2343,11 +2373,13 @@ PP(pp_splice) SP++; if (++MARK < SP) { - offset = SvIVx(*MARK); + offset = i = SvIVx(*MARK); if (offset < 0) offset += AvFILL(ary) + 1; else offset -= curcop->cop_arybase; + if (offset < 0) + DIE(no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) @@ -2360,12 +2392,6 @@ PP(pp_splice) offset = 0; length = AvMAX(ary) + 1; } - if (offset < 0) { - length += offset; - offset = 0; - if (length < 0) - length = 0; - } if (offset > AvFILL(ary) + 1) offset = AvFILL(ary) + 1; after = AvFILL(ary) + 1 - (offset + length); @@ -3740,8 +3766,12 @@ PP(pp_pack) #ifdef BW_BITS adouble <= BW_MASK #else +#ifdef CXUX_BROKEN_CONSTANT_CONVERT + adouble <= UV_MAX_cxux +#else adouble <= UV_MAX #endif +#endif ) { char buf[1 + sizeof(UV)]; @@ -3857,7 +3887,21 @@ PP(pp_pack) case 'p': while (len-- > 0) { fromstr = NEXTFROM; - aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */ + if (fromstr == &sv_undef) + aptr = NULL; + else { + /* XXX better yet, could spirit away the string to + * a safe spot and hang on to it until the result + * of pack() (and all copies of the result) are + * gone. + */ + if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) + warn("Attempt to pack pointer to temporary value"); + if (SvPOK(fromstr) || SvNIOK(fromstr)) + aptr = SvPV(fromstr,na); + else + aptr = SvPV_force(fromstr,na); + } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; @@ -1881,7 +1881,7 @@ PP(pp_goto) mark++; } } - if (perldb && curstash != debstash) { + if (PERLDB_SUB && curstash != debstash) { /* * We do not care about using sv to call CV; * it's for informational purposes only. @@ -1969,6 +1969,11 @@ PP(pp_goto) OP *oldop = op; for (ix = 1; enterops[ix]; ix++) { op = enterops[ix]; + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + if (op->op_type == OP_ENTERITER) + DIE("Can't \"goto\" into the middle of a foreach loop", + label); (*op->op_ppaddr)(ARGS); } op = oldop; @@ -2253,7 +2258,7 @@ int gimme; DEBUG_x(dump_eval()); /* Register with debugger: */ - if (perldb && saveop->op_type == OP_REQUIRE) { + if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -2316,6 +2321,9 @@ PP(pp_require) #ifdef DOSISH || (name[0] && name[1] == ':') #endif +#ifdef WIN32 + || (name[0] == '\\' && name[1] == '\\') /* UNC path */ +#endif #ifdef VMS || (strchr(name,':') || ((*name == '[' || *name == '<') && (isALNUM(name[1]) || strchr("$-_]>",name[1])))) @@ -2466,7 +2474,7 @@ PP(pp_entereval) /* prepare to compile string */ - if (perldb && curstash != debstash) + if (PERLDB_LINE && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; #ifdef USE_THREADS @@ -2478,7 +2486,8 @@ PP(pp_entereval) MUTEX_UNLOCK(&eval_mutex); #endif /* USE_THREADS */ ret = doeval(gimme); - if (perldb && was != sub_generation) { /* Some subs defined here. */ + if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */ + && ret != op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ } return DOCATCH(ret); @@ -2527,6 +2536,36 @@ PP(pp_leaveeval) } curpm = newpm; /* Don't pop $1 et al till now */ + /* + * Closures mentioned at top level of eval cannot be referenced + * again, and their presence indirectly causes a memory leak. + * (Note that the fact that compcv and friends are still set here + * is, AFAIK, an accident.) --Chip + */ + if (AvFILL(comppad_name) >= 0) { + SV **svp = AvARRAY(comppad_name); + I32 ix; + for (ix = AvFILL(comppad_name); ix >= 0; ix--) { + SV *sv = svp[ix]; + if (sv && sv != &sv_undef && *SvPVX(sv) == '&') { + SvREFCNT_dec(sv); + svp[ix] = &sv_undef; + + sv = curpad[ix]; + if (CvCLONE(sv)) { + SvREFCNT_dec(CvOUTSIDE(sv)); + CvOUTSIDE(sv) = Nullcv; + } + else { + SvREFCNT_dec(sv); + sv = NEWSV(0,0); + SvPADTMP_on(sv); + curpad[ix] = sv; + } + } + } + } + #ifdef DEBUGGING assert(CvDEPTH(compcv) == 1); #endif @@ -449,8 +449,6 @@ PP(pp_rv2av) av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) DIE("Not an ARRAY reference"); - if (op->op_private & OPpLVAL_INTRO) - av = (AV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { PUSHs((SV*)av); RETURN; @@ -526,8 +524,6 @@ PP(pp_rv2hv) hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) DIE("Not a HASH reference"); - if (op->op_private & OPpLVAL_INTRO) - hv = (HV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; @@ -2085,7 +2081,7 @@ PP(pp_entersub) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn - && !(perldb && cv == GvCV(DBsub))) + && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *av; @@ -536,7 +536,7 @@ PP(pp_tie) ENTER; SAVEOP(); op = (OP *) &myop; - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; XPUSHs((SV*)GvCV(gv)); @@ -647,7 +647,7 @@ PP(pp_dbmopen) ENTER; SAVEOP(); op = (OP *) &myop; - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(ARGS); @@ -4377,6 +4377,17 @@ int fd; int operation; { int i; + int save_errno; + Off_t pos; + + /* flock locks entire file so for lockf we need to do the same */ + save_errno = errno; + pos = lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ + if (pos > 0) /* is seekable and needs to be repositioned */ + if (lseek(fd, (Off_t)0, SEEK_SET) < 0) + pos = -1; /* seek failed, so don't seek back afterwards */ + errno = save_errno; + switch (operation) { /* LOCK_SH - get a shared lock */ @@ -4408,6 +4419,10 @@ int operation; errno = EINVAL; break; } + + if (pos > 0) /* need to restore position of the handle */ + lseek(fd, pos, SEEK_SET); /* ignore error here */ + return (i); } @@ -507,6 +507,7 @@ void sv_report_used _((void)); void sv_reset _((char* s, HV* stash)); void sv_setpvf _((SV* sv, const char* pat, ...)); void sv_setiv _((SV* sv, IV num)); +void sv_setpviv _((SV* sv, IV num)); void sv_setuv _((SV* sv, UV num)); void sv_setnv _((SV* sv, double num)); SV* sv_setref_iv _((SV* rv, char* classname, IV iv)); @@ -471,6 +471,9 @@ I32 *flagp; nextchar(); *flagp = TRYAGAIN; return NULL; + case 0: + croak("Sequence (? incomplete"); + break; default: --regparse; while (*regparse && strchr("iogcmsx", *regparse)) @@ -136,6 +136,35 @@ regcppop() return input; } +/* After a successful match in WHILEM, we want to restore paren matches + * that have been overwritten by a failed match attempt in the process + * of reaching this success. We do this by restoring regstartp[i] + * wherever regendp[i] has not changed; if OPEN is changed to modify + * regendp[], the '== endp' test below should be changed to match. + * This corrects the error of: + * 0 > length [ "foobar" =~ / ( (foo) | (bar) )* /x ]->[1] + */ +static void +regcppartblow() +{ + dTHR; + I32 i = SSPOPINT; + U32 paren; + char *startp; + char *endp; + assert(i == SAVEt_REGCONTEXT); + i = SSPOPINT; + /* input, lastparen, size */ + SSPOPPTR; SSPOPINT; SSPOPINT; + for (i -= 3; i > 0; i -= 3) { + paren = (U32)SSPOPINT; + startp = (char *) SSPOPPTR; + endp = (char *) SSPOPPTR; + if (paren <= *reglastparen && regendp[paren] == endp) + regstartp[paren] = startp; + } +} + #define regcpblow(cp) leave_scope(cp) /* @@ -947,7 +976,7 @@ char *prog; ln = regcc->cur; cp = regcppush(cc->parenfloor); if (regmatch(cc->next)) { - regcpblow(cp); + regcppartblow(cp); sayYES; /* All done. */ } regcppop(); @@ -963,7 +992,7 @@ char *prog; cc->lastloc = locinput; cp = regcppush(cc->parenfloor); if (regmatch(cc->scan)) { - regcpblow(cp); + regcppartblow(cp); sayYES; } regcppop(); @@ -978,7 +1007,7 @@ char *prog; cc->cur = n; cc->lastloc = locinput; if (regmatch(cc->scan)) { - regcpblow(cp); + regcppartblow(cp); sayYES; } regcppop(); /* Restore some previous $<digit>s? */ @@ -579,7 +579,8 @@ I32 base; case SAVEt_CLEARSV: ptr = (void*)&curpad[SSPOPLONG]; sv = *(SV**)ptr; - if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */ + /* Can clear pad variable in place? */ + if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) croak("panic: leave_scope clearsv"); @@ -1513,8 +1513,10 @@ SV *sv; { I32 numtype = looks_like_number(sv); +#ifdef HAS_STRTOUL if (numtype == 1) - return atol(SvPVX(sv)); + return strtoul(SvPVX(sv), Null(char**), 10); +#endif if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); @@ -1728,12 +1730,17 @@ STRLEN *lp; #endif } else if (SvIOKp(sv)) { + U32 oldIOK = SvIOK(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpvf(sv, "%Vd", SvIVX(sv)); + sv_setpviv(sv, SvIVX(sv)); errno = olderrno; s = SvEND(sv); + if (oldIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); } else { dTHR; @@ -2720,21 +2727,10 @@ register SV *sv; --sv_objcount; /* XXX Might want something more general */ } if (SvREFCNT(sv)) { - SV *ret; - if ( perldb - && (ret = perl_get_sv("DB::ret", FALSE)) - && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) { - /* Debugger is prone to dangling references. */ - SvRV(ret) = 0; - SvROK_off(ret); - SvREFCNT(sv) = 0; - } - else { if (in_clean_objs) croak("DESTROY created new reference to dead object"); /* DESTROY gave object new lease on life */ return; - } } } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) @@ -4148,6 +4144,42 @@ SV *sv; return FALSE; } +void +sv_setpviv(sv, iv) +SV *sv; +IV iv; +{ + STRLEN len; + char buf[TYPE_DIGITS(UV)]; + char *ptr = buf + sizeof(buf); + int sign; + UV uv; + char *p; + int i; + + sv_setpvn(sv, "", 0); + if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + len = (buf + sizeof(buf)) - ptr; + /* taking advantage of SvCUR(sv) == 0 */ + SvGROW(sv, sign + len + 1); + p = SvPVX(sv); + if (sign) + *p++ = '-'; + memcpy(p, ptr, len); + p += len; + *p = '\0'; + SvCUR(sv) = p - SvPVX(sv); +} + #ifdef I_STDARG void sv_setpvf(SV *sv, const char* pat, ...) @@ -4594,6 +4626,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) } if (fill == '0') *--eptr = fill; + if (left) + *--eptr = '-'; if (plus) *--eptr = plus; if (alt) @@ -4659,7 +4693,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) need = (have > width ? have : width); gap = need - have; - SvGROW(sv, SvLEN(sv) + need); + SvGROW(sv, SvCUR(sv) + need + 1); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) @@ -101,7 +101,7 @@ while ($test = shift) { } } else { $next += 1; - print "FAILED on test $next\n"; + print "FAILED at test $next\n"; $bad = $bad + 1; $_ = $test; if (/^base/) { @@ -113,6 +113,7 @@ while ($test = shift) { if ($bad == 0) { if ($ok) { print "All tests successful.\n"; + # XXX add mention of 'perlbug -ok' ? } else { die "FAILED--no tests were run for some reason.\n"; } diff --git a/t/base/lex.t b/t/base/lex.t index 7e0ca70fd7..6d03b9e8df 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..26\n"; +print "1..27\n"; $x = 'x'; @@ -103,3 +103,5 @@ print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n"; 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"); diff --git a/t/comp/cmdopt.t b/t/comp/cmdopt.t index 4d5c78a4cb..3f701a456a 100755 --- a/t/comp/cmdopt.t +++ b/t/comp/cmdopt.t @@ -2,7 +2,7 @@ # $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $ -print "1..40\n"; +print "1..44\n"; # test the optimization of constants @@ -81,3 +81,10 @@ if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} $x = ''; if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} + +$x = 1; +if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";} +if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";} +$x = ''; +if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";} +if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";} diff --git a/t/comp/term.t b/t/comp/term.t index b248e9b161..eb9968003e 100755 --- a/t/comp/term.t +++ b/t/comp/term.t @@ -4,7 +4,7 @@ # tests that aren't important enough for base.term -print "1..14\n"; +print "1..22\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; @@ -33,3 +33,38 @@ if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";} if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";} $" = '::'; if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";} + +# test if C<eval "{...}"> distinguishes between blocks and hashrefs + +$a = "{ '\\'' , 'foo' }"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";} + +$a = "{ '\\\\\\'abc' => 'foo' }"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";} + +$a = "{'a\\\n\\'b','foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";} + +$a = "{'\\\\\\'\\\\'=>'foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";} + +$a = "{q,a'b,,'foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";} + +$a = "{q[[']]=>'foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";} + +# needs disambiguation if first term is a variable +$a = "+{ \$a , 'foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} + +$a = "+{ \$a=>'foo'}"; +$a = eval $a; +if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} diff --git a/t/lib/complex.t b/t/lib/complex.t index 80a56254ba..c05f40f2d3 100755 --- a/t/lib/complex.t +++ b/t/lib/complex.t @@ -62,6 +62,21 @@ sub test_dbz { } } +# test the logofzeros + +sub test_loz { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# '$op'\n";)); + push(@script, qq(eval '$op';)); + push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);)); + push(@script, qq(print "ok $test\n";)); + } +} + +my $minusi = cplx(0, -1); + test_dbz( 'i/0', # 'tan(pi/2)', # may succeed thanks to floating point inaccuracies @@ -69,9 +84,11 @@ test_dbz( 'csc(0)', 'cot(0)', 'atan(i)', + 'atan($minusi)', 'asec(0)', 'acsc(0)', 'acot(i)', + 'acot($minusi)', # 'tanh(pi/2)', # may succeed thanks to floating point inaccuracies # 'sech(pi/2)', # may succeed thanks to floating point inaccuracies 'csch(0)', @@ -79,7 +96,12 @@ test_dbz( 'atanh(1)', 'asech(0)', 'acsch(0)', - 'acoth(1)' + 'acoth(1)', + ); + +test_loz( + 'atanh(-1)', + 'acoth(-1)', ); # test the 0**0 @@ -342,7 +364,7 @@ __END__ |'z - ~z':'2*i*Im(z)' |'z * ~z':'abs(z) * abs(z)' -{ (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } +{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } |'(root(z, 4))[1] ** 4':'z' |'(root(z, 5))[3] ** 5':'z' @@ -350,8 +372,8 @@ __END__ |'abs(z)':'r' |'acot(z)':'acotan(z)' |'acsc(z)':'acosec(z)' -|'acsc(z)':'asin(1 / z)' -|'asec(z)':'acos(1 / z)' +|'abs(acsc(z))':'abs(asin(1 / z))' +|'abs(asec(z))':'abs(acos(1 / z))' |'cbrt(z)':'cbrt(r) * exp(i * t/3)' |'cos(acos(z))':'z' |'cos(z) ** 2 + sin(z) ** 2':1 @@ -409,144 +431,346 @@ __END__ |'atanh(tanh(z))':'z' &sin +(-2.0,0):( -0.90929742682568, 0 ) +(-1.0,0):( -0.84147098480790, 0 ) +(-0.5,0):( -0.47942553860420, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.47942553860420, 0 ) +( 1.0,0):( 0.84147098480790, 0 ) +( 2.0,0):( 0.90929742682568, 0 ) + +&sin ( 2, 3):( 9.15449914691143, -4.16890695996656) (-2, 3):( -9.15449914691143, -4.16890695996656) (-2,-3):( -9.15449914691143, 4.16890695996656) ( 2,-3):( 9.15449914691143, 4.16890695996656) &cos +(-2.0,0):( -0.41614683654714, 0 ) +(-1.0,0):( 0.54030230586814, 0 ) +(-0.5,0):( 0.87758256189037, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 0.87758256189037, 0 ) +( 1.0,0):( 0.54030230586814, 0 ) +( 2.0,0):( -0.41614683654714, 0 ) + +&cos ( 2, 3):( -4.18962569096881, -9.10922789375534) (-2, 3):( -4.18962569096881, 9.10922789375534) (-2,-3):( -4.18962569096881, -9.10922789375534) ( 2,-3):( -4.18962569096881, 9.10922789375534) &tan +(-2.0,0):( 2.18503986326152, 0 ) +(-1.0,0):( -1.55740772465490, 0 ) +(-0.5,0):( -0.54630248984379, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.54630248984379, 0 ) +( 1.0,0):( 1.55740772465490, 0 ) +( 2.0,0):( -2.18503986326152, 0 ) + +&tan ( 2, 3):( -0.00376402564150, 1.00323862735361) (-2, 3):( 0.00376402564150, 1.00323862735361) (-2,-3):( 0.00376402564150, -1.00323862735361) ( 2,-3):( -0.00376402564150, -1.00323862735361) &sec +(-2.0,0):( -2.40299796172238, 0 ) +(-1.0,0):( 1.85081571768093, 0 ) +(-0.5,0):( 1.13949392732455, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 1.13949392732455, 0 ) +( 1.0,0):( 1.85081571768093, 0 ) +( 2.0,0):( -2.40299796172238, 0 ) + +&sec ( 2, 3):( -0.04167496441114, 0.09061113719624) (-2, 3):( -0.04167496441114, -0.09061113719624) (-2,-3):( -0.04167496441114, 0.09061113719624) ( 2,-3):( -0.04167496441114, -0.09061113719624) &csc +(-2.0,0):( -1.09975017029462, 0 ) +(-1.0,0):( -1.18839510577812, 0 ) +(-0.5,0):( -2.08582964293349, 0 ) +( 0.5,0):( 2.08582964293349, 0 ) +( 1.0,0):( 1.18839510577812, 0 ) +( 2.0,0):( 1.09975017029462, 0 ) + +&csc ( 2, 3):( 0.09047320975321, 0.04120098628857) (-2, 3):( -0.09047320975321, 0.04120098628857) (-2,-3):( -0.09047320975321, -0.04120098628857) ( 2,-3):( 0.09047320975321, -0.04120098628857) &cot +(-2.0,0):( 0.45765755436029, 0 ) +(-1.0,0):( -0.64209261593433, 0 ) +(-0.5,0):( -1.83048772171245, 0 ) +( 0.5,0):( 1.83048772171245, 0 ) +( 1.0,0):( 0.64209261593433, 0 ) +( 2.0,0):( -0.45765755436029, 0 ) + +&cot ( 2, 3):( -0.00373971037634, -0.99675779656936) (-2, 3):( 0.00373971037634, -0.99675779656936) (-2,-3):( 0.00373971037634, 0.99675779656936) ( 2,-3):( -0.00373971037634, 0.99675779656936) &asin +(-2.0,0):( -1.57079632679490, 1.31695789692482) +(-1.0,0):( -1.57079632679490, 0 ) +(-0.5,0):( -0.52359877559830, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.52359877559830, 0 ) +( 1.0,0):( 1.57079632679490, 0 ) +( 2.0,0):( 1.57079632679490, -1.31695789692482) + +&asin ( 2, 3):( 0.57065278432110, 1.98338702991654) (-2, 3):( -0.57065278432110, 1.98338702991654) (-2,-3):( -0.57065278432110, -1.98338702991654) ( 2,-3):( 0.57065278432110, -1.98338702991654) &acos +(-2.0,0):( 3.14159265358979, -1.31695789692482) +(-1.0,0):( 3.14159265358979, 0 ) +(-0.5,0):( 2.09439510239320, 0 ) +( 0.0,0):( 1.57079632679490, 0 ) +( 0.5,0):( 1.04719755119660, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0 , 1.31695789692482) + +&acos ( 2, 3):( 1.00014354247380, -1.98338702991654) (-2, 3):( 2.14144911111600, -1.98338702991654) (-2,-3):( 2.14144911111600, 1.98338702991654) ( 2,-3):( 1.00014354247380, 1.98338702991654) &atan +(-2.0,0):( -1.10714871779409, 0 ) +(-1.0,0):( -0.78539816339745, 0 ) +(-0.5,0):( -0.46364760900081, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.46364760900081, 0 ) +( 1.0,0):( 0.78539816339745, 0 ) +( 2.0,0):( 1.10714871779409, 0 ) + +&atan ( 2, 3):( 1.40992104959658, 0.22907268296854) (-2, 3):( -1.40992104959658, 0.22907268296854) (-2,-3):( -1.40992104959658, -0.22907268296854) ( 2,-3):( 1.40992104959658, -0.22907268296854) &asec +(-2.0,0):( 2.09439510239320, 0 ) +(-1.0,0):( 3.14159265358979, 0 ) +(-0.5,0):( 3.14159265358979, -1.31695789692482) +( 0.5,0):( 0 , 1.31695789692482) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 1.04719755119660, 0 ) + +&asec ( 2, 3):( 1.42041072246703, 0.23133469857397) (-2, 3):( 1.72118193112276, 0.23133469857397) (-2,-3):( 1.72118193112276, -0.23133469857397) ( 2,-3):( 1.42041072246703, -0.23133469857397) &acsc +(-2.0,0):( -0.52359877559830, 0 ) +(-1.0,0):( -1.57079632679490, 0 ) +(-0.5,0):( -1.57079632679490, 1.31695789692482) +( 0.5,0):( 1.57079632679490, -1.31695789692482) +( 1.0,0):( 1.57079632679490, 0 ) +( 2.0,0):( 0.52359877559830, 0 ) + +&acsc ( 2, 3):( 0.15038560432786, -0.23133469857397) (-2, 3):( -0.15038560432786, -0.23133469857397) (-2,-3):( -0.15038560432786, 0.23133469857397) ( 2,-3):( 0.15038560432786, 0.23133469857397) &acot +(-2.0,0):( -0.46364760900081, 0 ) +(-1.0,0):( -0.78539816339745, 0 ) +(-0.5,0):( -1.10714871779409, 0 ) +( 0.5,0):( 1.10714871779409, 0 ) +( 1.0,0):( 0.78539816339745, 0 ) +( 2.0,0):( 0.46364760900081, 0 ) + +&acot ( 2, 3):( 0.16087527719832, -0.22907268296854) (-2, 3):( -0.16087527719832, -0.22907268296854) (-2,-3):( -0.16087527719832, 0.22907268296854) ( 2,-3):( 0.16087527719832, 0.22907268296854) &sinh +(-2.0,0):( -3.62686040784702, 0 ) +(-1.0,0):( -1.17520119364380, 0 ) +(-0.5,0):( -0.52109530549375, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.52109530549375, 0 ) +( 1.0,0):( 1.17520119364380, 0 ) +( 2.0,0):( 3.62686040784702, 0 ) + +&sinh ( 2, 3):( -3.59056458998578, 0.53092108624852) (-2, 3):( 3.59056458998578, 0.53092108624852) (-2,-3):( 3.59056458998578, -0.53092108624852) ( 2,-3):( -3.59056458998578, -0.53092108624852) &cosh +(-2.0,0):( 3.76219569108363, 0 ) +(-1.0,0):( 1.54308063481524, 0 ) +(-0.5,0):( 1.12762596520638, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 1.12762596520638, 0 ) +( 1.0,0):( 1.54308063481524, 0 ) +( 2.0,0):( 3.76219569108363, 0 ) + +&cosh ( 2, 3):( -3.72454550491532, 0.51182256998738) (-2, 3):( -3.72454550491532, -0.51182256998738) (-2,-3):( -3.72454550491532, 0.51182256998738) ( 2,-3):( -3.72454550491532, -0.51182256998738) &tanh +(-2.0,0):( -0.96402758007582, 0 ) +(-1.0,0):( -0.76159415595576, 0 ) +(-0.5,0):( -0.46211715726001, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.46211715726001, 0 ) +( 1.0,0):( 0.76159415595576, 0 ) +( 2.0,0):( 0.96402758007582, 0 ) + +&tanh ( 2, 3):( 0.96538587902213, -0.00988437503832) (-2, 3):( -0.96538587902213, -0.00988437503832) (-2,-3):( -0.96538587902213, 0.00988437503832) ( 2,-3):( 0.96538587902213, 0.00988437503832) &sech +(-2.0,0):( 0.26580222883408, 0 ) +(-1.0,0):( 0.64805427366389, 0 ) +(-0.5,0):( 0.88681888397007, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 0.88681888397007, 0 ) +( 1.0,0):( 0.64805427366389, 0 ) +( 2.0,0):( 0.26580222883408, 0 ) + +&sech ( 2, 3):( -0.26351297515839, -0.03621163655877) (-2, 3):( -0.26351297515839, 0.03621163655877) (-2,-3):( -0.26351297515839, -0.03621163655877) ( 2,-3):( -0.26351297515839, 0.03621163655877) &csch +(-2.0,0):( -0.27572056477178, 0 ) +(-1.0,0):( -0.85091812823932, 0 ) +(-0.5,0):( -1.91903475133494, 0 ) +( 0.5,0):( 1.91903475133494, 0 ) +( 1.0,0):( 0.85091812823932, 0 ) +( 2.0,0):( 0.27572056477178, 0 ) + +&csch ( 2, 3):( -0.27254866146294, -0.04030057885689) (-2, 3):( 0.27254866146294, -0.04030057885689) (-2,-3):( 0.27254866146294, 0.04030057885689) ( 2,-3):( -0.27254866146294, 0.04030057885689) &coth +(-2.0,0):( -1.03731472072755, 0 ) +(-1.0,0):( -1.31303528549933, 0 ) +(-0.5,0):( -2.16395341373865, 0 ) +( 0.5,0):( 2.16395341373865, 0 ) +( 1.0,0):( 1.31303528549933, 0 ) +( 2.0,0):( 1.03731472072755, 0 ) + +&coth ( 2, 3):( 1.03574663776500, 0.01060478347034) (-2, 3):( -1.03574663776500, 0.01060478347034) (-2,-3):( -1.03574663776500, -0.01060478347034) ( 2,-3):( 1.03574663776500, -0.01060478347034) &asinh +(-2.0,0):( -1.44363547517881, 0 ) +(-1.0,0):( -0.88137358701954, 0 ) +(-0.5,0):( -0.48121182505960, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.48121182505960, 0 ) +( 1.0,0):( 0.88137358701954, 0 ) +( 2.0,0):( 1.44363547517881, 0 ) + +&asinh ( 2, 3):( 1.96863792579310, 0.96465850440760) (-2, 3):( -1.96863792579310, 0.96465850440761) (-2,-3):( -1.96863792579310, -0.96465850440761) ( 2,-3):( 1.96863792579310, -0.96465850440760) &acosh +(-2.0,0):( -1.31695789692482, 3.14159265358979) +(-1.0,0):( 0, 3.14159265358979) +(-0.5,0):( 0, 2.09439510239320) +( 0.0,0):( 0, 1.57079632679490) +( 0.5,0):( 0, 1.04719755119660) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 1.31695789692482, 0 ) + +&acosh ( 2, 3):( 1.98338702991654, 1.00014354247380) (-2, 3):( -1.98338702991653, -2.14144911111600) (-2,-3):( -1.98338702991653, 2.14144911111600) ( 2,-3):( 1.98338702991654, -1.00014354247380) &atanh +(-2.0,0):( -0.54930614433405, 1.57079632679490) +(-0.5,0):( -0.54930614433405, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.54930614433405, 0 ) +( 2.0,0):( 0.54930614433405, 1.57079632679490) + +&atanh ( 2, 3):( 0.14694666622553, 1.33897252229449) (-2, 3):( -0.14694666622553, 1.33897252229449) (-2,-3):( -0.14694666622553, -1.33897252229449) ( 2,-3):( 0.14694666622553, -1.33897252229449) &asech +(-2.0,0):( 0 , 2.09439510239320) +(-1.0,0):( 0 , 3.14159265358979) +(-0.5,0):( -1.31695789692482, 3.14159265358979) +( 0.5,0):( 1.31695789692482, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0 , 1.04719755119660) + +&asech ( 2, 3):( 0.23133469857397, -1.42041072246703) (-2, 3):( -0.23133469857397, 1.72118193112276) (-2,-3):( -0.23133469857397, -1.72118193112276) ( 2,-3):( 0.23133469857397, 1.42041072246703) &acsch +(-2.0,0):( -0.48121182505960, 0 ) +(-1.0,0):( -0.88137358701954, 0 ) +(-0.5,0):( -1.44363547517881, 0 ) +( 0.5,0):( 1.44363547517881, 0 ) +( 1.0,0):( 0.88137358701954, 0 ) +( 2.0,0):( 0.48121182505960, 0 ) + +&acsch ( 2, 3):( 0.15735549884499, -0.22996290237721) (-2, 3):( -0.15735549884499, -0.22996290237721) (-2,-3):( -0.15735549884499, 0.22996290237721) ( 2,-3):( 0.15735549884499, 0.22996290237721) &acoth +(-2.0,0):( -0.54930614433405, 0 ) +(-0.5,0):( -0.54930614433405, 1.57079632679490) +( 0.5,0):( 0.54930614433405, 1.57079632679490) +( 2.0,0):( 0.54930614433405, 0 ) + +&acoth ( 2, 3):( 0.14694666622553, -0.23182380450040) (-2, 3):( -0.14694666622553, -0.23182380450040) (-2,-3):( -0.14694666622553, 0.23182380450040) diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index c90c9d7d98..bebb63df8d 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..92\n"; +print "1..102\n"; sub ok { @@ -91,7 +91,7 @@ ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); +ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; @@ -513,4 +513,96 @@ unlink $Dfile1 ; unlink $filename ; } + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(93, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(94, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(97, $@ eq "") ; + main::ok(98, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(99, $@ eq "" ) ; + main::ok(100, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(101, $@ eq "") ; + main::ok(102, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 471ee0283b..9df918cce5 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..52\n"; +print "1..62\n"; sub ok { @@ -70,7 +70,7 @@ ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); +ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; @@ -320,4 +320,95 @@ untie %h ; unlink $filename ; } +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + +} + exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 338edd0db5..9950741ffe 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -41,7 +41,7 @@ sub bad_one EOM } -print "1..56\n"; +print "1..66\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -93,7 +93,7 @@ my $X ; my @h ; ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; -ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos') ; #my $l = @h ; @@ -198,6 +198,17 @@ untie(@h); unlink $Dfile; +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + + { # Check bval defaults to \n @@ -208,7 +219,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; ok(49, $x eq "abc\ndef\n\nghi\n") ; } @@ -224,7 +235,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; @@ -243,7 +254,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; @@ -263,7 +274,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; @@ -280,4 +291,95 @@ unlink $Dfile; unlink $filename ; } +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(57, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + + main::ok(58, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(59, $@ eq "") ; + main::ok(60, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(63, $@ eq "" ) ; + main::ok(64, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(65, $@ eq "") ; + main::ok(66, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "recno.tmp" ; + +} + exit ; diff --git a/t/lib/filehand.t b/t/lib/filehand.t index c23a7e0475..cedc2ebcb8 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -43,7 +43,7 @@ print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer); print "ok 5\n"; $fh->seek(0,0); -print "not " unless (<$fh> eq $buffer); +print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer); print "ok 6\n"; $fh->seek(0,2); diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index a0f081fa1e..37660c26c6 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -13,7 +13,7 @@ BEGIN { use GDBM_File; -print "1..12\n"; +print "1..20\n"; unlink <Op.dbmx*>; @@ -121,3 +121,86 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use GDBM_File; + @ISA=qw(GDBM_File); + @EXPORT = @GDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; + main::ok(17, $@ eq "" ) ; + main::ok(18, $ret == 1) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(19, $@ eq "") ; + main::ok(20, $ret eq "[[5]]") ; + + unlink "SubDB.pm", <dbhash.tmp*> ; + +} diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index b10d7c26d4..27f3ec5066 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -16,7 +16,7 @@ require NDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..12\n"; +print "1..18\n"; unlink <Op.dbmx*>; @@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use NDBM_File; + @ISA=qw(NDBM_File); + @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", <dbhash.tmp*> ; + +} diff --git a/t/lib/odbm.t b/t/lib/odbm.t index 06ba844029..6cfefdaee5 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -16,7 +16,7 @@ require ODBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..12\n"; +print "1..18\n"; unlink <Op.dbmx*>; @@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use ODBM_File; + @ISA=qw(ODBM_File); + @EXPORT = @ODBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", <dbhash.tmp*> ; + +} diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index 9928847b94..c8ae09285b 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -15,7 +15,7 @@ require SDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..12\n"; +print "1..18\n"; unlink <Op.dbmx*>; @@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use SDBM_File; + @ISA=qw(SDBM_File); + @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", <dbhash.tmp*> ; + +} diff --git a/t/op/local.t b/t/op/local.t index 043201072d..f527c9c9a9 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -2,7 +2,7 @@ # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ -print "1..20\n"; +print "1..23\n"; sub foo { local($a, $b) = @_; @@ -43,3 +43,12 @@ $d{''} = "ok 18\n"; print &foo2("ok 11\n","ok 12\n"); print $a,@b,@c,%d,$x,$y; + +eval 'local($$e)'; +print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n"; + +eval 'local(@$e)'; +print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; + +eval 'local(%$e)'; +print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; diff --git a/t/op/magic.t b/t/op/magic.t index 49caab56b4..bddcd27679 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -46,9 +46,9 @@ else { $| = 1; # command buffering - $SIG{"INT"} = "ok3"; kill "INT",$$; - $SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n"; - $SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n"; + $SIG{"INT"} = "ok3"; kill "INT",$$; + $SIG{"INT"} = "IGNORE"; kill "INT",$$; print "ok 4\n"; + $SIG{"INT"} = "DEFAULT"; kill "INT",$$; print "not ok\n"; sub ok3 { if (($x = pop(@_)) eq "INT") { @@ -106,24 +106,41 @@ ok 17, $@ eq "foo\n", $@; ok 18, $$ > 0, $$; # $^X and $0 -if ($Is_MSWin32) { - for (19 .. 25) { ok $_, 1 } -} -else { +{ if ($^O eq 'qnx') { chomp($wd = `pwd`); } else { $wd = '.'; } + my $perl = "$wd/perl"; + my $headmaybe = ''; + my $tailmaybe = ''; $script = "$wd/show-shebang"; - $s1 = $s2 = "\$^X is $wd/perl, \$0 is $script\n"; + if ($Is_MSWin32) { + chomp($wd = `cd`); + $perl = "$wd\\perl.exe"; + $script = "$wd\\show-shebang.bat"; + $headmaybe = <<EOH ; +\@rem =' +\@echo off +$perl -x \%0 +goto endofperl +\@rem '; +EOH + $tailmaybe = <<EOT ; + +__END__ +:endofperl +EOT + } + $s1 = $s2 = "\$^X is $perl, \$0 is $script\n"; if ($^O eq 'os2') { # Started by ksh, which adds suffixes '.exe' and '.' to perl and script $s2 = "\$^X is $wd/perl.exe, \$0 is $script.\n"; } ok 19, open(SCRIPT, ">$script"), $!; - ok 20, print(SCRIPT <<EOB . <<'EOF'), $!; + ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; #!$wd/perl EOB print "\$^X is $^X, \$0 is $0\n"; @@ -132,10 +149,10 @@ EOF ok 22, chmod(0755, $script), $!; $_ = `$script`; s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl - s{is perl}{is $wd/perl}; # for systems where $^X is only a basename - ok 23, $_ eq $s2, ":$_:!=:$s2:"; - $_ = `$wd/perl $script`; - ok 24, $_ eq $s1, ":$_:!=:$s1: after `$wd/perl $script`"; + s{is perl}{is $perl}; # for systems where $^X is only a basename + ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:"; + $_ = `$perl $script`; + ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`"; ok 25, unlink($script), $!; } diff --git a/t/op/pack.t b/t/op/pack.t index 223b9d169b..f9a89a3ec0 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..25\n"; +print "1..29\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 @@ -76,3 +76,27 @@ print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; +# +# test the "p" template + +# literals +print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n"); + +# scalars +print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); + +# temps +sub foo { my $a = "a"; return $a . $a++ . $a++ } +{ + local $^W = 1; + my $last = $test; + local $SIG{__WARN__} = sub { + print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ + }; + my $junk = pack("p", &foo); + print "not ok ", $test++, "\n" if $last == $test; +} + +# undef should give null pointer +print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); + diff --git a/t/op/re_tests b/t/op/re_tests index 77d97e2aeb..ce4c5a51a2 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -42,9 +42,9 @@ a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- -a[b-a] - c - - -a[]b - c - - -a[ - c - - +a[b-a] - c - /a[b-a]/: invalid [] range in regexp +a[]b - c - /a[]b/: unmatched [] in regexp +a[ - c - /a[/: unmatched [] in regexp a] a] y $& a] a[]]b a]b y $& a]b a[^bc]d aed y $& aed @@ -92,21 +92,21 @@ a[\S]b a-b y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -*a - c - - -(*)b - c - - +*a - c - /*a/: ?+*{} follows nothing in regexp +(*)b - c - /(*)b/: ?+*{} follows nothing in regexp $b b n - - -a\ - c - - +a\ - c - Search pattern not terminated a\(b a(b y $&-$1 a(b- a\(*b ab y $& ab a\(*b a((b y $& a((b a\\b a\b y $& a\b -abc) - c - - -(abc - c - - +abc) - c - /abc)/: unmatched () in regexp +(abc - c - /(abc/: unmatched () in regexp ((a)) abc y $&-$1-$2 a-a-a (a)b(c) abc y $&-$1-$2 abc-a-c a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc -a** - c - - +a** - c - /a**/: nested *?+ in regexp a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b){0,} ab y $&-$1 ab-b @@ -114,7 +114,7 @@ a.+?c abcabc y $& abc (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a -)( - c - - +)( - c - /)(/: unmatched () in regexp [^ab]* cde y $& cde abc n - - a* y $& @@ -205,9 +205,9 @@ a[-]?c ac y $& ac 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- -'a[b-a]'i - c - - -'a[]b'i - c - - -'a['i - c - - +'a[b-a]'i - c - /a[b-a]/: invalid [] range in regexp +'a[]b'i - c - /a[]b/: unmatched [] in regexp +'a['i - c - /a[/: unmatched [] in regexp 'a]'i A] y $& A] 'a[]]b'i A]B y $& A]B 'a[^bc]d'i AED y $& AED @@ -219,21 +219,21 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'*a'i - c - - -'(*)b'i - c - - +'*a'i - c - /*a/: ?+*{} follows nothing in regexp +'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp '$b'i B n - - -'a\'i - c - - +'a\'i - c - Search pattern not terminated 'a\(b'i A(B y $&-$1 A(B- 'a\(*b'i AB y $& AB 'a\(*b'i A((B y $& A((B 'a\\b'i A\B y $& A\B -'abc)'i - c - - -'(abc'i - c - - +'abc)'i - c - /abc)/: unmatched () in regexp +'(abc'i - c - /(abc/: unmatched () in regexp '((a))'i ABC y $&-$1-$2 A-A-A '(a)b(c)'i ABC y $&-$1-$2 ABC-A-C 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - - +'a**'i - c - /a**/: nested *?+ in regexp 'a.+?c'i ABCABC y $& ABC 'a.*?c'i ABCABC y $& ABC 'a.{0,5}?c'i ABCABC y $& ABC @@ -244,7 +244,7 @@ a[-]?c ac y $& ac '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A '(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - - +')('i - c - /)(/: unmatched () in regexp '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -304,3 +304,5 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce '([a-z]+)\s\1'i Aa aa y $&-$1 Aa aa-Aa '([a-z]+)\s\1'i Ab ab y $&-$1 Ab ab-Ab foo\w*\d{4}baz foobar1234baz y $& foobar1234baz +((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar +:(?: - c - Sequence (? incomplete diff --git a/t/op/ref.t b/t/op/ref.t index 4e024d8828..e83a04fbee 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..47\n"; +print "1..50\n"; # Test glob operations. @@ -207,12 +207,28 @@ print @baa == 3 ? "ok 42\n" : "not ok 42\n"; print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; +# test for proper destruction of lexical objects + +sub larry::DESTROY { print "# larry\nok 45\n"; } +sub curly::DESTROY { print "# curly\nok 46\n"; } +sub moe::DESTROY { print "# moe\nok 47\n"; } + +{ + my ($joe, @curly, %larry); + my $moe = bless \$joe, 'moe'; + my $curly = bless \@curly, 'curly'; + my $larry = bless \%larry, 'larry'; + print "# leaving block\n"; +} + +print "# left block\n"; + package FINALE; { - $ref3 = bless ["ok 47\n"]; # package destruction - my $ref2 = bless ["ok 46\n"]; # lexical destruction - local $ref1 = bless ["ok 45\n"]; # dynamic destruction + $ref3 = bless ["ok 50\n"]; # package destruction + my $ref2 = bless ["ok 49\n"]; # lexical destruction + local $ref1 = bless ["ok 48\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/regexp.t b/t/op/regexp.t index ea470f879b..803f1d0dab 100755 --- a/t/op/regexp.t +++ b/t/op/regexp.t @@ -14,7 +14,7 @@ # n expect no match # c expect an error # -# Columns 4 and 5 are used only of column 3 contains C<y>. +# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. # # Column 4 contains a string, usually C<$&>. # @@ -35,11 +35,11 @@ TEST: while (<TESTS>) { ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_); $input = join(':',$pat,$subject,$result,$repl,$expect); - $pat = "'$pat'" unless $pat =~ /^'/; + $pat = "'$pat'" unless $pat =~ /^[:']/; for $study ("", "study \$subject") { eval "$study; \$match = (\$subject =~ m$pat); \$got = \"$repl\";"; if ($result eq 'c') { - if ($@ eq '') { print "not ok $.\n"; next TEST } + if ($@ !~ m!^\Q$expect!) { print "not ok $.\n"; next TEST } last; # no need to study a syntax error } elsif ($result eq 'n') { diff --git a/t/op/stat.t b/t/op/stat.t index aea5cc147c..97f8192885 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -75,8 +75,8 @@ if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";} eval '$> = $olduid;'; # switch uid back (may not be implemented) print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid); -if ($Is_MSWin32 or ! -x 'Op.stat.tmp') {print "ok 11\n";} -else {print "not ok 11\n";} +if (! -x 'Op.stat.tmp') {print "ok 11\n";} +else {print "not ok 11\n";} foreach ((12,13,14,15,16,17)) { print "ok $_\n"; #deleted tests diff --git a/t/op/substr.t b/t/op/substr.t index e34216fb17..bb655f5209 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -2,25 +2,40 @@ # $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $ -print "1..25\n"; +print "1..97\n"; + +#P = start of string Q = start of substr R = end of substr S = end of string $a = 'abcdefxyz'; +BEGIN { $^W = 1 }; + +$SIG{__WARN__} = sub { + if ($_[0] =~ /^substr outside of string/) { + $w++; + } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { + $w += 2; + } else { + warn @_; + } +}; -print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); -print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); -print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); -print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n"); -print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); -print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); +sub fail { !defined(shift) && $w-- }; + +print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S +print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S +print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S +print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S $[ = 1; -print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); -print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); -print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); -print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n"); -print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n"); -print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); +print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S +print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S +print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S +print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S $[ = 0; @@ -28,7 +43,6 @@ substr($a,3,3) = 'XYZ'; print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; substr($a,0,2) = ''; print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; -y/a/a/; substr($a,0,0) = 'ab'; print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; substr($a,0,0) = '12345678'; @@ -42,9 +56,103 @@ print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; $a = 'abcdefxyz'; -print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); -print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); -print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n"); +print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S +print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S +print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q +print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S +print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S +print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S +print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S + +$a = '54321'; + +print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S +print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S +print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S +print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S +print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S +print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S +print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S +print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S +print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S +print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S +print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S +print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S +print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q +print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q +print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q +print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R + +print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S +print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S +print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S +print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R +print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S +print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S +print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S +print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R +print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S +print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S +print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R +print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S +print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S +print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S +print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S +print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R +print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S +print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S +print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S +print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R +print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S +print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S +print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S +print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S +print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S +print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S + +$a = ''; + +print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S +print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S +print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R +print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R +print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S +print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S + + +print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S +print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S +print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S +print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S +print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S +print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q +print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R +print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R +print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q + + +my $a = 'zxcvbnm'; +substr($a,2,0) = ''; +print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; +substr($a,7,0) = ''; +print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; +substr($a,5,0) = ''; +print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; +substr($a,0,2) = 'pq'; +print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; +substr($a,2,0) = 'r'; +print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; +substr($a,8,0) = 'asd'; +print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; +substr($a,0,2) = 'iop'; +print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; +substr($a,0,5) = 'fgh'; +print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; +substr($a,3,5) = 'jkl'; +print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; +substr($a,3,2) = '1234'; +print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; + # with lexicals (and in re-entered scopes) for (0,1) { @@ -52,17 +160,21 @@ for (0,1) { unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; - print $txt eq "FoX" ? "ok 23\n" : "not ok 23\n"; + print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; } else { + local $^W = 0; # because of (spurious?) "uninitialised value" substr($txt, 0, 1) = "X"; - print $txt eq "X" ? "ok 24\n" : "not ok 24\n"; + print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; } } -# coersion of references +# coercion of references { my $s = []; substr($s, 0, 1) = 'Foo'; - print substr($s,0,7) eq "FooRRAY" ? "ok 25\n" : "not ok 25\n"; + print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; } + +# check no spurious warnings +print $w ? "not ok 97\n" : "ok 97\n"; diff --git a/t/op/universal.t b/t/op/universal.t index 03f0fbdd9d..bd6c73afe9 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -3,7 +3,12 @@ # check UNIVERSAL # -print "1..11\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +print "1..72\n"; $a = {}; bless $a, "Bob"; @@ -21,35 +26,71 @@ package Alice; sub drink {} sub new { bless {} } +$Alice::VERSION = 2.718; + package main; + +my $i = 2; +sub test { print "not " unless shift; print "ok $i\n"; $i++; } + $a = new Alice; -print "not " unless $a->isa("Alice"); -print "ok 2\n"; +test $a->isa("Alice"); -print "not " unless $a->isa("Bob"); -print "ok 3\n"; +test $a->isa("Bob"); + +test $a->isa("Female"); + +test $a->isa("Human"); + +test ! $a->isa("Male"); + +test $a->can("drink"); + +test $a->can("eat"); + +test ! $a->can("sleep"); + +my $b = 'abc'; +my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); +my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); +for ($p=0; $p < @refs; $p++) { + for ($q=0; $q < @vals; $q++) { + test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); + }; +}; + +test ! UNIVERSAL::can(23, "can"); + +test $a->can("VERSION"); + +test $a->can("can"); +test ! $a->can("export_tags"); # a method in Exporter + +test (eval { $a->VERSION }) == 2.718; + +test ! (eval { $a->VERSION(2.719) }) && + $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; + +test (eval { $a->VERSION(2.718) }) && ! $@; -print "not " unless $a->isa("Female"); -print "ok 4\n"; +my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +test $subs eq "VERSION can isa"; -print "not " unless $a->isa("Human"); -print "ok 5\n"; +test $a->isa("UNIVERSAL"); -print "not " if $a->isa("Male"); -print "ok 6\n"; +# now use UNIVERSAL.pm and see what changes +eval "use UNIVERSAL"; -print "not " unless $a->can("drink"); -print "ok 7\n"; +test $a->isa("UNIVERSAL"); -print "not " unless $a->can("eat"); -print "ok 8\n"; +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +# XXX import being here is really a bug +test $sub2 eq "VERSION can import isa"; -print "not " if $a->can("sleep"); -print "ok 9\n"; +eval 'sub UNIVERSAL::sleep {}'; +test $a->can("sleep"); -print "not " unless UNIVERSAL::isa([], "ARRAY"); -print "ok 10\n"; +test ! UNIVERSAL::can($b, "can"); -print "not " unless UNIVERSAL::isa({}, "HASH"); -print "ok 11\n"; +test ! $a->can("export_tags"); # a method in Exporter diff --git a/t/pragma/locale.t b/t/pragma/locale.t index d4b73b8f91..e1ec5a800f 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -395,10 +395,14 @@ for (map { chr } 0..255) { print "ok 101\n"; # The @Locale should be internally consistent. +# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> +# for inventing a way to test for ordering consistency +# without requiring any particular order. +# ++$jhi;#@iki.fi print "# testing 102\n"; { - my ($from, $to, $lesser, $greater, @test, %test, $test); + my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); for (0..9) { # Select a slice. @@ -410,24 +414,25 @@ print "# testing 102\n"; $from++; $to++; $to = $#Locale if ($to > $#Locale); $greater = join('', @Locale[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). @test = ( - 'not ($lesser lt $greater)', # 0 - 'not ($lesser le $greater)', # 1 - 'not ($lesser ne $greater)', # 2 - ' ($lesser eq $greater)', # 3 - ' ($lesser ge $greater)', # 4 - ' ($lesser gt $greater)', # 5 - ' ($greater lt $lesser )', # 6 - ' ($greater le $lesser )', # 7 - 'not ($greater ne $lesser )', # 8 - ' ($greater eq $lesser )', # 9 - 'not ($greater ge $lesser )', # 10 - 'not ($greater gt $lesser )', # 11 - # Well, these two are sort of redundant - # because @Locale was derived using cmp. - 'not (($lesser cmp $greater) == -1)', # 12 - 'not (($greater cmp $lesser ) == 1)' # 13 + $no.' ($lesser lt $greater)', # 0 + $no.' ($lesser le $greater)', # 1 + $no.' ($lesser ne $greater)', # 2 + $yes.' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser gt $greater)', # 5 + $yes.' ($greater lt $lesser )', # 6 + $yes.' ($greater le $lesser )', # 7 + $no.' ($greater ne $lesser )', # 8 + $yes.' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + $no.' ($greater gt $lesser )', # 11 + 'not (($lesser cmp $greater) == -$sign)' # 12 ); @test{@test} = 0 x @test; $test = 0; @@ -436,6 +441,8 @@ print "# testing 102\n"; print "# failed 102 at:\n"; print "# lesser = '$lesser'\n"; print "# greater = '$greater'\n"; + print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; + print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; print "# (greater) from = $from, to = $to\n"; for my $ti (@test) { printf("# %-40s %-4s", $ti, @@ -452,3 +459,5 @@ print "# testing 102\n"; } } print "ok 102\n"; + +# eof @@ -372,7 +372,9 @@ register char *s; return s; if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) { if (minus_n || minus_p) { - sv_setpv(linestr,minus_p ? ";}continue{print" : ""); + sv_setpv(linestr,minus_p ? + ";}continue{print or die qq(-p destination: $!\\n)" : + ""); sv_catpv(linestr,";}"); minus_n = minus_p = 0; } @@ -386,6 +388,8 @@ register char *s; PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); + if (e_fp == rsfp) + e_fp = Nullfp; rsfp = Nullfp; return s; } @@ -393,7 +397,7 @@ register char *s; bufend = s + SvCUR(linestr); s = bufptr; incline(s); - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV *sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); @@ -1532,7 +1536,7 @@ yylex() sv_catpv(linestr, "\n"); oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV *sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); @@ -1551,6 +1555,8 @@ yylex() PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); + if (e_fp == rsfp) + e_fp = Nullfp; rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { @@ -1580,7 +1586,7 @@ yylex() incline(s); } while (doextract); oldoldbufptr = oldbufptr = bufptr = linestart = s; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV *sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); @@ -1705,7 +1711,7 @@ yylex() } d = moreswitches(d); } while (d); - if (perldb && !oldpdb || + if (PERLDB_LINE && !oldpdb || ( minus_n || minus_p ) && !(oldn || oldp) ) /* if we have already added "LINE: while (<>) {", we must not do it again */ @@ -1714,7 +1720,7 @@ yylex() oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); preambled = FALSE; - if (perldb) + if (PERLDB_LINE) (void)gv_fetchfile(origfilename); goto retry; } @@ -1998,19 +2004,73 @@ yylex() s = skipspace(s); if (*s == '}') OPERATOR(HASHBRACK); - if (isALPHA(*s)) { - for (t = s; t < bufend && isALNUM(*t); t++) ; + /* This hack serves to disambiguate a pair of curlies + * as being a block or an anon hash. Normally, expectation + * determines that, but in cases where we're not in a + * position to expect anything in particular (like inside + * eval"") we have to resolve the ambiguity. This code + * covers the case where the first term in the curlies is a + * quoted string. Most other cases need to be explicitly + * disambiguated by prepending a `+' before the opening + * curly in order to force resolution as an anon hash. + * + * XXX should probably propagate the outer expectation + * into eval"" to rely less on this hack, but that could + * potentially break current behavior of eval"". + * GSAR 97-07-21 + */ + t = s; + if (*s == '\'' || *s == '"' || *s == '`') { + /* common case: get past first string, handling escapes */ + for (t++; t < bufend && *t != *s;) + if (*t++ == '\\' && (*t == '\\' || *t == *s)) + t++; + t++; } - else if (*s == '\'' || *s == '"') { - t = strchr(s+1,*s); - if (!t++) - t = s; + else if (*s == 'q') { + if (++t < bufend + && (!isALNUM(*t) + || ((*t == 'q' || *t == 'x') && ++t < bufend + && !isALNUM(*t)))) { + char *tmps; + char open, close, term; + I32 brackets = 1; + + while (t < bufend && isSPACE(*t)) + t++; + term = *t; + open = term; + if (term && (tmps = strchr("([{< )]}> )]}>",term))) + term = tmps[5]; + close = term; + if (open == close) + for (t++; t < bufend; t++) { + if (*t == '\\' && t+1 < bufend && open != '\\') + t++; + else if (*t == open) + break; + } + else + for (t++; t < bufend; t++) { + if (*t == '\\' && t+1 < bufend) + t++; + else if (*t == close && --brackets <= 0) + break; + else if (*t == open) + brackets++; + } + } + t++; + } + else if (isALPHA(*s)) { + for (t++; t < bufend && isALNUM(*t); t++) ; } - else - t = s; while (t < bufend && isSPACE(*t)) t++; - if ((*t == ',' && !isLOWER(*s)) || (*t == '=' && t[1] == '>')) + /* if comma follows first term, call it an anon hash */ + /* XXX it could be a comma expression with loop modifiers */ + if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) + || (*t == '=' && t[1] == '>'))) OPERATOR(HASHBRACK); if (expect == XREF) expect = XTERM; @@ -2268,8 +2328,23 @@ yylex() else if (isIDFIRST(*s)) { char tmpbuf[sizeof tokenbuf]; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if (keyword(tmpbuf, len)) - expect = XTERM; /* e.g. print $fh length() */ + if (tmp = keyword(tmpbuf, len)) { + /* binary operators exclude handle interpretations */ + switch (tmp) { + case -KEY_x: + case -KEY_eq: + case -KEY_ne: + case -KEY_gt: + case -KEY_lt: + case -KEY_ge: + case -KEY_le: + case -KEY_cmp: + break; + default: + expect = XTERM; /* e.g. print $fh length() */ + break; + } + } else { GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); if (gv && GvCVu(gv)) @@ -4320,7 +4395,7 @@ char *what; } if (*w) for (; *w && isSPACE(*w); w++) ; - if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */ + if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) @@ -4486,7 +4561,7 @@ I32 ck_uni; lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; - if (dowarn && + if (dowarn && lex_state == LEX_NORMAL && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); @@ -4804,7 +4879,7 @@ register char *s; missingterm(tokenbuf); } curcop->cop_line++; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV *sv = NEWSV(88,0); sv_upgrade(sv, SVt_PVMG); @@ -4905,8 +4980,13 @@ char *start; register char *to; I32 brackets = 1; - if (isSPACE(*s)) - s = skipspace(s); + if (isSPACE(*s)) { + /* "#" is allowed as delimiter if on same line */ + while (*s == ' ' || *s == '\t') + s++; + if (isSPACE(*s)) + s = skipspace(s); + } CLINE; term = *s; multi_start = curcop->cop_line; @@ -4942,13 +5022,13 @@ char *start; for (; s < bufend; s++,to++) { if (*s == '\n' && !rsfp) curcop->cop_line++; - if (*s == '\\' && s+1 < bufend && term != '\\') { - if (s[1] == term) + if (*s == '\\' && s+1 < bufend) { + if ((s[1] == multi_open) || (s[1] == multi_close)) s++; else *to++ = *s++; } - else if (*s == term && --brackets <= 0) + else if (*s == multi_close && --brackets <= 0) break; else if (*s == multi_open) brackets++; @@ -4967,7 +5047,7 @@ char *start; return Nullch; } curcop->cop_line++; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV *sv = NEWSV(88,0); sv_upgrade(sv, SVt_PVMG); diff --git a/universal.c b/universal.c index b082da67ff..d6689f8acf 100644 --- a/universal.c +++ b/universal.c @@ -71,7 +71,7 @@ int level; } } - return &sv_no; + return boolSV(strEQ(name, "UNIVERSAL")); } bool @@ -2099,11 +2099,17 @@ int flags; } } #ifdef HAS_WAITPID +# ifdef HAS_WAITPID_RUNTIME + if (!HAS_WAITPID_RUNTIME) + goto hard_way; +# endif return waitpid(pid,statusp,flags); -#else -#ifdef HAS_WAIT4 +#endif +#if !defined(HAS_WAITPID) && defined(HAS_WAIT4) return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); -#else +#endif +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) + hard_way: { I32 result; if (flags) @@ -2117,7 +2123,6 @@ int flags; return result; } #endif -#endif } #endif /* !DOSISH */ diff --git a/utils/Makefile b/utils/Makefile index 9dd24642f2..3c343c82b7 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -12,19 +12,19 @@ all: $(plextract) $(plextract): $(PERL) -I../lib $@.PL -c2ph: c2ph.PL +c2ph: c2ph.PL ../config.sh -h2ph: h2ph.PL +h2ph: h2ph.PL ../config.sh -h2xs: h2xs.PL +h2xs: h2xs.PL ../config.sh -perlbug: perlbug.PL +perlbug: perlbug.PL ../config.sh ../patchlevel.h -perldoc: perldoc.PL +perldoc: perldoc.PL ../config.sh -pl2pm: pl2pm.PL +pl2pm: pl2pm.PL ../config.sh -splain: splain.PL ../lib/diagnostics.pm +splain: splain.PL ../config.sh ../lib/diagnostics.pm clean: diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 3471300c87..d48571f00f 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -116,10 +116,10 @@ foreach $file (@ARGV) { if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}';\n"; + "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; } else { - print OUT "sub $name $proto\{\n ${args}eval \"$new\";\n}\n"; + print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; } %curargs = (); } @@ -129,10 +129,10 @@ foreach $file (@ARGV) { $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name () {",$new,";}';\n"; + print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } else { - print OUT $t,"sub $name () {",$new,";}\n"; + print OUT $t,"unless(defined(\&$name) {\nsub $name () {",$new,";}\n}\n"; } } } diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 00fad311d2..6b670fc46b 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -9,6 +9,7 @@ use File::Basename qw(&basename &dirname); # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. +# $perlpath # 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. @@ -18,6 +19,33 @@ $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; +# extract patchlevel.h information + +open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!"; + +my $patchlevel_date = (stat PATCH_LEVEL)[9]; + +while (<PATCH_LEVEL>) { + last if index($_, "static\tchar\t*local_patches[] = {") >= 0; +}; + +my $patches; +while (<PATCH_LEVEL>) { + last if /^}/; + chomp; + s/^\s+,?"?//; + s/"?,?$//; + s/(['\\])/\\$1/g; + $patches .= "'$_',\n" unless $_ eq 'NULL'; +}; + +close PATCH_LEVEL; + +# TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is +# used, compare $Config::config_sh with the stored version. If they differ then +# append a list of individual differences to the bug report. + + print "Extracting $file (with variable substitutions)\n"; # In this section, perl variables will be expanded during extraction. @@ -27,6 +55,9 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; + +my \$patchlevel_date = $patchlevel_date; +my \@patches = ( $patches ); !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -49,7 +80,7 @@ use strict; sub paraprint; -my($Version) = "1.17"; +my($Version) = "1.19"; # 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. @@ -69,19 +100,26 @@ my($Version) = "1.17"; # Also report selected environment variables. # Changed in 1.16 to include @INC, and allow user to re-edit if no changes. # Changed in 1.17 Win32 support added. GSAR 97-04-12 +# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18 +# Changed in 1.19 '-ok' default not '-v' +# add local patch information +# warn on '-ok' if this is an old system; add '-okay' -# TODO: Allow the user to re-name the file on mail failure, and +# TODO: - Allow the user to re-name the file on mail failure, and # 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, - $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP); + $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); 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 @@ -90,7 +128,7 @@ EOF die "\n"; } -if($::opt_d or !-t STDOUT) { Dump(*STDOUT); exit; } +if(!-t STDOUT) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile; @@ -106,7 +144,7 @@ sub Init { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; - getopts("dhva:s:b:f:r:e:SCc:t"); + getopts("dhva:s:b:f:r:e:SCc:to:"); # This comment is needed to notify metaconfig that we are @@ -117,6 +155,7 @@ sub Init { # perlbug address $perlbug = 'perlbug@perl.com'; + # Test address $testaddress = 'perlbug-test@perl.com'; @@ -124,13 +163,6 @@ sub Init { # Target address $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); - # 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.) - $cc = ($::opt_C ? "" : ( - $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by} - )); - # Users address, used in message and in Reply-To header $from = $::opt_r || ""; @@ -154,9 +186,52 @@ sub Init { ($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\". +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 $] on" + ." $::Config{'osname'} $::Config{'osvers'} $subject"; + $::opt_b = 1; + $body = "Perl reported to build OK on this system.\n"; + $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'} : getpwuid($<)); + $me = ( $Is_MSWin32 + ? $ENV{'USERNAME'} + : ( $^O eq 'os2' + ? $ENV{'USER'} || $ENV{'LOGNAME'} + : eval { getpwuid($<) }) ); # May be missing } @@ -164,7 +239,7 @@ sub Init { sub Query { # Explain what perlbug is - + if ( ! $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 @@ -178,6 +253,7 @@ 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 @@ -239,6 +315,7 @@ EOF $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'}); if( $guess ) { + if ( ! $ok ) { paraprint <<EOF; @@ -246,6 +323,7 @@ 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; @@ -254,12 +332,20 @@ your full internet e-mail address here. EOF } - print "Your address [$guess]: "; - - $from = <>; - chop $from; - - if($from eq "") { $from = $guess } + + if ( $ok && $guess ne '' ) { + # use it + $from = $guess; + } + else { + # verify it + print "Your address [$guess]: "; + + $from = <>; + chop $from; + + if($from eq "") { $from = $guess } + } } @@ -350,8 +436,9 @@ EOF { my($dir) = ($Is_VMS ? 'sys$scratch:' : - ($Is_MSWin32 and $ENV{'TEMP'} ? $ENV{'TEMP'} : '/tmp/')); + (($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} : '/tmp/')); $filename = "bugrep0$$"; + $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; $filename++ while -e "$dir$filename"; $filename = "$dir$filename"; } @@ -400,8 +487,10 @@ EOF open(REP,">$filename"); + my $reptype = $ok ? "success" : "bug"; + print REP <<EOF; -This is a bug report for perl from $from, +This is a $reptype report for perl from $from, generated with the help of perlbug $Version running under perl $]. EOF @@ -458,15 +547,11 @@ EOF print OUT Config::myconfig; - 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"; - } - } + if (@patches) { + print OUT join "\n\t", "\nLocally applied patches:", @patches; + print OUT "\n"; + }; + print OUT <<EOF; --- @@ -490,6 +575,15 @@ EOF 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 Edit { @@ -543,6 +637,7 @@ EOF } } + return if $ok; # Check that we have a report that has some, eh, report in it. my $unseen = 0; @@ -680,6 +775,7 @@ sub Send { $fh->close; + print "\nMessage sent.\n"; } else { if ($Is_VMS) { if ( ($address =~ /@/ and $address !~ /^\w+%"/) or @@ -701,8 +797,20 @@ sub Send { { $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" and 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 @@ -713,7 +821,7 @@ been left in the file `$filename'. EOF - open(SENDMAIL,"|$sendmail -t"); + 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; @@ -723,12 +831,14 @@ EOF while(<REP>) { print SENDMAIL $_ } close(REP); - close(SENDMAIL); + if (close(SENDMAIL)) { + print "\nMessage sent.\n"; + } else { + warn "\nSendmail returned status '",$?>>8,"'\n"; + } } } - - print "\nMessage sent.\n"; 1 while unlink($filename); # remove all versions under VMS @@ -767,6 +877,9 @@ Options: -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). + -okay As -ok but also report on older systems. -h Print this help message. EOF @@ -802,6 +915,8 @@ 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> ]> + =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that @@ -906,8 +1021,8 @@ produced by running C<perl -V> (note the uppercase V). Having done your bit, please be prepared to wait, to be told the bug is in your code, or even to get no reply at all. The perl maintainers -are busy folks, so if your problem is a small one or if it is -difficult to understand, they may not respond with a personal reply. +are busy folks, so if your problem is a small one or if it is difficult +to understand or already known, they may not respond with a personal reply. If it is important to you that your bug be fixed, do monitor the C<Changes> file in any development releases since the time you submitted the bug, and encourage the maintainers with kind words (but never any @@ -955,6 +1070,19 @@ prepared message. Prints a brief summary of the options. +=item B<-ok> + +Report successful build on this system to perl porters. Forces B<-S> +and B<-C>. Forces and supplies values for B<-s> and B<-b>. 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<-okay> + +As B<-ok> except it will report on older systems. + =item B<-r> Your return address. The program will ask you to confirm its default @@ -983,8 +1111,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>), and Nathan Torkington -(E<lt>gnat@frii.comE<gt>). +(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>). =head1 SEE ALSO diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 129d985882..38ea9ee5ca 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -56,6 +56,8 @@ EOF } use Getopt::Std; +use Config '%Config'; + $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; @@ -132,17 +134,16 @@ sub containspod { return 0; } - sub minus_f_nocase { +sub minus_f_nocase { my($file) = @_; + # on a case-forgiving file system we can simply use -f $file + if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') { + return ( -f $file ) ? $file : ''; + } local *DIR; local($")="/"; my(@p,$p,$cip); foreach $p (split(/\//, $file)){ - if (($Is_VMS or $Is_MSWin32 or $^O eq 'os2') and not scalar @p) { - # VMSish filesystems don't begin at '/' - push(@p,$p); - next; - } if (-d ("@p/$p")){ push @p, $p; } elsif (-f ("@p/$p")) { @@ -152,7 +153,6 @@ sub containspod { my $lcp = lc $p; opendir DIR, "@p"; while ($cip=readdir(DIR)) { - $cip =~ s/\.dir$// if $Is_VMS; if (lc $cip eq $lcp){ $found++; last; @@ -184,7 +184,9 @@ sub containspod { or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) or ( $Is_VMS and $ret = minus_f_nocase "$dir/$s.com" and containspod($ret)) - or ( $Is_MSWin32 and + or ( $^O eq 'os2' and + $ret = minus_f_nocase "$dir/$s.cmd" and containspod($ret)) + or ( ($Is_MSWin32 or $^O eq 'os2') and $ret = minus_f_nocase "$dir/$s.bat" and containspod($ret)) or ( $ret = minus_f_nocase "$dir/pod/$s.pod") or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) @@ -215,10 +217,9 @@ foreach (@pages) { for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { push(@searchdirs,$trn); } - } elsif ($Is_MSWin32) { - push(@searchdirs, grep(-d, split(';', $ENV{'PATH'}))); } else { - push(@searchdirs, grep(-d, split(':', $ENV{'PATH'}))); + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); } @files= searchfor(0,$_,@searchdirs); } @@ -259,7 +260,12 @@ if ($Is_MSWin32) { $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; push @pagers, qw( most more less type/page ); } else { - $tmp = "/tmp/perldoc1.$$"; + if ($^O eq 'os2') { + require POSIX; + $tmp = POSIX::tmpnam(); + } else { + $tmp = "/tmp/perldoc1.$$"; + } push @pagers, qw( more less pg view cat ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } diff --git a/vms/config.vms b/vms/config.vms index cba33616d7..d6453ba34a 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -112,7 +112,11 @@ * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ -#undef HAS_BCMP /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_BCMP /**/ +#else +#undef HAS_BCMP /*config-skip*/ +#endif #include <string.h> /* Check whether new DECC has #defined bcopy and bzero */ /* HAS_BCOPY: @@ -233,7 +237,11 @@ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ -#undef HAS_GETTIMEOFDAY /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_GETTIMEOFDAY /**/ +#else +#undef HAS_GETTIMEOFDAY /*config-skip*/ +#endif #ifdef HAS_GETTIMEOFDAY # define Timeval struct timeval /*config-skip*/ #endif @@ -256,7 +264,11 @@ * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ -#undef HAS_UNAME /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_UNAME /**/ +#else +#undef HAS_UNAME /*config-skip*/ +#endif /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is @@ -492,7 +504,11 @@ * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ -#undef HAS_SIGACTION /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_SIGACTION /**/ +#else +#undef HAS_SIGACTION /*config-skip*/ +#endif /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring @@ -622,7 +638,11 @@ * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ -#undef HAS_TRUNCATE /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_TRUNCATE /**/ +#else +#undef HAS_TRUNCATE /*config-skip*/ +#endif /* HAS_VFORK: @@ -664,7 +684,11 @@ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ -#undef HAS_WAIT4 /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_WAIT4 /**/ +#else +#undef HAS_WAIT4 /*config-skip*/ +#endif /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is @@ -962,10 +986,10 @@ * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ -#if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) -#define Select_fd_set_t fd_set * /* config-skip */ +#if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && defined(DECCRTL_SOCKETS) +#define Select_fd_set_t fd_set * /**/ #else -#define Select_fd_set_t int * /**/ +#define Select_fd_set_t int * /* config-skip */ #endif /* STDCHAR: @@ -1161,7 +1185,11 @@ * functions are available for string searching. */ #define HAS_STRCHR /**/ -#undef HAS_INDEX /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_INDEX /**/ +#else +#undef HAS_INDEX /*config-skip*/ +#endif /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is @@ -1347,9 +1375,17 @@ * corresponds to the 0 at the end of the sig_num list. * See SIG_NUM and SIG_MAX. */ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ + "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\ + "ABRT","USR1","USR2","SPARE18","SPARE19","CHLD","CONT",\ + "STOP","TSTP","TTIN","TTOU","DEBUG","SPARE27","SPARE28",\ + "SPARE29","SPARE30","SPARE31","SPARE32","RTMIN","RTMAX",0 /**/ +#else #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\ - "ABRT","USR1","USR2",0 + "ABRT","USR1","USR2",0 /*config-skip*/ +#endif /* SIG_NUM: * This symbol contains a list of signal number, in the same order as the @@ -1364,7 +1400,11 @@ * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ -#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,64,0 /**/ +#else +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /*config-skip*/ +#endif /* Mode_t: * This symbol holds the type used to declare file modes @@ -1598,8 +1638,13 @@ * to determine file-system related limits and options associated * with a given open file descriptor. */ -#undef HAS_PATHCONF /**/ -#undef HAS_FPATHCONF /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_PATHCONF /**/ +#define HAS_FPATHCONF /**/ +#else +#undef HAS_PATHCONF /*config-skip*/ +#undef HAS_FPATHCONF /*config-skip*/ +#endif /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available @@ -1658,7 +1703,11 @@ * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ -#undef HAS_SYSCONF /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_SYSCONF /**/ +#else +#undef HAS_SYSCONF /*config-skip*/ +#endif /* Gconvert: * This preprocessor macro is defined to convert a floating point @@ -1718,7 +1767,11 @@ * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. */ -#undef HAS_SIGSETJMP /**/ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#define HAS_SIGSETJMP /**/ +#else +#undef HAS_SIGSETJMP /*config-skip*/ +#endif #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf /* config-skip */ #define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */ diff --git a/vms/descrip.mms b/vms/descrip.mms index 15a297b838..7681f21586 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -24,7 +24,10 @@ #: To each of the above, add /Macro="__AXP__=1" if building on an AXP, #: /Macro="__DEBUG__=1" to build a debug version #: (i.e. VMS debugger, not perl -D), and -#: /Macro="SOCKET=1" to include socket support. +#: /Macro="SOCKETSHR_SOCKETS=1" to include +#: SOCKETSHR socket support. +#: /Macro="DECC_SOCKETS=1" to include UCX (or +#: compatible) socket support # # tidy -- purge files generated by executing this file # clean -- remove all intermediate (e.g. object files, C files generated @@ -67,6 +70,25 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) # Updated by fndvers.com -- do not edit by hand PERL_VERSION = 5_004 # +.ifdef DECC_SOCKETS +SOCKET=1 +.endif + +.ifdef SOCKETSHR_SOCKETS +SOCKET=1 +.endif + +# If they defined SOCKET but didn't choose a stack, default to SOCKETSHR +.ifdef DECC_SOCKETS +.else +.ifdef SOCKETSHR_SOCKETS +.else +.ifdef SOCKET +SOCKETSHR_SOCKETS=1 +.endif +.endif +.endif + ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] ARCHCORE = [.lib.$(ARCH).$(PERL_VERSION).CORE] @@ -78,6 +100,9 @@ ARCHAUTO = [.lib.$(ARCH).$(PERL_VERSION).auto] PIPES_BROKEN = 1 .endif +.ifdef __DEBUG__ +NOX2P = 1 +.endif #: >>>>>Compiler-specific options <<<<< .ifdef GNUC @@ -142,7 +167,7 @@ DBGLINKFLAGS = /Trace/Debug/Map/Full/Cross DBG = DBG .else DBGCCFLAGS = /NoList -DBGLINKFLAGS = /NoMap +DBGLINKFLAGS = /NoTrace/NoMap DBG = .endif @@ -150,8 +175,13 @@ DBG = #: By default, used SOCKETSHR library; see ReadMe.VMS #: for information on changing socket support .ifdef SOCKET +.ifdef DECC_SOCKETS +SOCKDEF = ,VMS_DO_SOCKETS,DECCRTL_SOCKETS +SOCKLIB = +.else SOCKDEF = ,VMS_DO_SOCKETS SOCKLIB = SocketShr/Share +.endif # N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent # copies live in [.vms], and the `clean' target will delete copies of # these files in the current default directory. @@ -272,8 +302,13 @@ LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Fi utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com utils2 = [.lib]splain.com [.utils]pl2pm.com +.ifdef NOX2P +all : base extras archcorefiles preplibrary perlpods + @ $(NOOP) +.else all : base extras x2p archcorefiles preplibrary perlpods @ $(NOOP) +.endif base : miniperl perl @ $(NOOP) extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @@ -330,7 +365,7 @@ $(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE) .endif $(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts - Link /NoTrace$(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option + Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option # The following files are built in one go by gen_shrfls.pl: # perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 62b06fe9ed..6201a42dc6 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -25,11 +25,33 @@ foreach $test (@tests) { } } -print +(rmsexpand('[]') eq "\U$ENV{DEFAULT}" ? 'ok ' : 'not ok '),++$idx,"\n"; -print +(rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here" ? - 'ok ' : 'not ok '),++$idx,"\n"; -print +(rmsexpand('from.here','cant:[get.there];2') eq - 'cant:[get.there]from.here;2' ? 'ok ' : 'not ok '),++$idx,"\n"; +if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; } +else { + print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'), + "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n"; + print "# Note: This failure may have occurred because your default device\n"; + print "# was set using a non-concealed logical name. If this is the case,\n"; + print "# you will need to determine by inspection that the two resultant\n"; + print "# file specifications shwn above are in fact equivalent.\n"; +} +if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") { + print 'ok ', ++$idx, "\n"; +} +else { + print 'not ok ', ++$idx, ": rmsexpand('from.here') = |", + rmsexpand('from.here'), + "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n"; + print "# Note: This failure may have occurred because your default device\n"; + print "# was set using a non-concealed logical name. If this is the case,\n"; + print "# you will need to determine by inspection that the two resultant\n"; + print "# file specifications shwn above are in fact equivalent.\n"; +} +if (rmsexpand('from.here','cant:[get.there];2') eq + 'cant:[get.there]from.here;2') { print 'ok ',++$idx,"\n"; } +else { + print 'not ok ', ++$idx, ': expected |cant:[get.there]from.here;2|, got |', + rmsexpand('from.here','cant:[get.there];2'),"|\n"; +} __DATA__ diff --git a/vms/sockadapt.c b/vms/sockadapt.c index e4c3dad213..b63e4c937b 100644 --- a/vms/sockadapt.c +++ b/vms/sockadapt.c @@ -29,18 +29,25 @@ # define __sockadapt_my_name_t char * #endif +/* We have these on VMS 7.0 and above, or on Dec C 5.6 if it's providing */ +/* the 7.0 DECC RTL */ +#if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS)) +#else void setnetent(int stayopen) { croak("Function \"setnetent\" not implemented in this version of perl"); } void endnetent() { croak("Function \"endnetent\" not implemented in this version of perl"); } +#endif #if defined(DECCRTL_SOCKETS) /* Use builtin socket interface in DECCRTL and * UCX emulation in whatever TCP/IP stack is present. */ +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#else void sethostent(int stayopen) { croak("Function \"sethostent\" not implemented in this version of perl"); } @@ -67,6 +74,7 @@ void endnetent() { croak("Function \"getservent\" not implemented in this version of perl"); return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */ } +#endif #else /* Work around things missing/broken in SOCKETSHR. */ diff --git a/vms/sockadapt.h b/vms/sockadapt.h index f24faea475..7f9150a579 100644 --- a/vms/sockadapt.h +++ b/vms/sockadapt.h @@ -24,6 +24,8 @@ # include <inet.h> # include <in.h> # include <netdb.h> +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +#else void sethostent(int); void endhostent(void); void setnetent(int); @@ -32,6 +34,7 @@ void endprotoent(void); void setservent(int); void endservent(void); +#endif # if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) # define Sock_size_t unsigned int # endif diff --git a/vms/test.com b/vms/test.com index 50a98caf00..114cb24a40 100644 --- a/vms/test.com +++ b/vms/test.com @@ -6,6 +6,7 @@ $ $! A little basic setup $ On Error Then Goto wrapup $ olddef = F$Environment("Default") +$ oldmsg = F$Environment("Message") $ If F$Search("t.dir").nes."" $ Then $ Set Default [.t] @@ -18,6 +19,7 @@ $ Write Sys$Error "Can't find test directory" $ Exit 44 $ EndIf $ EndIf +$ Set Message /Facility/Severity/Identification/Text $ $ exe = ".Exe" $ If p1.nes."" Then exe = p1 @@ -87,12 +89,12 @@ $ Deck/Dollar=$$END-OF-TEST$$ # but the tests may use other operators which don't.) use Config; -@compexcl=('cpp.t','script.t'); +@compexcl=('cpp.t'); @ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t'); @libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t', 'ndbm.t','odbm.t','open2.t','open3.t','posix.t', - 'sdbm.t','soundex.t'); + 'sdbm.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC @@ -218,4 +220,5 @@ $$END-OF-TEST$$ $ wrapup: $ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Set Default &olddef +$ Set Message 'oldmsg' $ Exit @@ -456,9 +456,9 @@ kill_file(char *name) /*}}}*/ -/*{{{int my_mkdir(char *,mode_t)*/ +/*{{{int my_mkdir(char *,Mode_t)*/ int -my_mkdir(char *dir, mode_t mode) +my_mkdir(char *dir, Mode_t mode) { STRLEN dirlen = strlen(dir); @@ -1759,7 +1759,7 @@ static int background_process(int argc, char **argv); static void pipe_and_fork(char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ -void +static void getredirection(int *ac, char ***av) /* * Process vms redirection arg's. Exit if any error is seen. @@ -2221,6 +2221,34 @@ unsigned long int flags = 17, one = 1, retsts; /*}}}*/ /***** End of code taken from Mark Pizzolato's argproc.c package *****/ + +/* OS-specific initialization at image activation (not thread startup) */ +/*{{{void vms_image_init(int *, char ***)*/ +void +vms_image_init(int *argcp, char ***argvp) +{ + unsigned long int *mask, iosb[2], i; + unsigned short int dummy; + union prvdef iprv; + struct itmlst_3 jpilist[2] = { {sizeof iprv, JPI$_IMAGPRIV, &iprv, &dummy}, + { 0, 0, 0, 0} }; + + _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); + _ckvmssts(iosb[0]); + mask = (unsigned long int *) &iprv; /* Quick change of view */; + for (i = 0; i < (sizeof iprv + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i++) { + if (mask[i]) { /* Running image installed with privs? */ + _ckvmssts(sys$setprv(0,&iprv,0,NULL)); /* Turn 'em off. */ + tainting = TRUE; + break; + } + } + getredirection(argcp,argvp); + return; +} +/*}}}*/ + + /* trim_unixpath() * Trim Unix-style prefix off filespec, so it looks like what a shell * glob expansion would return (i.e. from specified prefix on, not diff --git a/vms/vmsish.h b/vms/vmsish.h index 841b11993a..81e3764a2c 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -104,14 +104,13 @@ # define tounixpath_ts Perl_tounixpath_ts # define tovmspath Perl_tovmspath # define tovmspath_ts Perl_tovmspath_ts -# define getredirection Perl_getredirection +# define vms_image_init Perl_vms_image_init # define opendir Perl_opendir # define readdir Perl_readdir # define telldir Perl_telldir # define seekdir Perl_seekdir # define closedir Perl_closedir # define vmsreaddirversions Perl_vmsreaddirversions -# define getredirection Perl_getredirection # define my_gmtime Perl_my_gmtime # define my_localtime Perl_my_localtime # define my_time Perl_my_time @@ -226,7 +225,7 @@ #endif #define BIT_BUCKET "_NLA0:" -#define PERL_SYS_INIT(c,v) getredirection((c),(v)) +#define PERL_SYS_INIT(c,v) vms_image_init((c),(v)) #define PERL_SYS_TERM() #define dXSUB_SYS #define HAS_KILL @@ -500,7 +499,6 @@ typedef unsigned myino_t; #endif void prime_env_iter _((void)); -void getredirection _((int *, char ***)); void init_os_extras _(()); /* prototype section start marker; `typedef' passes through cpp */ typedef char __VMS_PROTOTYPES__; @@ -511,7 +509,7 @@ Pid_t my_waitpid _((Pid_t, int *, int)); char * my_gconvert _((double, int, int, char *)); int do_rmdir _((char *)); int kill_file _((char *)); -int my_mkdir _((char *, mode_t)); +int my_mkdir _((char *, Mode_t)); int my_utime _((char *, struct utimbuf *)); char * rmsexpand _((char *, char *, char *, unsigned)); char * rmsexpand_ts _((char *, char *, char *, unsigned)); @@ -527,7 +525,7 @@ char * tounixpath _((char *, char *)); char * tounixpath_ts _((char *, char *)); char * tovmspath _((char *, char *)); char * tovmspath_ts _((char *, char *)); -void getredirection _(()); +void vms_image_init _((int *, char ***)); DIR * opendir _((char *)); struct dirent * readdir _((DIR *)); long telldir _((DIR *)); diff --git a/win32/Makefile b/win32/Makefile index 8c8b1ad0bc..9e4437f853 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -122,8 +122,8 @@ GLOBEXE=..\perlglob.exe CONFIGPM=..\lib\Config.pm MINIMOD=..\lib\ExtUtils\Miniperl.pm -PL2BAT=bin\PL2BAT.BAT -GLOBBAT = perlglob.bat +PL2BAT=bin\pl2bat.pl +GLOBBAT = bin\perlglob.bat MAKE=nmake -nologo CFGSH_TMPL = config.vc @@ -277,8 +277,8 @@ $(DYNALOADER).obj : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c $(GLOBEXE): perlglob.obj $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj -perlglob.bat : ..\lib\File\DosGlob.pm $(MINIPERL) - $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(*B).bat +$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) + $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) perlglob.obj : perlglob.c @@ -294,7 +294,7 @@ config.w32 : $(CFGSH_TMPL) ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ - "cf_email=$(EMAIL)" "libs=$(LIBFILES)" \ + "cf_email=$(EMAIL)" "libs=$(LIBFILES)" "incpath=$(CCINCDIR)" \ "libpth=$(CCLIBDIR)" "libc=$(LIBC)" \ config.w32 > ..\config.sh @@ -403,6 +403,11 @@ $(SOCKET_DLL): $(SOCKET).xs $(PERLEXE) cd ..\..\win32 doc: $(PERLEXE) + cd ..\pod + $(MAKE) -f ..\win32\pod.mak checkpods pod2html pod2latex \ + pod2man pod2text + $(XCOPY) *.bat ..\win32\bin\*.* + cd ..\win32 copy ..\README.win32 ..\pod\perlwin32.pod $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \ @@ -411,10 +416,12 @@ doc: $(PERLEXE) utils: $(PERLEXE) cd ..\utils nmake PERL=$(MINIPERL) - $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph \ - h2xs perldoc pstruct + $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph + $(PERLEXE) ..\win32\$(PL2BAT) h2xs perldoc pstruct $(XCOPY) *.bat ..\win32\bin\*.* cd ..\win32 + $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ + bin\pl2bat.pl distclean: clean -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ @@ -426,6 +433,9 @@ distclean: clean $(DYNALOADER).c -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat + -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c \ + config.h.new perl95.c + -del /f bin\*.bat -rmdir /s /q ..\lib\auto -rmdir /s /q ..\lib\CORE cd $(EXTDIR) @@ -438,9 +448,8 @@ install : all doc utils $(XCOPY) $(PERLEXE) $(INST_BIN)\*.* $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* - $(XCOPY) $(GLOBBAT) $(INST_BIN)\*.* $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* - $(XCOPY) bin\*.* $(INST_BIN)\*.* + $(XCOPY) bin\*.bat $(INST_BIN)\*.* $(RCOPY) ..\lib $(INST_LIB)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* @@ -481,7 +490,8 @@ clean : -@erase $(CORE_OBJ) -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) - -@erase ..\*.obj *.obj ..\*.lib ..\*.exp + -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp + -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat -@erase *.ilk -@erase *.pdb diff --git a/win32/bin/pl2bat.bat b/win32/bin/pl2bat.bat deleted file mode 100644 index 7f5f39aa95..0000000000 --- a/win32/bin/pl2bat.bat +++ /dev/null @@ -1,54 +0,0 @@ -@rem = '--*-Perl-*-- -@echo off -perl -x -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -goto endofperl -@rem '; -#!perl -w -#line 8 -(my $head = <<'--end--') =~ s/^\t//gm; - @rem = '--*-Perl-*-- - @echo off - perl -x -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 - goto endofperl - @rem '; ---end-- -my $headlines = 2 + ($head =~ tr/\n/\n/); -my $tail = "__END__\n:endofperl\n"; - -@ARGV = ('-') unless @ARGV; - -process(@ARGV); - -sub process { - LOOP: - foreach ( @_ ) { - my $myhead = $head; - my $linedone = 0; - my $linenum = $headlines; - my $line; - open( FILE, $_ ) or die "Can't open $_: $!"; - @file = <FILE>; - foreach $line ( @file ) { - $linenum++; - if ( $line =~ /^:endofperl/) { - warn "$_ has already been converted to a batch file!\n"; - next LOOP; - } - if ( not $linedone and $line =~ /^#!.*perl/ ) { - $line .= "#line $linenum\n"; - $linedone++; - } - } - close( FILE ); - s/\.pl$//; - $_ .= '.bat' unless /\.bat$/ or /^-$/; - open( FILE, ">$_" ) or die "Can't open $_: $!"; - $myhead =~ s/perl -x/perl/ unless $linedone; - print FILE $myhead; - print FILE "#line $headlines\n" unless $linedone; - print FILE @file, $tail; - close( FILE ); - } -} -__END__ -:endofperl diff --git a/win32/bin/pl2bat.pl b/win32/bin/pl2bat.pl new file mode 100644 index 0000000000..73ae87164d --- /dev/null +++ b/win32/bin/pl2bat.pl @@ -0,0 +1,154 @@ +#!perl -w +require 5; +use Getopt::Std; + +$0 =~ s|.*[/\\]||; + +my $usage = <<EOT; +Usage: $0 [-h] [-a argstring] [-s stripsuffix] [files] + -a argstring arguments to invoke perl with in generated file + Defaults to "-x -S %0 %*" on WindowsNT, + "-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9" otherwise + -s stripsuffix strip this suffix from file before appending ".bat" + Not case-sensitive + Can be a regex if it begins with `/' + Defaults to "/\.pl/" + -h show this help +EOT + +my %OPT = (); +warn($usage), exit(0) if !getopts('ha:s:',\%OPT) or $OPT{'h'}; +$OPT{'a'} = ($^O eq 'MSWin32' and &Win32::IsWinNT + ? '-x -S %0 %*' + : '-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9') + unless exists $OPT{'a'}; +$OPT{'s'} = '.pl' unless exists $OPT{'s'}; +$OPT{'s'} = ($OPT{'s'} =~ m|^/([^/]*)| ? $1 : "\Q$OPT{'s'}\E"); + +(my $head = <<EOT) =~ s/^\t//gm; + \@rem = '--*-Perl-*-- + \@echo off + perl $OPT{'a'} + goto endofperl + \@rem '; +EOT +my $headlines = 2 + ($head =~ tr/\n/\n/); +my $tail = "__END__\n:endofperl\n"; + +@ARGV = ('-') unless @ARGV; + +process(@ARGV); + +sub process { + LOOP: + foreach ( @_ ) { + my $myhead = $head; + my $linedone = 0; + my $linenum = $headlines; + my $line; + open( FILE, $_ ) or die "$0: Can't open $_: $!"; + @file = <FILE>; + foreach $line ( @file ) { + $linenum++; + if ( $line =~ /^:endofperl/) { + warn "$0: $_ has already been converted to a batch file!\n"; + next LOOP; + } + if ( not $linedone and $line =~ /^#!.*perl/ ) { + $line .= "#line $linenum\n"; + $linedone++; + } + } + close( FILE ); + s/$OPT{'s'}$//oi; + $_ .= '.bat' unless /\.bat$/i or /^-$/; + open( FILE, ">$_" ) or die "Can't open $_: $!"; + print FILE $myhead; + print FILE "#!perl\n#line " . ($headlines+1) . "\n" unless $linedone; + print FILE @file, $tail; + close( FILE ); + } +} +__END__ + +=head1 NAME + +pl2bat - wrap perl code into a batch file + +=head1 SYNOPSIS + +B<pl2bat> [B<-h>] S<[B<-a> I<argstring>]> S<[B<-s> I<stripsuffix>]> [files] + +=head1 DESCRIPTION + +This utility converts a perl script into a batch file that can be +executed on DOS-like operating systems. + +Note that by default, the ".pl" suffix will be stripped before adding +a ".bat" suffix to the supplied file names. This can be controlled +with the C<-s> option. + +The default behavior on WindowsNT is to generate a batch file that +uses the C<%*> construct to refer to all the command line arguments +that were given to it, so you'll need to make sure that works on your +variant of the command shell. It is known to work in the cmd.exe shell +under WindowsNT. 4DOS/NT users will want to put a C<ParameterChar = *> +line in their initialization file, or execute C<setdos /p*> in +the shell startup file. On Windows95 and other platforms a nine +argument limit is imposed on command-line arguments given to the +generated batch file, since they may not support C<%*> in batch files. +This can be overridden using the C<-a> option. + +=head1 OPTIONS + +=over 8 + +=item B<-a> I<argstring> + +Arguments to invoke perl with in generated batch file. Defaults to +S<"-x -S %0 %*"> on WindowsNT, S<"-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9"> +on other platforms. + +=item B<-s> I<stripsuffix> + +Strip a suffix string from file name before appending a ".bat" +suffix. The suffix is not case-sensitive. It can be a regex if it +begins with `/' (the trailing '/' being optional. Defaults to ".pl". + +=item B<-h> + +Show command line usage. + +=back + +=head1 EXAMPLES + + C:\> pl2bat foo.pl bar.PM + [..creates foo.bat, bar.PM.bat..] + + C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM + [..creates foo.bat, bar.bat..] + + C:\> pl2bat < somefile > another.bat + + C:\> pl2bat > another.bat + print scalar reverse "rekcah lrep rehtona tsuj\n"; + ^Z + [..another.bat is now a certified japh application..] + +=head1 BUGS + +C<$0> will contain the full name, including the ".bat" suffix +when the generated batch file runs. If you don't like this, +see runperl.bat for an alternative way to invoke perl scripts. + +Default behavior is to invoke Perl with the -S flag, so Perl will +search the PATH to find the script. This may have undesirable +effects. + +=head1 SEE ALSO + +perl, perlwin32, runperl.bat + +=cut + diff --git a/win32/bin/runperl.pl b/win32/bin/runperl.pl new file mode 100644 index 0000000000..95b33f9342 --- /dev/null +++ b/win32/bin/runperl.pl @@ -0,0 +1,67 @@ +#!perl -w +$0 =~ s|\.bat||i; +unless (-f $0) { + $0 =~ s|.*[/\\]||; + for (".", split ';', $ENV{PATH}) { + $_ = "." if $_ eq ""; + $0 = "$_/$0" , goto doit if -f "$_/$0"; + } + die "`$0' not found.\n"; +} +doit: exec "perl", "-x", $0, @ARGV; +die "Failed to exec `$0': $!"; +__END__ + +=head1 NAME + +runperl.bat - "universal" batch file to run perl scripts + +=head1 SYNOPSIS + + C:\> copy runperl.bat foo.bat + C:\> foo + [..runs the perl script `foo'..] + + C:\> foo.bat + [..runs the perl script `foo'..] + + +=head1 DESCRIPTION + +This file can be copied to any file name ending in the ".bat" suffix. +When executed on a DOS-like operating system, it will invoke the perl +script of the same name, but without the ".bat" suffix. It will +look for the script in the same directory as itself, and then in +the current directory, and then search the directories in your PATH. + +It relies on the C<exec()> operator, so you will need to make sure +that works in your perl. + +This method of invoking perl scripts has some advantages over +batch-file wrappers like C<pl2bat.bat>: it avoids duplication +of all the code; it ensures C<$0> contains the same name as the +executing file, without any egregious ".bat" suffix; it allows +you to separate your perl scripts from the wrapper used to +run them; since the wrapper is generic, you can use symbolic +links to simply link to C<runperl.bat>, if you are serving your +files on a filesystem that supports that. + +On the other hand, if the batch file is invoked with the ".bat" +suffix, it does an extra C<exec()>. This may be a performance +issue. You can avoid this by running it without specifying +the ".bat" suffix. + +Perl is invoked with the -x flag, so the script must contain +a C<#!perl> line. Any flags found on that line will be honored. + +=head1 BUGS + +Perl is invoked with the -S flag, so it will search the PATH to find +the script. This may have undesirable effects. + +=head1 SEE ALSO + +perl, perlwin32, pl2bat.bat + +=cut + diff --git a/win32/bin/search.bat b/win32/bin/search.pl index 88e83e5040..b63f7353af 100644 --- a/win32/bin/search.bat +++ b/win32/bin/search.pl @@ -1,9 +1,3 @@ -@rem = '--*-Perl-*--'; -@rem = ' -@echo off -perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -goto endofperl -@rem '; #!/usr/local/bin/perl -w 'di'; 'ig00'; @@ -1869,5 +1863,3 @@ http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html .SH "LATEST SOURCE" See http://www.wg.omron.co.jp/~jfriedl/perl/index.html -__END__ -:endofperl diff --git a/win32/bin/test.bat b/win32/bin/test.bat deleted file mode 100644 index e6b7b38160..0000000000 --- a/win32/bin/test.bat +++ /dev/null @@ -1,143 +0,0 @@ -@rem = ' -@echo off -if exist perl.exe goto perlhere -echo Cannot run without perl.exe in current directory!! Did you build it? -pause -goto endofperl -:perlhere -if exist perlglob.exe goto perlglobhere -echo Cannot run without perlglob.exe in current directory!! Did you build it? -pause -goto endofperl -:perlglobhere -perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -goto endofperl -@rem '; - -#Portions (C) 1995 Microsoft Corporation. All rights reserved. -# Developed by hip communications inc., http://info.hip.com/info/ - - -# This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. - -$| = 1; - -if ($ARGV[0] eq '-v') { - $verbose = 1; - shift; -} - - -# WYT 1995-05-02 -chdir 't' if -f 't/TESTNT'; - - -if ($ARGV[0] eq '') { -# @ARGV = split(/[ \n]/, -# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); -# `ls base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t`); - -# WYT 1995-05-02 wildcard expansion, -# `perl -e "print( join( ' ', \@ARGV ) )" base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t nt/*.t`); - -# WYT 1995-06-01 removed all dependency on perlglob -# WYT 1995-11-28 hacked up to cope with braindead Win95 console. - push( @ARGV, `dir/s/b base` ); - push( @ARGV, `dir/s/b comp` ); - push( @ARGV, `dir/s/b cmd` ); - push( @ARGV, `dir/s/b io` ); - push( @ARGV, `dir/s/b op` ); - push( @ARGV, `dir/s/b lib` ); - push( @ARGV, `dir/s/b nt` ); - - grep( chomp, @ARGV ); - @ARGV = grep( /\.t$/, @ARGV ); - grep( s/.*t\\//, @ARGV ); -} - -$sharpbang = 0; - -$bad = 0; -$good = 0; -$total = @ARGV; -while ($test = shift) { - if ($test =~ /^$/) { - next; - } - $te = $test; -# chop off 't' extension - chop($te); - print "$te" . '.' x (15 - length($te)); - if ($sharpbang) { - open(results,"./$test |") || (print "can't run.\n"); - } else { - $switch = ''; -# open(results,"./perl$switch $test |") || (print "can't run.\n"); - open(results,"perl$switch $test |") || (print "can't run.\n"); - } - $ok = 0; - $next = 0; - while (<results>) { - if ($verbose) { - print $_; - } - unless (/^#/||/^$/) { - if (/^1\.\.([0-9]+)/) { - $max = $1; - $totmax += $max; - $files += 1; - $next = 1; - $ok = 1; - } else { - $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; - if (/^ok (.*)/ && $1 == $next) { - $next = $next + 1; - } else { - $ok = 0; - } - } - } - } - $next = $next - 1; - if ($ok && $next == $max) { - print "ok\n"; - $good = $good + 1; - } else { - $next += 1; - print "FAILED on test $next\n"; - $bad = $bad + 1; - $_ = $test; - if (/^base/) { - die "Failed a basic test--cannot continue.\n"; - } - } -} - -if ($bad == 0) { - if ($ok) { - print "All tests successful.\n"; - } else { - die "FAILED--no tests were run for some reason.\n"; - } -} else { - $pct = sprintf("%.2f", $good / $total * 100); - if ($bad == 1) { - warn "Failed 1 test, $pct% okay.\n"; - } else { - die "Failed $bad/$total tests, $pct% okay.\n"; - } -} - - -# WYT 1995-05-03 times not implemented. -#($user,$sys,$cuser,$csys) = times; -#print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", -# $user,$sys,$cuser,$csys,$files,$totmax); - -#`del /f Cmd_while.tmp Comp.try null 2>NULL`; - -unlink 'Cmd_while.tmp', 'Comp.try', 'null'; - -__END__ -:endofperl diff --git a/win32/bin/webget.bat b/win32/bin/webget.pl index e77bb88ced..3d72208cb2 100644 --- a/win32/bin/webget.bat +++ b/win32/bin/webget.pl @@ -1,9 +1,3 @@ -@rem = '--*-Perl-*--'; -@rem = ' -@echo off -perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -goto endofperl -@rem '; #!/usr/local/bin/perl -w #- @@ -1095,5 +1089,3 @@ sub dummy { } __END__ -__END__ -:endofperl diff --git a/win32/config.bc b/win32/config.bc index 4b148de2fc..ad76309e5d 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -58,7 +58,7 @@ byacc='byacc' byteorder='1234' c='' castflags='0' -cat='cat' +cat='type' cccdlflags='' ccdlflags=' ' cf_by='garyng' @@ -68,10 +68,10 @@ chgrp='' chmod='' chown='' clocktype='clock_t' -comm='comm' +comm='' compress='' contains='grep' -cp='cp' +cp='copy' cpio='' cpp='cpp32' cpp_stuff='42' @@ -81,7 +81,7 @@ cpprun='' cppstdin='' cryptlib='' csh='undef' -d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_Gconvert='gcvt((x),(n),(b))' d_access='define' d_alarm='undef' d_archlib='define' @@ -371,13 +371,13 @@ line='line' lint='' lkflags='' ln='' -lns='' +lns='copy' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' -ls='ls' +ls='dir' lseektype='off_t' mail='' mailx='' @@ -421,7 +421,7 @@ path_sep=';' perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' -pg='pg' +pg='' phostname='hostname' plibpth='' pmake='' @@ -432,7 +432,7 @@ prototype='define' randbits='15' ranlib='' rd_nodata='-1' -rm='rm' +rm='del' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' @@ -459,7 +459,7 @@ sockethdr='' socketlib='' sort='sort' spackage='Perl5' -spitshell='cat' +spitshell='' split='' ssizetype='int' startperl='#perl' @@ -474,11 +474,11 @@ sysman='/usr/man/man1' tail='' tar='' tbl='' -test='test' +test='' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' -tr='tr' +tr='' troff='' uidtype='uid_t' uname='uname' diff --git a/win32/config.vc b/win32/config.vc index 0219969d89..7cc91dabd3 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -58,7 +58,7 @@ byacc='byacc' byteorder='1234' c='' castflags='0' -cat='cat' +cat='type' cccdlflags='' ccdlflags=' ' cf_by='garyng' @@ -68,10 +68,10 @@ chgrp='' chmod='' chown='' clocktype='clock_t' -comm='comm' +comm='' compress='' contains='grep' -cp='cp' +cp='copy' cpio='' cpp='cpp' cpp_stuff='42' @@ -371,13 +371,13 @@ line='line' lint='' lkflags='' ln='' -lns='' +lns='copy' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' -ls='ls' +ls='dir' lseektype='off_t' mail='' mailx='' @@ -421,7 +421,7 @@ path_sep=';' perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' -pg='pg' +pg='' phostname='hostname' plibpth='' pmake='' @@ -432,7 +432,7 @@ prototype='define' randbits='15' ranlib='' rd_nodata='-1' -rm='rm' +rm='del' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' @@ -459,7 +459,7 @@ sockethdr='' socketlib='' sort='sort' spackage='Perl5' -spitshell='cat' +spitshell='' split='' ssizetype='int' startperl='#perl' @@ -474,11 +474,11 @@ sysman='/usr/man/man1' tail='' tar='' tbl='' -test='test' +test='' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' -tr='tr' +tr='' troff='' uidtype='uid_t' uname='uname' diff --git a/win32/config_H.bc b/win32/config_H.bc index 5976289777..1883e973c1 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -1511,7 +1511,7 @@ * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ -#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) +#define Gconvert(x,n,t,b) gcvt((x),(n),(b)) /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that @@ -1687,7 +1687,7 @@ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "cmd /x /c" /**/ +#define SH_PATH "cmd.exe" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of diff --git a/win32/config_H.vc b/win32/config_H.vc index ced62a11c8..36a9a5b0d4 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1687,7 +1687,7 @@ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "cmd /x /c" /**/ +#define SH_PATH "cmd.exe" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of diff --git a/win32/config_h.PL b/win32/config_h.PL index 98b474a144..5d47016dc9 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -37,7 +37,8 @@ while (<SH>) s#/[ *\*]*\*/#/**/#; if (/^\s*#define\s+ARCHLIB_EXP/) { - $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n"; + $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n" + . "#define APPLLIB_EXP (win32SiteLibPath())\t/**/\n"; } print H; } diff --git a/win32/makedef.pl b/win32/makedef.pl index 73380b4b55..b4883ccb59 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -12,7 +12,7 @@ # There is some symbol defined in global.sym and interp.sym # that does not present in the WIN32 port but there is no easy -# way to find them so I just put a exeception list here +# way to find them so I just put a exception list here my $CCTYPE = shift || "MSVC"; @@ -191,12 +191,17 @@ sub emit_symbol { chomp $symbol; if ($CCTYPE eq "BORLAND") { # workaround Borland quirk by exporting both the straight - # name and a name with leading underscore - #print "\t$symbol = _$symbol\n"; + # name and a name with leading underscore. Note the + # alias *must* come after the symbol itself, if both + # are to be exported. (Linker bug?) print "\t_$symbol\n"; + print "\t$symbol = _$symbol\n"; } else { + # for binary coexistence, export both the symbol and + # alias with leading underscore print "\t$symbol\n"; + print "\t_$symbol = $symbol\n"; } } @@ -275,6 +280,7 @@ win32_mkdir win32_rmdir win32_chdir win32_flock +win32_execvp win32_htons win32_ntohs win32_htonl @@ -317,3 +323,25 @@ win32_sethostent win32_setnetent win32_setprotoent win32_setservent +win32_getenv +win32_perror +win32_setbuf +win32_setvbuf +win32_flushall +win32_fcloseall +win32_fgets +win32_gets +win32_fgetc +win32_putc +win32_puts +win32_getchar +win32_putchar +win32_malloc +win32_calloc +win32_realloc +win32_free +win32stdio +Perl_win32_init +RunPerl +SetIOSubSystem +GetIOSubSystem diff --git a/win32/makefile.mk b/win32/makefile.mk index b91fffc187..4696dcbccf 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -176,8 +176,8 @@ GLOBEXE=..\perlglob.exe CONFIGPM=..\lib\Config.pm MINIMOD=..\lib\ExtUtils\Miniperl.pm -PL2BAT=bin\PL2BAT.BAT -GLOBBAT = perlglob.bat +PL2BAT=bin\pl2bat.pl +GLOBBAT = bin\perlglob.bat .IF "$(CCTYPE)" == "BORLAND" @@ -350,8 +350,8 @@ $(GLOBEXE): perlglob.obj $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj .ENDIF -perlglob.bat : ..\lib\File\DosGlob.pm $(MINIPERL) - $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(*B).bat +$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) + $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) perlglob.obj : perlglob.c @@ -367,7 +367,7 @@ config.w32 : $(CFGSH_TMPL) ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ - "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" \ + "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" "incpath=$(CCINCDIR)" \ "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \ config.w32 > ..\config.sh @@ -498,6 +498,9 @@ $(SOCKET_DLL): $(SOCKET).xs $(PERLEXE) cd $(EXTDIR)\$(*B) && $(MAKE) doc: $(PERLEXE) + cd ..\pod && $(MAKE) -f ..\win32\pod.mak checkpods \ + pod2html pod2latex pod2man pod2text + cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.* copy ..\README.win32 ..\pod\perlwin32.pod $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \ @@ -507,7 +510,9 @@ utils: $(PERLEXE) cd ..\utils && $(MAKE) PERL=$(MINIPERL) cd ..\utils && $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug \ pl2pm c2ph h2xs perldoc pstruct - cd ..\utils && $(XCOPY) *.bat ..\win32\bin\*.* + $(XCOPY) ..\utils\*.bat bin\*.* + $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ + bin\pl2bat.pl distclean: clean -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ @@ -519,6 +524,11 @@ distclean: clean $(DYNALOADER).c -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat + -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new +.IF "$(PERL95EXE)" != "" + -del /f perl95.c +.ENDIF + -del /f bin\*.bat -cd $(EXTDIR) && del /s *.lib *.def *.map *.bs Makefile *.obj pm_to_blib -rmdir /s /q ..\lib\auto -rmdir /s /q ..\lib\CORE @@ -531,9 +541,8 @@ install : all doc utils $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* .ENDIF $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* - $(XCOPY) $(GLOBBAT) $(INST_BIN)\*.* $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* - $(XCOPY) bin\*.* $(INST_BIN)\*.* + $(XCOPY) bin\*.bat $(INST_BIN)\*.* $(RCOPY) ..\lib $(INST_LIB)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* @@ -579,7 +588,8 @@ clean : -@erase $(CORE_OBJ) -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) - -@erase ..\*.obj *.obj ..\*.lib ..\*.exp + -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp + -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat -@erase *.ilk -@erase *.pdb diff --git a/win32/perllib.c b/win32/perllib.c index 45d64d394c..391b4d375f 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -103,284 +103,11 @@ char *staticlinkmodules[] = { EXTERN_C void boot_DynaLoader _((CV* cv)); -static -XS(w32_GetCwd) -{ - dXSARGS; - SV *sv = sv_newmortal(); - /* Make one call with zero size - return value is required size */ - DWORD len = GetCurrentDirectory((DWORD)0,NULL); - SvUPGRADE(sv,SVt_PV); - SvGROW(sv,len); - SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); - /* - * If result != 0 - * then it worked, set PV valid, - * else leave it 'undef' - */ - if (SvCUR(sv)) - SvPOK_on(sv); - EXTEND(sp,1); - ST(0) = sv; - XSRETURN(1); -} - -static -XS(w32_SetCwd) -{ - dXSARGS; - if (items != 1) - croak("usage: Win32::SetCurrentDirectory($cwd)"); - if (SetCurrentDirectory(SvPV(ST(0),na))) - XSRETURN_YES; - - XSRETURN_NO; -} - -static -XS(w32_GetNextAvailDrive) -{ - dXSARGS; - char ix = 'C'; - char root[] = "_:\\"; - while (ix <= 'Z') { - root[0] = ix++; - if (GetDriveType(root) == 1) { - root[2] = '\0'; - XSRETURN_PV(root); - } - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetLastError) -{ - dXSARGS; - XSRETURN_IV(GetLastError()); -} - -static -XS(w32_LoginName) -{ - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - /* size includes NULL */ - ST(0) = sv_2mortal(newSVpv(name,size-1)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -static -XS(w32_NodeName) -{ - dXSARGS; - char name[MAX_COMPUTERNAME_LENGTH+1]; - DWORD size = sizeof(name); - if (GetComputerName(name,&size)) { - /* size does NOT include NULL :-( */ - ST(0) = sv_2mortal(newSVpv(name,size)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - - -static -XS(w32_DomainName) -{ - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - char sid[1024]; - DWORD sidlen = sizeof(sid); - char dname[256]; - DWORD dnamelen = sizeof(dname); - SID_NAME_USE snu; - if (LookupAccountName(NULL, name, &sid, &sidlen, - dname, &dnamelen, &snu)) { - XSRETURN_PV(dname); /* all that for this */ - } - } - XSRETURN_UNDEF; -} - -static -XS(w32_FsType) -{ - dXSARGS; - char fsname[256]; - DWORD flags, filecomplen; - if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { - if (GIMME == G_ARRAY) { - XPUSHs(sv_2mortal(newSVpv(fsname,0))); - XPUSHs(sv_2mortal(newSViv(flags))); - XPUSHs(sv_2mortal(newSViv(filecomplen))); - PUTBACK; - return; - } - XSRETURN_PV(fsname); - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetOSVersion) -{ - dXSARGS; - OSVERSIONINFO osver; - - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if (GetVersionEx(&osver)) { - XPUSHs(newSVpv(osver.szCSDVersion, 0)); - XPUSHs(newSViv(osver.dwMajorVersion)); - XPUSHs(newSViv(osver.dwMinorVersion)); - XPUSHs(newSViv(osver.dwBuildNumber)); - XPUSHs(newSViv(osver.dwPlatformId)); - PUTBACK; - return; - } - XSRETURN_UNDEF; -} - -static -XS(w32_IsWinNT) -{ - dXSARGS; - XSRETURN_IV(IsWinNT()); -} - -static -XS(w32_IsWin95) -{ - dXSARGS; - XSRETURN_IV(IsWin95()); -} - -static -XS(w32_FormatMessage) -{ - dXSARGS; - DWORD source = 0; - char msgbuf[1024]; - - if (items != 1) - croak("usage: Win32::FormatMessage($errno)"); - - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, - &source, SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - XSRETURN_PV(msgbuf); - - XSRETURN_UNDEF; -} - -static -XS(w32_Spawn) -{ - dXSARGS; - char *cmd, *args; - PROCESS_INFORMATION stProcInfo; - STARTUPINFO stStartInfo; - BOOL bSuccess = FALSE; - - if(items != 3) - croak("usage: Win32::Spawn($cmdName, $args, $PID)"); - - cmd = SvPV(ST(0),na); - args = SvPV(ST(1), na); - - memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ - stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ - stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ - stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ - - if(CreateProcess( - cmd, /* Image path */ - args, /* Arguments for command line */ - NULL, /* Default process security */ - NULL, /* Default thread security */ - FALSE, /* Must be TRUE to use std handles */ - NORMAL_PRIORITY_CLASS, /* No special scheduling */ - NULL, /* Inherit our environment block */ - NULL, /* Inherit our currrent directory */ - &stStartInfo, /* -> Startup info */ - &stProcInfo)) /* <- Process info (if OK) */ - { - CloseHandle(stProcInfo.hThread);/* library source code does this. */ - sv_setiv(ST(2), stProcInfo.dwProcessId); - bSuccess = TRUE; - } - XSRETURN_IV(bSuccess); -} - -static -XS(w32_GetTickCount) -{ - dXSARGS; - XSRETURN_IV(GetTickCount()); -} - -static -XS(w32_GetShortPathName) -{ - dXSARGS; - SV *shortpath; - - if(items != 1) - croak("usage: Win32::GetShortPathName($longPathName)"); - - shortpath = sv_mortalcopy(ST(0)); - SvUPGRADE(shortpath, SVt_PV); - /* src == target is allowed */ - if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) - ST(0) = shortpath; - else - ST(0) = &sv_undef; - XSRETURN(1); -} - static void xs_init() { char *file = __FILE__; dXSUB_SYS; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); - - /* XXX should be removed after checking with Nick */ - newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); - - /* these names are Activeware compatible */ - newXS("Win32::GetCwd", w32_GetCwd, file); - newXS("Win32::SetCwd", w32_SetCwd, file); - newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); - newXS("Win32::GetLastError", w32_GetLastError, file); - newXS("Win32::LoginName", w32_LoginName, file); - newXS("Win32::NodeName", w32_NodeName, file); - newXS("Win32::DomainName", w32_DomainName, file); - newXS("Win32::FsType", w32_FsType, file); - newXS("Win32::GetOSVersion", w32_GetOSVersion, file); - newXS("Win32::IsWinNT", w32_IsWinNT, file); - newXS("Win32::IsWin95", w32_IsWin95, file); - newXS("Win32::FormatMessage", w32_FormatMessage, file); - newXS("Win32::Spawn", w32_Spawn, file); - newXS("Win32::GetTickCount", w32_GetTickCount, file); - newXS("Win32::GetShortPathName", w32_GetShortPathName, file); - - /* XXX Bloat Alert! The following Activeware preloads really - * ought to be part of Win32::Sys::*, so they're not included - * here. - */ - /* LookupAccountName - * LookupAccountSID - * InitiateSystemShutdown - * AbortSystemShutdown - * ExpandEnvrironmentStrings - */ } diff --git a/win32/win32.c b/win32/win32.c index 6fbe7339c5..7a4c2852db 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -22,22 +22,25 @@ #include "EXTERN.h" #include "perl.h" +#include "XSUB.h" #include <fcntl.h> #include <sys/stat.h> #include <assert.h> #include <string.h> #include <stdarg.h> +#include <float.h> #define CROAK croak #define WARN warn +#define EXECF_EXEC 1 +#define EXECF_SPAWN 2 +#define EXECF_SPAWN_NOWAIT 3 + static DWORD IdOS(void); extern WIN32_IOSUBSYSTEM win32stdio; -#ifndef __BORLANDC__ /* pointers cannot be declared TLS! */ -__declspec(thread) -#endif -PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio; +static PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio; BOOL ProbeEnv = FALSE; DWORD Win32System = (DWORD)-1; @@ -45,6 +48,8 @@ char szShellPath[MAX_PATH+1]; char szPerlLibRoot[MAX_PATH+1]; HANDLE PerlDllHandle = INVALID_HANDLE_VALUE; +static int do_spawn2(char *cmd, int exectype); + int IsWin95(void) { return (IdOS() == VER_PLATFORM_WIN32_WINDOWS); @@ -55,7 +60,7 @@ IsWinNT(void) { return (IdOS() == VER_PLATFORM_WIN32_NT); } -void * +DllExport PWIN32_IOSUBSYSTEM SetIOSubSystem(void *p) { PWIN32_IOSUBSYSTEM old = pIOSubSystem; @@ -72,6 +77,12 @@ SetIOSubSystem(void *p) return old; } +DllExport PWIN32_IOSUBSYSTEM +GetIOSubSystem(void) +{ + return pIOSubSystem; +} + char * win32PerlLibPath(void) { @@ -89,6 +100,15 @@ win32PerlLibPath(void) return (szPerlLibRoot); } +char * +win32SiteLibPath(void) +{ + static char szPerlSiteLib[MAX_PATH+1]; + strcpy(szPerlSiteLib, win32PerlLibPath()); + strcat(szPerlSiteLib, "\\site"); + return (szPerlSiteLib); +} + BOOL HasRedirection(char *ptr) { @@ -359,7 +379,8 @@ do_aspawn(void* really, void** mark, void** arglast) } else { argv[index++] = cmd = GetShell(); - argv[index++] = "/x"; /* always enable command extensions */ + if (IsWinNT()) + argv[index++] = "/x"; /* always enable command extensions */ argv[index++] = "/c"; } @@ -384,7 +405,7 @@ do_aspawn(void* really, void** mark, void** arglast) } int -do_spawn(char *cmd) +do_spawn2(char *cmd, int exectype) { char **a; char *s; @@ -414,7 +435,19 @@ do_spawn(char *cmd) } *a = Nullch; if(argv[0]) { - status = win32_spawnvp(P_WAIT, argv[0], (const char* const*)argv); + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = win32_spawnvp(P_NOWAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } if(status != -1 || errno == 0) needToTry = FALSE; } @@ -423,19 +456,49 @@ do_spawn(char *cmd) } if(needToTry) { char *argv[5]; - argv[0] = shell; argv[1] = "/x"; argv[2] = "/c"; - argv[3] = cmd; argv[4] = Nullch; - status = win32_spawnvp(P_WAIT, argv[0], (const char* const*)argv); + int i = 0; + argv[i++] = shell; + if (IsWinNT()) + argv[i++] = "/x"; + argv[i++] = "/c"; argv[i++] = cmd; argv[i] = Nullch; + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = win32_spawnvp(P_NOWAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } } if (status < 0) { if (dowarn) - warn("Can't spawn \"%s\": %s", needToTry ? shell : argv[0], + warn("Can't %s \"%s\": %s", + (exectype == EXECF_EXEC ? "exec" : "spawn"), + needToTry ? shell : argv[0], strerror(errno)); status = 255 << 8; } return (status); } +int +do_spawn(char *cmd) +{ + return do_spawn2(cmd, EXECF_SPAWN); +} + +bool +do_exec(char *cmd) +{ + do_spawn2(cmd, EXECF_EXEC); + return FALSE; +} + #define PATHLEN 1024 @@ -461,7 +524,7 @@ opendir(char *filename) /* char *dummy;*/ /* check to see if filename is a directory */ - if(stat(filename, &sbuf) < 0 || sbuf.st_mode & S_IFDIR == 0) { + if (win32_stat(filename, &sbuf) < 0 || sbuf.st_mode & S_IFDIR == 0) { return NULL; } @@ -711,6 +774,7 @@ win32_stat(const char *path, struct stat *buffer) char t[MAX_PATH]; const char *p = path; int l = strlen(path); + int res; if (l > 1) { switch(path[l - 1]) { @@ -723,9 +787,52 @@ win32_stat(const char *path, struct stat *buffer) }; } } - return stat(p, buffer); + res = pIOSubSystem->pfnstat(p,buffer); +#ifdef __BORLANDC__ + if (res == 0) { + if (S_ISDIR(buffer->st_mode)) + buffer->st_mode |= S_IWRITE | S_IEXEC; + else if (S_ISREG(buffer->st_mode)) { + if (l >= 4 && path[l-4] == '.') { + const char *e = path + l - 3; + if (strnicmp(e,"exe",3) + && strnicmp(e,"bat",3) + && strnicmp(e,"com",3) + && (IsWin95() || strnicmp(e,"cmd",3))) + buffer->st_mode &= ~S_IEXEC; + else + buffer->st_mode |= S_IEXEC; + } + else + buffer->st_mode &= ~S_IEXEC; + } + } +#endif + return res; } +#ifndef USE_WIN32_RTL_ENV + +DllExport char * +win32_getenv(const char *name) +{ + static char *curitem = Nullch; + static DWORD curlen = 512; + DWORD needlen; + if (!curitem) + New(1305,curitem,curlen,char); + if (!(needlen = GetEnvironmentVariable(name,curitem,curlen))) + return Nullch; + while (needlen > curlen) { + Renew(curitem,needlen,char); + curlen = needlen; + needlen = GetEnvironmentVariable(name,curitem,curlen); + } + return curitem; +} + +#endif + #undef times int mytimes(struct tms *timebuf) @@ -1101,6 +1208,108 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) return pIOSubSystem->pfnspawnvp(mode, cmdname, argv); } +DllExport int +win32_execvp(const char *cmdname, const char *const *argv) +{ + return pIOSubSystem->pfnexecvp(cmdname, argv); +} + +DllExport void +win32_perror(const char *str) +{ + pIOSubSystem->pfnperror(str); +} + +DllExport void +win32_setbuf(FILE *pf, char *buf) +{ + pIOSubSystem->pfnsetbuf(pf, buf); +} + +DllExport int +win32_setvbuf(FILE *pf, char *buf, int type, size_t size) +{ + return pIOSubSystem->pfnsetvbuf(pf, buf, type, size); +} + +DllExport int +win32_flushall(void) +{ + return pIOSubSystem->pfnflushall(); +} + +DllExport int +win32_fcloseall(void) +{ + return pIOSubSystem->pfnfcloseall(); +} + +DllExport char* +win32_fgets(char *s, int n, FILE *pf) +{ + return pIOSubSystem->pfnfgets(s, n, pf); +} + +DllExport char* +win32_gets(char *s) +{ + return pIOSubSystem->pfngets(s); +} + +DllExport int +win32_fgetc(FILE *pf) +{ + return pIOSubSystem->pfnfgetc(pf); +} + +DllExport int +win32_putc(int c, FILE *pf) +{ + return pIOSubSystem->pfnputc(c,pf); +} + +DllExport int +win32_puts(const char *s) +{ + return pIOSubSystem->pfnputs(s); +} + +DllExport int +win32_getchar(void) +{ + return pIOSubSystem->pfngetchar(); +} + +DllExport int +win32_putchar(int c) +{ + return pIOSubSystem->pfnputchar(c); +} + +DllExport void* +win32_malloc(size_t size) +{ + return pIOSubSystem->pfnmalloc(size); +} + +DllExport void* +win32_calloc(size_t numitems, size_t size) +{ + return pIOSubSystem->pfncalloc(numitems,size); +} + +DllExport void* +win32_realloc(void *block, size_t size) +{ + return pIOSubSystem->pfnrealloc(block,size); +} + +DllExport void +win32_free(void *block) +{ + pIOSubSystem->pfnfree(block); +} + int stolen_open_osfhandle(long handle, int flags) { @@ -1127,3 +1336,296 @@ win32_flock(int fd, int oper) return pIOSubSystem->pfnflock(fd, oper); } +static +XS(w32_GetCwd) +{ + dXSARGS; + SV *sv = sv_newmortal(); + /* Make one call with zero size - return value is required size */ + DWORD len = GetCurrentDirectory((DWORD)0,NULL); + SvUPGRADE(sv,SVt_PV); + SvGROW(sv,len); + SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); + /* + * If result != 0 + * then it worked, set PV valid, + * else leave it 'undef' + */ + if (SvCUR(sv)) + SvPOK_on(sv); + EXTEND(sp,1); + ST(0) = sv; + XSRETURN(1); +} + +static +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + croak("usage: Win32::SetCurrentDirectory($cwd)"); + if (SetCurrentDirectory(SvPV(ST(0),na))) + XSRETURN_YES; + + XSRETURN_NO; +} + +static +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetLastError) +{ + dXSARGS; + XSRETURN_IV(GetLastError()); +} + +static +XS(w32_LoginName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpv(name,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpv(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +static +XS(w32_DomainName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + char sid[1024]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, &sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_FsType) +{ + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpv(fsname,0))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + XSRETURN_PV(fsname); + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetOSVersion) +{ + dXSARGS; + OSVERSIONINFO osver; + + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + XPUSHs(newSVpv(osver.szCSDVersion, 0)); + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; + return; + } + XSRETURN_UNDEF; +} + +static +XS(w32_IsWinNT) +{ + dXSARGS; + XSRETURN_IV(IsWinNT()); +} + +static +XS(w32_IsWin95) +{ + dXSARGS; + XSRETURN_IV(IsWin95()); +} + +static +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[1024]; + + if (items != 1) + croak("usage: Win32::FormatMessage($errno)"); + + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + XSRETURN_PV(msgbuf); + + XSRETURN_UNDEF; +} + +static +XS(w32_Spawn) +{ + dXSARGS; + char *cmd, *args; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if(items != 3) + croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV(ST(0),na); + args = SvPV(ST(1), na); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if(CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + NULL, /* Inherit our environment block */ + NULL, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + sv_setiv(ST(2), stProcInfo.dwProcessId); + bSuccess = TRUE; + } + XSRETURN_IV(bSuccess); +} + +static +XS(w32_GetTickCount) +{ + dXSARGS; + XSRETURN_IV(GetTickCount()); +} + +static +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + + if(items != 1) + croak("usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + /* src == target is allowed */ + if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) + ST(0) = shortpath; + else + ST(0) = &sv_undef; + XSRETURN(1); +} + +void +init_os_extras() +{ + char *file = __FILE__; + dXSUB_SYS; + + /* XXX should be removed after checking with Nick */ + newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); + + /* these names are Activeware compatible */ + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); + newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); + newXS("Win32::IsWinNT", w32_IsWinNT, file); + newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + + /* XXX Bloat Alert! The following Activeware preloads really + * ought to be part of Win32::Sys::*, so they're not included + * here. + */ + /* LookupAccountName + * LookupAccountSID + * InitiateSystemShutdown + * AbortSystemShutdown + * ExpandEnvrironmentStrings + */ +} + +void +Perl_win32_init(int *argcp, char ***argvp) +{ + /* Disable floating point errors, Perl will trap the ones we + * care about. VC++ RTL defaults to switching these off + * already, but the Borland RTL doesn't. Since we don't + * want to be at the vendor's whim on the default, we set + * it explicitly here. + */ +#if !defined(_ALPHA_) + _control87(MCW_EM, MCW_EM); +#endif +} diff --git a/win32/win32.h b/win32/win32.h index 344ddaba59..dc069ba366 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -31,6 +31,10 @@ #define _chdir chdir #include <sys/types.h> +#ifndef DllMain +#define DllMain DllEntryPoint +#endif + #pragma warn -ccc #pragma warn -rch #pragma warn -sig @@ -64,6 +68,19 @@ extern char *staticlinkmodules[]; * facilities for accessing the same. See note in util.c/my_setenv(). */ /*#define USE_WIN32_RTL_ENV */ + +#ifndef USE_WIN32_RTL_ENV +#include <stdlib.h> +#ifndef EXT +#include "EXTERN.h" +#endif +#undef getenv +#define getenv win32_getenv +EXT char *win32_getenv(const char *name); +#endif + +EXT void Perl_win32_init(int *argcp, char ***argvp); + #define USE_SOCKETS_AS_HANDLES #ifndef USE_SOCKETS_AS_HANDLES extern FILE *myfdopen(int, char *); @@ -99,10 +116,13 @@ struct tms { unsigned int sleep(unsigned int); char *win32PerlLibPath(void); +char *win32SiteLibPath(void); int mytimes(struct tms *timebuf); unsigned int myalarm(unsigned int sec); int do_aspawn(void* really, void** mark, void** arglast); int do_spawn(char *cmd); +char do_exec(char *cmd); +void init_os_extras(void); typedef char * caddr_t; /* In malloc.c (core address). */ diff --git a/win32/win32io.c b/win32/win32io.c index 0651781342..12bc645d2d 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -293,10 +293,29 @@ WIN32_IOSUBSYSTEM win32stdio = { my_open_osfhandle, my_get_osfhandle, spawnvp, - _mkdir, - _rmdir, - _chdir, + mkdir, + rmdir, + chdir, my_flock, /* (*pfunc_flock)(int fd, int oper) */ + execvp, + perror, + setbuf, + setvbuf, + flushall, + fcloseall, + fgets, + gets, + fgetc, + putc, + puts, + getchar, + putchar, + fscanf, + scanf, + malloc, + calloc, + realloc, + free, 87654321L, /* end of structure */ }; diff --git a/win32/win32io.h b/win32/win32io.h index 678327cd20..ba4080c152 100644 --- a/win32/win32io.h +++ b/win32/win32io.h @@ -60,7 +60,26 @@ int (*pfnmkdir)(const char *path); int (*pfnrmdir)(const char *path); int (*pfnchdir)(const char *path); int (*pfnflock)(int fd, int oper); -int signature_end; +int (*pfnexecvp)(const char *cmdname, const char *const *argv); +void (*pfnperror)(const char *str); +void (*pfnsetbuf)(FILE *pf, char *buf); +int (*pfnsetvbuf)(FILE *pf, char *buf, int type, size_t size); +int (*pfnflushall)(void); +int (*pfnfcloseall)(void); +char* (*pfnfgets)(char *s, int n, FILE *pf); +char* (*pfngets)(char *s); +int (*pfnfgetc)(FILE *pf); +int (*pfnputc)(int c, FILE *pf); +int (*pfnputs)(const char *s); +int (*pfngetchar)(void); +int (*pfnputchar)(int c); +int (*pfnfscanf)(FILE *pf, const char *format, ...); +int (*pfnscanf)(const char *format, ...); +void* (*pfnmalloc)(size_t size); +void* (*pfncalloc)(size_t numitems, size_t size); +void* (*pfnrealloc)(void *block, size_t size); +void (*pfnfree)(void *block); +int signature_end; } WIN32_IOSUBSYSTEM; typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM; diff --git a/win32/win32iop.h b/win32/win32iop.h index 4b4b9973d3..4606563d0e 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -63,6 +63,23 @@ EXT int win32_mkdir(const char *dir, int mode); EXT int win32_rmdir(const char *dir); EXT int win32_chdir(const char *dir); EXT int win32_flock(int fd, int oper); +EXT int win32_execvp(const char *cmdname, const char *const *argv); +EXT void win32_perror(const char *str); +EXT void win32_setbuf(FILE *pf, char *buf); +EXT int win32_setvbuf(FILE *pf, char *buf, int type, size_t size); +EXT int win32_flushall(void); +EXT int win32_fcloseall(void); +EXT char* win32_fgets(char *s, int n, FILE *pf); +EXT char* win32_gets(char *s); +EXT int win32_fgetc(FILE *pf); +EXT int win32_putc(int c, FILE *pf); +EXT int win32_puts(const char *s); +EXT int win32_getchar(void); +EXT int win32_putchar(int c); +EXT void* win32_malloc(size_t size); +EXT void* win32_calloc(size_t numitems, size_t size); +EXT void* win32_realloc(void *block, size_t size); +EXT void win32_free(void *block); /* * these two are win32 specific but still io related @@ -80,7 +97,8 @@ long stolen_get_osfhandle(int fd); #include <win32io.h> /* pull in the io sub system structure */ -void * SetIOSubSystem(void *piosubsystem); +EXT PWIN32_IOSUBSYSTEM SetIOSubSystem(void *piosubsystem); +EXT PWIN32_IOSUBSYSTEM GetIOSubSystem(void); /* * the following six(6) is #define in stdio.h @@ -97,6 +115,9 @@ void * SetIOSubSystem(void *piosubsystem); #ifdef __BORLANDC__ #undef ungetc #undef getc +#undef putc +#undef getchar +#undef putchar #undef fileno #endif @@ -137,6 +158,7 @@ void * SetIOSubSystem(void *piosubsystem); #define tmpfile() win32_tmpfile() #define abort() win32_abort() #define fstat(fd,bufptr) win32_fstat(fd,bufptr) +#define stat(pth,bufptr) win32_stat(pth,bufptr) #define setmode(fd,mode) win32_setmode(fd,mode) #define lseek(fd,offset,orig) win32_lseek(fd,offset,orig) #define tell(fd) win32_tell(fd) @@ -154,6 +176,25 @@ void * SetIOSubSystem(void *piosubsystem); #define rmdir win32_rmdir #define chdir win32_chdir #define flock(fd,o) win32_flock(fd,o) +#define execvp win32_execvp +#define perror win32_perror +#define setbuf win32_setbuf +#define setvbuf win32_setvbuf +#define flushall win32_flushall +#define fcloseall win32_fcloseall +#define fgets win32_fgets +#define gets win32_gets +#define fgetc win32_fgetc +#define putc win32_putc +#define puts win32_puts +#define getchar win32_getchar +#define putchar win32_putchar +#define fscanf (GetIOSubSystem()->pfnfscanf) +#define scanf (GetIOSubSystem()->pfnscanf) +#define malloc win32_malloc +#define calloc win32_calloc +#define realloc win32_realloc +#define free win32_free #endif /* WIN32IO_IS_STDIO */ #endif /* WIN32IOP_H */ diff --git a/win32/win32sck.c b/win32/win32sck.c index fe5b2e7153..d541a7e3ba 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -694,9 +694,12 @@ win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) d->s_name = s->s_name; d->s_aliases = s->s_aliases; d->s_port = s->s_port; +#ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */ if (!IsWin95() && s->s_proto && strlen(s->s_proto)) d->s_proto = s->s_proto; - else if (proto && strlen(proto)) + else +#endif + if (proto && strlen(proto)) d->s_proto = (char *)proto; else d->s_proto = "tcp"; |