diff options
388 files changed, 39945 insertions, 17219 deletions
@@ -97,7 +97,7 @@ interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall -under the copyright of this Package, but belong to whomever generated +under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a @@ -7,6 +7,2073 @@ site, in the .../src/5.0 directory for full version releases, or in the .../src/5/0/unsupported directory for sub-version releases.) + +---------------- +Version 5.003_21 +---------------- + +This release includes several important bug fixes, and a couple of +minor but valuable language tweaks. Please read on for a list of the +significant changes: + + CORE LANGUAGE CHANGES + + Title: "Fix overloading via inherited autoloaded functions" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701131022.FAA22830@monk.mps.ohio-state.edu> + Date: Mon, 13 Jan 1997 05:22:47 -0500 (EST) + Files: gv.c lib/overload.pm pod/perldiag.pod t/pragma/overload.t + + Title: "Method call fixes: Don't cache in alias, don't skip undef" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym gv.c gv.h hv.c op.c pod/perlguts.pod + pod/perltoc.pod pp.c pp_ctl.c pp_hot.c proto.h scope.c sv.c + t/op/method.t + + Title: "Formats can be closures" + From: Chip Salzenberg <chip@atlantic.net> + Files: cv.h op.c perly.c perly.c.diff perly.y pp_sys.c sv.h + + Title: "Quote 'foo' in C<$x{-foo}>" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Forbid C< x->{y} > and C< x->[0] > under C<strict refs>" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c pod/perldiag.pod t/pragma/strict-refs + + Title: "Allow <=> to return undef when operands are not ordered" + From: Chip Salzenberg and Andreas Koenig + Files: MANIFEST pp.c t/op/cmp.t + + Title: "Fail regex that starts with '{'" + From: Chip Salzenberg <chip@atlantic.net> + Files: regcomp.c + + CORE PORTABILITY + + Title: "Re: Perl 5.003_20: OS/2 patches" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701101102.GAA19051@monk.mps.ohio-state.edu> + Date: Fri, 10 Jan 1997 06:02:16 -0500 (EST) + Files: hints/os2.sh os2/Changes os2/os2.c os2/os2ish.h pp_sys.c + + Title: "VMS patches for _20" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IE7MGK7ULQ003K5M@hmivax.humgen.upenn.edu> + Date: Tue, 14 Jan 1997 17:34:43 -0500 (EST) + Files: configpm dosish.h os2/os2ish.h plan9/plan9ish.h proto.h + t/pragma/strict.t t/pragma/subs.t t/pragma/warning.t toke.c + unixish.h vms/Makefile vms/config.vms vms/descrip.mms + vms/genconfig.pl vms/perly_c.vms vms/test.com vms/vmsish.h + x2p/a2p.h x2p/str.c + + Title: "Irix 6.3 & 6.4 and perl5.003_20" + From: John Stoffel <jfs@fluent.com> + Msg-ID: <199701132242.RAA14601@jfs.Fluent.COM> + Date: Mon, 13 Jan 1997 17:42:50 -0500 (EST) + Files: MANIFEST hints/irix_6_3.sh hints/irix_6_4.sh + + Title: "Patch: MachTen hints, Configure" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03010d00af0123a93670@[194.51.248.75]> + Date: Tue, 14 Jan 1997 13:43:13 +0100 + Files: Configure hints/machten.sh + + Title: "Rename aux.sh to aux_3.sh for MS-LOSS" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST hints/aux_3.sh + + OTHER CORE CHANGES + + Title: "Fix C< eval { my $x; eval '$x' } >" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c t/op/misc.t + + Title: "Don't warn if eval '' uses outer func's lexicals" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Avoid memory wastage in wait(); make pidstatus global" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym interp.sym perl.c perl.h pp_sys.c + + Title: "Forbid ++ and -- on readonly values" + From: "John Q. Linux" <jql@accessone.com> + Msg-ID: <Pine.LNX.3.95.970110193330.11249D-100000@jql.accessone.com> + Date: Fri, 10 Jan 1997 19:47:16 -0800 (PST) + Files: pp.c pp_hot.c + + Title: "Keep array from dying during foreach(@array)" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h pp_ctl.c + + Title: "Fix C< $a="simple"; split /($a)/o >" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c t/op/misc.t + + Title: "Fix infinite loop for undef function in @SIG{__WARN__,__DIE__}" + From: Chip Salzenberg <chip@atlantic.net> + Files: util.c + + Title: "Fix for anon-lists with tied entries coredump" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701100745.CAA13057@aatma.engin.umich.edu> + Date: Fri, 10 Jan 1997 02:45:11 -0500 + Files: pp.c + + Title: "Don't set SVf_PADBUSY on immortal SVs" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Patch for Object subroutines" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701080156.UAA15366@monk.mps.ohio-state.edu> + Date: Tue, 7 Jan 1997 20:56:02 -0500 (EST) + Files: cop.h + + Title: "Use an SVt_PVLV to hold stacked OP pointers when debugging" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c pp_hot.c + + Title: "Undo change that freed large pad vars" + From: Chip Salzenberg <chip@atlantic.net> + Files: scope.c + + BUILD PROCESS + + Title: "Make MachTen hints file warn about db-recno failures" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03010d00aef92fba6aca@[194.51.248.78]> + Date: Wed, 8 Jan 1997 12:07:18 +0100 + Files: hints/machten.sh + + Title: "5.003_20, FreeBSD 3.0 and minor patch" + From: roberto@eurocontrol.fr (Ollivier Robert) + Msg-ID: <Mutt.19970108143747.roberto@caerdonn.eurocontrol.fr> + Date: Wed, 8 Jan 1997 14:37:47 +0100 + Files: Configure + + Title: "Make installperl quieter; only shared libraries need 0555" + From: Chip Salzenberg <chip@atlantic.net> + Files: installperl + + TESTS + + Title: "Advice on TEST failure" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03010d01aefbaefcf3bc@[194.51.248.78]> + Date: Fri, 10 Jan 1997 10:19:07 +0100 + Files: t/TEST + + Title: "UNIVERSAL tests" + From: Roderick Schertler <roderick@gate.net> + Files: MANIFEST t/op/universal.t + + Title: "Test deletion of array during foreach" + From: Jarkko Hietaniemi <jhi@alpha.hut.fi> + Files: t/op/misc.t + + Title: "patch for db-recno.t" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9701121509.AA11147@claudius.bfsec.bt.co.uk> + Date: Sun, 12 Jan 1997 15:09:33 +0000 (GMT) + Files: t/lib/db-recno.t + + LIBRARY AND EXTENSIONS + + Title: "Localize info about filesystems being case-forgiving" + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/File/Basename.pm pod/checkpods.PL pod/pod2html.PL + pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL + utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL + utils/perldoc.PL utils/pl2pm.PL utils/splain.PL + x2p/find2perl.PL x2p/s2p.PL + + Title: "Fix for fd leak in IO::File::new_tmpfile" + From: Graham Barr and Chip Salzenberg + Files: ext/IO/IO.xs ext/IO/lib/IO/Handle.pm + + Title: "Refresh Getopt::Long to 2.6" + From: Johan Vromans <jvromans@squirrel.nl> + Files: lib/Getopt/Long.pm + + Title: "Refresh DB_File to 1.10" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9701141247.AA21242@claudius.bfsec.bt.co.uk> + Date: Tue, 14 Jan 97 12:47:40 GMT + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs + + Title: "Re: FileCache::cacheout clobbers $_" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pz3ewb3189.fsf@eeyore.ibcinc.com> + Date: 08 Jan 1997 23:45:58 -0500 + Files: lib/FileCache.pm lib/cacheout.pl + + Title: "PATCH: AutoSplit" + From: Graham Barr <bodg@tiuk.ti.com> + Msg-ID: <9603111010.AA29935@tiuk.ti.com> + Date: 11 Mar 1996 06:01:58 -0500 + Files: lib/AutoSplit.pm + + Title: "Re: Uninitialized value in Carp.pm ? " + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701141815.NAA07960@aatma.engin.umich.edu> + Date: Tue, 14 Jan 1997 13:15:25 -0500 + Files: lib/Carp.pm + + Title: "Avoid "uninitialized" warnings from POSIX::constant()" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/POSIX/POSIX.pm + + Title: "Eliminate warning from C<use overload>" + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/overload.pm + + Title: "low priority patches" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9701081655.AA27349@claudius.bfsec.bt.co.uk> + Date: Wed, 8 Jan 97 16:55:02 GMT + Files: lib/Cwd.pm t/comp/redef.t t/lib/db-btree.t + + UTILITIES + + Title: "Re: xsubpp and Tk ==> segfault" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701080825.DAA15813@monk.mps.ohio-state.edu> + Date: Wed, 8 Jan 1997 03:25:47 -0500 (EST) + Files: lib/ExtUtils/xsubpp + + Title: "Re: MakeMaker and 'make uninstall'" + From: Andreas Koenig <k@anna.in-berlin.de> + Msg-ID: <199701101243.NAA26400@anna.in-berlin.de> + Date: Fri, 10 Jan 1997 13:43:39 +0100 + Files: lib/ExtUtils/MM_Unix.pm + + Title: "Don't search for pod if path is already valid" + From: Wayne Scott <wscott@ichips.intel.com> + Msg-ID: <199701082325.PAA04521@pdxlx008.intel.com> + Date: Wed, 08 Jan 1997 15:25:19 -0800 + Files: utils/perldoc.PL + + Title: "Yet another perldoc option" + From: Gisle Aas <aas@aas.no> + Msg-ID: <199610022200.AAA15334@furubotn.sn.no> + Date: Thu, 3 Oct 1996 00:00:35 +0200 + Files: utils/perldoc.PL + + Title: "Re: perldoc, temp files, async pagers" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzwwtoom8p.fsf@eeyore.ibcinc.com> + Date: 07 Jan 1997 22:54:14 -0500 + Files: utils/perldoc.PL + + DOCUMENTATION + + Title: "Full documentation generation patch" + From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> + Msg-ID: <15309.853323388@lyon.grenoble.hp.com> + Date: Wed, 15 Jan 97 11:16:28 +0100 + Files: MANIFEST pod/roffitall pod/rofftoc + + Title: "Re: documentation correction (i.e. patch) for perlsyn.pod" + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Msg-ID: <E0vilLh-0000M6-00@ursa.cus.cam.ac.uk> + Date: Fri, 10 Jan 1997 18:06:37 +0000 + Files: pod/perlsyn.pod + + Title: "Document use of pos() and /\G/" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701132013.PAA26606@aatma.engin.umich.edu> + Date: Mon, 13 Jan 1997 15:13:12 -0500 + Files: pod/perlfunc.pod pod/perlnews.pod pod/perlop.pod + pod/perlre.pod pod/perltoc.pod pod/perltrap.pod + + Title: "Fix example #4 in perlXStut" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701050739.CAA11112@monk.mps.ohio-state.edu> + Date: Sun, 5 Jan 1997 02:39:45 -0500 (EST) + Files: pod/perlxstut.pod + + Title: "Document new closure warnings" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c pod/perldiag.pod + + Title: "Misc. doc patches missing in _20" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <102.852695733@eeyore.ibcinc.com> + Date: Tue, 07 Jan 1997 22:55:33 -0500 + Files: pod/perlsub.pod pod/perltoc.pod pod/perlvar.pod + + +---------------- +Version 5.003_20 +---------------- + +The only language change in this release is the recension of support +for named closures: Now, no subroutine declared "sub foo {}" can be +a closure. (This is a return to the behavior of 5.003.) In addition, +there are new warnings triggered by any apparent attempt to use named +functions as closures. + +And, as usual, there are the usual little fixes, documentation +updates, and expanded tests. This is good stuff. "I love you, man!" + + CORE LANGUAGE CHANGES + + Title: "Rescind named closures" + From: Chip Salzenberg <chip@atlantic.net> + Files: Makefile.SH op.c perly.c perly.c.diff perly.y pp_hot.c + + Title: "Fix: empty @_ when calling empty-proto subs without parens" + From: Graham Barr <bodg@tiuk.ti.com> + Msg-ID: <32CE30F0.7E8425A5@tiuk.ti.com> + Date: Sat, 04 Jan 1997 10:29:04 +0000 + Files: perly.c perly.y + + CORE PORTABILITY + + Title: "Fix $^X on systems that set it to Perl's basename" + From: Chip Salzenberg <chip@atlantic.net> + Files: hints/hpux.sh toke.c + + Title: "Configure/perl5/Compartmented Mode Workstation (fwd)" + From: Andy Dougherty <doughera@fractal.phys.lafayette.edu> + Msg-ID: <Pine.SOL.3.95.970106131505.1662C-100000@fractal.lafayette.ed + Date: Mon, 06 Jan 1997 13:15:38 -0500 (EST) + Files: Configure hints/dec_osf.sh + + Title: "Remove obsolete file "dl_os2.xs"." + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: MANIFEST + + OTHER CORE CHANGES + + Title: "Fix C< sub foo (&@); sub bar (&); foo {}, bar {}, bar {} >" + From: Chip Salzenberg <chip@atlantic.net> + Files: perly.c perly.c.diff perly.y + + Title: "plug for safe/opcode leaks" + From: Doug MacEachern <dougm@osf.org> + Msg-ID: <199701072220.RAA02117@postman.osf.org> + Date: Tue, 07 Jan 1997 17:20:46 -0500 + Files: op.c + + Title: "Finish OP= warnings: none on ^=" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c pp.c t/op/assignwarn.t + + Title: "Fix Dynaloader failures with DProf" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701061718.MAA26909@aatma.engin.umich.edu> + Date: Mon, 06 Jan 1997 12:18:46 -0500 + Files: pp_hot.c + + BUILD PROCESS + + Title: "Make Configure default to the first domain in /etc/resolv.conf" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + Title: "Start all helper scripts with $startsh" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + Title: "Support libperl.so under FreeBSD" + From: roberto@keltia.freenix.fr (Ollivier Robert) + Msg-ID: <Mutt.19970105224149.roberto@keltia.freenix.fr> + Date: Sun, 5 Jan 1997 22:41:49 +0100 + Files: Configure Makefile.SH + + TESTS + + Title: "New test: comp/proto.t" + From: Graham Barr <bodg@tiuk.ti.com> + Msg-ID: <32D0C21F.3FB28D51@tiuk.ti.com> + Date: Mon, 06 Jan 1997 09:13:03 +0000 + Files: MANIFEST t/comp/proto.t + + Title: "More magic variable tests" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <7043.852565192@eeyore.ibcinc.com> + Date: Mon, 06 Jan 1997 10:39:52 -0500 + Files: t/harness t/op/magic.t + + LIBRARY AND EXTENSIONS + + Title: "File::Basename::dirname bugs" + From: Robin Barker <rmb@cise.npl.co.uk> + Msg-ID: <12393.9701071719@tempest.cise.npl.co.uk> + Date: Tue, 7 Jan 97 17:19:59 GMT + Files: lib/File/Basename.pm t/lib/basename.t + + Title: "sigaction() problems" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <12808.852583324@eeyore.ibcinc.com> + Date: Mon, 06 Jan 1997 15:42:04 -0500 + Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod + + Title: "Fix importation of FileHandle methods; fix POSIX docs" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod lib/FileHandle.pm + + Title: "Patch: make hints files warn about db-recno failures" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03010d00aef53ac4d18a@[194.51.248.68]> + Date: Sun, 5 Jan 1997 12:34:25 +0100 + Files: MANIFEST hints/aux.sh hints/broken-db.msg hints/freebsd.sh + + UTILITIES + + Title: "pod2html.PL patch (for 5.003-19)" + From: Fabien TASSIN <tassin@eerie.fr> + Msg-ID: <199701052347.AAA21297@solar5> + Date: Mon, 6 Jan 1997 00:47:01 +0100 + Files: pod/pod2html.PL + + DOCUMENTATION + + Title: "tiny doc patches" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <23338.852394333@eeyore.ibcinc.com> + Date: Sat, 04 Jan 1997 11:12:13 -0500 + Files: pod/perlapio.pod pod/perlnews.pod pod/perltoc.pod + + Title: "doc patch for defined on perlfunc.pod" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pz91686ek1.fsf@eeyore.ibcinc.com> + Date: 04 Jan 1997 21:28:30 -0500 + Files: pod/perlfunc.pod + + Title: "doc patch: perldsc" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzafqo6eo9.fsf@eeyore.ibcinc.com> + Date: 04 Jan 1997 21:25:58 -0500 + Files: pod/perldsc.pod pod/perltoc.pod + + Title: "Re: constant function inlining" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzk9pp1b95.fsf@eeyore.ibcinc.com> + Date: 07 Jan 1997 15:27:50 -0500 + Files: pod/perldiag.pod pod/perlsub.pod + + Title: "scalar caller doc fix" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <18245.852608060@eeyore.ibcinc.com> + Date: Mon, 06 Jan 1997 22:34:20 -0500 + Files: pod/perlfunc.pod + + Title: "perlpod.pod possible patches" + From: lvirden@cas.org (Larry W. Virden, x2487) + Msg-ID: <9701070756.AA1185@cas.org> + Date: Tue, 7 Jan 1997 07:56:30 -0500 + Files: pod/perlpod.pod + + Title: "Misc perlfunc updates" + From: Tom Christiansen <tchrist@mox.perl.com> + Files: pod/perlfunc.pod pod/perltoc.pod + + +---------------- +Version 5.003_19 +---------------- + +Lots of internal cleanup in this patch, especially plugged memory +leaks when embedded Perl interpreters shut down and restart. The +method cache is now invisible to user code. And there is a new test +directory, "t/pragma". + +IMHO, this is Beta quality code. + +Here's a list of the more significant changes... + + CORE LANGUAGE CHANGES + + Title: "Make method cache invisible to user code" + From: Chip Salzenberg <chip@atlantic.net> + Files: dump.c gv.c gv.h hv.c op.c perl.c pp_hot.c pp_sys.c sv.c + toke.c + + Title: "Never parse "{m,s,y,tr,q{,q,w,x}}:{,:}" as package or label" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + CORE PORTABILITY + + Title: "Fix $^X under HP-UX" + From: Chip Salzenberg <chip@atlantic.net> + Files: hints/hpux.sh toke.c + + Title: "New hints/hpux.sh" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199612312309.AA283393772@hpcc123.corp.hp.com> + Date: Tue, 31 Dec 1996 15:09:32 -0800 + Files: hints/hpux.sh + + OTHER CORE CHANGES + + Title: "Fix segv when calling named closures" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_hot.c + + Title: "Finish rationalizing "undef value" warnings" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c pp.c sv.c t/op/assignwarn.t + + Title: "Arrange for all "_<file" entries to be in %main::" + From: Chip Salzenberg <chip@atlantic.net> + Files: gv.c lib/perl5db.pl + + Title: "Introduce CVf_NODEBUG flag" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701012042.PAA25994@aatma.engin.umich.edu> + Date: Wed, 01 Jan 1997 15:42:05 -0500 + Files: cv.h pp_hot.c + + Title: "Reword 'may be "0"' warning per Larry; fix its line number" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c pod/perldiag.pod + + Title: "5.003_18: perl_{con,des}truct fixes" + From: Doug MacEachern <dougm@osf.org> + Msg-ID: <199701032042.PAA06766@postman.osf.org> + Date: Fri, 03 Jan 1997 15:42:04 -0500 + Files: perl.c perl.h pod/perlembed.pod pod/perltoc.pod t/op/sysio.t + + Title: "Fix lost value from READLINE after TIEHANDLE" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: pp_hot.c sv.h + + Title: "Free memory of large lexical variables when leaving scope" + From: Chip Salzenberg <chip@atlantic.net> + Files: scope.c + + TESTS + + Title: "Create t/pragma directory; populate with new and old" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Files: MANIFEST Makefile.SH t/TEST t/comp/use.t t/lib/locale.t + t/op/overload.t t/op/use.t t/pragma/locale.t t/pragma/overload.t + t/pragma/strict-refs t/pragma/strict-subs t/pragma/strict-vars + t/pragma/strict.t t/pragma/subs.t t/pragma/warn-global + t/pragma/warning.t + + Title: "New tests: comp/colon.t and op/assignwarn.t" + From: Robin Barker <rmb@cise.npl.co.uk> + Files: MANIFEST t/comp/colon.t t/op/assignwarn.t + + LIBRARY AND EXTENSIONS + + Title: "Make libs clean under '-w'" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Files: lib/AutoSplit.pm lib/Devel/SelfStubber.pm lib/Env.pm + lib/Math/Complex.pm lib/Pod/Functions.pm lib/Search/Dict.pm + lib/SelfLoader.pm lib/Term/Complete.pm lib/chat2.pl + lib/complete.pl lib/diagnostics.pm lib/ftp.pl lib/termcap.pl + lib/validate.pl + + DOCUMENTATION + + Title: "Perlguts, version 28" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199701032110.AA102535846@hpcc123.corp.hp.com> + Date: Fri, 3 Jan 1997 13:10:46 -0800 + Files: pod/perlguts.pod + + Title: "Re: perldelta, take 3" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <9701031748.AA15335@toad.ig.co.uk> + Date: Fri, 3 Jan 1997 17:48:46 +0000 + Files: pod/perlnews.pod + + Title: "Miscellaneous pod patches" + From: Ralf S. Engelschall <rse@engelschall.com> + Files: pod/Makefile pod/perldebug.pod pod/perlfunc.pod + pod/perlguts.pod + + Title: "expanded flock() docs" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <4481.852337871@eeyore.ibcinc.com> + Date: Fri, 03 Jan 1997 19:31:11 -0500 + Files: pod/perlfunc.pod + + Title: "Use Text::Wrap in buildtoc; run buildtoc" + From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> + Files: pod/buildtoc pod/perltoc.pod + + Title: "Remove obsolete perlovl.pod" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST plan9/mkfile pod/perlovl.pod vms/Makefile + vms/descrip.mms + + +---------------- +Version 5.003_18 +---------------- + +Yet further down the road to 5.004.... + + CORE LANGUAGE CHANGES + + Title: "Inherited overloading" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612291312.IAA02134@monk.mps.ohio-state.edu> + Date: Sun, 29 Dec 1996 08:12:54 -0500 (EST) + Files: gv.c lib/overload.pm perl.h sv.c sv.h t/op/overload.t + + Title: "Hide lexicals from C<use>d or C<require>d module (!)" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_ctl.c + + Title: "Closures at file scope must be anonymous" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Warn on '{if,while} ($x = X)' where X is glob, readdir, or <FH>" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c pod/perldiag.pod + + Title: "Warn on 'undef $x; $x OP 1' where OP is *=, /=, %=, or **=" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + CORE PORTABILITY + + Title: "Ultrix setlocale() workaround" + From: Chip Salzenberg <chip@atlantic.net> + Files: hints/ultrix_4.sh util.c + + OTHER CORE CHANGES + + Title: "Get rid of 'Leaked scalars'" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h gv.c op.c + + Title: "Don't forget $c in C<(($a,$b,$c)=(1,2))=(3,4,5)>" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_hot.c + + Title: "Fix core dump on perl_construct()/perl_destruct() loop" + From: Chip Salzenberg <chip@atlantic.net> + Files: perl.c + + Title: "Add missing syms to global.sym; update magic doc" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym pod/perlguts.pod + + TESTS + + Title: "Expanded locale.t and misc.t" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Files: t/lib/locale.t t/lib/misc.t + + Title: "Expanded my.t" + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/my.t + + Title: "test harness for C<use x.xxxx>" + From: Graham Barr <bodg@tiuk.ti.com> + Msg-ID: <32C76882.3F3C7999@tiuk.ti.com> + Date: Mon, 30 Dec 1996 07:00:18 +0000 + Files: MANIFEST t/op/use.t + + Title: "More tests" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.95.961229170736.15213M-100000@solaris.teleport.co + Date: Sun, 29 Dec 1996 17:46:21 -0800 (PST) + Files: t/op/each.t t/op/oct.t t/op/quotemeta.t t/op/rand.t + + LIBRARY AND EXTENSIONS + + Title: "Improving Config.pm" + From: Tom Phoenix <rootbeer@teleport.com> + Msg-ID: <Pine.GSO.3.95.961230091244.13467L-100000@solaris.teleport.co + Date: Mon, 30 Dec 1996 09:24:16 -0800 (PST) + Files: configpm + + Title: "File::Copy under OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612280347.WAA00293@monk.mps.ohio-state.edu> + Date: Fri, 27 Dec 1996 22:47:24 -0500 (EST) + Files: lib/File/Copy.pm t/lib/filecopy.t + + DOCUMENTATION + + Title: "Updates to perllocale.pod" + From: Dominic Dunlop <domo@slipper.ip.lu> + Files: pod/perllocale.pod + + Title: "Locale-related pod patches, take 2" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03007800aeea9e488b36@[194.51.248.77]> + Date: Sat, 28 Dec 1996 10:56:41 +0100 + Files: pod/perl.pod pod/perlform.pod pod/perlfunc.pod pod/perlop.pod + pod/perlre.pod pod/perlsec.pod + + Title: "Re: perldiag.pod entry for "Scalar value @%s{%s} ..."" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <2043.852051019@eeyore.ibcinc.com> + Date: Tue, 31 Dec 1996 11:50:19 -0500 + Files: pod/perldiag.pod + + +---------------- +Version 5.003_17 +---------------- + +The rate of patches is slowing down.... I see 5.004 at the end of the +tunnel! (Hey, what's that whistle?) + + CORE LANGUAGE CHANGES + + Title: "Support named closures" + From: Chip Salzenberg <chip@atlantic.net> + Files: cv.h op.c perl.c pp.c pp_ctl.c pp_hot.c + + CORE PORTABILITY + + Title: "perl5.003_15 and Interactive Unix" + From: win@in.rhein-main.de (Winfried Koenig) + Msg-ID: <m0vd254-0004oKC@incom.rhein-main.de> + Date: Thu, 26 Dec 1996 00:45:45 +0200 (EET) + Files: hints/isc.sh pp_sys.c + + Title: "Suggest "usemymalloc='n'" for FreeBSD 2.*" + From: rse@engelschall.com (Ralf S. Engelschall) + Files: hints/freebsd.sh + + Title: "Minor OS/2 fixes" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612252105.QAA11890@monk.mps.ohio-state.edu> + Date: Wed, 25 Dec 1996 16:05:42 -0500 (EST) + Files: os2/os2ish.h pod/perlxstut.pod + + OTHER CORE CHANGES + + Title: "Fix {,un}tainting of $1 etc. when C<use locale>" + From: Chip Salzenberg <chip@atlantic.net> + Files: mg.c sv.c + + Title: "Limit effects of "=pod" to a single file" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + TESTS + + Title: "New tests: op/method.t and op/locale.t" + From: Ilya Zakharevich and Jarkko Hietaniemi + Files: MANIFEST t/lib/locale.t t/op/method.t + + Title: "Test C< ()=() >" + From: Chip Salzenberg <chip@atlantic.net> + Files: t/op/misc.t + + LIBRARY AND EXTENSIONS + + Title: "Refresh MakeMaker to 5.39" + From: Andreas Koenig <k@anna.in-berlin.de> + Files: lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm + lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm + lib/ExtUtils/Mksymlists.pm + + Title: "Newer debugger" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612261954.OAA12999@monk.mps.ohio-state.edu> + Date: Thu, 26 Dec 1996 14:54:34 -0500 (EST) + Files: lib/perl5db.pl + + DOCUMENTATION + + Title: "Perlguts, version 27" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199612250144.AA059528263@hpcc123.corp.hp.com> + Date: Tue, 24 Dec 1996 17:44:23 -0800 + Files: pod/perlguts.pod + + Title: "perlpod.pod patch for _16" + From: Kenneth Albanowski <kjahds@kjahds.com> + Msg-ID: <Pine.LNX.3.93.961224225906.337B-100000@kjahds.com> + Date: Tue, 24 Dec 1996 23:00:10 -0500 (EST) + Files: pod/perlpod.pod + + Title: "tiny perllocale.pod diff for _16" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199612261306.PAA21161@alpha.hut.fi> + Date: Thu, 26 Dec 1996 15:06:04 +0200 (EET) + Files: pod/perllocale.pod + + +---------------- +Version 5.003_16 +---------------- + +This patch is all bug fixes, library updates, and documentation +updates. We'll get to 5.004 RSN, I promise. :-) + + CORE LANGUAGE CHANGES + + Title: "Fix closures that are not in subroutines" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + CORE PORTABILITY + + Title: "_13: patches for unicos/unicosmk" + From: Dean Roehrich <roehrich@cray.com> + Msg-ID: <199612202038.OAA22805@poplar.cray.com> + Date: Fri, 20 Dec 1996 14:38:50 -0600 + Files: Configure MANIFEST hints/unicos.sh hints/unicosmk.sh + + OTHER CORE CHANGES + + Title: "Fix 'foreach(@ARGV) { while (<>) { push @p,$_ } }'" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h pp_hot.c scope.c + + Title: "Eliminate warnings from C< undef $x; $x OP= "foo" >" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c pp.c pp.h pp_hot.c + + Title: "Try again to improve method caching" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612240113.UAA09487@monk.mps.ohio-state.edu> + Date: Mon, 23 Dec 1996 20:13:56 -0500 (EST) + Files: gv.c sv.c + + Title: "Be more careful about 'o' magic memory management" + From: Chip Salzenberg <chip@atlantic.net> + Files: mg.c sv.c + + Title: "Fix bad pointer refs when localized object loses magic" + From: Chip Salzenberg <chip@atlantic.net> + Files: scope.c + + LIBRARY AND EXTENSIONS + + Title: "Refresh CPAN to 1.09" + From: Andreas Koenig + Files: lib/CPAN.pm + + Title: "Refresh Net::Ping to 2.02" + From: Russell Mosemann <mose@ccsn.edu> + Files: lib/Net/Ping.pm + + Title: "Refresh IO to 1.14" + From: Graham Barr + Files: MANIFEST ext/IO/IO.xs ext/IO/README ext/IO/lib/IO/File.pm + ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Pipe.pm + ext/IO/lib/IO/Seekable.pm ext/IO/lib/IO/Select.pm + ext/IO/lib/IO/Socket.pm t/lib/io_dup.t t/lib/io_pipe.t + t/lib/io_sel.t t/lib/io_sock.t t/lib/io_tell.t + t/lib/io_udp.t t/lib/io_xs.t + + BUILD PROCESS AND UTILITIES + + Title: "Don't recurse into subdirs twice on 'make realclean'" + From: Chip Salzenberg <chip@atlantic.net> + Files: Makefile.SH + + Title: "Use root EXTERN.h when compiling x2p/malloc.c." + From: Paul Marquess + Files: x2p/Makefile.SH + + Title: "Fix compilation errors when malloc.c used for x2p" + From: Robin Barker <rmb@cise.npl.co.uk> + Files: malloc.c + + DOCUMENTATION + + Title: "Edit INSTALL to describe new binary compat setup" + From: Chip Salzenberg <chip@atlantic.net> + Files: INSTALL + + Title: "Update to perllocale.pod" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Files: pod/perllocale.pod + + +---------------- +Version 5.003_15 +---------------- + +As soon as I posted 5.003_14, I found a fatal error in it. :-( + +This release is strictly a bug fix -- it removes some function caching +changes that were supposed to be improvements, but weren't. + + +---------------- +Version 5.003_14 +---------------- + +We seem to have achieved "release candidate" status. + + CORE LANGUAGE CHANGES + + Title: "Eliminate support for {if,unless,while,until} BLOCK BLOCK" + From: Chip Salzenberg <chip@atlantic.net> + Files: perly.c perly.c.diff perly.y toke.c + + Title: "Taint $x after $x =~ s/pat/xyz/ if pat or xyz is tainted by locale" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h mg.c pp_ctl.c pp_hot.c + + Title: "Complete support for modifying undefined array members in foreach" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym mg.c perl.h pp.c pp_hot.c proto.h sv.c + + OTHER CORE CHANGES + + Title: "patch for regex bug: (x|x){n}" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199612210259.VAA10170@aatma.engin.umich.edu> + Date: Fri, 20 Dec 1996 21:59:22 -0500 + Files: regexec.c + + Title: "Bug in debugger with import manipulations" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612231037.FAA08617@monk.mps.ohio-state.edu> + Date: Mon, 23 Dec 1996 05:37:48 -0500 (EST) + Files: pp_hot.c + + Title: "Import and dynamic methods" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612230645.BAA08378@monk.mps.ohio-state.edu> + Date: Mon, 23 Dec 1996 01:45:37 -0500 (EST) + Files: gv.c hv.c sv.c + + Title: "malloc.c patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612220748.CAA07164@monk.mps.ohio-state.edu> + Date: Sun, 22 Dec 1996 02:48:58 -0500 (EST) + Files: malloc.c + + Title: "sv_gets patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612220824.DAA07235@monk.mps.ohio-state.edu> + Date: Sun, 22 Dec 1996 03:24:04 -0500 (EST) + Files: pp_hot.c + + Title: "pos $str patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612220831.DAA07247@monk.mps.ohio-state.edu> + Date: Sun, 22 Dec 1996 03:31:21 -0500 (EST) + Files: mg.c pp_hot.c t/op/pat.t + + Title: "Prevent warnings when STDCHAR is unsigned" + From: Chip Salzenberg <chip@atlantic.net> + Files: perlio.c perlio.h + + PORTABILITY + + Title: "Fix bugs in bincompat3 usage" + From: Chip Salzenberg <chip@atlantic.net> + Files: perl.h perl_exp.SH + + Title: "Support shared libperl on SunOS" + From: Ulrich Pfeifer + Files: Makefile.SH + + Title: "Configure on OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612202325.SAA05505@monk.mps.ohio-state.edu> + Date: Fri, 20 Dec 1996 18:25:30 -0500 (EST) + Files: Configure + + Title: "Fixes for Interactive Unix" + From: win@in.rhein-main.de (Winfried Koenig) + Msg-ID: <m0vbeNO-00003WC@incom.rhein-main.de> + Date: Sun, 22 Dec 96 05:14 EET + Files: hints/isc.sh op.c pp_sys.c universal.c + + Title: "Use "proto" instead of "_" in sdbm.h" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/SDBM_File/sdbm/sdbm.h + + Title: "VMS patches to 5.003_13" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IDBYYFYPIS002ASE@hmivax.humgen.upenn.edu> + Date: Mon, 23 Dec 1996 01:26:47 -0500 (EST) + Files: deb.c ext/POSIX/POSIX.xs gv.c lib/File/Copy.pm mg.c perl.c + perl.h proto.h sv.c t/lib/filecopy.t taint.c toke.c util.c + vms/Makefile vms/config.vms vms/descrip.mms + vms/gen_shrfls.pl vms/genconfig.pl vms/genopt.com + vms/perly_c.vms vms/perly_h.vms vms/test.com vms/vms.c + vms/vms_yfix.pl + + UTILITIES, LIBRARY, AND EXTENSIONS + + Title: "Remove libnet" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST pod/perlmod.pod + + Title: "Refresh CPAN module to 1.08" + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/CPAN.pm lib/CPAN/FirstTime.pm + + Title: "Refresh ExtUtils::Manifest to version 1.28" + From: Andreas Koenig + Files: lib/ExtUtils/Manifest.pm + + Title: "Update IO->VERSION() to 1.1201 for CPAN's sake" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm + + Title: "Remodel File::Copy." + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/File/Copy.pm + + Title: "dumb bug in User::pwent.pm" + From: Tom Christiansen <tchrist@mox.perl.com> + Msg-ID: <199612201145.EAA27860@mox.perl.com> + Date: Fri, 20 Dec 1996 04:45:37 -0700 + Files: lib/User/pwent.pm + + DOCUMENTATION + + Title: "Better support for =for" + From: Kenneth Albanowski <kjahds@kjahds.com> + Msg-ID: <Pine.LNX.3.93.961220163747.298T-100000@kjahds.com> + Date: Fri, 20 Dec 1996 16:43:35 -0500 (EST) + Files: lib/Pod/Text.pm pod/pod2latex.PL pod/pod2man.PL + + Title: "perllocale.pod -- second draft" + From: Dominic Dunlop <domo@slipper.ip.lu> + Msg-ID: <v03007800aee1923e30a2@[194.51.248.68]> + Date: Sat, 21 Dec 1996 15:00:50 +0100 + Files: pod/perllocale.pod + + Title: "Perlguts, version 26" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199612201943.AA048111018@hpcc123.corp.hp.com> + Date: Fri, 20 Dec 1996 11:43:38 -0800 + Files: pod/perlguts.pod + + Title: "Update pod/Makefile; s/perli18n/perllocale/" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/POSIX/POSIX.pod lib/I18N/Collate.pm pod/Makefile + pod/perl.pod pod/perlmod.pod pod/perlnews.pod pod/roffitall + + Title: "obstruct pod2man doc tweaks" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <3923.851106237@eeyore.ibcinc.com> + Date: Fri, 20 Dec 1996 13:23:57 -0500 + Files: lib/Class/Template.pm lib/Time/tm.pm + + +---------------- +Version 5.003_13 +---------------- + +The watchword here is "synchronization." There were a couple of +show-stopper bugs in 5.003_12, so I'm issuing this patch to bring +everyone up to a common working base. + + CORE LANGUAGE CHANGES + + Title: "Disallow labels named q, qq, qw, qx, s, y, and tr" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Make evals' lexicals visible to nested evals" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_ctl.c + + OTHER CORE CHANGES + + Title: "Fix core dump bug with anoncode" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Allow DESTROY to make refs to dying objects" + From: Chip Salzenberg <chip@atlantic.net> + Files: sv.c + + PORTABILITY + + Title: "Add missing backslash in Configure" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + UTILITIES, LIBRARY, AND EXTENSIONS + + Title: "Include libnet-1.01 instead of old Net::FTP" + From: Graham Barr <Graham.Barr@tiuk.ti.com> + Files: MANIFEST lib/Net/Cmd.pm lib/Net/Domain.pm + lib/Net/DummyInetd.pm lib/Net/FTP.pm lib/Net/NNTP.pm + lib/Net/Netrc.pm lib/Net/POP3.pm lib/Net/SMTP.pm + lib/Net/SNPP.pm lib/Net/Socket.pm lib/Net/Telnet.pm + lib/Net/Time.pm pod/perlmod.pod + + Title: "Use binmode when doing binary FTP" + From: Ilya Zakharevich + Files: lib/Net/FTP.pm + + Title: "Re: Open3.pm tries to close unopened file handle" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzloavmd9h.fsf@eeyore.ibcinc.com> + Date: 18 Dec 1996 22:19:54 -0500 + Files: MANIFEST lib/IPC/Open2.pm lib/IPC/Open3.pm lib/open2.pl + lib/open3.pl pod/perldiag.pod pod/perlfunc.pod t/lib/open2.t + t/lib/open3.t + + Title: "Long-standing problem in Socket module" + From: Spider Boardman <spider@orb.nashua.nh.us> + Msg-ID: <199612190418.XAA07291@Orb.Nashua.NH.US> + Date: Wed, 18 Dec 1996 23:18:14 -0500 + Files: Configure Porting/Glossary config_H config_h.SH + ext/Socket/Socket.pm ext/Socket/Socket.xs + + Title: "flock() constants" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <26669.850977437@eeyore.ibcinc.com> + Date: Thu, 19 Dec 1996 01:37:17 -0500 + Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs pod/perlfunc.pod + + Title: "Re: find2perl . -xdev BROKEN still" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzvi9yig3h.fsf@eeyore.ibcinc.com> + Date: 19 Dec 1996 12:44:34 -0500 + Files: lib/File/Find.pm lib/find.pl lib/finddepth.pl + + DOCUMENTATION + + Title: "small doc tweaks for _12" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <1826.851011557@eeyore.ibcinc.com> + Date: Thu, 19 Dec 1996 11:05:57 -0500 + Files: lib/UNIVERSAL.pm pod/perldiag.pod pod/perltie.pod + + Title: "Re: missing E<> POD directive in perlpod.pod" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzwwueimak.fsf@eeyore.ibcinc.com> + Date: 19 Dec 1996 10:30:43 -0500 + Files: pod/perlpod.pod pod/pod2html.PL + + +---------------- +Version 5.003_12 +---------------- + +This patch is huge. A multitude of bug fixes, new modules (especially +CPAN and Net::FTP), a couple of new Configure variables, updated +docs... it's a long list. And speaking of lists, here's a list of +the more significant changes in 5.003_12: + + CORE LANGUAGE CHANGES + + Title: "Support C<delete @hash{@keys}>" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c op.h opcode.pl pod/perldiag.pod pod/perlfunc.pod pp.c + t/op/delete.t + + Title: "Autovivify scalars" + From: Chip Salzenberg <chip@atlantic.net> + Files: dump.c op.c op.h pp.c pp_hot.c + + Title: "Allow any word, including keyword, as label" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + OTHER CORE CHANGES + + Title: "Allow assignment to empty array values during foreach()" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h global.sym mg.c op.c perl.h pp_hot.c proto.h sv.c + + Title: "Fix nested closures" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c opcode.pl pp.c pp_ctl.c pp_hot.c + + Title: "Fix core dump on auto-vivification" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_hot.c + + Title: "Fix core dump on C<open $undef_var, "X">" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_sys.c + + Title: "Fix -T/-B on globs and globrefs" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_sys.c + + Title: "Fix memory management of $`, $&, and $'" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_hot.c regexec.c + + Title: "Fix paren matching during backtracking" + From: Chip Salzenberg <chip@atlantic.net> + Files: regexec.c + + Title: "Fix memory leak and std{in,out,err} death in perl_{con,de}str + From: Chip Salzenberg <chip@atlantic.net> + Files: miniperlmain.c perl.c perl.h sv.c + + Title: "Discard garbage bytes at end of prototype()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Fix local($pack::{foo})" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym pp.c pp_hot.c proto.h scope.c + + Title: "Fix for AmigaOS - inplace operation" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724601@Armageddon.meb.uni-bonn.de> + Date: Sun, 08 Dec 1996 15:33:00 +0100 + Files: doio.c + + Title: "Disable warn, die, and parse hooks _before_ global destruction + From: Chip Salzenberg <chip@atlantic.net> + Files: perl.c + + Title: "Re: Bug in formline " + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199612081958.OAA26025@aatma.engin.umich.edu> + Date: Sun, 08 Dec 1996 14:58:32 -0500 + Files: pp_ctl.c + + Title: "Fix C<@a = ($a,$b,$c,$d) = (1,2)>" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_hot.c + + Title: "Fix %ENV assignment when environment starts out empty" + From: Chip Salzenberg <chip@atlantic.net> + Files: hv.c + + Title: "Properly support and document newRV{,_inc,_noinc}" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym pod/perlguts.pod sv.c sv.h + + Title: "Support SvREADONLY on arrays" + From: Chip Salzenberg <chip@atlantic.net> + Files: av.c + + Title: "Allow lvalue pos inside recursive function" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c pp.c pp_ctl.c pp_hot.c + + PORTABILITY + + Title: "Eliminate PerlIO warnings when setting cnt to -1" + From: Chip Salzenberg <chip@atlantic.net> + Files: perlio.c + + Title: "Make $privlib contents compatible with 5.003" + From: Chip Salzenberg <chip@atlantic.net> + Files: INSTALL ext/Opcode/Safe.pm installperl lib/FileHandle.pm + lib/Test/Harness.pm + + Title: "Support $bincompat3 config variable; update metaconfig units" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure MANIFEST compat3.sym config_h.SH embed.pl global.sym + old_embed.pl old_global.sym old_perl_exp.SH perl_exp.SH + + Title: "Look for gettimeofday() in Configure" + From: John Hughes <john@AtlanTech.COM> + Msg-ID: <01BBE77A.F6F37F80@malvinas.AtlanTech.COM> + Date: Wed, 11 Dec 1996 15:49:57 +0100 + Files: Configure config_H config_h.SH pp.c + + Title: "Make $startperl a relative path if people want portable scrip + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + Title: "Homogenize use of "eval exec" hack" + From: Chip Salzenberg <chip@atlantic.net> + Files: Porting/Glossary eg/README eg/nih eg/sysvipc/ipcmsg + eg/sysvipc/ipcsem eg/sysvipc/ipcshm lib/diagnostics.pm + makeaperl.SH pod/checkpods.PL pod/perlrun.pod + pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL + pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL + utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL x2p/a2py.c + x2p/find2perl.PL x2p/s2p.PL + + Title: "LynxOS support" + From: seibert@Lynx.COM (Greg Seibert) + Msg-ID: <m0vYEsY-0000IZC@kzinti.lynx.com> + Date: Thu, 12 Dec 1996 09:25:00 PST + Files: Configure MANIFEST hints/lynxos.sh t/op/stat.t + + Title: "In Linux hints, set suidsafe=no and dosuid=yes" + From: Chip Salzenberg <chip@atlantic.net> + Files: hints/linux.sh + + Title: "5.003_11 on UnixWare 2.1.1 - Only one small UnixWare buglet" + From: aburlison@cix.compulink.co.uk (Alan Burlison) + Msg-ID: <memo.453720@cix.compulink.co.uk> + Date: Wed, 11 Dec 96 18:34 GMT0 + Files: hints/svr4.sh + + Title: "Re: db-recno.t failures with _11 on Freebsd 2.1-stable" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzohg0r5tr.fsf@eeyore.ibcinc.com> + Date: 11 Dec 1996 18:58:56 -0500 + Files: INSTALL hints/freebsd.sh + + Title: "OS/2 updates from Ilya" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: README.os2 os2/Changes os2/Makefile.SHs os2/os2.c os2/os2ish.h + + Title: "VMS patches to 5.003_11" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01ICTR32LCZG001A1D@hmivax.humgen.upenn.edu> + Date: Mon, 09 Dec 1996 23:16:10 -0500 (EST) + Files: MANIFEST regexec.c t/lib/filehand.t util.c vms/* + + TESTING + + Title: "recurse recurse recurse ..." + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199612092144.XAA29025@alpha.hut.fi> + Date: Mon, 9 Dec 1996 23:44:27 +0200 (EET) + Files: MANIFEST t/op/recurse.t + + UTILITIES, LIBRARY, AND EXTENSIONS + + Title: "Add CPAN and Net::FTP" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm + lib/Net/FTP.pm lib/Net/Netrc.pm lib/Net/Socket.pm + pod/perlmod.pod + + Title: "Please update Text::Wrap and Text::Tabs" + From: David Muir Sharnoff <muir@idiom.com> + Msg-ID: <199612180659.WAA24957@idiom.com> + Date: Tue, 17 Dec 1996 22:59:59 -0800 (PST) + Files: lib/Text/Tabs.pm lib/Text/Wrap.pm + + Title: "Add File::Compare" + From: Nick Ing-Simmons <nik@tiuk.ti.com> + Msg-ID: <199612161844.SAA02152@pluto> + Date: Mon, 16 Dec 1996 18:44:59 GMT + Files: MANIFEST lib/File/Compare.pm pod/perlmod.pod + + Title: "Add Tie::RefHash" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199612152358.SAA28665@aatma.engin.umich.edu> + Date: Sun, 15 Dec 1996 18:58:08 -0500 + Files: MANIFEST lib/Tie/RefHash.pm pod/perlmod.pod + + Title: "Put "splain" in utils." + From: Chip Salzenberg <chip@atlantic.net> + Files: Makefile.SH installperl utils/Makefile utils/splain.PL + + Title: "Some h2ph fixes" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199612131934.AA289845652@hpcc123.corp.hp.com> + Date: Fri, 13 Dec 1996 11:34:12 -0800 + Files: utils/h2ph.PL + + Title: "xsubpp patch to add #line" + From: nick@ni-s.u-net.com (Nick Ing-Simmons) + Msg-ID: <199612162153.VAA03590@ni-s.u-net.com> + Date: Mon, 16 Dec 1996 21:53:56 GMT + Files: lib/ExtUtils/xsubpp + + Title: "Re: Proposed addition to File::Copy: move" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01ICZBN0LRC8001A1D@hmivax.humgen.upenn.edu> + Date: Sat, 14 Dec 1996 00:27:29 -0500 (EST) + Files: lib/File/Copy.pm t/lib/filecopy.t + + Title: "DB_File 1.09 patch" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9612181037.AA10123@claudius.bfsec.bt.co.uk> + Date: Wed, 18 Dec 96 10:37:58 GMT + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs + + Title: "Debugger update" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612111038.FAA24363@monk.mps.ohio-state.edu> + Date: Wed, 11 Dec 1996 05:38:28 -0500 (EST) + Files: lib/perl5db.pl + + DOCUMENTATION + + Title: "Update pods: perldelta -> perlnews, perli18n -> perllocale" + From: Tom Christiansen and Dominic Dunlop + Files: MANIFEST pod/perl.pod pod/perldelta.pod pod/perli18n.pod + pod/perlnews.pod + + Title: "perltoot.pod" + From: Tom Christiansen <tchrist@mox.perl.com> + Msg-ID: <199612091444.HAA09947@toy.perl.com> + Date: Mon, 09 Dec 1996 07:44:10 -0700 + Files: MANIFEST pod/perltoot.pod + + Title: "Perlguts, version 25" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199612061940.AA055461228@hpcc123.corp.hp.com> + Date: Fri, 6 Dec 96 11:40:27 PST + Files: pod/perlguts.pod + + Title: "pod/perlipc.pod patch" + From: d-lewart@uiuc.edu (Daniel S. Lewart) + Msg-ID: <199612090910.CAA20906@mox.perl.com> + Date: Mon, 9 Dec 96 3:10:02 CST + Files: pod/perlipc.pod + + Title: "pod patches for English errors" + From: Steve Kelem <steve.kelem@xilinx.com> + Msg-ID: <24616.850167191@castor> + Date: Mon, 09 Dec 1996 13:33:11 -0800 + Files: pod/*.pod + + Title: "Misc doc updates" + From: Tom Christiansen <tchrist@mox.perl.com> + Msg-ID: <199612150156.SAA12506@mox.perl.com> + Date: Sat, 14 Dec 1996 18:56:33 -0700 + Files: pod/* + +---------------- +Version 5.003_11 +---------------- + +This patch is (still) closing in on 5.004. Nothing dramatic, lots of +value. + + CORE LANGUAGE CHANGES + + Title: "Fix precedence problems with subs as uniops or listops" + From: Chip Salzenberg <chip@atlantic.net> + Files: perly.c perly.c.diff perly.h perly.y + + Title: "Don't reset $. on open()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_sys.c + + Title: "Support *glob{IO} (eventually deprecate *glob{FILEHANDLE})" + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/perlref.pod pp_hot.c sv.c + + Title: "Don't let expression context force return context" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Properly convert "1E2" et al to IV/UV" + From: Chip Salzenberg <chip@atlantic.net> + Files: doio.c sv.c + + Title: "Fix modulo operator in UV realm" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Fix stat(_) after stat(HANDLE)" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_sys.c + + Title: "Fix: s/// and "$x =~ $y" under 'use locale'" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c toke.c + + OTHER CORE CHANGES + + Title: "Eliminate spurious warning when splicing undefs" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c sv.h + + Title: "Eliminate spurious warning from "x=" operator" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Fix line numbers near control structures" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c perly.c perly.c.diff perly.y proto.h + + Title: "Don't let scalar unpack() underflow stack" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Fix core dump from precedence bug in "@foo" warning" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Move die() to utils.c; add varargs hack to croak()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_ctl.c util.c + + Title: "Avoid memcmp() for magnitude test if it thinks char is signed" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure config_H config_h.SH doop.c + ext/SDBM_File/sdbm/pair.c ext/SDBM_File/sdbm/sdbm.h handy.h + hv.c perl.h pp_hot.c proto.h regexec.c sv.c toke.c util.c + + Title: "Less malloc in magic" + From: Chip Salzenberg <chip@atlantic.net> + Files: mg.c + + Title: "Re: 5.003_09: PADTMP fix" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199611281150.GAA06884@monk.mps.ohio-state.edu> + Date: Thu, 28 Nov 1996 06:50:58 -0500 (EST) + Files: pod/perlguts.pod + + Title: "Fully paramaterize locales; disable all if NO_LOCALE" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/POSIX/POSIX.xs op.c perl.h pp.c pp_sys.c sv.c util.c + + PORTABILITY AND TESTING + + Title: "Bitwise op fix for Alpha" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "hints/dgux.sh update" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <24178.849309616@eeyore.ibcinc.com> + Date: Fri, 29 Nov 1996 18:20:16 -0500 + Files: hints/dgux.sh + + Title: "BUG in hints/hpux.sh" + From: Jeff McDougal <jmcdo@cris.com> + Msg-ID: <32A42C11.7FA2@cris.com> + Date: Tue, 03 Dec 1996 08:33:05 -0500 + Files: hints/hpux.sh + + Title: "VMS patches for 5.003_10" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01ICMALO8NMS001A1D@hmivax.humgen.upenn.edu> + Date: Wed, 04 Dec 1996 16:40:12 -0500 (EST) + Files: EXTERN.h INTERN.h old_perl_exp.SH perl.c perl.h perl_exp.SH + pp.c pp_ctl.c pp_sys.c proto.h sv.c toke.c util.c + utils/perldoc.PL vms/config.vms vms/descrip.mms + vms/gen_shrfls.pl vms/genconfig.pl vms/vmsish.h + + Title: "_10+ under OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612011107.GAA10805@monk.mps.ohio-state.edu> + Date: Sun, 1 Dec 1996 06:07:19 -0500 (EST) + Files: malloc.c os2/diff.configure + + LIBRARY AND EXTENSIONS + + Title: "{in,ob}structive pods" + From: Tom Christiansen <tchrist@mox.perl.com> + Msg-ID: <199611301652.JAA24201@toy.perl.com> + Date: Sat, 30 Nov 1996 09:52:57 -0700 + Files: MANIFEST lib/Class/Template.pm lib/File/stat.pm + lib/Net/hostent.pm lib/Net/netent.pm lib/Net/protoent.pm + lib/Net/servent.pm lib/Time/gmtime.pm lib/Time/localtime.pm + lib/Time/tm.pm lib/User/grent.pm lib/User/pwent.pm + + Title: "FileHandle that 'ISA' IO::File" + From: Nick Ing-Simmons <nik@tiuk.ti.com> + Msg-ID: <199612021718.RAA04416@pluto> + Date: Mon, 2 Dec 1996 17:18:02 GMT + Files: MANIFEST lib/FileHandle.pm + + Title: "Make IO::File::import use its parameters" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/IO/lib/IO/File.pm + + Title: "10+ debugger patch" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199612011137.GAA10864@monk.mps.ohio-state.edu> + Date: Sun, 1 Dec 1996 06:37:31 -0500 (EST) + Files: lib/perl5db.pl perl.c pod/perldebug.pod + + Title: "Don't call CORE::close in file handle DESTROY method" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/IO/lib/IO/Handle.pm + + Title: "Re: Namespace cleanup: Does SDBM need binary compatibility?" + From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no> + Msg-ID: <199612031445.PAA19056@bombur2.uio.no> + Date: Tue, 3 Dec 1996 15:45:27 +0100 (MET) + Files: ext/SDBM_File/sdbm/pair.h ext/SDBM_File/sdbm/sdbm.3 + + Title: "DB_File 1.07" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-btree.t + t/lib/db-recno.t + + Title: "DB_File 1.08" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs + + +---------------- +Version 5.003_10 +---------------- + +This patch is closing in on 5.004. It contains lots of small and +valuable changes, but nothing dramatic. + + CORE LANGUAGE CHANGES + + Title: "Allow &{sub {...}} without warning" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Make parens optional on [gs]ethost and [gs]et{pw,gr} functions + From: John L. Allen <allen@gateway.grumman.com> + Files: toke.c + + Title: "Fix syntax error with "$x [0]" and "$x {y}" and "@x {y}"" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + OTHER CORE CHANGES + + Title: "Fix regex matching of chars with high bit set" + From: Chip Salzenberg <chip@atlantic.net> + Files: regexec.c + + Title: "Hash key memory corruption fix and naming cleanup" + From: Chip Salzenberg <chip@atlantic.net> + Files: hv.c hv.h perl.h + + Title: "Undo broken perf. patch (PADTMP stealing)" + From: Chip Salzenberg <chip@atlantic.net> + Files: sv.c + + Title: "Make SV unstudied in sv_gets()" + From: Chip Salzenberg <chip@atlantic.net> + Files: sv.c + + Title: "Better support for UVs" + From: Paul Marquess + Files: global.sym old_global.sym perl.h pp.c pp.h proto.h sv.c sv.h + + Title: "Minor locale cleanups" + (Accept "POSIX" locale as standard like "C". Reset locale to + 'C' when testing strtod() in t/lib/posix.t.) + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/posix.t util.c + + Title: "Always taint result of sprintf() on float" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c + + Title: "Fix spurious warning from bitwise string ops" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c + + Title: "Eliminate warning on {,sys}read(,$newvar,)" + From: Chip Salzenberg <chip@atlantic.net> + Files: doop.c pp_sys.c + + Title: "Don't call fcntl(fileno(rsfp)) if !rsfp" + From: Chip Salzenberg <chip@atlantic.net> + Files: perl.c + + Title: "Save message when calling __DIE__ hook" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_ctl.c + + Title: "Namespace cleanup" + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym old_global.sym perl.h + + Title: "Modify perl_exp.SH; create old_perl_exp.SH; document old_*" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure INSTALL MANIFEST old_perl_exp.SH perl_exp.SH + + PORTABILITY + + Title: "Reliable signal patch" + From: Kenneth Albanowski <kjahds@kjahds.com> + Msg-ID: <Pine.LNX.3.93.961126053209.294J-100000@kjahds.com> + Date: Tue, 26 Nov 1996 05:40:50 -0500 (EST) + Files: global.sym mg.c old_global.sym perl.h pp_sys.c proto.h util.c + + Title: "Emulate missing flock() with either fcntl() or lockf()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_sys.c + + Title: "3_09: minor patches for OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199611270830.DAA04985@monk.mps.ohio-state.edu> + Date: Wed, 27 Nov 1996 03:30:05 -0500 (EST) + Files: doio.c global.sym malloc.c old_global.sym os2/Makefile.SHs + os2/OS2/ExtAttr/Makefile.PL os2/OS2/PrfDB/Makefile.PL + os2/OS2/Process/Makefile.PL os2/OS2/REXX/Makefile.PL + os2/os2.c os2/os2ish.h perl.h + + Title: "Re: 5.003_09 and QNX" + From: nort@bottesini.harvard.edu (Norton Allen) + Msg-ID: <9611271836.AA14460@bottesini.harvard.edu> + Date: Wed, 27 Nov 96 13:36:06 est + Files: Configure MANIFEST README.qnx hints/qnx.sh qnx/ar qnx/cpp + t/TEST toke.c util.c x2p/proto.h + + Title: "Re: updated patch on the sysread, syswrite for VMS" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01ICB648K2XG001A1D@hmivax.humgen.upenn.edu> + Date: Tue, 26 Nov 1996 17:28:23 -0500 (EST) + Files: t/op/sysio.t + + LIBRARY AND EXTENSIONS + + Title: "Minor patch to debugger" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199611290533.AAA08053@monk.mps.ohio-state.edu> + Date: Fri, 29 Nov 1996 00:33:49 -0500 (EST) + Files: lib/perl5db.pl + + Title: "AutoLoader::AUTOLOAD optimization" + From: nick@ni-s.u-net.com (Nick Ing-Simmons) + Msg-ID: <199611231954.TAA09921@ni-s.u-net.com> + Date: Sat, 23 Nov 1996 19:54:52 GMT + Files: lib/AutoLoader.pm + + Title: "Diagnostic cleanup" + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/diagnostics.pm pod/perldiag.pod + + DOCUMENTATION + + Title: "Improve documentation for sysread() and syswrite()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/perlfunc.pod + + Title: "Document how to use $SIG{ALRM} and alarm()" + From: Roderick Schertler <roderick@ibcinc.com> + Msg-ID: <5898.849026569@eeyore.ibcinc.com> + Date: Tue, 26 Nov 1996 11:42:49 -0500 + Files: pod/perlfunc.pod + + +---------------- +Version 5.003_09 +---------------- + +This patch was a compendium of various fixes and enhancements from +many people, including some serious improvement in lexical variable +scoping and locale handling. + + CORE LANGUAGE CHANGES + + Title: "Lexical locales" + (make effectiveness of locales depend on C<use locale>) + From: Chip Salzenberg <chip@atlantic.net> + Files: too many to list + + Title: "Lexical scoping cleanup" + (tighten scoping of lexical variables, somewhat on the + new constructs and somewhat on the old) + From: Chip Salzenberg <chip@atlantic.net> + Files: many... but mostly perly.y and toke.c + + Title: "Re: memory corruption / security bug in sysread,syswrite + pa + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199611251946.VAA30459@alpha.hut.fi> + Date: Mon, 25 Nov 1996 21:46:31 +0200 (EET) + Files: MANIFEST pod/perldiag.pod pod/perlfunc.pod pp_sys.c + t/op/sysio.t + + OTHER CORE CHANGES + + Title: "Configure fix for handling DynaLoader" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + Title: "Properly prototype safe{malloc,calloc,realloc,free}." + From: Chip Salzenberg <chip@atlantic.net> + Files: proto.h + + Title: "UnixWare 2.1 fix for perl5.003_08 - cope with fp->_cnt < -1, + From: John Hughes <john@AtlanTech.COM> + Msg-ID: <01BBD6EE.E915C860@malvinas.AtlanTech.COM> + Date: Wed, 20 Nov 1996 14:27:06 +0100 + Files: sv.c + + Title: ""static" call to UNIVERSAL::can" + From: Nick.Ing-Simmons@tiuk.ti.com + Msg-ID: <199611211547.PAA15878@pluto> + Date: Thu, 21 Nov 1996 15:47:46 GMT + Files: universal.c + + Title: "die -> croak" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199611212111.QAA17070@aatma.engin.umich.edu> + Date: Thu, 21 Nov 1996 16:11:21 -0500 + Files: pp_ctl.c + + Title: "Patch for embed.pl when !EMBED && !MULTIPLICITY" + From: Chip Salzenberg <chip@atlantic.net> + Files: embed.pl + + Title: "Add new symbols to old_global.sym, too." + From: Chip Salzenberg <chip@atlantic.net> + Files: global.sym old_global.sym + + Title: "Cleanup of {,un}pack('w')." + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Cleanups from Ilya." + From: Chip Salzenberg <chip@atlantic.net> + Files: gv.c malloc.c pod/perlguts.pod pp_ctl.c + + Title: "Fix for unpack('w') on 64-bit systems." + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Re: LC_NUMERIC support is ready + performance" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199611260308.WAA02677@monk.mps.ohio-state.edu> + Date: Mon, 25 Nov 1996 22:08:27 -0500 (EST) + Files: sv.c + + Title: "Hash key sharing improvements from Ilya." + From: Chip Salzenberg <chip@atlantic.net> + Files: hv.c hv.h proto.h + + Title: "Mortal stack pre-allocation from Ilya." + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c + + PORTABILITY + + Title: "VMS patches post-5.003_08" + From: bailey@hmivax.humgen.upenn.edu (Charles Bailey) + Msg-ID: <1996Nov22.181631.1603238@hmivax.humgen.upenn.edu> + Date: Fri, 22 Nov 1996 18:16:31 -0500 (EST) + Files: lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm + lib/ExtUtils/MakeMaker.pm lib/File/Path.pm mg.c pp_ctl.c + utils/h2xs.PL vms/config.vms vms/descrip.mms + vms/gen_shrfls.pl vms/genconfig.pl vms/perlvms.pod vms/vms.c + vms/vmsish.h + + Title: "5.003_08: OS/2-specific bugs/enhancements" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199611241147.GAA00490@monk.mps.ohio-state.edu> + Date: Sun, 24 Nov 1996 06:47:25 -0500 (EST) + Files: README.os2 hints/os2.sh os2/Changes os2/Makefile.SHs + os2/OS2/PrfDB/PrfDB.pm os2/os2.c + + Title: "HP patches didn't make it into _08 (fwd)" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199611260215.AA100414526@hpcc123.corp.hp.com> + Date: Mon, 25 Nov 96 18:15:26 PST + Files: ext/DynaLoader/dl_hpux.xs + + Title: "Another HP "patch" that didn't make it (new hints file)" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199611252116.AA245766577@hpcc123.corp.hp.com> + Date: Mon, 25 Nov 1996 13:16:17 -0800 + Files: hints/hpux.sh + + LIBRARY AND EXTENSIONS + + Title: "Elide spurious space in db-hash.t" + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/db-hash.t + + Title: "Update documentation and warning in I18N::Collate." + From: Chip Salzenberg <chip@atlantic.net> + Files: lib/I18N/Collate.pm + + Title: "Fix bitwise op test; clean up a couple of others" + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/bigintpm.t t/op/bop.t t/op/overload.t + + Title: "minimal timelocal.pl for _09" + From: Achim Bohnet <ach@rosat.mpe-garching.mpg.de> + Msg-ID: <9611191854.AA19586@o09.rosat.mpe-garching.mpg.de> + Date: Tue, 19 Nov 1996 19:54:23 +0100 + Files: lib/Time/Local.pm + + Title: "Socket test improvement from Ilya." + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/io_sock.t + + Title: "Re: blib" + From: nick@ni-s.u-net.com (Nick Ing-Simmons) + Msg-ID: <199611230917.JAA00471@ni-s.u-net.com> + Date: Sat, 23 Nov 1996 09:17:40 GMT + Files: lib/blib.pm + + DOCUMENTATION + + Title: "perldiag documentation patch." + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9611201607.AA12729@claudius.bfsec.bt.co.uk> + Date: Wed, 20 Nov 96 16:07:28 GMT + Files: pod/perldiag.pod + + Title: "a missing perldiag entry" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199611212024.PAA15758@aatma.engin.umich.edu> + Date: Thu, 21 Nov 1996 15:24:02 -0500 + Files: pod/perldiag.pod + + Title: "perlfunc patch" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9611201404.AA12477@claudius.bfsec.bt.co.uk> + Date: Wed, 20 Nov 96 14:04:08 GMT + Files: pod/perlfunc.pod + + Title: "Patch for pod/perlpod.pod" + From: "Joseph S. Myers" <jsm28@cam.ac.uk> + Msg-ID: <Pine.LNX.3.95.961120235016.6666A-100000@hammer.chu.cam.ac.uk + Date: Wed, 20 Nov 1996 23:54:41 +0000 (GMT) + Files: pod/perlpod.pod + + Title: "Update locale documentation." + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/perli18n.pod + + BUNDLED UTILITIES + + Title: "Fix type mismatches in x2p's safe{alloc,realloc,free}." + From: Chip Salzenberg <chip@atlantic.net> + Files: x2p/util.c + + +---------------- +Version 5.003_08 +---------------- + +This patch was a compendium of various fixes and enhancements from +many people. Here are some of the more significant changes. + + + CORE LANGUAGE CHANGES + + Title: "Make C<no FOO> fail if C<unimport FOO> fails" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Files: gv.c + + Title: "Bitwise op sign rationalization" + (Make bitwise ops result in unsigned values, unless C<use + integer> is in effect. Includes initial support for UVs.) + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c opcode.pl pod/perlop.pod pod/perltoc.pod pp.c pp.h + pp_hot.c proto.h sv.c t/op/bop.t + + Title: "Defined scoping for C<my> in control structures" + (Finally defines semantics of "my" in control expressions, + like the condition of "if" and "while". In all cases, scope + of a "my" var extends to the end of the entire control + structure. Also adds new construct "for my", which + automatically declares the control variable "my" and limits + its scope to the loop.) + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c perly.c perly.c.diff perly.h perly.y proto.h toke.c + + Title: "Fix ++/-- after int conversion (e.g. 'printf "%d"')" + (This patch makes Perl correctly ignore SvIVX() if either + NOK or POK is true, since SvIVX() may be a truncated or + overflowed version of the real value.) + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c pp_hot.c sv.c + + Title: "Make code match Camel II re: functions that use $_" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Files: opcode.pl + + Title: "Provide scalar context on left side of "->"" + From: Chip Salzenberg <chip@atlantic.net> + Files: perly.c perly.y + + Title: "Quote bearword package/handle FOO in "funcname FOO => 'bar'"" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + + OTHER CORE CHANGES + + Title: "Warn on overflow of octal and hex integers" + From: Chip Salzenberg <chip@atlantic.net> + Files: proto.h toke.c util.c + + Title: "If -w active, warn for commas and hashes ('#') in qw()" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Fixes for pack('w')" + From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> + Files: pp.c t/op/pack.t + + Title: "More complete output from sv_dump()" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: sv.c + + Title: "Major '..' and debugger patches" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h + + Title: "Fix for formline()" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: global.sym mg.c perl.h pod/perldiag.pod pp_ctl.c proto.h sv.c + t/op/write.t + + Title: "Fix stack botch in untie and binmode" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: pp_sys.c + + Title: "Complete EMBED, including symbols from interp.sym" + (New define EMBEDMYMALLOC makes embedding total by + avoiding "Mymalloc" etc.) + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST embed.pl ext/DynaLoader/dlutils.c + ext/SDBM_File/sdbm/sdbm.h global.sym handy.h malloc.c + perl.h pp_sys.c proto.h regexec.c toke.c util.c + x2p/Makefile.SH x2p/a2p.h x2p/handy.h x2p/util.h + + Title: "Support old embedding for people who want it" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST Makefile.SH old_embed.pl old_global.sym + + + PORTABILITY + + Title: "Miscellaneous VMS fixes" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm + lib/Math/Complex.pm lib/Time/Local.pm lib/timelocal.pl + perl.h perl_exp.SH proto.h t/TEST t/io/read.t + t/lib/findbin.t t/lib/getopt.t util.c utils/h2xs.PL + vms/Makefile vms/config.vms vms/descrip.mms + vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs + vms/perlvms.pod vms/test.com vms/vms.c + + Title: "DJGPP patches (MS-DOS)" + From: "Douglas E. Wegscheid" <wegscd@whirlpool.com> + Files: doio.c dosish.h ext/SDBM_File/sdbm/sdbm.c handy.h + lib/AutoSplit.pm lib/Cwd.pm lib/File/Find.pm malloc.c perl.c + perl.h pp_sys.c proto.h sv.c util.c + + Title: "Plan 9 update" + From: Luther Huffman <lutherh@infinet.com> + Files: plan9/buildinfo plan9/config.plan9 plan9/exclude + plan9/genconfig.pl plan9/mkfile plan9/setup.rc + + Title: "Patch to make Perl work under AmigaOS" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Files: MANIFEST hints/amigaos.sh installman lib/File/Basename.pm + lib/File/Find.pm pod/pod2man.PL pp_sys.c util.c + + LIBRARY AND EXTENSIONS + + Title: "DB_File 1.05" + From: Paul Marquess (pmarquess@bfsec.bt.co.uk) + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-hash.t + + Title: "Getopts::Std patch for hash support" + From: Stephen Zander <stephen.zander@interlock.mckesson.com> + Files: lib/Getopt/Std.pm + + Title: "Kludge for bareword handles" + (Add 'require IO::Handle' at beginning of FileHandle.pm) + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/FileHandle/FileHandle.pm + + Title: "Re: strtod / strtol patch for POSIX module" + From: hammen@gothamcity.jsc.nasa.gov (David Hammen) + Files: Configure config_h.SH ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod + ext/POSIX/POSIX.xs t/lib/posix.t + + BUNDLED UTILITIES + + Title: "Fix a2p translation of '{print "a" "b" "c"}'" + From: Chip Salzenberg <chip@atlantic.net> + Files: x2p/a2p.c x2p/a2p.y + + ---------------- Version 5.003_07 ---------------- @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $ # -# Generated on Thu Oct 10 15:08:34 EDT 1996 [metaconfig 3.0 PL60] +# Generated on Tue Dec 17 14:33:33 EST 1996 [metaconfig 3.0 PL60] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -227,6 +227,8 @@ baserev='' bin='' binexp='' installbin='' +bincompat3='' +d_bincompat3='' byteorder='' cc='' gccversion='' @@ -284,6 +286,8 @@ d_flexfnam='' d_flock='' d_fork='' d_fsetpos='' +d_ftime='' +d_gettimeod='' d_Gconvert='' d_getgrps='' d_gethent='' @@ -300,6 +304,7 @@ d_getppid='' d_getprior='' d_gnulibc='' d_htonl='' +d_inetaton='' d_isascii='' d_killpg='' d_link='' @@ -338,6 +343,7 @@ d_rename='' d_rmdir='' d_safebcpy='' d_safemcpy='' +d_sanemcmp='' d_select='' d_sem='' d_semctl='' @@ -394,6 +400,9 @@ d_strerrm='' d_strerror='' d_sysernlst='' d_syserrlst='' +d_strtod='' +d_strtol='' +d_strtoul='' d_strxfrm='' d_symlink='' d_syscall='' @@ -769,7 +778,7 @@ case "$sh" in '') cat <<EOM >&2 $me: Fatal Error: I can't find a Bourne Shell anywhere. Usually it's in /bin/sh. How did you even get this far? -Please contact me (Andy Dougherty) at doughera@lafcol.lafayette.edu and +Please contact me (Chip Salzenberg) at chip@atlantic.net and we'll try to straigten this all out. EOM exit 1 @@ -949,7 +958,11 @@ silent='' extractsh='' override='' knowitall='' + rm -f optdef.sh +cat >optdef.sh <<EOS +$startsh +EOS : option parsing while test $# -gt 0; do @@ -1137,7 +1150,7 @@ THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o -and contact the author (doughera@lafcol.lafayette.edu). +and contact the author (chip@atlantic.net). EOM echo $n "Continue? [n] $c" >&4 @@ -1183,6 +1196,7 @@ esac" : now set up to do reads with possible shell escape and default assignment cat <<EOSC >myread +$startsh xxxm=\$dflt $myecho ans='!' @@ -1337,7 +1351,7 @@ Much effort has been expended to ensure that this shell script will run on any Unix system. If despite that it blows up on yours, your best bet is to edit Configure and run it again. If you can't run Configure for some reason, you'll have to generate a config.sh file by hand. Whatever problems you -have, let me (doughera@lafcol.lafayette.edu) know how I blew it. +have, let me (chip@atlantic.net) know how I blew it. This installation script affects things in two ways: @@ -1627,13 +1641,15 @@ EOM cd hints; ls -C *.sh | $sed 's/\.sh/ /g' >&4 dflt='' : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to doughera@lafcol.lafayette.edu + : tests or hints, please send them to chip@atlantic.net : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix $test -f /dynix && osname=dynix $test -f /dnix && osname=dnix - $test -f /unicos && osname=unicos && osvers=`$uname -r` + $test -f /lynx.os && osname=lynxos + $test -f /unicos && osname=unicos && osvers=`$uname -r` + $test -f /unicosmk.ar && osname=unicosmk && osvers=`$uname -r` $test -f /bin/mips && /bin/mips && osname=mips $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \ $sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4 @@ -1759,7 +1775,7 @@ EOM ultrix) osname=ultrix osvers="$3" ;; - osf1) case "$5" in + osf1|mls+) case "$5" in alpha) osname=dec_osf osvers=`echo "$3" | sed 's/^[vt]//'` @@ -1771,10 +1787,13 @@ EOM uts) osname=uts osvers="$3" ;; + qnx) osname=qnx + osvers="$4" + ;; $2) case "$osname" in *isc*) ;; *freebsd*) ;; - svr*) + svr*) : svr4.x or possibly later case "svr$3" in ${osname}*) @@ -2013,7 +2032,8 @@ if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then tarch=`arch`"-$osname" elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then if uname -m > tmparch 2>&1 ; then - tarch=`$sed -e 's/ /_/g' -e 's/$/'"-$osname/" tmparch` + tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \ + -e 's/$/'"-$osname/" tmparch` else tarch="$osname" fi @@ -2102,7 +2122,10 @@ chmod +x filexp $eunicefix filexp : now set up to get a file name -cat <<'EOSC' >getfile +cat <<EOS >getfile +$startsh +EOS +cat <<'EOSC' >>getfile tilde='' fullpath='' already='' @@ -2411,7 +2434,7 @@ else fi : set the base revision -baserev=5.0 +baserev=5 : get the patchlevel echo " " @@ -2423,7 +2446,14 @@ else patchlevel=0 subversion=0 fi -echo "(You have $package $baserev patchlevel $patchlevel subversion $subversion.)" +$echo $n "(You have $package" $c +case "$package" in +"*$baserev") ;; +*) $echo $n " $baserev" $c ;; +esac +$echo $n " patchlevel $patchlevel" $c +test 0 -eq "$subversion" || $echo $n " subversion $subversion" $c +echo ".)" : set the prefixup variable, to restore leading tilda escape prefixup='case "$prefixexp" in @@ -2441,9 +2471,13 @@ case "$archlib" in set dflt eval $prefixup ;; - *) version=`LC_ALL=C;export LC_ALL;\ - echo $baserev $patchlevel $subversion | \ - $awk '{print $1 + $2/1000.0 + $3/100000.0}'` + *) if test 0 -eq "$subversion"; then + version=`echo $baserev $patchlevel | \ + $awk '{ printf "%d.%03d\n",$1,$2 }'` + else + version=`echo $baserev $patchlevel $subversion | \ + $awk '{ printf "%d.%03d%02d\n",$1,$2,$3 }'` + fi dflt="$privlib/$archname/$version" ;; esac @@ -2490,7 +2524,10 @@ else fi : set up the script used to warn in case of inconsistency -cat <<'EOSC' >whoa +cat <<EOS >whoa +$startsh +EOS +cat <<'EOSC' >>whoa dflt=y echo " " echo "*** WHOA THERE!!! ***" >&4 @@ -2510,6 +2547,33 @@ $undef$define) . ./whoa; eval "$var=\$tu";; *) eval "$var=$val";; esac' +$cat <<EOM + +Perl 5.004 can be compiled for binary compatibility with 5.003. +If you decide to do so, you will be able to continue using any +extensions that were compiled for Perl 5.003. However, binary +compatibility forces Perl to expose some of its internal symbols +in the same way that 5.003 did. So you may have symbol conflicts +if you embed a binary-compatible Perl in other programs. + +EOM +case "$d_bincompat3" in +"$undef") dflt=n ;; +*) dflt=y ;; +esac +rp='Binary compatibility with Perl 5.003?' +. ./myread +case "$ans" in +y*) val="$define" ;; +*) val="$undef" ;; +esac +set d_bincompat3 +eval $setvar +case "$d_bincompat3" in +"$define") bincompat3=y ;; +*) bincompat3=n ;; +esac + : make some quick guesses about what we are up against echo " " $echo $n "Hmm... $c" @@ -3206,6 +3270,25 @@ none) libpth=' ';; *) libpth="$ans";; esac +: Define several unixisms. Hints files or command line options +: can be used to override them. +case "$ar" in +'') ar='ar';; +esac +case "$lib_ext" in +'') lib_ext='.a';; +esac +case "$obj_ext" in +'') obj_ext='.o';; +esac +case "$path_sep" in +'') path_sep=':';; +esac +: Which makefile gets called first. This is used by make depend. +case "$firstmakefile" in +'') firstmakefile='makefile';; +esac + : compute shared library extension case "$so" in '') @@ -3252,25 +3335,25 @@ for thislib in $libswanted; do *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac - elif xxx=`./loc lib$thislib.a X $libpth`; $test -f "$xxx"; then + elif xxx=`./loc lib$thislib$lib_ext X $libpth`; $test -f "$xxx"; then echo "Found -l$thislib." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac - elif xxx=`./loc $thislib.a X $libpth`; $test -f "$xxx"; then + elif xxx=`./loc $thislib$lib_ext X $libpth`; $test -f "$xxx"; then echo "Found -l$thislib." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac - elif xxx=`./loc lib${thislib}_s.a X $libpth`; $test -f "$xxx"; then + elif xxx=`./loc lib${thislib}_s$lib_ext X $libpth`; $test -f "$xxx"; then echo "Found -l${thislib}_s." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l${thislib}_s";; esac - elif xxx=`./loc Slib$thislib.a X $xlibpth`; $test -f "$xxx"; then + elif xxx=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$xxx"; then echo "Found -l$thislib." case " $dflt " in *"-l$thislib "*);; @@ -3528,7 +3611,6 @@ if ./osf1; then else set signal.h LANGUAGE_C; eval $inctest fi -set signal.h NO_PROTOTYPE; eval $inctest set signal.h _NO_PROTO; eval $inctest case "$hint" in @@ -3821,7 +3903,7 @@ echo " " case "$libc" in '') libc=unknown case "$libs" in - *-lc_s*) libc=`./loc libc_s.a $libc $libpth` + *-lc_s*) libc=`./loc libc_s$lib_ext $libc $libpth` esac ;; esac @@ -3839,13 +3921,15 @@ case "$libs" in : elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then : - elif try=`./loc lib$thislib.a X $libpth`; $test -f "$try"; then + elif try=`./loc lib$thislib$lib_ext X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib$lib_ext X $libpth`; $test -f "$try"; then : elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then : elif try=`./loc $thislib X $libpth`; $test -f "$try"; then : - elif try=`./loc Slib$thislib.a X $xlibpth`; $test -f "$try"; then + elif try=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$try"; then : else try='' @@ -3876,7 +3960,7 @@ unknown) eval set \$$# done $test -r $1 || set /usr/ccs/lib/libc.$so - $test -r $1 || set /lib/libsys_s.a + $test -r $1 || set /lib/libsys_s$lib_ext ;; *) set blurfl @@ -3895,25 +3979,25 @@ elif $test -r /lib/libc && $test -r /lib/clib; then fi elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then echo "Your C library seems to be in $libc, as you said before." -elif $test -r $incpath/usr/lib/libc.a; then - libc=$incpath/usr/lib/libc.a; +elif $test -r $incpath/usr/lib/libc$lib_ext; then + libc=$incpath/usr/lib/libc$lib_ext; echo "Your C library seems to be in $libc. That's fine." -elif $test -r /lib/libc.a; then - libc=/lib/libc.a; +elif $test -r /lib/libc$lib_ext; then + libc=/lib/libc$lib_ext; echo "Your C library seems to be in $libc. You're normal." else - if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then + if tans=`./loc libc$lib_ext blurfl/dyick $libpth`; $test -r "$tans"; then : elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then libnames="$libnames "`./loc clib blurfl/dyick $libpth` elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then : - elif tans=`./loc Slibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then + elif tans=`./loc Slibc$lib_ext blurfl/dyick $xlibpth`; $test -r "$tans"; then : - elif tans=`./loc Mlibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then + elif tans=`./loc Mlibc$lib_ext blurfl/dyick $xlibpth`; $test -r "$tans"; then : else - tans=`./loc Llibc.a blurfl/dyick $xlibpth` + tans=`./loc Llibc$lib_ext blurfl/dyick $xlibpth` fi if $test -r "$tans"; then echo "Your C library seems to be in $tans, of all places." @@ -4021,6 +4105,10 @@ elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun +elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun else nm -p $* 2>/dev/null >libc.tmp $grep fprintf libc.tmp > libc.ptf @@ -4067,25 +4155,6 @@ fi esac $rm -f libnames libpath -: Define several unixisms. Hints files or command line options -: can be used to override them. -case "$ar" in -'') ar='ar';; -esac -case "$lib_ext" in -'') lib_ext='.a';; -esac -case "$obj_ext" in -'') obj_ext='.o';; -esac -case "$path_sep" in -'') path_sep=':';; -esac -: Which makefile gets called first. This is used by make depend. -case "$firstmakefile" in -'') firstmakefile='makefile';; -esac - : determine filename position in cpp output echo " " echo "Computing filename position in cpp output for #include directives..." >&4 @@ -4591,7 +4660,7 @@ case "$shrpdir" in *) $cat >&4 <<EOM WARNING: Use of the shrpdir variable for the installation location of the shared $libperl is not supported. It was never documented and -will not work in this version. Let me (doughera@lafcol.lafayette.edu) +will not work in this version. Let me (chip@atlantic.net) know of any problems this may cause. EOM @@ -4625,6 +4694,9 @@ if "$useshrplib"; then solaris|netbsd) xxx="-R $shrpdir" ;; + freebsd) + xxx="-Wl,-R$shrpdir" + ;; linux|irix*) xxx="-Wl,-rpath,$shrpdir" ;; @@ -5079,11 +5151,13 @@ case "$myhostname" in echo "(Attempting domain name extraction from $tans)" : Why was there an Egrep here, when Sed works? : Look for either a search or a domain directive. - dflt=.`$sed -n -e 's/^search[ ]*\(.*\)/\1/p' $tans \ - | ./tr '[A-Z]' '[a-z]' 2>/dev/null` + dflt=.`$sed -n -e 's/ / /g' \ + -e 's/^search *\([^ ]*\).*/\1/p' $tans \ + | ./tr '[A-Z]' '[a-z]' 2>/dev/null` case "$dflt" in - .) dflt=.`$sed -n -e 's/^domain[ ]*\(.*\)/\1/p' $tans \ - | ./tr '[A-Z]' '[a-z]' 2>/dev/null` + .) dflt=.`$sed -n -e 's/ / /g' \ + -e 's/^domain *\([^ ]*\).*/\1/p' $tans \ + | ./tr '[A-Z]' '[a-z]' 2>/dev/null` ;; esac fi @@ -5199,6 +5273,63 @@ rp='Perl administrator e-mail address' . ./myread perladmin="$ans" +: figure out how to guarantee perl startup +case "$startperl" in +'') + case "$sharpbang" in + *!) + $cat <<EOH + +I can use the #! construct to start perl on your system. This will +make startup of perl scripts faster, but may cause problems if you +want to share those scripts and perl is not in a standard place +($binexp/perl) on all your platforms. The alternative is to force +a shell by starting the script with a single ':' character. + +EOH + dflt="$binexp/perl" + rp='What shall I put after the #! to start up perl ("none" to not use #!)?' + . ./myread + case "$ans" in + none) startperl=": # use perl";; + *) startperl="#!$ans";; + esac + ;; + *) startperl=": # use perl" + ;; + esac + ;; +esac +echo "I'll use $startperl to start perl scripts." + +: figure best path for perl in scripts +case "$perlpath" in +'') + perlpath="$binexp/perl" + case "$startperl" in + *!*) ;; + *) + $cat <<EOH + +I will use the "eval 'exec'" idiom to start Perl on your system. +I can use the full path of your Perl binary for this purpose, but +doing so may cause problems if you want to share those scripts and +Perl is not always in a standard place ($binexp/perl). + +EOH + dflt="$binexp/perl" + rp="What path shall I use in \"eval 'exec'\"?" + . ./myread + perlpath="$ans" + ;; + esac + ;; +esac +case "$startperl" in +*!*) ;; +*) echo "I'll use $perlpath in \"eval 'exec'\"" ;; +esac + : determine where public executable scripts go set scriptdir scriptdir eval $prefixit @@ -5252,40 +5383,6 @@ else installscript="$scriptdirexp" fi -: determine perl absolute location -case "$perlpath" in -'') perlpath=$binexp/perl ;; -esac - -: figure out how to guarantee perl startup -case "$startperl" in -'') - case "$sharpbang" in - *!) - $cat <<EOH - -I can use the #! construct to start perl on your system. This will -make startup of perl scripts faster, but may cause problems if you -want to share those scripts and perl is not in a standard place -($perlpath) on all your platforms. The alternative is to force -a shell by starting the script with a single ':' character. - -EOH - dflt=$perlpath - rp='What shall I put after the #! to start up perl ("none" to not use #!)?' - . ./myread - case "$ans" in - none) startperl=": # use perl";; - *) startperl="#!$ans";; - esac - ;; - *) startperl=": # use perl" - ;; - esac - ;; -esac -echo "I'll use $startperl to start perl scripts." - cat <<EOM Previous version of $package used the standard IO mechanisms as defined in @@ -5894,19 +5991,19 @@ if set crypt val -f d_crypt; eval $csym; $val; then val="$define" cryptlib='' else - cryptlib=`./loc Slibcrypt.a "" $xlibpth` + cryptlib=`./loc Slibcrypt$lib_ext "" $xlibpth` if $test -z "$cryptlib"; then - cryptlib=`./loc Mlibcrypt.a "" $xlibpth` + cryptlib=`./loc Mlibcrypt$lib_ext "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then - cryptlib=`./loc Llibcrypt.a "" $xlibpth` + cryptlib=`./loc Llibcrypt$lib_ext "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then - cryptlib=`./loc libcrypt.a "" $libpth` + cryptlib=`./loc libcrypt$lib_ext "" $libpth` else cryptlib=-lcrypt fi @@ -6109,22 +6206,25 @@ main() #endif handle = dlopen("./dyna.$dlext", mode) ; if (handle == NULL) { - printf ("1\n") ; - exit(0); + printf ("1\n") ; + fflush (stdout) ; + exit(0); } symbol = dlsym(handle, "fred") ; if (symbol == NULL) { - /* try putting a leading underscore */ - symbol = dlsym(handle, "_fred") ; - if (symbol == NULL) { - printf ("2\n") ; - exit(0); - } - printf ("3\n") ; + /* try putting a leading underscore */ + symbol = dlsym(handle, "_fred") ; + if (symbol == NULL) { + printf ("2\n") ; + fflush (stdout) ; + exit(0); + } + printf ("3\n") ; } else - printf ("4\n") ; - exit(0); + printf ("4\n") ; + fflush (stdout) ; + exit(0); } EOM : Call the object file tmp-dyna.o in case dlext=o. @@ -6318,7 +6418,9 @@ main() } EOCP if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1; then - echo "$startsh" >mtry + cat <<EOS >mtry +$startsh +EOS echo "./try >try.out 2>try.ret 3>try.err || exit 4" >>mtry chmod +x mtry ./mtry >/dev/null 2>&1 @@ -6354,7 +6456,7 @@ EOCP *) echo "However, your read() returns '$status' on EOF??";; esac val="$define" - if test "$status" -eq "$rd_nodata"; then + if test "$status" = "$rd_nodata"; then echo "WARNING: you can't distinguish between EOF and no data!" val="$undef" fi @@ -6440,6 +6542,25 @@ eval $inlibc set getpriority d_getprior eval $inlibc +: see if gettimeofday or ftime exists +set gettimeofday d_gettimeod +eval $inlibc +case "$d_gettimeod" in +"$undef") + set ftime d_ftime + eval $inlibc + ;; +*) + val="$undef"; set d_ftime; eval $setvar + ;; +esac +case "$d_gettimeod$d_ftime" in +"$undef$undef") + echo " " + echo 'No ftime() nor gettimeofday() -- timing may be less accurate.' >&4 + ;; +esac + : see if this is a netinet/in.h or sys/in.h system set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr @@ -6533,6 +6654,10 @@ set d_strchr; eval $setvar val="$vali" set d_index; eval $setvar +: check whether inet_aton exists +set inet_aton d_inetaton +eval $inlibc + : Look for isascii echo " " $cat >isascii.c <<'EOCP' @@ -7023,6 +7148,60 @@ $rm -f foo.* safemcpy core set d_safemcpy eval $setvar +: can memcmp be trusted to compare relative magnitude? +val="$undef" +case "$d_memcmp" in +"$define") + echo " " + echo "Checking to see if your memcmp() can compare relative magnitude..." >&4 + $cat >foo.c <<EOCP +#$i_memory I_MEMORY +#$i_stdlib I_STDLIB +#$i_string I_STRING +#$i_unistd I_UNISTD +EOCP + $cat >>foo.c <<'EOCP' +#include <stdio.h> + +#ifdef I_MEMORY +# include <memory.h> +#endif +#ifdef I_STDLIB +# include <stdlib.h> +#endif +#ifdef I_STRING +# include <string.h> +#else +# include <strings.h> +#endif +#ifdef I_UNISTD +# include <unistd.h> /* Needed for NetBSD */ +#endif +main() +{ +char a = -1; +char b = 0; +if ((a < b) && memcmp(&a, &b, 1) < 0) + exit(1); +exit(0); +} +EOCP + if $cc $ccflags $ldflags foo.c -o sanemcmp $libs >/dev/null 2>&1; then + if ./sanemcmp 2>/dev/null; then + echo "Yes, it can." + val="$define" + else + echo "No, it can't (it uses signed chars)." + fi + else + echo "(I can't compile the test program, so we'll assume not...)" + fi + ;; +esac +$rm -f foo.* sanemcmp core +set d_sanemcmp +eval $setvar + : see if select exists set select d_select eval $inlibc @@ -7316,10 +7495,10 @@ else : we will have to assume that it supports the 4.2 BSD interface d_oldsock="$undef" else - echo "You don't have Berkeley networking in libc.a..." >&4 - if test -f /usr/lib/libnet.a; then - ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ - ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list + echo "You don't have Berkeley networking in libc$lib_ext..." >&4 + if test -f /usr/lib/libnet$lib_ext; then + ( (nm $nm_opt /usr/lib/libnet$lib_ext | eval $nm_extract) || \ + ar t /usr/lib/libnet$lib_ext) 2>/dev/null >> libc.list if $contains socket libc.list >/dev/null 2>&1; then echo "...but the Wollongong group seems to have hacked it in." >&4 socketlib="-lnet" @@ -7332,7 +7511,7 @@ else d_oldsock="$define" fi else - echo "or even in libnet.a, which is peculiar." >&4 + echo "or even in libnet$lib_ext, which is peculiar." >&4 d_socket="$undef" d_oldsock="$undef" fi @@ -7598,6 +7777,18 @@ else d_strerrm='"unknown"' fi +: see if strtod exists +set strtod d_strtod +eval $inlibc + +: see if strtol exists +set strtol d_strtol +eval $inlibc + +: see if strtoul exists +set strtoul d_strtoul +eval $inlibc + : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc @@ -8394,14 +8585,14 @@ EOP $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.a bar2.o bar1.o >/dev/null 2>&1 -if $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /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." orderlib=false ranlib=":" -elif ar ts bar.a >/dev/null 2>&1 && - $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /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'." orderlib=false @@ -8870,6 +9061,7 @@ main() printf("int\n"); else printf("long\n"); + fflush(stdout); exit(0); } EOM @@ -9444,19 +9636,22 @@ known_extensions='' : some additional extensions into the source tree and expect them : to be built. for xxx in * ; do - if $test -f $xxx/$xxx.xs; then - known_extensions="$known_extensions $xxx" + case "$xxx" in + DynaLoader) ;; + *) if $test -f $xxx/$xxx.xs; then + known_extensions="$known_extensions $xxx" else - if $test -d $xxx; then - cd $xxx - for yyy in * ; do - if $test -f $yyy/$yyy.xs; then - known_extensions="$known_extensions $xxx/$yyy" - fi - done - cd .. - fi - fi + if $test -d $xxx; then + cd $xxx + for yyy in * ; do + if $test -f $yyy/$yyy.xs; then + known_extensions="$known_extensions $xxx/$yyy" + fi + done + cd .. + fi + fi ;; + esac done set X $known_extensions shift @@ -9669,6 +9864,7 @@ awk='$awk' baserev='$baserev' bash='$bash' bin='$bin' +bincompat3='$bincompat3' binexp='$binexp' bison='$bison' byacc='$byacc' @@ -9708,6 +9904,7 @@ d_archlib='$d_archlib' d_attribut='$d_attribut' d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' +d_bincompat3='$d_bincompat3' d_bsd='$d_bsd' d_bsdgetpgrp='$d_bsdgetpgrp' d_bsdpgrp='$d_bsdpgrp' @@ -9746,6 +9943,7 @@ d_flock='$d_flock' d_fork='$d_fork' d_fpathconf='$d_fpathconf' d_fsetpos='$d_fsetpos' +d_ftime='$d_ftime' d_getgrps='$d_getgrps' d_gethent='$d_gethent' d_gethname='$d_gethname' @@ -9755,9 +9953,11 @@ d_getpgrp2='$d_getpgrp2' d_getpgrp='$d_getpgrp' d_getppid='$d_getppid' d_getprior='$d_getprior' +d_gettimeod='$d_gettimeod' d_gnulibc='$d_gnulibc' d_htonl='$d_htonl' d_index='$d_index' +d_inetaton='$d_inetaton' d_isascii='$d_isascii' d_killpg='$d_killpg' d_link='$d_link' @@ -9803,6 +10003,7 @@ d_rewinddir='$d_rewinddir' d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' d_safemcpy='$d_safemcpy' +d_sanemcmp='$d_sanemcmp' d_seekdir='$d_seekdir' d_select='$d_select' d_sem='$d_sem' @@ -9845,6 +10046,9 @@ d_strcoll='$d_strcoll' d_strctcpy='$d_strctcpy' d_strerrm='$d_strerrm' d_strerror='$d_strerror' +d_strtod='$d_strtod' +d_strtol='$d_strtol' +d_strtoul='$d_strtoul' d_strxfrm='$d_strxfrm' d_suidsafe='$d_suidsafe' d_symlink='$d_symlink' @@ -15,12 +15,18 @@ */ #undef EXT #undef dEXT +#undef EXTCONST +#undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) # define EXT globalref # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare +# define EXTCONST globalref +# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else # define EXT extern # define dEXT +# define EXTCONST extern const +# define dEXTCONST const #endif #undef INIT @@ -11,6 +11,11 @@ The basic steps to build and install perl5 on a Unix system are: make make test make install + # possibly add these: + (cd /usr/include && h2ph *.h sys/*.h) + cd pod; make html && mv *.html <www home dir> && cd .. + cd pod; make tex && <process the latex files> && cd .. + Each of these is explained in further detail below. @@ -120,12 +125,12 @@ you can use the Configure command line option -Uusedl. By default, Configure will offer to build every extension which appears to be supported. For example, Configure will offer to build GDBM_File only if it is able to find the gdbm library. (See examples below.) -DynaLoader, Fcntl, FileHandle and IO are always built by default. -Configure does not contain code to test for POSIX compliance, so POSIX -is always built by default as well. If you wish to skip POSIX, you can -set the Configure variable useposix=false either in a hint file or from -the Configure command line. Similarly, the Opcode extension is always -built by default, but you can skip it by setting the Configure variable +DynaLoader, Fcntl, and IO are always built by default. Configure does +not contain code to test for POSIX compliance, so POSIX is always built +by default as well. If you wish to skip POSIX, you can set the +Configure variable useposix=false either in a hint file or from the +Configure command line. Similarly, the Opcode extension is always built +by default, but you can skip it by setting the Configure variable useopcode=false either in a hint file for from the command line. Even if you do not have dynamic loading, you must still build the @@ -138,7 +143,6 @@ to turn off each extension: DB_File i_db DynaLoader (Must always be included as a static extension) Fcntl (Always included by default) - FileHandle (Always included by default) GDBM_File i_gdbm IO (Always included by default) NDBM_File i_ndbm @@ -311,11 +315,11 @@ just put their local extensions in with the standard distribution. In order to support using things like #!/usr/local/bin/perl5.002 after a later version is released, architecture-dependent libraries are stored in a version-specific directory, such as -/usr/local/lib/perl5/archname/5.002/. In 5.000 and 5.001, these files -were just stored in /usr/local/lib/perl5/archname/. If you will not be -using 5.001 binaries, you can delete the standard extensions from the -/usr/local/lib/perl5/archname/ directory. Locally-added extensions can -be moved to the site_perl and site_perl/archname directories. +/usr/local/lib/perl5/archname/5.002/. In Perl 5.000 and 5.001, these +files were just stored in /usr/local/lib/perl5/archname/. If you will +not be using 5.001 binaries, you can delete the standard extensions from +the /usr/local/lib/perl5/archname/ directory. Locally-added extensions +can be moved to the site_perl and site_perl/archname directories. Again, these are just the defaults, and can be changed as you run Configure. @@ -402,7 +406,7 @@ Your system and typical applications may well give quite different results. The default name for the shared library is typically something like -libperl.so.3.2 (for perl5.003_02) or libperl.so.302 or simply +libperl.so.3.2 (for Perl 5.003_02) or libperl.so.302 or simply libperl.so. Configure tries to guess a sensible naming convention based on your C library name. Since the library gets installed in a version-specific architecture-dependent directory, the exact name @@ -432,8 +436,8 @@ LD_LIBRARY_PATH above. There is also an potential problem with the shared perl library if you want to have more than one "flavor" of the same version of perl (e.g. with and without -DDEBUGGING). For example, suppose you build and -install a standard perl5.004 with a shared library. Then, suppose you -try to build perl5.004 with -DDEBUGGING enabled, but everything else +install a standard Perl 5.004 with a shared library. Then, suppose you +try to build Perl 5.004 with -DDEBUGGING enabled, but everything else the same, including all the installation directories. How can you ensure that your newly built perl will link with your newly built libperl.so.4 rather with the installed libperl.so.4? The answer is @@ -641,6 +645,17 @@ various other operating systems. =back +=head1 Binary Compatibility With Perl 5.003 + +Perl 5.003 turned on the EMBED feature by default, which tries to +avoid possible symbol name conflict by prefixing all global symbols +with "Perl_". However, its list of global symbols was incomplete. +This error has been rectified in Perl 5.004. + +However, some sites may need to maintain complete binary compatibility +with Perl 5.003. If you are building Perl for such a site, then when +B<Configure> asks if you want binary compatibility, answer "y". + =head1 make depend This will look for all the includes. @@ -863,6 +878,11 @@ If you get syntax errors on '(', try -DCRIPPLED_CC. Machines with half-implemented dbm routines will need to #undef I_ODBM +db-recno failure on tests 51, 53 and 55: Old versions of the DB library +(including the DB library which comes with FreeBSD 2.1) had broken +handling of recno databases with modified bval settings. Upgrade your +DB library or OS. + =back =head1 make test @@ -992,14 +1012,14 @@ You can safely install the current version of perl5 and still run scripts under the old binaries for versions 5.003 and later ONLY. Instead of starting your script with #!/usr/local/bin/perl, just start it with #!/usr/local/bin/perl5.003 (or whatever version you want to run.) -If you want to retain a version of perl5 prior to perl5.003, you'll +If you want to retain a version of Perl 5 prior to 5.003, you'll need to install the current version in a separate directory tree, since some of the architecture-independent library files have changed in incompatible ways. The architecture-dependent files are stored in a version-specific directory (such as F</usr/local/lib/perl5/sun4-sunos/5.002>) so that -they are still accessible. I<Note:> perl5.000 and perl5.001 did not +they are still accessible. I<Note:> Perl 5.000 and 5.001 did not put their architecture-dependent libraries in a version-specific directory. They are simply in F</usr/local/lib/perl5/$archname>. If you will not be using 5.000 or 5.001, you may safely remove those @@ -1012,7 +1032,7 @@ Most extensions will probably not need to be recompiled to use with a newer version of perl. If you do run into problems, and you want to continue to use the old version of perl along with your extension, simply move those extension files to the appropriate version directory, such as -F</usr/local/lib/perl/archname/5.002>. Then perl5.002 will find your +F</usr/local/lib/perl/archname/5.002>. Then Perl 5.002 will find your files in the 5.002 directory, and newer versions of perl will find your newer extension in the site_perl directory. @@ -1026,7 +1046,7 @@ and adding /opt/perl5.002/bin to the shell PATH variable. Such users may also wish to add a symbolic link /usr/local/bin/perl so that scripts can still start with #!/usr/local/bin/perl. -B<NOTE>: Starting with 5.002_01, all functions in the perl C source +B<NOTE>: Starting with Perl 5.002_01, all functions in the perl C source code are protected by default by the prefix Perl_ (or perl_) so that you may link with third-party libraries without fear of namespace collisons. This breaks compatability with @@ -1069,4 +1089,4 @@ from the original README by Larry Wall. =head1 LAST MODIFIED -9 October 1996 +24 December 1996 @@ -15,12 +15,18 @@ */ #undef EXT #undef dEXT +#undef EXTCONST +#undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) # define EXT globaldef {"$GLOBAL_RW_VARS"} noshare # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare +# define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly +# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else # define EXT # define dEXT +# define EXTCONST const +# define dEXTCONST const #endif #undef INIT @@ -1,27 +1,29 @@ Artistic The "Artistic License" -Changes Differences from previous versions. -Changes5.000 Differences from perl4. -Changes5.001 Differences from 5.000. -Changes5.002 Differences from 5.001. -Changes5.003 Differences from 5.002. -configure Crude emulation of GNU configure +Changes Differences from previous version +Changes5.000 Differences between 4.x and 5.000 +Changes5.001 Differences between 5.000 and 5.001 +Changes5.002 Differences between 5.001 and 5.002 +Changes5.003 Differences between 5.002 and 5.003 Configure Portability tool +configure Crude emulation of GNU configure Copying The GNU General Public License EXTERN.h Included before foreign .h files -INSTALL Detailed installation instructions. +INSTALL Detailed installation instructions INTERN.h Included before domestic .h files MANIFEST This list of files Makefile.SH A script that generates Makefile -Porting/Glossary Glossary of config.sh variables. +Porting/Glossary Glossary of config.sh variables README The Instructions README.os2 Notes about OS/2 port README.plan9 Notes about Plan9 port +README.qnx Notes about QNX port README.vms Notes about VMS port Todo The Wishlist XSUB.h Include file for extension subroutines av.c Array value code av.h Array value header cflags.SH A script that emits C compilation flags per file +compat3.sym List of symbols for binary-compatibility with 5.003 config_H Sample config.h config_h.SH Produces config.h configpm Produces lib/Config.pm @@ -93,15 +95,11 @@ ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation ext/DynaLoader/dl_next.xs Next implementation ext/DynaLoader/dl_none.xs Stub implementation -ext/DynaLoader/dl_os2.xs OS/2 implementation ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/Fcntl/Fcntl.pm Fcntl extension Perl module ext/Fcntl/Fcntl.xs Fcntl extension external subroutines ext/Fcntl/Makefile.PL Fcntl extension makefile writer -ext/FileHandle/FileHandle.pm FileHandle extension Perl module -ext/FileHandle/FileHandle.xs FileHandle extension external subroutines -ext/FileHandle/Makefile.PL FileHandle extension makefile writer ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/Makefile.PL GDBM extension makefile writer @@ -109,6 +107,7 @@ ext/GDBM_File/typemap GDBM extension interface types ext/IO/IO.pm Top-level interface to IO::* classes ext/IO/IO.xs IO extension external subroutines ext/IO/Makefile.PL IO extension makefile writer +ext/IO/README IO extension maintenance notice ext/IO/lib/IO/File.pm IO::File extension Perl module ext/IO/lib/IO/Handle.pm IO::Handle extension Perl module ext/IO/lib/IO/Pipe.pm IO::Pipe extension Perl module @@ -198,12 +197,14 @@ h2pl/tcbreak2 cbreak test routine using .pl handy.h Handy definitions hints/3b1.sh Hints for named architecture hints/3b1cc Hints for named architecture -hints/README.NeXT Notes about NeXT hints. -hints/README.hints Notes about hints. +hints/README.NeXT Notes about NeXT hints +hints/README.hints Notes about hints hints/aix.sh Hints for named architecture hints/altos486.sh Hints for named architecture +hints/amigaos.sh Hints for named architecture hints/apollo.sh Hints for named architecture -hints/aux.sh Hints for named architecture +hints/aux_3.sh Hints for named architecture +hints/broken-db.msg Warning message for systems with broken DB library hints/bsdos.sh Hints for named architecture hints/convexos.sh Hints for named architecture hints/cxux.sh Hints for named architecture @@ -223,9 +224,12 @@ hints/irix_4.sh Hints for named architecture hints/irix_5.sh Hints for named architecture hints/irix_6.sh Hints for named architecture hints/irix_6_2.sh Hints for named architecture +hints/irix_6_3.sh Hints for named architecture +hints/irix_6_4.sh Hints for named architecture hints/isc.sh Hints for named architecture hints/isc_2.sh Hints for named architecture hints/linux.sh Hints for named architecture +hints/lynxos.sh Hints for named architecture hints/machten.sh Hints for named architecture hints/machten_2.sh Hints for named architecture hints/mips.sh Hints for named architecture @@ -239,6 +243,7 @@ hints/next_4.sh Hints for named architecture hints/opus.sh Hints for named architecture hints/os2.sh Hints for named architecture hints/powerux.sh Hints for named architecture +hints/qnx.sh Hints for named architecture hints/sco.sh Hints for named architecture hints/sco_2_3_0.sh Hints for named architecture hints/sco_2_3_1.sh Hints for named architecture @@ -255,21 +260,26 @@ hints/titanos.sh Hints for named architecture hints/ultrix_4.sh Hints for named architecture hints/umips.sh Hints for named architecture hints/unicos.sh Hints for named architecture +hints/unicosmk.sh Hints for named architecture hints/unisysdynix.sh Hints for named architecture hints/utekv.sh Hints for named architecture hints/uts.sh Hints for named architecture hv.c Hash value code hv.h Hash value header -installman Perl script to install man pages for pods. +installman Perl script to install man pages for pods installperl Perl script to do "make install" dirty work interp.sym Interpreter specific symbols to hide in a struct keywords.h The keyword numbers keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AutoLoader.pm Autoloader base class -lib/AutoSplit.pm A module to split up autoload functions -lib/Benchmark.pm A module to time pieces of code and such +lib/AutoSplit.pm Split up autoload functions +lib/Benchmark.pm Measure execution time +lib/CPAN.pm Interface to Comprehensive Perl Archive Network +lib/CPAN/FirstTime.pm Utility for creating CPAN config files +lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class +lib/Class/Template.pm Structure/member template builder; makes nested types lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm lib/DirHandle.pm like FileHandle only for directories @@ -281,7 +291,7 @@ lib/ExtUtils/Install.pm Handles 'make install' on extensions lib/ExtUtils/Liblist.pm Locates libraries lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2 lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix -lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS. +lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker) @@ -290,28 +300,35 @@ lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension lib/ExtUtils/typemap Extension interface types lib/ExtUtils/xsubpp External subroutine preprocessor lib/Fatal.pm Make do-or-die equivalents of functions -lib/File/Basename.pm A module to emulate the basename program +lib/File/Basename.pm Emulate the basename program lib/File/CheckTree.pm Perl module supporting wholesale file mode validation +lib/File/Compare.pm Emulation of cmp command lib/File/Copy.pm Emulation of cp command lib/File/Find.pm Routines to do a find -lib/File/Path.pm A module to do things like `mkdir -p' and `rm -r' +lib/File/Path.pm Do things like `mkdir -p' and `rm -r' +lib/File/stat.pm By-name interface to Perl's built-in stat lib/FileCache.pm Keep more files open than the system permits +lib/FileHandle.pm Backward-compatible front end to IO extension lib/FindBin.pm Find name of currently executing program -lib/Getopt/Long.pm A module to fetch command options (GetOptions) -lib/Getopt/Std.pm A module to fetch command options (getopt, getopts) +lib/Getopt/Long.pm Fetch command options (GetOptions) +lib/Getopt/Std.pm Fetch command options (getopt, getopts) lib/I18N/Collate.pm Routines to do strxfrm-based collation lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open3.pm Open a three-ended pipe! lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package lib/Math/BigInt.pm An arbitrary precision integer arithmetic package lib/Math/Complex.pm A Complex package -lib/Net/Ping.pm Ping methods +lib/Net/Ping.pm Hello, anybody home? +lib/Net/hostent.pm By-name interface to Perl's built-in gethost* +lib/Net/netent.pm By-name interface to Perl's built-in getnet* +lib/Net/protoent.pm By-name interface to Perl's built-in getproto* +lib/Net/servent.pm By-name interface to Perl's built-in getserv* lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Text.pm Convert POD data to formatted ASCII text -lib/Search/Dict.pm A module to do binary search on dictionaries -lib/SelectSaver.pm A module to enforce proper select scoping -lib/SelfLoader.pm A module to load functions only on demand. -lib/Shell.pm A module to make AUTOLOADed system() calls +lib/Search/Dict.pm Perform binary search on dictionaries +lib/SelectSaver.pm Enforce proper select scoping +lib/SelfLoader.pm Load functions only on demand +lib/Shell.pm Make AUTOLOADed system() calls lib/Symbol.pm Symbol table manipulation routines lib/Sys/Hostname.pm Hostname methods lib/Sys/Syslog.pm Perl module supporting syslogging @@ -325,15 +342,22 @@ lib/Text/Soundex.pm Perl module to implement Soundex lib/Text/Tabs.pm Do expand and unexpand lib/Text/Wrap.pm Paragraph formatter lib/Tie/Hash.pm Base class for tied hashes +lib/Tie/RefHash.pm Base class for tied hashes with references as keys lib/Tie/Scalar.pm Base class for tied scalars lib/Tie/SubstrHash.pm Compact hash for known key, value and table size lib/Time/Local.pm Reverse translation of localtime, gmtime -lib/UNIVERSAL.pm Base class for ALL classes. +lib/Time/gmtime.pm By-name interface to Perl's built-in gmtime +lib/Time/localtime.pm By-name interface to Perl's built-in localtime +lib/Time/tm.pm Internal oject for Time::{gm,local}time +lib/UNIVERSAL.pm Base class for ALL classes +lib/User/grent.pm By-name interface to Perl's built-in getgr* +lib/User/pwent.pm By-name interface to Perl's built-in getpw* lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/bigfloat.pl An arbitrary precision floating point package lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package +lib/blib.pm For "use blib" lib/cacheout.pl Manages output filehandles when you need too many lib/chat2.inter A chat2 with interaction lib/chat2.pl Randal's famous expect-ish routines @@ -356,16 +380,16 @@ lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/less.pm For "use less" lib/lib.pm For "use lib" +lib/locale.pm For "use locale" lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing -lib/open2.pl Open a two-ended pipe -lib/open3.pl Open a three-ended pipe -lib/overload.pm Module for overloading perl operators. +lib/open2.pl Open a two-ended pipe (uses IPC::Open2) +lib/open3.pl Open a three-ended pipe (uses IPC::Open3) +lib/overload.pm Module for overloading perl operators lib/perl5db.pl Perl debugging routines lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback -lib/splain Standalone program to print verbose diagnostics. lib/stat.pl Perl library supporting stat function lib/strict.pm For "use strict" lib/subs.pm Declare overriding subs @@ -425,7 +449,7 @@ os2/OS2/REXX/t/rx_tievar.t DLL access module os2/OS2/REXX/t/rx_tieydb.t DLL access module os2/OS2/REXX/t/rx_varset.t DLL access module os2/OS2/REXX/t/rx_vrexx.t DLL access module -os2/POSIX.mkfifo POSIX.xs patch. +os2/POSIX.mkfifo POSIX.xs patch os2/diff.configure Patches to Configure os2/dl_os2.c Addon for dl_open os2/dlfcn.h Addon for dl_open @@ -435,9 +459,9 @@ os2/perl2cmd.pl Corrects installed binaries under OS/2 patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations -perl_exp.SH Creates list of exported symbols for AIX. -perlio.c C code for PerlIO abstraction. -perlio.h Interface to PerlIO abstraction. +perl_exp.SH Creates list of exported symbols for AIX +perlio.c C code for PerlIO abstraction +perlio.h Interface to PerlIO abstraction perlsdio.h Fake stdio using perlio perlsfio.h Prototype sfio mapping for PerlIO perlsh A poor man's perl shell @@ -463,7 +487,7 @@ plan9/setup.rc Plan9 port: script for easy build+install plan9/versnum Plan9 port: script to print version number pod/Makefile Make pods into something else pod/buildtoc generate perltoc.pod -pod/checkpods.PL Tool to check for common errors in pods. +pod/checkpods.PL Tool to check for common errors in pods pod/perl.pod Top level perl man page pod/perlapio.pod IO API info pod/perlbook.pod Book info @@ -477,13 +501,13 @@ pod/perlembed.pod Embedding info pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info -pod/perli18n.pod I18N info pod/perlipc.pod IPC info -pod/perllol.pod How to use lists of lists. +pod/perllocale.pod Locale support info +pod/perllol.pod How to use lists of lists pod/perlmod.pod Module info +pod/perlnews.pod News of changes since last version pod/perlobj.pod Object info pod/perlop.pod Operator info -pod/perlovl.pod Overloading info pod/perlpod.pod Pod info pod/perlre.pod Regular expression info pod/perlref.pod References info @@ -494,6 +518,7 @@ pod/perlsub.pod Subroutine info pod/perlsyn.pod Syntax info pod/perltie.pod Tieing an object class into a simple variable pod/perltoc.pod Table of Contents info +pod/perltoot.pod Tom's object-oriented tutorial pod/perltrap.pod Trap info pod/perlvar.pod Variable info pod/perlxs.pod XS api info @@ -503,6 +528,7 @@ pod/pod2latex.PL Precursor for translator to turn pod into LaTeX pod/pod2man.PL Precursor for translator to turn pod into manpage pod/pod2text.PL Precursor for translator to turn pod into text pod/roffitall troff the whole man page set +pod/rofftoc Generate a table of contents in troff format pod/splitman Splits perlfunc into multiple man pages pod/splitpod Splits perlfunc into multiple pod pages pp.c Push/Pop code @@ -511,6 +537,8 @@ pp_ctl.c Push/Pop code for control flow pp_hot.c Push/Pop code for heavily used opcodes pp_sys.c Push/Pop code for system interaction proto.h Prototypes +qnx/ar QNX implementation of "ar" utility +qnx/cpp QNX implementation of preprocessor filter regcomp.c Regular expression compiler regcomp.h Private declarations for above regexec.c Regular expression evaluator @@ -534,14 +562,17 @@ t/cmd/subval.t See if subroutine values work t/cmd/switch.t See if switch optimizations work t/cmd/while.t See if while loops work t/comp/cmdopt.t See if command optimization works +t/comp/colon.t See if colons are parsed correctly t/comp/cpp.aux main file for cpp.t t/comp/cpp.t See if C preprocessor works t/comp/decl.t See if declarations work t/comp/multiline.t See if multiline strings work t/comp/package.t See if packages work +t/comp/proto.t See if function prototypes work t/comp/redef.t See if we get correct warnings on redefined subs t/comp/script.t See if script invokation works t/comp/term.t See if more terms work +t/comp/use.t See if pragmas work t/harness Finer diagnostics from test suite t/io/argv.t See if ARGV stuff works t/io/dup.t See if >& works right @@ -577,6 +608,7 @@ t/lib/getopt.t See if Getopt::Std and Getopt::Long works t/lib/hostname.t See if Sys::Hostname works t/lib/io_dup.t See if dup()-related methods from IO work t/lib/io_pipe.t See if pipe()-related methods from IO work +t/lib/io_sel.t See if select()-related methods from IO work t/lib/io_sock.t See if INET socket-related methods from IO work t/lib/io_taint.t See if the untaint method from IO works t/lib/io_tell.t See if seek()/tell()-related methods from IO work @@ -585,6 +617,8 @@ t/lib/io_xs.t See if XSUB methods from IO work t/lib/ndbm.t See if NDBM_File works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works +t/lib/open2.t See if IPC::Open2 works +t/lib/open3.t See if IPC::Open3 works t/lib/ops.t See if Opcode works t/lib/parsewords.t See if Text::ParseWords works t/lib/posix.t See if POSIX works @@ -601,9 +635,11 @@ t/lib/textwrap.t See if Text::Wrap works t/lib/timelocal.t See if Time::Local works t/op/append.t See if . works t/op/array.t See if array operations work +t/op/assignwarn.t See if OP= operators warn correctly for undef targets t/op/auto.t See if autoincrement et all work t/op/bop.t See if bitops work t/op/chop.t See if chop works +t/op/cmp.t See if the various string and numeric compare work t/op/cond.t See if conditional expressions work t/op/delete.t See if delete works t/op/do.t See if subroutines work @@ -624,21 +660,22 @@ t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work +t/op/method.t See if method calls work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works t/op/oct.t See if oct and hex work t/op/ord.t See if ord works -t/op/overload.t See if operator overload works t/op/pack.t See if pack and unpack work t/op/pat.t See if esoteric patterns work t/op/push.t See if push and pop work t/op/quotemeta.t See if quotemeta works t/op/rand.t See if rand works t/op/range.t See if .. works -t/op/re_tests Input file for op.regexp +t/op/re_tests Regular expressions for regexp.t t/op/read.t See if read() works t/op/readdir.t See if readdir() works +t/op/recurse.t See if deep recursion works t/op/ref.t See if refs and objects work t/op/regexp.t See if regular expressions work t/op/repeat.t See if x operator works @@ -650,29 +687,45 @@ t/op/stat.t See if stat works t/op/study.t See if study works t/op/subst.t See if substitution works t/op/substr.t See if substr works +t/op/sysio.t See if sysread and syswrite work t/op/tie.t See if tie/untie functions work t/op/time.t See if time functions work t/op/undef.t See if undef works +t/op/universal.t See if UNIVERSAL class works t/op/unshift.t See if unshift works t/op/vec.t See if vectors work t/op/write.t See if write works -t/re_tests Regular expressions for regexp.t +t/pragma/locale.t See if locale support (i18n and l10n) works +t/pragma/overload.t See if operator overloading works +t/pragma/strict-refs Tests of "use strict 'refs'" for strict.t +t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t +t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t +t/pragma/strict.t See if strictures work +t/pragma/subs.t See if subroutine pseudo-importation works +t/pragma/warn-1global Tests of global warnings for warning.t +t/pragma/warning.t See if warning controls work taint.c Tainting code toke.c The tokener universal.c The default UNIVERSAL package methods unixish.h Defines that are assumed on Unix util.c Utility routines -util.h Public declarations for the above -utils/Makefile Extract the utility scripts. +util.h Dummy header +utils/Makefile Extract the utility scripts utils/c2ph.PL program to translate dbx stabs to perl utils/h2ph.PL A thing to turn C .h files into perl .ph files utils/h2xs.PL Program to make .xs files from C header files utils/perlbug.PL A simple tool to submit a bug report utils/perldoc.PL A simple tool to find & display perl's documentation utils/pl2pm.PL A pl to pm translator +utils/splain.PL Stand-alone version of diagnostics.pm vms/Makefile VMS port vms/config.vms default config.h for VMS vms/descrip.mms MM[SK] description file for build +vms/ext/DCLsym/0README.txt ReadMe file for VMS::DCLsym +vms/ext/DCLsym/DCLsym.pm Perl access to CLI symbols +vms/ext/DCLsym/DCLsym.xs Perl access to CLI symbols +vms/ext/DCLsym/Makefile.PL MakeMaker driver for VMS::DCLsym +vms/ext/DCLsym/test.pl regression tests for VMS::DCLsym vms/ext/Filespec.pm VMS-Unix file syntax interconversion vms/ext/Stdio/0README.txt ReadMe file for VMS::Stdio vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio @@ -708,9 +761,9 @@ x2p/a2p.y A yacc grammer for awk x2p/a2py.c Awk compiler, sort of x2p/cflags.SH A script that emits C compilation flags per file x2p/find2perl.PL A find to perl translator -x2p/handy.h Handy definitions x2p/hash.c Associative arrays again x2p/hash.h Public declarations for the above +x2p/proto.h Dummy header x2p/s2p.PL Sed to perl translator x2p/str.c String handling package x2p/str.h Public declarations for the above diff --git a/Makefile.SH b/Makefile.SH index e3ee81493d..025dd22248 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -23,9 +23,10 @@ case "$d_dosuid" in *) suidperl='';; esac +linklibperl='$(LIBPERL)' case "$useshrplib" in true) - pldlflags="$cccdlflags" + pldlflags="$cccdlflags" # NeXT-4 specific stuff. Can't we do this in the hint file? case "${osname}${osvers}" in next4*) @@ -33,8 +34,11 @@ true) -compatibility_version 1 -current_version $(PATCHLEVEL) \ -prebind -seg1addr 0x27000000 -install_name $(SHRPDIR)/$@' ;; + sunos*|freebsd[23]*) + linklibperl="-lperl" + ;; esac - ;; + ;; *) pldlflags='' ;; esac @@ -98,6 +102,7 @@ CCDLFLAGS = $ccdlflags DLSUFFIX = .$dlext PLDLFLAGS = $pldlflags LIBPERL = $libperl +LLIBPERL= $linklibperl SHRPENV = $shrpenv dynamic_ext = $dynamic_list @@ -243,7 +248,7 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) case "$useshrplib" in true) $spitshell >>Makefile <<'!NO!SUBS!' - $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) + $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) !NO!SUBS! ;; *) @@ -267,17 +272,17 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) # The Module used here must not depend on Config or any extensions. miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LIBPERL) $(libs) + $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) + purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) + quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) # This version, if specified in Configure, does ONLY those scripts which need # set-id emulation. Suidperl must be setuid root. It contains the "taint" @@ -285,7 +290,7 @@ quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs # has been invoked correctly. suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) !NO!SUBS! @@ -339,12 +344,13 @@ install.man: all installman # normally shouldn't remake perly.[ch]. run_byacc: FORCE - @ echo 'Expect' 130 shift/reduce and 1 reduce/reduce conflict + @ echo 'Expect' 113 shift/reduce and 1 reduce/reduce conflict $(BYACC) -d perly.y sh $(shellflags) ./perly.fixer y.tab.c perly.c - sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' perly.c >perly.tmp && mv perly.tmp perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c + echo 'extern YYSTYPE yylval;' >>y.tab.h + cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h perly.h - perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms # We don't want to regenerate perly.c and perly.h, but they might @@ -388,19 +394,34 @@ d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE @sh ext/util/make_ext static $@ LIBPERL_A=$(LIBPERL) -clean: +clean: _tidy _mopop + +realclean: _cleaner _mopup + @echo "Note that make realclean does not delete config.sh" + +clobber: _cleaner _mopup + rm -f config.sh cppstdin + +distclean: clobber + +# Do not 'make _mopup' directly. +_mopup: rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c rm -f perl.exp ext.libs -rm -f perl.export perl.dll perl.libexp perl.map perl.def + rm -f perl suidperl miniperl $(LIBPERL) + +# Do not 'make _tidy' directly. +_tidy: -cd pod; $(MAKE) clean -cd utils; $(MAKE) clean -cd x2p; $(MAKE) clean -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ sh ext/util/make_ext clean $$x ; \ done - rm -f perl suidperl miniperl $(LIBPERL) -realclean: clean +# Do not 'make _cleaner' directly. +_cleaner: -cd os2; rm -f Makefile -cd pod; $(MAKE) realclean -cd utils; $(MAKE) realclean @@ -416,12 +437,6 @@ realclean: clean rm -f lib/.exists rm -f h2ph.man pstruct rm -rf .config - @echo "Note that make realclean does not delete config.sh" - -clobber: realclean - rm -f config.sh cppstdin - -distclean: clobber # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. @@ -463,7 +478,7 @@ minitest: miniperl @echo "You may see some irrelevant test failures if you have been unable" @echo "to build lib/Config.pm." - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \ - && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t </dev/tty + && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t </dev/tty clist: $(c) echo $(c) | tr ' ' '\012' >.clist diff --git a/Porting/Glossary b/Porting/Glossary index 4cd0099c93..58f2cac2f6 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -34,6 +34,10 @@ bin (bin.U): is most often a local directory such as /usr/local/bin. Programs using this variable must be prepared to deal with ~name substitution. +bincompat3 (bincompat3.U): + This variable contains y if Perl 5.004 should be binary-compatible + with Perl 5.003. + byteorder (byteorder.U): This variable holds the byte order. In the following, larger digits indicate more significance. The variable byteorder is either 4321 @@ -133,6 +137,11 @@ d_bcopy (d_bcopy.U): This variable conditionally defines the HAS_BCOPY symbol if the bcopy() routine is available to copy strings. +d_bincompat3 (bincompat3.U): + This variable conditionally defines BINCOMPAT3 so that embed.h + can take special action if Perl 5.004 should be binary-compatible + with Perl 5.003. + d_bsdgetpgrp (d_getpgrp.U): This variable conditionally defines USE_BSD_GETPGRP if getpgrp needs one arguments whereas USG one needs none. @@ -272,10 +281,20 @@ d_fsetpos (d_fsetpos.U): This variable conditionally defines HAS_FSETPOS if fsetpos() is available to set the file position indicator. +d_ftime (d_ftime.U): + This variable conditionally defines the HAS_FTIME symbol, which + indicates that the ftime() routine exists. The ftime() routine is + basically a sub-second accuracy clock. + d_gethent (d_gethent.U): This variable conditionally defines HAS_GETHOSTENT if gethostent() is available to dup file descriptors. +d_gettimeod (d_ftime.U): + This variable conditionally defines the HAS_GETTIMEOFDAY symbol, which + indicates that the gettimeofday() system call exists (to obtain a + sub-second accuracy clock). + d_getlogin (d_getlogin.U): This variable conditionally defines the HAS_GETLOGIN symbol, which indicates to the C program that the getlogin() routine is available @@ -312,6 +331,11 @@ d_index (d_strchr.U): This variable conditionally defines HAS_INDEX if index() and rindex() are available for string searching. +d_inetaton (d_inetaton.U): + This variable conditionally defines the HAS_INET_ATON symbol, which + indicates to the C program that the inet_aton() function is available + to parse IP address "dotted-quad" strings. + d_isascii (d_isascii.U): This variable conditionally defines the HAS_ISASCII constant, which indicates to the C program that isascii() is available. @@ -483,6 +507,11 @@ d_safemcpy (d_safemcpy.U): This variable conditionally defines the HAS_SAFE_MEMCPY symbol if the memcpy() routine can do overlapping copies. +d_sanemcmp (d_sanemcmp.U): + This variable conditionally defines the HAS_SANE_MEMCMP symbol if + the memcpy() routine is available and can be used to compare relative + magnitudes of chars with their high bits set. + d_seekdir (d_readdir.U): This variable conditionally defines HAS_SEEKDIR if seekdir() is available. @@ -643,6 +672,21 @@ d_strerror (d_strerror.U): This variable conditionally defines HAS_STRERROR if strerror() is available to translate error numbers to strings. +d_strtod (d_strtod.U): + This variable conditionally defines the HAS_STRTOD symbol, which + indicates to the C program that the strtod() routine is available + to provide better numeric string conversion than atof(). + +d_strtol (d_strtol.U): + This variable conditionally defines the HAS_STRTOL symbol, which + indicates to the C program that the strtol() routine is available + to provide better numeric string conversion than atoi() and friends. + +d_strtoul (d_strtoul.U): + This variable conditionally defines the HAS_STRTOUL symbol, which + indicates to the C program that the strtoul() routine is available + to provide conversion of strings to unsigned long. + d_strxfrm (d_strxfrm.U): This variable conditionally defines HAS_STRXFRM if strxfrm() is available to transform strings. @@ -1175,6 +1219,11 @@ path_sep (Unix.U): perladmin (perladmin.U): Electronic mail address of the perl5 administrator. +perlpath (perlpath.U): + This variable contains the eventual value of the PERLPATH symbol, + which contains the name of the perl interpreter to be used in + shell scripts and in the "eval 'exec'" idiom. + prefix (prefix.U): This variable holds the name of the directory below which the user will install the package. Usually, this is /usr/local, and @@ -1318,7 +1367,7 @@ startperl (startperl.U): script to make sure (hopefully) that it runs with perl and not some shell. Of course, that leading line must be followed by the classical perl idiom: - eval 'exec perl -S $0 "$@"' + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if $running_under_some_shell; to guarantee perl startup should the shell execute the script. Note that this magic incatation is not understood by csh. diff --git a/README.os2 b/README.os2 index f5bf87db06..e6782e3dc1 100644 --- a/README.os2 +++ b/README.os2 @@ -4,7 +4,7 @@ specially designed to be readable as is. =head1 NAME -perlos2 - Perl under OS/2, Win0.31, Win0.95 and WinNT. +perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. =head1 SYNOPSIS @@ -18,28 +18,42 @@ One can read this document in the following formats: to list some (not all may be available simultaneously), or it may be read I<as is>: either as F<README.os2>, or F<pod/perlos2.pod>. +To read the F<.INF> version of documentation (B<very> recommended) +outside of OS/2, one needs an IBM's reader (may be available on IBM +ftp sites (?) (URL anyone?)) or shipped with PC DOS 7.0 and IBM's +Visual Age C++ 3.5. + +A copy of a Win* viewer is contained in the "Just add OS/2 Warp" package + + ftp://ftp.software.ibm.com/ps/products/os2/tools/jaow/jaow.zip + +in F<?:\JUST_ADD\view.exe>. This gives one an access to B<EMX>'s +F<.INF> docs as well (text form is available in F</emx/doc> in +B<EMX>'s distribution). + =cut Contents - perlos2 - Perl under OS/2 + perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. - NAME - SYNOPSIS - DESCRIPTION + NAME + SYNOPSIS + DESCRIPTION - Target - Other OSes - Prerequisites - Starting Perl programs under OS/2 - Starting OS/2 programs under Perl - Frequently asked questions - - I cannot run extenal programs - - I cannot embed perl into my program, or use perl.dll from my program. - INSTALLATION + Frequently asked questions + - I cannot run external programs + - I cannot embed perl into my program, or use perl.dll from my program. + - `` and pipe-open do not work under DOS. + INSTALLATION - Automatic binary installation - Manual binary installation - Warning - Accessing documentation + Accessing documentation - OS/2 .INF file - Plain text - Manpages @@ -47,7 +61,7 @@ Contents - GNU info files - .PDF files - LaTeX docs - BUILD + BUILD - Prerequisites - Getting perl source - Application of the patches @@ -56,20 +70,21 @@ Contents - Testing - Installing the built perl - a.out-style build - Build FAQ + Build FAQ - Some / became \ in pdksh. - 'errno' - unresolved external - Problems with tr - Some problem (forget which ;-) - Library ... not found - - Segfault in make - Specific (mis)features of OS/2 port + - Segfault in make + Specific (mis)features of OS/2 port - setpriority, getpriority - system() - Additional modules: - Prebuilt methods: - Misfeatures - Perl flavors + - Modifications + Perl flavors - perl.exe - perl_.exe - perl__.exe @@ -77,26 +92,27 @@ Contents - Why strange names? - Why dynamic linking? - Why chimera build? - ENVIRONMENT + ENVIRONMENT - PERLLIB_PREFIX - PERL_BADLANG - PERL_BADFREE - PERL_SH_DIR - TMP or TEMP - Evolution + Evolution - Priorities - - DLL name mungling + - DLL name mangling - Threading - Calls to external programs - AUTHOR - SEE ALSO - + - Memory allocation + AUTHOR + SEE ALSO + =head1 DESCRIPTION =head2 Target The target is to make OS/2 the best supported platform for -using/building/developping Perl and I<Perl applications>, as well as +using/building/developing Perl and I<Perl applications>, as well as make Perl the best language to use under OS/2. The current state is quite close to this target. Known limitations: @@ -117,7 +133,7 @@ to use PM code in your application (like the forthcoming Perl/Tk). There is no simple way to access B<WPS> objects. The only way I know is via C<OS2::REXX> extension (see L<OS2::REXX>), and we do not have access to -convinience methods of B<Object REXX>. (Is it possible at all? I know +convenience methods of B<Object REXX>. (Is it possible at all? I know of no B<Object-REXX> API.) =back @@ -129,7 +145,7 @@ Please keep this list up-to-date by informing me about other items. Since OS/2 port of perl uses a remarkable B<EMX> environment, it can run (and build extensions, and - possibly - be build itself) under any environment which can run EMX. The current list is DOS, -DOS-inside-OS/2, Win0.31, Win0.95 and WinNT. Out of many perl flavors, +DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT. Out of many perl flavors, only one works, see L<"perl_.exe">. Note that not all features of Perl are available under these @@ -144,9 +160,13 @@ Cf. L<Prerequisites>. =item B<EMX> -B<EMX> runtime is required. Note that it is possible to make F<perl_.exe> -to run under DOS without any external support by binding F<emx.exe> to -it, see L<emxbind>. +B<EMX> runtime is required (may be substituted by B<RSX>). Note that +it is possible to make F<perl_.exe> to run under DOS without any +external support by binding F<emx.exe>/F<rsx.exe> to it, see L<emxbind>. Note +that under DOS for best results one should use B<RSX> runtime, which +has much more functions working (like C<fork>, C<popen> and so on). In +fact B<RSX> is required if there is no C<VCPI> present. Note the +B<RSX> requires C<DPMI>. Only the latest runtime is supported, currently C<0.9c>. @@ -157,11 +177,24 @@ One can get different parts of B<EMX> from, say The runtime component should have the name F<emxrt.zip>. +B<NOTE>. It is enough to have F<emx.exe>/F<rsx.exe> on your path. One +does not need to specify them explicitly (though this + + emx perl_.exe -de 0 + +will work as well.) + =item B<RSX> -To run Perl on C<DPMS> platforms one needs B<RSX> runtime. This is -needed under DOS-inside-OS/2, Win0.31, Win0.95 and WinNT (see -L<"Other OSes">). +To run Perl on C<DPMI> platforms one needs B<RSX> runtime. This is +needed under DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT (see +L<"Other OSes">). B<RSX> would not work with C<VCPI> +only, as B<EMX> would, it requires C<DMPI>. + +Having B<RSX> and the latest F<sh.exe> one gets a fully functional +B<*nix>-ish environment under DOS, say, C<fork>, C<``> and +pipe-C<open> work. In fact, MakeMaker works (for static build), so one +can have Perl development environment under DOS. One can get B<RSX> from, say @@ -170,6 +203,10 @@ One can get B<RSX> from, say Contact the author on C<rainer@mathematik.uni-bielefeld.de>. +The latest F<sh.exe> with DOS hooks is available at + + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/sh_dos.exe + =item B<HPFS> Perl does not care about file systems, but to install the whole perl @@ -228,10 +265,10 @@ and C<-x> switches - see L<perlrun>, and cmdref about C<extproc>: or whatever method you prefer. -There are also endless possibilites to use I<executable extensions> of +There are also endless possibilities to use I<executable extensions> of B<4OS2>, I<associations> of B<WPS> and so on... However, if you use *nixish shell (like F<sh.exe> supplied in the binary distribution), -you need follow the syntax specified in L<perlrun/"Switches">. +you need to follow the syntax specified in L<perlrun/"Switches">. =head2 Starting OS/2 programs under Perl @@ -252,11 +289,24 @@ meta-characters. =head1 Frequently asked questions -=head2 I cannot run extenal programs +=head2 I cannot run external programs + +=over 4 + +=item Did you run your programs with C<-w> switch? See L<Starting OS/2 programs under Perl>. +=item + +Do you try to run I<internal> shell commands, like C<`copy a b`> +(internal for F<cmd.exe>), or C<`glob a*b`> (internal for ksh)? You +need to specify your shell explicitly, like C<`cmd /c copy a b`>, +since Perl cannot deduce which commands are internal to your shell. + +=back + =head2 I cannot embed perl into my program, or use F<perl.dll> from my program. @@ -273,11 +323,21 @@ I had reports it does not work. Somebody would need to fix it. =back +=head2 C<``> and pipe-C<open> do not work under DOS. + +This may a variant of just L<"I cannot run external programs">, or a +deeper problem. Basically: you I<need> B<RSX> (see L<"Prerequisites">) +for these commands to work, and you may need a port of F<sh.exe> which +understands command arguments. One of such ports is listed in +L<"Prerequisites"> under B<RSX>. + +C<DPMI> is required for B<RSX>. + =head1 INSTALLATION =head2 Automatic binary installation -The most convinient way of installing perl is via perl installer +The most convenient way of installing perl is via perl installer F<install.exe>. Just follow the instructions, and 99% of the installation blues would go away. @@ -319,7 +379,7 @@ data, please keep me informed if you find one. =head2 Manual binary installation -As of version 5.00305, OS/2 perl binary distribution comes splitted +As of version 5.00305, OS/2 perl binary distribution comes split into 11 components. Unfortunately, to enable configurable binary installation, the file paths in the C<zip> files are not absolute, but relative to some directory. @@ -328,7 +388,9 @@ Note that the extraction with the stored paths is still necessary (default with C<unzip>, specify C<-d> to C<pkunzip>). However, you need to know where to extract the files. You need also to manually change entries in F<Config.sys> to reflect where did you put the -files. +files. Note that if you have some primitive unzipper (like +C<pkunzip>), you may get a lot of warnings/errors during +unzipping. Upgrade to C<(w)unzip>. Below is the sample of what to do to reproduce the configuration on my machine: @@ -413,7 +475,7 @@ This directory should better be on C<BOOKSHELF>. unzip perl_sh.zip -d f:/bin -This is used by perl to run external commands which explicitely +This is used by perl to run external commands which explicitly require shell, like the commands using I<redirection> and I<shell metacharacters>. It is also used instead of explicit F</bin/sh>. @@ -449,7 +511,7 @@ identical) Perl documentation in the following formats: =head2 OS/2 F<.INF> file -Most probably the most convinient form. View it as +Most probably the most convenient form. View it as view perl view perl perlfunc @@ -479,7 +541,7 @@ installed, and B<GNU> C<groff> installed, you may use perldoc less perldoc ExtUtils::MakeMaker -to access the perl documention in the text form (note that you may get +to access the perl documentation in the text form (note that you may get better results using perl manpages). Alternately, try running pod2text on F<.pod> files. @@ -520,7 +582,7 @@ directory, and go ahead with reading docs, like this: explore file:///f:/perllib/lib/pod/perl.html -Alternatively you may be able to get these docs prebuild from C<CPAN>. +Alternatively you may be able to get these docs prebuilt from C<CPAN>. =head2 B<GNU> C<info> files @@ -583,12 +645,12 @@ but may be not installed due to customization. If typing link386 shows you do not have it, do I<Selective install>, and choose C<Link -object modules> in I<Optional system utilites/More>. If you get into +object modules> in I<Optional system utilities/More>. If you get into C<link386>, press C<Ctrl-C>. =head2 Getting perl source -You need to fetch the latest perl source (including developpers +You need to fetch the latest perl source (including developers releases). With some probability it is located in http://www.perl.com/CPAN/src/5.0 @@ -597,7 +659,7 @@ releases). With some probability it is located in If not, you may need to dig in the indices to find it in the directory of the current maintainer. -Quick cycle of developpers release may break the OS/2 build time to +Quick cycle of developers release may break the OS/2 build time to time, looking into http://www.perl.com/CPAN/ports/os2/ilyaz/ @@ -625,7 +687,7 @@ You need to apply the patches in F<./os2/diff.*> and F<./os2/POSIX.mkfifo> like this: gnupatch -p0 < os2\POSIX.mkfifo - gnupatch -p0 < os2\os2\diff.configure + gnupatch -p0 < os2\diff.configure You may also need to apply the patches supplied with the binary distribution of perl. @@ -688,11 +750,19 @@ The report you get may look like lib/io_pipe.t 3 768 6 ?? % ?? lib/io_sock.t 3 768 5 ?? % ?? op/stat.t 56 5 8.93% 3-4, 20, 35, 39 - Failed 4/118 test scripts, 96.61% okay. 27/2445 subtests failed, 98.90% okay. + Failed 4/140 test scripts, 97.14% okay. 27/2937 subtests failed, 99.08% okay. Note that using `make test' target two more tests may fail: C<op/exec:1> because of (mis)feature of C<pdksh>, and C<lib/posix:15>, which checks -that the buffers are not flushed on C<_exit>. +that the buffers are not flushed on C<_exit> (this is a bug in the test +which assumes that tty output is buffered). + +I submitted a patch to B<EMX> which makes it possible to fork() with EMX +dynamic libraries loaded, which makes F<lib/io*> tests pass. This means +that soon the number of failing tests may decrease yet more. + +However, the test F<lib/io_udp.t> is disabled, since it never terminates, I +do not know why. Comments/fixes welcome. The reasons for failed tests are: @@ -824,7 +894,7 @@ test and install by Manually put F<perl_.exe> to a location on your C<PATH>. Since C<perl_> has the extensions prebuilt, it does not suffer from -the I<dynamic extensions + fork()> syndrom, thus the failing tests +the I<dynamic extensions + fork()> syndrome, thus the failing tests look like Failed Test Status Wstat Total Fail Failed List of failed @@ -874,7 +944,7 @@ You use an old version of C<GNU> make. See L<Prerequisites>. Note that these functions are compatible with *nix, not with the older ports of '94 - 95. The priorities are absolute, go from 32 to -95, -lower is quickier. 0 is the default priority. +lower is quicker. 0 is the default priority. =head2 C<system()> @@ -889,7 +959,7 @@ modules provide access to additional numeric argument for C<system>, to DLLs having functions with REXX signature and to REXX runtime, to OS/2 databases in the F<.INI> format, and to Extended Attributes. -Two additional extensions by Andread Kaiser, C<OS2::UPM>, and +Two additional extensions by Andreas Kaiser, C<OS2::UPM>, and C<OS2::FTP>, are included into my ftp directory, mirrored on CPAN. =head2 Prebuilt methods: @@ -902,7 +972,7 @@ used by C<File::Copy::copy>, see L<File::Copy/copy>. =item C<DynaLoader::mod2fname> -used by C<DynaLoader> for DLL name mungling. +used by C<DynaLoader> for DLL name mangling. =item C<Cwd::current_drive()> @@ -961,12 +1031,26 @@ eventually). =item -Since <lockf> is present in B<EMX>, but is not functional, the same is -true for perl. +Since <flock> is present in B<EMX>, but is not functional, the same is +true for perl. Here is the list of things which may be "broken" on +EMX (from EMX docs): + + - The functions recvmsg(), sendmsg(), and socketpair() are not + implemented. + - sock_init() is not required and not implemented. + - flock() is not yet implemented (dummy function). + - kill: + Special treatment of PID=0, PID=1 and PID=-1 is not implemented. + - waitpid: + WUNTRACED + Not implemented. + waitpid() is not implemented for negative values of PID. + +Note that C<kill -9> does not work with the current version of EMX. =item -Since F<sh.exe> is used for globbing (see L<perlfunc/glob>), the bugs +Since F<sh.exe> is used for globing (see L<perlfunc/glob>), the bugs of F<sh.exe> plague perl as well. In particular, uppercase letters do not work in C<[...]>-patterns with @@ -974,9 +1058,39 @@ the current C<pdksh>. =back +=head2 Modifications + +Perl modifies some standard C library calls in the following ways: + +=over 9 + +=item C<popen> + +C<my_popen> uses F<sh.exe> if shell is required, cf. L<"PERL_SH_DIR">. + +=item C<tmpnam> + +is created using C<TMP> or C<TEMP> environment variable, via +C<tempnam>. + +=item C<tmpfile> + +If the current directory is not writable, file is created using modified +C<tmpnam>, so there may be a race condition. + +=item C<ctermid> + +a dummy implementation. + +=item C<stat> + +C<os2_stat> special-cases F</dev/tty> and F</dev/con>. + +=back + =head1 Perl flavors -Because of ideosyncrasies of OS/2 one cannot have all the eggs in the +Because of idiosyncrasies of OS/2 one cannot have all the eggs in the same basket (though C<EMX> environment tries hard to overcome this limitations, so the situation may somehow improve). There are 4 executables for Perl provided by the distribution: @@ -989,7 +1103,8 @@ library F<perl.dll>, and with dynamic B<CRT> DLL. This executable is a C<VIO> application. It can load perl dynamic extensions, and it can fork(). Unfortunately, -currently it cannot fork() with dynamic extensions loaded. +with the current version of B<EMX> it cannot fork() with dynamic +extensions loaded (may be fixed by patches to B<EMX>). B<Note.> Keep in mind that fork() is needed to open a pipe to yourself. @@ -1011,7 +1126,7 @@ hint files should be necessary to achieve this. I<This is also the only executable with does not require OS/2.> The friends locked into C<M$> world would appreciate the fact that this -executable runs under DOS, Win0.31, Win0.95 and WinNT with an +executable runs under DOS, Win0.3*, Win0.95 and WinNT with an appropriate extender. See L<"Other OSes">. =head2 F<perl__.exe> @@ -1046,7 +1161,7 @@ L<perldiag/"Not a perl script">, L<perldiag/"No Perl script found in input">), it should know when a program I<is a Perl>. There is some naming convention which allows Perl to distinguish correct lines from wrong ones. The above names are -almost the only names allowed by this convension which do not contain +almost the only names allowed by this convention which do not contain digits (which have absolutely different semantics). =head2 Why dynamic linking? @@ -1056,14 +1171,14 @@ library has its advantages, but this would not substantiate the additional work to make it compile. The reason is stupid-but-quick "hard" dynamic linking used by OS/2. -The address tables of DLLs are patches only once, when they are -loaded. The addresses of entry points into DLLs are guarantied to be +The address tables of DLLs are patched only once, when they are +loaded. The addresses of entry points into DLLs are guaranteed to be the same for all programs which use the same DLL, which reduces the amount of runtime patching - once DLL is loaded, its code is read-only. While this allows some performance advantages, this makes life -terrible for developpers, since the above scheme makes it impossible +terrible for developers, since the above scheme makes it impossible for a DLL to be resolved to a symbol in the .EXE file, since this would need a DLL to have different relocations tables for the executables which use it. @@ -1074,7 +1189,7 @@ internal evaluation stack. The solution is that the main code of interpreter should be contained in a DLL, and the F<.EXE> file just loads this DLL into memory and supplies command-arguments. -This I<greately> increases the load time for the application (as well as +This I<greatly> increases the load time for the application (as well as the number of problems during compilation). Since interpreter is in a DLL, the C<CRT> is basically forced to reside in a DLL as well (otherwise extensions would not be able to use C<CRT>). @@ -1160,7 +1275,7 @@ Here we list major changes which could make you by surprise. C<setpriority> and C<getpriority> are not compatible with earlier ports by Andreas Kaiser. See C<"setpriority, getpriority">. -=head2 DLL name mungling +=head2 DLL name mangling With the release 5.003_01 the dynamically loadable libraries should be rebuilt. In particular, DLLs are now created with the names @@ -1179,7 +1294,7 @@ Needed to compile C<Perl/Tk> for C<XFreeOS/2> out-of-the-box. =head2 Calls to external programs Due to a popular demand the perl external program calling has been -changed wrt Andread Kaiser's port. I<If> perl needs to call an +changed wrt Andreas Kaiser's port. I<If> perl needs to call an external program I<via shell>, the F<f:/bin/sh.exe> will be called, or whatever is the override, see L<"PERL_SH_DIR">. @@ -1197,16 +1312,19 @@ with F<cmd.exe> as a shell, thus I picked up C<sh.exe>. Thus assures almost B<Disadvantages:> currently F<sh.exe> of C<pdksh> calls external programs via fork()/exec(), and there is I<no> functioning exec() on OS/2. exec() is emulated by EMX by asyncroneous call while the caller -waits for child completion (to pretend that the pid did not change). This +waits for child completion (to pretend that the C<pid> did not change). This means that 1 I<extra> copy of F<sh.exe> is made active via fork()/exec(), which may lead to some resources taken from the system (even if we do not count extra work needed for fork()ing). -One can always start F<cmd.exe> explicitely via +Note that this a lesser issue now when we do not spawn F<sh.exe> +unless needed (metachars found). + +One can always start F<cmd.exe> explicitly via system 'cmd', '/c', 'mycmd', 'arg1', 'arg2', ... -If you need to use F<cmd.exe>, and do not want to hand-edit thousends of your +If you need to use F<cmd.exe>, and do not want to hand-edit thousands of your scripts, the long-term solution proposed on p5-p is to have a directive use OS2::Cmd; @@ -1221,11 +1339,30 @@ If you have some working code for C<OS2::Cmd>, please send it to me, I will include it into distribution. I have no need for such a module, so cannot test it. +=head2 Memory allocation + +Perl uses its own malloc() under OS/2 - interpreters are usually malloc-bound +for speed, but perl is not, since its malloc is lightning-fast. +Unfortunately, it is also quite frivolous with memory usage as well. + +Since kitchen-top machines are usually low on memory, perl is compiled with +all the possible memory-saving options. This probably makes perl's +malloc() as greedy with memory as the neighbor's malloc(), but still +much quickier. Note that this is true only for a "typical" usage, +it is possible that the perl malloc will be worse for some very special usage. + +Combination of perl's malloc() and rigid DLL name resolution creates +a special problem with library functions which expect their return value to +be free()d by system's free(). To facilitate extensions which need to call +such functions, system memory-allocation functions are still available with +the prefix C<emx_> added. (Currently only DLL perl has this, it should +propagate to F<perl_.exe> shortly.) + =cut OS/2 extensions ~~~~~~~~~~~~~~~ -I include 3 extensions by Andread Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP, +I include 3 extensions by Andreas Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP, into my ftp directory, mirrored on CPAN. I made some minor changes needed to compile them by standard tools. I cannot test UPM and FTP, so I will appreciate your feedback. Other extensions diff --git a/README.qnx b/README.qnx new file mode 100644 index 0000000000..0cfe3533ca --- /dev/null +++ b/README.qnx @@ -0,0 +1,22 @@ +README.qnx + +Please see hints/qnx.sh for more detailed information about compiling +perl under QNX4. + +The files in the "qnx" directory are: + + * "qnx/ar" is a script that emulates the standard unix archive (aka + library) utility. Under Watcom 10.6, ar is linked to wlib and + provides the expected interface. With Watcom 9.5, a cover function + is required. This one is fairly crude but has proved adequate for + compiling perl. A more thorough version is available at: + + http://www.fdma.com/pub/qnx/porting/ar + + * "qnx/cpp" is a script that provides C preprocessing functionality. + Configure can generate a similar cover, but it doesn't handle all + the command-line options that perl throws at it. This might be + reasonably placed in /usr/local/bin. + +-- +Norton T. Allen (allen@huarp.harvard.edu) @@ -179,10 +179,13 @@ SV *val; if (!av) return 0; + if (!val) + val = &sv_undef; if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { - mg_copy((SV*)av, val, 0, key); + if (val != &sv_undef) + mg_copy((SV*)av, val, 0, key); return 0; } } @@ -192,9 +195,8 @@ SV *val; if (key < 0) return 0; } - if (!val) - val = &sv_undef; - + if (SvREADONLY(av) && key >= AvFILL(av)) + croak(no_modify); if (key > AvMAX(av)) av_extend(av,key); if (AvREIFY(av)) @@ -362,6 +364,8 @@ register AV *av; if (!av || AvFILL(av) < 0) return &sv_undef; + if (SvREADONLY(av)) + croak(no_modify); retval = AvARRAY(av)[AvFILL(av)]; AvARRAY(av)[AvFILL(av)--] = &sv_undef; if (SvSMAGICAL(av)) @@ -379,6 +383,8 @@ register I32 num; if (!av || num <= 0) return; + if (SvREADONLY(av)) + croak(no_modify); if (!AvREAL(av)) { if (AvREIFY(av)) av_reify(av); @@ -422,6 +428,8 @@ register AV *av; if (!av || AvFILL(av) < 0) return &sv_undef; + if (SvREADONLY(av)) + croak(no_modify); retval = *AvARRAY(av); if (AvREAL(av)) *AvARRAY(av) = &sv_undef; diff --git a/compat3.sym b/compat3.sym new file mode 100644 index 0000000000..db53dd67be --- /dev/null +++ b/compat3.sym @@ -0,0 +1,46 @@ +# Global symbols that should handled differently when Perl 5.004 is +# compiled for binary compatibility with version 5.003. + +# Variables from "interp.sym" that _should_ be hidden. + +curcop +curcopdb +envgv +siggv +tainting + +# Variables from "global.sym" that should _not_ be hidden. + +Error +block_type +comppad_name_floor +debug +nice_chunk +nice_chunk_size +no_myglob +no_symref +no_wrongref +pad_reset_pending +padix_floor +regflags +warn_uninit + +# Functions from "global.sym" that should _not_ be hidden. + +SvIV +SvNV +SvTRUE +SvUV +boot_core_UNIVERSAL +do_undump +safecalloc +safefree +safemalloc +saferealloc +safexcalloc +safexfree +safexmalloc +safexrealloc +save_iv +sv_pvn +yydestruct @@ -255,6 +255,17 @@ */ #define HAS_FSETPOS /**/ +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +/*#define HAS_GETTIMEOFDAY / **/ +#ifdef HAS_GETTIMEOFDAY +#define Timeval struct timeval /* Structure used by gettimeofday() */ +#endif + /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -324,6 +335,13 @@ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#define HAS_INET_ATON /**/ + /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -536,6 +554,13 @@ */ /*#define HAS_SAFE_MEMCPY / **/ +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +/*#define HAS_SANE_MEMCMP / **/ + /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field @@ -786,6 +811,24 @@ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to translate strings to doubles. + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is + * available to translate strings to integers. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to translate strings to integers. + */ +#define HAS_STRTOUL /**/ + /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -1336,6 +1379,12 @@ #define ARCHLIB "/opt/perl/lib/i86pc-solaris/5.00305" /**/ #define ARCHLIB_EXP "/opt/perl/lib/i86pc-solaris/5.00305" /**/ +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +#define BINCOMPAT3 /**/ + /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... diff --git a/config_h.SH b/config_h.SH index 1f1880964f..c6d662aaa0 100644..100755 --- a/config_h.SH +++ b/config_h.SH @@ -269,6 +269,17 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_fsetpos HAS_FSETPOS /**/ +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +#$d_gettimeod HAS_GETTIMEOFDAY /**/ +#ifdef HAS_GETTIMEOFDAY +#define Timeval struct timeval /* Structure used by gettimeofday() */ +#endif + /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -338,6 +349,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_htonl HAS_NTOHL /**/ #$d_htonl HAS_NTOHS /**/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#$d_inetaton HAS_INET_ATON /**/ + /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -550,6 +568,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_safemcpy HAS_SAFE_MEMCPY /**/ +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#$d_sanemcmp HAS_SANE_MEMCMP /**/ + /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field @@ -800,6 +825,24 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_syserrlst HAS_SYS_ERRLIST /**/ #define Strerror(e) $d_strerrm +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#$d_strtod HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#$d_strtol HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#$d_strtoul HAS_STRTOUL /**/ + /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -1350,6 +1393,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_archlib ARCHLIB "$archlib" /**/ #$d_archlib ARCHLIB_EXP "$archlibexp" /**/ +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +#$d_bincompat3 BINCOMPAT3 /**/ + /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... @@ -39,19 +39,23 @@ ENDOFBEG @non_v=(); @v_fast=(); @v_others=(); +$in_v = 0; while (<>) { next if m:^#!/bin/sh:; # Catch CONFIG=true and PATCHLEVEL=n line from Configure. s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/; - unless (m/^(\w+)='(.*)'\s*$/){ + unless ($in_v or m/^(\w+)='(.*\n)/){ push(@non_v, "#$_"); # not a name='value' line next; } - $name = $1; + if ($in_v) { $val .= $_; } + else { ($name,$val) = ($1,$2); } + $in_v = $val !~ /'\n/; + next if $in_v; if ($extensions{$name}) { s,/,::,g } - if (!$fast{$name}){ push(@v_others, $_); next; } - push(@v_fast,$_); + if (!$fast{$name}){ push(@v_others, "$name='$val"); next; } + push(@v_fast,"$name='$val"); } foreach(@non_v){ print CONFIG $_ } @@ -86,11 +90,20 @@ EOT print CONFIG <<'ENDOFEND'; sub FETCH { - # check for cached value (which maybe undef so we use exists not defined) + # check for cached value (which may be undef so we use exists not defined) return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]}); - - my($value); # search for the item in the big $config_sh string - return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); + + # Search for it in the big string + my($value, $start, $marker); + $marker = "$_[1]='"; + # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); + $start = index($config_sh, "\n$marker"); + return undef if ( ($start == -1) && # in case it's first + (substr($config_sh, 0, length($marker)) ne $marker) ); + if ($start == -1) { $start = length($marker) } + else { $start += length($marker) + 1 } + $value = substr($config_sh, $start, + index($config_sh, qq('\n), $start) - $start); $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}". $_[0]->{$_[1]} = $value; # cache it @@ -101,19 +114,23 @@ my $prevpos = 0; sub FIRSTKEY { $prevpos = 0; - my($key) = $config_sh =~ m/^(.*?)=/; - $key; + # my($key) = $config_sh =~ m/^(.*?)=/; + substr($config_sh, 0, index($config_sh, '=') ); + # $key; } sub NEXTKEY { - my $pos = index($config_sh, "\n", $prevpos) + 1; + my $pos = index($config_sh, qq('\n), $prevpos) + 2; my $len = index($config_sh, "=", $pos) - $pos; $prevpos = $pos; $len > 0 ? substr($config_sh, $pos, $len) : undef; } sub EXISTS { - exists($_[0]->{$_[1]}) or $config_sh =~ m/^$_[1]=/m; + # exists($_[0]->{$_[1]}) or $config_sh =~ m/^$_[1]=/m; + exists($_[0]->{$_[1]}) or + index($config_sh, "\n$_[1]='") != -1 or + substr($config_sh, 0, length($_[1])+2) eq "$_[1]='"; } sub STORE { die "\%Config::Config is read-only\n" } @@ -21,12 +21,18 @@ # (exit $?0) || exec sh $0 $argv:q -if test $0 -ef `echo $0 | sed -e s/configure/Configure/`; then - echo "You're configure and Configure scripts seem to be identical." + +case "$0" in +*configure) + if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then + echo "Your configure and Configure scripts seem to be identical." echo "This can happen on filesystems that aren't fully case sensitive." echo "You'll have to explicitely extract Configure and run that." exit 1 -fi + fi + ;; +esac + opts='' verbose='' create='-e' @@ -46,16 +46,18 @@ struct block_sub { cx->blk_sub.dfoutgv = defoutgv; \ (void)SvREFCNT_inc(cx->blk_sub.dfoutgv) +/* We muck with cxstack_ix since _dec may call a DESTROY, overwriting cx. */ + #define POPSUB(cx) \ if (cx->blk_sub.hasargs) { /* put back old @_ */ \ + SvREFCNT_dec(GvAV(defgv)); \ GvAV(defgv) = cx->blk_sub.savearray; \ } \ if (cx->blk_sub.cv) { \ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \ - if (cx->blk_sub.hasargs) { \ - SvREFCNT_inc((SV*)cx->blk_sub.argarray); \ - } \ + cxstack_ix++; \ SvREFCNT_dec((SV*)cx->blk_sub.cv); \ + cxstack_ix--; \ } \ } @@ -93,6 +95,7 @@ struct block_loop { OP * last_op; SV ** itervar; SV * itersave; + SV * iterlval; AV * iterary; I32 iterix; }; @@ -103,12 +106,21 @@ struct block_loop { cx->blk_loop.redo_op = cLOOP->op_redoop; \ cx->blk_loop.next_op = cLOOP->op_nextop; \ cx->blk_loop.last_op = cLOOP->op_lastop; \ - cx->blk_loop.itervar = ivar; \ - if (ivar) \ - cx->blk_loop.itersave = *cx->blk_loop.itervar; + if (cx->blk_loop.itervar = (ivar)) \ + cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);\ + cx->blk_loop.iterlval = Nullsv; \ + cx->blk_loop.iterary = Nullav; \ + cx->blk_loop.iterix = -1; #define POPLOOP(cx) \ - newsp = stack_base + cx->blk_loop.resetsp; + newsp = stack_base + cx->blk_loop.resetsp; \ + SvREFCNT_dec(cx->blk_loop.iterlval); \ + if (cx->blk_loop.itervar) { \ + SvREFCNT_dec(*cx->blk_loop.itervar); \ + *cx->blk_loop.itervar = cx->blk_loop.itersave; \ + } \ + if (cx->blk_loop.iterary && cx->blk_loop.iterary != curstack) \ + SvREFCNT_dec(cx->blk_loop.iterary); /* context common to subroutines, evals and loops */ struct block { @@ -174,8 +186,9 @@ struct subst { I32 sbu_iters; I32 sbu_maxiters; I32 sbu_safebase; - I32 sbu_once; I32 sbu_oldsave; + bool sbu_once; + bool sbu_rxtainted; char * sbu_orig; SV * sbu_dstr; SV * sbu_targ; @@ -188,8 +201,9 @@ struct subst { #define sb_iters cx_u.cx_subst.sbu_iters #define sb_maxiters cx_u.cx_subst.sbu_maxiters #define sb_safebase cx_u.cx_subst.sbu_safebase -#define sb_once cx_u.cx_subst.sbu_once #define sb_oldsave cx_u.cx_subst.sbu_oldsave +#define sb_once cx_u.cx_subst.sbu_once +#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted #define sb_orig cx_u.cx_subst.sbu_orig #define sb_dstr cx_u.cx_subst.sbu_dstr #define sb_targ cx_u.cx_subst.sbu_targ @@ -203,8 +217,9 @@ struct subst { cx->sb_iters = iters, \ cx->sb_maxiters = maxiters, \ cx->sb_safebase = safebase, \ - cx->sb_once = once, \ cx->sb_oldsave = oldsave, \ + cx->sb_once = once, \ + cx->sb_rxtainted = rxtainted, \ cx->sb_orig = orig, \ cx->sb_dstr = dstr, \ cx->sb_targ = targ, \ @@ -7,6 +7,8 @@ * */ +/* This structure much match the beginning of XPVFM */ + struct xpvcv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xp_pv as a C string */ @@ -47,6 +49,10 @@ struct xpvcv { #define CVf_CLONED 0x02 /* a clone of one of those */ #define CVf_ANON 0x04 /* CvGV() can't be trusted */ #define CVf_OLDSTYLE 0x08 +#define CVf_UNIQUE 0x10 /* can't be cloned */ +#define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV + (esp. useful for special XSUBs) */ +#define CVf_FORMAT 0x40 /* is a format, not a sub */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -63,3 +69,15 @@ struct xpvcv { #define CvOLDSTYLE(cv) (CvFLAGS(cv) & CVf_OLDSTYLE) #define CvOLDSTYLE_on(cv) (CvFLAGS(cv) |= CVf_OLDSTYLE) #define CvOLDSTYLE_off(cv) (CvFLAGS(cv) &= ~CVf_OLDSTYLE) + +#define CvUNIQUE(cv) (CvFLAGS(cv) & CVf_UNIQUE) +#define CvUNIQUE_on(cv) (CvFLAGS(cv) |= CVf_UNIQUE) +#define CvUNIQUE_off(cv) (CvFLAGS(cv) &= ~CVf_UNIQUE) + +#define CvFORMAT(cv) (CvFLAGS(cv) & CVf_FORMAT) +#define CvFORMAT_on(cv) (CvFLAGS(cv) |= CVf_FORMAT) +#define CvFORMAT_off(cv) (CvFLAGS(cv) &= ~CVf_FORMAT) + +#define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG) +#define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG) +#define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG) @@ -42,12 +42,12 @@ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) # ifdef I_STDARG void -deb(char *pat, ...) +deb(const char *pat, ...) # else /*VARARGS1*/ void deb(pat, va_alist) - char *pat; + const char *pat; va_dcl # endif { @@ -418,7 +418,7 @@ register GV *gv; (void)unlink(SvPVX(sv)); (void)rename(oldname,SvPVX(sv)); do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp); -#endif /* MSDOS */ +#endif /* DOSISH */ #else (void)UNLINK(SvPVX(sv)); if (link(oldname,SvPVX(sv)) < 0) { @@ -431,7 +431,7 @@ register GV *gv; #endif } else { -#ifndef DOSISH +#if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(oldname) < 0) { warn("Can't rename %s to %s: %s, skipping file", @@ -742,56 +742,6 @@ Off_t length; /* length to set file to */ } #endif /* F_FREESP */ -I32 -looks_like_number(sv) -SV *sv; -{ - register char *s; - register char *send; - - if (!SvPOK(sv)) { - STRLEN len; - if (!SvPOKp(sv)) - return TRUE; - s = SvPV(sv, len); - send = s + len; - } - else { - s = SvPVX(sv); - send = s + SvCUR(sv); - } - while (isSPACE(*s)) - s++; - if (s >= send) - return FALSE; - if (*s == '+' || *s == '-') - s++; - while (isDIGIT(*s)) - s++; - if (s == send) - return TRUE; - if (*s == '.') - s++; - else if (s == SvPVX(sv)) - return FALSE; - while (isDIGIT(*s)) - s++; - if (s == send) - return TRUE; - if (*s == 'e' || *s == 'E') { - s++; - if (*s == '+' || *s == '-') - s++; - while (isDIGIT(*s)) - s++; - } - while (isSPACE(*s)) - s++; - if (s >= send) - return TRUE; - return FALSE; -} - bool do_print(sv,fp) register SV *sv; @@ -1027,7 +977,7 @@ char *cmd; break; } doshell: - execl(SH_PATH, "sh", "-c", cmd, (char*)0); + execl(sh_path, "sh", "-c", cmd, (char*)0); return FALSE; } } @@ -1057,7 +1007,7 @@ char *cmd; return FALSE; } -#endif +#endif /* OS2 */ I32 apply(type,mark,sp) @@ -1073,9 +1023,10 @@ register SV **sp; if (tainting) { while (++mark <= sp) { - MAGIC *mg; - if (SvMAGICAL(*mark) && (mg = mg_find(*mark, 't')) && mg->mg_len & 1) - tainted = TRUE; + if (SvTAINTED(*mark)) { + TAINT; + break; + } } mark = oldmark; } @@ -1108,6 +1059,8 @@ register SV **sp; #ifdef HAS_KILL case OP_KILL: TAINT_PROPER("kill"); + if (mark == sp) + break; s = SvPVx(*++mark, na); tot = sp - mark; if (isUPPER(*s)) { @@ -1258,7 +1211,7 @@ register struct stat *statbufp; */ return (bit & statbufp->st_mode) ? TRUE : FALSE; -#else /* ! MSDOS */ +#else /* ! DOSISH */ if ((effective ? euid : uid) == 0) { /* root is special */ if (bit == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) @@ -1279,7 +1232,7 @@ register struct stat *statbufp; else if (statbufp->st_mode & bit >> 6) return TRUE; /* ok as "other" */ return FALSE; -#endif /* ! MSDOS */ +#endif /* ! DOSISH */ } #endif /* ! VMS */ @@ -18,14 +18,6 @@ #include <signal.h> #endif -#ifdef BUGGY_MSC - #pragma function(memcmp) -#endif /* BUGGY_MSC */ - -#ifdef BUGGY_MSC - #pragma intrinsic(memcmp) -#endif /* BUGGY_MSC */ - I32 do_trans(sv,arg) SV *sv; @@ -273,6 +265,15 @@ register SV **sarg; *t = '\0'; (void)sprintf(xs,f,SvNV(arg)); xlen = strlen(xs); +#ifdef LC_NUMERIC + /* + * User-defined locales may include arbitrary characters. + * And, unfortunately, some system may alloc the "C" locale + * to be overridden by a malicious user. + */ + if (op->op_type == OP_SPRINTF) + SvTAINTED_on(sv); +#endif /* LC_NUMERIC */ break; case 's': ch = *(++t); @@ -498,7 +499,7 @@ register SV *sv; goto nope; len -= rslen - 1; s -= rslen - 1; - if (memcmp(s, rsptr, rslen)) + if (memNE(s, rsptr, rslen)) goto nope; count += rslen; } @@ -527,19 +528,32 @@ SV *right; register char *dc; STRLEN leftlen; STRLEN rightlen; - register char *lc = SvPV(left, leftlen); - register char *rc = SvPV(right, rightlen); + register char *lc; + register char *rc; register I32 len; I32 lensave; - char *lsave = lc; - char *rsave = rc; + char *lsave; + char *rsave; - dc = SvPV_force(sv,na); + if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) + sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */ + lsave = lc = SvPV(left, leftlen); + rsave = rc = SvPV(right, rightlen); len = leftlen < rightlen ? leftlen : rightlen; lensave = len; - if (SvCUR(sv) < len) { - dc = SvGROW(sv,len + 1); - (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); + if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { + dc = SvPV_force(sv, na); + if (SvCUR(sv) < len) { + dc = SvGROW(sv, len + 1); + (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); + } + } + else { + I32 needlen = ((optype == OP_BIT_AND) + ? len : (leftlen > rightlen ? leftlen : rightlen)); + Newz(801, dc, needlen + 1, char); + (void)sv_usepvn(sv, dc, needlen); + dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } SvCUR_set(sv, len); (void)SvPOK_only(sv); @@ -1,11 +1,39 @@ #define ABORT() abort(); -#define BIT_BUCKET "\dev\nul" +#define SH_PATH "/bin/sh" + +#ifdef DJGPP +#define BIT_BUCKET "nul" +#define OP_BINARY O_BINARY +void Perl_DJGPP_init(); +#define PERL_SYS_INIT(argcp, argvp) STMT_START { \ + Perl_DJGPP_init(); } STMT_END +#else #define PERL_SYS_INIT(c,v) +#define BIT_BUCKET "\dev\nul" +#endif + #define PERL_SYS_TERM() #define dXSUB_SYS int dummy #define TMPPATH "plXXXXXX" +/* + * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were + * running on DOS, *and* if we had to cope with 16 bit memory addressing + * constraints, *and* we need to have memory allocated as unsigned long. + * + * with the advent of *real* compilers for DOS, they are not locked together. + * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have + * 16 bit memory addressing constraints". + * + * if you need the last, try #DEFINE MEM_SIZE unsigned long. + */ +#ifdef MSDOS + #ifndef DJGPP + #define HAS_64K_LIMIT + #endif +#endif + /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype) to insure @@ -27,6 +55,18 @@ */ #undef ACME_MESS /**/ +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike @@ -50,7 +50,7 @@ HV* stash; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv = (GV*)HeVAL(entry); HV *hv; - if (GvCV(gv)) + if (GvCVu(gv)) dump_sub(gv); if (GvFORM(gv)) dump_form(gv); @@ -189,10 +189,17 @@ register OP *op; (void)strcat(buf,"AMPER,"); if (op->op_private & OPpENTERSUB_DB) (void)strcat(buf,"DB,"); - if (op->op_private & OPpDEREF_AV) - (void)strcat(buf,"AV,"); - if (op->op_private & OPpDEREF_HV) - (void)strcat(buf,"HV,"); + switch (op->op_private & OPpDEREF) { + case OPpDEREF_SV: + (void)strcat(buf, "SV,"); + break; + case OPpDEREF_AV: + (void)strcat(buf, "AV,"); + break; + case OPpDEREF_HV: + (void)strcat(buf, "HV,"); + break; + } if (op->op_private & HINT_STRICT_REFS) (void)strcat(buf,"STRICT_REFS,"); } @@ -357,8 +364,6 @@ register PMOP *pm; (void)strcat(buf,"ALL,"); if (pm->op_pmflags & PMf_SKIPWHITE) (void)strcat(buf,"SKIPWHITE,"); - if (pm->op_pmflags & PMf_FOLD) - (void)strcat(buf,"FOLD,"); if (pm->op_pmflags & PMf_CONST) (void)strcat(buf,"CONST,"); if (pm->op_pmflags & PMf_KEEP) @@ -13,7 +13,7 @@ of a system to check on and report various kinds of anomalies. If you machine doesn't support #!, the first thing you'll want to do is replace the #! with a couple of lines that look like this: - eval "exec /usr/bin/perl -S $0 $*" + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if $running_under_some_shell; being sure to include any flags that were on the #! line. A supplied script @@ -1,4 +1,4 @@ -eval "exec /usr/bin/perl -Spi.bak $0 $*" +eval 'exec /usr/bin/perl -Spi.bak $0 ${1+"$@"}' if $running_under_some_shell; # $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $ @@ -6,5 +6,6 @@ eval "exec /usr/bin/perl -Spi.bak $0 $*" # This script makes #! scripts directly executable on machines that don't # support #!. It edits in place any scripts mentioned on the command line. -s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| +s[^#!(.*)] + [#!$1\neval 'exec $1 -S \$0 \${1+"\$@"}'\n\tif \$running_under_some_shell;] if $. == 1; diff --git a/eg/sysvipc/ipcmsg b/eg/sysvipc/ipcmsg index 317e027ea7..646d8b6aed 100644 --- a/eg/sysvipc/ipcmsg +++ b/eg/sysvipc/ipcmsg @@ -1,6 +1,6 @@ #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' - if 0; + if $running_under_some_shell; require 'sys/ipc.ph'; require 'sys/msg.ph'; diff --git a/eg/sysvipc/ipcsem b/eg/sysvipc/ipcsem index d72a2dd77c..4d871b901a 100644 --- a/eg/sysvipc/ipcsem +++ b/eg/sysvipc/ipcsem @@ -1,6 +1,6 @@ #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' - if 0; + if $running_under_some_shell; require 'sys/ipc.ph'; require 'sys/msg.ph'; diff --git a/eg/sysvipc/ipcshm b/eg/sysvipc/ipcshm index d40e46b945..ecc1ba4366 100644 --- a/eg/sysvipc/ipcshm +++ b/eg/sysvipc/ipcshm @@ -1,6 +1,6 @@ #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' - if 0; + if $running_under_some_shell; require 'sys/ipc.ph'; require 'sys/shm.ph'; diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index c78a148e45..6fa07ad29a 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -10,7 +10,7 @@ ;; This file is not (yet) part of GNU Emacs. It may be distributed ;; either under the same terms as GNU Emacs, or under the same terms -;; as Perl. You should have recieved a copy of Perl Artistic license +;; as Perl. You should have received a copy of Perl Artistic license ;; along with the Perl distribution. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -24,13 +24,15 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + ;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de -;; $Id: cperl-mode.el,v 1.25 1996/09/06 09:51:41 ilya Exp ilya $ +;; $Id: cperl-mode.el,v 1.31+ 1996/12/09 08:03:14 ilya Exp ilya $ ;;; To use this mode put the following into your .emacs file: @@ -44,6 +46,10 @@ ;;; in your .emacs file. (Emacs rulers do not consider it politically ;;; correct to make whistles enabled by default.) +;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<< +;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< +;;; `cperl-non-problems'. <<<<<< + ;;; Additional useful commands to put into your .emacs file: ;; (setq auto-mode-alist @@ -53,7 +59,7 @@ ;;; The mode information (on C-h m) provides customization help. ;;; If you use font-lock feature of this mode, it is advisable to use -;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp +;;; either lazy-lock-mode or fast-lock-mode (available on ELisp ;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. ;;; Faces used now: three faces for first-class and second-class keywords @@ -63,12 +69,12 @@ ;;; not define them, so you need to define them manually. Maybe you have ;;; an obsolete font-lock from 19.28 or earlier. Upgrade. -;;; If you have grayscale monitor, and do not have the variable +;;; If you have a grayscale monitor, and do not have the variable ;;; font-lock-display-type bound to 'grayscale, insert ;;; (setq font-lock-display-type 'grayscale) -;;; to your .emacs file. +;;; into your .emacs file. ;;;; This mode supports font-lock, imenu and mode-compile. In the ;;;; hairy version font-lock is on, but you should activate imenu @@ -289,7 +295,7 @@ ;;; Electric-; should work better. ;;; Minor bugs with POD marking. -;;;; After 1.25 +;;;; After 1.25 (probably not...) ;;; `cperl-info-page' introduced. ;;; To make `uncomment-region' working, `comment-region' would ;;; not insert extra space. @@ -302,10 +308,52 @@ ;;; are not treated. ;;; POD/friends scan merged in one pass. ;;; Syntax class is not used for analyzing the code, only char-syntax -;;; may be cecked against _ or'ed with w. +;;; may be checked against _ or'ed with w. ;;; Syntax class of `:' changed to be _. ;;; `cperl-find-bad-style' added. +;;;; After 1.25 +;;; When search for here-documents, we ignore commented << in simplest cases. +;;; `cperl-get-help' added, available on C-h v and from menu. +;;; Auto-help added. Default with `cperl-hairy', switchable on/off +;;; with startup variable `cperl-lazy-help-time' and from +;;; menu. Requires `run-with-idle-timer'. +;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. + +;;;; After 1.27 +;;; Indentation: At toplevel after a label - fixed. +;;; 1.27 was put to archives in binary mode ===> DOSish :-( + +;;;; After 1.28 +;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in +;;; comments and docstrings corrected, XEmacs support cleaned up. +;;; The closing parenths would enclose the region into matching +;;; parens under the same conditions as the opening ones. +;;; Minor updates to `cperl-short-docs'. +;;; Will not consider <<= as start of here-doc. + +;;;; After 1.29 +;;; Added an extra advice to look into Micro-docs. ;-). +;;; Enclosing of region when you press a closing parenth is regulated by +;;; `cperl-electric-parens-string'. +;;; Minor updates to `cperl-short-docs'. +;;; `initialize-new-tags-table' called only if present (Does this help +;;; with generation of tags under XEmacs?). +;;; When creating/updating tag files, new info is written at the old place, +;;; or at the end (is this a wanted behaviour? I need this in perl build directory). + +;;;; After 1.30 +;;; All the keywords from keywords.pl included (maybe with dummy explanation). +;;; No auto-help inside strings, comment, here-docs, formats, and pods. +;;; Shrinkwrapping of info, regulated by `cperl-max-help-size'. +;;; Info on variables as well. +;;; Recognision of HERE-DOCS improved yet more. +;;; Autonewline works on `}' without warnings. +;;; Autohelp works again on $_[0]. + +;;;; After 1.31 +;;; perl-descr.el found its author - hi, Johan! + (defvar cperl-extra-newline-before-brace nil "*Non-nil means that if, elsif, while, until, else, for, foreach and do constructs look like: @@ -366,7 +414,7 @@ Can be overwritten by `cperl-hairy' if nil.") "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '. Can be overwritten by `cperl-hairy' if nil.") -(defvar cperl-electric-parens-string "({[<" +(defvar cperl-electric-parens-string "({[]})<" "*String of parentheses that should be electric in CPerl.") (defvar cperl-electric-parens nil @@ -409,6 +457,9 @@ Can be overwritten by `cperl-hairy' if nil.") The opposite behaviour is always available if prefixed with C-c. Can be overwritten by `cperl-hairy' if nil.") +(defvar cperl-lazy-help-time nil + "*Not-nil (and non-null) means to show lazy help after given idle time.") + (defvar cperl-pod-face 'font-lock-comment-face "*The result of evaluation of this expression is used for pod highlighting.") @@ -430,8 +481,14 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres].") "*Not-nil means add backreferences to generated `imenu's. May require patched `imenu' and `imenu-go'.") +(defvar cperl-max-help-size 66 + "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents.") + +(defvar cperl-shrink-wrap-info-frame t + "*Non-nil means shrink-wrapping of info-buffer-frame allowed.") + (defvar cperl-info-page "perl" - "Name of the info page containging perl docs. + "Name of the info page containing perl docs. Older version of this page was called `perl5', newer `perl'.") @@ -469,6 +526,8 @@ CPerl/Tools/Tags menu beforehand. Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. +Switch auto-help on/off with CPerl/Tools/Auto-help. + Before reporting (non-)problems look in the problem section on what I know about them.") @@ -479,26 +538,26 @@ It may be corrected on the level of C code, please look in the `non-problems' section if you want to volunteer. CPerl mode tries to corrects some Emacs misunderstandings, however, -for effeciency reasons the degree of correction is different for +for efficiency reasons the degree of correction is different for different operations. The partially corrected problems are: POD sections, here-documents, regexps. The operations are: highlighting, indentation, electric keywords, electric braces. This may be confusing, since the regexp s#//#/#\; may be highlighted -as a comment, but it will recognized as a regexp by the indentation +as a comment, but it will be recognized as a regexp by the indentation code. Or the opposite case, when a pod section is highlighted, but breaks the indentation of the following code. The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think out is +${aaa} look like unbalanced braces. The only trick I can think of is to insert it as $ {aaa} (legal in perl5, not in perl4). Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transpositinon is not always possible +as /($|\\s)/. Note that such a transposition is not always possible :-(. " ) (defvar cperl-non-problems 'please-ignore-this-line -"As you know from `problems' section, Perl syntax too hard for CPerl. +"As you know from `problems' section, Perl syntax is too hard for CPerl. Most the time, if you write your own code, you may find an equivalent \(and almost as readable) expression. @@ -521,6 +580,10 @@ will not break indentation, but 1 if ( s#//#/# ); will. +By similar reasons + s\"abc\"def\"; +will confuse CPerl a lot. + If you still get wrong indentation in situation that you think the code should be able to parse, try: @@ -530,7 +593,7 @@ b) Supply the code to me (IZ). Pods are treated _very_ rudimentally. Here-documents are not treated at all (except highlighting and inhibiting indentation). (This may change some time. RMS approved making syntax lookup recognize text -attributes, but volonteers are needed to change Emacs C code.) +attributes, but volunteers are needed to change Emacs C code.) To speed up coloring the following compromises exist: a) sub in $mypackage::sub may be highlighted. @@ -546,8 +609,13 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ;;; Portability stuff: -(defsubst cperl-xemacs-p () - (string-match "XEmacs\\|Lucid" emacs-version)) +(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) +(defmacro cperl-define-key (fsf-key definition &optional xemacs-key) + `(define-key cperl-mode-map + ,(if xemacs-key + `(if cperl-xemacs-p ,xemacs-key ,fsf-key) + fsf-key) + ,definition)) (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -556,7 +624,7 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (and (vectorp del-back-ch) (= (length del-back-ch) 1) (setq del-back-ch (aref del-back-ch 0))) -(if (cperl-xemacs-p) +(if cperl-xemacs-p (progn ;; "Active regions" are on: use region only if active ;; "Active regions" are off: use region unconditionally @@ -568,10 +636,10 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (defun cperl-mark-active () mark-active)) (defsubst cperl-enable-font-lock () - (or (cperl-xemacs-p) window-system)) + (or cperl-xemacs-p window-system)) (if (boundp 'unread-command-events) - (if (cperl-xemacs-p) + (if cperl-xemacs-p (defun cperl-putback-char (c) ; XEmacs >= 19.12 (setq unread-command-events (list (character-to-event c)))) (defun cperl-putback-char (c) ; Emacs 19 @@ -628,39 +696,37 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (if cperl-mode-map nil (setq cperl-mode-map (make-sparse-keymap)) - (define-key cperl-mode-map "{" 'cperl-electric-lbrace) - (define-key cperl-mode-map "[" 'cperl-electric-paren) - (define-key cperl-mode-map "(" 'cperl-electric-paren) - (define-key cperl-mode-map "<" 'cperl-electric-paren) - (define-key cperl-mode-map "}" 'cperl-electric-brace) - (define-key cperl-mode-map ";" 'cperl-electric-semi) - (define-key cperl-mode-map ":" 'cperl-electric-terminator) - (define-key cperl-mode-map "\C-j" 'newline-and-indent) - (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed) - (define-key cperl-mode-map "\C-c\C-a" 'cperl-toggle-auto-newline) - (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev) - (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric) - (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound - ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\177" 'cperl-electric-backspace) - (define-key cperl-mode-map "\t" 'cperl-indent-command) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command) - (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control c) (control h) f] - 'cperl-info-on-current-command) - (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command)) - (if (and (cperl-xemacs-p) + (cperl-define-key "{" 'cperl-electric-lbrace) + (cperl-define-key "[" 'cperl-electric-paren) + (cperl-define-key "(" 'cperl-electric-paren) + (cperl-define-key "<" 'cperl-electric-paren) + (cperl-define-key "}" 'cperl-electric-brace) + (cperl-define-key "]" 'cperl-electric-rparen) + (cperl-define-key ")" 'cperl-electric-rparen) + (cperl-define-key ";" 'cperl-electric-semi) + (cperl-define-key ":" 'cperl-electric-terminator) + (cperl-define-key "\C-j" 'newline-and-indent) + (cperl-define-key "\C-c\C-j" 'cperl-linefeed) + (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) + (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) + (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) + (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound + ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) + ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\177" 'cperl-electric-backspace) + (cperl-define-key "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-hv" 'cperl-get-help [(control h) v]) + (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn ;; substitute-key-definition is usefulness-deenhanced... - (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region)) + (cperl-define-key "\M-q" 'cperl-fill-paragraph) + (cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\e\C-\\" 'cperl-indent-region)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp cperl-mode-map global-map) @@ -728,7 +794,11 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ["Define word at point" imenu-go-find-at-position (fboundp 'imenu-go-find-at-position)] ["Help on function" cperl-info-on-command t] - ["Help on function at point" cperl-info-on-current-command t]) + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Auto-help on" cperl-lazy-install (fboundp 'run-with-idle-timer)] + ["Auto-help off" cperl-lazy-unstall + (fboundp 'run-with-idle-timer)]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -830,13 +900,13 @@ between the braces. If CPerl decides that you want to insert it will not do any expansion. See also help on variable `cperl-extra-newline-before-brace'. -\\[cperl-linefeed] is a convinience replacement for typing carriage +\\[cperl-linefeed] is a convenience replacement for typing carriage return. It places you in the next line with proper indentation, or if you type it inside the inline block of control construct, like foreach (@lines) {print; print} and you are on a boundary of a statement inside braces, it will transform the construct into a multiline and will place you into an -apporpriately indented blank line. If you need a usual +appropriately indented blank line. If you need a usual `newline-and-indent' behaviour, it is on \\[newline-and-indent], see documentation on `cperl-electric-linefeed'. @@ -862,6 +932,15 @@ These keys run commands `cperl-info-on-current-command' and `cperl-info-on-command', which one is which is controlled by variable `cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). +Even if you have no info-format documentation, short one-liner-style +help is available on \\[cperl-get-help]. + +It is possible to show this help automatically after some idle +time. This is regulated by variable `cperl-lazy-help-time'. Default +with `cperl-hairy' is 5 secs idle time if the value of this variable +is nil. It is also possible to switch this on/off from the +menu. Requires `run-with-idle-timer'. + Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', `cperl-pod-face', `cperl-pod-head-face' control processing of pod and here-docs sections. In a future version results of scan may be used @@ -926,15 +1005,10 @@ with no args." (local-set-key "\C-C\C-J" 'newline-and-indent))) (if (cperl-val 'cperl-info-on-command-no-prompt) (progn - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control h) f] 'cperl-info-on-current-command) - (local-set-key "\C-hf" 'cperl-info-on-current-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control c) (control h) f] - 'cperl-info-on-command) - (local-set-key "\C-c\C-hf" 'cperl-info-on-command)))) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command + [(control c) (control h) f]))) (setq major-mode 'perl-mode) (setq mode-name "CPerl") (if (not cperl-mode-abbrev-table) @@ -1009,6 +1083,8 @@ with no args." (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) + (if (featurep 'easymenu) + (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs. (run-hooks 'cperl-mode-hook) ;; After hooks since fontification will break this (if cperl-pod-here-scan (cperl-find-pods-heres))) @@ -1089,7 +1165,7 @@ with no args." ;;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () - "Substite for `indent-for-comment' in CPerl." + "Substitute for `indent-for-comment' in CPerl." (interactive) (let (cperl-wrong-comment) (indent-for-comment) @@ -1111,6 +1187,8 @@ See `comment-region'." (let ((comment-start "#")) (comment-region b e (- arg)))) +(defvar cperl-brace-recursing nil) + (defun cperl-electric-brace (arg &optional only-before) "Insert character and correct line's indentation. If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the @@ -1118,55 +1196,74 @@ place (even in empty line), but not after. If after \")\" and the inserted char is \"{\", insert extra newline before only if `cperl-extra-newline-before-brace'." (interactive "P") - (let (insertpos) - (if (and (not arg) ; No args, end (of empty line or auto) - (eolp) - (or (and (null only-before) - (save-excursion - (skip-chars-backward " \t") - (bolp))) - (and (eq last-command-char ?\{) ; Do not insert newline - ;; if after ")" and `cperl-extra-newline-before-brace' - ;; is nil, do not insert extra newline. - (not cperl-extra-newline-before-brace) - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) - (if cperl-auto-newline - (progn (cperl-indent-line) (newline) t) nil))) + (let (insertpos + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil))) + (if (and other-end + (not cperl-brace-recursing) + (cperl-val 'cperl-electric-parens) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) + ;; Need to insert a matching pair (progn - (if cperl-auto-newline - (setq insertpos (point))) - (insert last-command-char) - (cperl-indent-line) - (if (and cperl-auto-newline (null only-before)) - (progn - (newline) - (cperl-indent-line))) (save-excursion - (if insertpos (progn (goto-char insertpos) - (search-forward (make-string - 1 last-command-char)) - (setq insertpos (1- (point))))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) + (setq insertpos (point-marker)) + (goto-char other-end) + (setq last-command-char ?\{) + (cperl-electric-lbrace arg insertpos)) + (forward-char 1)) + (if (and (not arg) ; No args, end (of empty line or auto) + (eolp) + (or (and (null only-before) + (save-excursion + (skip-chars-backward " \t") + (bolp))) + (and (eq last-command-char ?\{) ; Do not insert newline + ;; if after ")" and `cperl-extra-newline-before-brace' + ;; is nil, do not insert extra newline. + (not cperl-extra-newline-before-brace) + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) + (if cperl-auto-newline + (progn (cperl-indent-line) (newline) t) nil))) + (progn + (insert last-command-char) + (cperl-indent-line) + (if cperl-auto-newline + (setq insertpos (1- (point)))) + (if (and cperl-auto-newline (null only-before)) + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg)))))) -(defun cperl-electric-lbrace (arg) +(defun cperl-electric-lbrace (arg &optional end) "Insert character, correct line's indentation, correct quoting by space." (interactive "P") (let (pos after + (cperl-brace-recursing t) (cperl-auto-newline cperl-auto-newline) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) + (other-end (or end + (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil)))) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -1215,10 +1312,42 @@ char is \"{\", insert extra newline before only if (insert last-command-char) ))) +(defun cperl-electric-rparen (arg) + "Insert a matching pair of parentheses if marking is active. +If not, or if we are not at the end of marking range, would self-insert." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point))) + (other-end (if (and cperl-electric-parens-mark + (cperl-val 'cperl-electric-parens) + (memq last-command-char + (append cperl-electric-parens-string nil)) + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil)) + p) + (if (and other-end + (cperl-val 'cperl-electric-parens) + (memq last-command-char '( ?\) ?\] ?\} ?\> )) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + ) + (progn + (insert last-command-char) + (setq p (point)) + (if other-end (goto-char other-end)) + (insert (cdr (assoc last-command-char '((?\} . ?\{) + (?\] . ?\[) + (?\) . ?\() + (?\> . ?\<))))) + (goto-char (1+ p))) + (call-interactively 'self-insert-command) + ))) + (defun cperl-electric-keyword () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq (preceding-char) ?$))) + (dollar (eq last-command-char ?$))) (and (save-excursion (backward-sexp 1) (cperl-after-expr-p nil "{};:")) @@ -1659,7 +1788,12 @@ Returns nil if line starts inside a string, t if in a comment." ;; Now add a little if this is a continuation line. (if (or (bobp) (memq (preceding-char) (append " ;}" nil)) ; Was ?\) - (memq char-after (append ")]}" nil))) + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label + (progn + (forward-sexp -1) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 0 cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) @@ -1721,7 +1855,7 @@ Returns nil if line starts inside a string, t if in a comment." (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1744,7 +1878,7 @@ Returns nil if line starts inside a string, t if in a comment." (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (+ old-indent cperl-indent-level)) (current-column))))) ;; If no previous statement, @@ -1894,7 +2028,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1920,7 +2054,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." (if (> (current-indentation) cperl-min-label-indent) (list (list 'label-in-block (point))) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (list (list 'label-in-block-min-indent (point)))) ;; Before statement @@ -2042,9 +2176,20 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\`\n?\\|\n\n\\)=" "\\|" ;; One extra () before this: - "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + "<<" + "\\(" + ;; First variant "BLAH" or just ``. + "\\([\"'`]\\)" + "\\([^\"'`\n]*\\)" + "\\3" + "\\|" + ;; Second variant: Identifier or empty + "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" + ;; Check that we do not have <<= or << 30 or << $blah. + "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" + "\\)" "\\|" - ;; 1+5 extra () before this: + ;; 1+6 extra () before this: "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) (unwind-protect (progn @@ -2105,74 +2250,82 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (match-beginning 1) (match-end 1) 'face head-face)))) (goto-char e))) - ;; 1 () ahead - ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" - ((match-beginning 2) ; 1 + 1 - (if (match-beginning 5) ;4 + 1 - (setq b1 (match-beginning 5) ; 4 + 1 - e1 (match-end 5)) ; 4 + 1 - (setq b1 (match-beginning 4) ; 3 + 1 - e1 (match-end 4))) ; 3 + 1 - (setq tag (buffer-substring b1 e1) - qtag (regexp-quote tag)) - (cond (cperl-pod-here-fontify - (put-text-property b1 e1 'face font-lock-reference-face) - (cperl-put-do-not-fontify b1 e1))) - (forward-line) - (setq b (point)) - (cond ((re-search-forward (concat "^" qtag "$") max 'toend) - (if cperl-pod-here-fontify - (progn - (put-text-property (match-beginning 0) (match-end 0) - 'face font-lock-reference-face) - (cperl-put-do-not-fontify b (match-end 0)) - ;;(put-text-property (max (point-min) (1- b)) - ;; (min (point-max) - ;; (1+ (match-end 0))) - ;; cperl-do-not-fontify t) - (put-text-property b (match-beginning 0) - 'face here-face))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc) - (cperl-put-do-not-fontify b (match-beginning 0))) - (t (message "End of here-document `%s' not found." tag)))) - (t - ;; 1+5=6 extra () before this: - ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) - (setq b (point) - name (if (match-beginning 7) ; 6 + 1 - (buffer-substring (match-beginning 7) ; 6 + 1 - (match-end 7)) ; 6 + 1 - "")) - (setq argument nil) - (if cperl-pod-here-fontify - (while (and (eq (forward-line) 0) - (not (looking-at "^[.;]$"))) - (cond - ((looking-at "^#")) ; Skip comments - ((and argument ; Skip argument multi-lines - (looking-at "^[ \t]*{")) - (forward-sexp 1) - (setq argument nil)) - (argument ; Skip argument lines - (setq argument nil)) - (t ; Format line - (setq b1 (point)) - (setq argument (looking-at "^[^\n]*[@^]")) - (end-of-line) - (put-text-property b1 (point) - 'face font-lock-string-face) - (cperl-put-do-not-fontify b1 (point))))) - (re-search-forward (concat "^[.;]$") max 'toend)) - (beginning-of-line) - (if (looking-at "^[.;]$") - (progn - (put-text-property (point) (+ (point) 2) - 'face font-lock-string-face) - (cperl-put-do-not-fontify (point) (+ (point) 2))) - (message "End of format `%s' not found." name)) - (forward-line) - (put-text-property b (point) 'syntax-type 'format) + ;; Here document + ;; 1 () ahead + ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + ((match-beginning 2) ; 1 + 1 + ;; Abort in comment (_extremely_ simplified): + (setq b (point)) + (if (save-excursion + (beginning-of-line) + (search-forward "#" b t)) + nil + (if (match-beginning 5) ;4 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5)) ; 4 + 1 + (setq b1 (match-beginning 4) ; 3 + 1 + e1 (match-end 4))) ; 3 + 1 + (setq tag (buffer-substring b1 e1) + qtag (regexp-quote tag)) + (cond (cperl-pod-here-fontify + (put-text-property b1 e1 'face font-lock-reference-face) + (cperl-put-do-not-fontify b1 e1))) + (forward-line) + (setq b (point)) + (cond ((re-search-forward (concat "^" qtag "$") max 'toend) + (if cperl-pod-here-fontify + (progn + (put-text-property (match-beginning 0) (match-end 0) + 'face font-lock-reference-face) + (cperl-put-do-not-fontify b (match-end 0)) + ;;(put-text-property (max (point-min) (1- b)) + ;; (min (point-max) + ;; (1+ (match-end 0))) + ;; cperl-do-not-fontify t) + (put-text-property b (match-beginning 0) + 'face here-face))) + (put-text-property b (match-beginning 0) + 'syntax-type 'here-doc) + (cperl-put-do-not-fontify b (match-beginning 0))) + (t (message "End of here-document `%s' not found." tag))))) + ;; format + (t + ;; 1+6=7 extra () before this: + ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) + (setq b (point) + name (if (match-beginning 8) ; 7 + 1 + (buffer-substring (match-beginning 8) ; 7 + 1 + (match-end 8)) ; 7 + 1 + "")) + (setq argument nil) + (if cperl-pod-here-fontify + (while (and (eq (forward-line) 0) + (not (looking-at "^[.;]$"))) + (cond + ((looking-at "^#")) ; Skip comments + ((and argument ; Skip argument multi-lines + (looking-at "^[ \t]*{")) + (forward-sexp 1) + (setq argument nil)) + (argument ; Skip argument lines + (setq argument nil)) + (t ; Format line + (setq b1 (point)) + (setq argument (looking-at "^[^\n]*[@^]")) + (end-of-line) + (put-text-property b1 (point) + 'face font-lock-string-face) + (cperl-put-do-not-fontify b1 (point))))) + (re-search-forward (concat "^[.;]$") max 'toend)) + (beginning-of-line) + (if (looking-at "^[.;]$") + (progn + (put-text-property (point) (+ (point) 2) + 'face font-lock-string-face) + (cperl-put-do-not-fontify (point) (+ (point) 2))) + (message "End of format `%s' not found." name)) + (forward-line) + (put-text-property b (point) 'syntax-type 'format) ;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) ;;; (if cperl-pod-here-fontify ;;; (progn @@ -2183,7 +2336,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; 'syntax-type 'format) ;;; (cperl-put-do-not-fontify b (match-beginning 0))) ;;; (t (message "End of format `%s' not found." name))) - ))) + ))) ;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) ;;; (if (looking-at "\n*cut\\>") ;;; (progn @@ -2734,36 +2887,43 @@ indentation and initial hashes. Behaves usually outside of comment." "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style - ; for overwritable buildins + ; for overwritable builtins (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2" - ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr" - ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos" - ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent" - ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec" - ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "formline" "ge" "getc" - ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" - ;; "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" - ;; "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" - ;; "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" - ;; "getservbyname" "getservbyport" "getservent" "getsockname" - ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" "ioctl" - ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen" - ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv" - ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" - ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink" - ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse" - ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl" - ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent" - ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" - ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown" - ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat" - ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink" - ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn" - ;; "write" "x" "xor" + ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; "and" "atan2" "bind" "binmode" "bless" "caller" + ;; "chdir" "chmod" "chown" "chr" "chroot" "close" + ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" + ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" + ;; "endhostent" "endnetent" "endprotoent" "endpwent" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "fileno" "flock" "fork" "formline" "ge" "getc" + ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" + ;; "gethostbyname" "gethostent" "getlogin" + ;; "getnetbyaddr" "getnetbyname" "getnetent" + ;; "getpeername" "getpgrp" "getppid" "getpriority" + ;; "getprotobyname" "getprotobynumber" "getprotoent" + ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" + ;; "getservbyport" "getservent" "getsockname" + ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" + ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" + ;; "link" "listen" "localtime" "log" "lstat" "lt" + ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" + ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + ;; "quotemeta" "rand" "read" "readdir" "readline" + ;; "readlink" "readpipe" "recv" "ref" "rename" "require" + ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" + ;; "seekdir" "select" "semctl" "semget" "semop" "send" + ;; "setgrent" "sethostent" "setnetent" "setpgrp" + ;; "setpriority" "setprotoent" "setpwent" "setservent" + ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" + ;; "shutdown" "sin" "sleep" "socket" "socketpair" + ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" + ;; "syscall" "sysread" "system" "syswrite" "tell" + ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" + ;; "umask" "unlink" "unpack" "utime" "values" "vec" + ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" "b\\(in\\(d\\|mode\\)\\|less\\)\\|" "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" @@ -2797,18 +2957,20 @@ indentation and initial hashes. Behaves usually outside of comment." "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style - ;; for nonoverwritable buildins - ;; Somehow 's', 'm' are not autogenerated??? + ;; for nonoverwritable builtins + ;; Somehow 's', 'm' are not auto-generated??? (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop" - ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for" - ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map" - ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q" - ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice" - ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie" - ;; "until" "use" "while" "y" + ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" + ;; "chop" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "grep" "if" "keys" "last" "local" "map" "my" "next" + ;; "no" "package" "pop" "pos" "print" "printf" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" + ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "undef" "unless" "unshift" "untie" "until" "use" + ;; "while" "y" "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" @@ -2825,7 +2987,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "#include" "#define" "#undef") ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1 font-lock-function-name-face) '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; @@ -2871,8 +3033,14 @@ indentation and initial hashes. Behaves usually outside of comment." (setq t-font-lock-keywords-1 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12 - '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 + '( + ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + (if (eq (char-after (match-beginning 2)) ?%) + font-lock-other-emphasized-face + font-lock-emphasized-face) + t) ; arrays and hashes + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) @@ -2880,11 +3048,6 @@ indentation and initial hashes. Behaves usually outside of comment." font-lock-emphasized-face) ; arrays and hashes font-lock-variable-name-face) ; Just to put something t) - ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 - (if (eq (char-after (match-beginning 2)) ?%) - font-lock-other-emphasized-face - font-lock-emphasized-face) - t) ; arrays and hashes ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") ;;; Too much noise from \s* @s[ and friends ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" @@ -2996,7 +3159,7 @@ indentation and initial hashes. Behaves usually outside of comment." 'font-lock-other-type-face "Face to use for data types from another group.") ) - (if (not (cperl-xemacs-p)) nil + (if (not cperl-xemacs-p) nil (or (boundp 'font-lock-comment-face) (defconst font-lock-comment-face 'font-lock-comment-face @@ -3182,34 +3345,52 @@ Available styles are GNU, K&R, BSD and Whitesmith." (let ((perl-dbg-flags "-wc")) (mode-compile))) -(defun cperl-info-buffer () - ;; Returns buffer with documentation. Creats if missing - (let ((info (get-buffer "*info-perl*"))) +(defun cperl-info-buffer (type) + ;; Returns buffer with documentation. Creates if missing. + ;; If TYPE, this vars buffer. + ;; Special care is taken to not stomp over an existing info buffer + (let* ((bname (if type "*info-perl-var*" "*info-perl*")) + (info (get-buffer bname)) + (oldbuf (get-buffer "*info*"))) (if info info (save-window-excursion ;; Get Info running (require 'info) + (cond (oldbuf + (set-buffer oldbuf) + (rename-buffer "*info-perl-tmp*"))) (save-window-excursion (info)) - (Info-find-node cperl-info-page "perlfunc") + (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) (set-buffer "*info*") - (rename-buffer "*info-perl*") + (rename-buffer bname) + (cond (oldbuf + (set-buffer "*info-perl-tmp*") + (rename-buffer "*info*") + (set-buffer bname))) + (make-variable-buffer-local 'window-min-height) + (setq window-min-height 2) (current-buffer))))) (defun cperl-word-at-point (&optional p) ;; Returns the word at point or at P. (save-excursion (if p (goto-char p)) - (require 'etags) - (funcall (or (and (boundp 'find-tag-default-function) - find-tag-default-function) - (get major-mode 'find-tag-default-function) - ;; XEmacs 19.12 has `find-tag-default-hook'; it is - ;; automatically used within `find-tag-default': - 'find-tag-default)))) + (or (cperl-word-at-point-hard) + (progn + (require 'etags) + (funcall (or (and (boundp 'find-tag-default-function) + find-tag-default-function) + (get major-mode 'find-tag-default-function) + ;; XEmacs 19.12 has `find-tag-default-hook'; it is + ;; automatically used within `find-tag-default': + 'find-tag-default)))))) (defun cperl-info-on-command (command) - "Shows documentation for Perl command in other window." + "Shows documentation for Perl command in other window. +If perl-info buffer is shown in some frame, uses this frame. +Customized by setting variables `cperl-shrink-wrap-info-frame', +`cperl-max-help-size'." (interactive (let* ((default (cperl-word-at-point)) (read (read-string @@ -3221,21 +3402,72 @@ Available styles are GNU, K&R, BSD and Whitesmith." (let ((buffer (current-buffer)) (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" - pos) + pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner + max-height char-height buf-list) (if (string-match "^-[a-zA-Z]$" command) (setq cmd-desc "^-X[ \t\n]")) - (set-buffer (cperl-info-buffer)) + (setq isvar (string-match "^[$@%]" command) + buf (cperl-info-buffer isvar) + iniwin (selected-window) + fr1 (window-frame iniwin)) + (set-buffer buf) (beginning-of-buffer) - (re-search-forward "^-X[ \t\n]") - (forward-line -1) + (or isvar + (progn (re-search-forward "^-X[ \t\n]") + (forward-line -1))) (if (re-search-forward cmd-desc nil t) (progn - (setq pos (progn (beginning-of-line) - (point))) - (pop-to-buffer (cperl-info-buffer)) + ;; Go back to beginning of the group (ex, for qq) + (if (re-search-backward "^[ \t\n\f]") + (forward-line 1)) + (beginning-of-line) + ;; Get some of + (setq pos (point) + buf-list (list buf "*info-perl-var*" "*info-perl*")) + (while (and (not win) buf-list) + (setq win (get-buffer-window (car buf-list) t)) + (setq buf-list (cdr buf-list))) + (or (not win) + (eq (window-buffer win) buf) + (set-window-buffer win buf)) + (and win (setq fr2 (window-frame win))) + (if (or (not fr2) (eq fr1 fr2)) + (pop-to-buffer buf) + (special-display-popup-frame buf) ; Make it visible + (select-window win)) + (goto-char pos) ; Needed (?!). + ;; Resize + (setq iniheight (window-height) + frheight (frame-height) + not-loner (< iniheight (1- frheight))) ; Are not alone + (cond ((if not-loner cperl-max-help-size + cperl-shrink-wrap-info-frame) + (setq height + (+ 2 + (count-lines + pos + (save-excursion + (if (re-search-forward + "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) + (match-beginning 0) (point-max))))) + max-height + (if not-loner + (/ (* (- frheight 3) cperl-max-help-size) 100) + (setq char-height (frame-char-height)) + ;; Non-functioning under OS/2: + (if (eq char-height 1) (setq char-height 18)) + ;; Title, menubar, + 2 for slack + (- (/ (x-display-pixel-height) char-height) 4) + )) + (if (> height max-height) (setq height max-height)) + ;;(message "was %s doing %s" iniheight height) + (if not-loner + (enlarge-window (- height iniheight)) + (set-frame-height (window-frame win) (1+ height))))) (set-window-start (selected-window) pos)) (message "No entry for %s found." command)) - (pop-to-buffer buffer))) + ;;(pop-to-buffer buffer) + (select-window iniwin))) (defun cperl-info-on-current-command () "Shows documentation for Perl command at point in other window." @@ -3260,7 +3492,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." imenu-extract-index-name-function (index-item (save-restriction (save-window-excursion - (set-buffer (cperl-info-buffer)) + (set-buffer (cperl-info-buffer nil)) (setq imenu-create-index-function 'imenu-default-create-index-function imenu-prev-index-position-function @@ -3283,7 +3515,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." (defun cperl-lineup (beg end &optional step minshift) "Lineup construction in a region. Beginning of region should be at the start of a construction. -All first occurences of this construction in the lines that are +All first occurrences of this construction in the lines that are partially contained in the region are lined up at the same column. MINSHIFT is the minimal amount of space to insert before the construction. @@ -3324,7 +3556,7 @@ Will not move the position at the start to the left." (setq tcol (current-column) seen t) (if (> tcol col) (setq col tcol))) (or seen - (error "The construction to line up occured only once")) + (error "The construction to line up occurred only once")) (goto-char beg) (setq col (+ col minshift)) (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) @@ -3547,7 +3779,7 @@ in subdirectories too." ) (t (setq xs (string-match "\\.xs$" file)) - (cond ((eq erase 'ignore) nil) + (cond ((eq erase 'ignore) (goto-char (point-max))) (erase (erase-buffer)) (t (goto-char 1) @@ -3558,12 +3790,13 @@ in subdirectories too." (progn (forward-char 1) (search-forward "\f\n" nil 'toend) - (point))) - (goto-char 1))))) + (point)))) + (goto-char (point-max))))) (insert (cperl-find-tags file xs)))) (if inbuffer nil ; Delegate to the caller (save-buffer 0) ; No backup - (initialize-new-tags-table))))) + (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? + (initialize-new-tags-table)))))) (defvar cperl-tags-hier-regexp-list "^\\(\\(package\\)\\>\\|sub\\>[^\n]+::\\|[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::\\|[ \t]*BOOT:\C-?[^\n]+::\\)") @@ -3596,7 +3829,7 @@ in subdirectories too." ;; Name known (setcdr cons1 (cons (cons fileind (vector file info)) (cdr cons1))) - ;; First occurence of the name, start alist + ;; First occurrence of the name, start alist (setq cons1 (cons name (list (cons fileind (vector file info))))) (if pack (setcar (cdr cperl-hierarchy) @@ -3852,3 +4085,612 @@ Currently it is tuned to C and Perl syntax." found-bad found))) (not not-found))) + +;;; Getting help +(defvar cperl-have-help-regexp + ;;(concat "\\(" + (mapconcat + 'identity + '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable + "[$@]\\^[a-zA-Z]" ; Special variable + "[$@][^ \n\t]" ; Special variable + "-[a-zA-Z]" ; File test + "\\\\[a-zA-Z0]" ; Special chars + "^=[a-z][a-zA-Z0-9_]*" ; Pod sections + "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[a-zA-Z_0-9:]+" ; symbol or number + "x=" + "#!" + ) + ;;"\\)\\|\\(" + "\\|" + ) + ;;"\\)" + ;;) + "Matches places in the buffer we can find help for.") + +(defvar cperl-message-on-help-error t) +(defvar cperl-help-from-timer nil) + +(defun cperl-word-at-point-hard () + ;; Does not save-excursion + ;; Get to the something meaningful + (or (eobp) (eolp) (forward-char 1)) + (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (save-excursion (beginning-of-line) (point)) + 'to-beg) + ;; (cond + ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol + ;; (skip-chars-backward " \n\t\r({[]});,") + ;; (or (bobp) (backward-char 1)))) + ;; Try to backtrace + (cond + ((looking-at "[a-zA-Z0-9_:]") ; symbol + (skip-chars-backward "[a-zA-Z0-9_:]") + (cond + ((and (eq (preceding-char) ?^) ; $^I + (eq (char-after (- (point) 2)) ?\$)) + (forward-char -2)) + ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob + (forward-char -1)) + ((and (eq (preceding-char) ?\=) + (eq (current-column) 1)) + (forward-char -1))) ; =head1 + (if (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH> + (forward-char -1))) + ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= + (forward-char -1)) + ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I + (forward-char -1)) + ((looking-at "[-!&*+,-./<=>?\\\\^|~]") + (skip-chars-backward "[-!&*+,-./<=>?\\\\^|~]") + (cond + ((and (eq (preceding-char) ?\$) + (not (eq (char-after (- (point) 2)) ?\$))) ; $- + (forward-char -1)) + ((and (eq (following-char) ?\>) + (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (save-excursion + (forward-sexp -1) + (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH> + (search-backward "<")))) + ((and (eq (following-char) ?\$) + (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (forward-char -1))) + (if (looking-at cperl-have-help-regexp) + (buffer-substring (match-beginning 0) (match-end 0)))) + +(defun cperl-get-help () + "Get one-line docs on the symbol at the point. +The data for these docs is a little bit obsolete and may be in fact longer +than a line. Your contribution to update/shorten it is appreciated." + (interactive) + (save-excursion + (let ((word (cperl-word-at-point-hard))) + (if word + (if (and cperl-help-from-timer ; Bail out if not in mainland + (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. + (or (memq (get-text-property (point) 'face) + '(font-lock-comment-face font-lock-string-face)) + (memq (get-text-property (point) 'syntax-type) + '(pod here-doc format)))) + nil + (cperl-describe-perl-symbol word)) + (if cperl-message-on-help-error + (message "Nothing found for %s..." + (buffer-substring (point) (+ 5 (point))))))))) + +;;; Stolen from perl-descr.el by Johan Vromans: + +(defvar cperl-doc-buffer " *perl-doc*" + "Where the documentation can be found.") + +(defun cperl-describe-perl-symbol (val) + "Display the documentation of symbol at point, a Perl operator." + (let ((enable-recursive-minibuffers t) + args-file regexp) + (cond + ((string-match "^[&*][a-zA-Z_]" val) + (setq val (concat (substring val 0 1) "NAME"))) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) + (setq val (concat "@" (substring val 1 (match-end 1))))) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) + (setq val (concat "%" (substring val 1 (match-end 1))))) + ((and (string= val "x") (string-match "^x=" val)) + (setq val "x=")) + ((string-match "^\\$[\C-a-\C-z]" val) + (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) + ((string-match "^CORE::" val) + (setq val "CORE::")) + ((string-match "^SUPER::" val) + (setq val "SUPER::")) + ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) + (setq val "<NAME>"))) + (setq regexp (concat "^" + "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" + (regexp-quote val) + "\\([ \t([/]\\|$\\)")) + + ;; get the buffer with the documentation text + (cperl-switch-to-doc-buffer) + + ;; lookup in the doc + (goto-char (point-min)) + (let ((case-fold-search nil)) + (list + (if (re-search-forward regexp (point-max) t) + (save-excursion + (beginning-of-line 1) + (let ((lnstart (point))) + (end-of-line) + (message "%s" (buffer-substring lnstart (point))))) + (if cperl-message-on-help-error + (message "No definition for %s" val))))))) + +(defvar cperl-short-docs "Ignore my value" + ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) + "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] +! ... Logical negation. +... != ... Numeric inequality. +... !~ ... Search pattern, substitution, or translation (negated). +$! In numeric context: errno. In a string context: error string. +$\" The separator which joins elements of arrays interpolated in strings. +$# The output format for printed numbers. Initial value is %.20g. +$$ Process number of this script. Changes in the fork()ed child process. +$% The current page number of the currently selected output channel. + + The following variables are always local to the current block: + +$1 Match of the 1st set of parentheses in the last match (auto-local). +$2 Match of the 2nd set of parentheses in the last match (auto-local). +$3 Match of the 3rd set of parentheses in the last match (auto-local). +$4 Match of the 4th set of parentheses in the last match (auto-local). +$5 Match of the 5th set of parentheses in the last match (auto-local). +$6 Match of the 6th set of parentheses in the last match (auto-local). +$7 Match of the 7th set of parentheses in the last match (auto-local). +$8 Match of the 8th set of parentheses in the last match (auto-local). +$9 Match of the 9th set of parentheses in the last match (auto-local). +$& The string matched by the last pattern match (auto-local). +$' The string after what was matched by the last match (auto-local). +$` The string before what was matched by the last match (auto-local). + +$( The real gid of this process. +$) The effective gid of this process. +$* Deprecated: Set to 1 to do multiline matching within a string. +$+ The last bracket matched by the last search pattern. +$, The output field separator for the print operator. +$- The number of lines left on the page. +$. The current input line number of the last filehandle that was read. +$/ The input record separator, newline by default. +$0 Name of the file containing the perl script being executed. May be set. +$: String may be broken after these characters to fill ^-lines in a format. +$; Subscript separator for multi-dim array emulation. Default \"\\034\". +$< The real uid of this process. +$= The page length of the current output channel. Default is 60 lines. +$> The effective uid of this process. +$? The status returned by the last ``, pipe close or `system'. +$@ The perl error message from the last eval or do @var{EXPR} command. +$ARGV The name of the current file used with <> . +$[ Deprecated: The index of the first element/char in an array/string. +$\\ The output record separator for the print operator. +$] The perl version string as displayed with perl -v. +$^ The name of the current top-of-page format. +$^A The current value of the write() accumulator for format() lines. +$^D The value of the perl debug (-D) flags. +$^E Information about the last system error other than that provided by $!. +$^F The highest system file descriptor, ordinarily 2. +$^H The current set of syntax checks enabled by `use strict'. +$^I The value of the in-place edit extension (perl -i option). +$^L What formats output to perform a formfeed. Default is \f. +$^O The operating system name under which this copy of Perl was built. +$^P Internal debugging flag. +$^T The time the script was started. Used by -A/-M/-C file tests. +$^W True if warnings are requested (perl -w flag). +$^X The name under which perl was invoked (argv[0] in C-speech). +$_ The default input and pattern-searching space. +$| Auto-flush after write/print on the current output channel? Default 0. +$~ The name of the current report format. +... % ... Modulo division. +... %= ... Modulo division assignment. +%ENV Contains the current environment. +%INC List of files that have been require-d or do-ne. +%SIG Used to set signal handlers for various signals. +... & ... Bitwise and. +... && ... Logical and. +... &&= ... Logical and assignment. +... &= ... Bitwise and assignment. +... * ... Multiplication. +... ** ... Exponentiation. +*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. +&NAME(arg0, ...) Subroutine call. Arguments go to @_. +... + ... Addition. +EXPR Makes EXPR into scalar context. +++ Auto-increment (magical on strings). ++EXPR EXPR++ +... += ... Addition assignment. +, Comma operator. +... - ... Subtraction. +-- Auto-decrement (NOT magical on strings). --EXPR EXPR-- +... -= ... Subtraction assignment. +-A Access time in days since script started. +-B File is a non-text (binary) file. +-C Inode change time in days since script started. +-M Age in days since script started. +-O File is owned by real uid. +-R File is readable by real uid. +-S File is a socket . +-T File is a text file. +-W File is writable by real uid. +-X File is executable by real uid. +-b File is a block special file. +-c File is a character special file. +-d File is a directory. +-e File exists . +-f File is a plain file. +-g File has setgid bit set. +-k File has sticky bit set. +-l File is a symbolic link. +-o File is owned by effective uid. +-p File is a named pipe (FIFO). +-r File is readable by effective uid. +-s File has non-zero size. +-t Tests if filehandle (STDIN by default) is opened to a tty. +-u File has setuid bit set. +-w File is writable by effective uid. +-x File is executable by effective uid. +-z File has zero size. +. Concatenate strings. +.. Alternation, also range operator. +.= Concatenate assignment strings +... / ... Division. /PATTERN/ioxsmg Pattern match +... /= ... Division assignment. +/PATTERN/ioxsmg Pattern match. +... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well. +<NAME> Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. +<pattern> Glob. (Unless pattern is bareword/dollar-bareword - see <NAME>) +<> Reads line from union of files in @ARGV (= command line) and STDIN. +... << ... Bitwise shift left. << start of HERE-DOCUMENT. +... <= ... Numeric less than or equal to. +... <=> ... Numeric compare. +... = ... Assignment. +... == ... Numeric equality. +... =~ ... Search pattern, substitution, or translation +... > ... Numeric greater than. +... >= ... Numeric greater than or equal to. +... >> ... Bitwise shift right. +... >>= ... Bitwise shift right assignment. +... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. +?PATTERN? One-time pattern match. +@ARGV Command line arguments (not including the command name - see $0). +@INC List of places to look for perl scripts during do/include/use. +@_ Parameter array for subroutines. Also used by split unless in array context. +\\ Creates a reference to whatever follows, like \$var. +\\0 Octal char, e.g. \\033. +\\E Case modification terminator. See \\Q, \\L, and \\U. +\\L Lowercase until \\E . See also \l, lc. +\\U Upcase until \\E . See also \u, uc. +\\Q Quote metacharacters until \\E . See also quotemeta. +\\a Alarm character (octal 007). +\\b Backspace character (octal 010). +\\c Control character, e.g. \\c[ . +\\e Escape character (octal 033). +\\f Formfeed character (octal 014). +\\l Lowercase the next character. See also \\L and \\u, lcfirst, +\\n Newline character (octal 012). +\\r Return character (octal 015). +\\t Tab character (octal 011). +\\u Upcase the next character. See also \\U and \\l, ucfirst, +\\x Hex character, e.g. \\x1b. +^ ... Bitwise exclusive or. +__END__ Ends program source. +__DATA__ Ends program source. +__FILE__ Current (source) filename. +__LINE__ Current line in current source. +ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>. +ARGVOUT Output filehandle with -i flag. +BEGIN { ... } Immediately executed (during compilation) piece of code. +END { ... } Pseudo-subroutine executed after the script finishes. +DATA Input filehandle for what follows after __END__ or __DATA__. +accept(NEWSOCKET,GENERICSOCKET) +alarm(SECONDS) +atan2(X,Y) +bind(SOCKET,NAME) +binmode(FILEHANDLE) +caller[(LEVEL)] +chdir(EXPR) +chmod(LIST) +chop[(LIST|VAR)] +chown(LIST) +chroot(FILENAME) +close(FILEHANDLE) +closedir(DIRHANDLE) +... cmp ... String compare. +connect(SOCKET,NAME) +continue of { block } continue { block }. Is executed after `next' or at end. +cos(EXPR) +crypt(PLAINTEXT,SALT) +dbmclose(%HASH) +dbmopen(%HASH,DBNAME,MODE) +defined(EXPR) +delete($HASH{KEY}) +die(LIST) +do { ... }|SUBR while|until EXPR executes at least once +do(EXPR|SUBR([LIST])) +dump LABEL +each(%HASH) +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof[([FILEHANDLE])] +... eq ... String equality. +eval(EXPR) or eval { BLOCK } +exec(LIST) +exit(EXPR) +exp(EXPR) +fcntl(FILEHANDLE,FUNCTION,SCALAR) +fileno(FILEHANDLE) +flock(FILEHANDLE,OPERATION) +for (EXPR;EXPR;EXPR) { ... } +foreach [VAR] (@ARRAY) { ... } +fork +... ge ... String greater than or equal. +getc[(FILEHANDLE)] +getgrent +getgrgid(GID) +getgrnam(NAME) +gethostbyaddr(ADDR,ADDRTYPE) +gethostbyname(NAME) +gethostent +getlogin +getnetbyaddr(ADDR,ADDRTYPE) +getnetbyname(NAME) +getnetent +getpeername(SOCKET) +getpgrp(PID) +getppid +getpriority(WHICH,WHO) +getprotobyname(NAME) +getprotobynumber(NUMBER) +getprotoent +getpwent +getpwnam(NAME) +getpwuid(UID) +getservbyname(NAME,PROTO) +getservbyport(PORT,PROTO) +getservent +getsockname(SOCKET) +getsockopt(SOCKET,LEVEL,OPTNAME) +gmtime(EXPR) +goto LABEL +grep(EXPR,LIST) +... gt ... String greater than. +hex(EXPR) +if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR +index(STR,SUBSTR[,OFFSET]) +int(EXPR) +ioctl(FILEHANDLE,FUNCTION,SCALAR) +join(EXPR,LIST) +keys(%HASH) +kill(LIST) +last [LABEL] +... le ... String less than or equal. +length(EXPR) +link(OLDFILE,NEWFILE) +listen(SOCKET,QUEUESIZE) +local(LIST) +localtime(EXPR) +log(EXPR) +lstat(EXPR|FILEHANDLE|VAR) +... lt ... String less than. +m/PATTERN/iogsmx +mkdir(FILENAME,MODE) +msgctl(ID,CMD,ARG) +msgget(KEY,FLAGS) +msgrcv(ID,VAR,SIZE,TYPE.FLAGS) +msgsnd(ID,MSG,FLAGS) +my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +... ne ... String inequality. +next [LABEL] +oct(EXPR) +open(FILEHANDLE[,EXPR]) +opendir(DIRHANDLE,EXPR) +ord(EXPR) +pack(TEMPLATE,LIST) +package NAME Introduces package context. +pipe(READHANDLE,WRITEHANDLE) +pop(ARRAY) +print [FILEHANDLE] [(LIST)] +printf [FILEHANDLE] (FORMAT,LIST) +push(ARRAY,LIST) +q/STRING/ Synonym for 'STRING' +qq/STRING/ Synonym for \"STRING\" +qx/STRING/ Synonym for `STRING` +rand[(EXPR)] +read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +readdir(DIRHANDLE) +readlink(EXPR) +recv(SOCKET,SCALAR,LEN,FLAGS) +redo [LABEL] +rename(OLDNAME,NEWNAME) +require [FILENAME | PERL_VERSION] +reset[(EXPR)] +return(LIST) +reverse(LIST) +rewinddir(DIRHANDLE) +rindex(STR,SUBSTR[,OFFSET]) +rmdir(FILENAME) +s/PATTERN/REPLACEMENT/gieoxsm +scalar(EXPR) +seek(FILEHANDLE,POSITION,WHENCE) +seekdir(DIRHANDLE,POS) +select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) +semctl(ID,SEMNUM,CMD,ARG) +semget(KEY,NSEMS,SIZE,FLAGS) +semop(KEY,...) +send(SOCKET,MSG,FLAGS[,TO]) +setgrent +sethostent(STAYOPEN) +setnetent(STAYOPEN) +setpgrp(PID,PGRP) +setpriority(WHICH,WHO,PRIORITY) +setprotoent(STAYOPEN) +setpwent +setservent(STAYOPEN) +setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) +shift[(ARRAY)] +shmctl(ID,CMD,ARG) +shmget(KEY,SIZE,FLAGS) +shmread(ID,VAR,POS,SIZE) +shmwrite(ID,STRING,POS,SIZE) +shutdown(SOCKET,HOW) +sin(EXPR) +sleep[(EXPR)] +socket(SOCKET,DOMAIN,TYPE,PROTOCOL) +socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) +sort [SUBROUTINE] (LIST) +splice(ARRAY,OFFSET[,LENGTH[,LIST]]) +split[(/PATTERN/[,EXPR[,LIMIT]])] +sprintf(FORMAT,LIST) +sqrt(EXPR) +srand(EXPR) +stat(EXPR|FILEHANDLE|VAR) +study[(SCALAR)] +sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} +substr(EXPR,OFFSET[,LEN]) +symlink(OLDFILE,NEWFILE) +syscall(LIST) +sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +system(LIST) +syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +tell[(FILEHANDLE)] +telldir(DIRHANDLE) +time +times +tr/SEARCHLIST/REPLACEMENTLIST/cds +truncate(FILE|EXPR,LENGTH) +umask[(EXPR)] +undef[(EXPR)] +unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR +unlink(LIST) +unpack(TEMPLATE,EXPR) +unshift(ARRAY,LIST) +until (EXPR) { ... } EXPR until EXPR +utime(LIST) +values(%HASH) +vec(EXPR,OFFSET,BITS) +wait +waitpid(PID,FLAGS) +wantarray +warn(LIST) +while (EXPR) { ... } EXPR while EXPR +write[(EXPR|FILEHANDLE)] +... x ... Repeat string or array. +x= ... Repetition assignment. +y/SEARCHLIST/REPLACEMENTLIST/ +... | ... Bitwise or. +... || ... Logical or. +~ ... Unary bitwise complement. +#! OS interpreter indicator. If contains `perl', used for options, and -x. +AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. +CORE:: Prefix to access builtin function if imported sub obscures it. +SUPER:: Prefix to lookup for a method in @ISA classes. +DESTROY Shorthand for `sub DESTROY {...}'. +... EQ ... Obsolete synonym of `eq'. +... GE ... Obsolete synonym of `ge'. +... GT ... Obsolete synonym of `gt'. +... LE ... Obsolete synonym of `le'. +... LT ... Obsolete synonym of `lt'. +... NE ... Obsolete synonym of `ne'. +abs [ EXPR ] absolute value +... and ... Low-precedence synonym for &&. +bless REFERENCE [, PACKAGE] Makes reference into an object of a package. +chomp Docs missing +chr Docs missing +else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +exists $HASH{KEY} True if the key exists. +format Docs missing +formline Docs missing +glob EXPR Synonym of <EXPR>. +lc [ EXPR ] Returns lowercased EXPR. +lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. +map Docs missing +no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. +... not ... Low-precedence synonym for ! - negation. +... or ... Low-precedence synonym for ||. +pos STRING Set/Get end-position of the last match over this string, see \\G. +quotemeta [ EXPR ] Quote metacharacters. +qw Docs missing +readline FH Synonym of <FH>. +readpipe CMD Synonym of `CMD`. +ref [ EXPR ] Type of EXPR when dereferenced. +sysopen Docs missing +tie Docs missing +tied Docs missing +uc [ EXPR ] Returns upcased EXPR. +ucfirst [ EXPR ] Returns EXPR with upcased first letter. +untie Docs missing +use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. +... xor ... Low-precedence synonym for exclusive or. +prototype \&SUB Returns prototype of the function given a reference. +=head1 Top-level heading. +=head2 Second-level heading. +=head3 Third-level heading (is there such?). +=over [ NUMBER ] Start list. +=item [ TITLE ] Start new item in the list. +=back End list. +=cut Switch from POD to Perl. +=pod Switch from Perl to POD. +") + +(defun cperl-switch-to-doc-buffer () + "Go to the perl documentation buffer and insert the documentation." + (interactive) + (let ((buf (get-buffer-create cperl-doc-buffer))) + (if (interactive-p) + (switch-to-buffer-other-window buf) + (set-buffer buf)) + (if (= (buffer-size) 0) + (progn + (insert (documentation-property 'cperl-short-docs + 'variable-documentation)) + (setq buffer-read-only t))))) + +(if (fboundp 'run-with-idle-timer) + (progn + (defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") + + (defvar cperl-help-timer nil + "Non-nil means that the help was already shown now.") + + (defun cperl-lazy-install () + (interactive) + (make-variable-buffer-local 'cperl-help-shown) + (if (cperl-val cperl-lazy-help-time) + (progn + (add-hook 'post-command-hook 'cperl-lazy-hook) + (setq cperl-help-timer + (run-with-idle-timer + (cperl-val cperl-lazy-help-time 1000000 5) + t + 'cperl-get-help-defer))))) + + (defun cperl-lazy-unstall () + (interactive) + (remove-hook 'post-command-hook 'cperl-lazy-hook) + (cancel-timer cperl-help-timer)) + + (defun cperl-lazy-hook () + (setq cperl-help-shown nil)) + + (defun cperl-get-help-defer () + (if (not (eq major-mode 'perl-mode)) nil + (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) + (cperl-get-help) + (setq cperl-help-shown t)))) + (cperl-lazy-install))) @@ -1,6 +1,6 @@ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file is built by embed.pl from global.sym and interp.sym. - Any changes made here will be lost + This file is built by embed.pl from global.sym, interp.sym, + and compat3.sym. Any changes made here will be lost! */ /* (Doing namespace management portably in C is really gross.) */ @@ -15,1406 +15,1619 @@ # define EMBED 1 #endif +/* Hide global symbols? */ + #ifdef EMBED -/* globals we need to hide from the world */ -#define AMG_names Perl_AMG_names -#define No Perl_No -#define Sv Perl_Sv -#define He Perl_He -#define Xpv Perl_Xpv -#define Yes Perl_Yes -#define abs_amg Perl_abs_amg -#define add_amg Perl_add_amg -#define add_ass_amg Perl_add_ass_amg -#define additem Perl_additem +#define AMG_names Perl_AMG_names +#define Gv_AMupdate Perl_Gv_AMupdate +#define No Perl_No +#define Sv Perl_Sv +#define Xpv Perl_Xpv +#define Yes Perl_Yes +#define abs_amg Perl_abs_amg +#define add_amg Perl_add_amg +#define add_ass_amg Perl_add_ass_amg +#define additem Perl_additem +#define amagic_call Perl_amagic_call #define amagic_generation Perl_amagic_generation -#define an Perl_an -#define atan2_amg Perl_atan2_amg -#define band_amg Perl_band_amg -#define bool__amg Perl_bool__amg -#define bor_amg Perl_bor_amg -#define buf Perl_buf -#define bufend Perl_bufend -#define bufptr Perl_bufptr -#define bxor_amg Perl_bxor_amg -#define check Perl_check -#define compiling Perl_compiling -#define compl_amg Perl_compl_amg -#define compcv Perl_compcv -#define comppad Perl_comppad -#define comppad_name Perl_comppad_name +#define an Perl_an +#define append_elem Perl_append_elem +#define append_list Perl_append_list +#define apply Perl_apply +#define assertref Perl_assertref +#define atan2_amg Perl_atan2_amg +#define av_clear Perl_av_clear +#define av_extend Perl_av_extend +#define av_fake Perl_av_fake +#define av_fetch Perl_av_fetch +#define av_fill Perl_av_fill +#define av_len Perl_av_len +#define av_make Perl_av_make +#define av_pop Perl_av_pop +#define av_push Perl_av_push +#define av_shift Perl_av_shift +#define av_store Perl_av_store +#define av_undef Perl_av_undef +#define av_unshift Perl_av_unshift +#define band_amg Perl_band_amg +#define bind_match Perl_bind_match +#define block_end Perl_block_end +#define block_start Perl_block_start +#define bool__amg Perl_bool__amg +#define bor_amg Perl_bor_amg +#define buf Perl_buf +#define bufend Perl_bufend +#define bufptr Perl_bufptr +#define bxor_amg Perl_bxor_amg +#define calllist Perl_calllist +#define cando Perl_cando +#define cast_ulong Perl_cast_ulong +#define check Perl_check +#define check_uni Perl_check_uni +#define checkcomma Perl_checkcomma +#define ck_aelem Perl_ck_aelem +#define ck_anoncode Perl_ck_anoncode +#define ck_bitop Perl_ck_bitop +#define ck_concat Perl_ck_concat +#define ck_delete Perl_ck_delete +#define ck_eof Perl_ck_eof +#define ck_eval Perl_ck_eval +#define ck_exec Perl_ck_exec +#define ck_exists Perl_ck_exists +#define ck_ftst Perl_ck_ftst +#define ck_fun Perl_ck_fun +#define ck_fun_locale Perl_ck_fun_locale +#define ck_glob Perl_ck_glob +#define ck_grep Perl_ck_grep +#define ck_gvconst Perl_ck_gvconst +#define ck_index Perl_ck_index +#define ck_lengthconst Perl_ck_lengthconst +#define ck_lfun Perl_ck_lfun +#define ck_listiob Perl_ck_listiob +#define ck_match Perl_ck_match +#define ck_null Perl_ck_null +#define ck_repeat Perl_ck_repeat +#define ck_require Perl_ck_require +#define ck_retarget Perl_ck_retarget +#define ck_rfun Perl_ck_rfun +#define ck_rvconst Perl_ck_rvconst +#define ck_scmp Perl_ck_scmp +#define ck_select Perl_ck_select +#define ck_shift Perl_ck_shift +#define ck_sort Perl_ck_sort +#define ck_spair Perl_ck_spair +#define ck_split Perl_ck_split +#define ck_subr Perl_ck_subr +#define ck_svconst Perl_ck_svconst +#define ck_trunc Perl_ck_trunc +#define collation_ix Perl_collation_ix +#define collation_name Perl_collation_name +#define collation_standard Perl_collation_standard +#define collxfrm_base Perl_collxfrm_base +#define collxfrm_mult Perl_collxfrm_mult +#define compcv Perl_compcv +#define compiling Perl_compiling +#define compl_amg Perl_compl_amg +#define comppad Perl_comppad +#define comppad_name Perl_comppad_name #define comppad_name_fill Perl_comppad_name_fill -#define comppad_name_floor Perl_comppad_name_floor -#define concat_amg Perl_concat_amg -#define concat_ass_amg Perl_concat_ass_amg -#define cop_seqmax Perl_cop_seqmax -#define cos_amg Perl_cos_amg -#define cryptseen Perl_cryptseen -#define cshlen Perl_cshlen -#define cshname Perl_cshname -#define curcop Perl_curcop -#define curcopdb Perl_curcopdb -#define curinterp Perl_curinterp -#define curpad Perl_curpad -#define cv_const_sv Perl_cv_const_sv -#define dc Perl_dc -#define debug Perl_debug -#define dec_amg Perl_dec_amg -#define di Perl_di -#define div_amg Perl_div_amg -#define div_ass_amg Perl_div_ass_amg -#define do_undump Perl_do_undump -#define ds Perl_ds -#define egid Perl_egid -#define envgv Perl_envgv -#define eq_amg Perl_eq_amg -#define error_count Perl_error_count -#define euid Perl_euid -#define evalseq Perl_evalseq -#define exp_amg Perl_exp_amg -#define expect Perl_expect -#define expectterm Perl_expectterm -#define fallback_amg Perl_fallback_amg -#define filter_add Perl_filter_add -#define filter_del Perl_filter_del -#define filter_read Perl_filter_read -#define fold Perl_fold -#define freq Perl_freq -#define ge_amg Perl_ge_amg -#define gid Perl_gid -#define gt_amg Perl_gt_amg -#define hexdigit Perl_hexdigit -#define hints Perl_hints -#define in_my Perl_in_my -#define inc_amg Perl_inc_amg -#define io_close Perl_io_close -#define know_next Perl_know_next -#define last_lop Perl_last_lop -#define last_lop_op Perl_last_lop_op -#define last_uni Perl_last_uni -#define le_amg Perl_le_amg -#define lex_state Perl_lex_state -#define lex_defer Perl_lex_defer -#define lex_expect Perl_lex_expect -#define lex_brackets Perl_lex_brackets -#define lex_formbrack Perl_lex_formbrack -#define lex_fakebrack Perl_lex_fakebrack -#define lex_casemods Perl_lex_casemods -#define lex_dojoin Perl_lex_dojoin -#define lex_starts Perl_lex_starts -#define lex_stuff Perl_lex_stuff -#define lex_repl Perl_lex_repl -#define lex_op Perl_lex_op -#define lex_inpat Perl_lex_inpat -#define lex_inwhat Perl_lex_inwhat -#define lex_brackstack Perl_lex_brackstack -#define lex_casestack Perl_lex_casestack -#define linestr Perl_linestr -#define log_amg Perl_log_amg -#define lshift_amg Perl_lshift_amg -#define lshift_ass_amg Perl_lshift_ass_amg -#define lt_amg Perl_lt_amg -#define markstack Perl_markstack -#define markstack_max Perl_markstack_max -#define markstack_ptr Perl_markstack_ptr -#define maxo Perl_maxo -#define max_intro_pending Perl_max_intro_pending -#define min_intro_pending Perl_min_intro_pending -#define mod_amg Perl_mod_amg -#define mod_ass_amg Perl_mod_ass_amg -#define mult_amg Perl_mult_amg -#define mult_ass_amg Perl_mult_ass_amg -#define multi_close Perl_multi_close -#define multi_end Perl_multi_end -#define multi_open Perl_multi_open -#define multi_start Perl_multi_start -#define na Perl_na -#define ncmp_amg Perl_ncmp_amg -#define nextval Perl_nextval -#define nexttype Perl_nexttype -#define nexttoke Perl_nexttoke -#define ne_amg Perl_ne_amg -#define neg_amg Perl_neg_amg -#define nexttype Perl_nexttype -#define nextval Perl_nextval -#define no_aelem Perl_no_aelem -#define no_dir_func Perl_no_dir_func -#define no_func Perl_no_func -#define no_helem Perl_no_helem -#define no_mem Perl_no_mem -#define no_modify Perl_no_modify -#define no_security Perl_no_security -#define no_sock_func Perl_no_sock_func -#define no_usym Perl_no_usym -#define nointrp Perl_nointrp -#define nomem Perl_nomem -#define nomemok Perl_nomemok -#define nomethod_amg Perl_nomethod_amg -#define not_amg Perl_not_amg -#define numer_amg Perl_numer_amg -#define oldbufptr Perl_oldbufptr -#define oldoldbufptr Perl_oldoldbufptr -#define op Perl_op -#define op_desc Perl_op_desc -#define op_name Perl_op_name -#define op_seqmax Perl_op_seqmax -#define opargs Perl_opargs -#define origalen Perl_origalen -#define origenviron Perl_origenviron -#define osname Perl_osname -#define padix Perl_padix -#define patleave Perl_patleave -#define pow_amg Perl_pow_amg -#define pow_ass_amg Perl_pow_ass_amg -#define ppaddr Perl_ppaddr -#define profiledata Perl_profiledata -#define provide_ref Perl_provide_ref -#define psig_ptr Perl_psig_ptr -#define psig_name Perl_psig_name -#define qrt_amg Perl_qrt_amg -#define rcsid Perl_rcsid -#define reall_srchlen Perl_reall_srchlen -#define regarglen Perl_regarglen -#define regbol Perl_regbol -#define regcode Perl_regcode -#define regdummy Perl_regdummy -#define regendp Perl_regendp -#define regeol Perl_regeol -#define regfold Perl_regfold -#define reginput Perl_reginput -#define regkind Perl_regkind -#define reglastparen Perl_reglastparen -#define regmyendp Perl_regmyendp -#define regmyp_size Perl_regmyp_size -#define regmystartp Perl_regmystartp -#define regnarrate Perl_regnarrate -#define regnaughty Perl_regnaughty -#define regnpar Perl_regnpar -#define regparse Perl_regparse -#define regprecomp Perl_regprecomp -#define regprev Perl_regprev -#define regsawback Perl_regsawback -#define regsize Perl_regsize -#define regstartp Perl_regstartp -#define regtill Perl_regtill -#define regxend Perl_regxend -#define repeat_amg Perl_repeat_amg -#define repeat_ass_amg Perl_repeat_ass_amg -#define retstack Perl_retstack -#define retstack_ix Perl_retstack_ix -#define retstack_max Perl_retstack_max -#define rsfp Perl_rsfp -#define rsfp_filters Perl_rsfp_filters -#define rshift_amg Perl_rshift_amg -#define rshift_ass_amg Perl_rshift_ass_amg -#define save_pptr Perl_save_pptr -#define savestack Perl_savestack -#define savestack_ix Perl_savestack_ix -#define savestack_max Perl_savestack_max -#define saw_return Perl_saw_return -#define scmp_amg Perl_scmp_amg -#define scopestack Perl_scopestack -#define scopestack_ix Perl_scopestack_ix -#define scopestack_max Perl_scopestack_max -#define scrgv Perl_scrgv -#define seq_amg Perl_seq_amg -#define sge_amg Perl_sge_amg -#define sgt_amg Perl_sgt_amg -#define sig_name Perl_sig_name -#define sig_num Perl_sig_num -#define siggv Perl_siggv -#define sighandler Perl_sighandler -#define simple Perl_simple -#define sin_amg Perl_sin_amg -#define sle_amg Perl_sle_amg -#define slt_amg Perl_slt_amg -#define sne_amg Perl_sne_amg -#define stack_base Perl_stack_base -#define stack_max Perl_stack_max -#define stack_sp Perl_stack_sp -#define statbuf Perl_statbuf -#define string_amg Perl_string_amg -#define sub_generation Perl_sub_generation -#define subline Perl_subline -#define subname Perl_subname -#define subtr_amg Perl_subtr_amg -#define subtr_ass_amg Perl_subtr_ass_amg -#define sv_no Perl_sv_no -#define sv_undef Perl_sv_undef -#define sv_yes Perl_sv_yes -#define tainting Perl_tainting -#define thisexpr Perl_thisexpr -#define timesbuf Perl_timesbuf -#define tokenbuf Perl_tokenbuf -#define uid Perl_uid -#define varies Perl_varies -#define vert Perl_vert -#define vtbl_amagic Perl_vtbl_amagic -#define vtbl_amagicelem Perl_vtbl_amagicelem -#define vtbl_arylen Perl_vtbl_arylen -#define vtbl_bm Perl_vtbl_bm -#define vtbl_dbline Perl_vtbl_dbline -#define vtbl_env Perl_vtbl_env -#define vtbl_envelem Perl_vtbl_envelem -#define vtbl_glob Perl_vtbl_glob -#define vtbl_isa Perl_vtbl_isa -#define vtbl_isaelem Perl_vtbl_isaelem -#define vtbl_mglob Perl_vtbl_mglob -#define vtbl_nkeys Perl_vtbl_nkeys -#define vtbl_pack Perl_vtbl_pack -#define vtbl_packelem Perl_vtbl_packelem -#define vtbl_pos Perl_vtbl_pos -#define vtbl_sig Perl_vtbl_sig -#define vtbl_sigelem Perl_vtbl_sigelem -#define vtbl_substr Perl_vtbl_substr -#define vtbl_sv Perl_vtbl_sv -#define vtbl_taint Perl_vtbl_taint -#define vtbl_uvar Perl_vtbl_uvar -#define vtbl_vec Perl_vtbl_vec -#define warn_nl Perl_warn_nl -#define warn_nosemi Perl_warn_nosemi -#define warn_reserved Perl_warn_reserved -#define watchaddr Perl_watchaddr -#define watchok Perl_watchok -#define yychar Perl_yychar -#define yycheck Perl_yycheck -#define yydebug Perl_yydebug -#define yydefred Perl_yydefred -#define yydgoto Perl_yydgoto -#define yyerrflag Perl_yyerrflag -#define yygindex Perl_yygindex -#define yylen Perl_yylen -#define yylhs Perl_yylhs -#define yylval Perl_yylval -#define yyname Perl_yyname -#define yynerrs Perl_yynerrs -#define yyrindex Perl_yyrindex -#define yyrule Perl_yyrule -#define yysindex Perl_yysindex -#define yytable Perl_yytable -#define yyval Perl_yyval -#define Gv_AMupdate Perl_Gv_AMupdate -#define amagic_call Perl_amagic_call -#define append_elem Perl_append_elem -#define append_list Perl_append_list -#define apply Perl_apply -#define assertref Perl_assertref -#define av_clear Perl_av_clear -#define av_extend Perl_av_extend -#define av_fake Perl_av_fake -#define av_fetch Perl_av_fetch -#define av_fill Perl_av_fill -#define av_len Perl_av_len -#define av_make Perl_av_make -#define av_pop Perl_av_pop -#define av_push Perl_av_push -#define av_shift Perl_av_shift -#define av_store Perl_av_store -#define av_undef Perl_av_undef -#define av_unshift Perl_av_unshift -#define bind_match Perl_bind_match -#define block_end Perl_block_end -#define block_start Perl_block_start -#define calllist Perl_calllist -#define cando Perl_cando -#define cast_ulong Perl_cast_ulong -#define check_uni Perl_check_uni -#define checkcomma Perl_checkcomma -#define ck_aelem Perl_ck_aelem -#define ck_concat Perl_ck_concat -#define ck_delete Perl_ck_delete -#define ck_eof Perl_ck_eof -#define ck_eval Perl_ck_eval -#define ck_exec Perl_ck_exec -#define ck_formline Perl_ck_formline -#define ck_ftst Perl_ck_ftst -#define ck_fun Perl_ck_fun -#define ck_glob Perl_ck_glob -#define ck_grep Perl_ck_grep -#define ck_gvconst Perl_ck_gvconst -#define ck_index Perl_ck_index -#define ck_lengthconst Perl_ck_lengthconst -#define ck_lfun Perl_ck_lfun -#define ck_listiob Perl_ck_listiob -#define ck_match Perl_ck_match -#define ck_null Perl_ck_null -#define ck_repeat Perl_ck_repeat -#define ck_require Perl_ck_require -#define ck_retarget Perl_ck_retarget -#define ck_rfun Perl_ck_rfun -#define ck_rvconst Perl_ck_rvconst -#define ck_select Perl_ck_select -#define ck_shift Perl_ck_shift -#define ck_sort Perl_ck_sort -#define ck_spair Perl_ck_spair -#define ck_split Perl_ck_split -#define ck_subr Perl_ck_subr -#define ck_svconst Perl_ck_svconst -#define ck_trunc Perl_ck_trunc -#define convert Perl_convert -#define cpytill Perl_cpytill -#define croak Perl_croak -#define cv_clone Perl_cv_clone -#define cv_undef Perl_cv_undef -#define cx_dump Perl_cx_dump -#define cxinc Perl_cxinc -#define deb Perl_deb -#define deb_growlevel Perl_deb_growlevel -#define debop Perl_debop -#define debprofdump Perl_debprofdump -#define debstack Perl_debstack -#define debstackptrs Perl_debstackptrs -#define deprecate Perl_deprecate -#define die Perl_die -#define die_where Perl_die_where -#define do_aexec Perl_do_aexec -#define do_chomp Perl_do_chomp -#define do_chop Perl_do_chop -#define do_close Perl_do_close -#define do_eof Perl_do_eof -#define do_exec Perl_do_exec -#define do_execfree Perl_do_execfree -#define do_ipcctl Perl_do_ipcctl -#define do_ipcget Perl_do_ipcget -#define do_join Perl_do_join -#define do_kv Perl_do_kv -#define do_msgrcv Perl_do_msgrcv -#define do_msgsnd Perl_do_msgsnd -#define do_open Perl_do_open -#define do_pipe Perl_do_pipe -#define do_print Perl_do_print -#define do_readline Perl_do_readline -#define do_seek Perl_do_seek -#define do_semop Perl_do_semop -#define do_shmio Perl_do_shmio -#define do_sprintf Perl_do_sprintf -#define do_tell Perl_do_tell -#define do_trans Perl_do_trans -#define do_vecset Perl_do_vecset -#define do_vop Perl_do_vop -#define doeval Perl_doeval -#define dofindlabel Perl_dofindlabel -#define dopoptoeval Perl_dopoptoeval -#define dounwind Perl_dounwind -#define dowantarray Perl_dowantarray -#define dump_all Perl_dump_all -#define dump_eval Perl_dump_eval -#define dump_fds Perl_dump_fds -#define dump_form Perl_dump_form -#define dump_gv Perl_dump_gv -#define dump_mstats Perl_dump_mstats -#define dump_op Perl_dump_op -#define dump_packsubs Perl_dump_packsubs -#define dump_pm Perl_dump_pm -#define dump_sub Perl_dump_sub -#define fbm_compile Perl_fbm_compile -#define fbm_instr Perl_fbm_instr -#define fetch_gv Perl_fetch_gv -#define fetch_io Perl_fetch_io -#define filter_add Perl_filter_add -#define filter_del Perl_filter_del -#define filter_read Perl_filter_read -#define fold_constants Perl_fold_constants -#define force_ident Perl_force_ident -#define force_list Perl_force_list -#define force_next Perl_force_next -#define force_word Perl_force_word -#define free_tmps Perl_free_tmps +#define concat_amg Perl_concat_amg +#define concat_ass_amg Perl_concat_ass_amg +#define convert Perl_convert +#define cop_seqmax Perl_cop_seqmax +#define cos_amg Perl_cos_amg +#define cpytill Perl_cpytill +#define croak Perl_croak +#define cryptseen Perl_cryptseen +#define cshlen Perl_cshlen +#define cshname Perl_cshname +#define curinterp Perl_curinterp +#define curpad Perl_curpad +#define cv_clone Perl_cv_clone +#define cv_const_sv Perl_cv_const_sv +#define cv_undef Perl_cv_undef +#define cx_dump Perl_cx_dump +#define cxinc Perl_cxinc +#define dc Perl_dc +#define deb Perl_deb +#define deb_growlevel Perl_deb_growlevel +#define debop Perl_debop +#define debprofdump Perl_debprofdump +#define debstack Perl_debstack +#define debstackptrs Perl_debstackptrs +#define dec_amg Perl_dec_amg +#define deprecate Perl_deprecate +#define di Perl_di +#define die Perl_die +#define die_where Perl_die_where +#define div_amg Perl_div_amg +#define div_ass_amg Perl_div_ass_amg +#define do_aexec Perl_do_aexec +#define do_chomp Perl_do_chomp +#define do_chop Perl_do_chop +#define do_close Perl_do_close +#define do_eof Perl_do_eof +#define do_exec Perl_do_exec +#define do_execfree Perl_do_execfree +#define do_ipcctl Perl_do_ipcctl +#define do_ipcget Perl_do_ipcget +#define do_join Perl_do_join +#define do_kv Perl_do_kv +#define do_msgrcv Perl_do_msgrcv +#define do_msgsnd Perl_do_msgsnd +#define do_open Perl_do_open +#define do_pipe Perl_do_pipe +#define do_print Perl_do_print +#define do_readline Perl_do_readline +#define do_seek Perl_do_seek +#define do_semop Perl_do_semop +#define do_shmio Perl_do_shmio +#define do_sprintf Perl_do_sprintf +#define do_tell Perl_do_tell +#define do_trans Perl_do_trans +#define do_vecset Perl_do_vecset +#define do_vop Perl_do_vop +#define doeval Perl_doeval +#define dofindlabel Perl_dofindlabel +#define dopoptoeval Perl_dopoptoeval +#define dounwind Perl_dounwind +#define dowantarray Perl_dowantarray +#define ds Perl_ds +#define dump_all Perl_dump_all +#define dump_eval Perl_dump_eval +#define dump_fds Perl_dump_fds +#define dump_form Perl_dump_form +#define dump_gv Perl_dump_gv +#define dump_mstats Perl_dump_mstats +#define dump_op Perl_dump_op +#define dump_packsubs Perl_dump_packsubs +#define dump_pm Perl_dump_pm +#define dump_sub Perl_dump_sub +#define egid Perl_egid +#define eq_amg Perl_eq_amg +#define error_count Perl_error_count +#define euid Perl_euid +#define evalseq Perl_evalseq +#define exp_amg Perl_exp_amg +#define expect Perl_expect +#define expectterm Perl_expectterm +#define fallback_amg Perl_fallback_amg +#define fbm_compile Perl_fbm_compile +#define fbm_instr Perl_fbm_instr +#define fetch_gv Perl_fetch_gv +#define fetch_io Perl_fetch_io +#define filter_add Perl_filter_add +#define filter_del Perl_filter_del +#define filter_read Perl_filter_read +#define fold Perl_fold +#define fold_constants Perl_fold_constants +#define fold_locale Perl_fold_locale +#define force_ident Perl_force_ident +#define force_list Perl_force_list +#define force_next Perl_force_next +#define force_word Perl_force_word +#define free_tmps Perl_free_tmps +#define freq Perl_freq +#define ge_amg Perl_ge_amg #define gen_constant_list Perl_gen_constant_list -#define gp_free Perl_gp_free -#define gp_ref Perl_gp_ref -#define gv_AVadd Perl_gv_AVadd -#define gv_HVadd Perl_gv_HVadd -#define gv_IOadd Perl_gv_IOadd -#define gv_check Perl_gv_check -#define gv_efullname Perl_gv_efullname -#define gv_efullname3 Perl_gv_efullname3 -#define gv_fetchfile Perl_gv_fetchfile -#define gv_fetchmeth Perl_gv_fetchmeth -#define gv_fetchmethod Perl_gv_fetchmethod -#define gv_fetchpv Perl_gv_fetchpv -#define gv_fullname Perl_gv_fullname -#define gv_fullname3 Perl_gv_fullname3 -#define gv_init Perl_gv_init -#define gv_stashpv Perl_gv_stashpv -#define gv_stashpvn Perl_gv_stashpvn -#define gv_stashsv Perl_gv_stashsv -#define he_delayfree Perl_he_delayfree -#define he_free Perl_he_free -#define he_root Perl_he_root -#define hoistmust Perl_hoistmust -#define hv_clear Perl_hv_clear -#define hv_delete Perl_hv_delete -#define hv_delete_ent Perl_hv_delete_ent -#define hv_exists Perl_hv_exists -#define hv_exists_ent Perl_hv_exists_ent -#define hv_fetch Perl_hv_fetch -#define hv_fetch_ent Perl_hv_fetch_ent -#define hv_iterinit Perl_hv_iterinit -#define hv_iterkey Perl_hv_iterkey -#define hv_iterkeysv Perl_hv_iterkeysv -#define hv_iternext Perl_hv_iternext -#define hv_iternextsv Perl_hv_iternextsv -#define hv_iterval Perl_hv_iterval -#define hv_ksplit Perl_hv_ksplit -#define hv_magic Perl_hv_magic -#define hv_stashpv Perl_hv_stashpv -#define hv_store Perl_hv_store -#define hv_store_ent Perl_hv_store_ent -#define hv_undef Perl_hv_undef -#define ibcmp Perl_ibcmp -#define ingroup Perl_ingroup -#define instr Perl_instr -#define intuit_more Perl_intuit_more -#define invert Perl_invert -#define jmaybe Perl_jmaybe -#define keyword Perl_keyword -#define leave_scope Perl_leave_scope -#define lex_end Perl_lex_end -#define lex_start Perl_lex_start -#define linklist Perl_linklist -#define list Perl_list -#define listkids Perl_listkids -#define localize Perl_localize +#define gid Perl_gid +#define gp_free Perl_gp_free +#define gp_ref Perl_gp_ref +#define gt_amg Perl_gt_amg +#define gv_AVadd Perl_gv_AVadd +#define gv_HVadd Perl_gv_HVadd +#define gv_IOadd Perl_gv_IOadd +#define gv_autoload Perl_gv_autoload +#define gv_check Perl_gv_check +#define gv_efullname Perl_gv_efullname +#define gv_efullname3 Perl_gv_efullname3 +#define gv_fetchfile Perl_gv_fetchfile +#define gv_fetchmeth Perl_gv_fetchmeth +#define gv_fetchmethod Perl_gv_fetchmethod +#define gv_fetchpv Perl_gv_fetchpv +#define gv_fullname Perl_gv_fullname +#define gv_fullname3 Perl_gv_fullname3 +#define gv_init Perl_gv_init +#define gv_stashpv Perl_gv_stashpv +#define gv_stashpvn Perl_gv_stashpvn +#define gv_stashsv Perl_gv_stashsv +#define he_delayfree Perl_he_delayfree +#define he_free Perl_he_free +#define he_root Perl_he_root +#define hexdigit Perl_hexdigit +#define hints Perl_hints +#define hoistmust Perl_hoistmust +#define hv_clear Perl_hv_clear +#define hv_delete Perl_hv_delete +#define hv_delete_ent Perl_hv_delete_ent +#define hv_exists Perl_hv_exists +#define hv_exists_ent Perl_hv_exists_ent +#define hv_fetch Perl_hv_fetch +#define hv_fetch_ent Perl_hv_fetch_ent +#define hv_iterinit Perl_hv_iterinit +#define hv_iterkey Perl_hv_iterkey +#define hv_iterkeysv Perl_hv_iterkeysv +#define hv_iternext Perl_hv_iternext +#define hv_iternextsv Perl_hv_iternextsv +#define hv_iterval Perl_hv_iterval +#define hv_ksplit Perl_hv_ksplit +#define hv_magic Perl_hv_magic +#define hv_stashpv Perl_hv_stashpv +#define hv_store Perl_hv_store +#define hv_store_ent Perl_hv_store_ent +#define hv_undef Perl_hv_undef +#define ibcmp Perl_ibcmp +#define ibcmp_locale Perl_ibcmp_locale +#define in_my Perl_in_my +#define inc_amg Perl_inc_amg +#define ingroup Perl_ingroup +#define instr Perl_instr +#define intro_my Perl_intro_my +#define intuit_more Perl_intuit_more +#define invert Perl_invert +#define io_close Perl_io_close +#define jmaybe Perl_jmaybe +#define keyword Perl_keyword +#define know_next Perl_know_next +#define last_lop Perl_last_lop +#define last_lop_op Perl_last_lop_op +#define last_uni Perl_last_uni +#define le_amg Perl_le_amg +#define leave_scope Perl_leave_scope +#define lex_brackets Perl_lex_brackets +#define lex_brackstack Perl_lex_brackstack +#define lex_casemods Perl_lex_casemods +#define lex_casestack Perl_lex_casestack +#define lex_defer Perl_lex_defer +#define lex_dojoin Perl_lex_dojoin +#define lex_end Perl_lex_end +#define lex_expect Perl_lex_expect +#define lex_fakebrack Perl_lex_fakebrack +#define lex_formbrack Perl_lex_formbrack +#define lex_inpat Perl_lex_inpat +#define lex_inwhat Perl_lex_inwhat +#define lex_op Perl_lex_op +#define lex_repl Perl_lex_repl +#define lex_start Perl_lex_start +#define lex_starts Perl_lex_starts +#define lex_state Perl_lex_state +#define lex_stuff Perl_lex_stuff +#define linestr Perl_linestr +#define linklist Perl_linklist +#define list Perl_list +#define listkids Perl_listkids +#define localize Perl_localize +#define log_amg Perl_log_amg #define looks_like_number Perl_looks_like_number -#define magic_clearenv Perl_magic_clearenv -#define magic_clearpack Perl_magic_clearpack -#define magic_clearsig Perl_magic_clearsig +#define lshift_amg Perl_lshift_amg +#define lshift_ass_amg Perl_lshift_ass_amg +#define lt_amg Perl_lt_amg +#define magic_clearenv Perl_magic_clearenv +#define magic_clearpack Perl_magic_clearpack +#define magic_clearsig Perl_magic_clearsig #define magic_existspack Perl_magic_existspack -#define magic_get Perl_magic_get -#define magic_getarylen Perl_magic_getarylen -#define magic_getglob Perl_magic_getglob -#define magic_getpack Perl_magic_getpack -#define magic_getpos Perl_magic_getpos -#define magic_getsig Perl_magic_getsig -#define magic_gettaint Perl_magic_gettaint -#define magic_getuvar Perl_magic_getuvar -#define magic_len Perl_magic_len -#define magic_nextpack Perl_magic_nextpack -#define magic_set Perl_magic_set -#define magic_setamagic Perl_magic_setamagic -#define magic_setarylen Perl_magic_setarylen -#define magic_setbm Perl_magic_setbm -#define magic_setdbline Perl_magic_setdbline -#define magic_setenv Perl_magic_setenv -#define magic_setglob Perl_magic_setglob -#define magic_setisa Perl_magic_setisa -#define magic_setmglob Perl_magic_setmglob -#define magic_setnkeys Perl_magic_setnkeys -#define magic_setpack Perl_magic_setpack -#define magic_setpos Perl_magic_setpos -#define magic_setsig Perl_magic_setsig -#define magic_setsubstr Perl_magic_setsubstr -#define magic_settaint Perl_magic_settaint -#define magic_setuvar Perl_magic_setuvar -#define magic_setvec Perl_magic_setvec -#define magic_wipepack Perl_magic_wipepack -#define magicname Perl_magicname -#define markstack_grow Perl_markstack_grow -#define mess Perl_mess -#define mg_clear Perl_mg_clear -#define mg_copy Perl_mg_copy -#define mg_find Perl_mg_find -#define mg_free Perl_mg_free -#define mg_get Perl_mg_get -#define mg_len Perl_mg_len -#define mg_magical Perl_mg_magical -#define mg_set Perl_mg_set -#define mod Perl_mod -#define modkids Perl_modkids -#define moreswitches Perl_moreswitches -#define mstats Perl_mstats -#define my Perl_my -#define my_bcopy Perl_my_bcopy -#define my_bzero Perl_my_bzero -#define my_chsize Perl_my_chsize -#define my_exit Perl_my_exit -#define my_htonl Perl_my_htonl -#define my_lstat Perl_my_lstat -#define my_memcmp Perl_my_memcmp -#define my_ntohl Perl_my_ntohl -#define my_pclose Perl_my_pclose -#define my_popen Perl_my_popen -#define my_setenv Perl_my_setenv -#define my_stat Perl_my_stat -#define my_swap Perl_my_swap -#define my_unexec Perl_my_unexec -#define newANONHASH Perl_newANONHASH -#define newANONLIST Perl_newANONLIST -#define newANONSUB Perl_newANONSUB -#define newASSIGNOP Perl_newASSIGNOP -#define newAV Perl_newAV -#define newAVREF Perl_newAVREF -#define newBINOP Perl_newBINOP -#define newCONDOP Perl_newCONDOP -#define newCVREF Perl_newCVREF -#define newFORM Perl_newFORM -#define newFOROP Perl_newFOROP -#define newGVOP Perl_newGVOP -#define newGVREF Perl_newGVREF -#define newGVgen Perl_newGVgen -#define newHV Perl_newHV -#define newHVREF Perl_newHVREF -#define newIO Perl_newIO -#define newLISTOP Perl_newLISTOP -#define newLOGOP Perl_newLOGOP -#define newLOOPEX Perl_newLOOPEX -#define newLOOPOP Perl_newLOOPOP -#define newNULLLIST Perl_newNULLLIST -#define newOP Perl_newOP -#define newPMOP Perl_newPMOP -#define newPROG Perl_newPROG -#define newPVOP Perl_newPVOP -#define newRANGE Perl_newRANGE -#define newRV Perl_newRV -#define newSLICEOP Perl_newSLICEOP -#define newSTATEOP Perl_newSTATEOP -#define newSUB Perl_newSUB -#define newSV Perl_newSV -#define newSVOP Perl_newSVOP -#define newSVREF Perl_newSVREF -#define newSViv Perl_newSViv -#define newSVnv Perl_newSVnv -#define newSVpv Perl_newSVpv -#define newSVrv Perl_newSVrv -#define newSVsv Perl_newSVsv -#define newUNOP Perl_newUNOP -#define newWHILEOP Perl_newWHILEOP -#define newXS Perl_newXS -#define newXSUB Perl_newXSUB -#define nextargv Perl_nextargv -#define ninstr Perl_ninstr -#define no_fh_allowed Perl_no_fh_allowed -#define no_op Perl_no_op -#define oopsAV Perl_oopsAV -#define oopsCV Perl_oopsCV -#define oopsHV Perl_oopsHV -#define op_free Perl_op_free -#define package Perl_package -#define pad_alloc Perl_pad_alloc -#define pad_allocmy Perl_pad_allocmy -#define pad_findmy Perl_pad_findmy -#define pad_free Perl_pad_free -#define pad_leavemy Perl_pad_leavemy -#define pad_reset Perl_pad_reset -#define pad_sv Perl_pad_sv -#define pad_swipe Perl_pad_swipe -#define peep Perl_peep -#define pidgone Perl_pidgone -#define pmflag Perl_pmflag -#define pmruntime Perl_pmruntime -#define pmtrans Perl_pmtrans -#define pop_return Perl_pop_return -#define pop_scope Perl_pop_scope -#define pp_aassign Perl_pp_aassign -#define pp_abs Perl_pp_abs -#define pp_accept Perl_pp_accept -#define pp_add Perl_pp_add -#define pp_aelem Perl_pp_aelem -#define pp_aelemfast Perl_pp_aelemfast -#define pp_alarm Perl_pp_alarm -#define pp_and Perl_pp_and -#define pp_andassign Perl_pp_andassign -#define pp_anoncode Perl_pp_anoncode -#define pp_anonhash Perl_pp_anonhash -#define pp_anonlist Perl_pp_anonlist -#define pp_aslice Perl_pp_aslice -#define pp_atan2 Perl_pp_atan2 -#define pp_av2arylen Perl_pp_av2arylen -#define pp_backtick Perl_pp_backtick -#define pp_bind Perl_pp_bind -#define pp_binmode Perl_pp_binmode -#define pp_bit_and Perl_pp_bit_and -#define pp_bit_or Perl_pp_bit_or -#define pp_bit_xor Perl_pp_bit_xor -#define pp_bless Perl_pp_bless -#define pp_caller Perl_pp_caller -#define pp_chdir Perl_pp_chdir -#define pp_chmod Perl_pp_chmod -#define pp_chomp Perl_pp_chomp -#define pp_chop Perl_pp_chop -#define pp_chown Perl_pp_chown -#define pp_chr Perl_pp_chr -#define pp_chroot Perl_pp_chroot -#define pp_close Perl_pp_close -#define pp_closedir Perl_pp_closedir -#define pp_complement Perl_pp_complement -#define pp_concat Perl_pp_concat -#define pp_cond_expr Perl_pp_cond_expr -#define pp_connect Perl_pp_connect -#define pp_const Perl_pp_const -#define pp_cos Perl_pp_cos -#define pp_crypt Perl_pp_crypt -#define pp_cswitch Perl_pp_cswitch -#define pp_dbmclose Perl_pp_dbmclose -#define pp_dbmopen Perl_pp_dbmopen -#define pp_dbstate Perl_pp_dbstate -#define pp_defined Perl_pp_defined -#define pp_delete Perl_pp_delete -#define pp_die Perl_pp_die -#define pp_divide Perl_pp_divide -#define pp_dofile Perl_pp_dofile -#define pp_dump Perl_pp_dump -#define pp_each Perl_pp_each -#define pp_egrent Perl_pp_egrent -#define pp_ehostent Perl_pp_ehostent -#define pp_enetent Perl_pp_enetent -#define pp_enter Perl_pp_enter -#define pp_entereval Perl_pp_entereval -#define pp_enteriter Perl_pp_enteriter -#define pp_enterloop Perl_pp_enterloop -#define pp_entersub Perl_pp_entersub -#define pp_entersubr Perl_pp_entersubr -#define pp_entertry Perl_pp_entertry -#define pp_enterwrite Perl_pp_enterwrite -#define pp_eof Perl_pp_eof -#define pp_eprotoent Perl_pp_eprotoent -#define pp_epwent Perl_pp_epwent -#define pp_eq Perl_pp_eq -#define pp_eservent Perl_pp_eservent -#define pp_evalonce Perl_pp_evalonce -#define pp_exec Perl_pp_exec -#define pp_exists Perl_pp_exists -#define pp_exit Perl_pp_exit -#define pp_exp Perl_pp_exp -#define pp_fcntl Perl_pp_fcntl -#define pp_fileno Perl_pp_fileno -#define pp_flip Perl_pp_flip -#define pp_flock Perl_pp_flock -#define pp_flop Perl_pp_flop -#define pp_fork Perl_pp_fork -#define pp_formline Perl_pp_formline -#define pp_ftatime Perl_pp_ftatime -#define pp_ftbinary Perl_pp_ftbinary -#define pp_ftblk Perl_pp_ftblk -#define pp_ftchr Perl_pp_ftchr -#define pp_ftctime Perl_pp_ftctime -#define pp_ftdir Perl_pp_ftdir -#define pp_fteexec Perl_pp_fteexec -#define pp_fteowned Perl_pp_fteowned -#define pp_fteread Perl_pp_fteread -#define pp_ftewrite Perl_pp_ftewrite -#define pp_ftfile Perl_pp_ftfile -#define pp_ftis Perl_pp_ftis -#define pp_ftlink Perl_pp_ftlink -#define pp_ftmtime Perl_pp_ftmtime -#define pp_ftpipe Perl_pp_ftpipe -#define pp_ftrexec Perl_pp_ftrexec -#define pp_ftrowned Perl_pp_ftrowned -#define pp_ftrread Perl_pp_ftrread -#define pp_ftrwrite Perl_pp_ftrwrite -#define pp_ftsgid Perl_pp_ftsgid -#define pp_ftsize Perl_pp_ftsize -#define pp_ftsock Perl_pp_ftsock -#define pp_ftsuid Perl_pp_ftsuid -#define pp_ftsvtx Perl_pp_ftsvtx -#define pp_fttext Perl_pp_fttext -#define pp_fttty Perl_pp_fttty -#define pp_ftzero Perl_pp_ftzero -#define pp_ge Perl_pp_ge -#define pp_gelem Perl_pp_gelem -#define pp_getc Perl_pp_getc -#define pp_getlogin Perl_pp_getlogin -#define pp_getpeername Perl_pp_getpeername -#define pp_getpgrp Perl_pp_getpgrp -#define pp_getppid Perl_pp_getppid -#define pp_getpriority Perl_pp_getpriority -#define pp_getsockname Perl_pp_getsockname -#define pp_ggrent Perl_pp_ggrent -#define pp_ggrgid Perl_pp_ggrgid -#define pp_ggrnam Perl_pp_ggrnam -#define pp_ghbyaddr Perl_pp_ghbyaddr -#define pp_ghbyname Perl_pp_ghbyname -#define pp_ghostent Perl_pp_ghostent -#define pp_glob Perl_pp_glob -#define pp_gmtime Perl_pp_gmtime -#define pp_gnbyaddr Perl_pp_gnbyaddr -#define pp_gnbyname Perl_pp_gnbyname -#define pp_gnetent Perl_pp_gnetent -#define pp_goto Perl_pp_goto -#define pp_gpbyname Perl_pp_gpbyname -#define pp_gpbynumber Perl_pp_gpbynumber -#define pp_gprotoent Perl_pp_gprotoent -#define pp_gpwent Perl_pp_gpwent -#define pp_gpwnam Perl_pp_gpwnam -#define pp_gpwuid Perl_pp_gpwuid -#define pp_grepstart Perl_pp_grepstart -#define pp_grepwhile Perl_pp_grepwhile -#define pp_gsbyname Perl_pp_gsbyname -#define pp_gsbyport Perl_pp_gsbyport -#define pp_gservent Perl_pp_gservent -#define pp_gsockopt Perl_pp_gsockopt -#define pp_gt Perl_pp_gt -#define pp_gv Perl_pp_gv -#define pp_gvsv Perl_pp_gvsv -#define pp_helem Perl_pp_helem -#define pp_hex Perl_pp_hex -#define pp_hslice Perl_pp_hslice -#define pp_i_add Perl_pp_i_add -#define pp_i_divide Perl_pp_i_divide -#define pp_i_eq Perl_pp_i_eq -#define pp_i_ge Perl_pp_i_ge -#define pp_i_gt Perl_pp_i_gt -#define pp_i_le Perl_pp_i_le -#define pp_i_lt Perl_pp_i_lt -#define pp_i_modulo Perl_pp_i_modulo -#define pp_i_multiply Perl_pp_i_multiply -#define pp_i_ncmp Perl_pp_i_ncmp -#define pp_i_ne Perl_pp_i_ne -#define pp_i_negate Perl_pp_i_negate -#define pp_i_subtract Perl_pp_i_subtract -#define pp_index Perl_pp_index -#define pp_indread Perl_pp_indread -#define pp_int Perl_pp_int -#define pp_interp Perl_pp_interp -#define pp_ioctl Perl_pp_ioctl -#define pp_iter Perl_pp_iter -#define pp_join Perl_pp_join -#define pp_keys Perl_pp_keys -#define pp_kill Perl_pp_kill -#define pp_last Perl_pp_last -#define pp_lc Perl_pp_lc -#define pp_lcfirst Perl_pp_lcfirst -#define pp_le Perl_pp_le -#define pp_leave Perl_pp_leave -#define pp_leaveeval Perl_pp_leaveeval -#define pp_leaveloop Perl_pp_leaveloop -#define pp_leavesub Perl_pp_leavesub -#define pp_leavetry Perl_pp_leavetry -#define pp_leavewrite Perl_pp_leavewrite -#define pp_left_shift Perl_pp_left_shift -#define pp_length Perl_pp_length -#define pp_lineseq Perl_pp_lineseq -#define pp_link Perl_pp_link -#define pp_list Perl_pp_list -#define pp_listen Perl_pp_listen -#define pp_localtime Perl_pp_localtime -#define pp_log Perl_pp_log -#define pp_lslice Perl_pp_lslice -#define pp_lstat Perl_pp_lstat -#define pp_lt Perl_pp_lt -#define pp_map Perl_pp_map -#define pp_mapstart Perl_pp_mapstart -#define pp_mapwhile Perl_pp_mapwhile -#define pp_match Perl_pp_match -#define pp_method Perl_pp_method -#define pp_mkdir Perl_pp_mkdir -#define pp_modulo Perl_pp_modulo -#define pp_msgctl Perl_pp_msgctl -#define pp_msgget Perl_pp_msgget -#define pp_msgrcv Perl_pp_msgrcv -#define pp_msgsnd Perl_pp_msgsnd -#define pp_multiply Perl_pp_multiply -#define pp_ncmp Perl_pp_ncmp -#define pp_ne Perl_pp_ne -#define pp_negate Perl_pp_negate -#define pp_next Perl_pp_next -#define pp_nextstate Perl_pp_nextstate -#define pp_not Perl_pp_not -#define pp_nswitch Perl_pp_nswitch -#define pp_null Perl_pp_null -#define pp_oct Perl_pp_oct -#define pp_open Perl_pp_open -#define pp_open_dir Perl_pp_open_dir -#define pp_or Perl_pp_or -#define pp_orassign Perl_pp_orassign -#define pp_ord Perl_pp_ord -#define pp_pack Perl_pp_pack -#define pp_padany Perl_pp_padany -#define pp_padav Perl_pp_padav -#define pp_padhv Perl_pp_padhv -#define pp_padsv Perl_pp_padsv -#define pp_pipe_op Perl_pp_pipe_op -#define pp_pop Perl_pp_pop -#define pp_pos Perl_pp_pos -#define pp_postdec Perl_pp_postdec -#define pp_postinc Perl_pp_postinc -#define pp_pow Perl_pp_pow -#define pp_predec Perl_pp_predec -#define pp_preinc Perl_pp_preinc -#define pp_print Perl_pp_print -#define pp_prototype Perl_pp_prototype -#define pp_prtf Perl_pp_prtf -#define pp_push Perl_pp_push -#define pp_pushmark Perl_pp_pushmark -#define pp_pushre Perl_pp_pushre -#define pp_quotemeta Perl_pp_quotemeta -#define pp_rand Perl_pp_rand -#define pp_range Perl_pp_range -#define pp_rcatline Perl_pp_rcatline -#define pp_read Perl_pp_read -#define pp_readdir Perl_pp_readdir -#define pp_readline Perl_pp_readline -#define pp_readlink Perl_pp_readlink -#define pp_recv Perl_pp_recv -#define pp_redo Perl_pp_redo -#define pp_ref Perl_pp_ref -#define pp_refgen Perl_pp_refgen -#define pp_regcmaybe Perl_pp_regcmaybe -#define pp_regcomp Perl_pp_regcomp -#define pp_rename Perl_pp_rename -#define pp_repeat Perl_pp_repeat -#define pp_require Perl_pp_require -#define pp_reset Perl_pp_reset -#define pp_return Perl_pp_return -#define pp_reverse Perl_pp_reverse -#define pp_rewinddir Perl_pp_rewinddir -#define pp_right_shift Perl_pp_right_shift -#define pp_rindex Perl_pp_rindex -#define pp_rmdir Perl_pp_rmdir -#define pp_rv2av Perl_pp_rv2av -#define pp_rv2cv Perl_pp_rv2cv -#define pp_rv2gv Perl_pp_rv2gv -#define pp_rv2hv Perl_pp_rv2hv -#define pp_rv2sv Perl_pp_rv2sv -#define pp_sassign Perl_pp_sassign -#define pp_scalar Perl_pp_scalar -#define pp_schomp Perl_pp_schomp -#define pp_schop Perl_pp_schop -#define pp_scmp Perl_pp_scmp -#define pp_scope Perl_pp_scope -#define pp_seek Perl_pp_seek -#define pp_seekdir Perl_pp_seekdir -#define pp_select Perl_pp_select -#define pp_semctl Perl_pp_semctl -#define pp_semget Perl_pp_semget -#define pp_semop Perl_pp_semop -#define pp_send Perl_pp_send -#define pp_seq Perl_pp_seq -#define pp_setpgrp Perl_pp_setpgrp -#define pp_setpriority Perl_pp_setpriority -#define pp_sge Perl_pp_sge -#define pp_sgrent Perl_pp_sgrent -#define pp_sgt Perl_pp_sgt -#define pp_shift Perl_pp_shift -#define pp_shmctl Perl_pp_shmctl -#define pp_shmget Perl_pp_shmget -#define pp_shmread Perl_pp_shmread -#define pp_shmwrite Perl_pp_shmwrite -#define pp_shostent Perl_pp_shostent -#define pp_shutdown Perl_pp_shutdown -#define pp_sin Perl_pp_sin -#define pp_sle Perl_pp_sle -#define pp_sleep Perl_pp_sleep -#define pp_slt Perl_pp_slt -#define pp_sne Perl_pp_sne -#define pp_snetent Perl_pp_snetent -#define pp_socket Perl_pp_socket -#define pp_sockpair Perl_pp_sockpair -#define pp_sort Perl_pp_sort -#define pp_splice Perl_pp_splice -#define pp_split Perl_pp_split -#define pp_sprintf Perl_pp_sprintf -#define pp_sprotoent Perl_pp_sprotoent -#define pp_spwent Perl_pp_spwent -#define pp_sqrt Perl_pp_sqrt -#define pp_srand Perl_pp_srand -#define pp_srefgen Perl_pp_srefgen -#define pp_sselect Perl_pp_sselect -#define pp_sservent Perl_pp_sservent -#define pp_ssockopt Perl_pp_ssockopt -#define pp_stat Perl_pp_stat -#define pp_stringify Perl_pp_stringify -#define pp_stub Perl_pp_stub -#define pp_study Perl_pp_study -#define pp_subst Perl_pp_subst -#define pp_substcont Perl_pp_substcont -#define pp_substr Perl_pp_substr -#define pp_subtract Perl_pp_subtract -#define pp_symlink Perl_pp_symlink -#define pp_syscall Perl_pp_syscall -#define pp_sysopen Perl_pp_sysopen -#define pp_sysread Perl_pp_sysread -#define pp_system Perl_pp_system -#define pp_syswrite Perl_pp_syswrite -#define pp_tell Perl_pp_tell -#define pp_telldir Perl_pp_telldir -#define pp_tie Perl_pp_tie -#define pp_tied Perl_pp_tied -#define pp_time Perl_pp_time -#define pp_tms Perl_pp_tms -#define pp_trans Perl_pp_trans -#define pp_truncate Perl_pp_truncate -#define pp_uc Perl_pp_uc -#define pp_ucfirst Perl_pp_ucfirst -#define pp_umask Perl_pp_umask -#define pp_undef Perl_pp_undef -#define pp_unlink Perl_pp_unlink -#define pp_unpack Perl_pp_unpack -#define pp_unshift Perl_pp_unshift -#define pp_unstack Perl_pp_unstack -#define pp_untie Perl_pp_untie -#define pp_utime Perl_pp_utime -#define pp_values Perl_pp_values -#define pp_vec Perl_pp_vec -#define pp_wait Perl_pp_wait -#define pp_waitpid Perl_pp_waitpid -#define pp_wantarray Perl_pp_wantarray -#define pp_warn Perl_pp_warn -#define pp_xor Perl_pp_xor -#define pregcomp Perl_pregcomp -#define pregexec Perl_pregexec -#define pregfree Perl_pregfree -#define prepend_elem Perl_prepend_elem -#define push_return Perl_push_return -#define push_scope Perl_push_scope -#define q Perl_q -#define ref Perl_ref -#define refkids Perl_refkids -#define regdump Perl_regdump -#define regnext Perl_regnext -#define regprop Perl_regprop -#define repeatcpy Perl_repeatcpy -#define rninstr Perl_rninstr -#define runops Perl_runops -#define same_dirent Perl_same_dirent -#define save_I32 Perl_save_I32 -#define save_aptr Perl_save_aptr -#define save_ary Perl_save_ary -#define save_clearsv Perl_save_clearsv -#define save_delete Perl_save_delete -#define save_destructor Perl_save_destructor -#define save_freeop Perl_save_freeop -#define save_freepv Perl_save_freepv -#define save_freesv Perl_save_freesv -#define save_hash Perl_save_hash -#define save_hptr Perl_save_hptr -#define save_int Perl_save_int -#define save_item Perl_save_item -#define save_list Perl_save_list -#define save_long Perl_save_long -#define save_nogv Perl_save_nogv -#define save_pptr Perl_save_pptr -#define save_scalar Perl_save_scalar -#define save_sptr Perl_save_sptr -#define save_svref Perl_save_svref -#define savepv Perl_savepv -#define savepvn Perl_savepvn -#define savestack_grow Perl_savestack_grow -#define sawparens Perl_sawparens -#define scalar Perl_scalar -#define scalarkids Perl_scalarkids -#define scalarseq Perl_scalarseq -#define scalarvoid Perl_scalarvoid -#define scan_const Perl_scan_const -#define scan_formline Perl_scan_formline -#define scan_heredoc Perl_scan_heredoc -#define scan_hex Perl_scan_hex -#define scan_ident Perl_scan_ident +#define magic_freeitervar Perl_magic_freeitervar +#define magic_get Perl_magic_get +#define magic_getarylen Perl_magic_getarylen +#define magic_getglob Perl_magic_getglob +#define magic_getitervar Perl_magic_getitervar +#define magic_getpack Perl_magic_getpack +#define magic_getpos Perl_magic_getpos +#define magic_getsig Perl_magic_getsig +#define magic_gettaint Perl_magic_gettaint +#define magic_getuvar Perl_magic_getuvar +#define magic_len Perl_magic_len +#define magic_nextpack Perl_magic_nextpack +#define magic_set Perl_magic_set +#define magic_setamagic Perl_magic_setamagic +#define magic_setarylen Perl_magic_setarylen +#define magic_setbm Perl_magic_setbm +#define magic_setcollxfrm Perl_magic_setcollxfrm +#define magic_setdbline Perl_magic_setdbline +#define magic_setenv Perl_magic_setenv +#define magic_setfm Perl_magic_setfm +#define magic_setglob Perl_magic_setglob +#define magic_setisa Perl_magic_setisa +#define magic_setitervar Perl_magic_setitervar +#define magic_setmglob Perl_magic_setmglob +#define magic_setnkeys Perl_magic_setnkeys +#define magic_setpack Perl_magic_setpack +#define magic_setpos Perl_magic_setpos +#define magic_setsig Perl_magic_setsig +#define magic_setsubstr Perl_magic_setsubstr +#define magic_settaint Perl_magic_settaint +#define magic_setuvar Perl_magic_setuvar +#define magic_setvec Perl_magic_setvec +#define magic_wipepack Perl_magic_wipepack +#define magicname Perl_magicname +#define markstack Perl_markstack +#define markstack_grow Perl_markstack_grow +#define markstack_max Perl_markstack_max +#define markstack_ptr Perl_markstack_ptr +#define max_intro_pending Perl_max_intro_pending +#define maxo Perl_maxo +#define mem_collxfrm Perl_mem_collxfrm +#define mess Perl_mess +#define mg_clear Perl_mg_clear +#define mg_copy Perl_mg_copy +#define mg_find Perl_mg_find +#define mg_free Perl_mg_free +#define mg_get Perl_mg_get +#define mg_len Perl_mg_len +#define mg_magical Perl_mg_magical +#define mg_set Perl_mg_set +#define min_intro_pending Perl_min_intro_pending +#define mod Perl_mod +#define mod_amg Perl_mod_amg +#define mod_ass_amg Perl_mod_ass_amg +#define modkids Perl_modkids +#define moreswitches Perl_moreswitches +#define mstats Perl_mstats +#define mult_amg Perl_mult_amg +#define mult_ass_amg Perl_mult_ass_amg +#define multi_close Perl_multi_close +#define multi_end Perl_multi_end +#define multi_open Perl_multi_open +#define multi_start Perl_multi_start +#define my Perl_my +#define my_bcopy Perl_my_bcopy +#define my_bzero Perl_my_bzero +#define my_chsize Perl_my_chsize +#define my_exit Perl_my_exit +#define my_htonl Perl_my_htonl +#define my_lstat Perl_my_lstat +#define my_memcmp Perl_my_memcmp +#define my_ntohl Perl_my_ntohl +#define my_pclose Perl_my_pclose +#define my_popen Perl_my_popen +#define my_setenv Perl_my_setenv +#define my_stat Perl_my_stat +#define my_swap Perl_my_swap +#define my_unexec Perl_my_unexec +#define na Perl_na +#define ncmp_amg Perl_ncmp_amg +#define ne_amg Perl_ne_amg +#define neg_amg Perl_neg_amg +#define newANONHASH Perl_newANONHASH +#define newANONLIST Perl_newANONLIST +#define newANONSUB Perl_newANONSUB +#define newASSIGNOP Perl_newASSIGNOP +#define newAV Perl_newAV +#define newAVREF Perl_newAVREF +#define newBINOP Perl_newBINOP +#define newCONDOP Perl_newCONDOP +#define newCVREF Perl_newCVREF +#define newFORM Perl_newFORM +#define newFOROP Perl_newFOROP +#define newGVOP Perl_newGVOP +#define newGVREF Perl_newGVREF +#define newGVgen Perl_newGVgen +#define newHV Perl_newHV +#define newHVREF Perl_newHVREF +#define newIO Perl_newIO +#define newLISTOP Perl_newLISTOP +#define newLOGOP Perl_newLOGOP +#define newLOOPEX Perl_newLOOPEX +#define newLOOPOP Perl_newLOOPOP +#define newNULLLIST Perl_newNULLLIST +#define newOP Perl_newOP +#define newPMOP Perl_newPMOP +#define newPROG Perl_newPROG +#define newPVOP Perl_newPVOP +#define newRANGE Perl_newRANGE +#define newRV Perl_newRV +#define newSLICEOP Perl_newSLICEOP +#define newSTATEOP Perl_newSTATEOP +#define newSUB Perl_newSUB +#define newSV Perl_newSV +#define newSVOP Perl_newSVOP +#define newSVREF Perl_newSVREF +#define newSViv Perl_newSViv +#define newSVnv Perl_newSVnv +#define newSVpv Perl_newSVpv +#define newSVrv Perl_newSVrv +#define newSVsv Perl_newSVsv +#define newUNOP Perl_newUNOP +#define newWHILEOP Perl_newWHILEOP +#define newXS Perl_newXS +#define newXSUB Perl_newXSUB +#define nextargv Perl_nextargv +#define nexttoke Perl_nexttoke +#define nexttype Perl_nexttype +#define nextval Perl_nextval +#define ninstr Perl_ninstr +#define no_aelem Perl_no_aelem +#define no_dir_func Perl_no_dir_func +#define no_fh_allowed Perl_no_fh_allowed +#define no_func Perl_no_func +#define no_helem Perl_no_helem +#define no_mem Perl_no_mem +#define no_modify Perl_no_modify +#define no_op Perl_no_op +#define no_security Perl_no_security +#define no_sock_func Perl_no_sock_func +#define no_usym Perl_no_usym +#define nointrp Perl_nointrp +#define nomem Perl_nomem +#define nomemok Perl_nomemok +#define nomethod_amg Perl_nomethod_amg +#define not_amg Perl_not_amg +#define numer_amg Perl_numer_amg +#define numeric_local Perl_numeric_local +#define numeric_name Perl_numeric_name +#define numeric_standard Perl_numeric_standard +#define oldbufptr Perl_oldbufptr +#define oldoldbufptr Perl_oldoldbufptr +#define oopsAV Perl_oopsAV +#define oopsCV Perl_oopsCV +#define oopsHV Perl_oopsHV +#define op Perl_op +#define op_desc Perl_op_desc +#define op_free Perl_op_free +#define op_name Perl_op_name +#define op_seqmax Perl_op_seqmax +#define opargs Perl_opargs +#define origalen Perl_origalen +#define origenviron Perl_origenviron +#define osname Perl_osname +#define package Perl_package +#define pad_alloc Perl_pad_alloc +#define pad_allocmy Perl_pad_allocmy +#define pad_findmy Perl_pad_findmy +#define pad_free Perl_pad_free +#define pad_leavemy Perl_pad_leavemy +#define pad_reset Perl_pad_reset +#define pad_sv Perl_pad_sv +#define pad_swipe Perl_pad_swipe +#define padix Perl_padix +#define patleave Perl_patleave +#define peep Perl_peep +#define pidgone Perl_pidgone +#define pidstatus Perl_pidstatus +#define pmflag Perl_pmflag +#define pmruntime Perl_pmruntime +#define pmtrans Perl_pmtrans +#define pop_return Perl_pop_return +#define pop_scope Perl_pop_scope +#define pow_amg Perl_pow_amg +#define pow_ass_amg Perl_pow_ass_amg +#define pp_aassign Perl_pp_aassign +#define pp_abs Perl_pp_abs +#define pp_accept Perl_pp_accept +#define pp_add Perl_pp_add +#define pp_aelem Perl_pp_aelem +#define pp_aelemfast Perl_pp_aelemfast +#define pp_alarm Perl_pp_alarm +#define pp_and Perl_pp_and +#define pp_andassign Perl_pp_andassign +#define pp_anoncode Perl_pp_anoncode +#define pp_anonhash Perl_pp_anonhash +#define pp_anonlist Perl_pp_anonlist +#define pp_aslice Perl_pp_aslice +#define pp_atan2 Perl_pp_atan2 +#define pp_av2arylen Perl_pp_av2arylen +#define pp_backtick Perl_pp_backtick +#define pp_bind Perl_pp_bind +#define pp_binmode Perl_pp_binmode +#define pp_bit_and Perl_pp_bit_and +#define pp_bit_or Perl_pp_bit_or +#define pp_bit_xor Perl_pp_bit_xor +#define pp_bless Perl_pp_bless +#define pp_caller Perl_pp_caller +#define pp_chdir Perl_pp_chdir +#define pp_chmod Perl_pp_chmod +#define pp_chomp Perl_pp_chomp +#define pp_chop Perl_pp_chop +#define pp_chown Perl_pp_chown +#define pp_chr Perl_pp_chr +#define pp_chroot Perl_pp_chroot +#define pp_close Perl_pp_close +#define pp_closedir Perl_pp_closedir +#define pp_complement Perl_pp_complement +#define pp_concat Perl_pp_concat +#define pp_cond_expr Perl_pp_cond_expr +#define pp_connect Perl_pp_connect +#define pp_const Perl_pp_const +#define pp_cos Perl_pp_cos +#define pp_crypt Perl_pp_crypt +#define pp_cswitch Perl_pp_cswitch +#define pp_dbmclose Perl_pp_dbmclose +#define pp_dbmopen Perl_pp_dbmopen +#define pp_dbstate Perl_pp_dbstate +#define pp_defined Perl_pp_defined +#define pp_delete Perl_pp_delete +#define pp_die Perl_pp_die +#define pp_divide Perl_pp_divide +#define pp_dofile Perl_pp_dofile +#define pp_dump Perl_pp_dump +#define pp_each Perl_pp_each +#define pp_egrent Perl_pp_egrent +#define pp_ehostent Perl_pp_ehostent +#define pp_enetent Perl_pp_enetent +#define pp_enter Perl_pp_enter +#define pp_entereval Perl_pp_entereval +#define pp_enteriter Perl_pp_enteriter +#define pp_enterloop Perl_pp_enterloop +#define pp_entersub Perl_pp_entersub +#define pp_entersubr Perl_pp_entersubr +#define pp_entertry Perl_pp_entertry +#define pp_enterwrite Perl_pp_enterwrite +#define pp_eof Perl_pp_eof +#define pp_eprotoent Perl_pp_eprotoent +#define pp_epwent Perl_pp_epwent +#define pp_eq Perl_pp_eq +#define pp_eservent Perl_pp_eservent +#define pp_evalonce Perl_pp_evalonce +#define pp_exec Perl_pp_exec +#define pp_exists Perl_pp_exists +#define pp_exit Perl_pp_exit +#define pp_exp Perl_pp_exp +#define pp_fcntl Perl_pp_fcntl +#define pp_fileno Perl_pp_fileno +#define pp_flip Perl_pp_flip +#define pp_flock Perl_pp_flock +#define pp_flop Perl_pp_flop +#define pp_fork Perl_pp_fork +#define pp_formline Perl_pp_formline +#define pp_ftatime Perl_pp_ftatime +#define pp_ftbinary Perl_pp_ftbinary +#define pp_ftblk Perl_pp_ftblk +#define pp_ftchr Perl_pp_ftchr +#define pp_ftctime Perl_pp_ftctime +#define pp_ftdir Perl_pp_ftdir +#define pp_fteexec Perl_pp_fteexec +#define pp_fteowned Perl_pp_fteowned +#define pp_fteread Perl_pp_fteread +#define pp_ftewrite Perl_pp_ftewrite +#define pp_ftfile Perl_pp_ftfile +#define pp_ftis Perl_pp_ftis +#define pp_ftlink Perl_pp_ftlink +#define pp_ftmtime Perl_pp_ftmtime +#define pp_ftpipe Perl_pp_ftpipe +#define pp_ftrexec Perl_pp_ftrexec +#define pp_ftrowned Perl_pp_ftrowned +#define pp_ftrread Perl_pp_ftrread +#define pp_ftrwrite Perl_pp_ftrwrite +#define pp_ftsgid Perl_pp_ftsgid +#define pp_ftsize Perl_pp_ftsize +#define pp_ftsock Perl_pp_ftsock +#define pp_ftsuid Perl_pp_ftsuid +#define pp_ftsvtx Perl_pp_ftsvtx +#define pp_fttext Perl_pp_fttext +#define pp_fttty Perl_pp_fttty +#define pp_ftzero Perl_pp_ftzero +#define pp_ge Perl_pp_ge +#define pp_gelem Perl_pp_gelem +#define pp_getc Perl_pp_getc +#define pp_getlogin Perl_pp_getlogin +#define pp_getpeername Perl_pp_getpeername +#define pp_getpgrp Perl_pp_getpgrp +#define pp_getppid Perl_pp_getppid +#define pp_getpriority Perl_pp_getpriority +#define pp_getsockname Perl_pp_getsockname +#define pp_ggrent Perl_pp_ggrent +#define pp_ggrgid Perl_pp_ggrgid +#define pp_ggrnam Perl_pp_ggrnam +#define pp_ghbyaddr Perl_pp_ghbyaddr +#define pp_ghbyname Perl_pp_ghbyname +#define pp_ghostent Perl_pp_ghostent +#define pp_glob Perl_pp_glob +#define pp_gmtime Perl_pp_gmtime +#define pp_gnbyaddr Perl_pp_gnbyaddr +#define pp_gnbyname Perl_pp_gnbyname +#define pp_gnetent Perl_pp_gnetent +#define pp_goto Perl_pp_goto +#define pp_gpbyname Perl_pp_gpbyname +#define pp_gpbynumber Perl_pp_gpbynumber +#define pp_gprotoent Perl_pp_gprotoent +#define pp_gpwent Perl_pp_gpwent +#define pp_gpwnam Perl_pp_gpwnam +#define pp_gpwuid Perl_pp_gpwuid +#define pp_grepstart Perl_pp_grepstart +#define pp_grepwhile Perl_pp_grepwhile +#define pp_gsbyname Perl_pp_gsbyname +#define pp_gsbyport Perl_pp_gsbyport +#define pp_gservent Perl_pp_gservent +#define pp_gsockopt Perl_pp_gsockopt +#define pp_gt Perl_pp_gt +#define pp_gv Perl_pp_gv +#define pp_gvsv Perl_pp_gvsv +#define pp_helem Perl_pp_helem +#define pp_hex Perl_pp_hex +#define pp_hslice Perl_pp_hslice +#define pp_i_add Perl_pp_i_add +#define pp_i_divide Perl_pp_i_divide +#define pp_i_eq Perl_pp_i_eq +#define pp_i_ge Perl_pp_i_ge +#define pp_i_gt Perl_pp_i_gt +#define pp_i_le Perl_pp_i_le +#define pp_i_lt Perl_pp_i_lt +#define pp_i_modulo Perl_pp_i_modulo +#define pp_i_multiply Perl_pp_i_multiply +#define pp_i_ncmp Perl_pp_i_ncmp +#define pp_i_ne Perl_pp_i_ne +#define pp_i_negate Perl_pp_i_negate +#define pp_i_subtract Perl_pp_i_subtract +#define pp_index Perl_pp_index +#define pp_indread Perl_pp_indread +#define pp_int Perl_pp_int +#define pp_interp Perl_pp_interp +#define pp_ioctl Perl_pp_ioctl +#define pp_iter Perl_pp_iter +#define pp_join Perl_pp_join +#define pp_keys Perl_pp_keys +#define pp_kill Perl_pp_kill +#define pp_last Perl_pp_last +#define pp_lc Perl_pp_lc +#define pp_lcfirst Perl_pp_lcfirst +#define pp_le Perl_pp_le +#define pp_leave Perl_pp_leave +#define pp_leaveeval Perl_pp_leaveeval +#define pp_leaveloop Perl_pp_leaveloop +#define pp_leavesub Perl_pp_leavesub +#define pp_leavetry Perl_pp_leavetry +#define pp_leavewrite Perl_pp_leavewrite +#define pp_left_shift Perl_pp_left_shift +#define pp_length Perl_pp_length +#define pp_lineseq Perl_pp_lineseq +#define pp_link Perl_pp_link +#define pp_list Perl_pp_list +#define pp_listen Perl_pp_listen +#define pp_localtime Perl_pp_localtime +#define pp_log Perl_pp_log +#define pp_lslice Perl_pp_lslice +#define pp_lstat Perl_pp_lstat +#define pp_lt Perl_pp_lt +#define pp_map Perl_pp_map +#define pp_mapstart Perl_pp_mapstart +#define pp_mapwhile Perl_pp_mapwhile +#define pp_match Perl_pp_match +#define pp_method Perl_pp_method +#define pp_mkdir Perl_pp_mkdir +#define pp_modulo Perl_pp_modulo +#define pp_msgctl Perl_pp_msgctl +#define pp_msgget Perl_pp_msgget +#define pp_msgrcv Perl_pp_msgrcv +#define pp_msgsnd Perl_pp_msgsnd +#define pp_multiply Perl_pp_multiply +#define pp_ncmp Perl_pp_ncmp +#define pp_ne Perl_pp_ne +#define pp_negate Perl_pp_negate +#define pp_next Perl_pp_next +#define pp_nextstate Perl_pp_nextstate +#define pp_not Perl_pp_not +#define pp_nswitch Perl_pp_nswitch +#define pp_null Perl_pp_null +#define pp_oct Perl_pp_oct +#define pp_open Perl_pp_open +#define pp_open_dir Perl_pp_open_dir +#define pp_or Perl_pp_or +#define pp_orassign Perl_pp_orassign +#define pp_ord Perl_pp_ord +#define pp_pack Perl_pp_pack +#define pp_padany Perl_pp_padany +#define pp_padav Perl_pp_padav +#define pp_padhv Perl_pp_padhv +#define pp_padsv Perl_pp_padsv +#define pp_pipe_op Perl_pp_pipe_op +#define pp_pop Perl_pp_pop +#define pp_pos Perl_pp_pos +#define pp_postdec Perl_pp_postdec +#define pp_postinc Perl_pp_postinc +#define pp_pow Perl_pp_pow +#define pp_predec Perl_pp_predec +#define pp_preinc Perl_pp_preinc +#define pp_print Perl_pp_print +#define pp_prototype Perl_pp_prototype +#define pp_prtf Perl_pp_prtf +#define pp_push Perl_pp_push +#define pp_pushmark Perl_pp_pushmark +#define pp_pushre Perl_pp_pushre +#define pp_quotemeta Perl_pp_quotemeta +#define pp_rand Perl_pp_rand +#define pp_range Perl_pp_range +#define pp_rcatline Perl_pp_rcatline +#define pp_read Perl_pp_read +#define pp_readdir Perl_pp_readdir +#define pp_readline Perl_pp_readline +#define pp_readlink Perl_pp_readlink +#define pp_recv Perl_pp_recv +#define pp_redo Perl_pp_redo +#define pp_ref Perl_pp_ref +#define pp_refgen Perl_pp_refgen +#define pp_regcmaybe Perl_pp_regcmaybe +#define pp_regcomp Perl_pp_regcomp +#define pp_rename Perl_pp_rename +#define pp_repeat Perl_pp_repeat +#define pp_require Perl_pp_require +#define pp_reset Perl_pp_reset +#define pp_return Perl_pp_return +#define pp_reverse Perl_pp_reverse +#define pp_rewinddir Perl_pp_rewinddir +#define pp_right_shift Perl_pp_right_shift +#define pp_rindex Perl_pp_rindex +#define pp_rmdir Perl_pp_rmdir +#define pp_rv2av Perl_pp_rv2av +#define pp_rv2cv Perl_pp_rv2cv +#define pp_rv2gv Perl_pp_rv2gv +#define pp_rv2hv Perl_pp_rv2hv +#define pp_rv2sv Perl_pp_rv2sv +#define pp_sassign Perl_pp_sassign +#define pp_scalar Perl_pp_scalar +#define pp_schomp Perl_pp_schomp +#define pp_schop Perl_pp_schop +#define pp_scmp Perl_pp_scmp +#define pp_scope Perl_pp_scope +#define pp_seek Perl_pp_seek +#define pp_seekdir Perl_pp_seekdir +#define pp_select Perl_pp_select +#define pp_semctl Perl_pp_semctl +#define pp_semget Perl_pp_semget +#define pp_semop Perl_pp_semop +#define pp_send Perl_pp_send +#define pp_seq Perl_pp_seq +#define pp_setpgrp Perl_pp_setpgrp +#define pp_setpriority Perl_pp_setpriority +#define pp_sge Perl_pp_sge +#define pp_sgrent Perl_pp_sgrent +#define pp_sgt Perl_pp_sgt +#define pp_shift Perl_pp_shift +#define pp_shmctl Perl_pp_shmctl +#define pp_shmget Perl_pp_shmget +#define pp_shmread Perl_pp_shmread +#define pp_shmwrite Perl_pp_shmwrite +#define pp_shostent Perl_pp_shostent +#define pp_shutdown Perl_pp_shutdown +#define pp_sin Perl_pp_sin +#define pp_sle Perl_pp_sle +#define pp_sleep Perl_pp_sleep +#define pp_slt Perl_pp_slt +#define pp_sne Perl_pp_sne +#define pp_snetent Perl_pp_snetent +#define pp_socket Perl_pp_socket +#define pp_sockpair Perl_pp_sockpair +#define pp_sort Perl_pp_sort +#define pp_splice Perl_pp_splice +#define pp_split Perl_pp_split +#define pp_sprintf Perl_pp_sprintf +#define pp_sprotoent Perl_pp_sprotoent +#define pp_spwent Perl_pp_spwent +#define pp_sqrt Perl_pp_sqrt +#define pp_srand Perl_pp_srand +#define pp_srefgen Perl_pp_srefgen +#define pp_sselect Perl_pp_sselect +#define pp_sservent Perl_pp_sservent +#define pp_ssockopt Perl_pp_ssockopt +#define pp_stat Perl_pp_stat +#define pp_stringify Perl_pp_stringify +#define pp_stub Perl_pp_stub +#define pp_study Perl_pp_study +#define pp_subst Perl_pp_subst +#define pp_substcont Perl_pp_substcont +#define pp_substr Perl_pp_substr +#define pp_subtract Perl_pp_subtract +#define pp_symlink Perl_pp_symlink +#define pp_syscall Perl_pp_syscall +#define pp_sysopen Perl_pp_sysopen +#define pp_sysread Perl_pp_sysread +#define pp_system Perl_pp_system +#define pp_syswrite Perl_pp_syswrite +#define pp_tell Perl_pp_tell +#define pp_telldir Perl_pp_telldir +#define pp_tie Perl_pp_tie +#define pp_tied Perl_pp_tied +#define pp_time Perl_pp_time +#define pp_tms Perl_pp_tms +#define pp_trans Perl_pp_trans +#define pp_truncate Perl_pp_truncate +#define pp_uc Perl_pp_uc +#define pp_ucfirst Perl_pp_ucfirst +#define pp_umask Perl_pp_umask +#define pp_undef Perl_pp_undef +#define pp_unlink Perl_pp_unlink +#define pp_unpack Perl_pp_unpack +#define pp_unshift Perl_pp_unshift +#define pp_unstack Perl_pp_unstack +#define pp_untie Perl_pp_untie +#define pp_utime Perl_pp_utime +#define pp_values Perl_pp_values +#define pp_vec Perl_pp_vec +#define pp_wait Perl_pp_wait +#define pp_waitpid Perl_pp_waitpid +#define pp_wantarray Perl_pp_wantarray +#define pp_warn Perl_pp_warn +#define pp_xor Perl_pp_xor +#define ppaddr Perl_ppaddr +#define pregcomp Perl_pregcomp +#define pregexec Perl_pregexec +#define pregfree Perl_pregfree +#define prepend_elem Perl_prepend_elem +#define profiledata Perl_profiledata +#define provide_ref Perl_provide_ref +#define psig_name Perl_psig_name +#define psig_ptr Perl_psig_ptr +#define push_return Perl_push_return +#define push_scope Perl_push_scope +#define q Perl_q +#define qrt_amg Perl_qrt_amg +#define rcsid Perl_rcsid +#define reall_srchlen Perl_reall_srchlen +#define ref Perl_ref +#define refkids Perl_refkids +#define regarglen Perl_regarglen +#define regbol Perl_regbol +#define regcode Perl_regcode +#define regdummy Perl_regdummy +#define regdump Perl_regdump +#define regendp Perl_regendp +#define regeol Perl_regeol +#define reginput Perl_reginput +#define regkind Perl_regkind +#define reglastparen Perl_reglastparen +#define regmyendp Perl_regmyendp +#define regmyp_size Perl_regmyp_size +#define regmystartp Perl_regmystartp +#define regnarrate Perl_regnarrate +#define regnaughty Perl_regnaughty +#define regnext Perl_regnext +#define regnpar Perl_regnpar +#define regparse Perl_regparse +#define regprecomp Perl_regprecomp +#define regprev Perl_regprev +#define regprop Perl_regprop +#define regsawback Perl_regsawback +#define regsize Perl_regsize +#define regstartp Perl_regstartp +#define regtill Perl_regtill +#define regxend Perl_regxend +#define repeat_amg Perl_repeat_amg +#define repeat_ass_amg Perl_repeat_ass_amg +#define repeatcpy Perl_repeatcpy +#define retstack Perl_retstack +#define retstack_ix Perl_retstack_ix +#define retstack_max Perl_retstack_max +#define rninstr Perl_rninstr +#define rsfp Perl_rsfp +#define rsfp_filters Perl_rsfp_filters +#define rshift_amg Perl_rshift_amg +#define rshift_ass_amg Perl_rshift_ass_amg +#define rsignal Perl_rsignal +#define rsignal_restore Perl_rsignal_restore +#define rsignal_save Perl_rsignal_save +#define rsignal_state Perl_rsignal_state +#define runops Perl_runops +#define same_dirent Perl_same_dirent +#define save_I16 Perl_save_I16 +#define save_I32 Perl_save_I32 +#define save_aptr Perl_save_aptr +#define save_ary Perl_save_ary +#define save_clearsv Perl_save_clearsv +#define save_delete Perl_save_delete +#define save_destructor Perl_save_destructor +#define save_freeop Perl_save_freeop +#define save_freepv Perl_save_freepv +#define save_freesv Perl_save_freesv +#define save_gp Perl_save_gp +#define save_hash Perl_save_hash +#define save_hptr Perl_save_hptr +#define save_int Perl_save_int +#define save_item Perl_save_item +#define save_list Perl_save_list +#define save_long Perl_save_long +#define save_nogv Perl_save_nogv +#define save_pptr Perl_save_pptr +#define save_scalar Perl_save_scalar +#define save_sptr Perl_save_sptr +#define save_svref Perl_save_svref +#define savepv Perl_savepv +#define savepvn Perl_savepvn +#define savestack Perl_savestack +#define savestack_grow Perl_savestack_grow +#define savestack_ix Perl_savestack_ix +#define savestack_max Perl_savestack_max +#define saw_return Perl_saw_return +#define sawparens Perl_sawparens +#define scalar Perl_scalar +#define scalarkids Perl_scalarkids +#define scalarseq Perl_scalarseq +#define scalarvoid Perl_scalarvoid +#define scan_const Perl_scan_const +#define scan_formline Perl_scan_formline +#define scan_heredoc Perl_scan_heredoc +#define scan_hex Perl_scan_hex +#define scan_ident Perl_scan_ident #define scan_inputsymbol Perl_scan_inputsymbol -#define scan_num Perl_scan_num -#define scan_oct Perl_scan_oct -#define scan_pat Perl_scan_pat -#define scan_prefix Perl_scan_prefix -#define scan_str Perl_scan_str -#define scan_subst Perl_scan_subst -#define scan_trans Perl_scan_trans -#define scan_word Perl_scan_word -#define scope Perl_scope -#define screaminstr Perl_screaminstr -#define setdefout Perl_setdefout -#define setenv_getix Perl_setenv_getix -#define sharepvn Perl_sharepvn -#define sighandler Perl_sighandler -#define skipspace Perl_skipspace -#define stack_grow Perl_stack_grow -#define start_subparse Perl_start_subparse -#define sublex_done Perl_sublex_done -#define sublex_start Perl_sublex_start -#define sv_2bool Perl_sv_2bool -#define sv_2cv Perl_sv_2cv -#define sv_2io Perl_sv_2io -#define sv_2iv Perl_sv_2iv -#define sv_2mortal Perl_sv_2mortal -#define sv_2nv Perl_sv_2nv -#define sv_2pv Perl_sv_2pv -#define sv_add_arena Perl_sv_add_arena -#define sv_backoff Perl_sv_backoff -#define sv_bless Perl_sv_bless -#define sv_catpv Perl_sv_catpv -#define sv_catpvn Perl_sv_catpvn -#define sv_catsv Perl_sv_catsv -#define sv_chop Perl_sv_chop -#define sv_clean_all Perl_sv_clean_all -#define sv_clean_objs Perl_sv_clean_objs -#define sv_clear Perl_sv_clear -#define sv_cmp Perl_sv_cmp -#define sv_dec Perl_sv_dec -#define sv_dump Perl_sv_dump -#define sv_eq Perl_sv_eq -#define sv_free Perl_sv_free -#define sv_free_arenas Perl_sv_free_arenas -#define sv_gets Perl_sv_gets -#define sv_grow Perl_sv_grow -#define sv_inc Perl_sv_inc -#define sv_insert Perl_sv_insert -#define sv_isa Perl_sv_isa -#define sv_isobject Perl_sv_isobject -#define sv_len Perl_sv_len -#define sv_magic Perl_sv_magic -#define sv_mortalcopy Perl_sv_mortalcopy -#define sv_newmortal Perl_sv_newmortal -#define sv_newref Perl_sv_newref -#define sv_peek Perl_sv_peek -#define sv_pvn_force Perl_sv_pvn_force -#define sv_ref Perl_sv_ref -#define sv_reftype Perl_sv_reftype -#define sv_replace Perl_sv_replace -#define sv_report_used Perl_sv_report_used -#define sv_reset Perl_sv_reset -#define sv_setiv Perl_sv_setiv -#define sv_setnv Perl_sv_setnv -#define sv_setptrobj Perl_sv_setptrobj -#define sv_setpv Perl_sv_setpv -#define sv_setpvn Perl_sv_setpvn -#define sv_setref_iv Perl_sv_setref_iv -#define sv_setref_nv Perl_sv_setref_nv -#define sv_setref_pv Perl_sv_setref_pv -#define sv_setref_pvn Perl_sv_setref_pvn -#define sv_setsv Perl_sv_setsv -#define sv_unmagic Perl_sv_unmagic -#define sv_unref Perl_sv_unref -#define sv_upgrade Perl_sv_upgrade -#define sv_usepvn Perl_sv_usepvn -#define taint_env Perl_taint_env -#define taint_not Perl_taint_not -#define taint_proper Perl_taint_proper +#define scan_num Perl_scan_num +#define scan_oct Perl_scan_oct +#define scan_pat Perl_scan_pat +#define scan_prefix Perl_scan_prefix +#define scan_str Perl_scan_str +#define scan_subst Perl_scan_subst +#define scan_trans Perl_scan_trans +#define scan_word Perl_scan_word +#define scmp_amg Perl_scmp_amg +#define scope Perl_scope +#define scopestack Perl_scopestack +#define scopestack_ix Perl_scopestack_ix +#define scopestack_max Perl_scopestack_max +#define screaminstr Perl_screaminstr +#define scrgv Perl_scrgv +#define seq_amg Perl_seq_amg +#define setdefout Perl_setdefout +#define setenv_getix Perl_setenv_getix +#define sge_amg Perl_sge_amg +#define sgt_amg Perl_sgt_amg +#define sh_path Perl_sh_path +#define share_hek Perl_share_hek +#define sharepvn Perl_sharepvn +#define sig_name Perl_sig_name +#define sig_num Perl_sig_num +#define sighandler Perl_sighandler +#define simple Perl_simple +#define sin_amg Perl_sin_amg +#define skipspace Perl_skipspace +#define sle_amg Perl_sle_amg +#define slt_amg Perl_slt_amg +#define sne_amg Perl_sne_amg +#define stack_base Perl_stack_base +#define stack_grow Perl_stack_grow +#define stack_max Perl_stack_max +#define stack_sp Perl_stack_sp +#define start_subparse Perl_start_subparse +#define statbuf Perl_statbuf +#define string_amg Perl_string_amg +#define sub_crush_depth Perl_sub_crush_depth +#define sub_generation Perl_sub_generation +#define subline Perl_subline +#define subname Perl_subname +#define subtr_amg Perl_subtr_amg +#define subtr_ass_amg Perl_subtr_ass_amg +#define sv_2bool Perl_sv_2bool +#define sv_2cv Perl_sv_2cv +#define sv_2io Perl_sv_2io +#define sv_2iv Perl_sv_2iv +#define sv_2mortal Perl_sv_2mortal +#define sv_2nv Perl_sv_2nv +#define sv_2pv Perl_sv_2pv +#define sv_2uv Perl_sv_2uv +#define sv_add_arena Perl_sv_add_arena +#define sv_backoff Perl_sv_backoff +#define sv_bless Perl_sv_bless +#define sv_catpv Perl_sv_catpv +#define sv_catpvn Perl_sv_catpvn +#define sv_catsv Perl_sv_catsv +#define sv_chop Perl_sv_chop +#define sv_clean_all Perl_sv_clean_all +#define sv_clean_objs Perl_sv_clean_objs +#define sv_clear Perl_sv_clear +#define sv_cmp Perl_sv_cmp +#define sv_cmp_locale Perl_sv_cmp_locale +#define sv_collxfrm Perl_sv_collxfrm +#define sv_dec Perl_sv_dec +#define sv_derived_from Perl_sv_derived_from +#define sv_dump Perl_sv_dump +#define sv_eq Perl_sv_eq +#define sv_free Perl_sv_free +#define sv_free_arenas Perl_sv_free_arenas +#define sv_gets Perl_sv_gets +#define sv_grow Perl_sv_grow +#define sv_inc Perl_sv_inc +#define sv_insert Perl_sv_insert +#define sv_isa Perl_sv_isa +#define sv_isobject Perl_sv_isobject +#define sv_len Perl_sv_len +#define sv_magic Perl_sv_magic +#define sv_mortalcopy Perl_sv_mortalcopy +#define sv_newmortal Perl_sv_newmortal +#define sv_newref Perl_sv_newref +#define sv_no Perl_sv_no +#define sv_peek Perl_sv_peek +#define sv_pvn_force Perl_sv_pvn_force +#define sv_ref Perl_sv_ref +#define sv_reftype Perl_sv_reftype +#define sv_replace Perl_sv_replace +#define sv_report_used Perl_sv_report_used +#define sv_reset Perl_sv_reset +#define sv_setiv Perl_sv_setiv +#define sv_setnv Perl_sv_setnv +#define sv_setptrobj Perl_sv_setptrobj +#define sv_setpv Perl_sv_setpv +#define sv_setpvn Perl_sv_setpvn +#define sv_setref_iv Perl_sv_setref_iv +#define sv_setref_nv Perl_sv_setref_nv +#define sv_setref_pv Perl_sv_setref_pv +#define sv_setref_pvn Perl_sv_setref_pvn +#define sv_setsv Perl_sv_setsv +#define sv_setuv Perl_sv_setuv +#define sv_taint Perl_sv_taint +#define sv_tainted Perl_sv_tainted +#define sv_undef Perl_sv_undef +#define sv_unmagic Perl_sv_unmagic +#define sv_unref Perl_sv_unref +#define sv_untaint Perl_sv_untaint +#define sv_upgrade Perl_sv_upgrade +#define sv_usepvn Perl_sv_usepvn +#define sv_yes Perl_sv_yes +#define taint_env Perl_taint_env +#define taint_proper Perl_taint_proper +#define thisexpr Perl_thisexpr +#define timesbuf Perl_timesbuf +#define tokenbuf Perl_tokenbuf #define too_few_arguments Perl_too_few_arguments #define too_many_arguments Perl_too_many_arguments -#define unlnk Perl_unlnk -#define unsharepvn Perl_unsharepvn -#define utilize Perl_utilize -#define wait4pid Perl_wait4pid -#define warn Perl_warn -#define watch Perl_watch -#define whichsig Perl_whichsig -#define xiv_arenaroot Perl_xiv_arenaroot -#define xiv_root Perl_xiv_root -#define xnv_root Perl_xnv_root -#define xpv_root Perl_xpv_root -#define xrv_root Perl_xrv_root -#define yyerror Perl_yyerror -#define yylex Perl_yylex -#define yyparse Perl_yyparse -#define yywarn Perl_yywarn +#define uid Perl_uid +#define unlnk Perl_unlnk +#define unshare_hek Perl_unshare_hek +#define unsharepvn Perl_unsharepvn +#define utilize Perl_utilize +#define varies Perl_varies +#define vert Perl_vert +#define vivify_itervar Perl_vivify_itervar +#define vtbl_amagic Perl_vtbl_amagic +#define vtbl_amagicelem Perl_vtbl_amagicelem +#define vtbl_arylen Perl_vtbl_arylen +#define vtbl_bm Perl_vtbl_bm +#define vtbl_collxfrm Perl_vtbl_collxfrm +#define vtbl_dbline Perl_vtbl_dbline +#define vtbl_env Perl_vtbl_env +#define vtbl_envelem Perl_vtbl_envelem +#define vtbl_fm Perl_vtbl_fm +#define vtbl_glob Perl_vtbl_glob +#define vtbl_isa Perl_vtbl_isa +#define vtbl_isaelem Perl_vtbl_isaelem +#define vtbl_itervar Perl_vtbl_itervar +#define vtbl_mglob Perl_vtbl_mglob +#define vtbl_nkeys Perl_vtbl_nkeys +#define vtbl_pack Perl_vtbl_pack +#define vtbl_packelem Perl_vtbl_packelem +#define vtbl_pos Perl_vtbl_pos +#define vtbl_sig Perl_vtbl_sig +#define vtbl_sigelem Perl_vtbl_sigelem +#define vtbl_substr Perl_vtbl_substr +#define vtbl_sv Perl_vtbl_sv +#define vtbl_taint Perl_vtbl_taint +#define vtbl_uvar Perl_vtbl_uvar +#define vtbl_vec Perl_vtbl_vec +#define wait4pid Perl_wait4pid +#define warn Perl_warn +#define warn_nl Perl_warn_nl +#define warn_nosemi Perl_warn_nosemi +#define warn_reserved Perl_warn_reserved +#define watch Perl_watch +#define watchaddr Perl_watchaddr +#define watchok Perl_watchok +#define whichsig Perl_whichsig +#define xiv_arenaroot Perl_xiv_arenaroot +#define xiv_root Perl_xiv_root +#define xnv_root Perl_xnv_root +#define xpv_root Perl_xpv_root +#define xrv_root Perl_xrv_root +#define yychar Perl_yychar +#define yycheck Perl_yycheck +#define yydebug Perl_yydebug +#define yydefred Perl_yydefred +#define yydgoto Perl_yydgoto +#define yyerrflag Perl_yyerrflag +#define yyerror Perl_yyerror +#define yygindex Perl_yygindex +#define yylen Perl_yylen +#define yylex Perl_yylex +#define yylhs Perl_yylhs +#define yylval Perl_yylval +#define yyname Perl_yyname +#define yynerrs Perl_yynerrs +#define yyparse Perl_yyparse +#define yyrindex Perl_yyrindex +#define yyrule Perl_yyrule +#define yysindex Perl_yysindex +#define yytable Perl_yytable +#define yyval Perl_yyval +#define yywarn Perl_yywarn -#endif /* EMBED */ +/* Hide global symbols that 5.003 revealed? */ -/* Put interpreter specific symbols into a struct? */ +#ifndef BINCOMPAT3 -#ifdef MULTIPLICITY +#define Error Perl_Error +#define SvIV Perl_SvIV +#define SvNV Perl_SvNV +#define SvTRUE Perl_SvTRUE +#define SvUV Perl_SvUV +#define block_type Perl_block_type +#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL +#define comppad_name_floor Perl_comppad_name_floor +#define debug Perl_debug +#define do_undump Perl_do_undump +#define nice_chunk Perl_nice_chunk +#define nice_chunk_size Perl_nice_chunk_size +#define no_myglob Perl_no_myglob +#define no_symref Perl_no_symref +#define no_wrongref Perl_no_wrongref +#define pad_reset_pending Perl_pad_reset_pending +#define padix_floor Perl_padix_floor +#define regflags Perl_regflags +#define safecalloc Perl_safecalloc +#define safefree Perl_safefree +#define safemalloc Perl_safemalloc +#define saferealloc Perl_saferealloc +#define safexcalloc Perl_safexcalloc +#define safexfree Perl_safexfree +#define safexmalloc Perl_safexmalloc +#define safexrealloc Perl_safexrealloc +#define save_iv Perl_save_iv +#define sv_pvn Perl_sv_pvn +#define warn_uninit Perl_warn_uninit +#define yydestruct Perl_yydestruct -/* Undefine symbols that were defined by EMBED. Somewhat ugly */ +#endif /* !BINCOMPAT3 */ -#undef curcop -#undef curcopdb -#undef envgv -#undef siggv -#undef tainting +#endif /* EMBED */ + +/* Put interpreter-specific symbols into a struct? */ -#define Argv (curinterp->IArgv) -#define Cmd (curinterp->ICmd) -#define DBgv (curinterp->IDBgv) -#define DBline (curinterp->IDBline) -#define DBsignal (curinterp->IDBsignal) -#define DBsingle (curinterp->IDBsingle) -#define DBsub (curinterp->IDBsub) -#define DBtrace (curinterp->IDBtrace) -#define allgvs (curinterp->Iallgvs) -#define ampergv (curinterp->Iampergv) -#define argvgv (curinterp->Iargvgv) -#define argvoutgv (curinterp->Iargvoutgv) -#define basetime (curinterp->Ibasetime) -#define beginav (curinterp->Ibeginav) -#define bodytarget (curinterp->Ibodytarget) -#define cddir (curinterp->Icddir) -#define chopset (curinterp->Ichopset) -#define copline (curinterp->Icopline) -#define curblock (curinterp->Icurblock) -#define curcop (curinterp->Icurcop) -#define curcopdb (curinterp->Icurcopdb) -#define curcsv (curinterp->Icurcsv) -#define curpm (curinterp->Icurpm) -#define curstack (curinterp->Icurstack) -#define curstash (curinterp->Icurstash) -#define curstname (curinterp->Icurstname) -#define cxstack (curinterp->Icxstack) -#define cxstack_ix (curinterp->Icxstack_ix) -#define cxstack_max (curinterp->Icxstack_max) -#define dbargs (curinterp->Idbargs) -#define debdelim (curinterp->Idebdelim) -#define debname (curinterp->Idebname) -#define debstash (curinterp->Idebstash) -#define defgv (curinterp->Idefgv) -#define defoutgv (curinterp->Idefoutgv) -#define defstash (curinterp->Idefstash) -#define delaymagic (curinterp->Idelaymagic) -#define diehook (curinterp->Idiehook) -#define dirty (curinterp->Idirty) -#define dlevel (curinterp->Idlevel) -#define dlmax (curinterp->Idlmax) -#define doextract (curinterp->Idoextract) -#define doswitches (curinterp->Idoswitches) -#define dowarn (curinterp->Idowarn) -#define dumplvl (curinterp->Idumplvl) -#define e_fp (curinterp->Ie_fp) -#define e_tmpname (curinterp->Ie_tmpname) -#define endav (curinterp->Iendav) -#define envgv (curinterp->Ienvgv) -#define errgv (curinterp->Ierrgv) -#define eval_root (curinterp->Ieval_root) -#define eval_start (curinterp->Ieval_start) -#define fdpid (curinterp->Ifdpid) -#define filemode (curinterp->Ifilemode) -#define firstgv (curinterp->Ifirstgv) -#define forkprocess (curinterp->Iforkprocess) -#define formfeed (curinterp->Iformfeed) -#define formtarget (curinterp->Iformtarget) -#define gensym (curinterp->Igensym) -#define in_eval (curinterp->Iin_eval) -#define incgv (curinterp->Iincgv) -#define inplace (curinterp->Iinplace) -#define last_in_gv (curinterp->Ilast_in_gv) -#define lastfd (curinterp->Ilastfd) -#define lastretstr (curinterp->Ilastretstr) -#define lastscream (curinterp->Ilastscream) -#define lastsize (curinterp->Ilastsize) -#define lastspbase (curinterp->Ilastspbase) -#define laststatval (curinterp->Ilaststatval) -#define laststype (curinterp->Ilaststype) -#define leftgv (curinterp->Ileftgv) -#define lineary (curinterp->Ilineary) -#define localizing (curinterp->Ilocalizing) -#define localpatches (curinterp->Ilocalpatches) -#define main_cv (curinterp->Imain_cv) -#define main_root (curinterp->Imain_root) -#define main_start (curinterp->Imain_start) -#define mainstack (curinterp->Imainstack) -#define maxscream (curinterp->Imaxscream) -#define maxsysfd (curinterp->Imaxsysfd) -#define minus_F (curinterp->Iminus_F) -#define minus_a (curinterp->Iminus_a) -#define minus_c (curinterp->Iminus_c) -#define minus_l (curinterp->Iminus_l) -#define minus_n (curinterp->Iminus_n) -#define minus_p (curinterp->Iminus_p) -#define multiline (curinterp->Imultiline) -#define mystack_base (curinterp->Imystack_base) -#define mystack_mark (curinterp->Imystack_mark) -#define mystack_max (curinterp->Imystack_max) -#define mystack_sp (curinterp->Imystack_sp) -#define mystrk (curinterp->Imystrk) -#define nrs (curinterp->Inrs) -#define ofmt (curinterp->Iofmt) -#define ofs (curinterp->Iofs) -#define ofslen (curinterp->Iofslen) -#define oldlastpm (curinterp->Ioldlastpm) -#define oldname (curinterp->Ioldname) -#define op_mask (curinterp->Iop_mask) -#define origargc (curinterp->Iorigargc) -#define origargv (curinterp->Iorigargv) -#define origfilename (curinterp->Iorigfilename) -#define ors (curinterp->Iors) -#define orslen (curinterp->Iorslen) -#define parsehook (curinterp->Iparsehook) -#define patchlevel (curinterp->Ipatchlevel) -#define perldb (curinterp->Iperldb) +#ifdef MULTIPLICITY + +#define Argv (curinterp->IArgv) +#define Cmd (curinterp->ICmd) +#define DBgv (curinterp->IDBgv) +#define DBline (curinterp->IDBline) +#define DBsignal (curinterp->IDBsignal) +#define DBsingle (curinterp->IDBsingle) +#define DBsub (curinterp->IDBsub) +#define DBtrace (curinterp->IDBtrace) +#define allgvs (curinterp->Iallgvs) +#define ampergv (curinterp->Iampergv) +#define argvgv (curinterp->Iargvgv) +#define argvoutgv (curinterp->Iargvoutgv) +#define basetime (curinterp->Ibasetime) +#define beginav (curinterp->Ibeginav) +#define bodytarget (curinterp->Ibodytarget) +#define cddir (curinterp->Icddir) +#define chopset (curinterp->Ichopset) +#define copline (curinterp->Icopline) +#define curblock (curinterp->Icurblock) +#define curcop (curinterp->Icurcop) +#define curcopdb (curinterp->Icurcopdb) +#define curcsv (curinterp->Icurcsv) +#define curpm (curinterp->Icurpm) +#define curstack (curinterp->Icurstack) +#define curstash (curinterp->Icurstash) +#define curstname (curinterp->Icurstname) +#define cxstack (curinterp->Icxstack) +#define cxstack_ix (curinterp->Icxstack_ix) +#define cxstack_max (curinterp->Icxstack_max) +#define dbargs (curinterp->Idbargs) +#define debdelim (curinterp->Idebdelim) +#define debname (curinterp->Idebname) +#define debstash (curinterp->Idebstash) +#define defgv (curinterp->Idefgv) +#define defoutgv (curinterp->Idefoutgv) +#define defstash (curinterp->Idefstash) +#define delaymagic (curinterp->Idelaymagic) +#define diehook (curinterp->Idiehook) +#define dirty (curinterp->Idirty) +#define dlevel (curinterp->Idlevel) +#define dlmax (curinterp->Idlmax) +#define doextract (curinterp->Idoextract) +#define doswitches (curinterp->Idoswitches) +#define dowarn (curinterp->Idowarn) +#define dumplvl (curinterp->Idumplvl) +#define e_fp (curinterp->Ie_fp) +#define e_tmpname (curinterp->Ie_tmpname) +#define endav (curinterp->Iendav) +#define envgv (curinterp->Ienvgv) +#define errgv (curinterp->Ierrgv) +#define eval_root (curinterp->Ieval_root) +#define eval_start (curinterp->Ieval_start) +#define fdpid (curinterp->Ifdpid) +#define filemode (curinterp->Ifilemode) +#define firstgv (curinterp->Ifirstgv) +#define forkprocess (curinterp->Iforkprocess) +#define formfeed (curinterp->Iformfeed) +#define formtarget (curinterp->Iformtarget) +#define gensym (curinterp->Igensym) +#define in_eval (curinterp->Iin_eval) +#define incgv (curinterp->Iincgv) +#define inplace (curinterp->Iinplace) +#define last_in_gv (curinterp->Ilast_in_gv) +#define lastfd (curinterp->Ilastfd) +#define lastretstr (curinterp->Ilastretstr) +#define lastscream (curinterp->Ilastscream) +#define lastsize (curinterp->Ilastsize) +#define lastspbase (curinterp->Ilastspbase) +#define laststatval (curinterp->Ilaststatval) +#define laststype (curinterp->Ilaststype) +#define leftgv (curinterp->Ileftgv) +#define lineary (curinterp->Ilineary) +#define localizing (curinterp->Ilocalizing) +#define localpatches (curinterp->Ilocalpatches) +#define main_cv (curinterp->Imain_cv) +#define main_root (curinterp->Imain_root) +#define main_start (curinterp->Imain_start) +#define mainstack (curinterp->Imainstack) +#define maxscream (curinterp->Imaxscream) +#define maxsysfd (curinterp->Imaxsysfd) +#define minus_F (curinterp->Iminus_F) +#define minus_a (curinterp->Iminus_a) +#define minus_c (curinterp->Iminus_c) +#define minus_l (curinterp->Iminus_l) +#define minus_n (curinterp->Iminus_n) +#define minus_p (curinterp->Iminus_p) +#define multiline (curinterp->Imultiline) +#define mystack_base (curinterp->Imystack_base) +#define mystack_mark (curinterp->Imystack_mark) +#define mystack_max (curinterp->Imystack_max) +#define mystack_sp (curinterp->Imystack_sp) +#define mystrk (curinterp->Imystrk) +#define nrs (curinterp->Inrs) +#define ofmt (curinterp->Iofmt) +#define ofs (curinterp->Iofs) +#define ofslen (curinterp->Iofslen) +#define oldlastpm (curinterp->Ioldlastpm) +#define oldname (curinterp->Ioldname) +#define op_mask (curinterp->Iop_mask) +#define origargc (curinterp->Iorigargc) +#define origargv (curinterp->Iorigargv) +#define origfilename (curinterp->Iorigfilename) +#define ors (curinterp->Iors) +#define orslen (curinterp->Iorslen) +#define parsehook (curinterp->Iparsehook) +#define patchlevel (curinterp->Ipatchlevel) #define perl_destruct_level (curinterp->Iperl_destruct_level) -#define pidstatus (curinterp->Ipidstatus) -#define preambled (curinterp->Ipreambled) -#define preambleav (curinterp->Ipreambleav) -#define preprocess (curinterp->Ipreprocess) -#define restartop (curinterp->Irestartop) -#define rightgv (curinterp->Irightgv) -#define rs (curinterp->Irs) -#define runlevel (curinterp->Irunlevel) -#define sawampersand (curinterp->Isawampersand) -#define sawi (curinterp->Isawi) -#define sawstudy (curinterp->Isawstudy) -#define sawvec (curinterp->Isawvec) -#define screamfirst (curinterp->Iscreamfirst) -#define screamnext (curinterp->Iscreamnext) -#define secondgv (curinterp->Isecondgv) -#define siggv (curinterp->Isiggv) -#define signalstack (curinterp->Isignalstack) -#define sortcop (curinterp->Isortcop) -#define sortstack (curinterp->Isortstack) -#define sortstash (curinterp->Isortstash) -#define splitstr (curinterp->Isplitstr) -#define statcache (curinterp->Istatcache) -#define statgv (curinterp->Istatgv) -#define statname (curinterp->Istatname) -#define statusvalue (curinterp->Istatusvalue) -#define stdingv (curinterp->Istdingv) -#define strchop (curinterp->Istrchop) -#define strtab (curinterp->Istrtab) -#define sv_count (curinterp->Isv_count) -#define sv_objcount (curinterp->Isv_objcount) -#define sv_root (curinterp->Isv_root) -#define sv_arenaroot (curinterp->Isv_arenaroot) -#define tainted (curinterp->Itainted) -#define tainting (curinterp->Itainting) -#define tmps_floor (curinterp->Itmps_floor) -#define tmps_ix (curinterp->Itmps_ix) -#define tmps_max (curinterp->Itmps_max) -#define tmps_stack (curinterp->Itmps_stack) -#define top_env (curinterp->Itop_env) -#define toptarget (curinterp->Itoptarget) -#define unsafe (curinterp->Iunsafe) -#define warnhook (curinterp->Iwarnhook) +#define perldb (curinterp->Iperldb) +#define preambleav (curinterp->Ipreambleav) +#define preambled (curinterp->Ipreambled) +#define preprocess (curinterp->Ipreprocess) +#define restartop (curinterp->Irestartop) +#define rightgv (curinterp->Irightgv) +#define rs (curinterp->Irs) +#define runlevel (curinterp->Irunlevel) +#define sawampersand (curinterp->Isawampersand) +#define sawstudy (curinterp->Isawstudy) +#define sawvec (curinterp->Isawvec) +#define screamfirst (curinterp->Iscreamfirst) +#define screamnext (curinterp->Iscreamnext) +#define secondgv (curinterp->Isecondgv) +#define siggv (curinterp->Isiggv) +#define signalstack (curinterp->Isignalstack) +#define sortcop (curinterp->Isortcop) +#define sortstack (curinterp->Isortstack) +#define sortstash (curinterp->Isortstash) +#define splitstr (curinterp->Isplitstr) +#define statcache (curinterp->Istatcache) +#define statgv (curinterp->Istatgv) +#define statname (curinterp->Istatname) +#define statusvalue (curinterp->Istatusvalue) +#define stdingv (curinterp->Istdingv) +#define strchop (curinterp->Istrchop) +#define strtab (curinterp->Istrtab) +#define sv_arenaroot (curinterp->Isv_arenaroot) +#define sv_count (curinterp->Isv_count) +#define sv_objcount (curinterp->Isv_objcount) +#define sv_root (curinterp->Isv_root) +#define tainted (curinterp->Itainted) +#define tainting (curinterp->Itainting) +#define tmps_floor (curinterp->Itmps_floor) +#define tmps_ix (curinterp->Itmps_ix) +#define tmps_max (curinterp->Itmps_max) +#define tmps_stack (curinterp->Itmps_stack) +#define top_env (curinterp->Itop_env) +#define toptarget (curinterp->Itoptarget) +#define unsafe (curinterp->Iunsafe) +#define warnhook (curinterp->Iwarnhook) -#else /* not multiple, so translate interpreter symbols the other way... */ +#else /* !MULTIPLICITY */ -#define IArgv Argv -#define ICmd Cmd -#define IDBgv DBgv -#define IDBline DBline -#define IDBsignal DBsignal -#define IDBsingle DBsingle -#define IDBsub DBsub -#define IDBtrace DBtrace -#define Iallgvs allgvs -#define Iampergv ampergv -#define Iargvgv argvgv -#define Iargvoutgv argvoutgv -#define Ibasetime basetime -#define Ibeginav beginav -#define Ibodytarget bodytarget -#define Icddir cddir -#define Ichopset chopset -#define Icopline copline -#define Icurblock curblock -#define Icurcop curcop -#define Icurcopdb curcopdb -#define Icurcsv curcsv -#define Icurpm curpm -#define Icurstack curstack -#define Icurstash curstash -#define Icurstname curstname -#define Icxstack cxstack -#define Icxstack_ix cxstack_ix -#define Icxstack_max cxstack_max -#define Idbargs dbargs -#define Idebdelim debdelim -#define Idebname debname -#define Idebstash debstash -#define Idefgv defgv -#define Idefoutgv defoutgv -#define Idefstash defstash -#define Idelaymagic delaymagic -#define Idiehook diehook -#define Idirty dirty -#define Idlevel dlevel -#define Idlmax dlmax -#define Idoextract doextract -#define Idoswitches doswitches -#define Idowarn dowarn -#define Idumplvl dumplvl -#define Ie_fp e_fp -#define Ie_tmpname e_tmpname -#define Iendav endav -#define Ienvgv envgv -#define Ierrgv errgv -#define Ieval_root eval_root -#define Ieval_start eval_start -#define Ifdpid fdpid -#define Ifilemode filemode -#define Ifirstgv firstgv -#define Iforkprocess forkprocess -#define Iformfeed formfeed -#define Iformtarget formtarget -#define Igensym gensym -#define Iin_eval in_eval -#define Iincgv incgv -#define Iinplace inplace -#define Ilast_in_gv last_in_gv -#define Ilastfd lastfd -#define Ilastretstr lastretstr -#define Ilastscream lastscream -#define Ilastsize lastsize -#define Ilastspbase lastspbase -#define Ilaststatval laststatval -#define Ilaststype laststype -#define Ileftgv leftgv -#define Ilineary lineary -#define Ilocalizing localizing -#define Ilocalpatches localpatches -#define Imain_cv main_cv -#define Imain_root main_root -#define Imain_start main_start -#define Imainstack mainstack -#define Imaxscream maxscream -#define Imaxsysfd maxsysfd -#define Iminus_F minus_F -#define Iminus_a minus_a -#define Iminus_c minus_c -#define Iminus_l minus_l -#define Iminus_n minus_n -#define Iminus_p minus_p -#define Imultiline multiline -#define Imystack_base mystack_base -#define Imystack_mark mystack_mark -#define Imystack_max mystack_max -#define Imystack_sp mystack_sp -#define Imystrk mystrk -#define Inrs nrs -#define Iofmt ofmt -#define Iofs ofs -#define Iofslen ofslen -#define Ioldlastpm oldlastpm -#define Ioldname oldname -#define Iop_mask op_mask -#define Iorigargc origargc -#define Iorigargv origargv -#define Iorigfilename origfilename -#define Iors ors -#define Iorslen orslen -#define Iparsehook parsehook -#define Ipatchlevel patchlevel -#define Iperldb perldb +#define IArgv Argv +#define ICmd Cmd +#define IDBgv DBgv +#define IDBline DBline +#define IDBsignal DBsignal +#define IDBsingle DBsingle +#define IDBsub DBsub +#define IDBtrace DBtrace +#define Iallgvs allgvs +#define Iampergv ampergv +#define Iargvgv argvgv +#define Iargvoutgv argvoutgv +#define Ibasetime basetime +#define Ibeginav beginav +#define Ibodytarget bodytarget +#define Icddir cddir +#define Ichopset chopset +#define Icopline copline +#define Icurblock curblock +#define Icurcop curcop +#define Icurcopdb curcopdb +#define Icurcsv curcsv +#define Icurpm curpm +#define Icurstack curstack +#define Icurstash curstash +#define Icurstname curstname +#define Icxstack cxstack +#define Icxstack_ix cxstack_ix +#define Icxstack_max cxstack_max +#define Idbargs dbargs +#define Idebdelim debdelim +#define Idebname debname +#define Idebstash debstash +#define Idefgv defgv +#define Idefoutgv defoutgv +#define Idefstash defstash +#define Idelaymagic delaymagic +#define Idiehook diehook +#define Idirty dirty +#define Idlevel dlevel +#define Idlmax dlmax +#define Idoextract doextract +#define Idoswitches doswitches +#define Idowarn dowarn +#define Idumplvl dumplvl +#define Ie_fp e_fp +#define Ie_tmpname e_tmpname +#define Iendav endav +#define Ienvgv envgv +#define Ierrgv errgv +#define Ieval_root eval_root +#define Ieval_start eval_start +#define Ifdpid fdpid +#define Ifilemode filemode +#define Ifirstgv firstgv +#define Iforkprocess forkprocess +#define Iformfeed formfeed +#define Iformtarget formtarget +#define Igensym gensym +#define Iin_eval in_eval +#define Iincgv incgv +#define Iinplace inplace +#define Ilast_in_gv last_in_gv +#define Ilastfd lastfd +#define Ilastretstr lastretstr +#define Ilastscream lastscream +#define Ilastsize lastsize +#define Ilastspbase lastspbase +#define Ilaststatval laststatval +#define Ilaststype laststype +#define Ileftgv leftgv +#define Ilineary lineary +#define Ilocalizing localizing +#define Ilocalpatches localpatches +#define Imain_cv main_cv +#define Imain_root main_root +#define Imain_start main_start +#define Imainstack mainstack +#define Imaxscream maxscream +#define Imaxsysfd maxsysfd +#define Iminus_F minus_F +#define Iminus_a minus_a +#define Iminus_c minus_c +#define Iminus_l minus_l +#define Iminus_n minus_n +#define Iminus_p minus_p +#define Imultiline multiline +#define Imystack_base mystack_base +#define Imystack_mark mystack_mark +#define Imystack_max mystack_max +#define Imystack_sp mystack_sp +#define Imystrk mystrk +#define Inrs nrs +#define Iofmt ofmt +#define Iofs ofs +#define Iofslen ofslen +#define Ioldlastpm oldlastpm +#define Ioldname oldname +#define Iop_mask op_mask +#define Iorigargc origargc +#define Iorigargv origargv +#define Iorigfilename origfilename +#define Iors ors +#define Iorslen orslen +#define Iparsehook parsehook +#define Ipatchlevel patchlevel #define Iperl_destruct_level perl_destruct_level -#define Ipidstatus pidstatus -#define Ipreambled preambled -#define Ipreambleav preambleav -#define Ipreprocess preprocess -#define Irestartop restartop -#define Irightgv rightgv -#define Irs rs -#define Irunlevel runlevel -#define Isawampersand sawampersand -#define Isawi sawi -#define Isawstudy sawstudy -#define Isawvec sawvec -#define Iscreamfirst screamfirst -#define Iscreamnext screamnext -#define Isecondgv secondgv -#define Isiggv siggv -#define Isignalstack signalstack -#define Isortcop sortcop -#define Isortstack sortstack -#define Isortstash sortstash -#define Isplitstr splitstr -#define Istatcache statcache -#define Istatgv statgv -#define Istatname statname -#define Istatusvalue statusvalue -#define Istdingv stdingv -#define Istrchop strchop -#define Istrtab strtab -#define Isv_count sv_count -#define Isv_objcount sv_objcount -#define Isv_root sv_root -#define Isv_arenaroot sv_arenaroot -#define Itainted tainted -#define Itainting tainting -#define Itmps_floor tmps_floor -#define Itmps_ix tmps_ix -#define Itmps_max tmps_max -#define Itmps_stack tmps_stack -#define Itop_env top_env -#define Itoptarget toptarget -#define Iunsafe unsafe -#define Iwarnhook warnhook +#define Iperldb perldb +#define Ipreambleav preambleav +#define Ipreambled preambled +#define Ipreprocess preprocess +#define Irestartop restartop +#define Irightgv rightgv +#define Irs rs +#define Irunlevel runlevel +#define Isawampersand sawampersand +#define Isawstudy sawstudy +#define Isawvec sawvec +#define Iscreamfirst screamfirst +#define Iscreamnext screamnext +#define Isecondgv secondgv +#define Isiggv siggv +#define Isignalstack signalstack +#define Isortcop sortcop +#define Isortstack sortstack +#define Isortstash sortstash +#define Isplitstr splitstr +#define Istatcache statcache +#define Istatgv statgv +#define Istatname statname +#define Istatusvalue statusvalue +#define Istdingv stdingv +#define Istrchop strchop +#define Istrtab strtab +#define Isv_arenaroot sv_arenaroot +#define Isv_count sv_count +#define Isv_objcount sv_objcount +#define Isv_root sv_root +#define Itainted tainted +#define Itainting tainting +#define Itmps_floor tmps_floor +#define Itmps_ix tmps_ix +#define Itmps_max tmps_max +#define Itmps_stack tmps_stack +#define Itop_env top_env +#define Itoptarget toptarget +#define Iunsafe unsafe +#define Iwarnhook warnhook + +/* Hide interpreter-specific symbols? */ + +#ifdef EMBED + +#define curcop Perl_curcop +#define curcopdb Perl_curcopdb +#define envgv Perl_envgv +#define siggv Perl_siggv +#define tainting Perl_tainting + +/* Hide interpreter symbols that 5.003 revealed? */ + +#ifndef BINCOMPAT3 + +#define Argv Perl_Argv +#define Cmd Perl_Cmd +#define DBgv Perl_DBgv +#define DBline Perl_DBline +#define DBsignal Perl_DBsignal +#define DBsingle Perl_DBsingle +#define DBsub Perl_DBsub +#define DBtrace Perl_DBtrace +#define allgvs Perl_allgvs +#define ampergv Perl_ampergv +#define argvgv Perl_argvgv +#define argvoutgv Perl_argvoutgv +#define basetime Perl_basetime +#define beginav Perl_beginav +#define bodytarget Perl_bodytarget +#define cddir Perl_cddir +#define chopset Perl_chopset +#define copline Perl_copline +#define curblock Perl_curblock +#define curcsv Perl_curcsv +#define curpm Perl_curpm +#define curstack Perl_curstack +#define curstash Perl_curstash +#define curstname Perl_curstname +#define cxstack Perl_cxstack +#define cxstack_ix Perl_cxstack_ix +#define cxstack_max Perl_cxstack_max +#define dbargs Perl_dbargs +#define debdelim Perl_debdelim +#define debname Perl_debname +#define debstash Perl_debstash +#define defgv Perl_defgv +#define defoutgv Perl_defoutgv +#define defstash Perl_defstash +#define delaymagic Perl_delaymagic +#define diehook Perl_diehook +#define dirty Perl_dirty +#define dlevel Perl_dlevel +#define dlmax Perl_dlmax +#define doextract Perl_doextract +#define doswitches Perl_doswitches +#define dowarn Perl_dowarn +#define dumplvl Perl_dumplvl +#define e_fp Perl_e_fp +#define e_tmpname Perl_e_tmpname +#define endav Perl_endav +#define errgv Perl_errgv +#define eval_root Perl_eval_root +#define eval_start Perl_eval_start +#define fdpid Perl_fdpid +#define filemode Perl_filemode +#define firstgv Perl_firstgv +#define forkprocess Perl_forkprocess +#define formfeed Perl_formfeed +#define formtarget Perl_formtarget +#define gensym Perl_gensym +#define in_eval Perl_in_eval +#define incgv Perl_incgv +#define inplace Perl_inplace +#define last_in_gv Perl_last_in_gv +#define lastfd Perl_lastfd +#define lastretstr Perl_lastretstr +#define lastscream Perl_lastscream +#define lastsize Perl_lastsize +#define lastspbase Perl_lastspbase +#define laststatval Perl_laststatval +#define laststype Perl_laststype +#define leftgv Perl_leftgv +#define lineary Perl_lineary +#define localizing Perl_localizing +#define localpatches Perl_localpatches +#define main_cv Perl_main_cv +#define main_root Perl_main_root +#define main_start Perl_main_start +#define mainstack Perl_mainstack +#define maxscream Perl_maxscream +#define maxsysfd Perl_maxsysfd +#define minus_F Perl_minus_F +#define minus_a Perl_minus_a +#define minus_c Perl_minus_c +#define minus_l Perl_minus_l +#define minus_n Perl_minus_n +#define minus_p Perl_minus_p +#define multiline Perl_multiline +#define mystack_base Perl_mystack_base +#define mystack_mark Perl_mystack_mark +#define mystack_max Perl_mystack_max +#define mystack_sp Perl_mystack_sp +#define mystrk Perl_mystrk +#define nrs Perl_nrs +#define ofmt Perl_ofmt +#define ofs Perl_ofs +#define ofslen Perl_ofslen +#define oldlastpm Perl_oldlastpm +#define oldname Perl_oldname +#define op_mask Perl_op_mask +#define origargc Perl_origargc +#define origargv Perl_origargv +#define origfilename Perl_origfilename +#define ors Perl_ors +#define orslen Perl_orslen +#define parsehook Perl_parsehook +#define patchlevel Perl_patchlevel +#define perl_destruct_level Perl_perl_destruct_level +#define perldb Perl_perldb +#define preambleav Perl_preambleav +#define preambled Perl_preambled +#define preprocess Perl_preprocess +#define restartop Perl_restartop +#define rightgv Perl_rightgv +#define rs Perl_rs +#define runlevel Perl_runlevel +#define sawampersand Perl_sawampersand +#define sawstudy Perl_sawstudy +#define sawvec Perl_sawvec +#define screamfirst Perl_screamfirst +#define screamnext Perl_screamnext +#define secondgv Perl_secondgv +#define signalstack Perl_signalstack +#define sortcop Perl_sortcop +#define sortstack Perl_sortstack +#define sortstash Perl_sortstash +#define splitstr Perl_splitstr +#define statcache Perl_statcache +#define statgv Perl_statgv +#define statname Perl_statname +#define statusvalue Perl_statusvalue +#define stdingv Perl_stdingv +#define strchop Perl_strchop +#define strtab Perl_strtab +#define sv_arenaroot Perl_sv_arenaroot +#define sv_count Perl_sv_count +#define sv_objcount Perl_sv_objcount +#define sv_root Perl_sv_root +#define tainted Perl_tainted +#define tmps_floor Perl_tmps_floor +#define tmps_ix Perl_tmps_ix +#define tmps_max Perl_tmps_max +#define tmps_stack Perl_tmps_stack +#define top_env Perl_top_env +#define toptarget Perl_toptarget +#define unsafe Perl_unsafe +#define warnhook Perl_warnhook + +#endif /* !BINCOMPAT3 */ + +#endif /* EMBED */ #endif /* MULTIPLICITY */ @@ -1,11 +1,52 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w -open(EM, ">embed.h") || die "Can't create embed.h: $!\n"; +require 5.003; + +sub readsyms (\%$) { + my ($syms, $file) = @_; + %$syms = (); + local (*FILE, $_); + open(FILE, "< $file") + or die "embed.pl: Can't open $file: $!\n"; + while (<FILE>) { + s/[ \t]*#.*//; # Delete comments. + if (/^\s*(\S+)\s*$/) { + $$syms{$1} = 1; + } + } + close(FILE); +} + +readsyms %global, 'global.sym'; +readsyms %interp, 'interp.sym'; +readsyms %compat3, 'compat3.sym'; + +sub hide ($$) { + my ($from, $to) = @_; + my $t = int(length($from) / 8); + "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n"; +} +sub embed ($) { + my ($sym) = @_; + hide($sym, "Perl_$sym"); +} +sub multon ($) { + my ($sym) = @_; + hide($sym, "(curinterp->I$sym)"); +} +sub multoff ($) { + my ($sym) = @_; + hide("I$sym", $sym); +} + +unlink 'embed.h'; +open(EM, '> embed.h') + or die "Can't create embed.h: $!\n"; print EM <<'END'; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file is built by embed.pl from global.sym and interp.sym. - Any changes made here will be lost + This file is built by embed.pl from global.sym, interp.sym, + and compat3.sym. Any changes made here will be lost! */ /* (Doing namespace management portably in C is really gross.) */ @@ -20,76 +61,84 @@ print EM <<'END'; # define EMBED 1 #endif +/* Hide global symbols? */ + #ifdef EMBED -/* globals we need to hide from the world */ END -open(GL, "<global.sym") || die "Can't open global.sym: $!\n"; - -while(<GL>) { - s/[ \t]*#.*//; # Delete comments. - next unless /\S/; - s/^\s*(\S+).*$/#define $1\t\tPerl_$1/; - $global{$1} = 1; - s/(................\t)\t/$1/; - print EM $_; +for $sym (sort keys %global) { + print EM embed($sym) unless $compat3{$sym}; } -close(GL) || warn "Can't close global.sym: $!\n"; +print EM <<'END'; + +/* Hide global symbols that 5.003 revealed? */ + +#ifndef BINCOMPAT3 + +END + +for $sym (sort keys %global) { + print EM embed($sym) if $compat3{$sym}; +} print EM <<'END'; +#endif /* !BINCOMPAT3 */ + #endif /* EMBED */ -/* Put interpreter specific symbols into a struct? */ +/* Put interpreter-specific symbols into a struct? */ #ifdef MULTIPLICITY -/* Undefine symbols that were defined by EMBED. Somewhat ugly */ - END +for $sym (sort keys %interp) { + print EM multon($sym); +} -open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; -while (<INT>) { - s/[ \t]*#.*//; # Delete comments. - next unless /\S/; - s/^\s*(\S*).*$/#undef $1/; - print EM $_ if (exists $global{$1}); +print EM <<'END'; + +#else /* !MULTIPLICITY */ + +END + +for $sym (sort keys %interp) { + print EM multoff($sym); } -close(INT) || warn "Can't close interp.sym: $!\n"; -print EM "\n"; +print EM <<'END'; -open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; -while (<INT>) { - s/[ \t]*#.*//; # Delete comments. - next unless /\S/; - s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; - s/(................\t)\t/$1/; - print EM $_; +/* Hide interpreter-specific symbols? */ + +#ifdef EMBED + +END + +for $sym (sort keys %interp) { + print EM embed($sym) if $compat3{$sym}; } -close(INT) || warn "Can't close interp.sym: $!\n"; print EM <<'END'; -#else /* not multiple, so translate interpreter symbols the other way... */ +/* Hide interpreter symbols that 5.003 revealed? */ + +#ifndef BINCOMPAT3 END -open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; -while (<INT>) { - s/[ \t]*#.*//; # Delete comments. - next unless /\S/; - s/^\s*(\S+).*$/#define I$1\t\t$1/; - s/(................\t)\t/$1/; - print EM $_; +for $sym (sort keys %interp) { + print EM embed($sym) unless $compat3{$sym}; } -close(INT) || warn "Can't close interp.sym: $!\n"; print EM <<'END'; +#endif /* !BINCOMPAT3 */ + +#endif /* EMBED */ + #endif /* MULTIPLICITY */ END diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 8f3dd96fa5..ff746cf0f8 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,11 +1,18 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 4th Sept 1996 -# version 1.03 +# last modified 14th Jan 1997 +# version 1.10 +# +# Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + package DB_File::HASHINFO ; +require 5.003 ; + use strict; use Carp; require Tie::Hash; @@ -19,25 +26,25 @@ sub new bless \%x, $pkg ; } + sub TIEHASH { my $pkg = shift ; - bless { 'bsize' => undef, - 'ffactor' => undef, - 'nelem' => undef, - 'cachesize' => undef, - 'hash' => undef, - 'lorder' => undef, - }, $pkg ; + bless { VALID => { map {$_, 1} + qw( bsize ffactor nelem cachesize hash lorder) + }, + GOT => {} + }, $pkg ; } + sub FETCH { my $self = shift ; my $key = shift ; - return $self->{$key} if exists $self->{$key} ; + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; my $pkg = ref $self ; croak "${pkg}::FETCH - Unknown element '$key'" ; @@ -50,9 +57,9 @@ sub STORE my $key = shift ; my $value = shift ; - if ( exists $self->{$key} ) + if ( exists $self->{VALID}{$key} ) { - $self->{$key} = $value ; + $self->{GOT}{$key} = $value ; return ; } @@ -65,9 +72,9 @@ sub DELETE my $self = shift ; my $key = shift ; - if ( exists $self->{$key} ) + if ( exists $self->{VALID}{$key} ) { - delete $self->{$key} ; + delete $self->{GOT}{$key} ; return ; } @@ -80,21 +87,21 @@ sub EXISTS my $self = shift ; my $key = shift ; - exists $self->{$key} ; + exists $self->{VALID}{$key} ; } sub NotHere { - my $pkg = shift ; + my $self = shift ; my $method = shift ; - croak "${pkg} does not define the method ${method}" ; + croak ref($self) . " does not define the method ${method}" ; } sub DESTROY { undef %{$_[0]} } -sub FIRSTKEY { my $self = shift ; $self->NotHere(ref $self, "FIRSTKEY") } -sub NEXTKEY { my $self = shift ; $self->NotHere(ref $self, "NEXTKEY") } -sub CLEAR { my $self = shift ; $self->NotHere(ref $self, "CLEAR") } +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; @@ -106,14 +113,11 @@ sub TIEHASH { my $pkg = shift ; - bless { 'bval' => undef, - 'cachesize' => undef, - 'psize' => undef, - 'flags' => undef, - 'lorder' => undef, - 'reclen' => undef, - 'bfname' => "", - }, $pkg ; + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; } package DB_File::BTREEINFO ; @@ -126,15 +130,12 @@ sub TIEHASH { my $pkg = shift ; - bless { 'flags' => undef, - 'cachesize' => undef, - 'maxkeypage' => undef, - 'minkeypage' => undef, - 'psize' => undef, - 'compare' => undef, - 'prefix' => undef, - 'lorder' => undef, - }, $pkg ; + bless { VALID => { map {$_, 1} + qw( flags cachesize maxkeypage minkeypage psize + compare prefix lorder ) + }, + GOT => {}, + }, $pkg ; } @@ -145,13 +146,9 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ; use Carp; -$VERSION = "1.03" ; +$VERSION = "1.10" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; -#$DB_BTREE = TIEHASH DB_File::BTREEINFO ; -#$DB_HASH = TIEHASH DB_File::HASHINFO ; -#$DB_RECNO = TIEHASH DB_File::RECNOINFO ; - $DB_BTREE = new DB_File::BTREEINFO ; $DB_HASH = new DB_File::HASHINFO ; $DB_RECNO = new DB_File::RECNOINFO ; @@ -220,10 +217,10 @@ sub AUTOLOAD { sub import { my $pkg = shift; my $callpkg = caller; - Exporter::export $pkg, $callpkg; + Exporter::export $pkg, $callpkg, @_; eval { require Fcntl; - Exporter::export 'Fcntl', $callpkg; + Exporter::export 'Fcntl', $callpkg, '/^O_/'; }; } @@ -232,6 +229,17 @@ bootstrap DB_File $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. +sub TIEHASH +{ + my (@arg) = @_ ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + DoTie_(@arg) ; +} + +*TIEARRAY = \&TIEHASH ; sub get_dup { @@ -249,9 +257,6 @@ sub get_dup my $counter = 0 ; my $status = 0 ; - # get the first value associated with the key, $key - #$db->seq($key, $value, R_CURSOR()) ; - # iterate through the database until either EOF ($status == 0) # or a different key is encountered ($key ne $origkey). for ($status = $db->seq($key, $value, R_CURSOR()) ; @@ -286,7 +291,6 @@ DB_File - Perl5 access to Berkeley DB =head1 SYNOPSIS use DB_File ; - use strict 'untie' ; [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; @@ -455,7 +459,7 @@ values when you only want to change one. Here is an example: $a->{'cachesize'} = 12345 ; tie %y, 'DB_File', "filename", $flags, 0777, $a ; -A few of the values need extra discussion here. When used, the C +A few of the options need extra discussion here. When used, the C equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers to C functions. In B<DB_File> these keys are used to store references to Perl subs. Below are templates for each of the subs: @@ -490,6 +494,9 @@ to Perl subs. Below are templates for each of the subs: See L<Changing the BTREE sort order> for an example of using the C<compare> template. +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The bval option>. + =head2 Default Parameters It is possible to omit some or all of the final 4 parameters in the @@ -500,7 +507,7 @@ common file format used, the call: is equivalent to: - tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0640, $DB_HASH ; + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; It is also possible to omit the filename parameter as well, so the call: @@ -509,7 +516,7 @@ call: is equivalent to: - tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0640, $DB_HASH ; + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; See L<In Memory Databases> for a discussion on the use of C<undef> in place of a filename. @@ -532,8 +539,9 @@ This example shows how to create a database, add key/value pairs to the database, delete keys/value pairs and finally how to enumerate the contents of the database. + use strict ; use DB_File ; - use strict 'untie' ; + use vars qw( %h $k $v ) ; tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH or die "Cannot open file 'fruit': $!\n"; @@ -580,8 +588,10 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use strict ; use DB_File ; - use strict 'untie' ; + + my %h ; sub Compare { @@ -645,9 +655,11 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use strict ; use DB_File ; - use strict 'untie' ; - + + use vars qw($filename %h ) ; + $filename = "tree" ; unlink $filename ; @@ -697,9 +709,11 @@ and the API in general. Here is the script above rewritten using the C<seq> API method. + use strict ; use DB_File ; - use strict 'untie' ; + use vars qw($filename $x %h $status $key $value) ; + $filename = "tree" ; unlink $filename ; @@ -718,6 +732,7 @@ Here is the script above rewritten using the C<seq> API method. # iterate through the btree using seq # and print each key/value pair. + $key = $value = 0 ; for ($status = $x->seq($key, $value, R_FIRST) ; $status == 0 ; $status = $x->seq($key, $value, R_NEXT) ) @@ -762,14 +777,14 @@ value occurred in the BTREE. So assuming the database created above, we can use C<get_dup> like this: - $cnt = $x->get_dup("Wall") ; + my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; - %hash = $x->get_dup("Wall", 1) ; + my %hash = $x->get_dup("Wall", 1) ; print "Larry is there\n" if $hash{'Larry'} ; print "There are $hash{'Brick'} Brick Walls\n" ; - @list = $x->get_dup("Wall") ; + my @list = $x->get_dup("Wall") ; print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; @@ -799,24 +814,24 @@ is used along with the R_CURSOR flag. Here is the relevant quote from the dbopen man page where it defines the use of the R_CURSOR flag with seq: - Note, for the DB_BTREE access method, the returned key is not necessarily an exact match for the specified key. The returned key is the smallest key greater than or equal to the specified key, permitting partial key matches and range searches. - In the example script below, the C<match> sub uses this feature to find and print the first matching key/value pair given a partial key. + use strict ; use DB_File ; use Fcntl ; - use strict 'untie' ; + + use vars qw($filename $x %h $st $key $value) ; sub match { my $key = shift ; - my $value ; + my $value = 0; my $orig_key = $key ; $x->seq($key, $value, R_CURSOR) ; print "$orig_key\t-> $key\t-> $value\n" ; @@ -835,6 +850,7 @@ and print the first matching key/value pair given a partial key. $h{'Smith'} = 'John' ; + $key = $value = 0 ; print "IN ORDER\n" ; for ($st = $x->seq($key, $value, R_FIRST) ; $st == 0 ; @@ -877,13 +893,41 @@ negative indexes. The index -1 refers to the last element of the array, -2 the second last, and so on. Attempting to access an element before the start of the array will raise a fatal run-time error. +=head2 The bval option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + =head2 A Simple Example Here is a simple example that uses RECNO. + use strict ; use DB_File ; - use strict 'untie' ; + my @h ; tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO or die "Cannot open file 'text': $!\n" ; @@ -1007,7 +1051,7 @@ L<THE API INTERFACE>). # same again, but use the API functions instead print "\nREVERSE again\n" ; - my ($s, $k, $v) ; + my ($s, $k, $v) = (0, 0, 0) ; for ($s = $H->seq($k, $v, R_LAST) ; $s == 0 ; $s = $H->seq($k, $v, R_PREV)) @@ -1091,7 +1135,7 @@ as B<DB_File> methods directly like this: B<Important:> If you have saved a copy of the object returned from C<tie>, the underlying database file will I<not> be closed until both the tied variable is untied and all copies of the saved object are -destroyed. See L<The strict untie pragma> for more details. +destroyed. use DB_File ; $db = tie %hash, "DB_File", "filename" @@ -1227,101 +1271,6 @@ R_RECNOSYNC is the only valid flag at present. =head1 HINTS AND TIPS -=head2 The strict untie pragma - -If you run Perl version 5.004 or later (actually any version from the -5.003_01 development release on will suffice) and you make use of the -Berkeley DB API, it is is I<very> strongly recommended that you always -include the C<use strict 'untie'> pragma in any of your scripts that -make use of B<DB_File>. - -Even if you don't currently make use of the API interface, it is still -a good idea to include the pragma. It won't affect the performance of -your script, but it will prevent problems in the future. - -If possible you should try to run with the full strict pragma, but that -is another story. For further details see L<strict> and -L<perldsc/WHY YOU SHOULD ALWAYS C<use strict>>. - -To illustrate the importance of including the untie pragma, here is an -example script that fails in an unexpected place because it doesn't use -it: - - use DB_File ; - use Fcntl ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie first time: $!" ; - - $x{123} = 456 ; - - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie second time: $!" ; - - untie %x ; - -When run the script will produce this error message: - - Cannot tie second time: Invalid argument at bad.file line 12. - -Although the error message above refers to the second tie statement in -the script, the source of the problem is really with the untie -statement that precedes it. - -To understand why there is a problem at all with the untie statement, -consider what the tie does for a moment. - -Whenever the tie is executed, it creates a logical link between a Perl -variable, the associative array C<%x> in this case, and a Berkeley DB -database, C<tst.fil>. The logical link ensures that all operation on -the associative array are automatically mirrored to the database file. - -In normal circumstances the untie is enough to break the logical link -and also close the database. In this particular case there is another -logical link, namely the API object returned from the tie and stored in -C<$X>. Whenever the untie is executed in this case, only the link -between the associative array and the database will be broken. The API -object in C<$X> is still valid, so the database will not be closed. - -The end result of this is that when the second tie is executed, the -database will be in an inconsistent state (i.e. it is still opened by -the first tie) - thus the second tie will fail. - -If the C<use strict 'untie'> pragma is included in the script, like -this: - - use DB_File ; - use Fcntl ; - use strict 'untie' ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie first time: $!" ; - - $x{123} = 456 ; - - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie second time: $!" ; - -then the error message becomes: - - Can't untie: 1 inner references still exist at bad.file line 11. - -which pinpoints the real problem. Finally the script can now be -modified to fix the original problem by destroying the API object -before the untie: - - ... - $x{123} = 456 ; - - undef $X ; - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - ... =head2 Locking Databases @@ -1331,7 +1280,6 @@ uses the I<fd> method to get the file descriptor, and then a careful open() to give something Perl will flock() for you. Run this repeatedly in the background to watch the locks granted in proper order. - use strict 'untie'; use DB_File; use strict; @@ -1374,7 +1322,7 @@ in the background to watch the locks granted in proper order. print "$$: Write lock granted\n"; $db{$key} = $value; - $db->sync; + $db->sync; # to flush sleep 10; flock(DB_FH, LOCK_UN); @@ -1406,10 +1354,11 @@ Here is a snippet of code that is loosely based on Tom Christiansen's I<ggh> script (available from your nearest CPAN archive in F<authors/id/TOMC/scripts/nshist.gz>). + use strict ; use DB_File ; use Fcntl ; - use strict 'untie' ; + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; $dotdir = $ENV{HOME} || $ENV{LOGNAME}; $HISTORY = "$dotdir/.netscape/history.db"; @@ -1480,8 +1429,7 @@ Here are a couple of possibilities: =item 1. -Attempting to reopen a database without closing it. See -L<The strict untie pragma> for an example. +Attempting to reopen a database without closing it. =item 2. @@ -1577,6 +1525,52 @@ The standard hash function C<exists> is now supported. Modified the behavior of get_dup. When it returns an associative array, the value is the count of the number of matching BTREE values. +=item 1.04 + +Minor documentation changes. + +Fixed a bug in hash_cb. Patches supplied by Dave Hammen, +E<lt>hammen@gothamcity.jsc.nasa.govE<gt>. + +Fixed a bug with the constructors for DB_File::HASHINFO, +DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the +constructors to make them C<-w> clean. + +Reworked part of the test harness to be more locale friendly. + +=item 1.05 + +Made all scripts in the documentation C<strict> and C<-w> clean. + +Added logic to F<DB_File.xs> to allow the module to be built after Perl +is installed. + +=item 1.06 + +Minor namespace cleanup: Localized C<PrintBtree>. + +=item 1.07 + +Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +=item 1.08 + +Documented operation of bval. + +=item 1.09 + +Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and +DB_File::BTREEINFO. + +Changed default mode to 0666. + +=item 1.10 + +Fixed fd method so that it still returns -1 for in-memory files when db +1.86 is used. + +=back + =head1 BUGS Some older versions of Berkeley DB had problems with fixed length @@ -1593,13 +1587,33 @@ the directory F<ext/DB_File>. Berkeley DB is available at your nearest CPAN archive (see L<perlmod/"CPAN"> for a list) in F<src/misc/db.1.85.tar.gz>, or via the -host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. It is I<not> under -the GPL. +host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. Alternatively, +check out the Berkeley DB home page at F<http://www.bostic.com/db>. It +is I<not> under the GPL. If you are running IRIX, then get Berkeley DB from F<http://reality.sgi.com/ariel>. It has the patches necessary to compile properly on IRIX 5.3. +As of January 1997, version 1.86 of Berkeley DB is available from the +Berkeley DB home page. Although this release does fix a number of bugs +that were present in 1.85 you should ba aware of the following +information (taken from the Berkeley DB home page) before you consider +using it: + + DB version 1.86 includes a new implementation of the hash access + method that fixes a variety of hashing problems found in DB version + 1.85. We are making it available as an interim solution until DB + 2.0 is available. + + PLEASE NOTE: the underlying file format for the hash access method + changed between version 1.85 and version 1.86, so you will have to + dump and reload all of your databases to convert from version 1.85 + to version 1.86. If you do not absolutely require the fixes from + version 1.86, we strongly urge you to wait until DB 2.0 is released + before upgrading from 1.85. + + =head1 SEE ALSO L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index aecfb0c40d..a938ffb09d 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,11 +3,15 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 4th Sept 1996 - version 1.03 + last modified 14th Jan 1997 + version 1.10 All comments/suggestions/problems are welcome + Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + Changes: 0.1 - Initial Release 0.2 - No longer bombs out if dbopen returns an error. @@ -23,6 +27,16 @@ Allow negative subscripts with RECNO interface. Changed the default flags to O_CREAT|O_RDWR 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. */ @@ -34,25 +48,41 @@ #include <fcntl.h> +#ifdef mDB_Prefix_t +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t mDB_Hash_t +#endif + +union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } ; + typedef struct { DBTYPE type ; DB * dbp ; SV * compare ; SV * prefix ; SV * hash ; + int in_memory ; + union INFO info ; } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; -union INFO { - HASHINFO hash ; - RECNOINFO recno ; - BTREEINFO btree ; - } ; - -/* #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) @@ -61,7 +91,9 @@ union INFO { #define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) -#define db_fd(db) ((db->dbp)->fd)(db->dbp) +#define db_fd(db) (db->in_memory \ + ? -1 \ + : ((db->dbp)->fd)(db->dbp) ) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags) #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags) @@ -198,7 +230,12 @@ size_t size ; if (size == 0) data = "" ; + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); PUTBACK ; @@ -223,44 +260,45 @@ size_t size ; static void PrintHash(hash) -HASHINFO hash ; +HASHINFO * hash ; { printf ("HASH Info\n") ; - printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ; - printf (" bsize = %d\n", hash.bsize) ; - printf (" ffactor = %d\n", hash.ffactor) ; - printf (" nelem = %d\n", hash.nelem) ; - printf (" cachesize = %d\n", hash.cachesize) ; - printf (" lorder = %d\n", hash.lorder) ; + printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->bsize) ; + printf (" ffactor = %d\n", hash->ffactor) ; + printf (" nelem = %d\n", hash->nelem) ; + printf (" cachesize = %d\n", hash->cachesize) ; + printf (" lorder = %d\n", hash->lorder) ; } static void PrintRecno(recno) -RECNOINFO recno ; +RECNOINFO * recno ; { printf ("RECNO Info\n") ; - printf (" flags = %d\n", recno.flags) ; - printf (" cachesize = %d\n", recno.cachesize) ; - printf (" psize = %d\n", recno.psize) ; - printf (" lorder = %d\n", recno.lorder) ; - printf (" reclen = %d\n", recno.reclen) ; - printf (" bval = %d\n", recno.bval) ; - printf (" bfname = %d [%s]\n", recno.bfname, recno.bfname) ; + printf (" flags = %d\n", recno->flags) ; + printf (" cachesize = %d\n", recno->cachesize) ; + printf (" psize = %d\n", recno->psize) ; + printf (" lorder = %d\n", recno->lorder) ; + printf (" reclen = %d\n", recno->reclen) ; + printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ; + printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ; } +static void PrintBtree(btree) -BTREEINFO btree ; +BTREEINFO * btree ; { printf ("BTREE Info\n") ; - printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ; - printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ; - printf (" flags = %d\n", btree.flags) ; - printf (" cachesize = %d\n", btree.cachesize) ; - printf (" psize = %d\n", btree.psize) ; - printf (" maxkeypage = %d\n", btree.maxkeypage) ; - printf (" minkeypage = %d\n", btree.minkeypage) ; - printf (" lorder = %d\n", btree.lorder) ; + printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->flags) ; + printf (" cachesize = %d\n", btree->cachesize) ; + printf (" psize = %d\n", btree->psize) ; + printf (" maxkeypage = %d\n", btree->maxkeypage) ; + printf (" minkeypage = %d\n", btree->minkeypage) ; + printf (" lorder = %d\n", btree->lorder) ; } #else @@ -286,7 +324,7 @@ DB * db ; else if (RETVAL == 1) /* No key means empty file */ RETVAL = 0 ; - return (RETVAL) ; + return ((I32)RETVAL) ; } static recno_t @@ -311,101 +349,111 @@ I32 value ; } static DB_File -ParseOpenInfo(name, flags, mode, sv, string) +ParseOpenInfo(name, flags, mode, sv) char * name ; int flags ; int mode ; SV * sv ; -char * string ; { SV ** svp; HV * action ; - union INFO info ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; + union INFO * info = &RETVAL->info ; /* Default to HASH */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + if (sv) { if (! SvROK(sv) ) croak ("type parameter is not a reference") ; - action = (HV*)SvRV(sv); + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + if (sv_isa(sv, "DB_File::HASHINFO")) { RETVAL->type = DB_HASH ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { - info.hash.hash = hash_cb ; + info->hash.hash = hash_cb ; RETVAL->hash = newSVsv(*svp) ; } else - info.hash.hash = NULL ; + info->hash.hash = NULL ; svp = hv_fetch(action, "bsize", 5, FALSE); - info.hash.bsize = svp ? SvIV(*svp) : 0; + info->hash.bsize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "ffactor", 7, FALSE); - info.hash.ffactor = svp ? SvIV(*svp) : 0; + info->hash.ffactor = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "nelem", 5, FALSE); - info.hash.nelem = svp ? SvIV(*svp) : 0; + info->hash.nelem = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.hash.cachesize = svp ? SvIV(*svp) : 0; + info->hash.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.hash.lorder = svp ? SvIV(*svp) : 0; + info->hash.lorder = svp ? SvIV(*svp) : 0; PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { RETVAL->type = DB_BTREE ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { - info.btree.compare = btree_compare ; + info->btree.compare = btree_compare ; RETVAL->compare = newSVsv(*svp) ; } else - info.btree.compare = NULL ; + info->btree.compare = NULL ; svp = hv_fetch(action, "prefix", 6, FALSE); if (svp && SvOK(*svp)) { - info.btree.prefix = btree_prefix ; + info->btree.prefix = btree_prefix ; RETVAL->prefix = newSVsv(*svp) ; } else - info.btree.prefix = NULL ; + info->btree.prefix = NULL ; svp = hv_fetch(action, "flags", 5, FALSE); - info.btree.flags = svp ? SvIV(*svp) : 0; + info->btree.flags = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.btree.cachesize = svp ? SvIV(*svp) : 0; + info->btree.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "minkeypage", 10, FALSE); - info.btree.minkeypage = svp ? SvIV(*svp) : 0; + info->btree.minkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "maxkeypage", 10, FALSE); - info.btree.maxkeypage = svp ? SvIV(*svp) : 0; + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); - info.btree.psize = svp ? SvIV(*svp) : 0; + info->btree.psize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.btree.lorder = svp ? SvIV(*svp) : 0; + info->btree.lorder = svp ? SvIV(*svp) : 0; PrintBtree(info) ; @@ -413,44 +461,46 @@ char * string ; else if (sv_isa(sv, "DB_File::RECNOINFO")) { RETVAL->type = DB_RECNO ; - openinfo = (void *)&info ; + openinfo = (void *)info ; svp = hv_fetch(action, "flags", 5, FALSE); - info.recno.flags = (u_long) svp ? SvIV(*svp) : 0; + info->recno.flags = (u_long) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; + info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); - info.recno.psize = (int) svp ? SvIV(*svp) : 0; + info->recno.psize = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.recno.lorder = (int) svp ? SvIV(*svp) : 0; + info->recno.lorder = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "reclen", 6, FALSE); - info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0; + info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "bval", 4, FALSE); if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info.recno.bval = (u_char)*SvPV(*svp, na) ; + info->recno.bval = (u_char)*SvPV(*svp, na) ; else - info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ; + info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ; } else { - if (info.recno.flags & R_FIXEDLEN) - info.recno.bval = (u_char) ' ' ; + if (info->recno.flags & R_FIXEDLEN) + info->recno.bval = (u_char) ' ' ; else - info.recno.bval = (u_char) '\n' ; + info->recno.bval = (u_char) '\n' ; } svp = hv_fetch(action, "bfname", 6, FALSE); - if (svp) { + if (svp && SvOK(*svp)) { char * ptr = SvPV(*svp,na) ; - info.recno.bfname = (char*) na ? ptr : 0 ; + info->recno.bfname = (char*) na ? ptr : NULL ; } + else + info->recno.bfname = NULL ; PrintRecno(info) ; } @@ -727,11 +777,10 @@ constant(name,arg) DB_File -db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH) +db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) char * dbtype int flags int mode - ALIAS: TIEARRAY = 1 CODE: { char * name = (char *) NULL ; @@ -743,7 +792,7 @@ db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH) if (items == 5) sv = ST(4) ; - RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; + RETVAL = ParseOpenInfo(name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } @@ -1039,3 +1088,4 @@ db_seq(db, key, value, flags) OUTPUT: key value + diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 975d26d779..3d6b2d32d4 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -48,6 +48,10 @@ dl_load_file(filename) bind_type = BIND_IMMEDIATE; else bind_type = BIND_DEFERRED; +#ifdef DEBUGGING + if (dl_debug) + bind_type |= BIND_VERBOSE; +#endif /* DEBUGGING */ max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { diff --git a/ext/DynaLoader/dl_os2.xs b/ext/DynaLoader/dl_os2.xs deleted file mode 100644 index 3042a002b2..0000000000 --- a/ext/DynaLoader/dl_os2.xs +++ /dev/null @@ -1,188 +0,0 @@ -/* dl_os2.xs - * - * Platform: OS/2. - * Author: Andreas Kaiser (ak@ananke.s.bawue.de) - * Created: 08th December 1994 - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define INCL_BASE -#include <os2.h> - -#include "dlutils.c" /* SaveError() etc */ - -static ULONG retcode; - -static void * -dlopen(char *path, int mode) -{ - HMODULE handle; - char tmp[260], *beg, *dot; - char fail[300]; - ULONG rc; - - if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0) - return (void *)handle; - - retcode = rc; - - /* Not found. Check for non-FAT name and try truncated name. */ - /* Don't know if this helps though... */ - for (beg = dot = path + strlen(path); - beg > path && !strchr(":/\\", *(beg-1)); - beg--) - if (*beg == '.') - dot = beg; - if (dot - beg > 8) { - int n = beg+8-path; - memmove(tmp, path, n); - memmove(tmp+n, dot, strlen(dot)+1); - if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) - return (void *)handle; - } - - return NULL; -} - -static void * -dlsym(void *handle, char *symbol) -{ - ULONG rc, type; - PFN addr; - - rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); - if (rc == 0) { - rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); - if (rc == 0 && type == PT_32BIT) - return (void *)addr; - rc = ERROR_CALL_NOT_IMPLEMENTED; - } - retcode = rc; - return NULL; -} - -static char * -dlerror(void) -{ - static char buf[300]; - ULONG len; - - if (retcode == 0) - return NULL; - if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len)) - sprintf(buf, "OS/2 system error code %d", retcode); - else - buf[len] = '\0'; - retcode = 0; - return buf; -} - - -static void -dl_private_init() -{ - (void)dl_generic_private_init(); -} - -static char * -mod2fname(sv) - SV *sv; -{ - static char fname[9]; - int pos = 7; - int len; - AV *av; - SV *svp; - char *s; - - if (!SvROK(sv)) croak("Not a reference given to mod2fname"); - sv = SvRV(sv); - if (SvTYPE(sv) != SVt_PVAV) - croak("Not array reference given to mod2fname"); - if (av_len((AV*)sv) < 0) - croak("Empty array reference given to mod2fname"); - s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na); - strncpy(fname, s, 8); - if ((len=strlen(s)) < 7) pos = len; - fname[pos] = '_'; - fname[pos + 1] = '\0'; - return (char *)fname; -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(); - - -void * -dl_load_file(filename) - char * filename - CODE: - int mode = 1; /* Solaris 1 */ -#ifdef RTLD_LAZY - mode = RTLD_LAZY; /* Solaris 2 */ -#endif - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); - RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError("%s",dlerror()) ; - else - sv_setiv( ST(0), (IV)RETVAL); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: -#ifdef DLSYM_NEEDS_UNDERSCORE - char symbolname_buf[1024]; - symbolname = dl_add_underscore(symbolname, symbolname_buf); -#endif - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError("%s",dlerror()) ; - else - sv_setiv( ST(0), (IV)RETVAL); - - -void -dl_undef_symbols() - PPCODE: - -char * -mod2fname(sv) - SV *sv; - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 599dd37ea5..e13427a353 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -84,7 +84,7 @@ SaveError(pat, va_alist) /* prepend underscore to s. write into buf. return buf. */ -char * +static char * dl_add_underscore(s, buf) char *s; char *buf; diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 9d000a1e68..489853416d 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -7,6 +7,7 @@ Fcntl - load the C Fcntl.h defines =head1 SYNOPSIS use Fcntl; + use Fcntl qw(:DEFAULT :flock); =head1 DESCRIPTION @@ -21,14 +22,21 @@ far more likely chance of getting the numbers right. Only C<#define> symbols get translated; you must still correctly pack up your own arguments to pass as args for locking functions, etc. +=head1 EXPORTED SYMBOLS + +By default your system's F_* and O_* constants (eg, F_DUPFD and O_CREAT) +are exported into your namespace. You can request that the flock() +constants (LOCK_SH, LOCK_EX, LOCK_NB and LOCK_UN) be provided by using +the tag C<:flock>. See L<Exporter>. + =cut -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); -$VERSION = "1.00"; +$VERSION = "1.01"; # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = @@ -42,6 +50,11 @@ $VERSION = "1.00"; ); # Other items we are prepared to export if requested @EXPORT_OK = qw( + LOCK_SH LOCK_EX LOCK_NB LOCK_UN +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], ); sub AUTOLOAD { diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index 90f3af5028..0f51b100d7 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -115,6 +115,37 @@ int arg; goto not_there; #endif break; + case 'L': + if (strnEQ(name, "LOCK_", 5)) { + /* We support flock() on systems which don't have it, so + always supply the constants. */ + if (strEQ(name, "LOCK_SH")) +#ifdef LOCK_SH + return LOCK_SH; +#else + return 1; +#endif + if (strEQ(name, "LOCK_EX")) +#ifdef LOCK_EX + return LOCK_EX; +#else + return 2; +#endif + if (strEQ(name, "LOCK_NB")) +#ifdef LOCK_NB + return LOCK_NB; +#else + return 4; +#endif + if (strEQ(name, "LOCK_UN")) +#ifdef LOCK_UN + return LOCK_UN; +#else + return 8; +#endif + } else + goto not_there; + break; case 'O': if (strnEQ(name, "O_", 2)) { if (strEQ(name, "O_CREAT")) diff --git a/ext/FileHandle/FileHandle.pm b/ext/FileHandle/FileHandle.pm deleted file mode 100644 index d479dae08c..0000000000 --- a/ext/FileHandle/FileHandle.pm +++ /dev/null @@ -1,489 +0,0 @@ -package FileHandle; - -=head1 NAME - -FileHandle - supply object methods for filehandles - -=head1 SYNOPSIS - - use FileHandle; - - $fh = new FileHandle; - if ($fh->open "< file") { - print <$fh>; - $fh->close; - } - - $fh = new FileHandle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new FileHandle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new FileHandle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file - } - - $pos = $fh->getpos; - $fh->setpos $pos; - - $fh->setvbuf($buffer_var, _IOLBF, 1024); - - ($readfh, $writefh) = FileHandle::pipe; - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<FileHandle::new> creates a C<FileHandle>, which is a reference to a -newly created symbol (see the C<Symbol> package). If it receives any -parameters, they are passed to C<FileHandle::open>; if the open fails, -the C<FileHandle> object is destroyed. Otherwise, it is returned to -the caller. - -C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. -It requires two parameters, which are passed to C<FileHandle::fdopen>; -if the fdopen fails, the C<FileHandle> object is destroyed. -Otherwise, it is returned to the caller. - -C<FileHandle::open> accepts one parameter or two. With one parameter, -it is just a front end for the built-in C<open> function. With two -parameters, the first parameter is a filename that may include -whitespace or other special characters, and the second parameter is -the open mode, optionally followed by a file permission value. - -If C<FileHandle::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) -or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic -Perl C<open> operator. - -If C<FileHandle::open> is given a numeric mode, it passes that mode -and the optional permissions value to the Perl C<sysopen> operator. -For convenience, C<FileHandle::import> tries to import the O_XXX -constants from the Fcntl module. If dynamic loading is not available, -this may fail, but the rest of FileHandle will still work. - -C<FileHandle::fdopen> is like C<open> except that its first parameter -is not a filename but rather a file handle name, a FileHandle object, -or a file descriptor number. - -If the C functions fgetpos() and fsetpos() are available, then -C<FileHandle::getpos> returns an opaque value that represents the -current position of the FileHandle, and C<FileHandle::setpos> uses -that value to return to a previously visited position. - -If the C function setvbuf() is available, then C<FileHandle::setvbuf> -sets the buffering policy for the FileHandle. The calling sequence -for the Perl function is the same as its C counterpart, including the -macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer -parameter specifies a scalar variable to use as a buffer. WARNING: A -variable used as a buffer by C<FileHandle::setvbuf> must not be -modified in any way until the FileHandle is closed or until -C<FileHandle::setvbuf> is called again, or memory corruption may -result! - -See L<perlfunc> for complete descriptions of each of the following -supported C<FileHandle> methods, which are just front ends for the -corresponding built-in functions: - - close - fileno - getc - gets - eof - clearerr - seek - tell - -See L<perlvar> for complete descriptions of each of the following -supported C<FileHandle> methods: - - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - -Furthermore, for doing normal I/O you might need these: - -=over - -=item $fh-E<gt>print - -See L<perlfunc/print>. - -=item $fh-E<gt>printf - -See L<perlfunc/printf>. - -=item $fh-E<gt>getline - -This works like E<lt>$fhE<gt> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in an -array context but still returns just one line. - -=item $fh-E<gt>getlines - -This works like E<lt>$fhE<gt> when called in an array context to -read all the remaining lines in a file, except that it's more readable. -It will also croak() if accidentally called in a scalar context. - -=back - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<POSIX/"FileHandle"> - -=head1 BUGS - -Due to backwards compatibility, all filehandles resemble objects -of class C<FileHandle>, or actually classes derived from that class. -They actually aren't. Which means you can't derive your own -class from C<FileHandle> and inherit those methods. - -=cut - -require 5.000; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD); -use Carp; -use Symbol; -use SelectSaver; - -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); - -$VERSION = "1.00" ; - -@EXPORT = qw(_IOFBF _IOLBF _IONBF); - -@EXPORT_OK = qw( - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - - print - printf - getline - getlines -); - - -################################################ -## If the Fcntl extension is available, -## export its constants. -## - -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export $pkg, $callpkg; - eval { - require Fcntl; - Exporter::export 'Fcntl', $callpkg; - }; -}; - - -################################################ -## Interaction with the XS. -## - -eval { - bootstrap FileHandle; -}; -if ($@) { - *constant = sub { undef }; -} - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - my $constname = $AUTOLOAD; - $constname =~ s/.*:://; - my $val = constant($constname); - defined $val or croak "$constname is not a valid FileHandle macro"; - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; -} - - -################################################ -## Constructors, destructors. -## - -sub new { - @_ >= 1 && @_ <= 4 - or croak 'usage: new FileHandle [FILENAME [,MODE [,PERMS]]]'; - my $class = shift; - my $fh = gensym; - if (@_) { - FileHandle::open($fh, @_) - or return undef; - } - bless $fh, $class; -} - -sub new_from_fd { - @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE'; - my $class = shift; - my $fh = gensym; - FileHandle::fdopen($fh, @_) - or return undef; - bless $fh, $class; -} - -sub DESTROY { - my ($fh) = @_; - - # During global object destruction, this function may be called - # on FILEHANDLEs as well as on the GLOBs that contains them. - # Thus the following trickery. If only the CORE file operators - # could deal with FILEHANDLEs, it wouldn't be necessary... - - if ($fh =~ /=FILEHANDLE\(/) { - local *TMP = $fh; - close(TMP) if defined fileno(TMP); - } - else { - close($fh) if defined fileno($fh); - } -} - -################################################ -## Open and close. -## - -sub pipe { - @_ and croak 'usage: FileHandle::pipe()'; - my $readfh = new FileHandle; - my $writefh = new FileHandle; - pipe($readfh, $writefh) - or return undef; - ($readfh, $writefh); -} - -sub _open_mode_string { - my ($mode) = @_; - $mode =~ /^\+?(<|>>?)$/ - or $mode =~ s/^r(\+?)$/$1</ - or $mode =~ s/^w(\+?)$/$1>/ - or $mode =~ s/^a(\+?)$/$1>>/ - or croak "FileHandle: bad open mode: $mode"; - $mode; -} - -sub open { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; - my ($fh, $file) = @_; - if (@_ > 2) { - my ($mode, $perms) = @_[2, 3]; - if ($mode =~ /^\d+$/) { - defined $perms or $perms = 0666; - return sysopen($fh, $file, $mode, $perms); - } - $file = "./" . $file unless $file =~ m#^/#; - $file = _open_mode_string($mode) . " $file\0"; - } - open($fh, $file); -} - -sub fdopen { - @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; - my ($fh, $fd, $mode) = @_; - if (ref($fd) =~ /GLOB\(/) { - # It's a glob reference; remove the star from its name. - ($fd = "".$$fd) =~ s/^\*//; - } elsif ($fd =~ m#^\d+$#) { - # It's an FD number; prefix with "=". - $fd = "=$fd"; - } - open($fh, _open_mode_string($mode) . '&' . $fd); -} - -sub close { - @_ == 1 or croak 'usage: $fh->close()'; - close($_[0]); -} - -################################################ -## Normal I/O functions. -## - -sub fileno { - @_ == 1 or croak 'usage: $fh->fileno()'; - fileno($_[0]); -} - -sub getc { - @_ == 1 or croak 'usage: $fh->getc()'; - getc($_[0]); -} - -sub gets { - @_ == 1 or croak 'usage: $fh->gets()'; - my ($handle) = @_; - scalar <$handle>; -} - -sub eof { - @_ == 1 or croak 'usage: $fh->eof()'; - eof($_[0]); -} - -sub clearerr { - @_ == 1 or croak 'usage: $fh->clearerr()'; - seek($_[0], 0, 1); -} - -sub seek { - @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; - seek($_[0], $_[1], $_[2]); -} - -sub tell { - @_ == 1 or croak 'usage: $fh->tell()'; - tell($_[0]); -} - -sub print { - @_ or croak 'usage: $fh->print([ARGS])'; - my $this = shift; - print $this @_; -} - -sub printf { - @_ or croak 'usage: $fh->printf([ARGS])'; - my $this = shift; - printf $this @_; -} - -sub getline { - @_ == 1 or croak 'usage: $fh->getline'; - my $this = shift; - return scalar <$this>; -} - -sub getlines { - @_ == 1 or croak 'usage: $fh->getline()'; - my $this = shift; - wantarray or croak "Can't call FileHandle::getlines in a scalar context"; - return <$this>; -} - -################################################ -## State modification functions. -## - -sub autoflush { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $|; - $| = @_ > 1 ? $_[1] : 1; - $prev; -} - -sub output_field_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $,; - $, = $_[1] if @_ > 1; - $prev; -} - -sub output_record_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $\; - $\ = $_[1] if @_ > 1; - $prev; -} - -sub input_record_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $/; - $/ = $_[1] if @_ > 1; - $prev; -} - -sub input_line_number { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $.; - $. = $_[1] if @_ > 1; - $prev; -} - -sub format_page_number { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $%; - $% = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_per_page { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $=; - $= = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_left { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $-; - $- = $_[1] if @_ > 1; - $prev; -} - -sub format_name { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $~; - $~ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_top_name { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $^; - $^ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_line_break_characters { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $:; - $: = $_[1] if @_ > 1; - $prev; -} - -sub format_formfeed { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $^L; - $^L = $_[1] if @_ > 1; - $prev; -} - -1; diff --git a/ext/FileHandle/FileHandle.xs b/ext/FileHandle/FileHandle.xs deleted file mode 100644 index 413b312d4e..0000000000 --- a/ext/FileHandle/FileHandle.xs +++ /dev/null @@ -1,176 +0,0 @@ -#include "EXTERN.h" -#define PERLIO_NOT_STDIO 1 -#include "perl.h" -#include "XSUB.h" - -typedef int SysRet; -typedef PerlIO * InputStream; -typedef PerlIO * OutputStream; - -static int -not_here(s) -char *s; -{ - croak("FileHandle::%s not implemented on this architecture", s); - return -1; -} - -static bool -constant(name, pval) -char *name; -IV *pval; -{ - switch (*name) { - case '_': - if (strEQ(name, "_IOFBF")) -#ifdef _IOFBF - { *pval = _IOFBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IOLBF")) -#ifdef _IOLBF - { *pval = _IOLBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IONBF")) -#ifdef _IONBF - { *pval = _IONBF; return TRUE; } -#else - return FALSE; -#endif - break; - } - - return FALSE; -} - - -MODULE = FileHandle PACKAGE = FileHandle PREFIX = f - -SV * -constant(name) - char * name - CODE: - IV i; - if (constant(name, &i)) - RETVAL = newSViv(i); - else - RETVAL = &sv_undef; - OUTPUT: - RETVAL - -SV * -fgetpos(handle) - InputStream handle - CODE: - if (handle) { - Fpos_t pos; - PerlIO_getpos(handle, &pos); - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); - } - else { - ST(0) = &sv_undef; - errno = EINVAL; - } - -SysRet -fsetpos(handle, pos) - InputStream handle - SV * pos - CODE: - if (handle) - RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -int -ungetc(handle, c) - InputStream handle - int c - CODE: - if (handle) - RETVAL = PerlIO_ungetc(handle, c); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -OutputStream -new_tmpfile(packname = "FileHandle") - char * packname - CODE: - RETVAL = PerlIO_tmpfile(); - OUTPUT: - RETVAL - -int -ferror(handle) - InputStream handle - CODE: - if (handle) - RETVAL = PerlIO_error(handle); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -SysRet -fflush(handle) - OutputStream handle - CODE: - if (handle) - RETVAL = PerlIO_flush(handle); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -void -setbuf(handle, buf) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; - CODE: -#ifdef PERLIO_IS_STDIO - if (handle) - setbuf(handle, buf); -#else - not_here("setbuf"); -#endif - - -SysRet -setvbuf(handle, buf, type, size) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; - int type - int size - CODE: -#ifdef PERLIO_IS_STDIO -#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */ - if (handle) - RETVAL = setvbuf(handle, buf, type, size); - else { - RETVAL = -1; - errno = EINVAL; - } -#else - RETVAL = (SysRet) not_here("setvbuf"); -#endif /* _IOFBF */ -#else - RETVAL = (SysRet) not_here("setvbuf"); -#endif - OUTPUT: - RETVAL - diff --git a/ext/FileHandle/Makefile.PL b/ext/FileHandle/Makefile.PL deleted file mode 100644 index 7efd382043..0000000000 --- a/ext/FileHandle/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'FileHandle', - MAN3PODS => ' ', # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'FileHandle.pm', -); diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 3cc3518e7e..daa22f6000 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -121,17 +121,28 @@ fsetpos(handle, pos) MODULE = IO PACKAGE = IO::File PREFIX = f -OutputStream +SV * new_tmpfile(packname = "IO::File") char * packname + PREINIT: + OutputStream fp; + GV *gv; CODE: #ifdef PerlIO - RETVAL = PerlIO_tmpfile(); + fp = PerlIO_tmpfile(); #else - RETVAL = tmpfile(); + fp = tmpfile(); #endif - OUTPUT: - RETVAL + gv = (GV*)SvREFCNT_inc(newGVgen(packname)); + hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); + if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { + ST(0) = sv_2mortal(newRV_noinc((SV*)gv)); + sv_bless(ST(0), gv_stashpv(packname, TRUE)); + } + else { + ST(0) = &sv_undef; + SvREFCNT_dec(gv); + } MODULE = IO PACKAGE = IO::Handle PREFIX = f @@ -203,6 +214,7 @@ int untaint(handle) SV * handle CODE: +#ifdef IOf_UNTAINT IO * io; io = sv_2io(handle); if (io) { @@ -210,9 +222,12 @@ untaint(handle) RETVAL = 0; } else { +#endif RETVAL = -1; errno = EINVAL; +#ifdef IOf_UNTAINT } +#endif OUTPUT: RETVAL diff --git a/ext/IO/README b/ext/IO/README new file mode 100644 index 0000000000..e855afade4 --- /dev/null +++ b/ext/IO/README @@ -0,0 +1,4 @@ +This directory contains files from the IO distribution maintained by +Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify +any files in this directory then please forward him a patch for only +the files in this directory. diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index ef9d510f91..e44d77f1fe 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -43,7 +43,7 @@ IO::File - supply object methods for filehandles =head1 DESCRIPTION -C<IO::File> is inherits from C<IO::Handle> ans C<IO::Seekable>. It extends +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends these classes with methods that are specific to file handles. =head1 CONSTRUCTOR @@ -93,17 +93,13 @@ L<IO::Seekable> Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. -=head1 REVISION - -$Revision: 1.5 $ - =cut require 5.000; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD); +use strict; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); use Carp; use Symbol; -use English; use SelectSaver; use IO::Handle qw(_open_mode_string); use IO::Seekable; @@ -113,24 +109,24 @@ require DynaLoader; @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); -$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/); +$VERSION = "1.06"; @EXPORT = @IO::Seekable::EXPORT; -################################################ -## If the Fcntl extension is available, -## export its constants. -## - sub import { my $pkg = shift; my $callpkg = caller; - Exporter::export $pkg, $callpkg; + Exporter::export $pkg, $callpkg, @_; + + # + # If the Fcntl extension is available, + # export its constants for sysopen(). + # eval { require Fcntl; - Exporter::export 'Fcntl', $callpkg; + Exporter::export 'Fcntl', $callpkg, '/^O_/'; }; -}; +} ################################################ diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index e4abdd2ecb..e271268390 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -1,5 +1,3 @@ -# - package IO::Handle; =head1 NAME @@ -78,7 +76,7 @@ result! See L<perlfunc> for complete descriptions of each of the following supported C<IO::Handle> methods, which are just front ends for the corresponding built-in functions: - + close fileno getc @@ -169,7 +167,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'. L<perlfunc>, L<perlop/"I/O Operators">, -L<POSIX/"FileHandle"> +L<FileHandle> =head1 BUGS @@ -185,7 +183,8 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> =cut require 5.000; -use vars qw($RCS $VERSION @EXPORT_OK $AUTOLOAD); +use strict; +use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA); use Carp; use Symbol; use SelectSaver; @@ -193,13 +192,7 @@ use SelectSaver; require Exporter; @ISA = qw(Exporter); -## -## TEMPORARY workaround as perl expects handles to be <FileHandle> objects -## -@FileHandle::ISA = qw(IO::Handle); - -$VERSION = "1.12"; -$RCS = sprintf("%s", q$Revision: 1.15 $ =~ /([\d\.]+)/); +$VERSION = "1.1401"; @EXPORT_OK = qw( autoflush @@ -249,6 +242,7 @@ sub AUTOLOAD { $constname =~ s/.*:://; my $val = constant($constname); defined $val or croak "$constname is not a valid IO::Handle macro"; + no strict 'refs'; *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } @@ -269,6 +263,7 @@ sub new_from_fd { my $class = ref($_[0]) || $_[0] || "IO::Handle"; @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; my $fh = gensym; + shift; IO::Handle::fdopen($fh, @_) or return undef; bless $fh, $class; @@ -421,7 +416,7 @@ sub write { sub syswrite { @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; - sysread($_[0], $_[1], $_[2], $_[3] || 0); + syswrite($_[0], $_[1], $_[2], $_[3] || 0); } sub stat { diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index 27fe7f1aa2..34cb0daad2 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -89,11 +89,7 @@ L<IO::Handle> =head1 AUTHOR -Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> - -=head1 REVISION - -$Revision: 1.7 $ +Graham Barr <bodg@tiuk.ti.com> =head1 COPYRIGHT @@ -104,12 +100,13 @@ as Perl itself. =cut require 5.000; +use strict; use vars qw($VERSION); use Carp; use Symbol; require IO::Handle; -$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/); +$VERSION = "1.08"; sub new { my $type = shift; @@ -165,9 +162,10 @@ sub reader { my $pid = $me->_doit(0,@_) if(@_); + close(${*$me}[1]); bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh; # Really wan't un-bless here + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -181,9 +179,10 @@ sub writer { my $pid = $me->_doit(1,@_) if(@_); + close(${*$me}[0]); bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh; # Really wan't un-bless here + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm index 8e0f87ac18..3bae914087 100644 --- a/ext/IO/lib/IO/Seekable.pm +++ b/ext/IO/lib/IO/Seekable.pm @@ -26,7 +26,7 @@ that value to return to a previously visited position. See L<perlfunc> for complete descriptions of each of the following supported C<IO::Seekable> methods, which are just front ends for the corresponding built-in functions: - + clearerr seek tell @@ -42,14 +42,11 @@ L<IO::File> Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> -=head1 REVISION - -$Revision: 1.5 $ - =cut require 5.000; use Carp; +use strict; use vars qw($VERSION @EXPORT @ISA); use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; @@ -57,7 +54,7 @@ require Exporter; @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); @ISA = qw(Exporter); -$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/); +$VERSION = "1.06"; sub clearerr { @_ == 1 or croak 'usage: $fh->clearerr()'; diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index 845d6b25a4..dea684a62e 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -1,4 +1,8 @@ # IO::Select.pm +# +# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +# software; you can redistribute it and/or modify it under the same terms +# as Perl itself. package IO::Select; @@ -47,17 +51,30 @@ will be returned when an event occurs. C<IO::Select> keeps these values in a cache which is indexed by the C<fileno> of the handle, so if more than one handle with the same C<fileno> is specified then only the last one is cached. +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is a C<IO::Handle> or an integer. + =item remove ( HANDLES ) Remove all the given handles from the object. This method also works by the C<fileno> of the handles. So the exact handles that were added need not be passed, just handles that have an equivalent C<fileno> +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + =item can_read ( [ TIMEOUT ] ) -Return an array of handles that are ready for reading. C<TIMEOUT> is the maximum -amount of time to wait before returning an empty list. If C<TIMEOUT> is -not given then the call will block. +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list. If +C<TIMEOUT> is not given and any handles are registered then the call +will block. =item can_write ( [ TIMEOUT ] ) @@ -65,8 +82,8 @@ Same as C<can_read> except check for handles that can be written to. =item has_error ( [ TIMEOUT ] ) -Same as C<can_read> except check for handles that have an error condition, for -example EOF. +Same as C<can_read> except check for handles that have an error +condition, for example EOF. =item count () @@ -74,12 +91,20 @@ Returns the number of handles that the object will check for when one of the C<can_> methods is called or the object is passed to the C<select> static method. +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + =item select ( READ, WRITE, ERROR [, TIMEOUT ] ) -C<select> is a static method, that is you call it with the package name -like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> or -C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as -before. +C<select> is a static method, that is you call it with the package +name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> +or C<IO::Select> objects. C<TIMEOUT> is optional and has the same +effect as for the core select call. The result will be an array of 3 elements, each a reference to an array which will hold the handles that are ready for reading, writing and have @@ -120,10 +145,6 @@ listening for more connections on a listen socket Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> -=head1 REVISION - -$Revision: 1.9 $ - =head1 COPYRIGHT Copyright (c) 1995 Graham Barr. All rights reserved. This program is free @@ -136,13 +157,13 @@ use strict; use vars qw($VERSION @ISA); require Exporter; -$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/); +$VERSION = "1.10"; @ISA = qw(Exporter); # This is only so we can do version checking -sub VEC_BITS {0} -sub FD_COUNT {1} -sub FIRST_FD {2} +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} sub new { @@ -159,39 +180,63 @@ sub new sub add { + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ my $vec = shift; - my $f; + $vec->[$vec->_fileno(shift) + FIRST_FD]; +} - $vec->[VEC_BITS] = '' unless defined $vec->[VEC_BITS]; - foreach $f (@_) - { - my $fn = $f =~ /^\d+$/ ? $f : fileno($f); - next - unless defined $fn; - vec($vec->[VEC_BITS],$fn,1) = 1; - $vec->[FD_COUNT] += 1 - unless defined $vec->[$fn+FIRST_FD]; - $vec->[$fn+FIRST_FD] = $f; - } - $vec->[VEC_BITS] = undef unless $vec->count; +sub _fileno +{ + my($self, $f) = @_; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); } -sub remove +sub _update { my $vec = shift; - my $f; + my $add = shift eq 'add'; + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; foreach $f (@_) { - my $fn = $f =~ /^\d+$/ ? $f : fileno($f); - next - unless defined $fn; - vec($vec->[VEC_BITS],$fn,1) = 0; - $vec->[$fn+FIRST_FD] = undef; - $vec->[FD_COUNT] -= 1; + my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + $count++; } - $vec->[VEC_BITS] = undef unless $vec->count; + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; } sub can_read @@ -201,7 +246,7 @@ sub can_read my $r = $vec->[VEC_BITS]; defined($r) && (select($r,undef,undef,$timeout) > 0) - ? _handles($vec, $r) + ? handles($vec, $r) : (); } @@ -212,7 +257,7 @@ sub can_write my $w = $vec->[VEC_BITS]; defined($w) && (select(undef,$w,undef,$timeout) > 0) - ? _handles($vec, $w) + ? handles($vec, $w) : (); } @@ -223,7 +268,7 @@ sub has_error my $e = $vec->[VEC_BITS]; defined($e) && (select(undef,undef,$e,$timeout) > 0) - ? _handles($vec, $e) + ? handles($vec, $e) : (); } @@ -233,6 +278,28 @@ sub count $vec->[FD_COUNT]; } +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + sub _max { my($a,$b,$c) = @_; @@ -254,8 +321,8 @@ sub select my @result = (); my $rb = defined $r ? $r->[VEC_BITS] : undef; - my $wb = defined $w ? $e->[VEC_BITS] : undef; - my $eb = defined $e ? $w->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; if(select($rb,$wb,$eb,$t) > 0) { @@ -282,18 +349,20 @@ sub select @result; } -sub _handles + +sub handles { my $vec = shift; my $bits = shift; my @h = (); my $i; + my $max = scalar(@$vec) - 1; - for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--) + for ($i = FIRST_FD; $i <= $max; $i++) { next unless defined $vec->[$i]; push(@h, $vec->[$i]) - if vec($bits,$i - FIRST_FD,1); + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); } @h; diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 94ae88a536..6a69c6b624 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -20,13 +20,15 @@ C<IO::Socket> only defines methods for those operations which are common to all types of socket. Operations which are specified to a socket in a particular domain have methods defined in sub classes of C<IO::Socket> +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + =head1 CONSTRUCTOR =over 4 =item new ( [ARGS] ) -Creates a C<IO::Pipe>, which is a reference to a +Creates a C<IO::Socket>, which is a reference to a newly created symbol (see the C<Symbol> package). C<new> optionally takes arguments, these arguments are in key-value pairs. C<new> only looks for one key C<Domain> which tells new which domain @@ -81,12 +83,12 @@ with one argument then getsockopt is called, otherwise setsockopt is called. =item sockdomain -Returns the numerical number for the socket domain type. For example, fir +Returns the numerical number for the socket domain type. For example, for a AF_INET socket the value of &AF_INET will be returned. =item socktype -Returns the numerical number for the socket type. For example, fir +Returns the numerical number for the socket type. For example, for a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. =item protocol @@ -107,14 +109,12 @@ use IO::Handle; use Socket 1.3; use Carp; use strict; -use vars qw(@ISA @EXPORT_OK $VERSION); +use vars qw(@ISA $VERSION); use Exporter; @ISA = qw(IO::Handle); -# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ... - -$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; +$VERSION = "1.15"; sub import { my $pkg = shift; @@ -155,12 +155,13 @@ sub configure { croak 'IO::Socket: Cannot configure a generic socket' unless defined $domain; - my $sub = ref(_domain2pkg($domain)) . "::configure"; + my $class = ref(_domain2pkg($domain)); - goto &{$sub} - if(defined &{$sub}); + croak "IO::Socket: Cannot configure socket in domain '$domain'" + unless ref($fh) eq "IO::Socket"; - croak "IO::Socket: Cannot configure socket in domain '$domain' $sub"; + bless($fh, $class); + $fh->configure; } sub socket { @@ -366,27 +367,6 @@ sub protocol { ${*$fh}{'io_socket_protocol'}; } -sub _addmethod { - my $self = shift; - my $name; - - foreach $name (@_) { - my $n = $name; - - no strict qw(refs); - - *{$n} = sub { - my $pkg = ref(${*{$_[0]}}{'io_socket_domain'}); - my $sub = "${pkg}::${n}"; - goto &{$sub} if defined &{$sub}; - croak qq{Can't locate object method "$n" via package "$pkg"}; - } - unless defined &{$n}; - } - -} - - =head1 SUB-CLASSES =cut @@ -398,14 +378,13 @@ sub _addmethod { package IO::Socket::INET; use strict; -use vars qw(@ISA $VERSION); +use vars qw(@ISA); use Socket; use Carp; use Exporter; @ISA = qw(IO::Socket); -IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost)); IO::Socket::INET->register_domain( AF_INET ); my %socket_type = ( tcp => SOCK_STREAM, @@ -417,22 +396,45 @@ my %socket_type = ( tcp => SOCK_STREAM, C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket and some related methods. The constructor can take the following options - PeerAddr Remote host address - PeerPort Remote port or service - LocalPort Local host bind port - LocalAddr Local host bind address - Proto Protocol name (eg tcp udp etc) - Type Socket type (SOCK_STREAM etc) + PeerAddr Remote host address <hostname>[:<port>] + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... Listen Queue size for listen + Reuse Set SO_REUSEADDR before binding Timeout Timeout value for various operations -If Listen is defined then a listen socket is created, else if the socket -type, which is derived from the protocol, is SOCK_STREAM then a connect -is called. +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +Only one of C<Type> or C<Proto> needs to be specified, one will be +assumed from the other. If you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Type> and C<Proto> from +the service name. -Only one of C<Type> or C<Proto> needs to be specified, one will be assumed -from the other. +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => http(80), + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); =head2 METHODS @@ -469,7 +471,6 @@ peer host in a text form xx.xx.xx.xx =cut - sub _sock_info { my($addr,$port,$proto) = @_; my @proto = (); @@ -508,7 +509,8 @@ sub _sock_info { sub _error { my $fh = shift; - carp join("",ref($fh),": ",@_) if @_; + $@ = join("",ref($fh),": ",@_); + carp $@ if $^W; close($fh) if(defined fileno($fh)); return undef; @@ -551,14 +553,19 @@ sub configure { ${*$fh}{'io_socket_domain'} = bless \$domain; $fh->socket(AF_INET, $type, $proto) or - return _error($fh); + return _error($fh,"$!"); + + if ($arg->{Reuse}) { + $fh->sockopt(SO_REUSEADDR,1) or + return _error($fh); + } $fh->bind($lport || 0, $laddr) or - return _error($fh); + return _error($fh,"$!"); if(exists $arg->{Listen}) { $fh->listen($arg->{Listen} || 5) or - return _error($fh); + return _error($fh,"$!"); } else { return _error($fh,'Cannot determine remote port') @@ -569,7 +576,7 @@ sub configure { unless(defined $raddr); $fh->connect($rport,$raddr) or - return _error($fh); + return _error($fh,"$!"); } } @@ -626,7 +633,6 @@ use Exporter; @ISA = qw(IO::Socket); -IO::Socket::UNIX->_addmethod(qw(hostpath peerpath)); IO::Socket::UNIX->register_domain( AF_UNIX ); =head2 IO::Socket::UNIX @@ -645,11 +651,11 @@ and some related methods. The constructor can take the following options =item hostpath() -Returns the pathname to the fifo at the local end. +Returns the pathname to the fifo at the local end =item peerpath() -Returns the pathanme to the fifo at the peer end. +Returns the pathanme to the fifo at the peer end =back @@ -688,32 +694,22 @@ sub configure { sub hostpath { @_ == 1 or croak 'usage: $fh->hostpath()'; my $n = $_[0]->sockname || return undef; -warn length($n); (sockaddr_un($n))[0]; } sub peerpath { @_ == 1 or croak 'usage: $fh->peerpath()'; my $n = $_[0]->peername || return undef; -warn length($n); -my @n = sockaddr_un($n); -warn join(",",@n); (sockaddr_un($n))[0]; } -=head1 AUTHOR - -Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> +=head1 SEE ALSO -=head1 REVISION +L<Socket>, L<IO::Handle> -$Revision: 1.13 $ - -The VERSION is derived from the revision turning each number after the -first dot into a 2 digit number so +=head1 AUTHOR - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> =head1 COPYRIGHT diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm index 6007b97311..22772796e2 100644 --- a/ext/Opcode/Safe.pm +++ b/ext/Opcode/Safe.pm @@ -1,14 +1,13 @@ package Safe; -require 5.002; - +use 5.003_11; use strict; -use Carp; - use vars qw($VERSION); $VERSION = "2.06"; +use Carp; + use Opcode 1.01, qw( opset opset_to_ops opmask_add empty_opset full_opset invert_opset verify_opset diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 66b55c1565..b095ffebe7 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -96,7 +96,7 @@ $VERSION = "1.00" ; stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX abort atexit atof atoi atol bsearch calloc div free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort realloc strtod strtol stroul wcstombs wctomb)], + qsort realloc strtod strtol strtoul wcstombs wctomb)], string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat strchr strcmp strcoll strcpy strcspn strerror strlen @@ -194,7 +194,7 @@ sub AUTOLOAD { local $! = 0; my $constname = $AUTOLOAD; $constname =~ s/.*:://; - my $val = constant($constname, $_[0]); + my $val = constant($constname, @_ ? $_[0] : 0); if ($! == 0) { *$AUTOLOAD = sub { $val }; } @@ -231,7 +231,7 @@ sub unimpl { package POSIX::SigAction; sub new { - bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; + bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0]; } ############################ @@ -385,35 +385,35 @@ sub offsetof { } sub clearerr { - redef "FileHandle::clearerr()"; + redef "IO::Handle::clearerr()"; } sub fclose { - redef "FileHandle::close()"; + redef "IO::Handle::close()"; } sub fdopen { - redef "FileHandle::new_from_fd()"; + redef "IO::Handle::new_from_fd()"; } sub feof { - redef "FileHandle::eof()"; + redef "IO::Handle::eof()"; } sub fgetc { - redef "FileHandle::getc()"; + redef "IO::Handle::getc()"; } sub fgets { - redef "FileHandle::gets()"; + redef "IO::Handle::gets()"; } sub fileno { - redef "FileHandle::fileno()"; + redef "IO::Handle::fileno()"; } sub fopen { - redef "FileHandle::open()"; + redef "IO::File::open()"; } sub fprintf { @@ -441,27 +441,27 @@ sub fscanf { } sub fseek { - redef "FileHandle::seek()"; + redef "IO::Seekable::seek()"; } sub ferror { - redef "FileHandle::error()"; + redef "IO::Handle::error()"; } sub fflush { - redef "FileHandle::flush()"; + redef "IO::Handle::flush()"; } sub fgetpos { - redef "FileHandle::getpos()"; + redef "IO::Seekable::getpos()"; } sub fsetpos { - redef "FileHandle::setpos()"; + redef "IO::Seekable::setpos()"; } sub ftell { - redef "FileHandle::tell()"; + redef "IO::Seekable::tell()"; } sub fwrite { @@ -534,11 +534,11 @@ sub sscanf { } sub tmpfile { - redef "FileHandle::new_tmpfile()"; + redef "IO::File::new_tmpfile()"; } sub ungetc { - redef "FileHandle::ungetc()"; + redef "IO::Handle::ungetc()"; } sub vfprintf { @@ -628,18 +628,6 @@ sub srand { unimpl "srand()"; } -sub strtod { - unimpl "strtod() is C-specific, stopped"; -} - -sub strtol { - unimpl "strtol() is C-specific, stopped"; -} - -sub stroul { - unimpl "stroul() is C-specific, stopped"; -} - sub system { usage "system(command)" if @_ != 1; system($_[0]); diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index a8cd0d1ca0..34597d1bd5 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -155,7 +155,7 @@ This is identical to Perl's builtin C<chown()> function. =item clearerr -Use method C<FileHandle::clearerr()> instead. +Use method C<IO::Handle::clearerr()> instead. =item clock @@ -277,7 +277,7 @@ This is identical to Perl's builtin C<abs()> function. =item fclose -Use method C<FileHandle::close()> instead. +Use method C<IO::Handle::close()> instead. =item fcntl @@ -285,35 +285,35 @@ This is identical to Perl's builtin C<fcntl()> function. =item fdopen -Use method C<FileHandle::new_from_fd()> instead. +Use method C<IO::Handle::new_from_fd()> instead. =item feof -Use method C<FileHandle::eof()> instead. +Use method C<IO::Handle::eof()> instead. =item ferror -Use method C<FileHandle::error()> instead. +Use method C<IO::Handle::error()> instead. =item fflush -Use method C<FileHandle::flush()> instead. +Use method C<IO::Handle::flush()> instead. =item fgetc -Use method C<FileHandle::getc()> instead. +Use method C<IO::Handle::getc()> instead. =item fgetpos -Use method C<FileHandle::getpos()> instead. +Use method C<IO::Seekable::getpos()> instead. =item fgets -Use method C<FileHandle::gets()> instead. +Use method C<IO::Handle::gets()> instead. =item fileno -Use method C<FileHandle::fileno()> instead. +Use method C<IO::Handle::fileno()> instead. =item floor @@ -325,7 +325,7 @@ This is identical to the C function C<fmod()>. =item fopen -Use method C<FileHandle::open()> instead. +Use method C<IO::File::open()> instead. =item fork @@ -380,11 +380,11 @@ fscanf() is C-specific--use <> and regular expressions instead. =item fseek -Use method C<FileHandle::seek()> instead. +Use method C<IO::Seekable::seek()> instead. =item fsetpos -Use method C<FileHandle::setpos()> instead. +Use method C<IO::Seekable::setpos()> instead. =item fstat @@ -397,7 +397,7 @@ Perl's builtin C<stat> function. =item ftell -Use method C<FileHandle::tell()> instead. +Use method C<IO::Seekable::tell()> instead. =item fwrite @@ -862,13 +862,13 @@ LC_CTYPE category. The following will set the LC_CTYPE behaviour according to the locale environment variables (the second argument C<"">). Please see your systems L<setlocale(3)> documentation for the locale -environment variables' meaning or consult L<perli18n>. +environment variables' meaning or consult L<perllocale>. $loc = POSIX::setlocale( &POSIX::LC_CTYPE, ""); The following will set the LC_COLLATE behaviour to Argentinian Spanish. B<NOTE>: The naming and availability of locales depends on -your operating system. Please consult L<perli18n> for how to find +your operating system. Please consult L<perllocale> for how to find out which locales are available in your system. $loc = POSIX::setlocale( &POSIX::LC_ALL, "es_AR.ISO8859-1" ); @@ -1060,7 +1060,26 @@ This is identical to Perl's builtin C<index()> function. =item strtod -strtod() is C-specific. +String to double translation. Returns the parsed number and the number +of characters in the unparsed portion of the string. Truly +POSIX-compliant systems set $! ($ERRNO) to indicate a translation +error, so clear $! before calling strtod. However, non-POSIX systems +may not check for overflow, and therefore will never set $!. + +strtod should respect any POSIX I<setlocale()> settings. + +To parse a string $str as a floating point number use + + $! = 0; + ($num, $n_unparsed) = POSIX::strtod($str); + +The second returned item and $! can be used to check for valid input: + + if (($str eq '') || ($n_unparsed != 0) || !$!) { + die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; + } + +When called in a scalar context strtod returns the parsed number. =item strtok @@ -1068,7 +1087,42 @@ strtok() is C-specific. =item strtol -strtol() is C-specific. +String to (long) integer translation. Returns the parsed number and +the number of characters in the unparsed portion of the string. Truly +POSIX-compliant systems set $! ($ERRNO) to indicate a translation +error, so clear $! before calling strtol. However, non-POSIX systems +may not check for overflow, and therefore will never set $!. + +strtol should respect any POSIX I<setlocale()> settings. + +To parse a string $str as a number in some base $base use + + $! = 0; + ($num, $n_unparsed) = POSIX::strtol($str, $base); + +The base should be zero or between 2 and 36, inclusive. When the base +is zero or omitted strtol will use the string itself to determine the +base: a leading "0x" or "0X" means hexadecimal; a leading "0" means +octal; any other leading characters mean decimal. Thus, "1234" is +parsed as a decimal number, "01234" as an octal number, and "0x1234" +as a hexadecimal number. + +The second returned item and $! can be used to check for valid input: + + if (($str eq '') || ($n_unparsed != 0) || !$!) { + die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; + } + +When called in a scalar context strtol returns the parsed number. + +=item strtoul + +String to unsigned (long) integer translation. strtoul is identical +to strtol except that strtoul only parses unsigned integers. See +I<strtol> for details. + +Note: Some vendors supply strtod and strtol but not strtoul. +Other vendors that do suply strtoul parse "-1" as a valid value. =item strxfrm @@ -1150,7 +1204,7 @@ seconds. =item tmpfile -Use method C<FileHandle::new_tmpfile()> instead. +Use method C<IO::File::new_tmpfile()> instead. =item tmpnam @@ -1193,7 +1247,7 @@ Get name of current operating system. =item ungetc -Use method C<FileHandle::ungetc()> instead. +Use method C<IO::Handle::ungetc()> instead. =item unlink @@ -1260,9 +1314,10 @@ Creates a new C<POSIX::SigAction> object which corresponds to the C C<struct sigaction>. This object will be destroyed automatically when it is no longer needed. The first parameter is the fully-qualified name of a sub which is a signal-handler. The second parameter is a C<POSIX::SigSet> -object. The third parameter contains the C<sa_flags>. +object, it defaults to the empty set. The third parameter contains the +C<sa_flags>, it defaults to 0. - $sigset = POSIX::SigSet->new; + $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT); $sigaction = POSIX::SigAction->new( 'main::handler', $sigset, &POSIX::SA_NOCLDSTOP ); This C<POSIX::SigAction> object should be used with the C<POSIX::sigaction()> diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index def5fb1235..6354dc3db5 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -33,7 +33,6 @@ #if defined(I_TERMIOS) #include <termios.h> #endif -#include <stdio.h> #ifdef I_STDLIB #include <stdlib.h> #endif @@ -42,8 +41,9 @@ #include <sys/types.h> #include <time.h> #include <unistd.h> +#include <fcntl.h> + #if defined(__VMS) && !defined(__POSIX_SOURCE) -# include <file.h> /* == fcntl.h for DECC; no fcntl.h for VAXC */ # include <libdef.h> /* LIB$_INVARG constant */ # include <lib$routines.h> /* prototype for lib$ediv() */ # include <starlet.h> /* prototype for sys$gettim() */ @@ -52,49 +52,50 @@ # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") - /* The default VMS emulation of Unix signals isn't very POSIXish */ - typedef int sigset_t; -# define sigpending(a) (not_here("sigpending"),0) +# if __VMS_VER < 70000000 + /* The default VMS emulation of Unix signals isn't very POSIXish */ + typedef int sigset_t; +# define sigpending(a) (not_here("sigpending"),0) - /* sigset_t is atomic under VMS, so these routines are easy */ - int sigemptyset(sigset_t *set) { + /* sigset_t is atomic under VMS, so these routines are easy */ + int sigemptyset(sigset_t *set) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } *set = 0; return 0; - } - int sigfillset(sigset_t *set) { + } + int sigfillset(sigset_t *set) { int i; if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } for (i = 0; i < NSIG; i++) *set |= (1 << i); return 0; - } - int sigaddset(sigset_t *set, int sig) { + } + int sigaddset(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set |= (1 << (sig - 1)); return 0; - } - int sigdelset(sigset_t *set, int sig) { + } + int sigdelset(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set &= ~(1 << (sig - 1)); return 0; - } - int sigismember(sigset_t *set, int sig) { + } + int sigismember(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set & (1 << (sig - 1)); - } - /* The tools for sigprocmask() are there, just not the routine itself */ -# ifndef SIG_UNBLOCK -# define SIG_UNBLOCK 1 -# endif -# ifndef SIG_BLOCK -# define SIG_BLOCK 2 -# endif -# ifndef SIG_SETMASK -# define SIG_SETMASK 3 -# endif - int sigprocmask(int how, sigset_t *set, sigset_t *oset) { + } + /* The tools for sigprocmask() are there, just not the routine itself */ +# ifndef SIG_UNBLOCK +# define SIG_UNBLOCK 1 +# endif +# ifndef SIG_BLOCK +# define SIG_BLOCK 2 +# endif +# ifndef SIG_SETMASK +# define SIG_SETMASK 3 +# endif + int sigprocmask(int how, sigset_t *set, sigset_t *oset) { if (!set || !oset) { set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO); return -1; @@ -115,12 +116,15 @@ return -1; } return 0; - } -# define sigaction sigvec -# define sa_flags sv_onstack -# define sa_handler sv_handler -# define sa_mask sv_mask -# define sigsuspend(set) sigpause(*set) + } +# define sigaction sigvec +# define sa_flags sv_onstack +# 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 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; @@ -153,7 +157,6 @@ } # define times(t) vms_times(t) #else -# include <fcntl.h> # include <grp.h> # include <sys/times.h> # ifdef HAS_UNAME @@ -191,6 +194,9 @@ typedef struct termios* POSIX__Termios; /* Possibly needed prototypes */ char *cuserid _((char *)); +double strtod _((const char *, char **)); +long strtol _((const char *, char **, int)); +unsigned long strtoul _((const char *, char **, int)); #ifndef HAS_CUSERID #define cuserid(a) (char *) not_here("cuserid") @@ -227,6 +233,15 @@ char *cuserid _((char *)); #ifndef HAS_STRCOLL #define strcoll(s1,s2) not_here("strcoll") #endif +#ifndef HAS_STRTOD +#define strtod(s1,s2) not_here("strtod") +#endif +#ifndef HAS_STRTOL +#define strtol(s1,s2,b) not_here("strtol") +#endif +#ifndef HAS_STRTOUL +#define strtoul(s1,s2,b) not_here("strtoul") +#endif #ifndef HAS_STRXFRM #define strxfrm(s1,s2,n) not_here("strxfrm") #endif @@ -2654,6 +2669,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); + SET_NUMERIC_LOCAL(); if (lcbuf = localeconv()) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) @@ -2724,8 +2740,59 @@ setlocale(category, locale = 0) char * locale CODE: RETVAL = setlocale(category, locale); - if (RETVAL) - perl_init_fold(); + if (RETVAL) { +#ifdef USE_LOCALE_CTYPE + if (category == LC_CTYPE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newctype; +#ifdef LC_ALL + if (category == LC_ALL) + newctype = setlocale(LC_CTYPE, NULL); + else +#endif + newctype = RETVAL; + perl_new_ctype(newctype); + } +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (category == LC_COLLATE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newcoll; +#ifdef LC_ALL + if (category == LC_ALL) + newcoll = setlocale(LC_COLLATE, NULL); + else +#endif + newcoll = RETVAL; + perl_new_collate(newcoll); + } +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (category == LC_NUMERIC +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newnum; +#ifdef LC_ALL + if (category == LC_ALL) + newnum = setlocale(LC_NUMERIC, NULL); + else +#endif + newnum = RETVAL; + perl_new_numeric(newnum); + } +#endif /* USE_LOCALE_NUMERIC */ + } OUTPUT: RETVAL @@ -2950,8 +3017,7 @@ read(fd, buffer, nbytes) SvCUR(sv_buffer) = RETVAL; SvPOK_only(sv_buffer); *SvEND(sv_buffer) = '\0'; - if (tainting) - sv_magic(sv_buffer, 0, 't', 0, 0); + SvTAINTED_on(sv_buffer); } SysRet @@ -3034,6 +3100,66 @@ strcoll(s1, s2) char * s1 char * s2 +void +strtod(str) + char * str + PREINIT: + double num; + char *unparsed; + PPCODE: + SET_NUMERIC_LOCAL(); + num = strtod(str, &unparsed); + PUSHs(sv_2mortal(newSVnv(num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + +void +strtol(str, base = 0) + char * str + int base + PREINIT: + long num; + char *unparsed; + PPCODE: + num = strtol(str, &unparsed, base); + if (num >= IV_MIN && num <= IV_MAX) + PUSHs(sv_2mortal(newSViv((IV)num))); + else + PUSHs(sv_2mortal(newSVnv((double)num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + +void +strtoul(str, base = 0) + char * str + int base + PREINIT: + unsigned long num; + char *unparsed; + PPCODE: + num = strtoul(str, &unparsed, base); + if (num <= IV_MAX) + PUSHs(sv_2mortal(newSViv((IV)num))); + else + PUSHs(sv_2mortal(newSVnv((double)num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + SV * strxfrm(src) SV * src diff --git a/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index a02c73f28f..23bbfe9a67 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -231,7 +231,7 @@ register int siz; for (i = 1; i < n; i += 2) { if (siz == off - ino[i] && - memcmp(key, pag + ino[i], siz) == 0) + memEQ(key, pag + ino[i], siz)) return i; off = ino[i + 1]; } diff --git a/ext/SDBM_File/sdbm/pair.h b/ext/SDBM_File/sdbm/pair.h index bd66d02fd2..8a675b9065 100644 --- a/ext/SDBM_File/sdbm/pair.h +++ b/ext/SDBM_File/sdbm/pair.h @@ -1,3 +1,13 @@ +/* Mini EMBED (pair.c) */ +#define chkpage sdbm__chkpage +#define delpair sdbm__delpair +#define duppair sdbm__duppair +#define fitpair sdbm__fitpair +#define getnkey sdbm__getnkey +#define getpair sdbm__getpair +#define putpair sdbm__putpair +#define splpage sdbm__splpage + extern int fitpair proto((char *, int)); extern void putpair proto((char *, datum, datum)); extern datum getpair proto((char *, datum)); diff --git a/ext/SDBM_File/sdbm/sdbm.3 b/ext/SDBM_File/sdbm/sdbm.3 index f0f2d07c84..7e5c176404 100644 --- a/ext/SDBM_File/sdbm/sdbm.3 +++ b/ext/SDBM_File/sdbm/sdbm.3 @@ -1,7 +1,7 @@ .\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ .TH SDBM 3 "1 March 1990" .SH NAME -sdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines +sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B @@ -14,60 +14,60 @@ typedef struct { .sp datum nullitem = { NULL, 0 }; .sp -\s-1DBM\s0 *dbm_open(char *file, int flags, int mode) +\s-1DBM\s0 *sdbm_open(char *file, int flags, int mode) .sp -\s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode) +\s-1DBM\s0 *sdbm_prep(char *dirname, char *pagname, int flags, int mode) .sp -void dbm_close(\s-1DBM\s0 *db) +void sdbm_close(\s-1DBM\s0 *db) .sp -datum dbm_fetch(\s-1DBM\s0 *db, key) +datum sdbm_fetch(\s-1DBM\s0 *db, key) .sp -int dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) +int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp -int dbm_delete(\s-1DBM\s0 *db, datum key) +int sdbm_delete(\s-1DBM\s0 *db, datum key) .sp -datum dbm_firstkey(\s-1DBM\s0 *db) +datum sdbm_firstkey(\s-1DBM\s0 *db) .sp -datum dbm_nextkey(\s-1DBM\s0 *db) +datum sdbm_nextkey(\s-1DBM\s0 *db) .sp -long dbm_hash(char *string, int len) +long sdbm_hash(char *string, int len) .sp -int dbm_rdonly(\s-1DBM\s0 *db) -int dbm_error(\s-1DBM\s0 *db) -dbm_clearerr(\s-1DBM\s0 *db) -int dbm_dirfno(\s-1DBM\s0 *db) -int dbm_pagfno(\s-1DBM\s0 *db) +int sdbm_rdonly(\s-1DBM\s0 *db) +int sdbm_error(\s-1DBM\s0 *db) +sdbm_clearerr(\s-1DBM\s0 *db) +int sdbm_dirfno(\s-1DBM\s0 *db) +int sdbm_pagfno(\s-1DBM\s0 *db) .ft R .fi .SH DESCRIPTION .IX "database library" sdbm "" "\fLsdbm\fR" -.IX dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database" -.IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database" -.IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine" -.IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data" -.IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database" -.IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database" -.IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database" -.IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database" -.IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database" -.IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" -.IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" -.IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" -.IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" -.IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" -.IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP -.IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP -.IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP -.IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP -.IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP -.IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP -.IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP -.IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP -.IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP -.IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP -.IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP -.IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP -.IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP +.IX sdbm_open "" "\fLsdbm_open\fR \(em open \fLsdbm\fR database" +.IX sdbm_prep "" "\fLsdbm_prep\fR \(em prepare \fLsdbm\fR database" +.IX sdbm_close "" "\fLsdbm_close\fR \(em close \fLsdbm\fR routine" +.IX sdbm_fetch "" "\fLsdbm_fetch\fR \(em fetch \fLsdbm\fR database data" +.IX sdbm_store "" "\fLsdbm_store\fR \(em add data to \fLsdbm\fR database" +.IX sdbm_delete "" "\fLsdbm_delete\fR \(em remove data from \fLsdbm\fR database" +.IX sdbm_firstkey "" "\fLsdbm_firstkey\fR \(em access \fLsdbm\fR database" +.IX sdbm_nextkey "" "\fLsdbm_nextkey\fR \(em access \fLsdbm\fR database" +.IX sdbm_hash "" "\fLsdbm_hash\fR \(em string hash for \fLsdbm\fR database" +.IX sdbm_rdonly "" "\fLsdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" +.IX sdbm_error "" "\fLsdbm_error\fR \(em return \fLsdbm\fR database error condition" +.IX sdbm_clearerr "" "\fLsdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" +.IX sdbm_dirfno "" "\fLsdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" +.IX sdbm_pagfno "" "\fLsdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" +.IX "database functions \(em \fLsdbm\fR" sdbm_open "" \fLsdbm_open\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_prep "" \fLsdbm_prep\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_close "" \fLsdbm_close\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_fetch "" \fLsdbm_fetch\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_store "" \fLsdbm_store\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_delete "" \fLsdbm_delete\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_firstkey "" \fLsdbm_firstkey\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_nextkey "" \fLsdbm_nextkey\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_rdonly "" \fLsdbm_rdonly\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_error "" \fLsdbm_error\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_clearerr "" \fLsdbm_clearerr\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_dirfno "" \fLsdbm_dirfno\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_pagfno "" \fLsdbm_pagfno\fP .LP This package allows an application to maintain a mapping of <key,value> pairs in disk files. This is not to be considered a real database system, but is @@ -124,15 +124,15 @@ a .BR "DBM *" , to identify the database to be manipulated. Such a handle can be obtained from the only routines that do not require it, namely -.BR dbm_open (\|) +.BR sdbm_open (\|) or -.BR dbm_prep (\|). +.BR sdbm_prep (\|). Either of these will open or create the two necessary files. The difference is that the latter allows explicitly naming the bitmap and data files whereas -.BR dbm_open (\|) +.BR sdbm_open (\|) will take a base file name and call -.BR dbm_prep (\|) +.BR sdbm_prep (\|) with the default extensions. The .I flags @@ -142,18 +142,18 @@ parameters are the same as for .BR open (2). .LP To free the resources occupied while a database handle is active, call -.BR dbm_close (\|). +.BR sdbm_close (\|). .LP Given a handle, one can retrieve data associated with a key by using the -.BR dbm_fetch (\|) +.BR sdbm_fetch (\|) routine, and associate data with a key by using the -.BR dbm_store (\|) +.BR sdbm_store (\|) routine. .LP The values of the .I flags parameter for -.BR dbm_store (\|) +.BR sdbm_store (\|) can be either .BR \s-1DBM_INSERT\s0 , which will not change an existing entry with the same key, or @@ -162,14 +162,14 @@ which will replace an existing entry with the same key. Keys are unique within the database. .LP To delete a key and its associated value use the -.BR dbm_delete (\|) +.BR sdbm_delete (\|) routine. .LP To retrieve every key in the database, use a loop like: .sp .nf .ft B -for (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db)) +for (key = sdbm_firstkey(db); key.dptr != NULL; key = sdbm_nextkey(db)) ; .ft R .fi @@ -180,27 +180,27 @@ If you determine that the performance of the database is inadequate or you notice clustering or other effects that may be due to the hashing algorithm used by this package, you can override it by supplying your own -.BR dbm_hash (\|) +.BR sdbm_hash (\|) routine. Doing so will make the database unintelligable to any other applications that do not use your specialized hash function. .sp .LP The following macros are defined in the header file: .IP -.BR dbm_rdonly (\|) +.BR sdbm_rdonly (\|) returns true if the database has been opened read\-only. .IP -.BR dbm_error (\|) +.BR sdbm_error (\|) returns true if an I/O error has occurred. .IP -.BR dbm_clearerr (\|) +.BR sdbm_clearerr (\|) allows you to clear the error flag if you think you know what the error was and insist on ignoring it. .IP -.BR dbm_dirfno (\|) +.BR sdbm_dirfno (\|) returns the file descriptor associated with the bitmap file. .IP -.BR dbm_pagfno (\|) +.BR sdbm_pagfno (\|) returns the file descriptor associated with the data file. .SH SEE ALSO .IR open (2). @@ -220,7 +220,7 @@ will return to indicate an error. .LP As a special case of -.BR dbm_store (\|), +.BR sdbm_store (\|), if it is called with the .B \s-1DBM_INSERT\s0 flag and the key already exists in the database, the return value will be 1. @@ -281,10 +281,10 @@ header file should be installed in The .B nullitem data item, and the -.BR dbm_prep (\|), -.BR dbm_hash (\|), -.BR dbm_rdonly (\|), -.BR dbm_dirfno (\|), +.BR sdbm_prep (\|), +.BR sdbm_hash (\|), +.BR sdbm_rdonly (\|), +.BR sdbm_dirfno (\|), and -.BR dbm_pagfno (\|) +.BR sdbm_pagfno (\|) functions are unique to this package. diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index d4836be671..a62334c45e 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -135,7 +135,7 @@ int mode; * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ -# ifdef OS2 +#if defined(OS2) || defined(MSDOS) flags |= O_BINARY; # endif if ((db->pagf = open(pagname, flags, mode)) > -1) { diff --git a/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h index 8fcdda0f9f..4eeb147f43 100644 --- a/ext/SDBM_File/sdbm/sdbm.h +++ b/ext/SDBM_File/sdbm/sdbm.h @@ -79,15 +79,15 @@ extern DBM *sdbm_prep proto((char *, char *, int, int)); extern long sdbm_hash proto((char *, int)); #ifndef SDBM_ONLY -#define dbm_open sdbm_open; -#define dbm_close sdbm_close; -#define dbm_fetch sdbm_fetch; -#define dbm_store sdbm_store; -#define dbm_delete sdbm_delete; -#define dbm_firstkey sdbm_firstkey; -#define dbm_nextkey sdbm_nextkey; -#define dbm_error sdbm_error; -#define dbm_clearerr sdbm_clearerr; +#define dbm_open sdbm_open +#define dbm_close sdbm_close +#define dbm_fetch sdbm_fetch +#define dbm_store sdbm_store +#define dbm_delete sdbm_delete +#define dbm_firstkey sdbm_firstkey +#define dbm_nextkey sdbm_nextkey +#define dbm_error sdbm_error +#define dbm_clearerr sdbm_clearerr #endif /* Most of the following is stolen from perl.h. */ @@ -108,19 +108,6 @@ extern long sdbm_hash proto((char *, int)); # endif #endif -#ifdef MYMALLOC -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define realloc Myremalloc -# define free Myfree -# define calloc Mycalloc -# endif -# define safemalloc malloc -# define saferealloc realloc -# define safefree free -# define safecalloc calloc -#endif - #if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif @@ -163,6 +150,31 @@ extern long sdbm_hash proto((char *, int)); #define MEM_SIZE Size_t +/* This comes after <stdlib.h> so we don't try to change the standard + * library prototypes; we'll use our own instead. */ + +#if defined(MYMALLOC) && (defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)) + +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define calloc Mycalloc +# define realloc Myremalloc +# define free Myfree +# endif +# ifdef EMBEDMYMALLOC +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_free +# endif + + Malloc_t malloc proto((MEM_SIZE nbytes)); + Malloc_t calloc proto((MEM_SIZE elements, MEM_SIZE size)); + Malloc_t realloc proto((Malloc_t where, MEM_SIZE nbytes)); + Free_t free proto((Malloc_t where)); + +#endif /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */ + #ifdef I_STRING #include <string.h> #else @@ -173,14 +185,10 @@ extern long sdbm_hash proto((char *, int)); #include <memory.h> #endif -#if defined(mips) && defined(ultrix) && !defined(__STDC__) -# undef HAS_MEMCMP -#endif - #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy - extern char * memcpy _((char*, char*, int)); + extern char * memcpy proto((char*, char*, int)); # endif # endif #else @@ -196,7 +204,7 @@ extern long sdbm_hash proto((char *, int)); #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset - extern char *memset _((char*, int, int)); + extern char *memset proto((char*, int, int)); # endif # endif # define memzero(d,l) memset(d,0,l) @@ -210,24 +218,44 @@ extern long sdbm_hash proto((char *, int)); # endif #endif /* HAS_MEMSET */ -#ifdef HAS_MEMCMP +#if defined(mips) && defined(ultrix) && !defined(__STDC__) +# undef HAS_MEMCMP +#endif + +#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp - extern int memcmp _((char*, char*, int)); + extern int memcmp proto((char*, char*, int)); # endif # endif +# ifdef BUGGY_MSC + # pragma function(memcmp) +# endif #else # ifndef memcmp -# define memcmp my_memcmp +# /* maybe we should have included the full embedding header... */ +# ifdef NO_EMBED +# define memcmp my_memcmp +# else +# define memcmp Perl_my_memcmp +# endif + extern int memcmp proto((char*, char*, int)); # endif #endif /* HAS_MEMCMP */ -/* we prefer bcmp slightly for comparisons that don't care about ordering */ #ifndef HAS_BCMP # ifndef bcmp # define bcmp(s1,s2,l) memcmp(s1,s2,l) # endif -#endif /* HAS_BCMP */ +#endif /* !HAS_BCMP */ + +#ifdef HAS_MEMCMP +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#else +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif #ifdef I_NETINET_IN # include <netinet/in.h> diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 9872d03526..e04689d9b8 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; use vars qw($VERSION @ISA @EXPORT); -$VERSION = "1.5"; +$VERSION = "1.6"; =head1 NAME @@ -52,7 +52,8 @@ In addition, some structure manipulation functions are available: Takes a string giving the name of a host, and translates that to the 4-byte string (structure). Takes arguments of both the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name -cannot be resolved, returns undef. +cannot be resolved, returns undef. For multi-homed hosts (hosts +with more than one address), the first address found is returned. =item inet_ntoa IP_ADDRESS @@ -72,6 +73,15 @@ a particular network interface. This wildcard address allows you to bind to all of them simultaneously.) Normally equivalent to inet_aton('0.0.0.0'). +=item INADDR_BROADCAST + +Note: does not return a number, but a packed string. + +Returns the 4-byte 'this-lan' ip broadcast address. +This can be useful for some protocols to solicit information +from all servers on the same LAN cable. +Normally equivalent to inet_aton('255.255.255.255'). + =item INADDR_LOOPBACK Note - does not return a number. @@ -83,7 +93,7 @@ to inet_aton('localhost'). Note - does not return a number. -Returns the 4-byte invalid ip address. Normally equivalent +Returns the 4-byte 'invalid' ip address. Normally equivalent to inet_aton('255.255.255.255'). =item sockaddr_in PORT, ADDRESS @@ -145,7 +155,7 @@ require DynaLoader; inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un sockaddr_in sockaddr_un - INADDR_ANY INADDR_LOOPBACK INADDR_NONE + INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 6c39557185..7e3e3b375d 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -30,10 +30,117 @@ #ifndef INADDR_NONE #define INADDR_NONE 0xffffffff #endif /* INADDR_NONE */ +#ifndef INADDR_BROADCAST +#define INADDR_BROADCAST 0xffffffff +#endif /* INADDR_BROADCAST */ #ifndef INADDR_LOOPBACK #define INADDR_LOOPBACK 0x7F000001 #endif /* INADDR_LOOPBACK */ +#ifndef HAS_INET_ATON + +/* + * Check whether "cp" is a valid ascii representation + * of an Internet address and convert to a binary address. + * Returns 1 if the address is valid, 0 if not. + * This replaces inet_addr, the return value from which + * cannot distinguish between failure and a local broadcast address. + */ +static int +my_inet_aton(cp, addr) +register const char *cp; +struct in_addr *addr; +{ + register unsigned long val; + register int base; + register char c; + int nparts; + const char *s; + unsigned int parts[4]; + register unsigned int *pp = parts; + + for (;;) { + /* + * Collect number up to ``.''. + * Values are specified as for C: + * 0x=hex, 0=octal, other=decimal. + */ + val = 0; base = 10; + if (*cp == '0') { + if (*++cp == 'x' || *cp == 'X') + base = 16, cp++; + else + base = 8; + } + while ((c = *cp) != '\0') { + if (isDIGIT(c)) { + val = (val * base) + (c - '0'); + cp++; + continue; + } + if (base == 16 && (s=strchr(hexdigit,c))) { + val = (val << 4) + + ((s - hexdigit) & 15); + cp++; + continue; + } + break; + } + if (*cp == '.') { + /* + * Internet format: + * a.b.c.d + * a.b.c (with c treated as 16-bits) + * a.b (with b treated as 24 bits) + */ + if (pp >= parts + 3 || val > 0xff) + return 0; + *pp++ = val, cp++; + } else + break; + } + /* + * Check for trailing characters. + */ + if (*cp && !isSPACE(*cp)) + return 0; + /* + * Concoct the address according to + * the number of parts specified. + */ + nparts = pp - parts + 1; /* force to an int for switch() */ + switch (nparts) { + + case 1: /* a -- 32 bits */ + break; + + case 2: /* a.b -- 8.24 bits */ + if (val > 0xffffff) + return 0; + val |= parts[0] << 24; + break; + + case 3: /* a.b.c -- 8.8.16 bits */ + if (val > 0xffff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16); + break; + + case 4: /* a.b.c.d -- 8.8.8.8 bits */ + if (val > 0xff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); + break; + } + addr->s_addr = htonl(val); + return 1; +} + +#undef inet_aton +#define inet_aton my_inet_aton + +#endif /* ! HAS_INET_ATON */ + static int not_here(s) @@ -595,15 +702,17 @@ inet_aton(host) { struct in_addr ip_address; struct hostent * phe; + int ok; if (phe = gethostbyname(host)) { Copy( phe->h_addr, &ip_address, phe->h_length, char ); + ok = 1; } else { - ip_address.s_addr = inet_addr(host); + ok = inet_aton(host, &ip_address); } ST(0) = sv_newmortal(); - if(ip_address.s_addr != INADDR_NONE) { + if (ok) { sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address ); } } @@ -748,3 +857,12 @@ INADDR_NONE() ip_address.s_addr = htonl(INADDR_NONE); ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); } + +void +INADDR_BROADCAST() + CODE: + { + struct in_addr ip_address; + ip_address.s_addr = htonl(INADDR_BROADCAST); + ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + } diff --git a/global.sym b/global.sym index 62f7064576..6ffac19fee 100644 --- a/global.sym +++ b/global.sym @@ -3,9 +3,9 @@ # Variables AMG_names +Error No Sv -He Xpv Yes abs_amg @@ -16,6 +16,7 @@ amagic_generation an atan2_amg band_amg +block_type bool__amg bor_amg buf @@ -23,9 +24,14 @@ bufend bufptr bxor_amg check +collation_ix +collation_name +collation_standard +collxfrm_base +collxfrm_mult +compcv compiling compl_amg -compcv comppad comppad_name comppad_name_fill @@ -37,8 +43,6 @@ cos_amg cryptseen cshlen cshname -curcop -curcopdb curinterp curpad cv_const_sv @@ -51,7 +55,6 @@ div_ass_amg do_undump ds egid -envgv eq_amg error_count euid @@ -60,10 +63,8 @@ exp_amg expect expectterm fallback_amg -filter_add -filter_del -filter_read fold +fold_locale freq ge_amg gid @@ -77,24 +78,23 @@ know_next last_lop last_lop_op last_uni -lc_collate_active le_amg -lex_state -lex_defer -lex_expect lex_brackets -lex_formbrack -lex_fakebrack +lex_brackstack lex_casemods +lex_casestack +lex_defer lex_dojoin -lex_starts -lex_stuff -lex_repl -lex_op +lex_expect +lex_fakebrack +lex_formbrack lex_inpat lex_inwhat -lex_brackstack -lex_casestack +lex_op +lex_repl +lex_starts +lex_state +lex_stuff linestr log_amg lshift_amg @@ -103,8 +103,8 @@ lt_amg markstack markstack_max markstack_ptr -maxo max_intro_pending +maxo min_intro_pending mod_amg mod_ass_amg @@ -116,27 +116,33 @@ multi_open multi_start na ncmp_amg -nextval -nexttype -nexttoke ne_amg neg_amg +nexttoke nexttype nextval +nice_chunk +nice_chunk_size no_aelem no_dir_func no_func no_helem no_mem no_modify +no_myglob no_security no_sock_func +no_symref no_usym +no_wrongref nointrp nomem nomemok nomethod_amg not_amg +numeric_local +numeric_name +numeric_standard numer_amg oldbufptr oldoldbufptr @@ -148,15 +154,18 @@ opargs origalen origenviron osname +pad_reset_pending padix +padix_floor patleave +pidstatus pow_amg pow_ass_amg ppaddr profiledata provide_ref -psig_ptr psig_name +psig_ptr qrt_amg rcsid reall_srchlen @@ -166,7 +175,7 @@ regcode regdummy regendp regeol -regfold +regflags reginput regkind reglastparen @@ -193,7 +202,6 @@ rsfp rsfp_filters rshift_amg rshift_ass_amg -save_pptr savestack savestack_ix savestack_max @@ -206,10 +214,9 @@ scrgv seq_amg sge_amg sgt_amg +sh_path sig_name sig_num -siggv -sighandler simple sin_amg sle_amg @@ -228,23 +235,26 @@ subtr_ass_amg sv_no sv_undef sv_yes -tainting thisexpr timesbuf tokenbuf uid varies vert +vivify_itervar vtbl_amagic vtbl_amagicelem vtbl_arylen vtbl_bm +vtbl_collxfrm vtbl_dbline vtbl_env vtbl_envelem +vtbl_fm vtbl_glob vtbl_isa vtbl_isaelem +vtbl_itervar vtbl_mglob vtbl_nkeys vtbl_pack @@ -260,6 +270,7 @@ vtbl_vec warn_nl warn_nosemi warn_reserved +warn_uninit watchaddr watchok yychar @@ -283,6 +294,10 @@ yyval # Functions Gv_AMupdate +SvTRUE +SvIV +SvUV +SvNV amagic_call append_elem append_list @@ -304,20 +319,24 @@ av_unshift bind_match block_end block_start +boot_core_UNIVERSAL calllist cando cast_ulong check_uni checkcomma ck_aelem +ck_anoncode +ck_bitop ck_concat ck_delete ck_eof ck_eval ck_exec -ck_formline +ck_exists ck_ftst ck_fun +ck_fun_locale ck_glob ck_grep ck_gvconst @@ -332,6 +351,7 @@ ck_require ck_retarget ck_rfun ck_rvconst +ck_scmp ck_select ck_shift ck_sort @@ -415,6 +435,7 @@ gp_ref gv_AVadd gv_HVadd gv_IOadd +gv_autoload gv_check gv_efullname gv_efullname3 @@ -452,8 +473,10 @@ hv_store hv_store_ent hv_undef ibcmp +ibcmp_locale ingroup instr +intro_my intuit_more invert jmaybe @@ -470,9 +493,11 @@ magic_clearenv magic_clearpack magic_clearsig magic_existspack +magic_freeitervar magic_get magic_getarylen magic_getglob +magic_getitervar magic_getpack magic_getpos magic_getsig @@ -484,10 +509,13 @@ magic_set magic_setamagic magic_setarylen magic_setbm +magic_setcollxfrm magic_setdbline magic_setenv +magic_setfm magic_setglob magic_setisa +magic_setitervar magic_setmglob magic_setnkeys magic_setpack @@ -956,8 +984,21 @@ regnext regprop repeatcpy rninstr +rsignal +rsignal_save +rsignal_state +rsignal_restore runops +safecalloc +safemalloc +safefree +saferealloc +safexcalloc +safexmalloc +safexfree +safexrealloc same_dirent +save_I16 save_I32 save_aptr save_ary @@ -967,10 +1008,12 @@ save_destructor save_freeop save_freepv save_freesv +save_gp save_hash save_hptr save_int save_item +save_iv save_list save_long save_nogv @@ -1004,13 +1047,13 @@ scope screaminstr setdefout setenv_getix +share_hek sharepvn sighandler skipspace stack_grow start_subparse -sublex_done -sublex_start +sub_crush_depth sv_2bool sv_2cv sv_2io @@ -1018,6 +1061,7 @@ sv_2iv sv_2mortal sv_2nv sv_2pv +sv_2uv sv_add_arena sv_backoff sv_bless @@ -1029,7 +1073,10 @@ sv_clean_all sv_clean_objs sv_clear sv_cmp +sv_cmp_locale +sv_collxfrm sv_dec +sv_derived_from sv_dump sv_eq sv_free @@ -1046,6 +1093,7 @@ sv_mortalcopy sv_newmortal sv_newref sv_peek +sv_pvn sv_pvn_force sv_ref sv_reftype @@ -1062,16 +1110,20 @@ sv_setref_nv sv_setref_pv sv_setref_pvn sv_setsv +sv_setuv +sv_taint +sv_tainted sv_unmagic sv_unref +sv_untaint sv_upgrade sv_usepvn taint_env -taint_not taint_proper too_few_arguments too_many_arguments unlnk +unshare_hek unsharepvn utilize wait4pid @@ -1084,6 +1136,7 @@ xnv_root xpv_root xrv_root yyerror +yydestruct yylex yyparse yywarn @@ -19,7 +19,7 @@ #include "EXTERN.h" #include "perl.h" -extern char rcsid[]; +EXT char rcsid[]; GV * gv_AVadd(gv) @@ -59,12 +59,16 @@ gv_fetchfile(name) char *name; { char tmpbuf[1200]; + STRLEN tmplen; GV *gv; - sprintf(tmpbuf,"::_<%s", name); - gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); + sprintf(tmpbuf, "_<%s", name); + tmplen = strlen(tmpbuf); + gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); + if (!isGV(gv)) + gv_init(gv, defstash, tmpbuf, tmplen, FALSE); sv_setpv(GvSV(gv), name); - if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) + if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) GvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); @@ -84,9 +88,8 @@ int multi; sv_upgrade((SV*)gv, SVt_PVGV); if (SvLEN(gv)) Safefree(SvPVX(gv)); - Newz(602,gp, 1, GP); + Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); - GvREFCNT(gv) = 1; GvSV(gv) = NEWSV(72,0); GvLINE(gv) = curcop->cop_line; GvFILEGV(gv) = curcop->cop_filegv; @@ -133,29 +136,28 @@ I32 level; if (!stash) return 0; - if (level > 100) + if ((level > 100) || (level < -100)) croak("Recursive inheritance detected"); - gvp = (GV**)hv_fetch(stash, name, len, TRUE); - DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); - topgv = *gvp; - if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); - - if (cv=GvCV(topgv)) { - if (GvCVGEN(topgv) >= sub_generation) - return topgv; /* valid cached inheritance */ - if (!GvCVGEN(topgv)) { /* not an inheritance cache */ - return topgv; - } - else { - /* stale cached entry, just junk it */ - GvCV(topgv) = cv = 0; + + gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + if (!gvp) + topgv = Nullgv; + else { + topgv = *gvp; + if (SvTYPE(topgv) != SVt_PVGV) + gv_init(topgv, stash, name, len, TRUE); + if (cv = GvCV(topgv)) { + /* If genuine method or valid cache entry, use it */ + if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) + return topgv; + /* Stale cached entry: junk it */ + SvREFCNT_dec(cv); + GvCV(topgv) = cv = Nullcv; GvCVGEN(topgv) = 0; } } - /* if cv is still set, we have to free it if we find something to cache */ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { @@ -170,30 +172,25 @@ I32 level; SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len, level + 1); - if (gv) { - if (cv) { /* junk old undef */ - assert(SvREFCNT(topgv) > 1); - SvREFCNT_dec(topgv); - SvREFCNT_dec(cv); - } - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ - return gv; - } + gv = gv_fetchmeth(basestash, name, len, + (level >= 0) ? level + 1 : level - 1); + if (gv) + goto gotcha; } } - if (!level) { + if (level == 0 || level == -1) { if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { - if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { - if (cv) { /* junk old undef */ - assert(SvREFCNT(topgv) > 1); - SvREFCNT_dec(topgv); - SvREFCNT_dec(cv); + if (gv = gv_fetchmeth(lastchance, name, len, + (level >= 0) ? level + 1 : level - 1)) { + gotcha: + /* Use topgv for cache only if it has no synonyms */ + if (topgv && GvREFCNT(topgv) == 1) { + if (cv = GvCV(topgv)) + SvREFCNT_dec(cv); + GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); + GvCVGEN(topgv) = sub_generation; } - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; } } @@ -274,22 +271,50 @@ char* name; } if (!gv) { - CV* cv; - - if (strEQ(name,"import") || strEQ(name,"unimport")) + if (strEQ(name,"import")) gv = (GV*)&sv_yes; - else if (strNE(name, "AUTOLOAD")) { - gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0); - if (gv && (cv = GvCV(gv))) { /* One more chance... */ - SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); - sv_catpvn(tmpstr,"::", 2); - sv_catpvn(tmpstr, name, nend - name); - sv_setsv(GvSV(CvGV(cv)), tmpstr); - if (tainting) - sv_unmagic(GvSV(CvGV(cv)), 't'); - } - } + else + gv = gv_autoload(stash, name, nend - name); } + + return gv; +} + +GV* +gv_autoload(stash, name, len) +HV* stash; +char* name; +STRLEN len; +{ + static char autoload[] = "AUTOLOAD"; + static STRLEN autolen = 8; + GV* gv; + CV* cv; + HV* varstash; + GV* vargv; + SV* varsv; + + if (len == autolen && strnEQ(name, autoload, autolen)) + return Nullgv; + if (!(gv = gv_fetchmeth(stash, autoload, autolen, 0))) + return Nullgv; + cv = GvCV(gv); + + /* + * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. + * The subroutine's original name may not be "AUTOLOAD", so we don't + * use that, but for lack of anything better we will use the sub's + * original package to look up $AUTOLOAD. + */ + varstash = GvSTASH(CvGV(cv)); + vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + if (!isGV(vargv)) + gv_init(vargv, varstash, autoload, autolen, FALSE); + varsv = GvSV(vargv); + sv_setpv(varsv, HvNAME(stash)); + sv_catpvn(varsv, "::", 2); + sv_catpvn(varsv, name, len); + SvTAINTED_off(varsv); return gv; } @@ -466,7 +491,7 @@ I32 sv_type; sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); - if (GvCV(*gvp)) + if (GvCVu(*gvp)) warn("(Did you mean &%s instead?)\n", name); stash = 0; } @@ -799,8 +824,19 @@ gp_ref(gp) GP* gp; { gp->gp_refcnt++; + if (gp->gp_cv) { + if (gp->gp_cvgen) { + /* multi-named GPs cannot be used for method cache */ + SvREFCNT_dec(gp->gp_cv); + gp->gp_cv = Nullcv; + gp->gp_cvgen = 0; + } + else { + /* Adding a new name to a subroutine invalidates method cache */ + sub_generation++; + } + } return gp; - } void @@ -816,6 +852,10 @@ GV* gv; warn("Attempt to free unreferenced glob pointers"); return; } + if (gp->gp_cv) { + /* Deleting the name of a subroutine invalidates method cache */ + sub_generation++; + } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; @@ -826,8 +866,7 @@ GV* gv; SvREFCNT_dec(gp->gp_av); SvREFCNT_dec(gp->gp_hv); SvREFCNT_dec(gp->gp_io); - if ((cv = gp->gp_cv) && !GvCVGEN(gv)) - SvREFCNT_dec(cv); + SvREFCNT_dec(gp->gp_cv); SvREFCNT_dec(gp->gp_form); Safefree(gp); @@ -871,14 +910,14 @@ HV* stash; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; + AMT amt; if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && amtp->was_ok_sub == sub_generation) - return HV_AMAGIC(stash)? TRUE: FALSE; - gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); - if (amtp && amtp->table) { + return AMT_AMAGIC(amtp); + if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; - for (i=1;i<NofAMmeth*2;i++) { + for (i=1; i<NofAMmeth; i++) { if (amtp->table[i]) { SvREFCNT_dec(amtp->table[i]); } @@ -888,38 +927,32 @@ HV* stash; DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); + amt.was_ok_am = amagic_generation; + amt.was_ok_sub = sub_generation; + amt.fallback = AMGfallNO; + amt.flags = 0; + +#ifdef OVERLOAD_VIA_HASH + gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) { int filled=0; int i; char *cp; - AMT amt; SV* sv; SV** svp; - GV** gvp; - -/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) { - DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash)) -); - return HV_AMAGIC(stash)? TRUE: FALSE; - }*/ - - amt.was_ok_am=amagic_generation; - amt.was_ok_sub=sub_generation; - amt.fallback=AMGfallNO; /* Work with "fallback" key, which we assume to be first in AMG_names */ - if ((cp=((char**)(*AMG_names))[0]) && - (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { + if (( cp = (char *)AMG_names[0] ) && + (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; } - - for (i=1;i<NofAMmeth*2;i++) { - cv=0; - - if ( (cp=((char**)(*AMG_names))[i]) ) { - svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE); + for (i = 1; i < NofAMmeth; i++) { + cv = 0; + cp = (char *)AMG_names[i]; + + svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); if (svp && ((sv = *svp) != &sv_undef)) { switch (SvTYPE(sv)) { default: @@ -935,35 +968,97 @@ HV* stash; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: - die("Not a subroutine reference in overload table"); + croak("Not a subroutine reference in overload table"); return FALSE; case SVt_PVCV: - cv = (CV*)sv; - break; + cv = (CV*)sv; + break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); - break; + if (!(cv = GvCVu((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, TRUE); + break; } if (cv) filled=1; else { - die("Method for operation %s not found in package %.256s during blessing\n", + croak("Method for operation %s not found in package %.256s during blessing\n", cp,HvNAME(stash)); return FALSE; } } - } - amt.table[i]=(CV*)SvREFCNT_inc(cv); +#else + { + int filled = 0; + int i; + char *cp; + SV* sv = NULL; + SV** svp; + + /* Work with "fallback" key, which we assume to be first in AMG_names */ + + if ( cp = (char *)AMG_names[0] ) { + /* Try to find via inheritance. */ + gv = gv_fetchmeth(stash, "()", 2, 0); /* A cooky: "()". */ + if (gv) sv = GvSV(gv); + + if (!sv) /* Empty */; + else if (SvTRUE(sv)) amt.fallback=AMGfallYES; + else if (SvOK(sv)) amt.fallback=AMGfallNEVER; + } + + for (i = 1; i < NofAMmeth; i++) { + cv = 0; + cp = (char *)AMG_names[i]; + + *buf = '('; /* A cooky: "(". */ + strcpy(buf + 1, cp); + DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", + cp, HvNAME(stash)) ); + gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */ + if(gv && (cv = GvCV(gv))) { + char *name = buf; + if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") + && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + /* GvSV contains the name of the method. */ + GV *ngv; + + DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", + SvPV(GvSV(gv), na), cp, HvNAME(stash)) ); + if (SvPOK(GvSV(gv)) + && (ngv = gv_fetchmethod(stash, SvPVX(GvSV(gv))))) { + name = SvPVX(GvSV(gv)); + cv = GvCV(gv = ngv); + } else { + /* Can be an import stub (created by `can'). */ + if (GvCVGEN(gv)) { + croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } else + croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } + /* If the sub is only a stub then we may have a gv to AUTOLOAD */ + gv = (GV*)*hv_fetch(GvSTASH(gv), name, strlen(name), TRUE); + cv = GvCV(gv); + } + DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", + cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } +#endif + amt.table[i]=(CV*)SvREFCNT_inc(cv); } - sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt)); if (filled) { -/* HV_badAMAGIC_off(stash);*/ - HV_AMAGIC_on(stash); + AMT_AMAGIC_on(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); return TRUE; } } -/*HV_badAMAGIC_off(stash);*/ - HV_AMAGIC_off(stash); + /* Here we have no table: */ + AMT_AMAGIC_off(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); return FALSE; } @@ -986,7 +1081,9 @@ int flags; HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) - && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table)) + && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ @@ -1079,7 +1176,9 @@ int flags; if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) - && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table)) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1116,7 +1215,7 @@ int flags; goto not_found; } } else { - not_found: /* No method found, either report or die */ + not_found: /* No method found, either report or croak */ if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { @@ -1124,7 +1223,7 @@ int flags; } else { if (off==-1) off=method; sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s", - ((char**)AMG_names)[method + assignshift], + AMG_names[method + assignshift], SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -1140,7 +1239,7 @@ int flags; if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( deb(buf) ); } else { - die(buf); + croak(buf); } return NULL; } @@ -1148,11 +1247,11 @@ int flags; } if (!notfound) { DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", - ((char**)AMG_names)[off], + AMG_names[off], method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - ((char**)AMG_names)[method+assignshift], + AMG_names[method+assignshift], method+assignshift==off? "" : "')", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", @@ -1190,7 +1289,7 @@ int flags; PUSHs(lr>0? left: right); PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no)); if (notfound) { - PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) ); + PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); } PUSHs((SV*)cv); PUTBACK; @@ -1231,14 +1330,14 @@ int flags; ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: - SvSetSV(left,res); return res; break; + SvSetSV(left,res); return left; case not_amg: -ans=!SvOK(res); break; + ans=!SvOK(res); break; } return ans? &sv_yes: &sv_no; } else if (method==copy_amg) { if (!SvROK(res)) { - die("Copy method did not return a reference"); + croak("Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else { @@ -42,7 +42,9 @@ struct gp { #define GvFORM(gv) (GvGP(gv)->gp_form) #define GvAV(gv) (GvGP(gv)->gp_av) -#define GvREFCNT_inc(gv) ((GV*)SvREFCNT_inc(gv)) + +/* This macro is deprecated. Do not use! */ +#define GvREFCNT_inc(gv) ((GV*)SvREFCNT_inc(gv)) /* DO NOT USE */ #ifdef MICROPORT /* Microport 2.4 hack */ AV *GvAVn(); @@ -63,6 +65,7 @@ HV *GvHVn(); #define GvCV(gv) (GvGP(gv)->gp_cv) #define GvCVGEN(gv) (GvGP(gv)->gp_cvgen) +#define GvCVu(gv) (GvGP(gv)->gp_cvgen ? Nullcv : GvGP(gv)->gp_cv) #define GvLASTEXPR(gv) (GvGP(gv)->gp_lastexpr) @@ -113,7 +113,7 @@ typedef unsigned short U16; # define U32_MIN PERL_ULONG_MIN #endif -#define Ctl(ch) (ch & 037) +#define Ctl(ch) ((ch) & 037) #define strNE(s1,s2) (strcmp(s1,s2)) #define strEQ(s1,s2) (!strcmp(s1,s2)) @@ -124,46 +124,97 @@ typedef unsigned short U16; #define strnNE(s1,s2,l) (strncmp(s1,s2,l)) #define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) +#ifdef HAS_MEMCMP +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#else +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +/* + * Character classes. + * + * Unfortunately, the introduction of locales means that we + * can't trust isupper(), etc. to tell the truth. And when + * it comes to /\w+/ with tainting enabled, we *must* be able + * to trust our character classes. + * + * Therefore, the default tests in the text of Perl will be + * independent of locale. Any code that wants to depend on + * the current locale will use the tests that begin with "lc". + */ + #ifdef HAS_SETLOCALE /* XXX Is there a better test for this? */ # ifndef CTYPE256 # define CTYPE256 # endif #endif -#ifdef USE_NEXT_CTYPE -#define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_') -#define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_') -#define isALPHA(c) NXIsAlpha((unsigned int)c) -#define isSPACE(c) NXIsSpace((unsigned int)c) -#define isDIGIT(c) NXIsDigit((unsigned int)c) -#define isUPPER(c) NXIsUpper((unsigned int)c) -#define isLOWER(c) NXIsLower((unsigned int)c) -#define toUPPER(c) NXToUpper((unsigned int)c) -#define toLOWER(c) NXToLower((unsigned int)c) -#else /* USE_NEXT_CTYPE */ -#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) -#define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_') -#define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_') -#define isALPHA(c) isalpha((unsigned char)(c)) -#define isSPACE(c) isspace((unsigned char)(c)) -#define isDIGIT(c) isdigit((unsigned char)(c)) -#define isUPPER(c) isupper((unsigned char)(c)) -#define isLOWER(c) islower((unsigned char)(c)) -#define toUPPER(c) toupper((unsigned char)(c)) -#define toLOWER(c) tolower((unsigned char)(c)) -#else -#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_')) -#define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_')) -#define isALPHA(c) (isascii(c) && isalpha(c)) -#define isSPACE(c) (isascii(c) && isspace(c)) -#define isDIGIT(c) (isascii(c) && isdigit(c)) -#define isUPPER(c) (isascii(c) && isupper(c)) -#define isLOWER(c) (isascii(c) && islower(c)) -#define toUPPER(c) toupper(c) -#define toLOWER(c) tolower(c) -#endif +#define isALNUM(c) (isALPHA(c) || isDIGIT(c) || (c) == '_') +#define isIDFIRST(c) (isALPHA(c) || (c) == '_') +#define isALPHA(c) (isUPPER(c) || isLOWER(c)) +#define isSPACE(c) \ + ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f') +#define isDIGIT(c) ((c) >= '0' && (c) <= '9') +#define isUPPER(c) ((c) >= 'A' && (c) <= 'Z') +#define isLOWER(c) ((c) >= 'a' && (c) <= 'z') +#define isPRINT(c) (((c) > 32 && (c) < 127) || isSPACE(c)) +#define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c)) +#define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c)) + +#ifdef USE_NEXT_CTYPE + +# define isALNUM_LC(c) \ + (NXIsAlpha((unsigned int)(c)) || NXIsDigit((unsigned int)(c)) || \ + (char)(c) == '_') +# define isIDFIRST_LC(c) \ + (NXIsAlpha((unsigned int)(c)) || (char)(c) == '_') +# define isALPHA_LC(c) NXIsAlpha((unsigned int)(c)) +# define isSPACE_LC(c) NXIsSpace((unsigned int)(c)) +# define isDIGIT_LC(c) NXIsDigit((unsigned int)(c)) +# define isUPPER_LC(c) NXIsUpper((unsigned int)(c)) +# define isLOWER_LC(c) NXIsLower((unsigned int)(c)) +# define isPRINT_LC(c) NXIsPrint((unsigned int)(c)) +# define toUPPER_LC(c) NXToUpper((unsigned int)(c)) +# define toLOWER_LC(c) NXToLower((unsigned int)(c)) + +#else /* !USE_NEXT_CTYPE */ +# if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) + +# define isALNUM_LC(c) \ + (isalpha((unsigned char)(c)) || \ + isdigit((unsigned char)(c)) || (char)(c) == '_') +# define isIDFIRST_LC(c) (isalpha((unsigned char)(c)) || (char)(c) == '_') +# define isALPHA_LC(c) isalpha((unsigned char)(c)) +# define isSPACE_LC(c) isspace((unsigned char)(c)) +# define isDIGIT_LC(c) isdigit((unsigned char)(c)) +# define isUPPER_LC(c) isupper((unsigned char)(c)) +# define isLOWER_LC(c) islower((unsigned char)(c)) +# define isPRINT_LC(c) isprint((unsigned char)(c)) +# define toUPPER_LC(c) toupper((unsigned char)(c)) +# define toLOWER_LC(c) tolower((unsigned char)(c)) + +# else + +# define isALNUM_LC(c) \ + (isascii(c) && (isalpha(c) || isdigit(c) || (c) == '_')) +# define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_')) +# define isALPHA_LC(c) (isascii(c) && isalpha(c)) +# define isSPACE_LC(c) (isascii(c) && isspace(c)) +# define isDIGIT_LC(c) (isascii(c) && isdigit(c)) +# define isUPPER_LC(c) (isascii(c) && isupper(c)) +# define isLOWER_LC(c) (isascii(c) && islower(c)) +# define isPRINT_LC(c) (isascii(c) && isprint(c)) +# define toUPPER_LC(c) toupper(c) +# define toLOWER_LC(c) tolower(c) + +# endif #endif /* USE_NEXT_CTYPE */ +/* This conversion works both ways, strangely enough. */ +#define toCTRL(c) (toUPPER(c) ^ 64) + /* Line numbers are unsigned, 16 bits. */ typedef U16 line_t; #ifdef lint @@ -181,71 +232,59 @@ typedef U16 line_t; Renew macros. --Andy Dougherty August 1996 */ + #ifndef lint #ifndef LEAKTEST -#ifndef safemalloc -# ifdef __cplusplus - extern "C" { -# endif -Malloc_t safemalloc _((MEM_SIZE)); -Malloc_t saferealloc _((Malloc_t, MEM_SIZE)); -Free_t safefree _((Malloc_t)); -Malloc_t safecalloc _((MEM_SIZE, MEM_SIZE)); -# ifdef __cplusplus - } -# endif -#endif -#ifndef MSDOS -#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#else -#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)saferealloc((Malloc_t)(v),((unsigned long)(n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)saferealloc((Malloc_t)(v),((unsigned long)(n)*sizeof(t)))) -#endif /* MSDOS */ -#define Safefree(d) safefree((Malloc_t)(d)) -#define NEWSV(x,len) newSV(len) +#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n)*sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))), \ + memzero((char*)(v), (n)*sizeof(t)) +#define Renew(v,n,t) \ + (v = (t*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) \ + (v = (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Safefree(d) safefree((Malloc_t)(d)) +#define NEWSV(x,len) newSV(len) + #else /* LEAKTEST */ -Malloc_t safexmalloc(); -Malloc_t safexrealloc(); -Free_t safexfree(); -Malloc_t safexcalloc(); -#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Safefree(d) safexfree((Malloc_t)d) -#define NEWSV(x,len) newSV(x,len) + +#define New(x,v,n,t) (v = (t*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t)))), \ + memzero((char*)(v), (n)*sizeof(t)) +#define Renew(v,n,t) \ + (v = (t*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) \ + (v = (c*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Safefree(d) safexfree((Malloc_t)d) +#define NEWSV(x,len) newSV(x,len) + #define MAXXCOUNT 1200 long xcount[MAXXCOUNT]; long lastxcount[MAXXCOUNT]; + #endif /* LEAKTEST */ -#define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) -#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) -#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) + +#define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) + #else /* lint */ -#define New(x,v,n,s) (v = Null(s *)) -#define Newc(x,v,n,s,c) (v = Null(s *)) -#define Newz(x,v,n,s) (v = Null(s *)) -#define Renew(v,n,s) (v = Null(s *)) + +#define New(x,v,n,s) (v = Null(s *)) +#define Newc(x,v,n,s,c) (v = Null(s *)) +#define Newz(x,v,n,s) (v = Null(s *)) +#define Renew(v,n,s) (v = Null(s *)) #define Move(s,d,n,t) #define Copy(s,d,n,t) #define Zero(d,n,t) -#define Safefree(d) d = d +#define Safefree(d) (d) = (d) + #endif /* lint */ #ifdef USE_STRUCT_COPY -#define StructCopy(s,d,t) *((t*)(d)) = *((t*)(s)) +#define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s))) #else #define StructCopy(s,d,t) Copy(s,d,1,t) #endif diff --git a/hints/amigaos.sh b/hints/amigaos.sh new file mode 100644 index 0000000000..8328c8a3d3 --- /dev/null +++ b/hints/amigaos.sh @@ -0,0 +1,43 @@ +# hints/amigaos.sh +# +# talk to pueschel@imsdd.meb.uni-bonn.de if you want to change this file. +# +# misc stuff +archname='m68k-amigaos' +cc='gcc' +firstmakefile='GNUmakefile' +ccflags='-DAMIGAOS -mstackextend' +optimize='-O2 -fomit-frame-pointer' + +cppminus=' ' +cpprun='cpp' +cppstdin='cpp' + +usenm='y' +usemymalloc='n' +usevfork='true' +useperlio='true' +d_eofnblk='define' +d_fork='undef' +d_vfork='define' +groupstype='int' + +# libs + +libpth="/local/lib $prefix/lib" +glibpth="$libpth" +xlibpth="$libpth" + +libswanted='dld m c gdbm' +so=' ' + +# dynamic loading + +dlext='o' +cccdlflags='none' +ccdlflags='none' +lddlflags='-oformat a.out-amiga -r' + +# Avoid telldir prototype conflict in pp_sys.c (AmigaOS uses const DIR *) +# Configure should test for this. Volunteers? +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' diff --git a/hints/aux.sh b/hints/aux_3.sh index e0aec237bc..aa3150afbe 100644 --- a/hints/aux.sh +++ b/hints/aux_3.sh @@ -1,9 +1,10 @@ -# hints/aux.sh +# hints/aux_3.sh # # Improved by Jake Hamby <jehamby@lightside.com> to support both Apple CC # and GNU CC. Tested on A/UX 3.1.1 with GCC 2.6.3. +# Now notifies of problem with version of dbm shipped with A/UX # Last modified -# Fri May 5 10:59:43 EDT 1995 +# Sun Jan 5 11:16:41 WET 1997 case "$cc" in *gcc*) optimize='-O2' @@ -18,3 +19,4 @@ case "$cc" in echo "./Configure -Dcc=gcc" ;; esac +test -r ./broken-db.msg && . ./broken-db.msg diff --git a/hints/broken-db.msg b/hints/broken-db.msg new file mode 100644 index 0000000000..92ba0776bf --- /dev/null +++ b/hints/broken-db.msg @@ -0,0 +1,14 @@ +# Several OSs come with an old version of the DB library which fails +# on a few of the db-recno.t tests. This file is sourced by the hints +# files for those OSs. + +cat <<EOF >&4 + +Unless you've upgraded your DB library manually you will see failures in +db-recno tests 51, 53 and 55. The behavior these tests are checking is +broken in the DB library which is included with the OS. You can ignore +the errors if you're never going to use the broken functionality (recno +databases with a modified bval), otherwise you'll have to upgrade your +DB library or OS. + +EOF diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index bfd235faaf..a85abff18c 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -7,5 +7,12 @@ case "$optimize" in esac ;; esac + ccflags="$ccflags -DSTANDARD_C" -lddlflags='-shared -expect_unresolved "*" -s -hidden' + +# Check if it's a CMW version of OSF1 +if test `uname -s` = "MLS+"; then + lddlflags='-shared -expect_unresolved "*" -s' +else + lddlflags='-shared -expect_unresolved "*" -s -hidden' +fi diff --git a/hints/dgux.sh b/hints/dgux.sh index 1409d37f19..0b9dd11766 100644 --- a/hints/dgux.sh +++ b/hints/dgux.sh @@ -1,13 +1,13 @@ -# $Id: dgux.sh,v 1.4 1996/01/18 03:40:38 roderick Exp $ +# $Id: dgux.sh,v 1.8 1996-11-29 18:16:43-05 roderick Exp $ # This is a hints file for DGUX, which is Data General's Unix. It was -# developed using version 5.4.3.10 of the OS. I think the gross -# features should work with versions 5.4.2 through 5.4.4.11 with perhaps -# minor tweaking, but I don't have any older or newer versions installed -# at the moment with which to test it. +# originally developed with version 5.4.3.10 of the OS, and then was +# later updated running under version 4.11.2 (running on m88k hardware). +# The gross features should work with versions going back to 2.nil but +# some tweaking will probably be necessary. # # DGUX is a SVR4 derivative. It ships with gcc as the standard -# compiler. Since version 5.4.3.0 it has shipped with Perl 4.036 +# compiler. Since version 3.0 it has shipped with Perl 4.036 # installed in /usr/bin, which is kind of neat. Be careful when you # install that you don't overwrite the system version, though (by # answering yes to the question about installing perl as /usr/bin/perl), @@ -34,7 +34,7 @@ # cppstdin='/lib/cpp' # # The 4.036 and 5.001 hints files both contained these. The 5.001 hints -# file said it was developed with version 5.4.2.01 of DGUX. +# file said it was developed with version 2.01 of DGUX. # # gidtype='gid_t' # groupstype='gid_t' @@ -53,7 +53,7 @@ # # One last note: The 5.001 hints file said "you don't want to use # /usr/ucb/cc" in the place at which it set cc to gcc. That in -# particular baffles me, as I used to have 5.4.2.01 loaded and my memory +# particular baffles me, as I used to have 2.01 loaded and my memory # is telling me that even then /usr/ucb was a symlink to /usr/bin. @@ -82,8 +82,45 @@ usevfork=true # $plibpth to explicitly include the place to which the elinks point # allows Configure to find libraries which vary based on the development # environment. -plibpth="$plibpth \ - ${SDE_PATH:-/usr}/sde/${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib" +# +# Starting with version 4.10 (the first time the OS supported Intel +# hardware) all libraries are accessed with this mechanism. +# +# The default $TARGET_BINARY_INTERFACE changed with version 4.10. The +# system now comes with a link named /usr/sde/default which points to +# the proper entry, but older versions lacked this and used m88kdgux +# directly. + +: && sde_path=${SDE_PATH:-/usr}/sde # hide from Configure +while : # dummy loop +do + if [ -n "$TARGET_BINARY_INTERFACE" ] + then set X "$TARGET_BINARY_INTERFACE" + else set X default dg m88k_dg ix86_dg m88kdgux m88kdguxelf + fi + shift + default_sde=$1 + for sde + do + [ -d "$sde_path/$sde" ] && break 2 + done + cat <<END + +NOTE: I can't figure out what SDE is used by default on this machine (I +didn't find a likely directory under $sde_path). This is bad news. If +this is a R4.10 or newer system I'm not going to be able to find any of +your libraries, if this system is R3.10 or older I won't be able to find +the math library. You should re-run Configure with the environment +variable TARGET_BINARY_INTERFACE set to the proper value for this +machine, see sde(5) and the notes in hints/dgux.sh. + +END + sde=$default_sde + break +done + +plibpth="$plibpth $sde_path/$sde/usr/lib" +unset sde_path default_sde sde # Many functions (eg, gethostent(), killpg(), getpriority(), setruid() # dbm_*(), and plenty more) are defined in -ldgc. Usually you don't @@ -93,22 +130,12 @@ plibpth="$plibpth \ libswanted="dgc $libswanted" # Dynamic loading works using the dlopen() functions. Note that dlfcn.h -# is broken, it declares _dl*() rather than dl*(). (This is in my -# I'd-open-a-ticket-about-this-if-it-weren't-going-to-be-such-a-hassle -# file.) You can ignore the warnings caused by the missing -# declarations, they're harmless. +# used to be broken, it declared _dl*() rather than dl*(). This was the +# case up to 3.10, it has been fixed in 4.11. I'm not sure if it was +# fixed in 4.10. If you have the older header just ignore the warnings +# (since pointers and integers have the same format on m88k). usedl=true # For cc rather than gcc the flags would be `-K PIC' for compiling and # -G for loading. I haven't tested this. cccdlflags=-fpic lddlflags=-shared - -# The system has a function called dg_flock() which is an flock() -# emulation built using fcntl() locking. Perl currently comes with an -# flock() emulation which uses lockf(), it should eventually also -# include an fcntl() emulation of its own. Until that happens I -# recommend using DG's emulation (and ignoring the `WHOA THERE!' this -# causes), it provides semantics closer to the original than the lockf() -# emulation. -ccflags="$ccflags -Dflock=dg_flock" -d_flock=define diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 1e92053cf5..4d2ba22b10 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -14,6 +14,10 @@ # Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net> # Date: Fri, 12 May 1995 14:30:38 +0200 (MET DST) # +# Additional 2.2 defines from +# Mark Murray <mark@grondar.za> +# Date: Wed, 6 Nov 1996 09:44:58 +0200 (MET) +# # The two flags "-fpic -DPIC" are used to indicate a # will-be-shared object. Configure will guess the -fpic, (and the # -DPIC is not used by perl proper) but the full define is included to @@ -43,16 +47,40 @@ case "$osvers" in d_setruid='undef' ;; # -# Trying to cover 2.0.5, 2.1-current and future 2.1 +# Trying to cover 2.0.5, 2.1-current and future 2.1/2.2 # It does not covert all 2.1-current versions as the output of uname # changed a few times. # +# Even though seteuid/setegid are available, they've been turned off +# because perl isn't coded with saved set[ug]id variables in mind. +# In addition, a small patch is requried to suidperl to avoid a security +# problem with FreeBSD. +# 2.0.5*|2.0-built*|2.1*) usevfork='true' + usemymalloc='n' + d_dosuid='define' + d_setregid='define' + d_setreuid='define' + d_setegid='undef' + d_seteuid='undef' + test -r ./broken-db.msg && . ./broken-db.msg + ;; +# +# 2.2 and above have phkmalloc(3). +2.2*) + usevfork='true' + usemymalloc='n' + d_dosuid='define' + d_setregid='define' + d_setreuid='define' + d_setegid='undef' + d_seteuid='undef' ;; # -# Guesses at what will be needed after 2.1 +# Guesses at what will be needed after 2.2 *) usevfork='true' + usemymalloc='n' ;; esac diff --git a/hints/hpux.sh b/hints/hpux.sh index 5c741e3674..b103cf5bd3 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -1,14 +1,15 @@ # hints/hpux.sh -# Perl Configure hints file for Hewlett Packard HP/UX 9.x and 10.x +# Perl Configure hints file for Hewlett Packard HP-UX 9.x and 10.x # This file is based on -# hints/hpux_9.sh, Perl Configure hints file for Hewlett Packard HP/UX 9.x +# hints/hpux_9.sh, Perl Configure hints file for Hewlett Packard HP-UX 9.x # Use Configure -Dcc=gcc to use gcc. -# From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> -# Date: Thu, 28 Sep 95 11:06:07 PDT +# From: Jeff Okamoto <okamoto@corp.hp.com> # and -# hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP/UX 10.x +# hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP-UX 10.x # From: Giles Lean <giles@nemeton.com.au> -# Date: Tue, 27 Jun 1995 08:17:45 +1000 + +# This version: December 27, 1996 +# Current maintainer: Jeff Okamoto <okamoto@corp.hp.com> # Use Configure -Dcc=gcc to use gcc. # Use Configure -Dprefix=/usr/local to install in /usr/local. @@ -18,7 +19,10 @@ # Turn on the _HPUX_SOURCE flag to get many of the HP add-ons ccflags="$ccflags -D_HPUX_SOURCE" -ldflags="$ldflags" + +# If you plan to use gcc, then you should uncomment the following line +# so you get the HP math library and not the GCC math library. +# ccflags="$ccflags -L/lib/pa1.1" # Check if you're using the bundled C compiler. This compiler doesn't support # ANSI C (the -Aa flag) nor can it produce shared libraries. Thus we have @@ -48,7 +52,9 @@ xxuname=`uname -r` if echo $xxuname | $contains '10' then # This system is running 10.0 - xxcontext=`grep $(printf %#x $(getconf CPU_VERSION)) /usr/include/sys/unistd.h` + xxcpu1=`getconf CPU_VERSION` + xxcpu2=`printf %#x ${xxcpu1}` + xxcontext=`grep "$xxcpu2" /usr/include/sys/unistd.h` if echo "$xxcontext" | $contains 'PA-RISC1.1' then archname='PA-RISC1.1' @@ -105,7 +111,7 @@ ccdlflags="-Wl,-E -Wl,-B,deferred $ccdlflags" usemymalloc='y' alignbytes=8 -selecttype='int *' +selecttype='int *' # If your compile complains about FLT_MIN, uncomment the next line # POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"' @@ -113,7 +119,7 @@ selecttype='int *' # Comment this out if you don't want to follow the SVR4 filesystem layout # that HP-UX 10.0 uses case "$prefix" in -'') prefix='/opt/perl5' ;; +'') prefix='/opt/perl5.003' ;; esac # Date: Fri, 6 Sep 96 23:15:31 CDT diff --git a/hints/irix_6_3.sh b/hints/irix_6_3.sh new file mode 100644 index 0000000000..11bd82ac38 --- /dev/null +++ b/hints/irix_6_3.sh @@ -0,0 +1,16 @@ +# hints/irix_6_3.sh +# +# Created by John Stoffel (jfs@fluent.com), 01/13/1997 +# Based on the Irix 6.2 hints file, but simplified. + +# Configure can't parse 'nm' output on Irix 6.3 +usenm='n' + +# This keeps optimizer warnings quiet. +ccflags="$ccflags -Olimit 3000" + +# Gets rid of some extra libs that don't seem to be really needed. +# See the Irix 6.2 hints file for some justifications. +set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /' -e 's/ dl / /' -e 's/ socket / /' -e 's/ nsl / /'` +shift +libswanted="$*" diff --git a/hints/irix_6_4.sh b/hints/irix_6_4.sh new file mode 100644 index 0000000000..b5a994525a --- /dev/null +++ b/hints/irix_6_4.sh @@ -0,0 +1,16 @@ +# hints/irix_6_4.sh +# +# Created by John Stoffel (jfs@fluent.com), 01/13/1997 +# Based on the Irix 6.2 hints file, but simplified. + +# Configure can't parse 'nm' output on Irix 6.4 +usenm='n' + +# This keeps optimizer warnings quiet. +ccflags="$ccflags -Olimit 3000" + +# Gets rid of some extra libs that don't seem to be really needed. +# See the Irix 6.2 hints file for some justifications. +set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /' -e 's/ dl / /' -e 's/ socket / /' -e 's/ nsl / /'` +shift +libswanted="$*" diff --git a/hints/isc.sh b/hints/isc.sh index df745a9b25..43b70fde36 100644 --- a/hints/isc.sh +++ b/hints/isc.sh @@ -28,6 +28,12 @@ case "$cc" in ;; esac +# getsockname() and getpeername() return 256 for no good reason +ccflags="$ccflags -DBOGUS_GETNAME_RETURN=256" + +# rename(2) can't rename long filenames +d_rename=undef + # You can also include -D_SYSV3 to pick up "traditionally visible" # symbols hidden by name-space pollution rules. This raises some # compilation "redefinition" warnings, but they appear harmless. diff --git a/hints/linux.sh b/hints/linux.sh index afec2fa723..86b0241c99 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -15,6 +15,10 @@ # Updated Fri Jun 21 11:07:54 EDT 1996 # NDBM support for ELF renabled by <kjahds@kjahds.com> +# No version of Linux supports setuid scripts. +d_suidsafe='undef' +d_dosuid='define' + # perl goes into the /usr tree. See the Filesystem Standard # available via anonymous FTP at tsx-11.mit.edu in # /pub/linux/docs/linux-standards/fsstnd. diff --git a/hints/lynxos.sh b/hints/lynxos.sh new file mode 100644 index 0000000000..5f8991bc45 --- /dev/null +++ b/hints/lynxos.sh @@ -0,0 +1,12 @@ +# +# LynxOS hints +# +# These hints were submitted by: +# Greg Seibert +# seibert@Lynx.COM +# + +cc='gcc' +ccflags='-D_filbuf=_fillbuf' +so='none' +usemymalloc='n' diff --git a/hints/machten.sh b/hints/machten.sh index 321a80a297..55feadcfb7 100644 --- a/hints/machten.sh +++ b/hints/machten.sh @@ -1,5 +1,5 @@ # machten.sh -# This is for MachTen 4.0.2. It might work on other versions too. +# This is for MachTen 4.0.3. It might work on other versions too. # # MachTen users might need a fixed tr from ftp.tenon.com. This should # be described in the MachTen release notes. @@ -13,8 +13,12 @@ # Martijn Koster <m.koster@webcrawler.com> # Richard Yeh <rcyeh@cco.caltech.edu> # -# File::Find's use of link count disabled by Dominic Dunlop 950528 -# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 950521 +# Reinstate sigsetjmp iff version is 4.0.3 or greater; use nm +# (assumes Configure change); prune libswanted -- Dominic Dunlop 970113 +# Warn about test failure due to old Berkeley db -- Dominic Dunlop 970105 +# Do not use perl's malloc; SysV IPC OK -- Neil Cutcliffe, Tenon 961030 +# File::Find's use of link count disabled by Dominic Dunlop 960528 +# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 960521 # # Comments, questions, and improvements welcome! # @@ -22,19 +26,37 @@ # know how to use it yet. # # Updated by Dominic Dunlop <domo@tcp.ip.lu> -# Tue May 28 11:20:08 WET DST 1996 +# Tue Jan 14 10:17:18 WET 1997 -# Configure doesn't know how to parse the nm output. -usenm=undef +# Power MachTen is a real memory system and its standard malloc +# has been optimized for this. Using this malloc instead of Perl's +# malloc may result in significant memory savings. +usemymalloc='false' + +# Make symbol table listings les voluminous +nmopts=-gp + +# Install in /usr/local by default +prefix='/usr/local' # At least on PowerMac, doubles must be aligned on 8 byte boundaries. # I don't know if this is true for all MachTen systems, or how to # determine this automatically. alignbytes=8 -# There appears to be a problem with perl's use of sigsetjmp and +# 4.0.2 and earlier had a problem with perl's use of sigsetjmp and # friends. Use setjmp and friends instead. -d_sigsetjmp='undef' +expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='undef' + +# Get rid of some extra libs which it takes Configure a tediously +# long time never to find on MachTen +set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \ + -e 's/ inet / /' -e 's/ nsl / /' -e 's/ nm / /' -e 's/ malloc / /' \ + -e 's/ ld / /' -e 's/ sun / /' -e 's/ posix / /' \ + -e 's/ cposix / /' -e 's/ crypt / /' \ + -e 's/ ucb / /' -e 's/ bsd / /' -e 's/ BSD / /' -e 's/ PW / /'` +shift +libswanted="$*" # MachTen always reports ony two links to directories, even if they # contain subdirectories. Consequently, we use this variable to stop @@ -56,20 +78,8 @@ At the end of Configure, you will see a harmless message Hmm...You had some extra variables I don't know about...I'll try to keep 'em. Propagating recommended variable dont_use_nlink - -Read the File::Find documentation for more information. + Propagating recommended variable nmopts +Read the File::Find documentation for more information about dont_use_nlink EOM - -# Date: Wed, 18 Sep 1996 11:29:40 +0200 -# From: Dominic Dunlop <domo@tcp.ip.lu> -# Subject: Re: Perl 5.003 from ftp.tenon.com requires MT 4.0.3 - -# MachTen 4.0.2 and earlier do not implement System V interprocess -# communication (message queues, semaphores and shered memory); 4.0.3 has a -# half-baked implementation which provides the corresponding library -# functions but does not implement the system calls or provide the header -# files (or documentation). The perl installation process correctly divines -# that System V IPC is not usable in either case. Do not attempt to persuade -# it otherwise, or the resulting perl will crash (rather than producing an -# error message) if you attempt to use the functions. +test -r ./broken-db.msg && . ./broken-db.msg diff --git a/hints/os2.sh b/hints/os2.sh index 9d81b24a5d..9bce2a594c 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -64,8 +64,8 @@ fi aout_ldflags="$aout_ldflags" aout_d_fork='define' -aout_ccflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS' -aout_cppflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS' +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_use_clib='c' aout_usedl='undef' aout_archobjs="os2.o dl_os2.o" @@ -105,7 +105,7 @@ else # Recursive regmatch may eat 2.5M of stack alone. ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000' if [ $emxcrtrev -ge 50 ]; then - ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS' + ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK' else ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DEMX_BAD_SBRK' fi @@ -129,7 +129,9 @@ fi # [Maybe we should just remove c from $libswanted ?] -libs='-lsocket -lm' +# Test would pick up wrong rand, so we hardwire the value for random() +libs='-lsocket -lm -lbsd' +randbits=31 archobjs="os2$obj_ext dl_os2$obj_ext" # Run files without extension with sh: diff --git a/hints/qnx.sh b/hints/qnx.sh new file mode 100644 index 0000000000..e0ce55c249 --- /dev/null +++ b/hints/qnx.sh @@ -0,0 +1,176 @@ +#---------------------------------------------------------------- +# QNX hints +# +# As of perl5.003_09, perl5 will compile without errors +# and pass almost all the tests in the test suite. The remaining +# failures have been identified as bugs in the Watcom libraries +# which I hope will be fixed in the near future. +# +# As with many unix ports, this one depends on a few "standard" +# unix utilities which are not necessarily standard for QNX. +# +# /bin/sh This is used heavily by Configure and then by +# perl itself. QNX's version is fine, but Configure +# will choke on the 16-bit version, so if you are +# running QNX 4.22, link /bin/sh to /bin32/ksh +# ar This is the standard unix library builder. +# We use wlib. With Watcom 10.6, when wlib is +# linked as "ar", it behaves like ar and all is +# fine. Under 9.5, a cover is required. One is +# included in ../qnx +# nm This is used (optionally) by configure to list +# the contents of libraries. I will generate +# a cover function on the fly in the UU directory. +# cpp Configure and perl need a way to invoke a C +# preprocessor. I have created a simple cover +# for cc which does the right thing. Without this, +# Configure will create it's own wrapper which works, +# but it doesn't handle some of the command line arguments +# that perl will throw at it. +# make You really need GNU make to compile this. GNU make +# ships by default with QNX 4.23, but you can get it +# from quics for earlier versions. +#---------------------------------------------------------------- +# Outstanding Issues: +# lib/posix.t test fails on test 17 because acos(1) != 0. +# Watcom promises to fix this in next release. +# lib/io_udp.t test hangs because of a bug in getsockname(). +# Fixed in latest BETA socket3r.lib +# If there is a softlink in your path, Findbin will fail. +# This is a documented feature of getpwd(). +# There is currently no support for dynamically linked +# libraries. +#---------------------------------------------------------------- +# At present, all QNX systems are equivalent architectures, +# so it might be reasonable to call archname=qnx rather than +# making an unnecessary distinction between AT-qnx and PCI-qnx, +# for example. +#---------------------------------------------------------------- +# These hints were submitted by: +# Norton T. Allen +# Harvard University Atmospheric Research Project +# allen@huarp.harvard.edu +# +# If you have suggestions or changes, please let me know. +#---------------------------------------------------------------- + +#---------------------------------------------------------------- +# QNX doesn't come with a csh and the ports of tcsh I've used +# don't work reliably: +#---------------------------------------------------------------- +csh='' +d_csh='undef' +full_csh='' + +#---------------------------------------------------------------- +# difftime is implemented as a preprocessor macro, so it doesn't show +# up in the libraries: +#---------------------------------------------------------------- +d_difftime='define' + +#---------------------------------------------------------------- +# strtod is in the math library, but we can't tell Configure +# about the math library or it will confuse the linker +#---------------------------------------------------------------- +d_strtod='define' + +#---------------------------------------------------------------- +# The following exist in the libraries, but there are no +# prototypes available: +#---------------------------------------------------------------- +d_setregid='undef' +d_setreuid='undef' +d_setlinebuf='undef' +d_truncate='undef' +d_getpgid='undef' + +lib_ext='3r.lib' +libc='/usr/lib/clib3r.lib' + +#---------------------------------------------------------------- +# ccflags: +# I like to turn the warnings up high, but a few common +# constructs make a lot of noise, so I turn those warnings off. +# A few still remain... +# +# HIDEMYMALLOC is necessary if using mymalloc since it is very +# tricky (though not impossible) to totally replace the watcom +# malloc/free set. +# +# unix.h is required as a general rule for unixy applications. +#---------------------------------------------------------------- +ccflags='-DHIDEMYMALLOC -mf -w4 -Wc,-wcd=202 -Wc,-wcd=203 -Wc,-wcd=302 -Wc,-fi=unix.h' + +#---------------------------------------------------------------- +# ldflags: +# If you want debugging information, you must specify -g on the +# link as well as the compile. If optimize != -g, you should +# remove this. +#---------------------------------------------------------------- +ldflags="-g" + +so='none' +selecttype='fd_set *' + +#---------------------------------------------------------------- +# Add -lunix to list of libs. This is needed mainly so the nm +# search will find funcs in the unix lib. Including unix.h should +# automatically include the library without -l. +#---------------------------------------------------------------- +libswanted="$libswanted unix" + +if [ -z "`which ar 2>/dev/null`" ]; then + cat <<-'EOF' + I don't see an 'ar', so I'm guessing you are running + Watcom 9.5 or earlier. You may want to install the ar + cover found in the qnx subdirectory of this distribution. + It might reasonably be placed in /usr/local/bin. + + EOF +fi +#---------------------------------------------------------------- +# Here is a nm script which fixes up wlib's output to look +# something like nm's, at least enough so that Configure can +# use it. +#---------------------------------------------------------------- +if [ -z "`which nm 2>/dev/null`" ]; then + cat <<-EOF + Creating a quick-and-dirty nm cover for Configure to use: + + EOF + cat >../UU/nm <<-'EOF' + #! /bin/sh + #__USAGE + #%C <lib> [<lib> ...] + # Designed to mimic Unix's nm utility to list + # defined symbols in a library + for i in $*; do wlib $i; done | + awk ' + /^ / { + for (i = 1; i <= NF; i++) { + sub("_$", "", $i) + print "000000 T " $i + } + }' + EOF + chmod +x ../UU/nm +fi + +cppstdin=`which cpp 2>/dev/null` +if [ -n "$cppstdin" ]; then + cat <<-EOF + I found a cpp at $cppstdin and will assume it is a good + thing to use. If this proves to be false, there is a + thin cover for cpp in the qnx subdirectory of this + distribution which you could move into your path. + EOF + cpprun="$cppstdin" +else + cat <<-EOF + + There is a cpp cover in the qnx subdirectory of this + distribution which works a little better than the + Configure default. You may wish to copy it to + /usr/local/bin or some other suitable location. + EOF +fi diff --git a/hints/svr4.sh b/hints/svr4.sh index 5569274753..c91e13e052 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -32,6 +32,15 @@ usevfork='false' # other SVR4 derivatives. d_lstat=define +# UnixWare has a broken csh. The undocumented -X argument to uname is probably +# a reasonable way of detecting UnixWare +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' +fi + cat <<'EOM' >&4 If you wish to use dynamic linking, you must use diff --git a/hints/ultrix_4.sh b/hints/ultrix_4.sh index 76b0768f8d..826cb34c19 100644 --- a/hints/ultrix_4.sh +++ b/hints/ultrix_4.sh @@ -50,4 +50,7 @@ case "$osvers" in *) ranlib='ranlib' ;; esac +# Settings that don't depend on $osvers: + +util_cflags='ccflags="$ccflags -DLOCALE_ENVIRON_REQUIRED"' groupstype='int' diff --git a/hints/unicos.sh b/hints/unicos.sh index 272cb9b5d6..b864019a84 100644 --- a/hints/unicos.sh +++ b/hints/unicos.sh @@ -1,9 +1,7 @@ case `uname -r` in 6.1*) shellflags="-m+65536" ;; esac -ccflags="$ccflags -DHZ=__hertz" optimize="-O1" -libswanted=m d_setregid='undef' d_setreuid='undef' diff --git a/hints/unicosmk.sh b/hints/unicosmk.sh new file mode 100644 index 0000000000..90784b5b39 --- /dev/null +++ b/hints/unicosmk.sh @@ -0,0 +1,3 @@ +optimize="-O1" +d_setregid='undef' +d_setreuid='undef' @@ -55,6 +55,31 @@ more_he() return new_he(); } +static HEK * +save_hek(str, len, hash) +char *str; +I32 len; +U32 hash; +{ + char *k; + register HEK *hek; + + New(54, k, HEK_BASESIZE + len + 1, char); + hek = (HEK*)k; + Copy(str, HEK_KEY(hek), len, char); + *(HEK_KEY(hek) + len) = '\0'; + HEK_LEN(hek) = len; + HEK_HASH(hek) = hash; + return hek; +} + +void +unshare_hek(hek) +HEK *hek; +{ + unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek)); +} + /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot * contains an SV* */ @@ -102,7 +127,7 @@ I32 lval; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return &HeVAL(entry); } @@ -143,14 +168,20 @@ register U32 hash; return 0; if (SvRMAGICAL(hv) && mg_find((SV*)hv,'P')) { + static HE mh; + sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); - entry = &He; - HeVAL(entry) = sv; - HeKEY(entry) = (char*)keysv; - HeKLEN(entry) = HEf_SVKEY; /* hent_key is holding an SV* */ - return entry; + if (!HeKEY_hek(&mh)) { + char *k; + New(54, k, HEK_BASESIZE + sizeof(SV*), char); + HeKEY_hek(&mh) = (HEK*)k; + HeKLEN(&mh) = HEf_SVKEY; /* key will always hold an SV* */ + } + HeSVKEY_set(&mh, keysv); + HeVAL(&mh) = sv; + return &mh; } xhv = (XPVHV*)SvANY(hv); @@ -176,7 +207,7 @@ register U32 hash; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return entry; } @@ -217,14 +248,14 @@ register U32 hash; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { mg_copy((SV*)hv, val, key, klen); -#ifndef OVERLOAD - if (!xhv->xhv_array) - return 0; -#else - if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A' - || SvMAGIC(hv)->mg_moremagic)) - return 0; + if (!xhv->xhv_array + && (SvMAGIC(hv)->mg_moremagic + || (SvMAGIC(hv)->mg_type != 'E' +#ifdef OVERLOAD + && SvMAGIC(hv)->mg_type != 'A' #endif /* OVERLOAD */ + ))) + return 0; } if (!hash) PERL_HASH(hash, key, klen); @@ -240,7 +271,7 @@ register U32 hash; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; @@ -248,13 +279,11 @@ register U32 hash; } entry = new_he(); - HeKLEN(entry) = klen; if (HvSHAREKEYS(hv)) - HeKEY(entry) = sharepvn(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, klen, hash); else /* gotta do the real thing */ - HeKEY(entry) = savepvn(key,klen); + HeKEY_hek(entry) = save_hek(key, klen, hash); HeVAL(entry) = val; - HeHASH(entry) = hash; HeNEXT(entry) = *oentry; *oentry = entry; @@ -289,14 +318,14 @@ register U32 hash; if (SvMAGICAL(hv)) { keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); -#ifndef OVERLOAD - if (!xhv->xhv_array) - return Nullhe; -#else - if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A' - || SvMAGIC(hv)->mg_moremagic)) - return Nullhe; + if (!xhv->xhv_array + && (SvMAGIC(hv)->mg_moremagic + || (SvMAGIC(hv)->mg_type != 'E' +#ifdef OVERLOAD + && SvMAGIC(hv)->mg_type != 'A' #endif /* OVERLOAD */ + ))) + return Nullhe; } key = SvPV(keysv, klen); @@ -315,7 +344,7 @@ register U32 hash; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; @@ -323,13 +352,11 @@ register U32 hash; } entry = new_he(); - HeKLEN(entry) = klen; if (HvSHAREKEYS(hv)) - HeKEY(entry) = sharepvn(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, klen, hash); else /* gotta do the real thing */ - HeKEY(entry) = savepvn(key,klen); + HeKEY_hek(entry) = save_hek(key, klen, hash); HeVAL(entry) = val; - HeHASH(entry) = hash; HeNEXT(entry) = *oentry; *oentry = entry; @@ -384,7 +411,7 @@ I32 flags; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; *oentry = HeNEXT(entry); if (i && !*oentry) @@ -396,7 +423,7 @@ I32 flags; if (entry == xhv->xhv_eiter) HvLAZYDEL_on(hv); else - he_free(entry, HvSHAREKEYS(hv)); + he_free(hv, entry); --xhv->xhv_keys; return sv; } @@ -446,7 +473,7 @@ U32 hash; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; *oentry = HeNEXT(entry); if (i && !*oentry) @@ -458,7 +485,7 @@ U32 hash; if (entry == xhv->xhv_eiter) HvLAZYDEL_on(hv); else - he_free(entry, HvSHAREKEYS(hv)); + he_free(hv, entry); --xhv->xhv_keys; return sv; } @@ -500,7 +527,7 @@ U32 klen; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return TRUE; } @@ -547,7 +574,7 @@ U32 hash; continue; if (HeKLEN(entry) != klen) continue; - if (memcmp(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return TRUE; } @@ -719,36 +746,44 @@ newHV() } void -he_free(hent, shared) +he_free(hv, hent) +HV *hv; register HE *hent; -I32 shared; { if (!hent) return; + if (isGV(HeVAL(hent)) && GvCVu(HeVAL(hent)) && HvNAME(hv)) + sub_generation++; /* may be deletion of method from stash */ SvREFCNT_dec(HeVAL(hent)); - if (HeKLEN(hent) == HEf_SVKEY) - SvREFCNT_dec((SV*)HeKEY(hent)); - else if (shared) - unsharepvn(HeKEY(hent), HeKLEN(hent), HeHASH(hent)); + if (HeKLEN(hent) == HEf_SVKEY) { + SvREFCNT_dec(HeKEY_sv(hent)); + Safefree(HeKEY_hek(hent)); + } + else if (HvSHAREKEYS(hv)) + unshare_hek(HeKEY_hek(hent)); else - Safefree(HeKEY(hent)); + Safefree(HeKEY_hek(hent)); del_he(hent); } void -he_delayfree(hent, shared) +he_delayfree(hv, hent) +HV *hv; register HE *hent; -I32 shared; { if (!hent) return; + if (isGV(HeVAL(hent)) && GvCVu(HeVAL(hent)) && HvNAME(hv)) + sub_generation++; /* may be deletion of method from stash */ sv_2mortal(HeVAL(hent)); /* free between statements */ - if (HeKLEN(hent) == HEf_SVKEY) - sv_2mortal((SV*)HeKEY(hent)); - else if (shared) - unsharepvn(HeKEY(hent), HeKLEN(hent), HeHASH(hent)); + if (HeKLEN(hent) == HEf_SVKEY) { + sv_2mortal(HeKEY_sv(hent)); + Safefree(HeKEY_hek(hent)); + } + else if (HvSHAREKEYS(hv)) + unshare_hek(HeKEY_hek(hent)); else - Safefree(HeKEY(hent)); + Safefree(HeKEY_hek(hent)); del_he(hent); } @@ -779,7 +814,6 @@ HV *hv; register HE *ohent = Null(HE*); I32 riter; I32 max; - I32 shared; if (!hv) return; @@ -790,12 +824,11 @@ HV *hv; max = HvMAX(hv); array = HvARRAY(hv); hent = array[0]; - shared = HvSHAREKEYS(hv); for (;;) { if (hent) { ohent = hent; hent = HeNEXT(hent); - he_free(ohent, shared); + he_free(hv, ohent); } if (!hent) { if (++riter > max) @@ -840,7 +873,7 @@ HV *hv; #endif if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); - he_free(entry, HvSHAREKEYS(hv)); + he_free(hv, entry); } xhv->xhv_riter = -1; xhv->xhv_eiter = Null(HE*); @@ -868,18 +901,25 @@ HV *hv; SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ } else { - xhv->xhv_eiter = entry = new_he(); /* only one HE per MAGICAL hash */ + char *k; + HEK *hek; + + xhv->xhv_eiter = entry = new_he(); /* one HE per MAGICAL hash */ Zero(entry, 1, HE); + Newz(54, k, HEK_BASESIZE + sizeof(SV*), char); + hek = (HEK*)k; + HeKEY_hek(entry) = hek; HeKLEN(entry) = HEf_SVKEY; } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { /* force key to stay around until next time */ - HeKEY(entry) = (char*)SvREFCNT_inc(key); - return entry; /* beware, hent_val is not set */ + HeSVKEY_set(entry, SvREFCNT_inc(key)); + return entry; /* beware, hent_val is not set */ } if (HeVAL(entry)) SvREFCNT_dec(HeVAL(entry)); + Safefree(HeKEY_hek(entry)); del_he(entry); xhv->xhv_eiter = Null(HE*); return Null(HE*); @@ -900,7 +940,7 @@ HV *hv; if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); - he_free(oldentry, HvSHAREKEYS(hv)); + he_free(hv, oldentry); } xhv->xhv_eiter = entry; @@ -913,7 +953,7 @@ register HE *entry; I32 *retlen; { if (HeKLEN(entry) == HEf_SVKEY) { - return SvPV((SV*)HeKEY(entry), *(STRLEN*)retlen); + return SvPV(HeKEY_sv(entry), *(STRLEN*)retlen); } else { *retlen = HeKLEN(entry); @@ -927,7 +967,7 @@ hv_iterkeysv(entry) register HE *entry; { if (HeKLEN(entry) == HEf_SVKEY) - return sv_mortalcopy((SV*)HeKEY(entry)); + return sv_mortalcopy(HeKEY_sv(entry)); else return sv_2mortal(newSVpv((HeKLEN(entry) ? HeKEY(entry) : ""), HeKLEN(entry))); @@ -941,7 +981,9 @@ register HE *entry; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { SV* sv = sv_newmortal(); - mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry)); + if (HeKLEN(entry) == HEf_SVKEY) + mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY); + else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry)); return sv; } } @@ -970,65 +1012,67 @@ int how; sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); } -/* get a (constant) string ptr from the global string table - * string will get added if it is not already there. +char* +sharepvn(sv, len, hash) +char* sv; +I32 len; +U32 hash; +{ + return HEK_KEY(share_hek(sv, len, hash)); +} + +/* possibly free a shared string if no one has access to it * len and hash must both be valid for str. */ -char * -sharepvn(str, len, hash) -char *str; +void +unsharepvn(str, len, hash) +char* str; I32 len; -register U32 hash; +U32 hash; { register XPVHV* xhv; register HE *entry; register HE **oentry; register I32 i = 1; I32 found = 0; - + /* what follows is the moral equivalent of: - - if (!(Svp = hv_fetch(strtab, str, len, FALSE))) - hv_store(strtab, str, len, Nullsv, hash); - */ + if ((Svp = hv_fetch(strtab, tmpsv, FALSE, hash))) { + if (--*Svp == Nullsv) + hv_delete(strtab, str, len, G_DISCARD, hash); + } */ xhv = (XPVHV*)SvANY(strtab); /* assert(xhv_array != 0) */ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { + for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != len) continue; - if (memcmp(HeKEY(entry),str,len)) /* is this it? */ + if (memNE(HeKEY(entry),str,len)) /* is this it? */ continue; found = 1; - break; - } - if (!found) { - entry = new_he(); - HeKLEN(entry) = len; - HeKEY(entry) = savepvn(str,len); - HeVAL(entry) = Nullsv; - HeHASH(entry) = hash; - HeNEXT(entry) = *oentry; - *oentry = entry; - xhv->xhv_keys++; - if (i) { /* initial entry? */ - ++xhv->xhv_fill; - if (xhv->xhv_keys > xhv->xhv_max) - hsplit(strtab); + if (--HeVAL(entry) == Nullsv) { + *oentry = HeNEXT(entry); + if (i && !*oentry) + xhv->xhv_fill--; + Safefree(HeKEY_hek(entry)); + del_he(entry); + --xhv->xhv_keys; } + break; } - - ++HeVAL(entry); /* use value slot as REFCNT */ - return HeKEY(entry); + + if (!found) + warn("Attempt to free non-existent shared string"); } -/* possibly free a shared string if no one has access to it +/* get a (constant) string ptr from the global string table + * string will get added if it is not already there. * len and hash must both be valid for str. */ -void -unsharepvn(str, len, hash) +HEK * +share_hek(str, len, hash) char *str; I32 len; register U32 hash; @@ -1038,35 +1082,41 @@ register U32 hash; register HE **oentry; register I32 i = 1; I32 found = 0; - + /* what follows is the moral equivalent of: - if ((Svp = hv_fetch(strtab, tmpsv, FALSE, hash))) { - if (--*Svp == Nullsv) - hv_delete(strtab, str, len, G_DISCARD, hash); - } */ + + if (!(Svp = hv_fetch(strtab, str, len, FALSE))) + hv_store(strtab, str, len, Nullsv, hash); + */ xhv = (XPVHV*)SvANY(strtab); /* assert(xhv_array != 0) */ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { + for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != len) continue; - if (memcmp(HeKEY(entry),str,len)) /* is this it? */ + if (memNE(HeKEY(entry),str,len)) /* is this it? */ continue; found = 1; - if (--HeVAL(entry) == Nullsv) { - *oentry = HeNEXT(entry); - if (i && !*oentry) - xhv->xhv_fill--; - Safefree(HeKEY(entry)); - del_he(entry); - --xhv->xhv_keys; - } break; } - - if (!found) - warn("Attempt to free non-existent shared string"); + if (!found) { + entry = new_he(); + HeKEY_hek(entry) = save_hek(str, len, hash); + HeVAL(entry) = Nullsv; + HeNEXT(entry) = *oentry; + *oentry = entry; + xhv->xhv_keys++; + if (i) { /* initial entry? */ + ++xhv->xhv_fill; + if (xhv->xhv_keys > xhv->xhv_max) + hsplit(strtab); + } + } + + ++HeVAL(entry); /* use value slot as REFCNT */ + return HeKEY_hek(entry); } + @@ -8,13 +8,18 @@ */ typedef struct he HE; +typedef struct hek HEK; struct he { HE *hent_next; - char *hent_key; + HEK *hent_hek; SV *hent_val; - U32 hent_hash; - I32 hent_klen; +}; + +struct hek { + U32 hek_hash; + I32 hek_len; + char hek_key[1]; }; struct xpvhv { @@ -84,20 +89,29 @@ struct xpvhv { #define Nullhe Null(HE*) #define HeNEXT(he) (he)->hent_next -#define HeKEY(he) (he)->hent_key -#define HeKLEN(he) (he)->hent_klen +#define HeKEY_hek(he) (he)->hent_hek +#define HeKEY(he) HEK_KEY(HeKEY_hek(he)) +#define HeKEY_sv(he) (*(SV**)HeKEY(he)) +#define HeKLEN(he) HEK_LEN(HeKEY_hek(he)) #define HeVAL(he) (he)->hent_val -#define HeHASH(he) (he)->hent_hash -#define HePV(he) ((he)->hent_klen == HEf_SVKEY) ? \ - SvPV((SV*)((he)->hent_key),na) : \ - (he)->hent_key)) -#define HeSVKEY(he) (((he)->hent_key && \ - (he)->hent_klen == HEf_SVKEY) ? \ - (SV*)((he)->hent_key) : Nullsv) - -#define HeSVKEY_force(he) ((he)->hent_key ? \ - (((he)->hent_klen == HEf_SVKEY) ? \ - (SV*)((he)->hent_key) : \ - sv_2mortal(newSVpv((he)->hent_key, \ - (he)->hent_klen))) : \ +#define HeHASH(he) HEK_HASH(HeKEY_hek(he)) +#define HePV(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvPV(HeKEY_sv(he),na) : \ + HeKEY(he)) +#define HeSVKEY(he) ((HeKEY(he) && \ + HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : Nullsv) + +#define HeSVKEY_force(he) (HeKEY(he) ? \ + ((HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : \ + sv_2mortal(newSVpv(HeKEY(he), \ + HeKLEN(he)))) : \ &sv_undef) +#define HeSVKEY_set(he,sv) (HeKEY_sv(he) = sv) + +#define Nullhek Null(HEK*) +#define HEK_BASESIZE STRUCT_OFFSET(HEK, hek_key[0]) +#define HEK_HASH(hek) (hek)->hek_hash +#define HEK_LEN(hek) (hek)->hek_len +#define HEK_KEY(hek) (hek)->hek_key diff --git a/installman b/installman index d57cdb14e9..c5663dd562 100755 --- a/installman +++ b/installman @@ -126,7 +126,7 @@ sub runpod2man { # Convert name from File/Basename.pm to File::Basename.3 format, # if necessary. $manpage =~ s#\.p(m|od)$##; - if ($^O eq 'os2') { + if ($^O eq 'os2' || $^O eq 'amigaos') { $manpage =~ s#/#.#g; } else { $manpage =~ s#/#::#g; diff --git a/installperl b/installperl index 8f8f7e79ef..05f77f6a42 100755 --- a/installperl +++ b/installperl @@ -1,6 +1,7 @@ #!./perl BEGIN { @INC=('./lib', '../lib') } use File::Find; +use File::Compare; use File::Path (); use Config; use subs qw(unlink rename link chmod); @@ -23,7 +24,7 @@ while (@ARGV) { umask 022; @scripts = qw( utils/c2ph utils/h2ph utils/h2xs - utils/perlbug utils/perldoc utils/pl2pm + utils/perlbug utils/perldoc utils/pl2pm utils/splain x2p/s2p x2p/find2perl pod/pod2man pod/pod2html pod/pod2latex pod/pod2text); @@ -73,6 +74,7 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } &safe_unlink("$installbin/perl$ver$exe_ext"); &cmd("cp perl$exe_ext $installbin/perl$ver$exe_ext"); +&chmod(0755, "$installbin/perl$ver$exe_ext"); &safe_unlink("$installbin/sperl$ver$exe_ext"); if ($d_dosuid) { @@ -158,8 +160,11 @@ push(@corefiles,'perl.exp') if $^O eq 'aix'; # If they have built sperl.o... push(@corefiles,'sperl.o') if -f 'sperl.o'; foreach $file (@corefiles) { - cp_if_diff($file,"$installarchlib/CORE/$file"); - &chmod($file =~ /^libperl/ ? 0555 : 0444,"$installarchlib/CORE/$file"); + # HP-UX (at least) needs to maintain execute permissions + # on dynamically-loaded libraries. + cp_if_diff($file,"$installarchlib/CORE/$file") + and &chmod($file =~ /^\.(so|$dlext)$/ ? 0555 : 0444, + "$installarchlib/CORE/$file"); } # Offer to install perl in a "standard" location @@ -167,27 +172,30 @@ foreach $file (@corefiles) { $mainperl_is_instperl = 0; if (-w $mainperldir && ! &samepath($mainperldir, $installbin) && !$nonono) { - # First make sure $mainperldir/perl is not already the same as - # the perl we just installed - if (-x "$mainperldir/perl$exe_ext") { + local($usrbinperl) = "$mainperldir/perl$exe_ext"; + local($instperl) = "$installbin/perl$exe_ext"; + local($expinstperl) = "$binexp/perl$exe_ext"; + + # First make sure $usrbinperl is not already the same as the perl we + # just installed. + if (-x $usrbinperl) { # Try to be clever about mainperl being a symbolic link # to binexp/perl if binexp and installbin are different. $mainperl_is_instperl = - &samepath("$mainperldir/perl$exe_ext", "$installbin/perl$exe_ext") || + &samepath($usrbinperl, $instperl) || (($binexp ne $installbin) && - (-l "$mainperldir/perl$exe_ext") && - ((readlink "$mainperldir/perl$exe_ext") eq "$binexp/perl$exe_ext")); + (-l $usrbinperl) && + ((readlink $usrbinperl) eq $expinstperl)); } if ((! $mainperl_is_instperl) && - (&yn("Many scripts expect perl to be installed as " . - "$mainperldir/perl.\n" . - "Do you wish to have $mainperldir/perl be the same as\n" . - "$binexp/perl? [y] "))) + (&yn("Many scripts expect perl to be installed as $usrbinperl.\n" . + "Do you wish to have $usrbinperl be the same as\n" . + "$expinstperl? [y] "))) { - unlink("$mainperldir/perl$exe_ext"); - CORE::link("$installbin/perl$exe_ext", "$mainperldir/perl$exe_ext") || - symlink("$binexp/perl$exe_ext", "$mainperldir/perl$exe_ext") || - cmd("cp $installbin/perl$exe_ext $mainperldir$exe_ext"); + unlink($usrbinperl); + eval { CORE::link $instperl, $usrbinperl } || + eval { symlink $expinstperl, $usrbinperl } || + cmd("cp $instperl $usrbinperl"); $mainperl_is_instperl = 1; } } @@ -340,7 +348,7 @@ sub installlib { $name = "$dir/$name" if $dir ne ''; my $installlib = $installprivlib; - if ((substr($dir, 0, 4) eq 'auto') || ($name eq 'Config.pm')) { + if ($dir =~ /^auto/ || $name =~ /^(Config|FileHandle|Safe)\.pm$/) { $installlib = $installarchlib; return unless $do_installarchlib; } else { @@ -356,19 +364,14 @@ sub installlib { #This might not work because $archname might have changed. &unlink("$installarchlib/$name"); } - system "cmp", "-s", $_, "$installlib/$name"; - if ($? || $nonono) { + if (compare($_, "$installlib/$name") || $nonono) { &unlink("$installlib/$name"); mkpath("$installlib/$dir", 1, 0777); - cp_if_diff($_, "$installlib/$name"); # HP-UX (at least) needs to maintain execute permissions # on dynamically-loaded libraries. - if ($name =~ /\.(so|$dlext)$/o) { - &chmod(0555, "$installlib/$name"); - } - else { - &chmod(0444, "$installlib/$name"); - } + cp_if_diff($_, "$installlib/$name") + and &chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444, + "$installlib/$name"); } } elsif (-d $_) { mkpath("$installlib/$name", 1, 0777); @@ -383,11 +386,11 @@ sub installlib { # and then try to link against the installed libperl.a, you might # get an error message to the effect that the symbol table is older # than the library. +# Return true if copying occurred. sub cp_if_diff { my($from,$to)=@_; -f $from || die "$0: $from not found"; - system "cmp", "-s", $from, $to; - if ($? || $nonono) { + if (compare($from, $to) || $nonono) { my ($atime, $mtime); unlink($to); # In case we don't have write permissions. if ($nonono) { @@ -399,5 +402,6 @@ sub cp_if_diff { ($atime, $mtime) = (stat $from)[8,9]; utime $atime, $mtime, $to; } + 1; } } diff --git a/interp.sym b/interp.sym index 33fb2c7b43..ea4241ac25 100644 --- a/interp.sym +++ b/interp.sym @@ -106,7 +106,6 @@ parsehook patchlevel perldb perl_destruct_level -pidstatus preambled preambleav preprocess @@ -115,7 +114,6 @@ rightgv rs runlevel sawampersand -sawi sawstudy sawvec screamfirst diff --git a/keywords.pl b/keywords.pl index 086a10956a..595e875bc4 100755 --- a/keywords.pl +++ b/keywords.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl +unlink "keywords.h"; open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n"; select KW; diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 7d781d13c0..be6429e6e8 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -95,16 +95,25 @@ subroutine may have a shorter name that the routine itself. This can lead to conflicting file names. The I<AutoSplit> package warns of these potential conflicts when used to split a module. -Calling foo($1) for the autoloaded function foo() might not work as -expected, because the AUTOLOAD function of B<AutoLoader> clobbers the -regexp variables. Invoking it as foo("$1") avoids this problem. - =cut AUTOLOAD { - my $name = "auto/$AUTOLOAD.al"; - # Braces used on the s/// below to preserve $1 et al. - {$name =~ s#::#/#g} + my $name; + # 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 {require $name}; if ($@) { diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index b582f78d69..c1ff13a70c 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -195,6 +195,7 @@ sub autosplit_file{ die "Package $package does not match filename $filename" unless ($filename =~ m/$modpname.pm$/ or + ($^O eq "msdos") or $Is_VMS && $filename =~ m/$modpname.pm/i); if ($check_mod_time){ @@ -247,14 +248,17 @@ sub autosplit_file{ open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning my(@subnames, %proto); + my @cache = (); + my $caching = 1; while (<IN>) { + next if /^=\w/ .. /^=cut/; if (/^package ([\w:]+)\s*;/) { warn "package $1; in AutoSplit section ignored. Not currently supported."; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { print OUT "1;\n"; my $subname = $1; - $proto{$1} = $2 or ''; + $proto{$1} = $2 || ''; if ($subname =~ m/::/){ warn "subs with package names not currently supported in AutoSplit section"; } @@ -274,10 +278,26 @@ sub autosplit_file{ print OUT "# NOTE: Derived from $filename. ", "Changes made here will be lost.\n"; print OUT "package $package;\n\n"; + print OUT @cache; + @cache = (); + $caching = 0; + } + if($caching) { + push(@cache, $_) if @cache || /\S/; + } + else { + print OUT $_; + } + if(/^}/) { + if($caching) { + print OUT @cache; + @cache = (); + } + print OUT "\n"; + $caching = 1; } - print OUT $_; } - print OUT "1;\n"; + print OUT @cache,"1;\n"; close(OUT); close(IN); diff --git a/lib/CPAN.pm b/lib/CPAN.pm new file mode 100644 index 0000000000..3db4870fdc --- /dev/null +++ b/lib/CPAN.pm @@ -0,0 +1,2731 @@ +package CPAN; +use vars qw{$META $Signal $Cwd $End $Suppress_readline}; + +$VERSION = '1.09'; + +# $Id: CPAN.pm,v 1.94 1996/12/24 00:41:14 k Exp $ + +# my $version = substr q$Revision: 1.94 $, 10; # only used during development + +BEGIN {require 5.003;} +require UNIVERSAL if $] == 5.003; + +use Carp (); +use Config (); +use Cwd (); +use DirHandle; +use Exporter (); +use ExtUtils::MakeMaker (); +use File::Basename (); +use File::Copy (); +use File::Find; +use File::Path (); +use IO::File (); +use Safe (); +use Text::ParseWords (); + +$Cwd = Cwd::cwd(); + +END { $End++; &cleanup; } + +%CPAN::DEBUG = qw( + CPAN 1 + Index 2 + InfoObj 4 + Author 8 + Distribution 16 + Bundle 32 + Module 64 + CacheMgr 128 + Complete 256 + FTP 512 + Shell 1024 + Eval 2048 + Config 4096 + ); + +$CPAN::DEBUG ||= 0; + +package CPAN; +use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META); +use strict qw(vars); + +@CPAN::ISA = qw(CPAN::Debug Exporter MY); # the MY class from + # MakeMaker, gives us + # catfile and catdir + +$META ||= new CPAN; # In case we reeval ourselves we + # need a || + +CPAN::Config->load; + +@EXPORT = qw(autobundle bundle expand force install make recompile shell test clean); + + + +#-> sub CPAN::autobundle ; +sub autobundle; +#-> sub CPAN::bundle ; +sub bundle; +#-> sub CPAN::expand ; +sub expand; +#-> sub CPAN::force ; +sub force; +#-> sub CPAN::install ; +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) = @_; + CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; + CPAN::Index->reload; + values %{ $META->{$class} }; +} + +# Called by shell, not in batch mode. Not clean XXX +#-> sub CPAN::checklock ; +sub checklock { + my($self) = @_; + my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock"); + if (-f $lockfile && -M _ > 0) { + my $fh = IO::File->new($lockfile); + my $other = <$fh>; + $fh->close; + if (defined $other && $other) { + chomp $other; + return if $$==$other; # should never happen + print qq{There seems to be running another CPAN process ($other). Trying to contact...\n}; + if (kill 0, $other) { + Carp::croak qq{Other job is running.\n}. + qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}. + qq{ kill $other\n}. + qq{ rm $lockfile\n}; + } elsif (-w $lockfile) { + my($ans)= + ExtUtils::MakeMaker::prompt + (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y"); + print("Ok, bye\n"), exit unless $ans =~ /^y/i; + } else { + Carp::croak( + qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}. + qq{ On UNIX try:\n}. + qq{ rm $lockfile\n}. + qq{ and then rerun us.\n} + ); + } + } + } + File::Path::mkpath($CPAN::Config->{cpan_home}); + my $fh; + unless ($fh = IO::File->new(">$lockfile")) { + if ($! =~ /Permission/) { + my $incc = $INC{'CPAN/Config.pm'}; + my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); + print qq{ + +Your configuration suggests that CPAN.pm should use a working +directory of + $CPAN::Config->{cpan_home} +Unfortunately we could not create the lock file + $lockfile +due to permission problems. + +Please make sure that the configuration variable + \$CPAN::Config->{cpan_home} +points to a directory where you can write a .lock file. You can set +this variable in either + $incc +or + $myincc + +}; + } + Carp::croak "Could not open >$lockfile: $!"; + } + print $fh $$, "\n"; + $self->{LOCK} = $lockfile; + $fh->close; + $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; }; + $SIG{'INT'} = sub { &cleanup, die "Got a second SIGINT" if $Signal; $Signal = 1; }; + $SIG{'__DIE__'} = \&cleanup; + print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'}; +} + +#-> sub CPAN::DESTROY ; +sub DESTROY { + &cleanup; # need an eval? +} + +#-> sub CPAN::exists ; +sub exists { + my($mgr,$class,$id) = @_; + CPAN::Index->reload; + Carp::croak "exists called without class argument" unless $class; + $id ||= ""; + 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::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'}; +} + +#-> 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 MD5\n"; + $self->{'hasMD5'} = 0; + } else { + $self->{'hasMD5'}++; + } + } + return $self->{'hasMD5'}; +} + +#-> sub CPAN::instance ; +sub instance { + my($mgr,$class,$id) = @_; + CPAN::Index->reload; + Carp::croak "instance called without class argument" unless $class; + $id ||= ""; + $META->{$class}{$id} ||= $class->new(ID => $id ); +} + +#-> sub CPAN::new ; +sub new { + bless {}, shift; +} + +#-> sub CPAN::cleanup ; +sub cleanup { + local $SIG{__DIE__} = ''; + my $i = 0; my $ineval = 0; my $sub; + while ((undef,undef,undef,$sub) = caller(++$i)) { + $ineval = 1, last if $sub eq '(eval)'; + } + return if $ineval && !$End; + return unless defined $META->{'LOCK'}; + 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; + my $term; + 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 $cwd = Cwd::cwd(); + # How should we determine if we have more than stub ReadLine enabled? + my $rl_avail = $Suppress_readline ? "suppressed" : + defined &Term::ReadLine::Perl::readline ? "enabled" : + "available (get Term::ReadKey and Term::ReadLine)"; + + 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); + 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::Shell; +use vars qw($AUTOLOAD); +@CPAN::Shell::ISA = qw(CPAN::Debug); + +# private function ro re-eval this module (handy during development) +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-( +Nothing Done. +"; + CPAN::Shell->h; +} + +#-> sub CPAN::Shell::h ; +sub h { + my($class,$about) = @_; + if (defined $about) { + print "Detailed help not yet implemented\n"; + } else { + print q{ +command arguments description +a string authors +b or display bundles +d /regex/ info distributions +m or about modules +i none anything of above + +r as reinstall recommendations +u above uninstalled distributions +See manpage for autobundle, recompile, force, etc. + +make modules, make +test dists, bundles, make test (implies make) +install "r" or "u" make install (implies test) +clean make clean + +reload index|cpan load most recent indices/CPAN.pm +h or ? display this menu +o various set and query options +! perl-code eval a perl command +q quit the shell subroutine +}; + } +} + +#-> sub CPAN::Shell::a ; +sub a { print shift->format_result('Author',@_);} +#-> sub CPAN::Shell::b ; +sub b { + my($self,@which) = @_; + my($incdir,$bdir,$dh); + foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { + $bdir = $CPAN::META->catdir($incdir,"Bundle"); + if ($dh = DirHandle->new($bdir)) { # may fail + my($entry); + for $entry ($dh->read) { + next if -d $CPAN::META->catdir($bdir,$entry); + next unless $entry =~ s/\.pm$//; + $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); + } + } + } + print $self->format_result('Bundle',@which); +} +#-> sub CPAN::Shell::d ; +sub d { print shift->format_result('Distribution',@_);} +#-> sub CPAN::Shell::m ; +sub m { print shift->format_result('Module',@_);} + +#-> sub CPAN::Shell::i ; +sub i { + my($self) = shift; + my(@args) = @_; + my(@type,$type,@m); + @type = qw/Author Bundle Distribution Module/; + @args = '/./' unless @args; + my(@result); + for $type (@type) { + push @result, $self->expand($type,@args); + } + my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; + $result ||= "No objects found of any type for argument @args\n"; + print $result; +} + +#-> sub CPAN::Shell::o ; +sub o { + my($self,$o_type,@o_what) = @_; + $o_type ||= ""; + CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); + if ($o_type eq 'conf') { + shift @o_what if @o_what && $o_what[0] eq 'help'; + if (!@o_what) { + my($k,$v); + print "CPAN::Config options:\n"; + for $k (sort keys %CPAN::Config::can) { + $v = $CPAN::Config::can{$k}; + printf " %-18s %s\n", $k, $v; + } + print "\n"; + for $k (sort keys %$CPAN::Config) { + $v = $CPAN::Config->{$k}; + if (ref $v) { + printf " %-18s\n", $k; + print map {"\t$_\n"} @{$v}; + } else { + printf " %-18s %s\n", $k, $v; + } + } + print "\n"; + } elsif (!CPAN::Config->edit(@o_what)) { + print qq[Type 'o conf' to view configuration edit options\n\n]; + } + } elsif ($o_type eq 'debug') { + my(%valid); + @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; + if (@o_what) { + while (@o_what) { + my($what) = shift @o_what; + if ( exists $CPAN::DEBUG{$what} ) { + $CPAN::DEBUG |= $CPAN::DEBUG{$what}; + } elsif ($what =~ /^\d/) { + $CPAN::DEBUG = $what; + } elsif (lc $what eq 'all') { + my($max) = 0; + for (values %CPAN::DEBUG) { + $max += $_; + } + $CPAN::DEBUG = $max; + } else { + for (keys %CPAN::DEBUG) { + next unless lc($_) eq lc($what); + $CPAN::DEBUG |= $CPAN::DEBUG{$_}; + } + print "unknown argument $what\n"; + } + } + } else { + print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all'). + " or a number. Completion works on the options. Case is ignored.\n\n"; + } + if ($CPAN::DEBUG) { + print "Options set for debugging:\n"; + my($k,$v); + for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { + $v = $CPAN::DEBUG{$k}; + printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG; + } + } else { + print "Debugging turned off completely.\n"; + } + } else { + print qq{ +Known options: + conf set or get configuration variables + debug set or get debugging options +}; + } +} + +#-> sub CPAN::Shell::reload ; +sub reload { + if ($_[1] =~ /cpan/i) { + CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; + my $fh = IO::File->new($INC{'CPAN.pm'}); + local $/; + undef $/; + eval <$fh>; + warn $@ if $@; + } elsif ($_[1] =~ /index/) { + CPAN::Index->force_reload; + } +} + +#-> sub CPAN::Shell::_binary_extensions ; +sub _binary_extensions { + my($self) = shift @_; + my(@result,$module,%seen,%need,$headerdone); + for $module ($self->expand('Module','/./')) { + my $file = $module->cpan_file; + next if $file eq "N/A"; + next if $file =~ /^Contact Author/; + next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/; + next unless $module->xs_file; + push @result, $module; + } +# print join " | ", @result; +# print "\n"; + return @result; +} + +#-> sub CPAN::Shell::recompile ; +sub recompile { + my($self) = shift @_; + my($module,@module,$cpan_file,%dist); + @module = $self->_binary_extensions(); + for $module (@module){ # we force now and compile later, so we don't do it twice + $cpan_file = $module->cpan_file; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->force; + $dist{$cpan_file}++; + } + for $cpan_file (sort keys %dist) { + print " CPAN: Recompiling $cpan_file\n\n"; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->install; + $CPAN::Signal = 0; # it's tempting to reset Signal, so we can + # stop a package from recompiling, + # e.g. IO-1.12 when we have perl5.003_10 + } +} + +#-> sub CPAN::Shell::_u_r_common ; +sub _u_r_common { + my($self) = shift @_; + my($what) = shift @_; + CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; + Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; + Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; + my(@args) = @_; + @args = '/./' unless @args; + my(@result,$module,%seen,%need,$headerdone,$version_zeroes); + $version_zeroes = 0; + my $sprintf = "%-25s %9s %9s %s\n"; + for $module ($self->expand('Module',@args)) { + my $file = $module->cpan_file; + next unless defined $file; # ?? + my($latest) = $module->cpan_version || 0; + my($inst_file) = $module->inst_file; + my($have); + if ($inst_file){ + if ($what eq "a") { + $have = $module->inst_version; + } elsif ($what eq "r") { + $have = $module->inst_version; + local($^W) = 0; + $version_zeroes++ unless $have; + next if $have >= $latest; + } elsif ($what eq "u") { + next; + } + } else { + if ($what eq "a") { + next; + } elsif ($what eq "r") { + next; + } elsif ($what eq "u") { + $have = "-"; + } + } + $seen{$file} ||= 0; + if ($what eq "a") { + push @result, sprintf "%s %s\n", $module->id, $have; + } elsif ($what eq "r") { + push @result, $module->id; + next if $seen{$file}++; + } elsif ($what eq "u") { + push @result, $module->id; + next if $seen{$file}++; + next if $file =~ /^Contact/; + } + unless ($headerdone++){ + print "\n"; + printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file"; + } + $latest = substr($latest,0,8) if length($latest) > 8; + $have = substr($have,0,8) if length($have) > 8; + printf $sprintf, $module->id, $have, $latest, $file; + $need{$module->id}++; + return if $CPAN::Signal; # this is sometimes lengthy + } + unless (%need) { + if ($what eq "u") { + print "No modules found for @args\n"; + } elsif ($what eq "r") { + print "All modules are up to date for @args\n"; + } + } + if ($what eq "r" && $version_zeroes) { + my $s = $version_zeroes>1 ? "s have" : " has"; + print qq{$version_zeroes installed module$s no version number to compare\n}; + } + @result; +} + +#-> sub CPAN::Shell::r ; +sub r { + shift->_u_r_common("r",@_); +} + +#-> sub CPAN::Shell::u ; +sub u { + shift->_u_r_common("u",@_); +} + +#-> sub CPAN::Shell::autobundle ; +sub autobundle { + my($self) = shift; + my(@bundle) = $self->_u_r_common("a",@_); + my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + File::Path::mkpath($todir); + unless (-d $todir) { + print "Couldn't mkdir $todir for some reason\n"; + return; + } + my($y,$m,$d) = (localtime)[5,4,3]; + $y+=1900; + $m++; + my($c) = 0; + my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; + my($to) = $CPAN::META->catfile($todir,"$me.pm"); + while (-f $to) { + $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; + $to = $CPAN::META->catfile($todir,"$me.pm"); + } + my($fh) = IO::File->new(">$to") or Carp::croak "Can't open >$to: $!"; + $fh->print( + "package Bundle::$me;\n\n", + "\$VERSION = '0.01';\n\n", + "1;\n\n", + "__END__\n\n", + "=head1 NAME\n\n", + "Bundle::$me - Snapshot of installation on ", + $Config::Config{'myhostname'}, + " on ", + scalar(localtime), + "\n\n=head1 SYNOPSIS\n\n", + "perl -MCPAN -e 'install Bundle::$me'\n\n", + "=head1 CONTENTS\n\n", + join("\n", @bundle), + "\n\n=head1 CONFIGURATION\n\n", + Config->myconfig, + "\n\n=head1 AUTHOR\n\n", + "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n", + ); + $fh->close; + print "\nWrote bundle file + $to\n\n"; +} + +#-> sub CPAN::Shell::expand ; +sub expand { + shift; + my($type,@args) = @_; + my($arg,@m); + for $arg (@args) { + my $regex; + if ($arg =~ m|^/(.*)/$|) { + $regex = $1; + } + my $class = "CPAN::$type"; + my $obj; + if (defined $regex) { + for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { + push @m, $obj if $obj->id =~ /$regex/i or $obj->can('name') && $obj->name =~ /$regex/i; + } + } else { + my($xarg) = $arg; + if ( $type eq 'Bundle' ) { + $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; + } + if ($CPAN::META->exists($class,$xarg)) { + $obj = $CPAN::META->instance($class,$xarg); + } elsif ($obj = $CPAN::META->exists($class,$arg)) { + $obj = $CPAN::META->instance($class,$arg); + } else { + next; + } + push @m, $obj; + } + } + return @m; +} + +#-> sub CPAN::Shell::format_result ; +sub format_result { + my($self) = shift; + my($type,@args) = @_; + @args = '/./' unless @args; + my(@result) = $self->expand($type,@args); + my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; + $result ||= "No objects of type $type found for argument @args\n"; + $result; +} + +#-> sub CPAN::Shell::rematein ; +sub rematein { + shift; + my($meth,@some) = @_; + my $pragma = ""; + if ($meth eq 'force') { + $pragma = $meth; + $meth = shift @some; + } + CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; + my($s,@s); + foreach $s (@some) { + my $obj; + if (ref $s) { + $obj = $s; + } elsif ($s =~ m|/|) { # looks like a file + $obj = $CPAN::META->instance('CPAN::Distribution',$s); + } elsif ($s =~ m|^Bundle::|) { + $obj = $CPAN::META->instance('CPAN::Bundle',$s); + } else { + $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s); + } + if (ref $obj) { + CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG; + $obj->$pragma() if $pragma && $obj->can($pragma); + $obj->$meth(); + } else { + print "Warning: Cannot $meth $s, don't know what it is\n"; + } + } +} + +#-> sub CPAN::Shell::force ; +sub force { shift->rematein('force',@_); } +#-> sub CPAN::Shell::readme ; +sub readme { shift->rematein('readme',@_); } +#-> sub CPAN::Shell::make ; +sub make { shift->rematein('make',@_); } +#-> sub CPAN::Shell::clean ; +sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Shell::test ; +sub test { shift->rematein('test',@_); } +#-> sub CPAN::Shell::install ; +sub install { shift->rematein('install',@_); } + +package CPAN::FTP; +use vars qw($Ua); +@CPAN::FTP::ISA = qw(CPAN::Debug); + +#-> sub CPAN::FTP::ftp_get ; +sub ftp_get { + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] + on host [$host] as local [$target]\n] + ) if $CPAN::DEBUG; + my $ftp = Net::FTP->new($host); + $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; + $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ + warn "Couldn't login on $host"; + return; + } + # print qq[Going to ->cwd("$dir")\n]; + unless ( $ftp->cwd($dir) ){ + warn "Couldn't cwd $dir"; + return; + } + $ftp->binary; + $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; + unless ( $ftp->get($file,$target) ){ + warn "Couldn't fetch $file from $host"; + return; + } + $ftp->quit; +} + +#-> sub CPAN::FTP::localize ; +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; + + return $aslocal if -f $aslocal && -r _ && ! $force; + + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir". + I\'ll continue, but if you face any problems, they may be due + to insufficient permissions.\n} unless -w $aslocal_dir; + + # Inheritance is not easier to manage than a few if/else branches + if ($CPAN::META->hasLWP) { + require LWP::UserAgent; + unless ($Ua) { + $Ua = new LWP::UserAgent; + $Ua->proxy('ftp', $ENV{'ftp_proxy'}) if defined $ENV{'ftp_proxy'}; + $Ua->proxy('http', $ENV{'http_proxy'}) if defined $ENV{'http_proxy'}; + $Ua->no_proxy($ENV{'no_proxy'}) if defined $ENV{'no_proxy'}; + } + } + + # Try the list of urls for each single object. We keep a record + # where we did get a file from + for (0..$#{$CPAN::Config->{urllist}}) { + my $url = $CPAN::Config->{urllist}[$_]; + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing[$url]") if $CPAN::DEBUG; + if ($url =~ /^file:/) { + my $l; + if ($CPAN::META->hasLWP) { + require URI::URL; + my $u = new URI::URL $url; + $l = $u->path; + } else { # works only on Unix, is poorly constructed, but + # 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 + ($l = $url) =~ s,^file://[^/]+,,; # discard the host part + $l =~ s/^file://; # assume they meant file://localhost + } + return $l if -f $l && -r _; + } + + if ($CPAN::META->hasLWP) { + print "Fetching $url\n"; + my $res = $Ua->mirror($url, $aslocal); + if ($res->is_success) { + return $aslocal; + } + } + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + my($host,$dir,$getfile) = ($1,$2,$3); + if ($CPAN::META->hasFTP) { + $dir =~ s|/+|/|g; + $self->debug("Going to fetch file [$getfile] + from dir [$dir] + on host [$host] + as local [$aslocal]") if $CPAN::DEBUG; + CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; + } elsif (-x $CPAN::Config->{'ftp'}) { + my($netrc) = CPAN::FTP::netrc->new; + if ($netrc->hasdefault() || $netrc->contains($host)) { + print( + qq{ + Trying with external ftp to get $url + As this requires some features that are not thoroughly tested, we\'re + not sure, that we get it right. Please, install Net::FTP as soon + as possible. Just type "install Net::FTP". Thank you. + +} + ); + my($fh) = IO::File->new; + my($cwd) = Cwd::cwd(); + chdir $aslocal_dir; + my($targetfile) = File::Basename::basename($aslocal); + my(@dialog); + push @dialog, map {"cd $_\n"} split "/", $dir; + push @dialog, "get $getfile $targetfile\n"; + push @dialog, "quit\n"; + open($fh, "|$CPAN::Config->{'ftp'} $host") or die "Couldn't open ftp: $!"; + # pilot is blind now + foreach (@dialog) { + $fh->print($_); + } + chdir($cwd); + return $aslocal; + } else { + my($netrcfile) = $netrc->netrc(); + if ($netrcfile){ + print qq{ Your $netrcfile does not contain host $host.\n} + } else { + print qq{ I could not find or open your .netrc file.\n} + } + print qq{ If you want to use external ftp, + please enter the host $host (or a default entry) + into your .netrc file and retry. + + The format of a proper entry in your .netrc file would be: + machine $host + login ftp + password $Config::Config{cf_email} + + A typical default entry would be: + default login ftp password $Config::Config{cf_email} + + Please make also sure, your .netrc will not be readable by others. + You don\'t have to leave and restart CPAN.pm, I\'ll look again next + time I come around here.\n\n}; + } + } + sleep 2; + } + if (-x $CPAN::Config->{'lynx'}) { +## $self->debug("Trying with lynx for [$url]") if $CPAN::DEBUG; + my($want_compressed); + print( + qq{ + Trying with lynx to get $url + As lynx has so many options and versions, we\'re not sure, that we + get it right. It is recommended that you install Net::FTP as soon + as possible. Just type "install Net::FTP". Thank you. + +} + ); + $want_compressed = $aslocal =~ s/\.gz//; + my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal"; + if (system($system)==0) { + if ($want_compressed) { + $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; + if (system($system)==0) { + rename $aslocal, "$aslocal.gz"; + } else { + $system = "$CPAN::Config->{'gzip'} $aslocal"; + system($system); + } + return "$aslocal.gz"; + } else { + $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; + if (system($system)==0) { + $system = "$CPAN::Config->{'gzip'} -d $aslocal"; + system($system); + } else { + # should be fine, eh? + } + return $aslocal; + } + } + } + warn "Can't access URL $url. + Either get LWP or Net::FTP + or an external lynx or ftp"; + } + Carp::croak("Cannot fetch $file from anywhere"); +} + +package CPAN::FTP::external; + +package CPAN::FTP::netrc; + +sub new { + my($class) = @_; + my $file = MY->catfile($ENV{HOME},".netrc"); + my($fh,@machines,$hasdefault); + $hasdefault = 0; + if($fh = IO::File->new($file,"r")){ + local($/) = ""; + NETRC: while (<$fh>) { + my(@tokens) = split ' ', $_; + TOKEN: while (@tokens) { + my($t) = shift @tokens; + $hasdefault++, last NETRC if $t eq "default"; # we will most + # probably be + # able to anonftp + last TOKEN if $t eq "macdef"; + if ($t eq "machine") { + push @machines, shift @tokens; + } + } + } + } else { + $file = ""; + } + bless { + 'mach' => [@machines], + 'netrc' => $file, + 'hasdefault' => $hasdefault, + }, $class; +} + +sub hasdefault { shift->{'hasdefault'} } +sub netrc { shift->{'netrc'} } +sub contains { + my($self,$mach) = @_; + scalar grep {$_ eq $mach} @{$self->{'mach'}}; +} + +package CPAN::Complete; +@CPAN::Complete::ISA = qw(CPAN::Debug); + +#-> sub CPAN::Complete::complete ; +sub complete { + my($word,$line,$pos) = @_; + $word ||= ""; + $line ||= ""; + $pos ||= 0; + CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + $line =~ s/^\s*//; + my @return; + if ($pos == 0) { + @return = grep(/^$word/, sort qw(! a b d h i m o q r u autobundle clean make test install reload)); + } elsif ( $line !~ /^[\!abdhimorut]/ ) { + @return = (); + } elsif ($line =~ /^a\s/) { + @return = completex('CPAN::Author',$word); + } elsif ($line =~ /^b\s/) { + @return = completex('CPAN::Bundle',$word); + } elsif ($line =~ /^d\s/) { + @return = completex('CPAN::Distribution',$word); + } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) { + @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word)); + } elsif ($line =~ /^i\s/) { + @return = complete_any($word); + } elsif ($line =~ /^reload\s/) { + @return = complete_reload($word,$line,$pos); + } elsif ($line =~ /^o\s/) { + @return = complete_option($word,$line,$pos); + } else { + @return = (); + } + return @return; +} + +#-> sub CPAN::Complete::completex ; +sub completex { + my($class, $word) = @_; + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); +} + +#-> sub CPAN::Complete::complete_any ; +sub complete_any { + my($word) = shift; + return ( + completex('CPAN::Author',$word), + completex('CPAN::Bundle',$word), + completex('CPAN::Distribution',$word), + completex('CPAN::Module',$word), + ); +} + +#-> sub CPAN::Complete::complete_reload ; +sub complete_reload { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@words) = split " ", $line; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@ok) = qw(cpan index); + return @ok if @words==1; + return grep /^\Q$word\E/, @ok if @words==2 && $word; +} + +#-> sub CPAN::Complete::complete_option ; +sub complete_option { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@words) = split " ", $line; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@ok) = qw(conf debug); + return @ok if @words==1; + return grep /^\Q$word\E/, @ok if @words==2 && $word; + if (0) { + } elsif ($words[1] eq 'index') { + return (); + } elsif ($words[1] eq 'conf') { + return CPAN::Config::complete(@_); + } elsif ($words[1] eq 'debug') { + return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; + } +} + +package CPAN::Index; +use vars qw($last_time); +@CPAN::Index::ISA = qw(CPAN::Debug); +$last_time ||= 0; + +#-> sub CPAN::Index::force_reload ; +sub force_reload { + my($class) = @_; + $CPAN::Index::last_time = 0; + $class->reload(1); +} + +#-> sub CPAN::Index::reload ; +sub reload { + my($cl,$force) = @_; + my $time = time; + + # XXX check if a newer one is available. (We currently read it from time to time) + return if $last_time + $CPAN::Config->{index_expire}*86400 > $time; + $last_time = $time; + + $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force)); + return if $CPAN::Signal; # this is sometimes lengthy + $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force)); + return if $CPAN::Signal; # this is sometimes lengthy + $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force)); +} + +#-> sub CPAN::Index::reload_x ; +sub reload_x { + my($cl,$wanted,$localname,$force) = @_; + $force ||= 0; + 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; + $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n}); + return $abs_wanted; + } else { + $force ||= 1; + } + return CPAN::FTP->localize($wanted,$abs_wanted,$force); +} + +#-> sub CPAN::Index::read_authindex ; +sub read_authindex { + my($cl,$index_target) = @_; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + warn "Going to read $index_target\n"; + my $fh = IO::File->new("$pipe|"); + while (<$fh>) { + chomp; + my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + next unless $userid && $fullname && $email; + + # instantiate an author object + my $userobj = $CPAN::META->instance('CPAN::Author',$userid); + $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); + return if $CPAN::Signal; + } + $fh->close; + $? and Carp::croak "FAILED $pipe: exit status [$?]"; +} + +#-> sub CPAN::Index::read_modpacks ; +sub read_modpacks { + my($cl,$index_target) = @_; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + warn "Going to read $index_target\n"; + my $fh = IO::File->new("$pipe|"); + while (<$fh>) { + next if 1../^\s*$/; + chomp; + my($mod,$version,$dist) = split; + $version =~ s/^\+//; + + # if it as a bundle, instatiate a bundle object + my($bundle); + if ($mod =~ /^Bundle::(.*)/) { + $bundle = $1; + } + + if ($mod eq 'CPAN') { + local($^W)=0; + if ($version > $CPAN::VERSION){ + print qq{ + Hey, you know what? There\'s a new CPAN.pm version (v$version) + available! I\'d suggest--provided you have time--you try + install CPAN + reload cpan + without quitting the current session. It should be a seemless upgrade + while we are running... +}; + sleep 2; + print qq{\n}; + } + } + + my($id); + if ($bundle){ + $id = $CPAN::META->instance('CPAN::Bundle',$mod); + $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); +# This "next" makes us faster but if the job is running long, we ignore +# rereads which is bad. So we have to be a bit slower again. +# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { +# next; + } else { + # instantiate a module object + $id = $CPAN::META->instance('CPAN::Module',$mod); + $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); + } + + # determine the author + my($userid) = $dist =~ /([^\/]+)/; + $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/; + + # instantiate a distribution object + unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ) + if $userid =~ /\w/; + } + + return if $CPAN::Signal; + } + $fh->close; + $? and Carp::croak "FAILED $pipe: exit status [$?]"; +} + +#-> sub CPAN::Index::read_modlist ; +sub read_modlist { + my($cl,$index_target) = @_; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + warn "Going to read $index_target\n"; + my $fh = IO::File->new("$pipe|"); + my $eval = ""; + while (<$fh>) { + next if 1../^\s*$/; + next if /use vars/; # will go away in 03... + $eval .= $_; + return if $CPAN::Signal; + } + $eval .= q{CPAN::Modulelist->data;}; + local($^W) = 0; + my($comp) = Safe->new("CPAN::Safe1"); + my $ret = $comp->reval($eval); + Carp::confess($@) if $@; + return if $CPAN::Signal; + for (keys %$ret) { + my $obj = $CPAN::META->instance(CPAN::Module,$_); + $obj->set(%{$ret->{$_}}); + return if $CPAN::Signal; + } +} + +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); + +#-> sub CPAN::InfoObj::new ; +sub new { my $this = bless {}, shift; %$this = @_; $this } + +#-> sub CPAN::InfoObj::set ; +sub set { + my($self,%att) = @_; + my(%oldatt) = %$self; + %$self = (%oldatt, %att); +} + +#-> sub CPAN::InfoObj::id ; +sub id { shift->{'ID'} } + +#-> sub CPAN::InfoObj::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s\n", $class, $self->{ID}; + join "", @m; +} + +#-> sub CPAN::InfoObj::as_string ; +sub as_string { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, $class, " id = $self->{ID}\n"; + for (sort keys %$self) { + next if $_ eq 'ID'; + my $extra = ""; + $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; + if (ref $self->{$_}) { # Should we setup a language interface? XXX + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + } else { + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + } + } + join "", @m, "\n"; +} + +#-> sub CPAN::InfoObj::author ; +sub author { + my($self) = @_; + $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; +} + +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj); + +#-> sub CPAN::Author::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; + join "", @m; +} + +# Dead code, I would have liked to have,,, but it was never reached,,, +#sub make { +# my($self) = @_; +# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; +#} + +#-> sub CPAN::Author::fullname ; +sub fullname { shift->{'FULLNAME'} } +*name = \&fullname; +#-> sub CPAN::Author::email ; +sub email { shift->{'EMAIL'} } + +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj); + +#-> sub CPAN::Distribution::called_for ; +sub called_for { + my($self,$id) = @_; + $self->{'CALLED_FOR'} = $id if defined $id; + return $self->{'CALLED_FOR'}; +} + +#-> sub CPAN::Distribution::get ; +sub get { + my($self) = @_; + EXCUSE: { + my @e; + exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}"; + print join "", map {" $_\n"} @e and return if @e; + } + my($local_file); + my($local_wanted) = + CPAN->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/",$self->{ID}) + ); + + $self->debug("Doing localize") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); + $self->{localfile} = $local_file; + my $builddir = $CPAN::META->{cachemgr}->dir; + $self->debug("doing chdir $builddir") if $CPAN::DEBUG; + chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); + my $packagedir; + + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; + 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 "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 ($distdir,$packagedir); + if (@readdir == 1 && -d $readdir[0]) { + $distdir = $readdir[0]; + $packagedir = $CPAN::META->catdir($builddir,$distdir); + -d $packagedir and print "Removing previously used $packagedir\n"; + File::Path::rmtree($packagedir); + rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); + } else { + my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; + $pragmatic_dir =~ s/\W_//g; + $pragmatic_dir++ while -d "../$pragmatic_dir"; + $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir); + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = $CPAN::META->catdir($packagedir,$f); + rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); + } + } + $self->{'build_dir'} = $packagedir; + + chdir ".."; + $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ + print "Going to unlink $local_file\n"; + unlink $local_file or Carp::carp "Couldn't unlink $local_file"; + } + my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL"); + unless (-f $makefilepl) { + my($configure) = $CPAN::META->catfile($packagedir,"Configure"); + if (-f $configure) { + # do we have anything to do? + $self->{'configure'} = $configure; + } else { + my $fh = IO::File->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 +# 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 CPAN::Distribution::new ; +sub new { + my($class,%att) = @_; + + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); + + my $this = { %att }; + return bless $this, $class; +} + +#-> sub CPAN::Distribution::readme ; +sub readme { + my($self) = @_; + print "Readme not yet implemented (says ".$self->id.")\n"; +} + +#-> sub CPAN::Distribution::verifyMD5 ; +sub verifyMD5 { + my($self) = @_; + EXCUSE: { + my @e; + $self->{MD5_STATUS} 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; + push @local, "CHECKSUMS"; + my($local_wanted) = + CPAN->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + @local + ); + local($") = "/"; + if ( + -f $local_wanted + && + $self->MD5_check_file($local_wanted,$basename) + ) { + return $self->{MD5_STATUS}="OK"; + } + $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{'); + my($checksum_pipe); + if ($local_file) { + # fine + } else { + $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$//; + } + $self->MD5_check_file($local_file,$basename); +} + +#-> sub CPAN::Distribution::MD5_check_file ; +sub MD5_check_file { + my($self,$lfile,$basename) = @_; + my($cksum); + my $fh = new IO::File; + local($/)=undef; + if (open $fh, $lfile){ + 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 { + die join( + "", + "\nChecksum mismatch for distribution file. Please investigate.\n\n", + $self->as_string, + $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string, + "Please contact the author or your CPAN site admin" + ); + } + close $fh if fileno($fh); + } else { + print "No md5 checksum for $basename in local $lfile\n"; + return; + } + } else { + Carp::carp "Could not open $lfile for reading"; + } +} + +#-> sub CPAN::Distribution::eq_MD5 ; +sub eq_MD5 { + my($self,$fh,$expectMD5) = @_; + my $md5 = new MD5; + $md5->addfile($fh); + my $hexdigest = $md5->hexdigest; + $hexdigest eq $expectMD5; +} + +#-> sub CPAN::Distribution::force ; +sub force { + my($self) = @_; + $self->{'force_update'}++; + delete $self->{'MD5_STATUS'}; + delete $self->{'archived'}; + delete $self->{'build_dir'}; + delete $self->{'localfile'}; + delete $self->{'make'}; + delete $self->{'install'}; + delete $self->{'unwrapped'}; + delete $self->{'writemakefile'}; +} + +#-> sub CPAN::Distribution::make ; +sub make { + my($self) = @_; + $self->debug($self->id) if $CPAN::DEBUG; + print "Running make\n"; + $self->get; + if ($CPAN::META->hasMD5) { + $self->verifyMD5; + } + EXCUSE: { + my @e; + $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive."; + $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually"; + exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile"; + defined $self->{'make'} and push @e, "Has already been processed within this session"; + print join "", map {" $_\n"} @e and return if @e; + } + print "\n CPAN: Going to build ".$self->id."\n\n"; + my $builddir = $self->dir; + chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); + $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + + my $system; + if ($self->{'configure'}) { + $system = $self->{'configure'}; + } else { + my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me! + $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}"; + } + $SIG{ALRM} = sub { die "inactivity_timeout reached\n" }; + my($ret,$pid); + $@ = ""; + if ($CPAN::Config->{inactivity_timeout}) { + eval { + alarm $CPAN::Config->{inactivity_timeout}; + #$SIG{CHLD} = \&REAPER; + if (defined($pid=fork)) { + if ($pid) { #parent + wait; + } else { #child + exec $system; + } + } else { + print "Cannot fork: $!"; + return; + } + $ret = system($system); + }; + alarm 0; + } else { + $ret = system($system); + } + if ($@){ + kill 9, $pid; + waitpid $pid, 0; + print $@; + $self->{writemakefile} = "NO - $@"; + $@ = ""; + return; + } elsif ($ret != 0) { + $self->{writemakefile} = "NO"; + return; + } + $self->{writemakefile} = "YES"; + return if $CPAN::Signal; + $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; + if (system($system)==0) { + print " $system -- OK\n"; + $self->{'make'} = "YES"; + } else { + $self->{writemakefile} = "YES"; + $self->{'make'} = "NO"; + print " $system -- NOT OK\n"; + } +} + +#-> sub CPAN::Distribution::test ; +sub test { + my($self) = @_; + $self->make; + return if $CPAN::Signal; + print "Running make test\n"; + EXCUSE: { + my @e; + exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test"; + exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + print join "", map {" $_\n"} @e and return if @e; + } + chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + my $system = join " ", $CPAN::Config->{'make'}, "test"; + if (system($system)==0) { + print " $system -- OK\n"; + $self->{'make_test'} = "YES"; + } else { + $self->{'make_test'} = "NO"; + print " $system -- NOT OK\n"; + } +} + +#-> sub CPAN::Distribution::clean ; +sub clean { + my($self) = @_; + print "Running make clean\n"; + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + print join "", map {" $_\n"} @e and return if @e; + } + chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + my $system = join " ", $CPAN::Config->{'make'}, "clean"; + if (system($system)==0) { + print " $system -- OK\n"; + $self->force; + } else { + # Hmmm, what to do if make clean failed? + } +} + +#-> sub CPAN::Distribution::install ; +sub install { + my($self) = @_; + $self->test; + return if $CPAN::Signal; + print "Running make install\n"; + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install"; + exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; + exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success"; + print join "", map {" $_\n"} @e and return if @e; + } + chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}; + my($pipe) = IO::File->new("$system 2>&1 |"); + my($makeout) = ""; + + # #If I were to try this, I'd do something like: + # # + # # $SIG{ALRM} = sub { die "alarm\n" }; + # # + # # open(PROC,"make somesuch|"); + # # eval { + # # alarm 30; + # # while(<PROC>) { + # # alarm 30; + # # } + # # } + # # close(PROC); + # # alarm 0; + # # + # #I'm really not sure how reliable this would is, though. + # # + # #-- + # #Kenneth Albanowski (kjahds@kjahds.com, CIS: 70705,126) + # # + # # + # # + # # + while (<$pipe>){ + print; + $makeout .= $_; + } + $pipe->close; + if ($?==0) { + print " $system -- OK\n"; + $self->{'install'} = "YES"; + } else { + $self->{'install'} = "NO"; + print " $system -- NOT OK\n"; + if ($makeout =~ /permission/s && $> > 0) { + print " You may have to su to root to install the package\n"; + } + } +} + +#-> sub CPAN::Distribution::dir ; +sub dir { + shift->{'build_dir'}; +} + +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module); + +#-> sub CPAN::Bundle::as_string ; +sub as_string { + my($self) = @_; + $self->contains; + return $self->SUPER::as_string; +} + +#-> sub CPAN::Bundle::contains ; +sub contains { + my($self) = @_; + my($parsefile) = $self->inst_file; + unless ($parsefile) { + # Try to get at it in the cpan directory + $self->debug("no parsefile") if $CPAN::DEBUG; + my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'}); + $self->debug($dist->as_string) if $CPAN::DEBUG; + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + File::Path::mkpath($todir); + my($me,$from,$to); + ($me = $self->id) =~ s/.*://; + $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm"); + $to = $CPAN::META->catfile($todir,"$me.pm"); + File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!"); + $parsefile = $to; + } + my @result; + my $fh = new IO::File; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + while (<$fh>) { + $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = [@result]; + @result; +} + +#-> sub CPAN::Bundle::inst_file ; +sub inst_file { + my($self) = @_; + my($me,$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 = $self->SUPER::inst_file; + return $self->{'INST_FILE'} = $inst_file if -f $inst_file; + return $self->{'INST_FILE'}; # even if undefined? +} + +#-> sub CPAN::Bundle::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; + my($s); + for $s ($self->contains) { + $CPAN::META->instance('CPAN::Module',$s)->$meth(); + } +} + +#-> sub CPAN::Bundle::force ; +sub force { shift->rematein('force',@_); } +#-> sub CPAN::Bundle::install ; +sub install { shift->rematein('install',@_); } +#-> sub CPAN::Bundle::clean ; +sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Bundle::test ; +sub test { shift->rematein('test',@_); } +#-> sub CPAN::Bundle::make ; +sub make { shift->rematein('make',@_); } + +# XXX not yet implemented! +#-> sub CPAN::Bundle::readme ; +sub readme { + my($self) = @_; + my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; + $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; + $CPAN::META->instance('CPAN::Distribution',$file)->readme; +# CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX +} + +package CPAN::Module; +@CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj); + +#-> sub CPAN::Module::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; + join "", @m; +} + +#-> sub CPAN::Module::as_string ; +sub as_string { + my($self) = @_; + my(@m); + CPAN->debug($self) if $CPAN::DEBUG; + my $class = ref($self); + $class =~ s/^CPAN:://; + local($^W) = 0; + push @m, $class, " id = $self->{ID}\n"; + my $sprintf = " %-12s %s\n"; + push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description}; + my $sprintf2 = " %-12s %s (%s)\n"; + my($userid); + if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ + push @m, sprintf( + $sprintf2, + 'CPAN_USERID', + $userid, + $CPAN::META->instance(CPAN::Author,$userid)->fullname + ) + } + push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION}; + push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE}; + my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; + my(%statd,%stats,%statl,%stati); + @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,; + @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; + @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; + @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,; + $statd{' '} = 'unknown'; + $stats{' '} = 'unknown'; + $statl{' '} = 'unknown'; + $stati{' '} = 'unknown'; + push @m, sprintf( + $sprintf3, + 'DSLI_STATUS', + $self->{statd}, + $self->{stats}, + $self->{statl}, + $self->{stati}, + $statd{$self->{statd}}, + $stats{$self->{stats}}, + $statl{$self->{statl}}, + $stati{$self->{stati}} + ) if $self->{statd}; + my $local_file = $self->inst_file; + if ($local_file && ! exists $self->{MANPAGE}) { + my $fh = IO::File->new($local_file) or Carp::croak("Couldn't open $local_file: $!"); + my $inpod = 0; + my(@result); + local $/ = "\n"; + while (<$fh>) { + $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, $_; + } + close $fh; + $self->{MANPAGE} = join " ", @result; + } + push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE}; + push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)"; + push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file; + join "", @m, "\n"; +} + +#-> sub CPAN::Module::cpan_file ; +sub cpan_file { + my $self = shift; + CPAN->debug($self->id) if $CPAN::DEBUG; + unless (defined $self->{'CPAN_FILE'}) { + CPAN::Index->reload; + } + if (defined $self->{'CPAN_FILE'}){ + return $self->{'CPAN_FILE'}; + } elsif (defined $self->{'userid'}) { + return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname + } else { + return "N/A"; + } +} + +*name = \&cpan_file; + +#-> sub CPAN::Module::cpan_version ; +sub cpan_version { shift->{'CPAN_VERSION'} } + +#-> sub CPAN::Module::force ; +sub force { + my($self) = @_; + $self->{'force_update'}++; +} + +#-> sub CPAN::Module::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug($self->id) if $CPAN::DEBUG; + my $cpan_file = $self->cpan_file; + return if $cpan_file eq "N/A"; + return if $cpan_file =~ /^Contact Author/; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->called_for($self->id); + $pack->force if exists $self->{'force_update'}; + $pack->$meth(); + delete $self->{'force_update'}; +} + +#-> sub CPAN::Module::readme ; +sub readme { shift->rematein('readme') } +#-> sub CPAN::Module::make ; +sub make { shift->rematein('make') } +#-> sub CPAN::Module::clean ; +sub clean { shift->rematein('clean') } +#-> sub CPAN::Module::test ; +sub test { shift->rematein('test') } +#-> sub CPAN::Module::install ; +sub install { + my($self) = @_; + my($doit) = 0; + my($latest) = $self->cpan_version; + $latest ||= 0; + my($inst_file) = $self->inst_file; + my($have) = 0; + if (defined $inst_file) { + $have = $self->inst_version; + } + if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) { + print $self->id, " is up to date.\n"; + } else { + $doit = 1; + } + $self->rematein('install') if $doit; +} + +#-> sub CPAN::Module::inst_file ; +sub inst_file { + my($self) = @_; + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + $packpath[-1] .= ".pm"; + foreach $dir (@INC) { + my $pmfile = CPAN->catfile($dir,@packpath); + if (-f $pmfile){ + return $pmfile; + } + } +} + +#-> sub CPAN::Module::xs_file ; +sub xs_file { + my($self) = @_; + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + push @packpath, $packpath[-1]; + $packpath[-1] .= "." . $Config::Config{'dlext'}; + foreach $dir (@INC) { + my $xsfile = CPAN->catfile($dir,'auto',@packpath); + if (-f $xsfile){ + return $xsfile; + } + } +} + +#-> sub CPAN::Module::inst_version ; +sub inst_version { + my($self) = @_; + my $parsefile = $self->inst_file or return 0; + my $have = MY->parse_version($parsefile); + $have ||= 0; + $have =~ s/\s+//g; + $have ||= 0; + $have; +} + +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj); +use File::Find; + +#-> sub CPAN::CacheMgr::as_string ; +sub as_string { + eval { require Data::Dumper }; + if ($@) { + return shift->SUPER::as_string; + } else { + return Data::Dumper::Dumper(shift); + } +} + +#-> sub CPAN::CacheMgr::cachesize ; +sub cachesize { + shift->{DU}; +} + +# sub check { +# my($self,@dirs) = @_; +# return unless -d $self->{ID}; +# my $dir; +# @dirs = $self->dirs unless @dirs; +# for $dir (@dirs) { +# $self->disk_usage($dir); +# } +# } + +#-> sub CPAN::CacheMgr::clean_cache ; +sub clean_cache { + my $self = shift; + my $dir; + while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { + $self->force_clean_cache($dir); + } + $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; +} + +#-> sub CPAN::CacheMgr::dir ; +sub dir { + shift->{ID}; +} + +#-> sub CPAN::CacheMgr::entries ; +sub entries { + my($self,$dir) = @_; + $dir ||= $self->{ID}; + my($cwd) = Cwd::cwd(); + chdir $dir or Carp::croak("Can't chdir to $dir: $!"); + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my(@entries); + for ($dh->read) { + next if $_ eq "." || $_ eq ".."; + if (-f $_) { + push @entries, $CPAN::META->catfile($dir,$_); + } elsif (-d _) { + push @entries, $CPAN::META->catdir($dir,$_); + } else { + print STDERR "Warning: weird direntry in $dir: $_\n"; + } + } + chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); + sort {-M $b <=> -M $a} @entries; +} + +#-> sub CPAN::CacheMgr::disk_usage ; +sub disk_usage { + my($self,$dir) = @_; + if (! defined $dir or $dir eq "") { + $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; + return; + } + return if defined $self->{SIZE}{$dir}; + local($Du) = 0; + find( + sub { + return if -l $_; + $Du += -s; + }, + $dir + ); + $self->{SIZE}{$dir} = $Du/1024/1024; + push @{$self->{FIFO}}, $dir; + $self->debug("measured $dir is $Du") if $CPAN::DEBUG; + $self->{DU} += $Du/1024/1024; + if ($self->{DU} > $self->{'MAX'} ) { + printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n", + $self->{DU}, $self->{'MAX'}; + $self->clean_cache; + } else { + $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG; + $self->debug($self->as_string) if $CPAN::DEBUG; + } + $self->{DU}; +} + +#-> sub CPAN::CacheMgr::force_clean_cache ; +sub force_clean_cache { + my($self,$dir) = @_; + $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG; + File::Path::rmtree($dir); + $self->{DU} -= $self->{SIZE}{$dir}; + delete $self->{SIZE}{$dir}; +} + +#-> sub CPAN::CacheMgr::new ; +sub new { + my $class = shift; + my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 }; + File::Path::mkpath($self->{ID}); + my $dh = DirHandle->new($self->{ID}); + bless $self, $class; + $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; + my $e; + for $e ($self->entries) { + next if $e eq ".." || $e eq "."; + $self->debug("Have to check size $e") if $CPAN::DEBUG; + $self->disk_usage($e); + } + $self; +} + +package CPAN::Debug; + +#-> sub CPAN::Debug::debug ; +sub debug { + my($self,$arg) = @_; + my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) 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"; + if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ + if (ref $arg) { + eval { require Data::Dumper }; + if ($@) { + print $arg->as_string; + } else { + print Data::Dumper::Dumper($arg); + } + } else { + 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", +); + +#-> sub CPAN::Config::edit ; +sub edit { + my($class,@args) = @_; + return unless @args; + CPAN->debug("class[$class]args[".join(" | ",@args)."]"); + my($o,$str,$func,$args,$key_exists); + $o = shift @args; + if($can{$o}) { + $class->$o(@args); + return 1; + } else { + if (ref($CPAN::Config->{$o}) eq ARRAY) { + $func = shift @args; + # Let's avoid eval, it's easier to comprehend without. + if ($func eq "push") { + push @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "pop") { + pop @{$CPAN::Config->{$o}}; + } elsif ($func eq "shift") { + shift @{$CPAN::Config->{$o}}; + } elsif ($func eq "unshift") { + unshift @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "splice") { + splice @{$CPAN::Config->{$o}}, @args; + } else { + $CPAN::Config->{$o} = [@args]; + } + } else { + $CPAN::Config->{$o} = $args[0]; + print " $o "; + print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; + } + } +} + +#-> sub CPAN::Config::commit ; +sub commit { + my($self, $configpm) = @_; + my $mode; + # mkpath!? + + my($fh) = IO::File->new; + $configpm ||= cfile(); + if (-f $configpm) { + $mode = (stat $configpm)[2]; + if ($mode && ! -w _) { + print "$configpm is not writable\n" and return; + } + #chmod 0644, $configpm; #? + } + + 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. + +EOF + $msg ||= "\n"; + open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; + print $fh qq[$msg\$CPAN::Config = \{\n]; + foreach (sort keys %$CPAN::Config) { + print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n"; + } + + print $fh "};\n1;\n__END__\n"; + close $fh; + + #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + #chmod $mode, $configpm; + $self->defaults; + print "commit: wrote $configpm\n"; + 1; +} + +*default = \&defaults; +#-> sub CPAN::Config::defaults ; +sub defaults { + my($self) = @_; + $self->unload; + $self->load; + 1; +} + +my $dot_cpan; +#-> sub CPAN::Config::load ; +sub load { + my($self) = @_; + eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems + unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++; + eval {require CPAN::MyConfig;}; # where you can override system wide settings + unless ( $self->load_succeeded ) { + require CPAN::FirstTime; + my($configpm,$fh); + if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { + $configpm = $INC{"CPAN/Config.pm"}; + } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { + $configpm = $INC{"CPAN/MyConfig.pm"}; + } else { + my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); + my($configpmdir) = MY->catdir($path_to_cpan,"CPAN"); + my($configpmtest) = MY->catfile($configpmdir,"Config.pm"); + if (-d $configpmdir || File::Path::mkpath($configpmdir)) { +#_#_# following code dumped core on me with 5.003_11, a.k. +#_#_# $fh = IO::File->new; +#_#_# if ($fh->open(">$configpmtest")) { +#_#_# $fh->print("1;\n"); +#_#_# $configpm = $configpmtest; +#_#_# } + if (-w $configpmtest or -w $configpmdir) { + $configpm = $configpmtest; + } + } + unless ($configpm) { + $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN"); + File::Path::mkpath($configpmdir); + $configpmtest = MY->catfile($configpmdir,"MyConfig.pm"); + if (-w $configpmtest or -w $configpmdir) { + $configpm = $configpmtest; + } else { + warn "WARNING: CPAN.pm is unable to create a configuration file.\n"; + } + } + } + warn "Calling CPAN::FirstTime::init($configpm)"; + CPAN::FirstTime::init($configpm); + } +} + +#-> sub CPAN::Config::load_succeeded ; +sub load_succeeded { + my($miss) = 0; + for (qw( + cpan_home keep_source_where build_dir build_cache index_expire + gzip tar unzip make pager makepl_arg make_arg make_install_arg + urllist inhibit_startup_message + )) { + $miss++ unless defined $CPAN::Config->{$_}; # we want them all + } + return !$miss; +} + +#-> sub CPAN::Config::unload ; +sub unload { + delete $INC{'CPAN/MyConfig.pm'}; + delete $INC{'CPAN/Config.pm'}; +} + +#-> sub CPAN::Config::cfile ; +sub cfile { + $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'}; +} + +*h = \&help; +#-> sub CPAN::Config::help ; +sub help { + print <<EOF; +Known options: + defaults reload default config values from disk + commit commit session changes to disk + +You may edit key values in the follow fashion: + + o conf build_cache 15 + + o conf build_dir "/foo/bar" + + o conf urllist shift + + o conf urllist unshift ftp://ftp.foo.bar/ + +EOF + undef; #don't reprint CPAN::Config +} + +#-> sub CPAN::Config::complete ; +sub complete { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@words) = split " ", $line; + my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config); + return (@o_conf) unless @words>2; + if($words[2] =~ /->(.*)/) { + my $meth = $1; + my(@methods) = qw(shift unshift push pop splice); + return @methods unless $meth; + return sort grep /^\Q$meth\E/, @methods; + } + return sort grep /^\Q$word\E/, @o_conf; +} + +1; + +=head1 NAME + +CPAN - query, download and build perl modules from CPAN sites + +=head1 SYNOPSIS + +Interactive mode: + + perl -MCPAN -e shell; + +Batch mode: + + use CPAN; + + autobundle, clean, install, make, recompile, test + +=head1 DESCRIPTION + +The CPAN module is designed to automate the make and install of perl +modules and extensions. It includes some searching capabilities and +knows how to use Net::FTP or LWP (or lynx or an external ftp client) +to fetch the raw data from the net. + +Modules are fetched from one or more of the mirrored CPAN +(Comprehensive Perl Archive Network) sites and unpacked in a dedicated +directory. + +The CPAN module also supports the concept of named and versioned +'bundles' of modules. Bundles simplify the handling of sets of +related modules. See BUNDLES below. + +The package contains a session manager and a cache manager. There is +no status retained between sessions. The session manager keeps track +of what has been fetched, built and installed in the current +session. The cache manager keeps track of the disk space occupied by +the make processes and deletes excess space according to a simple FIFO +mechanism. + +All methods provided are accessible in a programmer style and in an +interactive shell style. + +=head2 Interactive Mode + +The interactive mode is entered by running + + perl -MCPAN -e shell + +which puts you into a readline interface. You will have most fun if +you install Term::ReadKey and Term::ReadLine to enjoy both history and +completion. + +Once you are on the command line, type 'h' and the rest should be +self-explanatory. + +The most common uses of the interactive modes are + +=over 2 + +=item Searching for authors, bundles, distribution files and modules + +There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> +for each of the four categories and another, C<i> for any of the +mentioned four. Each of the four entities is implemented as a class +with slightly differing methods for displaying an object. + +Arguments you pass to these commands are either strings matching exact +the identification string of an object or regular expressions that are +then matched case-insensitively against various attributes of the +objects. The parser recognizes a regualar expression only if you +enclose it between two slashes. + +The principle is that the number of found objects influences how an +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 + Author id = ANDK + EMAIL a.koenig@franz.ww.TU-Berlin.DE + FULLNAME Andreas König + + + cpan> a /andk/ + Author id = ANDK + EMAIL a.koenig@franz.ww.TU-Berlin.DE + FULLNAME Andreas König + + + cpan> a /and.*rt/ + Author ANDYD (Andy Dougherty) + Author MERLYN (Randal L. Schwartz) + +=item make, test, install, clean modules or distributions + +The four commands do indeed exist just as written above. Each of them +takes as many arguments as provided and investigates for each what it +might 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> and C<test> are run unconditionally. A + + C<install E<lt>distribution_fileE<gt>> + +also is run unconditionally. But for + + C<install E<lt>moduleE<gt>> + +CPAN checks if an install is actually needed for it and prints +I<Foo up to date> in case the module doesnE<39>t need to be updated. + +CPAN also keeps track of what it has done within the current session +and doesnE<39>t try to build a package a second time regardless if it +succeeded or not. The C<force > command takes as first argument the +method to invoke (currently: make, test, or install) and executes the +command from scratch. + +Example: + + cpan> install OpenGL + OpenGL is up to date. + cpan> force install OpenGL + Running make + OpenGL-0.4/ + OpenGL-0.4/COPYRIGHT + [...] + +=back + +=head2 CPAN::Shell + +The commands that are available in the shell interface are methods in +the package CPAN::Shell. If you enter the shell command, all your +input is split by the Text::ParseWords::shellwords() routine which +acts like most shells do. The first word is being interpreted as the +method to be called and the rest of the words are treated as arguments +to this method. + +=head2 ProgrammerE<39>s interface + +If you do not enter the shell, the available shell commands are both +available as methods (C<CPAN::Shell-E<gt>install(...)>) and as +functions in the calling package (C<install(...)>). The +programmerE<39>s interface has beta status. Do not heavily rely on it, +changes may still be necessary. + +=head2 Cache Manager + +Currently the cache manager only keeps track of the build directory +($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that +deletes complete directories below C<build_dir> as soon as the size of +all directories there gets bigger than $CPAN::Config->{build_cache} +(in MB). The contents of this cache may be used for later +re-installations that you intend to do manually, but will never be +trusted by CPAN itself. This is due to the fact that the user might +use these directories for building modules on different architectures. + +There is another directory ($CPAN::Config->{keep_source_where}) where +the original distribution files are kept. This directory is not +covered by the cache manager and must be controlled by the user. If +you choose to have the same directory as build_dir and as +keep_source_where directory, then your sources will be deleted with +the same fifo mechanism. + +=head2 Bundles + +A bundle is just a perl module in the namespace Bundle:: that does not +define any functions or methods. It usually only contains documentation. + +It starts like a perl module with a package declaration and a $VERSION +variable. After that the pod section looks like any other pod with the +only difference, that I<one special pod section> exists starting with +(verbatim): + + =head1 CONTENTS + +In this pod section each line obeys the format + + Module_Name [Version_String] [- optional text] + +The only required part is the first field, the name of a module +(eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest +of the line is optional. The comment part is delimited by a dash just +as in the man page header. + +The distribution of a bundle should follow the same convention as +other distributions. + +Bundles are treated specially in the CPAN package. If you say 'install +Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all +the modules in the CONTENTS section of the pod. You can install your +own Bundles locally by placing a conformant Bundle file somewhere into +your @INC path. The autobundle() command which is available in the +shell interface does that for you by including all currently installed +modules in a snapshot bundle file. + +There is a meaningless Bundle::Demo available on CPAN. Try to install +it, it usually does no harm, just demonstrates what the Bundle +interface looks like. + +=head2 autobundle + +C<autobundle> writes a bundle file into the +C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains +a list of all modules that are both available from CPAN and currently +installed within @INC. The name of the bundle file is based on the +current date and a counter. + +=head2 recompile + +recompile() is a very special command in that it takes no argument and +runs the make/test/install cycle with brute force over all installed +dynamically loadable extensions (aka XS modules) with 'force' in +effect. Primary purpose of this command is to act as a rescue in case +your 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. + +Another popular use for recompile is to finish a network +installation. Imagine, you have a common source tree for two different +architectures. You decide to do a completely independent fresh +installation. You start on one architecture with the help of a Bundle +file produced earlier. CPAN installs the whole Bundle for you, but +when you try to repeat the job on the second architecture, CPAN +responds with a C<"Foo up to date"> message for all modules. So you +will be glad to run recompile in the second architecture and +youE<39>re done. + +=head1 CONFIGURATION + +When the CPAN module is installed a site wide configuration file is +created as CPAN/Config.pm. The default values defined there can be +overridden in another configuration file: CPAN/MyConfig.pm. You can +store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because +$HOME/.cpan is added to the search path of the CPAN module before the +use() or require() statements. + +Currently the following keys in the hash reference $CPAN::Config are +defined: + + build_cache size of cache for directories to build modules + build_dir locally accessible directory to build modules + index_expire after how many days refetch index files + cpan_home local directory reserved for this package + gzip location of external program gzip + inactivity_timeout breaks interactive Makefile.PLs after that + many seconds inactivity. Set to 0 to never break. + inhibit_startup_message + if true, does not print the startup message + keep_source keep the source in a local directory? + keep_source_where where keep the source (if we do) + make location of external program make + make_arg arguments that should always be passed to 'make' + make_install_arg same as make_arg for 'make install' + makepl_arg arguments passed to 'perl Makefile.PL' + pager location of external program more (or any pager) + tar location of external program tar + unzip location of external program unzip + urllist arrayref to nearby CPAN sites (or equivalent locations) + +You can set and query each of these options interactively in the cpan +shell with the command set defined within the C<o conf> command: + +=over 2 + +=item o conf E<lt>scalar optionE<gt> + +prints the current value of the I<scalar option> + +=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> + +Sets the value of the I<scalar option> to I<value> + +=item o conf E<lt>list optionE<gt> + +prints the current value of the I<list option> in MakeMaker's +neatvalue format. + +=item o conf E<lt>list optionE<gt> [shift|pop] + +shifts or pops the array in the I<list option> variable + +=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> + +works like the corresponding perl commands. + +=back + +=head1 SECURITY + +There's no strong security layer in CPAN.pm. CPAN.pm helps you to +install foreign, unmasked, unsigned code on your machine. We compare +to a checksum that comes from the net just as the distribution file +itself. If somebody has managed to tamper with the distribution file, +they may have as well tampered with the CHECKSUMS file. Future +development will go towards strong authentification. + +=head1 EXPORT + +Most functions in package CPAN are exported per default. The reason +for this is that the primary use is intended for the cpan shell or for +oneliners. + +=head1 Debugging + +The debugging of this module is pretty difficult, because we have +interferences of the software producing the indices on CPAN, of the +mirroring process on CPAN, of packaging, of configuration, of +synchronicity, and of bugs within CPAN.pm. + +In interactive mode you can try "o debug" which will list options for +debugging the various parts of the package. The output may not be very +useful for you as it's just a byproduct of my own testing, but if you +have an idea which part of the package may have a bug, it's sometimes +worth to give it a try and send me more specific output. You should +know that "o debug" has built-in completion support. + +=head2 Prerequisites + +If you have a local mirror of CPAN and can access all files with +"file:" URLs, then you only need perl5.003 to run this +module. Otherwise Net::FTP is recommended. LWP may be required for +non-UNIX systems or if your nearest CPAN site is associated with an +URL that is not C<ftp:>. + +If you have neither Net::FTP nor LWP, there is a fallback mechanism +implemented for an external ftp command or for an external lynx +command. + +This module presumes that all packages on CPAN + +=over 2 + +=item * + +declare their $VERSION variable in an easy to parse manner. This +prerequisite can hardly be relaxed because it consumes by far too much +memory to load all packages into the running program just to determine +the $VERSION variable . Currently all programs that are dealing with +version use something like this + + perl -MExtUtils::MakeMaker -le \ + 'print MM->parse_version($ARGV[0])' filename + +If you are author of a package and wonder if your $VERSION can be +parsed, please try the above method. + +=item * + +come as compressed or gzipped tarfiles or as zip files and contain a +Makefile.PL (well we try to handle a bit more, but without much +enthusiasm). + +=back + +=head1 AUTHOR + +Andreas König E<lt>a.koenig@mind.deE<gt> + +=head1 SEE ALSO + +perl(1), CPAN::Nox(3) + +=cut + diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm new file mode 100644 index 0000000000..aba93e8b86 --- /dev/null +++ b/lib/CPAN/FirstTime.pm @@ -0,0 +1,304 @@ +package CPAN::Mirrored::By; + +sub new { + my($self,@arg) = @_; + bless [@arg], $self; +} +sub con { shift->[0] } +sub cou { shift->[1] } +sub url { shift->[2] } + +package CPAN::FirstTime; + +use strict; +use ExtUtils::MakeMaker qw(prompt); +require File::Path; +use vars qw($VERSION); +$VERSION = "1.00"; + +=head1 NAME + +CPAN::FirstTime - Utility for CPAN::Config file Initialization + +=head1 SYNOPSIS + +CPAN::FirstTime::init() + +=head1 DESCRIPTION + +The init routine asks a few questions and writes a CPAN::Config +file. Nothing special. + +=cut + + +sub init { + my($configpm) = @_; + use Config; + require CPAN::Nox; + eval {require CPAN::Config;}; + $CPAN::Config ||= {}; + + my($ans,$default,$local,$cont,$url,$expected_size); + + print qq{ + +The CPAN module needs a directory of its own to cache important +index files and maybe keep a temporary mirror of CPAN files. This may +be a site-wide directory or a personal directory. +}; + + my $cpan_home = $CPAN::Config->{cpan_home} || MM->catdir($ENV{HOME}, ".cpan"); + if (-d $cpan_home) { + print qq{ + +I see you already have a directory + $cpan_home +Shall we use it as the general CPAN build and cache directory? + +}; + } else { + print qq{ + +First of all, I\'d like to create this directory. Where? + +}; + } + + $default = $cpan_home; + until (-d ($ans = prompt("CPAN build and cache directory?",$default)) && -w _) { + print "Couldn't find directory $ans + or directory is not writable. Please retry.\n"; + } + File::Path::mkpath($ans); # dies if it can't + $CPAN::Config->{cpan_home} = $ans; + + print qq{ + +If you want, I can keep the source files after a build in the cpan +home directory. If you choose so then future builds will take the +files from there. If you don\'t want to keep them, answer 0 to the +next question. + +}; + + $CPAN::Config->{keep_source_where} = MM->catdir($CPAN::Config->{cpan_home},"sources"); + $CPAN::Config->{build_dir} = MM->catdir($CPAN::Config->{cpan_home},"build"); + + print qq{ + +How big should the disk cache be for keeping the build directories +with all the intermediate files? + +}; + + $default = $CPAN::Config->{build_cache} || 10; + $ans = prompt("Cache size for build directory (in MB)?", $default); + $CPAN::Config->{build_cache} = $ans; + + # XXX This the time when we refetch the index files (in days) + $CPAN::Config->{'index_expire'} = 1; + + print qq{ + +The CPAN module will need a few external programs to work +properly. Please correct me, if I guess the wrong path for a program. + +}; + + my(@path) = split($Config{path_sep},$ENV{PATH}); + my $prog; + for $prog (qw/gzip tar unzip make lynx ftp/){ + my $path = $CPAN::Config->{$prog} || find_exe($prog,[@path]) || $prog; + $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; + $CPAN::Config->{'pager'} = $ans; + print qq{ + +Every Makefile.PL is run by perl in a seperate process. Likewise we +run \'make\' and \'make install\' in processes. If you have any parameters +\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to +the calls, please specify them here. + +}; + + $default = $CPAN::Config->{makepl_arg} || ""; + $CPAN::Config->{makepl_arg} = + prompt("Parameters for the 'perl Makefile.PL' command?",$default); + $default = $CPAN::Config->{make_arg} || ""; + $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default); + + $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || ""; + $CPAN::Config->{make_install_arg} = + prompt("Parameters for the 'make install' command?",$default); + + print qq{ + +Sometimes you may wish to leave the processes run by CPAN alone +without caring about them. As sometimes the Makefile.PL contains +question you\'re expected to answer, you can set a timer that will +kill a 'perl Makefile.PL' process after the specified time in seconds. + +If you set this value to 0, these processes will wait forever. + +}; + + $default = $CPAN::Config->{inactivity_timeout} || 0; + $CPAN::Config->{inactivity_timeout} = + prompt("Timout for inacivity during Makefile.PL?",$default); + + $default = $CPAN::Config->{makepl_arg} || ""; + + $local = 'MIRRORED.BY'; + if (@{$CPAN::Config->{urllist}||[]}) { + print qq{ +I found a list of URLs in CPAN::Config and will use this. +You can change it later with the 'o conf' command. + +} + } elsif (-f $local) { # if they really have a wrong MIRRORED.BY in + # the current directory, we can't help + read_mirrored_by($local); + } else { + $CPAN::Config->{urllist} ||= []; + while (! @{$CPAN::Config->{urllist}}) { + print qq{ +We need to know the URL of your favorite CPAN site. +Please enter it here: }; + chop($_ = <>); + s/\s//g; + push @{$CPAN::Config->{urllist}}, $_ if $_; + } + } + + # We don't ask that now, it will be noticed in time.... + $CPAN::Config->{'inhibit_startup_message'} = 0; + + print "\n\n"; + CPAN::Config->commit($configpm); +} + +sub find_exe { + my($exe,$path) = @_; + my($dir,$MY); + $MY = {}; + bless $MY, 'MY'; + for $dir (@$path) { + my $abs = $MY->catfile($dir,$exe); + if ($MY->maybe_command($abs)) { + return $abs; + } + } +} + +sub read_mirrored_by { + my($local) = @_; + my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); + open FH, $local or die "Couldn't open $local: $!"; + while (<FH>) { + ($host) = /^([\w\.\-]+)/ unless defined $host; + next unless defined $host; + next unless /\s+dst_(dst|location)/; + /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and + ($continent, $country) = @location[-1,-2]; + $continent =~ s/\s\(.*//; + /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; + next unless $host && $dst && $continent && $country; + $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); + undef $host; + $dst=$continent=$country=""; + } + $CPAN::Config->{urllist} ||= []; + if ($expected_size = @{$CPAN::Config->{urllist}}) { + for $url (@{$CPAN::Config->{urllist}}) { + # sanity check, scheme+colon, not "q" there: + next unless $url =~ /^\w+:\/./; + $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url); + } + $CPAN::Config->{urllist} = []; + } else { + $expected_size = 6; + } + + print qq{ + +Now we need to know, where your favorite CPAN sites are located. Push +a few sites onto the array (just in case the first on the array won\'t +work). If you are mirroring CPAN to your local workstation, specify a +file: URL. + +You can enter the number in front of the URL on the next screen, a +file:, ftp: or http: URL, or "q" to finish selecting. + +}; + + $ans = prompt("Press RETURN to continue"); + my $other; + $ans = $other = ""; + my(%seen); + + while () { + my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; + my(@valid,$previous_best); + open FH, $pipe; + { + my($cont,$country,$url,$item); + my(@cont) = sort keys %all; + for $cont (@cont) { + print FH " $cont\n"; + for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { + for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { + my $t = sprintf( + " %-18s (%2d) %s\n", + $country, + ++$item, + $url + ); + if ($cont =~ /^\[/) { + $previous_best ||= $item; + } + push @valid, $all{$cont}{$country}{$url}; + print FH $t; + } + } + } + } + close FH; + $previous_best ||= 1; + $default = + @{$CPAN::Config->{urllist}} >= $expected_size ? "q" : $previous_best; + $ans = prompt( + "\nSelect an$other ftp or file URL or a number (q to finish)", + $default + ); + my $sel; + if ($ans =~ /^\d/) { + my $this = $valid[$ans-1]; + my($con,$cou,$url) = ($this->con,$this->cou,$this->url); + push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++; + delete $all{$con}{$cou}{$url}; + # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n"; + } elsif (@{$CPAN::Config->{urllist}} && $ans =~ /^q/i) { + last; + } else { + $ans =~ s|/?$|/|; # has to end with one slash + $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: + if ($ans =~ /^\w+:\/./) { + push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++; + } else { + print qq{"$ans" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm +later and report a bug in my Makefile.PL to me (andreas koenig). +Thanks.\n}; + } + } + $other ||= "other"; + } +} + +1; diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm new file mode 100644 index 0000000000..b0b70fec04 --- /dev/null +++ b/lib/CPAN/Nox.pm @@ -0,0 +1,33 @@ +BEGIN{$CPAN::Suppress_readline++;} + +use CPAN; + +$CPAN::META->hasMD5(0); +$CPAN::META->hasLWP(0); +@EXPORT = @CPAN::EXPORT; + +*AUTOLOAD = \&CPAN::AUTOLOAD; + +=head1 NAME + +CPAN::Nox - Wrapper around CPAN.pm without using any XS module + +=head1 SYNOPSIS + +Interactive mode: + + perl -MCPAN::Nox -e shell; + +=head1 DESCRIPTION + +This package has the same functionality as CPAN.pm, but tries to +prevent the usage of compiled extensions during it's own +execution. It's primary purpose is a rescue in case you upgraded perl +and broke binary compatibility somehow. + +=head1 SEE ALSO + +CPAN(3) + +=cut + diff --git a/lib/Carp.pm b/lib/Carp.pm index 5de8f83d14..de586489ba 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -29,6 +29,8 @@ not where carp() was called. $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. +$MaxArgLen = 64; # How much of each argument to print. 0 = all. +$MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; @ISA = Exporter; @@ -38,8 +40,10 @@ sub longmess { my $error = shift; my $mess = ""; my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$eval,$require); - while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + while (do { { package DB; @a = caller($i++) } } ) { + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; if ($error =~ m/\n$/) { $mess .= $error; } else { @@ -56,6 +60,22 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + if ($hargs) { + @a = @DB::args; # must get local copy of args + if ($MaxArgNums and @a > $MaxArgNums) { + $#a = $MaxArgNums; + $a[$#a] = "..."; + } + for (@a) { + $_ = "undef", next unless defined $_; + s/'/\\'/g; + substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + $sub .= '(' . join(', ', @a) . ')'; + } $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } diff --git a/lib/Class/Template.pm b/lib/Class/Template.pm new file mode 100644 index 0000000000..23a0d5ba83 --- /dev/null +++ b/lib/Class/Template.pm @@ -0,0 +1,254 @@ +package Class::Template; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(members struct); +use strict; + +# Template.pm --- struct/member template builder +# 12mar95 +# Dean Roehrich +# +# changes/bugs fixed since 28nov94 version: +# - podified +# changes/bugs fixed since 21nov94 version: +# - Fixed examples. +# changes/bugs fixed since 02sep94 version: +# - Moved to Class::Template. +# changes/bugs fixed since 20feb94 version: +# - Updated to be a more proper module. +# - Added "use strict". +# - Bug in build_methods, was using @var when @$var needed. +# - Now using my() rather than local(). +# +# Uses perl5 classes to create nested data types. +# This is offered as one implementation of Tom Christiansen's "structs.pl" +# idea. + +=head1 NAME + +Class::Template - struct/member template builder + +=head1 SYNOPSIS + + use Class::Template; + struct(name => { key1 => type1, key2 => type2 }); + + package Myobj; + use Class::Template; + members Myobj { key1 => type1, key2 => type2 }; + +=head1 DESCRIPTION + +This module uses perl5 classes to create nested data types. + +=head1 EXAMPLES + +=item * Example 1 + + use Class::Template; + + struct( rusage => { + ru_utime => timeval, + ru_stime => timeval, + }); + + struct( timeval => [ + tv_secs => '$', + tv_usecs => '$', + ]); + + my $s = new rusage; + +=item * Example 2 + + package OBJ; + use Class::Template; + + members OBJ { + 'a' => '$', + 'b' => '$', + }; + + members OBJ2 { + 'd' => '@', + 'c' => '$', + }; + + package OBJ2; @ISA = (OBJ); + + sub new { + my $r = InitMembers( &OBJ::InitMembers() ); + bless $r; + } + +=head1 NOTES + +Use '%' if the member should point to an anonymous hash. Use '@' if the +member should point to an anonymous array. + +When using % and @ the method requires one argument for the key or index +into the hash or array. + +Prefix the %, @, or $ with '*' to indicate you want to retrieve pointers to +the values rather than the values themselves. + +=cut + +Var: { + $Class::Template::print = 0; + sub printem { $Class::Template::print++ } +} + + +sub struct { + my( $struct, $ref ) = @_; + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my $out = ''; + + $out = "{\n package $struct;\n sub new {\n"; + parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 0 ); + $out .= " bless \$r;\n }\n"; + build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes ); + $out .= "}\n1;\n"; + + ( $Class::Template::print ) ? print( $out ) : eval $out; +} + +sub members { + my( $pkg, $ref ) = @_; + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my $out = ''; + + $out = "{\n package $pkg;\n sub InitMembers {\n"; + parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 1 ); + $out .= " bless \$r;\n }\n"; + build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes ); + $out .= "}\n1;\n"; + + ( $Class::Template::print ) ? print( $out ) : eval $out; +} + + +sub parse_fields { + my( $ref, $out, $methods, $refs, $arrays, $hashes, $member ) = @_; + my $type = ref $ref; + my @keys; + my $val; + my $cnt = 0; + my $idx = 0; + my( $cmt, $n ); + + if( $type eq 'HASH' ){ + if( $member ){ + $$out .= " my(\$r) = \@_ ? shift : {};\n"; + } + else{ + $$out .= " my(\$r) = {};\n"; + } + @keys = keys %$ref; + foreach (@keys){ + $val = $ref->{$_}; + if( $val =~ /^\*(.)/ ){ + $refs->{$_}++; + $val = $1; + } + if( $val eq '@' ){ + $$out .= " \$r->{'$_'} = [];\n"; + $arrays->{$_}++; + } + elsif( $val eq '%' ){ + $$out .= " \$r->{'$_'} = {};\n"; + $hashes->{$_}++; + } + elsif( $val ne '$' ){ + $$out .= " \$r->{'$_'} = \&${val}::new();\n"; + } + else{ + $$out .= " \$r->{'$_'} = undef;\n"; + } + push( @$methods, $_ ); + } + } + elsif( $type eq 'ARRAY' ){ + if( $member ){ + $$out .= " my(\$r) = \@_ ? shift : [];\n"; + } + else{ + $$out .= " my(\$r) = [];\n"; + } + while( $idx < @$ref ){ + $n = $ref->[$idx]; + push( @$methods, $n ); + $val = $ref->[$idx+1]; + $cmt = "# $n"; + if( $val =~ /^\*(.)/ ){ + $refs->{$n}++; + $val = $1; + } + if( $val eq '@' ){ + $$out .= " \$r->[$cnt] = []; $cmt\n"; + $arrays->{$n}++; + } + elsif( $val eq '%' ){ + $$out .= " \$r->[$cnt] = {}; $cmt\n"; + $hashes->{$n}++; + } + elsif( $val ne '$' ){ + $$out .= " \$r->[$cnt] = \&${val}::new();\n"; + } + else{ + $$out .= " \$r->[$cnt] = undef; $cmt\n"; + } + ++$cnt; + $idx += 2; + } + } +} + + +sub build_methods { + my( $ref, $out, $methods, $refs, $arrays, $hashes ) = @_; + my $type = ref $ref; + my $elem = ''; + my $cnt = 0; + my( $pre, $pst, $cmt, $idx ); + + foreach (@$methods){ + $pre = $pst = $cmt = $idx = ''; + if( defined $refs->{$_} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $$out .= " sub $_ {$cmt\n my \$r = shift;\n"; + if( $type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $type eq 'HASH' ){ + $elem = "{'$_'}"; + } + if( defined $arrays->{$_} ){ + $$out .= " my \$i;\n"; + $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $idx = "->[\$i]"; + } + elsif( defined $hashes->{$_} ){ + $$out .= " my \$i;\n"; + $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $idx = "->{\$i}"; + } + $$out .= " \@_ ? (\$r->$elem$idx = shift) : $pre\$r->$elem$idx$pst;\n"; + $$out .= " }\n"; + } +} + +1; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 83b472cf6a..e93cf1a0a9 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -38,7 +38,7 @@ the trailing line terminator). It is recommended that cwd (or another If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See -L<perlsub/Overriding builtin functions>.) Note that it will only be +L<perlsub/Overriding Builtin Functions>.) Note that it will only be kept up to date if all packages which use chdir import it from Cwd. =cut @@ -108,7 +108,7 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; + # warn "lstat($dotdots/$dir): $!"; # Just because you can't lstat this directory # doesn't mean you'll never find the right one. # closedir(PARENT); @@ -172,7 +172,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -237,30 +237,42 @@ sub _os2_cwd { return $ENV{'PWD'}; } -my($oldw) = $^W; -$^W = 0; # assignments trigger 'subroutine redefined' warning -if ($^O eq 'VMS') { - - *cwd = \&_vms_cwd; - *getcwd = \&_vms_cwd; - *fastcwd = \&_vms_cwd; - *fastgetcwd = \&_vms_cwd; +sub _msdos_cwd { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; } -elsif ($^O eq 'NT' or $^O eq 'MSWin32') { - # We assume that &_NT_cwd is defined as an XSUB or in the core. - *getcwd = \&_NT_cwd; - *fastcwd = \&_NT_cwd; - *fastgetcwd = \&_NT_cwd; +{ + local $^W = 0; # assignments trigger 'subroutine redefined' warning + + if ($^O eq 'VMS') { + *cwd = \&_vms_cwd; + *getcwd = \&_vms_cwd; + *fastcwd = \&_vms_cwd; + *fastgetcwd = \&_vms_cwd; + } + elsif ($^O eq 'NT' or $^O eq 'MSWin32') { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + *getcwd = \&_NT_cwd; + *fastcwd = \&_NT_cwd; + *fastgetcwd = \&_NT_cwd; + } + elsif ($^O eq 'os2') { + # sys_cwd may keep the builtin command + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + } + elsif ($^O eq 'msdos') { + *cwd = \&_msdos_cwd; + *getcwd = \&_msdos_cwd; + *fastgetcwd = \&_msdos_cwd; + *fastcwd = \&_msdos_cwd; + } } -elsif ($^O eq 'os2') { - # sys_cwd may keep the builtin command - *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - } -$^W = $oldw; # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/lib/Devel/SelfStubber.pm b/lib/Devel/SelfStubber.pm index 7bb38f6957..4c2d039580 100644 --- a/lib/Devel/SelfStubber.pm +++ b/lib/Devel/SelfStubber.pm @@ -35,7 +35,7 @@ sub stub { $fh = "${module}::DATA"; open($fh,$mod_file) || die "Unable to open $mod_file"; - while($line = <$fh> and $line !~ m/^__DATA__/) { + while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) { push(@BEFORE_DATA,$line); $line =~ /use\s+SelfLoader/ && $found_selfloader++; } @@ -45,7 +45,7 @@ sub stub { $self->_load_stubs($module); if ( fileno($fh) ) { $end = 1; - while($line = <$fh>) { + while(defined($line = <$fh>)) { push(@AFTER_DATA,$line); } } diff --git a/lib/Env.pm b/lib/Env.pm index 63beb07508..1f06bebf24 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -47,7 +47,11 @@ sub import { my ($callpack) = caller(0); my $pack = shift; my @vars = @_ ? @_ : keys(%ENV); + return unless @vars; + eval "package $callpack; use vars qw(" + . join(' ', map { '$'.$_ } @vars) . ")"; + die $@ if $@; foreach (@vars) { tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; } diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index 97832929f1..c663d64dd7 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -1,4 +1,4 @@ -# $Id: Embed.pm,v 1.18 1996/07/02 13:48:17 dougm Exp $ +# $Id: Embed.pm,v 1.21 1996/11/29 17:26:23 dougm Exp $ require 5.002; package ExtUtils::Embed; @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT $VERSION ); use strict; -$VERSION = sprintf("%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/); #for the namespace change $Devel::embed::VERSION = "99.99"; @@ -201,7 +201,7 @@ sub ldopts { my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) = $MM->ext(join ' ', - $MM->catdir("-L$Config{archlib}", "CORE"), " -lperl", + $MM->catdir("-L$Config{archlibexp}", "CORE"), " -lperl", @potential_libs); my $ld_or_bs = $bsloadlibs || $ldloadlibs; @@ -222,7 +222,7 @@ sub ccdlflags { } sub perl_inc { - print " -I$Config{archlib}/CORE "; + print " -I$Config{archlibexp}/CORE "; } sub ccopts { @@ -265,7 +265,7 @@ functions while building your application. =head1 @EXPORT ExtUtils::Embed exports the following functions: - + xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(), ccdlflags(), xsi_header(), xsi_protos(), xsi_body() @@ -301,7 +301,7 @@ B<[@modules]> is an array ref, same as additional arguments mentioned above. =item Examples - + perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket @@ -395,7 +395,7 @@ are picked up from the B<extralibs.ld> file in the same directory. perl -MExtUtils::Embed -e ldopts -- -std Socket - + This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension. @@ -419,11 +419,11 @@ conflict, the additional arguments will be part of the output. For including perl header files this function simply prints: - -I$Config{archlib}/CORE + -I$Config{archlibexp}/CORE So, rather than having to say: - perl -MConfig -e 'print "-I$Config{archlib}/CORE"' + perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"' Just say: @@ -457,7 +457,7 @@ B<xsinit()> uses the xsi_* functions to generate most of it's code. For examples on how to use B<ExtUtils::Embed> for building C/C++ applications with embedded perl, see the eg/ directory and L<perlembed>. - + =head1 SEE ALSO L<perlembed> diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index dda132565f..c7eb8b4028 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -1,7 +1,7 @@ package ExtUtils::Install; -$VERSION = substr q$Revision: 1.15 $, 10; -# $Date: 1996/09/03 21:58:58 $ +$VERSION = substr q$Revision: 1.16 $, 10; +# $Date: 1996/12/17 00:31:26 $ use Exporter; use Carp (); diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index dc8b94334e..9664e54127 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -2,15 +2,18 @@ package ExtUtils::Liblist; use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.20 $, 10; +$VERSION = substr q$Revision: 1.21 $, 10; use Config; use Cwd 'cwd'; use File::Basename; -my $Config_libext = $Config{lib_ext} || ".a"; - sub ext { + if ($^O eq 'VMS') { return &_vms_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { my($self,$potential_libs, $Verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including @@ -24,6 +27,8 @@ sub ext { my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs @@ -174,6 +179,136 @@ sub ext { ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } + +sub _vms_ext { + my($self, $potential_libs,$verbose) = @_; + return ('', '', '', '') unless $potential_libs; + + my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; + # List of common Unix library names and there VMS equivalents + # (VMS equivalent of '' indicates that the library is automatially + # searched by the linker, and should be skipped here.) + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + print STDOUT "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$Config{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + print STDOUT "Resolving directory $dir\n" if $verbose; + if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } + else { $dir = $self->catdir($cwd,$dir); } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$name,$test,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + print STDOUT "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + print "\tChecking $name\n" if $verbose > 2; + if (-f ($test = VMS::Filespec::rmsexpand($name))) { + # It's got its own suffix, so we'll have to figure out the type + if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } + elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + elsif ($test =~ /(?:$obj_ext|obj)$/i) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + } + else { + print STDOUT "Warning (will try anyway): Unknown library type for $test; assuming shared\n"; + $type = 'sh'; + } + } + elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'sh'; + $name = $test unless $test =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'olb'; + $name = $test unless $test =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + $name = $test unless $test =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'sh'; + } + } + if ($ctype) { + eval '$' . $ctype . "{'$cand'}++"; + die "Error recording library: $@" if $@; + print STDOUT "\tFound as $name (really $test), type $type\n" if $verbose > 1; + next LIB; + } + } + print STDOUT "Warning (will try anyway): No library found for $lib\n"; + } + + @libs = sort keys %obj; + # This has to precede any other CRTLs, so just make it first + if ($olb{VAXCCURSE}) { + push(@libs,"$olb{VAXCCURSE}/Library"); + delete $olb{VAXCCURSE}; + } + push(@libs, map { "$_/Library" } sort keys %olb); + push(@libs, map { "$_/Share" } sort keys %sh); + $lib = join(' ',@libs); + print "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + 1; __END__ @@ -247,11 +382,55 @@ object file. This list is used to create a .bs (bootstrap) file. This module deals with a lot of system dependencies and has quite a few architecture specific B<if>s in the code. +=head2 VMS implementation + +The version of ext() which is executed under VMS differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +present, a token is considered a directory to search if it is in fact +a directory, and a library to search for otherwise. Authors who wish +their extensions to be portable to Unix or OS/2 should use the Unix +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Wherever possible, shareable images are preferred to object libraries, +and object libraries to plain object files. In accordance with VMS +naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; +it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +used in some ported software. + +=item * + +For each library that is found, an appropriate directive for a linker options +file is generated. The return values are space-separated strings of +these directives, rather than elements used on the linker command line. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under VMS, and BSLOADLIBS +and LD_RIN_PATH are always empty. + +=back + +In addition, an attempt is made to recognize several common Unix library +names, and filter them out or convert them to their VMS equivalents, as +appropriate. + +In general, the VMS version of ext() should properly handle input from +extensions originally designed for a Unix or VMS environment. If you +encounter problems, or discover cases where the search could be improved, +please let us know. + =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut - - diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index ca2bf652ee..c44d6c9e2b 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -5,16 +5,16 @@ use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; use strict; -use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS +use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.107 $, 10; -# $Id: MM_Unix.pm,v 1.107 1996/09/03 20:53:39 k Exp $ +$VERSION = substr q$Revision: 1.109_01 $, 10; +# $Id: MM_Unix.pm,v 1.109 1996/12/17 00:42:32 k Exp k $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$Is_OS2 = $^O =~ m|^os/?2$|i; +$Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq "MacOS"; if ($Is_VMS = $^O eq 'VMS') { @@ -61,7 +61,7 @@ sections and complain loudly to the makemaker mailing list. Not all of the methods below are overridable in a Makefile.PL. Overridable methods are marked as (o). All methods are overridable by a platform specific MM_*.pm file (See -L<ExtUtils::MM_VMS> and L<ExtUtils::MM_OS2>). +L<ExtUtils::MM_VMS>) and L<ExtUtils::MM_OS2>). =head2 Preloaded methods @@ -236,8 +236,12 @@ use SelfLoader; __DATA__ +=back + =head2 SelfLoaded methods +=over 2 + =item c_o (o) Defines the suffix rules to compile different flavors of C files to @@ -492,7 +496,7 @@ sub constants { AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB - INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS + INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB @@ -1084,12 +1088,14 @@ in these dirs: 0; # false and not empty } +=back + =head2 Methods to actually produce chunks of text for the Makefile -The methods here are called in the order specified by -@ExtUtils::MakeMaker::MM_Sections. This manpage reflects the order as -well as possible. Some methods call each other, so in doubt refer to -the code. +The methods here are called for each MakeMaker object in the order +specified by @ExtUtils::MakeMaker::MM_Sections. + +=over 2 =item force (o) @@ -1376,7 +1382,7 @@ sub init_main { # It may also edit @modparts if required. if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); - } + } ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; @@ -1421,7 +1427,16 @@ sub init_main { $self->{PERL_INC} = $self->{PERL_SRC}; # catch a situation that has occurred a few times in the past: - warn <<EOM unless (-s $self->catfile($self->{PERL_SRC},'cflags') or $Is_VMS && -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') or $Is_Mac); + unless ( + -s $self->catfile($self->{PERL_SRC},'cflags') + or + $Is_VMS + && + -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') + or + $Is_Mac + ){ + warn qq{ You cannot build extensions below the perl source tree after executing a 'make clean' in the perl source tree. @@ -1433,26 +1448,27 @@ usually without extra arguments. It is recommended that you unpack and build additional extensions away from the perl source tree. -EOM +}; + } } else { # we should also consider $ENV{PERL5LIB} here $self->{PERL_LIB} ||= $Config::Config{privlibexp}; $self->{PERL_ARCHLIB} ||= $Config::Config{archlibexp}; $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; - die <<EOM unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))); + unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))){ + die qq{ Error: Unable to locate installed Perl libraries or Perl source code. It is recommended that you install perl in a standard location before -building extensions. You can say: - - $^X Makefile.PL PERL_SRC=/path/to/perl/source/directory - -if you have not yet installed perl but still want to build this -extension now. -(You get this message, because MakeMaker could not find "$perl_h") -EOM +building extensions. Some precompiled versions of perl do not contain +these header files, so you cannot build extensions. In such a case, +please build and install your perl from a fresh perl distribution. It +usually solves this kind of problem. +\(You get this message, because MakeMaker could not find "$perl_h"\) +}; + } # print STDOUT "Using header files found in $self->{PERL_INC}\n" # if $Verbose && $self->needs_linking(); @@ -1495,7 +1511,7 @@ EOM # The user who requests an installation directory explicitly # should not have to tell us a architecture installation directory - # as well We look if a directory exists that is named after the + # as well. We look if a directory exists that is named after the # architecture. If not we take it as a sign that it should be the # same as the requested installation directory. Otherwise we take # the found one. @@ -1523,23 +1539,67 @@ EOM # requested values. We're going to set the $Config{prefix} part of # all the installation path variables to literally $(PREFIX), so # the user can still say make PREFIX=foo - my($prefix) = $Config{'prefix'}; + my($configure_prefix) = $Config{'prefix'}; $prefix = VMS::Filespec::unixify($prefix) if $Is_VMS; - unless ($self->{PREFIX}){ - $self->{PREFIX} = $prefix; + $self->{PREFIX} ||= $configure_prefix; + + + my($install_variable,$search_prefix,$replace_prefix); + + # The rule, taken from Configure, is that if prefix contains perl, + # we shape the tree + # perlprefix/lib/ INSTALLPRIVLIB + # perlprefix/lib/pod/ + # perlprefix/lib/site_perl/ INSTALLSITELIB + # perlprefix/bin/ INSTALLBIN + # perlprefix/man/ INSTALLMAN1DIR + # else + # prefix/lib/perl5/ INSTALLPRIVLIB + # prefix/lib/perl5/pod/ + # prefix/lib/perl5/site_perl/ INSTALLSITELIB + # prefix/bin/ INSTALLBIN + # prefix/lib/perl5/man/ INSTALLMAN1DIR + + $replace_prefix = qq[\$\(PREFIX\)]; + for $install_variable (qw/ + INSTALLBIN + INSTALLSCRIPT + /) { + $self->prefixify($install_variable,$configure_prefix,$replace_prefix); + } + $search_prefix = $configure_prefix =~ /perl/ ? + $self->catdir($configure_prefix,"lib") : + $self->catdir($configure_prefix,"lib","perl5"); + if ($self->{LIB}) { + $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB}; + $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} = + $self->catdir($self->{LIB},$Config{'archname'}); + } else { + $replace_prefix = $self->{PREFIX} =~ /perl/ ? + $self->catdir(qq[\$\(PREFIX\)],"lib") : + $self->catdir(qq[\$\(PREFIX\)],"lib","perl5"); + for $install_variable (qw/ + INSTALLPRIVLIB + INSTALLARCHLIB + INSTALLSITELIB + INSTALLSITEARCH + /) { + $self->prefixify($install_variable,$search_prefix,$replace_prefix); + } } - my($install_variable); + $search_prefix = $configure_prefix =~ /perl/ ? + $self->catdir($configure_prefix,"man") : + $self->catdir($configure_prefix,"lib","perl5","man"); + $replace_prefix = $self->{PREFIX} =~ /perl/ ? + $self->catdir(qq[\$\(PREFIX\)],"man") : + $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man"); for $install_variable (qw/ - - INSTALLPRIVLIB INSTALLARCHLIB INSTALLBIN - INSTALLMAN1DIR INSTALLMAN3DIR INSTALLSCRIPT - INSTALLSITELIB INSTALLSITEARCH - + INSTALLMAN1DIR + INSTALLMAN3DIR /) { - $self->prefixify($install_variable,$prefix,q[$(PREFIX)]); + $self->prefixify($install_variable,$search_prefix,$replace_prefix); } - # Now we head at the manpages. Maybe they DO NOT want manpages # installed $self->{INSTALLMAN1DIR} = $Config::Config{installman1dir} @@ -1701,7 +1761,7 @@ sub init_others { # --- Initialize Other Attributes }; # These get overridden for VMS and maybe some other systems - $self->{NOOP} ||= "sh -c true"; + $self->{NOOP} ||= '$(SHELL) -c true'; $self->{FIRST_MAKEFILE} ||= "Makefile"; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; @@ -1923,6 +1983,10 @@ sub macro { Called by staticmake. Defines how to write the Makefile to produce a static new perl. +By default the Makefile produced includes all the static extensions in +the perl library. (Purified versions of library files, e.g., +DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + =cut sub makeaperl { @@ -1971,7 +2035,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) $cccmd = $self->const_cccmd($libperl); $cccmd =~ s/^CCCMD\s*=\s*//; $cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /; - $cccmd .= " $Config::Config{cccdlflags}" + $cccmd .= " $Config::Config{cccdlflags}" if ($Config::Config{useshrplib} eq 'true'); $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; @@ -1987,6 +2051,8 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; + # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; @@ -2107,7 +2173,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ - writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@ + writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@t && mv $@t $@ }; @@ -2337,9 +2403,9 @@ sub parse_version { my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; - - \$$1=undef; do { - $_ + + \$$1=undef; do { + $_ }; \$$1 }; local($^W) = 0; @@ -2364,12 +2430,14 @@ sub pasthru { my(@m,$key); my(@pasthru); + my($sep) = $Is_VMS ? ',' : ''; + $sep .= "\\\n\t"; - foreach $key (qw(LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){ + foreach $key (qw(LIB LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){ push @pasthru, "$key=\"\$($key)\""; } - push @m, "\nPASTHRU = ", join ("\\\n\t", @pasthru), "\n"; + push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; join "", @m; } @@ -2451,7 +2519,7 @@ $(OBJECT) : $(PERL_HDRS) =item pm_to_blib Defines target that copies all files in the hash PM to their -destination and autosplits them. See L<ExtUtils::Install/pm_to_blib> +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> =cut @@ -2888,8 +2956,9 @@ DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ -e 'print "=back";' UNINSTALL = $(PERL) -MExtUtils::Install \ --e 'uninstall($$ARGV[0],1);' - +-e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \ +-e 'print " packlist above carefully.\n There may be errors. Remove the";' \ +-e 'print " appropriate files manually.\n Sorry for the inconveniences.\n"' }; return join "", @m; @@ -3130,6 +3199,7 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o 1; +=back =head1 SEE ALSO diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index d05ddac6b8..13383e9411 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -6,7 +6,7 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (02-Oct-1996)'; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (19-Nov-1996)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; use Config; @@ -162,6 +162,30 @@ sub catfile { $rslt; } +=item wraplist + +Converts a list into a string wrapped at approximately 80 columns. + +=cut + +sub wraplist { + my($self) = shift; + my($line,$hlen) = ('',0); + my($word); + + foreach $word (@_) { + # Perl bug -- seems to occasionally insert extra elements when + # traversing array (scalar(@array) doesn't show them, but + # foreach(@array) does) (5.00307) + next unless $word =~ /\w/; + $line .= ', ' if length($line); + if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } + $line .= $word; + $hlen += length($word) + 2; + } + $line; +} + =item curdir (override) Returns a string representing of the current directory. @@ -194,6 +218,7 @@ sub updir { package ExtUtils::MM_VMS; +sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::guess_name; sub ExtUtils::MM_VMS::find_perl; sub ExtUtils::MM_VMS::path; @@ -204,7 +229,6 @@ sub ExtUtils::MM_VMS::file_name_is_absolute; sub ExtUtils::MM_VMS::replace_manpage_separator; sub ExtUtils::MM_VMS::init_others; sub ExtUtils::MM_VMS::constants; -sub ExtUtils::MM_VMS::const_loadlibs; sub ExtUtils::MM_VMS::cflags; sub ExtUtils::MM_VMS::const_cccmd; sub ExtUtils::MM_VMS::pm_to_blib; @@ -268,6 +292,16 @@ sub AUTOLOAD { #__DATA__ + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist. +sub ext { + ExtUtils::Liblist::ext(@_); +} + + =head2 SelfLoaded methods Those methods which override default MM_Unix methods are marked @@ -289,12 +323,24 @@ package name. sub guess_name { my($self) = @_; - my($defname,$defpm); + my($defname,$defpm,@pm,%xs,$pm); local *PM; $defname = basename(fileify($ENV{'DEFAULT'})); $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = map { s/.pm$//; $_ } glob('*.pm'); + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); + if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } } + } + } if (open(PM,"${defpm}.pm")){ while (<PM>) { if (/^\s*package\s+([^;]+)/i) { @@ -406,7 +452,7 @@ sub path { Follows VMS naming conventions for executable files. If the name passed in doesn't exactly match an executable file, appends F<.Exe> to check for executable image, and F<.Com> to check -for DCL procedure. If this fails, checks F<Sys$Share:> for an +for DCL procedure. If this fails, checks F<Sys$System:> for an executable file having the name specified. Finally, appends F<.Exe> and checks again. @@ -418,7 +464,7 @@ sub maybe_command { return "$file.exe" if -x "$file.exe"; return "$file.com" if -x "$file.com"; if ($file !~ m![/:>\]]!) { - my($shrfile) = 'Sys$Share:' . $file; + my($shrfile) = 'Sys$System:' . $file; return $file if -x $shrfile && ! -d _; return "$file.exe" if -x "$shrfile.exe"; } @@ -484,6 +530,8 @@ Checks for VMS directory spec as well as Unix separators. sub file_name_is_absolute { my($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; } @@ -549,7 +597,7 @@ sub constants { if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT})); + $self->{OBJECT} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); } $self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); @@ -643,12 +691,12 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision push @m,' # Handy lists of source code files: -XS_FILES = ',join(', ', sort keys %{$self->{XS}}),' -C_FILES = ',join(', ', @{$self->{C}}),' -O_FILES = ',join(', ', @{$self->{O_FILES}} ),' -H_FILES = ',join(', ', @{$self->{H}}),' -MAN1PODS = ',join(', ', sort keys %{$self->{MAN1PODS}}),' -MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),' +XS_FILES = ',$self->wraplist(', ', sort keys %{$self->{XS}}),' +C_FILES = ',$self->wraplist(', ', @{$self->{C}}),' +O_FILES = ',$self->wraplist(', ', @{$self->{O_FILES}} ),' +H_FILES = ',$self->wraplist(', ', @{$self->{H}}),' +MAN1PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN1PODS}}),' +MAN3PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN3PODS}}),' '; @@ -692,65 +740,14 @@ PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),' $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ]; $self->{PM_TO_BLIB} = [ %{$self->{PM}} ]; push @m,' -TO_INST_PM = ',join(', ',@{$self->{TO_INST_PM}}),' +TO_INST_PM = ',$self->wraplist(', ',@{$self->{TO_INST_PM}}),' -PM_TO_BLIB = ',join(', ',@{$self->{PM_TO_BLIB}}),' +PM_TO_BLIB = ',$self->wraplist(', ',@{$self->{PM_TO_BLIB}}),' '; join('',@m); } -=item const_loadlibs (override) - -Basically a stub which passes through library specfications provided -by the caller. Will be updated or removed when VMS support is added -to ExtUtils::Liblist. - -=cut - -sub const_loadlibs { - my($self) = @_; - my (@m); - push @m, " -# $self->{NAME} might depend on some other libraries. -# (These comments may need revising:) -# -# Dependent libraries can be linked in one of three ways: -# -# 1. (For static extensions) by the ld command when the perl binary -# is linked with the extension library. See EXTRALIBS below. -# -# 2. (For dynamic extensions) by the ld command when the shared -# object is built/linked. See LDLOADLIBS below. -# -# 3. (For dynamic extensions) by the DynaLoader when the shared -# object is loaded. See BSLOADLIBS below. -# -# EXTRALIBS = List of libraries that need to be linked with when -# linking a perl binary which includes this extension -# Only those libraries that actually exist are included. -# These are written to a file and used when linking perl. -# -# LDLOADLIBS = List of those libraries which can or must be linked into -# the shared library when created using ld. These may be -# static or dynamic libraries. -# LD_RUN_PATH is a colon separated list of the directories -# in LDLOADLIBS. It is passed as an environment variable to -# the process that links the shared library. -# -# BSLOADLIBS = List of those libraries that are needed but can be -# linked in dynamically at run time on this platform. -# SunOS/Solaris does not need this because ld records -# the information (from LDLOADLIBS) into the object file. -# This list is used to create a .bs (bootstrap) file. -# -EXTRALIBS = ",map($self->fixpath($_) . ' ',$self->{'EXTRALIBS'})," -BSLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'BSLOADLIBS'})," -LDLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'LDLOADLIBS'}),"\n"; - - join('',@m); -} - =item cflags (override) Bypass shell script and produce qualifiers for CC directly (but warn @@ -1271,7 +1268,21 @@ $(BASEEXT).opt : Makefile.PL $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); + if (length $self->{LDLOADLIBS}) { + my($lib); my($line) = ''; + foreach $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n" if $line; + } + join('',@m); + } =item dynamic_lib (override) @@ -1414,8 +1425,7 @@ sub manifypods { } else { $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); } - if ($pod2man_exe = $self->perl_script($pod2man_exe)) { $found_pod2man = 1; } - else { + if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) { # No pod2man but some MAN3PODS to be installed print <<END; @@ -1432,9 +1442,7 @@ qq[POD2MAN_EXE = $pod2man_exe\n], q[POD2MAN = $(PERL) -we "%m=@ARGV;for (keys %m){" - -e "system(""MCR $^X $(POD2MAN_EXE) $_ >$m{$_}"");}" ]; - push @m, "\nmanifypods : "; - push @m, join " ", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}; - push(@m,"\n"); + push @m, "\nmanifypods : \$(MAN1PODS) \$(MAN3PODS)\n"; if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) { my($pod); foreach $pod (sort keys %{$self->{MAN1PODS}}) { @@ -1460,12 +1468,14 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { + my $vmsplfile = vmsify($plfile); + my $vmsfile = vmsify($self->{PL_FILES}->{$plfile}); push @m, " -all :: $self->{PL_FILES}->{$plfile} +all :: $vmsfile \$(NOECHO) \$(NOOP) -$self->{PL_FILES}->{$plfile} :: $plfile -",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile +$vmsfile :: $vmsplfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile "; } join "", @m; @@ -1484,16 +1494,17 @@ sub installbin { return '' unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; return '' unless @{$self->{EXE_FILES}}; my(@m, $from, $to, %fromto, @to, $line); - for $from (@{$self->{EXE_FILES}}) { + my(@exefiles) = map { vmsify($_) } @{$self->{EXE_FILES}}; + for $from (@exefiles) { my($path) = '$(INST_SCRIPT)' . basename($from); local($_) = $path; # backward compatibility $to = $self->libscan($path); print "libscan($from) => '$to'\n" if ($Verbose >=2); - $fromto{$from}=$to; + $fromto{$from} = vmsify($to); } - @to = values %fromto; + @to = values %fromto; push @m, " -EXE_FILES = @{$self->{EXE_FILES}} +EXE_FILES = @exefiles all :: @to \$(NOECHO) \$(NOOP) @@ -1761,11 +1772,11 @@ sub install { foreach $file (@{$self->{EXE_FILES}}) { $line .= "$file "; if (length($line) > 128) { - push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]); + push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]); $line = ''; } } - push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]) if $line; + push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]) if $line; } push @m, q[ @@ -2255,18 +2266,6 @@ map_clean : join '', @m; } -=item ext (specific) - -Stub routine standing in for C<ExtUtils::LibList::ext> until VMS -support is added to that package. - -=cut - -sub ext { - my($self) = @_; - '','',''; -} - # --- Output postprocessing section --- =item nicetext (override) diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 027c1fe6e9..2d3dd56e6a 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.38"; +$Version = $VERSION = "5.39"; $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.207 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.208 $, 10)) =~ s/\s+$//; @@ -69,7 +69,7 @@ package ExtUtils::MakeMaker; # Now we can can pull in the friends # $Is_VMS = $^O eq 'VMS'; -$Is_OS2 = $^O =~ m|^os/?2$|i; +$Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; require ExtUtils::MM_Unix; @@ -236,7 +236,7 @@ sub full_setup { INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB - INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIBS + INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIB LIBS LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB NAME NEEDS_LINKING NOECHO NORECURS OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PL_FILES PM PMLIBDIRS PREFIX @@ -299,7 +299,7 @@ sub full_setup { # we will use all these variables in the Makefile @Get_from_Config = qw( - ar cc cccdlflags ccdlflags ccflags dlext dlsrc ld lddlflags ldflags libc + ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc lib_ext obj_ext ranlib sitelibexp sitearchexp so ); @@ -408,10 +408,7 @@ sub ExtUtils::MakeMaker::new { # This is for old Makefiles written pre 5.00, will go away if ( Carp::longmess("") =~ /runsubdirpl/s ){ - #$self->{Correct_relativ_directories}++; Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n"); - } else { - $self->{Correct_relativ_directories}=0; } my $newclass = ++$PACKNAME; @@ -430,8 +427,12 @@ sub ExtUtils::MakeMaker::new { for $key (keys %Prepend_dot_dot) { next unless defined $self->{PARENT}{$key}; $self->{$key} = $self->{PARENT}{$key}; + # PERL and FULLPERL may be command verbs instead of full + # file specifications under VMS. If so, don't turn them + # into a filespec. $self->{$key} = $self->catdir("..",$self->{$key}) - unless $self->file_name_is_absolute($self->{$key}); + unless $self->file_name_is_absolute($self->{$key}) + || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{key} =~ /^[\w\-\$]$/)); } $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; } else { @@ -553,15 +554,8 @@ sub parse_args{ (getpwuid($>))[7] ]ex; } - # This may go away, in mid 1996 - if ($self->{Correct_relativ_directories}){ - $value = $self->catdir("..",$value) - if $Prepend_dot_dot{$name} && ! $self->file_name_is_absolute($value); - } $self->{uc($name)} = $value; } - # This may go away, in mid 1996 - delete $self->{Correct_relativ_directories}; # catch old-style 'potential_libs' and inform user how to 'upgrade' if (defined $self->{potential_libs}){ @@ -858,18 +852,26 @@ Makefiles with a single invocation of WriteMakefile(). =head2 How To Write A Makefile.PL -The short answer is: Don't. Run h2xs(1) before you start thinking -about writing a module. For so called pm-only modules that consist of -C<*.pm> files only, h2xs has the very useful C<-X> switch. This will -generate dummy files of all kinds that are useful for the module -developer. +The short answer is: Don't. + + Always begin with h2xs. + Always begin with h2xs! + ALWAYS BEGIN WITH H2XS! + +even if you're not building around a header file, and even if you +don't have an XS component. + +Run h2xs(1) before you start thinking about writing a module. For so +called pm-only modules that consist of C<*.pm> files only, h2xs has +the C<-X> switch. This will generate dummy files of all kinds that are +useful for the module developer. The medium answer is: use ExtUtils::MakeMaker; WriteMakefile( NAME => "Foo::Bar" ); -The long answer is below. +The long answer is the rest of the manpage :-) =head2 Default Makefile Behaviour @@ -895,7 +897,7 @@ Other interesting targets in the generated Makefile are =head2 make test -MakeMaker checks for the existence of a file named "test.pl" in the +MakeMaker checks for the existence of a file named F<test.pl> in the current directory and if it exists it adds commands to the test target of the generated Makefile that will execute the script with the proper set of perl C<-I> options. @@ -905,6 +907,22 @@ add commands to the test target of the generated Makefile that execute all matching files via the L<Test::Harness> module with the C<-I> switches set correctly. +=head2 make testdb + +A useful variation of the above is the target C<testdb>. It runs the +test under the Perl debugger (see L<perldebug>). If the file +F<test.pl> exists in the current directory, it is used for the test. + +If you want to debug some other testfile, set C<TEST_FILE> variable +thusly: + + make testdb TEST_FILE=t/mytest.t + +By default the debugger is called using C<-d> option to perl. If you +want to specify some other option, set C<TESTDB_SW> variable: + + make testdb TESTDB_SW=-Dx + =head2 make install make alone puts all relevant files into directories that are named by @@ -934,9 +952,7 @@ The INSTALL... macros in turn default to their %Config You can check the values of these variables on your system with - perl -MConfig -le 'print join $/, map - sprintf("%20s: %s", $_, $Config{$_}), - grep /^install/, keys %Config' + perl '-V:install.*' And to check the sequence in which the library directories are searched by perl, run @@ -944,18 +960,29 @@ searched by perl, run perl -le 'print join $/, @INC' -=head2 PREFIX attribute +=head2 PREFIX and LIB attribute + +PREFIX and LIB can be used to set several INSTALL* attributes in one +go. The quickest way to install a module in a non-standard place might +be -The PREFIX attribute can be used to set the INSTALL* attributes in one -go. The quickest way to install a module in a non-standard place + perl Makefile.PL LIB=~/lib + +This will install the module's architecture-independent files into +~/lib, the architecture-dependent files into ~/lib/$archname/auto. + +Another way to specify many INSTALL directories with a single +parameter is PREFIX. perl Makefile.PL PREFIX=~ This will replace the string specified by $Config{prefix} in all $Config{install*} values. -Note, that the tilde expansion is done by MakeMaker, not by perl by -default, nor by make. +Note, that in both cases the tilde expansion is done by MakeMaker, not +by perl by default, nor by make. Conflicts between parmeters LIB, +PREFIX and the various INSTALL* arguments are resolved so that +XXX If the user has superuser privileges, and is not working on AFS (Andrew File System) or relatives, then the defaults for @@ -1326,6 +1353,11 @@ specify ld flags) The filename of the perllibrary that will be used together with this extension. Defaults to libperl.a. +=item LIB + +LIB can only be set at C<perl Makefile.PL> time. It has the effect of +setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any + =item LIBS An anonymous array of alternative library @@ -1525,7 +1557,7 @@ 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.207 $ ' =~ /\$Revision:\s+([^\s]+)/; + ( $VERSION ) = '$Revision: 1.208 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; but these will fail: diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index e1fcbf0163..09bdbd55c0 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -17,7 +17,7 @@ $Debug = 0; $Verbose = 1; $Is_VMS = $^O eq 'VMS'; -$VERSION = substr(q$Revision: 1.27 $,10,4); +$VERSION = "1.28"; $Quiet = 0; @@ -25,7 +25,6 @@ $MANIFEST = 'MANIFEST'; # Really cool fix from Ilya :) unless (defined $Config{d_link}) { - local($^W) = 0; # avoid sub redefined message *ln = \&cp; } @@ -249,7 +248,7 @@ sub best { if (-l $srcFile) { cp($srcFile, $dstFile); } else { - ln($srcFile, $dstFile); + ln($srcFile, $dstFile) or cp($srcFile, $dstFile); } } @@ -394,6 +393,6 @@ L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. =head1 AUTHOR -Andreas Koenig E<lt>F<koenig@franz.ww.TU-Berlin.DE>E<gt> +Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>> =cut diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 0f9a132c36..4c96437e15 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -48,7 +48,7 @@ sub Mksymlists { if ($osname eq 'aix') { _write_aix(\%spec); } elsif ($osname eq 'VMS') { _write_vms(\%spec) } - elsif ($osname =~ m|^os/?2$|i) { _write_os2(\%spec) } + elsif ($osname eq 'os2') { _write_os2(\%spec) } else { croak("Don't know how to create linker option file for $osname\n"); } } diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 14d1222e63..c65b1cf35d 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -127,7 +127,7 @@ T_REF_IV_PTR else croak(\"$var is not of type ${ntype}\") T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) { + if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index eaf5bd4342..76e45d6d99 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -76,7 +76,7 @@ perl(1), perlxs(1), perlxstut(1), perlxs(1) =cut # Global Constants -$XSUBPP_version = "1.938"; +$XSUBPP_version = "1.940"; require 5.002; use vars '$cplusplus'; @@ -95,7 +95,7 @@ $ProtoUsed = 0 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; - $spat = shift, next SWITCH if $flag eq 's'; + $spat = quotemeta shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; @@ -169,6 +169,7 @@ foreach $typemap (@tm) { $current = \$junk; while (<TYPEMAP>) { next if /^\s*#/; + my $line_no = $. + 1; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } @@ -228,8 +229,10 @@ sub check_keyword { sub print_section { + my $count = 0; $_ = shift(@line) while !/\S/ && @line; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { + print line_directive() unless ($count++); print "$_\n"; } } @@ -241,6 +244,7 @@ sub process_keyword($) &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; + print line_directive(); } sub CASE_handler { @@ -317,6 +321,7 @@ 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 { @@ -634,7 +639,7 @@ print <<EOM ; */ EOM - +print "#line 1 \"$filename\"\n"; while (<$FH>) { last if ($Module, $Package, $Prefix) = @@ -646,7 +651,6 @@ while (<$FH>) { $lastline = $_; $lastline_no = $.; - # Read next xsub into @line from ($lastline, <$FH>). sub fetch_para { # parse paragraph @@ -661,6 +665,7 @@ sub fetch_para { $Module = $1; $Package = defined($2) ? $2 : ''; # keep -w happy $Prefix = defined($3) ? $3 : ''; # keep -w happy + $Prefix = quotemeta $Prefix ; ($Module_cname = $Module) =~ s/\W/_/g; ($Packid = $Package) =~ tr/:/_/; $Packprefix = $Package; @@ -741,7 +746,9 @@ while (fetch_para()) { $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; } - death ("Code is not inside a function") + death ("Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a a statement on column one?)") if $line[0] =~ /^\s/; # initialize info arrays @@ -769,7 +776,7 @@ while (fetch_para()) { if (check_keyword("BOOT")) { &check_cpp; - push (@BootCode, $_, @line, "") ; + push (@BootCode, $_, line_directive(), @line, "") ; next PARAGRAPH ; } @@ -789,12 +796,13 @@ while (fetch_para()) { ($class, $func_name, $orig_args) = ($1, $2, $3) ; ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; - $Full_func_name = "${Packid}_$func_name"; + ($clean_func_name = $func_name) =~ s/^$Prefix//; + $Full_func_name = "${Packid}_$clean_func_name"; # Check for duplicate function definition for $tmp (@XSStack) { next unless defined $tmp->{functions}{$Full_func_name}; - Warn("Warning: duplicate function definition '$func_name' detected"); + Warn("Warning: duplicate function definition '$clean_func_name' detected"); last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; @@ -834,11 +842,12 @@ while (fetch_para()) { $PPCODE = grep(/^\s*PPCODE\s*:/, @line); $CODE = grep(/^\s*CODE\s*:/, @line); + $EXPLICIT_RETURN = $CODE && ("@line" =~ /\bST\s*\([^;]*=/ ); $ALIAS = grep(/^\s*ALIAS\s*:/, @line); # print function header print Q<<"EOF"; -#XS(XS_${Packid}_$func_name) +#XS(XS_${Full_func_name}) #[[ # dXSARGS; EOF @@ -980,6 +989,7 @@ EOF } elsif ($gotRETVAL || $wantRETVAL) { &generate_output($ret_type, 0, 'RETVAL'); } + print line_directive(); # do cleanup process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; @@ -1016,7 +1026,7 @@ EOF # croak(errbuf); EOF - if ($ret_type ne "void" or $CODE) { + if ($ret_type ne "void" or $EXPLICIT_RETURN) { print Q<<EOF unless $PPCODE; # XSRETURN(1); EOF @@ -1132,6 +1142,15 @@ 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/Fatal.pm b/lib/Fatal.pm index 0d9c51b113..281474c336 100644 --- a/lib/Fatal.pm +++ b/lib/Fatal.pm @@ -43,7 +43,7 @@ sub _make_fatal { $code .= "\(\@_\) || croak \"Can't $name\(\@_\): \$!\";\n}\n"; print $code if $Debug; eval($code); - die($@) if $@; + die if $@; local($^W) = 0; # to avoid: Subroutine foo redefined ... no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... *{$sub} = \&{"Fatal::$name"}; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 2602f0d530..b904a529bd 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -2,8 +2,6 @@ package File::Basename; =head1 NAME -Basename - parse file specifications - fileparse - split a pathname into pieces basename - extract just the filename from a path @@ -35,10 +33,10 @@ pieces using the syntax of different operating systems. You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings -"VMS", "MSDOS", or "MacOS", the file specification syntax of that -operating system is used in future calls to fileparse(), -basename(), and dirname(). If it contains none of these -substrings, UNIX syntax is used. This pattern matching is +"VMS", "MSDOS", "MacOS" or "AmigaOS", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, UNIX syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", they assume you are using UNIX emulation and apply the UNIX syntax @@ -93,8 +91,9 @@ would yield =item C<basename> The basename() routine returns the first element of the list produced -by calling fileparse() with the same arguments. It is provided for -compatibility with the UNIX shell command basename(1). +by calling fileparse() with the same arguments, except that it always +quotes metacharacters in the given suffixes. It is provided for +programmer compatibility with the UNIX shell command basename(1). =item C<dirname> @@ -117,20 +116,23 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); #use strict; -#use vars qw($VERSION $Fileparse_fstype); +#use vars qw($VERSION $Fileparse_fstype $Fileparse_fgcase); $VERSION = "2.4"; # fileparse_set_fstype() - specify OS-based rules used in future # calls to routines in this package # -# Currently recognized values: VMS, MSDOS, MacOS +# Currently recognized values: VMS, MSDOS, MacOS, os2, AmigaOS # Any other name uses Unix-style rules sub fileparse_set_fstype { - my($old) = $Fileparse_fstype; - $Fileparse_fstype = $_[0] if $_[0]; - $old; + my @old = ($Fileparse_fstype, $Fileparse_fgcase); + if (@_) { + $Fileparse_fstype = $_[0]; + $Fileparse_fgcase = ($_[0] =~ /^(?:MacOS|VMS|os2|AmigaOS)/i); + } + wantarray ? @old : $old[0]; } # fileparse() - parse file specification @@ -140,7 +142,7 @@ sub fileparse_set_fstype { sub fileparse { my($fullname,@suffices) = @_; - my($fstype) = $Fileparse_fstype; + my($fstype,$fgcase) = ($Fileparse_fstype, $Fileparse_fgcase); my($dirpath,$tail,$suffix,$basename); if ($fstype =~ /^VMS/i) { @@ -151,11 +153,14 @@ sub fileparse { } if ($fstype =~ /^MSDOS/i) { ($dirpath,$basename) = ($fullname =~ /^(.*[:\\\/])?(.*)/); - $dirpath .= '.\\' unless $dirpath =~ /\\$/; + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; } elsif ($fstype =~ /^MacOS/i) { ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); } + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); $dirpath = './' unless $dirpath; @@ -164,15 +169,14 @@ sub fileparse { if (@suffices) { $tail = ''; foreach $suffix (@suffices) { - if ($basename =~ /([\x00-\xff]*?)($suffix)$/) { - $tail = $2 . $tail; - $basename = $1; + my $pat = ($fgcase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//) { + $tail = $1 . $tail; } } } wantarray ? ($basename,$dirpath,$tail) : $basename; - } @@ -201,22 +205,29 @@ sub dirname { } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - if ( $dirname =~ /:\\$/) { return $dirname } + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:$/) { return $dirname } chop $dirname; - $dirname =~ s:[^\\]+$:: unless length($basename); - $dirname = '.' unless length($dirname); + $dirname =~ s#[^:/]+$## unless length($basename); } else { - if ( $dirname =~ m:^/+$:) { return '/'; } - chop $dirname; - $dirname =~ s:[^/]+$:: unless length($basename); - $dirname =~ s:/+$:: ; - $dirname = '.' unless length($dirname); + $dirname =~ s:(.)/*$:$1:; + unless( length($basename) ) { + local($File::Basename::Fileparse_fstype) = $fstype; + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s:(.)/*$:$1:; + } } $dirname; } -$Fileparse_fstype = $^O; +fileparse_set_fstype $^O; 1; diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm new file mode 100644 index 0000000000..e76c10fb5f --- /dev/null +++ b/lib/File/Compare.pm @@ -0,0 +1,136 @@ +package File::Compare; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); + +require Exporter; +use Carp; +use UNIVERSAL qw(isa); + +$VERSION = '1.1'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp); + +$Too_Big = 1024 * 1024 * 2; + +sub VERSION { + # Version of File::Compare + return $File::Compare::VERSION; +} + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + my $closefrom=0; + my $closeto=0; + my ($size, $status, $fr, $tr, $fbuf, $tbuf); + local(*FROM, *TO); + local($\) = ''; + + croak("from undefined") unless (defined $from); + croak("to undefined") unless (defined $to); + + if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) { + *FROM = *$from; + } elsif (ref(\$from) eq 'GLOB') { + *FROM = $from; + } else { + open(FROM,"<$from") or goto fail_open1; + binmode FROM; + $closefrom = 1; + } + + if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) { + *TO = *$to; + } elsif (ref(\$to) eq 'GLOB') { + *TO = $to; + } else { + open(TO,"<$to") or goto fail_open2; + binmode TO; + $closeto = 1; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for compare: $size\n") unless ($size > 0); + } else { + $size = -s FROM; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $fbuf = ''; + $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) { + goto fail_inner; + } + } + goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0); + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 0; + + # All of these contortions try to preserve error messages... + fail_inner: + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 1; + + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +*cmp = \&compare; + +1; + +__END__ + +=head1 NAME + +File::Compare - Compare files or filehandles + +=head1 SYNOPSIS + + use File::Compare; + + if (compare("file1","file2") == 0) { + print "They're equal\n"; + } + +=head1 DESCRIPTION + +The File::Compare::compare function compares the contents of two +sources, each of which can be a file or a file handle. It is exported +from File::Compare by default. + +File::Compare::cmp is a synonym for File::Compare::compare. It is +exported from File::Compare only by request. + +=head1 RETURN + +File::Compare::compare return 0 if the files are equal, 1 if the +files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 5cea310265..b1baa207b3 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -2,64 +2,93 @@ # source code has been placed in the public domain by the author. # Please be kind and preserve the documentation. # +# Additions copyright 1996 by Charles Bailey. Permission is granted +# to distribute the revised code under the same terms as Perl itself. package File::Copy; -require Exporter; +use strict; use Carp; +use UNIVERSAL qw(isa); +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big + © &syscopy &cp &mv); + +# Note that this module implements only *part* of the API defined by +# the File/Copy.pm module of the File-Tools-2.0 package. However, that +# package has not yet been updated to work with Perl 5.004, and so it +# would be a Bad Thing for the CPAN module to grab it and replace this +# module. Therefore, we set this module's version higher than 2.0. +$VERSION = '2.02'; -@ISA=qw(Exporter); -@EXPORT=qw(copy); -@EXPORT_OK=qw(copy cp); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); -$File::Copy::VERSION = '1.5'; -$File::Copy::Too_Big = 1024 * 1024 * 2; +$Too_Big = 1024 * 1024 * 2; -sub VERSION { - # Version of File::Copy - return $File::Copy::VERSION; +sub _catname { # Will be replaced by File::Spec when it arrives + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } + elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); } + elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } + else { $to .= '/' . basename($from); } } sub copy { - croak("Usage: copy( file1, file2 [, buffersize]) ") + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") unless(@_ == 2 || @_ == 3); - if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$_[1]) ne 'GLOB' && - !(defined ref $_[1] and (ref($_[1]) eq 'GLOB' || - ref($_[1]) eq 'FileHandle' || ref($_[1]) eq 'VMS::Stdio'))) - { return File::Copy::syscopy($_[0],$_[1]) } - my $from = shift; my $to = shift; - my $closefrom=0; - my $closeto=0; + + my $from_a_handle = (ref($from) + ? (ref($from) eq 'GLOB' + || isa($from, 'GLOB') || 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')) + : (ref(\$to) eq 'GLOB')); + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } + + if (defined &syscopy && \&syscopy != \© + && !$to_a_handle + && !($from_a_handle && $^O eq 'os2')) # OS/2 cannot handle handles + { + return syscopy($from, $to); + } + + my $closefrom = 0; + my $closeto = 0; my ($size, $status, $r, $buf); local(*FROM, *TO); local($\) = ''; - if (ref(\$from) eq 'GLOB') { - *FROM = $from; - } elsif (defined ref $from and - (ref($from) eq 'GLOB' || ref($from) eq 'FileHandle' || - ref($from) eq 'VMS::Stdio')) { - *FROM = *$from; + if ($from_a_handle) { + *FROM = *$from{FILEHANDLE}; } else { - open(FROM,"<$from")||goto(fail_open1); - binmode FROM; + $from = "./$from" if $from =~ /^\s/; + open(FROM, "< $from\0") or goto fail_open1; + binmode FROM or die "($!,$^E)"; $closefrom = 1; - } - - if (ref(\$to) eq 'GLOB') { - *TO = $to; - } elsif (defined ref $to and - (ref($to) eq 'GLOB' || ref($to) eq 'FileHandle' || - ref($to) eq 'VMS::Stdio')) { - *TO = *$to; - } else { - open(TO,">$to")||goto(fail_open2); - binmode TO; - $closeto=1; - } + } + + if ($to_a_handle) { + *TO = *$to{FILEHANDLE}; + } else { + $to = "./$to" if $to =~ /^\s/; + open(TO,"> $to\0") or goto fail_open2; + binmode TO or die "($!,$^E)"; + $closeto = 1; + } if (@_) { $size = shift(@_) + 0; @@ -67,18 +96,24 @@ sub copy { } else { $size = -s FROM; $size = 1024 if ($size < 512); - $size = $File::Copy::Too_Big if ($size > $File::Copy::Too_Big); + $size = $Too_Big if ($size > $Too_Big); } - $buf = ''; - while(defined($r = read(FROM,$buf,$size)) && $r > 0) { - if (syswrite (TO,$buf,$r) != $r) { - goto fail_inner; + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread(FROM, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite(TO, $buf, $r - $w, $w) + or goto fail_inner; } } - goto fail_inner unless(defined($r)); + close(TO) || goto fail_open2 if $closeto; close(FROM) || goto fail_open1 if $closefrom; + # Use this idiom to avoid uninitialized value warning. return 1; @@ -101,10 +136,44 @@ sub copy { return 0; } +sub move { + my($from,$to) = @_; + my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); + + if (-d $to && ! -d $from) { + $to = _catname($from, $to); + } + + ($tosz1,$tomt1) = (stat($to))[7,9]; + $fromsz = -s $from; + if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { + # will not rename with overwrite + unlink $to; + } + return 1 if rename $from, $to; + + ($sts,$ossts) = ($! + 0, $^E + 0); + # Did rename return an error even though it succeeded, because $to + # is on a remote NFS file system, and NFS lost the server's ack? + return 1 if defined($fromsz) && !-e $from && # $from disappeared + (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there + ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed + $tosz2 == $fromsz; # it's all there + + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something + return 1 if ($copied = copy($from,$to)) && unlink($from); + + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; + unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; + ($!,$^E) = ($sts,$ossts); + return 0; +} *cp = \© +*mv = \&move; + # &syscopy is an XSUB under OS/2 -*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless $^O eq 'os2'; +*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless defined &syscopy; 1; @@ -120,6 +189,7 @@ File::Copy - Copy files or filehandles copy("file1","file2"); copy("Copy.pm",\*STDOUT);' + move("/dev1/fileA","/dev2/fileB"); use POSIX; use File::Copy cp; @@ -129,16 +199,28 @@ File::Copy - Copy files or filehandles =head1 DESCRIPTION -The File::Copy module provides a basic function C<copy> which takes two +The File::Copy module provides two basic functions, C<copy> and +C<move>, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C<copy> function takes two parameters: a file to copy from and a file to copy to. Either argument may be a string, a FileHandle reference or a FileHandle glob. Obviously, if the first argument is a filehandle of some sort, it will be read from, and if it is a file I<name> it will be opened for reading. Likewise, the second argument will be -written to (and created if need be). Note that passing in +written to (and created if need be). + +B<Note that passing in files as handles instead of names may lead to loss of information on some operating systems; it is recommended that you use file -names whenever possible. +names whenever possible.> Files are opened in binary mode where +applicable. To get a consistent behavour when copying from a +filehandle to a file, use C<binmode> on the filehandle. An optional third parameter can be used to specify the buffer size used for copying. This is the number of bytes from the @@ -150,6 +232,24 @@ upon the file, but will generally be the whole file (up to 2Mb), or You may use the syntax C<use File::Copy "cp"> to get at the "cp" alias for this function. The syntax is I<exactly> the same. +=item * + +The C<move> function also takes two parameters: the current name +and the intended name of the file to be moved. If the destination +already exists and is a directory, and the source is not a +directory, then the source file will be renamed into the directory +specified by the destination. + +If possible, move() will simply rename the file. Otherwise, it copies +the file to the new location and deletes the original. If an error occurs +during this copy-and-delete process, you may be left with a (possibly partial) +copy of the file under the destination name. + +You may use the "mv" alias for this function in the same way that +you may use the "cp" alias for C<copy>. + +=back + File::Copy also provides the C<syscopy> routine, which copies the file specified in the first parameter to the file specified in the second parameter, preserving OS-specific attributes and file @@ -158,25 +258,28 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior under VMS +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) -If the second argument to C<copy> is not a file handle for an -already opened file, then C<copy> will perform an RMS copy of +If both arguments to C<copy> are not file handles, +then C<copy> will perform a "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I<etc.> The buffer size -parameter is ignored. If the second argument to C<copy> is a -Perl handle to an opened file, then data is copied using Perl +parameter is ignored. If either argument to C<copy> is a +handle to an opened file, then data is copied using Perl operators, and no effort is made to preserve file attributes or record structure. -The RMS copy routine may also be called directly under VMS -as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which -is just an alias for this routine). +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which +is the routine that does the actual work for syscopy). + +=over 4 =item rmscopy($from,$to[,$date_flag]) -The first and second arguments may be strings, typeglobs, or -typeglob references; they are used in all cases to obtain the +The first and second arguments may be strings, typeglobs, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the I<filespec> of the input and output files, respectively. The name and type of the input file are used as defaults for the output file, if necessary. @@ -207,15 +310,17 @@ it defaults to 0. Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, it sets C<$!>, deletes the output file, and returns 0. +=back + =head1 RETURN -Returns 1 on success, 0 on failure. $! will be set if an error was -encountered. +All functions return 1 on success, 0 on failure. +$! will be set if an error was encountered. =head1 AUTHOR -File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995. -The VMS-specific code was added by Charles Bailey -I<E<lt>bailey@genetics.upenn.eduE<gt>> in March 1996. +File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. =cut + diff --git a/lib/File/Find.pm b/lib/File/Find.pm index b0312be10e..1faea50158 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -74,7 +74,9 @@ that don't resolve: sub find { my $wanted = shift; my $cwd = Cwd::cwd(); - my ($topdir,$topdev,$topino,$topmode,$topnlink); + # Localize these rather than lexicalizing them for backwards + # compatibility. + local($topdir,$topdev,$topino,$topmode,$topnlink); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); @@ -163,7 +165,9 @@ sub finddepth { $cwd = Cwd::fastcwd();; - my($topdir, $topdev, $topino, $topmode, $topnlink); + # Localize these rather than lexicalizing them for backwards + # compatibility. + local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); @@ -259,7 +263,8 @@ if ($^O =~ m:^mswin32:i) { $dont_use_nlink = 1; } -$dont_use_nlink = 1 if $^O eq 'os2'; +$dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos'; 1; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 8d775d52d5..2e35303bb3 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -131,9 +131,13 @@ sub rmtree { $root =~ s#/$##; if (not -l $root and -d _) { opendir(D,$root); - ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; - @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D)); + @files = readdir(D); closedir(D); + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; + @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files); $count += rmtree(\@files,$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { @@ -152,7 +156,7 @@ sub rmtree { print "unlink $root\n" if $verbose; while (-e $root || -l $root) { # delete all versions under VMS (unlink($root) && ++$count) - or carp "Can't unlink file $root: $!"; + or croak "Can't unlink file $root: $!"; } } } diff --git a/lib/File/stat.pm b/lib/File/stat.pm new file mode 100644 index 0000000000..581fbf3214 --- /dev/null +++ b/lib/File/stat.pm @@ -0,0 +1,111 @@ +package File::stat; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(stat lstat); + @EXPORT_OK = qw( $st_dev $st_ino $st_mode + $st_nlink $st_uid $st_gid + $st_rdev $st_size + $st_atime $st_mtime $st_ctime + $st_blksize $st_blocks + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'File::stat' => [ + map { $_ => '$' } qw{ + dev ino mode nlink uid gid rdev size + atime mtime ctime blksize blocks + } +]; + +sub populate (@) { + return unless @_; + my $stob = new(); + @$stob = ( + $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, + $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) + = @_; + return $stob; +} + +sub lstat (*) { populate(CORE::lstat(shift)) } + +sub stat ($) { + my $arg = shift; + my $st = populate(CORE::stat $arg); + return $st if $st; + no strict 'refs'; + require Symbol; + return populate(CORE::stat \*{Symbol::qualify($arg)}); +} + +1; +__END__ + +=head1 NAME + +File::stat.pm - by-name interface to Perl's built-in stat() functions + +=head1 SYNOPSIS + + use File::stat; + $st = stat($file) or die "No $file: $!"; + if ( ($st->mode & 0111) && $st->nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + + use File::stat qw(:FIELDS); + stat($file) or die "No $file: $!"; + if ( ($st_mode & 0111) && $st_nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + +=head1 DESCRIPTION + +This module's default exports override the core stat() +and lstat() functions, replacing them with versions that return +"File::stat" objects. This object has methods that +return the similarly named structure field name from the +stat(2) function; namely, +dev, +ino, +mode, +nlink, +uid, +gid, +rdev, +size, +atime, +mtime, +ctime, +blksize, +and +blocks. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your stat() and lstat() functions.) Access these fields as +variables named with a preceding C<st_> in front their method names. +Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/FileCache.pm b/lib/FileCache.pm index 3d01371b3b..4fd63315f9 100644 --- a/lib/FileCache.pm +++ b/lib/FileCache.pm @@ -53,7 +53,7 @@ sub cacheout { ($file) = @_; unless (defined $cacheout_maxopen) { if (open(PARAM,'/usr/include/sys/param.h')) { - local $.; + local ($_, $.); while (<PARAM>) { $cacheout_maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm new file mode 100644 index 0000000000..b907cae40c --- /dev/null +++ b/lib/FileHandle.pm @@ -0,0 +1,252 @@ +package FileHandle; + +use 5.003_11; +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); + +$VERSION = "2.00"; + +require IO::File; +@ISA = qw(IO::File); + +@EXPORT = qw(_IOFBF _IOLBF _IONBF); + +@EXPORT_OK = qw( + pipe + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + + print + printf + getline + getlines +); + +# +# Everything we're willing to export, we must first import. +# +import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; + +# +# Some people call "FileHandle::function", so all the functions +# that were in the old FileHandle class must be imported, too. +# +{ + no strict 'refs'; + + my %import = ( + 'IO::Handle' => + [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets + eof flush error clearerr setbuf setvbuf _open_mode_string)], + 'IO::Seekable' => + [qw(seek tell getpos setpos)], + 'IO::File' => + [qw(new new_tmpfile open)] + ); + for my $pkg (keys %import) { + for my $func (@{$import{$pkg}}) { + my $c = *{"${pkg}::$func"}{CODE} + or die "${pkg}::$func missing"; + *$func = $c; + } + } +} + +# +# Specialized importer for Fcntl magic. +# +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export $pkg, $callpkg, @_; + + # + # If the Fcntl extension is available, + # export its constants. + # + eval { + require Fcntl; + Exporter::export 'Fcntl', $callpkg; + }; +} + +################################################ +# This is the only exported function we define; +# the rest come from other classes. +# + +sub pipe { + my $r = new IO::Handle; + my $w = new IO::Handle; + CORE::pipe($r, $w) or return undef; + ($r, $w); +} + +1; + +__END__ + +=head1 NAME + +FileHandle - supply object methods for filehandles + +=head1 SYNOPSIS + + use FileHandle; + + $fh = new FileHandle; + if ($fh->open "< file") { + print <$fh>; + $fh->close; + } + + $fh = new FileHandle "> FOO"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new FileHandle "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new FileHandle "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + undef $fh; # automatically closes the file + } + + $pos = $fh->getpos; + $fh->setpos $pos; + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + ($readfh, $writefh) = FileHandle::pipe; + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +NOTE: This class is now a front-end to the IO::* classes. + +C<FileHandle::new> creates a C<FileHandle>, which is a reference to a +newly created symbol (see the C<Symbol> package). If it receives any +parameters, they are passed to C<FileHandle::open>; if the open fails, +the C<FileHandle> object is destroyed. Otherwise, it is returned to +the caller. + +C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. +It requires two parameters, which are passed to C<FileHandle::fdopen>; +if the fdopen fails, the C<FileHandle> object is destroyed. +Otherwise, it is returned to the caller. + +C<FileHandle::open> accepts one parameter or two. With one parameter, +it is just a front end for the built-in C<open> function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<FileHandle::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<FileHandle::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of FileHandle will still work. + +C<FileHandle::fdopen> is like C<open> except that its first parameter +is not a filename but rather a file handle name, a FileHandle object, +or a file descriptor number. + +If the C functions fgetpos() and fsetpos() are available, then +C<FileHandle::getpos> returns an opaque value that represents the +current position of the FileHandle, and C<FileHandle::setpos> uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C<FileHandle::setvbuf> +sets the buffering policy for the FileHandle. The calling sequence +for the Perl function is the same as its C counterpart, including the +macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer +parameter specifies a scalar variable to use as a buffer. WARNING: A +variable used as a buffer by C<FileHandle::setvbuf> must not be +modified in any way until the FileHandle is closed or until +C<FileHandle::setvbuf> is called again, or memory corruption may +result! + +See L<perlfunc> for complete descriptions of each of the following +supported C<FileHandle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + gets + eof + clearerr + seek + tell + +See L<perlvar> for complete descriptions of each of the following +supported C<FileHandle> methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->print + +See L<perlfunc/print>. + +=item $fh->printf + +See L<perlfunc/printf>. + +=item $fh->getline + +This works like <$fh> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in an +array context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in an array context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=back + +=head1 SEE ALSO + +The B<IO> extension, +L<perlfunc>, +L<perlop/"I/O Operators">. + +=cut diff --git a/lib/FindBin.pm b/lib/FindBin.pm index 45d9e33341..bbd72a2aa2 100644 --- a/lib/FindBin.pm +++ b/lib/FindBin.pm @@ -96,7 +96,7 @@ $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); # $realpath; #} -sub abs_path +sub my_abs_path { my $start = shift || '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); @@ -154,6 +154,8 @@ BEGIN { *Dir = \$Bin; *RealDir = \$RealBin; + if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath} + else { *abs_path = \&my_abs_path} if($0 eq '-e' || $0 eq '-') { diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 11d10f8d03..f2b37e917f 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,11 +1,11 @@ # GetOpt::Long.pm -- POSIX compatible options parsing -# RCS Status : $Id: GetoptLong.pm,v 2.4 1996-10-02 11:16:26+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.6 1997-01-11 13:12:01+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Wed Oct 2 11:13:12 1996 -# Update Count : 500 +# Last Modified On: Sat Jan 11 13:11:35 1997 +# Update Count : 506 # Status : Released package Getopt::Long; @@ -14,7 +14,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); -$VERSION = sprintf("%d.%02d", '$Revision: 2.4 $ ' =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", '$Revision: 2.6 $ ' =~ /(\d+)\.(\d+)/); use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER @@ -86,7 +86,7 @@ followed by an argument specifier. Values for argument specifiers are: =over 8 -=item <none> +=item E<lt>noneE<gt> Option does not take an argument. The option variable will be set to 1. @@ -225,7 +225,7 @@ The option name is always the true name, not an abbreviation or alias. The option name may actually be a list of option names, separated by "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name -op this option. If no linkage is specified, options "foo", "bar" and +of this option. If no linkage is specified, options "foo", "bar" and "blech" all will set $opt_foo. Option names may be abbreviated to uniqueness, depending on @@ -233,7 +233,7 @@ configuration variable $Getopt::Long::autoabbrev. =head2 Non-option call-back routine -A special option specifier, <>, can be used to designate a subroutine +A special option specifier, E<lt>E<gt>, can be used to designate a subroutine to handle non-option arguments. GetOptions will immediately call this subroutine for every non-option it encounters in the options list. This subroutine gets the name of the non-option passed. @@ -316,11 +316,11 @@ Example of using variable references: With command line options "-foo blech -bar 24 -ar xx -ar yy" this will result in: - $bar = 'blech' + $foo = 'blech' $opt_bar = 24 @ar = ('xx','yy') -Example of using the <> option specifier: +Example of using the E<lt>E<gt> option specifier: @ARGV = qw(-foo 1 bar -foo 2 blech); &GetOptions("foo=i", \$myfoo, "<>", \&mysub); @@ -530,7 +530,7 @@ sub GetOptions { # than once in differing environments $error = 0; - print STDERR ('GetOptions $Revision: 2.4 $ ', + print STDERR ('GetOptions $Revision: 2.6 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -927,6 +927,11 @@ sub find_option { } } + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + # Check validity by fetching the info. my $type = $optbl->{$tryopt}; unless ( defined $type ) { diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index 4117ca7f8b..fee0d33e8f 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -11,9 +11,12 @@ getopts - Process single-character switches with switch clustering =head1 SYNOPSIS use Getopt::Std; - getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + + getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts getopts('oif:'); # -o & -i are boolean flags, -f takes an argument # Sets opt_* as a side effect. + getopts('oif:', \%opts); # options as above. Values in %opts =head1 DESCRIPTION @@ -24,6 +27,11 @@ switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. +For those of you who don't like additional variables being created, getopt() +and getopts() will also accept a hash reference as an optional second argument. +Hash keys will be x (where x is the switch name) with key values the value of +the argument or 1 if no argument is specified. + =cut @ISA = qw(Exporter); @@ -40,8 +48,8 @@ switch and the argument. # Usage: # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. -sub getopt { - local($argumentative) = @_; +sub getopt ($;$) { + local($argumentative, $hash) = @_; local($_,$first,$rest); local $Exporter::ExportLevel; @@ -55,12 +63,22 @@ sub getopt { shift(@ARGV); $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } } else { - eval "\$opt_$first = 1;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = 1; + } + else { + eval "\$opt_$first = 1;"; + push( @EXPORT, "\$opt_$first" ); + } if ($rest ne '') { $ARGV[0] = "-$rest"; } @@ -77,8 +95,8 @@ sub getopt { # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a # # side effect. -sub getopts { - local($argumentative) = @_; +sub getopts ($;$) { + local($argumentative, $hash) = @_; local(@args,$_,$first,$rest); local($errs) = 0; local $Exporter::ExportLevel; @@ -94,12 +112,22 @@ sub getopts { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } } else { - eval "\$opt_$first = 1"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = 1; + } + else { + eval "\$opt_$first = 1"; + push( @EXPORT, "\$opt_$first" ); + } if($rest eq '') { shift(@ARGV); } diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 5d1e14157e..343cb02205 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -1,7 +1,7 @@ -# -# NOTE! This module is deprecated (obsolete) after the Perl release -# 5.003_06 as the functionality has been integrated into the Perl core. -# +#-----------------------------------------------------------------------# +# 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; @@ -28,21 +28,20 @@ You can compare $s1 and $s2 above with to extract the data itself, you'll need a dereference: $$s1 -This uses POSIX::setlocale(). The basic collation conversion is done by -strxfrm() which terminates at NUL characters being a decent C routine. -collate_xfrm() handles embedded NUL characters gracefully. Due to C<cmp> -and overload magic, C<lt>, C<le>, C<eq>, C<ge>, and C<gt> work also. The -available locales depend on your operating system; try whether C<locale --a> shows them or man pages for "locale" or "nlsinfo" or -the direct approach C<ls /usr/lib/nls/loc> or C<ls -/usr/lib/nls>. Not all the locales that your vendor supports -are necessarily installed: please consult your operating system's -documentation and possibly your local system administration. +This module uses POSIX::setlocale(). The basic collation conversion is +done by strxfrm() which terminates at NUL characters being a decent C +routine. collate_xfrm() handles embedded NUL characters gracefully. -The locale names are probably something like -C<"xx_XX.(ISO)?8859-N"> or C<"xx_XX.(ISO)?8859N">, for example -C<"fr_CH.ISO8859-1"> is the Swiss (CH) variant of French (fr), -ISO Latin (8859) 1 (-1) which is the Western European character set. +The available locales depend on your operating system; try whether +C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the +direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or +C<ls /usr/lib/locale>. Not all the locales that your vendor supports +are necessarily installed: please consult your operating system's +documentation and possibly your local system administration. The +locale names are probably something like C<xx_XX.(ISO)?8859-N> or +C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH) +variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western +European character set. =cut @@ -123,14 +122,10 @@ sub new { 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. - - All scalar data is now collated according to the current locale setting. - Also, Perl does automatically the setlocale(LC_COLLATE, "") for you. + migrate the old applications away from it) because its functionality was + integrated into the Perl core language in the release 5.003_06. - To convert: forget I18N::Collate completely and use scalar data in - a completely normal way. + See pod/perllocale.pod for further information. *** ___EOD___ diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 35bb0d1f16..cfd15a848b 100644 --- a/lib/IPC/Open2.pm +++ b/lib/IPC/Open2.pm @@ -1,7 +1,14 @@ package IPC::Open2; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + require 5.000; require Exporter; -use Carp; + +$VERSION = 1.01; +@ISA = qw(Exporter); +@EXPORT = qw(open2); =head1 NAME @@ -22,6 +29,13 @@ when you try open(HANDLE, "|cmd args|"); +If $rdr is a string (that is, a bareword filehandle rather than a glob +or a reference) and it begins with ">&", then the child will send output +directly to that file handle. If $wtr is a string that begins with +"<&", then WTR will be closed in the parent, and the child will read +from it directly. In both cases, there will be a dup(2) instead of a +pipe(2) made. + open2() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open2:/>. @@ -44,13 +58,11 @@ read and write a line from it. =head1 SEE ALSO -See L<open3> for an alternative that handles STDERR as well. +See L<IPC::Open3> for an alternative that handles STDERR as well. This +function is really just a wrapper around open3(). =cut -@ISA = qw(Exporter); -@EXPORT = qw(open2); - # &open2: tom christiansen, <tchrist@convex.com> # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); @@ -67,41 +79,15 @@ See L<open3> for an alternative that handles STDERR as well. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +require IPC::Open3; sub open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || croak "open2: rdr should not be null"; - $dad_wtr ne '' || croak "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^([^']+$)/$package'$1/ unless ref $dad_rdr; - $dad_wtr =~ s/^([^']+$)/$package'$1/ unless ref $dad_wtr; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; - - if (($kidpid = fork) < 0) { - croak "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - close $dad_rdr; close $dad_wtr; - open(STDIN, "<&$kid_rdr"); - open(STDOUT, ">&$kid_wtr"); - warn "execing @cmd\n" if $debug; - exec @cmd - or croak "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; + my ($read, $write, @cmd) = @_; + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + return IPC::Open3::_open3('open2', scalar caller, + $write, $read, '>&STDERR', @cmd); } -1; # so require is happy +1 diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index d416ae7886..794893b297 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -1,7 +1,18 @@ package IPC::Open3; + +use strict; +no strict 'refs'; # because users pass me bareword filehandles +use vars qw($VERSION @ISA @EXPORT $Fh $Me); + require 5.001; require Exporter; + use Carp; +use Symbol 'qualify'; + +$VERSION = 1.01; +@ISA = qw(Exporter); +@EXPORT = qw(open3); =head1 NAME @@ -9,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 @@ -29,12 +40,28 @@ writer, you'll have problems with blocking, which means you'll want to use select(), which means you'll have to use sysread() instead of normal stuff. -All caveats from open2() continue to apply. See L<open2> for details. +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C</^open3:/>. -=cut +=head1 WARNING + +It will not create these file handles for you. You have to do this +yourself. So don't pass it empty variables expecting them to get filled +in for you. -@ISA = qw(Exporter); -@EXPORT = qw(open3); +Additionally, this is very dangerous as you may block forever. It +assumes it's going to talk to something like B<bc>, both writing to it +and reading from it. This is presumably safe because you "know" that +commands like B<bc> will read a line at a time and output a line at a +time. Programs like B<sort> that read their entire input stream first, +however, are quite apt to cause deadlock. + +The big problem with this approach is that if you don't have control +over source code being run in the the child process, you can't control +what it does with pipe buffering. Thus you can't just open a pipe to +C<cat -v> and continually read and write a line from it. + +=cut # &open3: Marc Horowitz <marc@mit.edu> # derived mostly from &open2 by tom christiansen, <tchrist@convex.com> @@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L<open2> for details. # reading, wtr for writing, and err for errors. # if err is '', or the same as rdr, then stdout and # stderr of the child are on the same fh. returns pid -# of child, or 0 on failure. +# of child (or dies on failure). # if wtr begins with '<&', then wtr will be closed in the parent, and @@ -64,17 +91,41 @@ All caveats from open2() continue to apply. See L<open2> for details. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +$Fh = 'FHOPEN000'; # package static in case called more than once +$Me = 'open3 (bug)'; # you should never see this, it's always localized -sub open3 { - my($kidpid); - my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - my($dup_wtr, $dup_rdr, $dup_err); +# Fatal.pm needs to be fixed WRT prototypes. + +sub xfork { + my $pid = fork; + defined $pid or croak "$Me: fork failed: $!"; + return $pid; +} + +sub xpipe { + pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; +} + +# I tried using a * prototype character for the filehandle but it still +# disallows a bearword while compiling under strict subs. - $dad_wtr || croak "open3: wtr should not be null"; - $dad_rdr || croak "open3: rdr should not be null"; +sub xopen { + open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; +} + +sub xclose { + close $_[0] or croak "$Me: close($_[0]) failed: $!"; +} + +sub _open3 { + local $Me = shift; + my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + my($dup_wtr, $dup_rdr, $dup_err, $kidpid); + + $dad_wtr or croak "$Me: wtr should not be null"; + $dad_rdr or croak "$Me: rdr should not be null"; $dad_err = $dad_rdr if ($dad_err eq ''); $dup_wtr = ($dad_wtr =~ s/^[<>]&//); @@ -82,63 +133,73 @@ sub open3 { $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into callers' package - my($package) = caller; - $dad_wtr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_wtr; - $dad_rdr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_rdr; - $dad_err =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_err; - - my($kid_rdr) = ++$fh; - my($kid_wtr) = ++$fh; - my($kid_err) = ++$fh; - - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; - } + $dad_wtr = qualify $dad_wtr, $package; + $dad_rdr = qualify $dad_rdr, $package; + $dad_err = qualify $dad_err, $package; + + my $kid_rdr = ++$Fh; + my $kid_wtr = ++$Fh; + my $kid_err = ++$Fh; + + xpipe $kid_rdr, $dad_wtr if !$dup_wtr; + xpipe $dad_rdr, $kid_wtr if !$dup_rdr; + xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr; + + $kidpid = xfork; + if ($kidpid == 0) { + # If she wants to dup the kid's stderr onto her stdout I need to + # save a copy of her stdout before I put something else there. + if ($dad_rdr ne $dad_err && $dup_err + && fileno($dad_err) == fileno(STDOUT)) { + my $tmp = ++$Fh; + xopen($tmp, ">&$dad_err"); + $dad_err = $tmp; + } - if (($kidpid = fork) < 0) { - croak "open3: fork failed: $!"; - } elsif ($kidpid == 0) { if ($dup_wtr) { - open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); } else { - close($dad_wtr); - open(STDIN, "<&$kid_rdr"); + xclose $dad_wtr; + xopen \*STDIN, "<&$kid_rdr"; + xclose $kid_rdr; } if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); + xclose $dad_rdr; + xopen \*STDOUT, ">&$kid_wtr"; + xclose $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_err)); + xopen \*STDERR, ">&$dad_err" + if fileno(STDERR) != fileno($dad_err); } else { - close($dad_err); - open(STDERR, ">&$kid_err"); + xclose $dad_err; + xopen \*STDERR, ">&$kid_err"; + xclose $kid_err; } } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); + xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); } local($")=(" "); exec @cmd or croak "open3: exec of @cmd failed"; } - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); - } + xclose $kid_rdr if !$dup_wtr; + xclose $kid_wtr if !$dup_rdr; + xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err; + # If the write handle is a dup give it away entirely, close my copy + # of it. + xclose $dad_wtr if $dup_wtr; select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } + +sub open3 { + return _open3 'open3', scalar caller, @_ +} 1; # so require is happy diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index a4d8b6bd18..f76f2611f0 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,11 +171,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 5ec4a5661e..fce53f7b81 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -56,7 +56,7 @@ $display = 'cartesian'; # Default display format sub make { my $self = bless {}, shift; my ($re, $im) = @_; - $self->{cartesian} = [$re, $im]; + $self->{'cartesian'} = [$re, $im]; $self->{c_dirty} = 0; $self->{p_dirty} = 1; return $self; @@ -71,7 +71,7 @@ sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; $theta += pi() if $rho < 0; - $self->{polar} = [abs($rho), $theta]; + $self->{'polar'} = [abs($rho), $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; return $self; @@ -118,8 +118,8 @@ sub pi () { # sub i () { $i = bless {} unless $i; # There can be only one i - $i->{cartesian} = [0, 1]; - $i->{polar} = [1, pi/2]; + $i->{'cartesian'} = [0, 1]; + $i->{'polar'} = [1, pi/2]; $i->{c_dirty} = 0; $i->{p_dirty} = 0; return $i; @@ -129,11 +129,11 @@ sub i () { # Attribute access/set routines # -sub cartesian {$_[0]->{c_dirty} ? $_[0]->update_cartesian : $_[0]->{cartesian}} -sub polar {$_[0]->{p_dirty} ? $_[0]->update_polar : $_[0]->{polar}} +sub cartesian {$_[0]->{c_dirty} ? $_[0]->update_cartesian : $_[0]->{'cartesian'}} +sub polar {$_[0]->{p_dirty} ? $_[0]->update_polar : $_[0]->{'polar'}} -sub set_cartesian { $_[0]->{p_dirty}++; $_[0]->{cartesian} = $_[1] } -sub set_polar { $_[0]->{c_dirty}++; $_[0]->{polar} = $_[1] } +sub set_cartesian { $_[0]->{p_dirty}++; $_[0]->{'cartesian'} = $_[1] } +sub set_polar { $_[0]->{c_dirty}++; $_[0]->{'polar'} = $_[1] } # # ->update_cartesian @@ -142,9 +142,9 @@ sub set_polar { $_[0]->{c_dirty}++; $_[0]->{polar} = $_[1] } # sub update_cartesian { my $self = shift; - my ($r, $t) = @{$self->{polar}}; + my ($r, $t) = @{$self->{'polar'}}; $self->{c_dirty} = 0; - return $self->{cartesian} = [$r * cos $t, $r * sin $t]; + return $self->{'cartesian'} = [$r * cos $t, $r * sin $t]; } # @@ -155,10 +155,10 @@ sub update_cartesian { # sub update_polar { my $self = shift; - my ($x, $y) = @{$self->{cartesian}}; + my ($x, $y) = @{$self->{'cartesian'}}; $self->{p_dirty} = 0; - return $self->{polar} = [0, 0] if $x == 0 && $y == 0; - return $self->{polar} = [sqrt($x*$x + $y*$y), atan2($y, $x)]; + return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0; + return $self->{'polar'} = [sqrt($x*$x + $y*$y), atan2($y, $x)]; } # @@ -699,10 +699,15 @@ sub stringify_cartesian { my ($x, $y) = @{$z->cartesian}; my ($re, $im); + $x = int($x + ($x < 0 ? -1 : 1) * 1e-14) + if int(abs($x)) != int(abs($x) + 1e-14); + $y = int($y + ($y < 0 ? -1 : 1) * 1e-14) + if int(abs($y)) != int(abs($y) + 1e-14); + $re = "$x" if abs($x) >= 1e-14; if ($y == 1) { $im = 'i' } elsif ($y == -1) { $im = '-i' } - elsif (abs($y) >= 1e-14) { $im = "${y}i" } + elsif (abs($y) >= 1e-14) { $im = $y . "i" } my $str; $str = $re if defined $re; @@ -734,7 +739,13 @@ sub stringify_polar { if (abs($nt) <= 1e-14) { $theta = 0 } elsif (abs(pi-$nt) <= 1e-14) { $theta = 'pi' } - return "\[$r,$theta\]" if defined $theta; + if (defined $theta) { + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; + } # # Okay, number is not a real. Try to identify pi/n and friends... @@ -753,6 +764,11 @@ sub stringify_polar { $theta = $nt unless defined $theta; + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; } diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 3ba88d5751..91077ddad1 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,106 +1,550 @@ package Net::Ping; -# Authors: karrer@bernina.ethz.ch (Andreas Karrer) -# pmarquess@bfsec.bt.co.uk (Paul Marquess) - -require 5.002 ; +# Author: mose@ccsn.edu (Russell Mosemann) +# +# Authors of the original pingecho(): +# karrer@bernina.ethz.ch (Andreas Karrer) +# pmarquess@bfsec.bt.co.uk (Paul Marquess) +# +# Copyright (c) 1996 Russell Mosemann. All rights reserved. This +# program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +require 5.002; require Exporter; -use strict ; -use vars qw(@ISA @EXPORT $VERSION $tcp_proto $echo_port) ; +use strict; +use vars qw(@ISA @EXPORT $VERSION + $def_timeout $def_proto $max_datasize); +use FileHandle; +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET + inet_aton sockaddr_in ); +use Carp; @ISA = qw(Exporter); -@EXPORT = qw(ping pingecho); -$VERSION = 1.01; - -use Socket 'PF_INET', 'AF_INET', 'SOCK_STREAM'; -use Carp ; - -$tcp_proto = (getprotobyname('tcp'))[2]; -$echo_port = (getservbyname('echo', 'tcp'))[2]; - -sub ping { - croak "ping not implemented yet. Use pingecho()"; -} +@EXPORT = qw(pingecho); +$VERSION = 2.02; +# Constants -sub pingecho { +$def_timeout = 5; # Default timeout to wait for a reply +$def_proto = "udp"; # Default protocol to use for pinging +$max_datasize = 1024; # Maximum data bytes in a packet - croak "usage: pingecho host [timeout]" - unless @_ == 1 or @_ == 2 ; +# Description: The pingecho() subroutine is provided for backward +# compatibility with the original Net::Ping. It accepts a host +# name/IP and an optional timeout in seconds. Create a tcp ping +# object and try pinging the host. The result of the ping is returned. - my ($host, $timeout) = @_; - my ($saddr, $ip); - my ($ret) ; - local (*PINGSOCK); +sub pingecho +{ + my ($host, # Name or IP number of host to ping + $timeout # Optional timeout in seconds + ) = @_; + my ($p); # A ping object - # check if $host is alive by connecting to its echo port, within $timeout - # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found + $p = Net::Ping->new("tcp", $timeout); + $p->ping($host); # Going out of scope closes the connection +} - $timeout = 5 unless $timeout; +# Description: The new() method creates a new ping object. Optional +# parameters may be specified for the protocol to use, the timeout in +# seconds and the size in bytes of additional data which should be +# included in the packet. +# After the optional parameters are checked, the data is constructed +# and a socket is opened if appropriate. The object is returned. + +sub new +{ + my ($this, + $proto, # Optional protocol to use for pinging + $timeout, # Optional timeout in seconds + $data_size # Optional additional bytes of data + ) = @_; + my $class = ref($this) || $this; + my $self = {}; + my ($cnt, # Count through data bytes + $min_datasize # Minimum data bytes required + ); + + bless($self, $class); + + $proto = $def_proto unless $proto; # Determine the protocol + croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"") + unless $proto =~ m/^(tcp|udp|icmp)$/; + $self->{"proto"} = $proto; + + $timeout = $def_timeout unless $timeout; # Determine the timeout + croak("Default timeout for ping must be greater than 0 seconds") + if $timeout <= 0; + $self->{"timeout"} = $timeout; + + $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size + $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; + croak("Data for ping must be from $min_datasize to $max_datasize bytes") + if ($data_size < $min_datasize) || ($data_size > $max_datasize); + $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte + $self->{"data_size"} = $data_size; + + $self->{"data"} = ""; # Construct data bytes + for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++) + { + $self->{"data"} .= chr($cnt % 256); + } + + $self->{"seq"} = 0; # For counting packets + if ($self->{"proto"} eq "udp") # Open a socket + { + $self->{"proto_num"} = (getprotobyname('udp'))[2] || + croak("Can't udp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || + croak("Can't get udp echo port by name"); + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(), + $self->{"proto_num"}) || + croak("udp socket error - $!"); + } + elsif ($self->{"proto"} eq "icmp") + { + croak("icmp ping requires root privilege") if $>; + $self->{"proto_num"} = (getprotobyname('icmp'))[2] || + croak("Can't get icmp protocol by name"); + $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) || + croak("icmp socket error - $!"); + } + elsif ($self->{"proto"} eq "tcp") # Just a file handle for now + { + $self->{"proto_num"} = (getprotobyname('tcp'))[2] || + croak("Can't get tcp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || + croak("Can't get tcp echo port by name"); + $self->{"fh"} = FileHandle->new(); + } + + + return($self); +} - if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/) - { $ip = pack ('C4', split (/\./, $1)) } +# Description: Ping a host name or IP number with an optional timeout. +# First lookup the host, and return undef if it is not found. Otherwise +# perform the specific ping method based on the protocol. Return the +# result of the ping. + +sub ping +{ + my ($self, + $host, # Name or IP number of host to ping + $timeout # Seconds after which ping times out + ) = @_; + my ($ip, # Packed IP number of $host + $ret # The return value + ); + + croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3; + $timeout = $self->{"timeout"} unless $timeout; + croak("Timeout must be greater than 0 seconds") if $timeout <= 0; + + $ip = inet_aton($host); + return(undef) unless defined($ip); # Does host exist? + + if ($self->{"proto"} eq "udp") + { + $ret = $self->ping_udp($ip, $timeout); + } + elsif ($self->{"proto"} eq "icmp") + { + $ret = $self->ping_icmp($ip, $timeout); + } + elsif ($self->{"proto"} eq "tcp") + { + $ret = $self->ping_tcp($ip, $timeout); + } else - { $ip = (gethostbyname($host))[4] } - - return 0 unless $ip; # "no such host" + { + croak("Unknown protocol \"$self->{proto}\" in ping()"); + } + return($ret); +} - $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip); - $SIG{'ALRM'} = sub { die } ; - alarm($timeout); - +sub ping_icmp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $ICMP_ECHOREPLY = 0; # ICMP packet types + my $ICMP_ECHO = 8; + my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet + my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY + my $flags = 0; # No special flags when opening a socket + my $port = 0; # No port with ICMP + + my ($saddr, # sockaddr_in with port and ip + $checksum, # Checksum of ICMP packet + $msg, # ICMP packet to send + $len_msg, # Length of $msg + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $finish_time, # Time ping should be finished + $done, # set to 1 when we are done + $ret, # Return value + $recv_msg, # Received message including IP header + $from_saddr, # sockaddr_in of sender + $from_port, # Port packet was sent from + $from_ip, # Packed IP of sender + $from_type, # ICMP type + $from_subcode, # ICMP subcode + $from_chk, # ICMP packet checksum + $from_pid, # ICMP packet id + $from_seq, # ICMP packet sequence + $from_msg # ICMP message + ); + + $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence + $checksum = 0; # No checksum for starters + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $checksum = Net::Ping->checksum($msg); + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $len_msg = length($msg); + $saddr = sockaddr_in($port, $ip); + send($self->{"fh"}, $msg, $flags, $saddr); # Send the message + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; $ret = 0; + $done = 0; + $finish_time = time() + $timeout; # Must be done by this time + while (!$done && $timeout > 0) # Keep trying if we have time + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for packet + $timeout = $finish_time - time(); # Get remaining time + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # Got a packet from somewhere + { + $recv_msg = ""; + $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + ($from_type, $from_subcode, $from_chk, + $from_pid, $from_seq, $from_msg) = + unpack($icmp_struct . $self->{"data_size"}, + substr($recv_msg, length($recv_msg) - $len_msg, + $len_msg)); + if (($from_type == $ICMP_ECHOREPLY) && + ($from_ip eq $ip) && + ($from_pid == $self->{"pid"}) && # Does the packet check out? + ($from_seq == $self->{"seq"})) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret) +} + +# Description: Do a checksum on the message. Basically sum all of +# the short words and fold the high order bits into the low order bits. + +sub checksum +{ + my ($class, + $msg # The message to checksum + ) = @_; + my ($len_msg, # Length of the message + $num_short, # The number of short words in the message + $short, # One short word + $chk # The checksum + ); + + $len_msg = length($msg); + $num_short = $len_msg / 2; + $chk = 0; + foreach $short (unpack("S$num_short", $msg)) + { + $chk += $short; + } # Add the odd byte in + $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; + $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low + return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement +} + +# Description: Perform a tcp echo ping. Since a tcp connection is +# host specific, we have to open and close each connection here. We +# can't just leave a socket open. Because of the robust nature of +# tcp, it will take a while before it gives up trying to establish a +# connection. Therefore, we have to set the alarm to break out of the +# connection sooner if the timeout expires. No data bytes are actually +# sent since the successful establishment of a connection is proof +# enough of the reachability of the remote host. Also, tcp is +# expensive and doesn't need our help to add to the overhead. + +sub ping_tcp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + my ($saddr, # sockaddr_in with port and ip + $ret # The return value + ); + + socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) || + croak("tcp socket error - $!"); + $saddr = sockaddr_in($self->{"port_num"}, $ip); + + $SIG{'ALRM'} = sub { die }; + alarm($timeout); # Interrupt connect() if we have to + + $ret = 0; # Default to unreachable eval <<'EOM' ; - return unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; - return unless connect(PINGSOCK, $saddr) ; - $ret=1 ; + return unless connect($self->{"fh"}, $saddr); + $ret = 1; EOM alarm(0); - close(PINGSOCK); - $ret; + $self->{"fh"}->close(); + return($ret); +} + +# Description: Perform a udp echo ping. Construct a message of +# at least the one-byte sequence number and any additional data bytes. +# Send the message out and wait for a message to come back. If we +# get a message, make sure all of its parts match. If they do, we are +# done. Otherwise go back and wait for the message until we run out +# of time. Return the result of our efforts. + +sub ping_udp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $flags = 0; # Nothing special on open + + my ($saddr, # sockaddr_in with port and ip + $ret, # The return value + $msg, # Message to be echoed + $finish_time, # Time ping should be finished + $done, # Set to 1 when we are done pinging + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $from_saddr, # sockaddr_in of sender + $from_msg, # Characters echoed by $host + $from_port, # Port message was echoed from + $from_ip # Packed IP number of sender + ); + + $saddr = sockaddr_in($self->{"port_num"}, $ip); + $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence + $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any + send($self->{"fh"}, $msg, $flags, $saddr); # Send it + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + $ret = 0; # Default to unreachable + $done = 0; + $finish_time = time() + $timeout; # Ping needs to be done by then + while (!$done && $timeout > 0) + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for response + $timeout = $finish_time - time(); # Get remaining time + + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # A packet is waiting + { + $from_msg = ""; + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + if (($from_ip eq $ip) && # Does the packet check out? + ($from_port == $self->{"port_num"}) && + ($from_msg eq $msg)) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret); } +# Description: Close the connection unless we are using the tcp +# protocol, since it will already be closed. + +sub close +{ + my ($self) = @_; + + $self->{"fh"}->close() unless $self->{"proto"} eq "tcp"; +} + + 1; __END__ -=cut - =head1 NAME -Net::Ping, pingecho - check a host for upness +Net::Ping - check a remote host for reachability =head1 SYNOPSIS use Net::Ping; - print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ; - -=head1 DESCRIPTION -This module contains routines to test for the reachability of remote hosts. -Currently the only routine implemented is pingecho(). + $p = Net::Ping->new(); + print "$host is alive.\n" if $p->ping($host); + $p->close(); + + $p = Net::Ping->new("icmp"); + foreach $host (@host_array) + { + print "$host is "; + print "NOT " unless $p->ping($host, 2); + print "reachable.\n"; + sleep(1); + } + $p->close(); + + $p = Net::Ping->new("tcp", 2); + while ($stop_time > time()) + { + print "$host not reachable ", scalar(localtime()), "\n" + unless $p->ping($host); + sleep(300); + } + undef($p); + + # For backward compatibility + print "$host is alive.\n" if pingecho($host); -pingecho() uses a TCP echo (I<not> an ICMP one) to determine if the -remote host is reachable. This is usually adequate to tell that a remote -host is available to rsh(1), ftp(1), or telnet(1) onto. +=head1 DESCRIPTION -=head2 Parameters +This module contains methods to test the reachability of remote +hosts on a network. A ping object is first created with optional +parameters, a variable number of hosts may be pinged multiple +times and then the connection is closed. + +You may choose one of three different protocols to use for the ping. +With the "tcp" protocol the ping() method attempts to establish a +connection to the remote host's echo port. If the connection is +successfully established, the remote host is considered reachable. No +data is actually echoed. This protocol does not require any special +privileges but has higher overhead than the other two protocols. + +Specifying the "udp" protocol causes the ping() method to send a udp +packet to the remote host's echo port. If the echoed packet is +received from the remote host and the received packet contains the +same data as the packet that was sent, the remote host is considered +reachable. This protocol does not require any special privileges. + +If the "icmp" protocol is specified, the ping() method sends an icmp +echo message to the remote host, which is what the UNIX ping program +does. If the echoed message is received from the remote host and +the echoed information is correct, the remote host is considered +reachable. Specifying the "icmp" protocol requires that the program +be run as root or that the program be setuid to root. + +=head2 Functions + +=over 4 + +=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]); + +Create a new ping object. All of the parameters are optional. $proto +specifies the protocol to use when doing a ping. The current choices +are "tcp", "udp" or "icmp". The default is "udp". + +If a default timeout ($def_timeout) in seconds is provided, it is used +when a timeout is not given to the ping() method (below). The timeout +must be greater than 0 and the default, if not specified, is 5 seconds. + +If the number of data bytes ($bytes) is given, that many data bytes +are included in the ping packet sent to the remote host. The number of +data bytes is ignored if the protocol is "tcp". The minimum (and +default) number of data bytes is 1 if the protocol is "udp" and 0 +otherwise. The maximum number of data bytes that can be specified is +1024. + +=item $p->ping($host [, $timeout]); + +Ping the remote host and wait for a response. $host can be either the +hostname or the IP number of the remote host. The optional timeout +must be greater than 0 seconds and defaults to whatever was specified +when the ping object was created. If the hostname cannot be found or +there is a problem with the IP number, undef is returned. Otherwise, +1 is returned if the host is reachable and 0 if it is not. For all +practical purposes, undef and 0 and can be treated as the same case. + +=item $p->close(); + +Close the network connection for this ping object. The network +connection is also closed by "undef $p". The network connection is +automatically closed if the ping object goes out of scope (e.g. $p is +local to a subroutine and you leave the subroutine). + +=item pingecho($host [, $timeout]); + +To provide backward compatibility with the previous version of +Net::Ping, a pingecho() subroutine is available with the same +functionality as before. pingecho() uses the tcp protocol. The +return values and parameters are the same as described for the ping() +method. This subroutine is obsolete and may be removed in a future +version of Net::Ping. -=over 5 +=back -=item hostname +=head1 WARNING -The remote host to check, specified either as a hostname or as an IP address. +pingecho() or a ping object with the tcp protocol use alarm() to +implement the timeout. So, don't use alarm() in your program while +you are using pingecho() or a ping object with the tcp protocol. The +udp and icmp protocols do not use alarm() to implement the timeout. -=item timeout +=head1 NOTES -The timeout in seconds. If not specified it will default to 5 seconds. +There will be less network overhead (and some efficiency in your +program) if you specify either the udp or the icmp protocol. The tcp +protocol will generate 2.5 times or more traffic for each ping than +either udp or icmp. If many hosts are pinged frequently, you may wish +to implement a small wait (e.g. 25ms or more) between each ping to +avoid flooding your network with packets. -=back +The icmp protocol requires that the program be run as root or that it +be setuid to root. The tcp and udp protocols do not require special +privileges, but not all network devices implement the echo protocol +for tcp or udp. -=head1 WARNING +Local hosts should normally respond to pings within milliseconds. +However, on a very congested network it may take up to 3 seconds or +longer to receive an echo packet from the remote host. If the timeout +is set too low under these conditions, it will appear that the remote +host is not reachable (which is almost the truth). -pingecho() uses alarm to implement the timeout, so don't set another alarm -while you are using it. +Reachability doesn't necessarily mean that the remote host is actually +functioning beyond its ability to echo packets. +Because of a lack of anything better, this module uses its own +routines to pack and unpack ICMP packets. It would be better for a +separate module to be written which understands all of the different +kinds of ICMP packets. +=cut diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm new file mode 100644 index 0000000000..1eeaae3393 --- /dev/null +++ b/lib/Net/hostent.pm @@ -0,0 +1,147 @@ +package Net::hostent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(gethostbyname gethostbyaddr gethost); + @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'Net::hostent' => [ + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', +]; + +sub addr { shift->addr_list->[0] } + +sub populate (@) { + return unless @_; + my $hob = new(); + $h_name = $hob->[0] = $_[0]; + @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; + $h_addrtype = $hob->[2] = $_[2]; + $h_length = $hob->[3] = $_[3]; + $h_addr = $_[4]; + @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; + return $hob; +} + +sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } + +sub gethostbyaddr ($;$) { + my ($addr, $addrtype); + $addr = shift; + require Socket unless @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::gethostbyaddr($addr, $addrtype)) +} + +sub gethost($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &gethostbyaddr(Socket::inet_aton(shift)); + } else { + &gethostbyname; + } +} + +1; +__END__ + +=head1 NAME + +Net::hostent - by-name interface to Perl's built-in gethost*() functions + +=head1 SYNOPSIS + + use Net::hostnet; + +=head1 DESCRIPTION + +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 +reference. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to +$h_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $host_obj-E<gt>aliases() +}> would be simply @h_aliases. + +The gethost() funtion is a simple front-end that forwards a numeric +argument to gethostbyaddr() by way of Socket::inet_aton, and the rest +to gethostbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + + use Net::hostent; + use Socket; + + @ARGV = ('netscape.com') unless @ARGV; + + for $host ( @ARGV ) { + + unless ($h = gethost($host)) { + warn "$0: no such host: $host\n"; + next; + } + + printf "\n%s is %s%s\n", + $host, + lc($h->name) eq lc($host) ? "" : "*really* ", + $h->name; + + print "\taliases are ", join(", ", @{$h->aliases}), "\n" + if @{$h->aliases}; + + if ( @{$h->addr_list} > 1 ) { + my $i; + for $addr ( @{$h->addr_list} ) { + printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr); + } + } else { + printf "\taddress is [%s]\n", inet_ntoa($h->addr); + } + + if ($h = gethostbyaddr($h->addr)) { + if (lc($h->name) ne lc($host)) { + printf "\tThat addr reverses to host %s!\n", $h->name; + $host = $h->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm new file mode 100644 index 0000000000..c21096d724 --- /dev/null +++ b/lib/Net/netent.pm @@ -0,0 +1,165 @@ +package Net::netent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(getnetbyname getnetbyaddr getnet); + @EXPORT_OK = qw( + $n_name @n_aliases + $n_addrtype $n_net + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'Net::netent' => [ + name => '$', + aliases => '@', + addrtype => '$', + net => '$', +]; + +sub populate (@) { + return unless @_; + my $nob = new(); + $n_name = $nob->[0] = $_[0]; + @n_aliases = @{ $nob->[1] } = split ' ', $_[1]; + $n_addrtype = $nob->[2] = $_[2]; + $n_net = $nob->[3] = $_[3]; + return $nob; +} + +sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) } + +sub getnetbyaddr ($;$) { + my ($net, $addrtype); + $net = shift; + require Socket if @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::getnetbyaddr($net, $addrtype)) +} + +sub getnet($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &getnetbyaddr(Socket::inet_aton(shift)); + } else { + &getnetbyname; + } +} + +1; +__END__ + +=head1 NAME + +Net::netent - by-name interface to Perl's built-in getnet*() functions + +=head1 SYNOPSIS + + use Net::netent qw(:FIELDS); + getnetbyname("loopback") or die "bad net"; + printf "%s is %08X\n", $n_name, $n_net; + + use Net::netent; + + $n = getnetbyname("loopback") or die "bad net"; + { # there's gotta be a better way, eh? + @bytes = unpack("C4", pack("N", $n->net)); + shift @bytes while @bytes && $bytes[0] == 0; + } + printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes; + +=head1 DESCRIPTION + +This module's default exports override the core getnetbyname() and +getnetbyaddr() functions, replacing them with versions that return +"Net::netent" objects. This object has methods that return the similarly +named structure field name from the C's netent structure from F<netdb.h>; +namely name, aliases, addrtype, and net. The aliases +method returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to +$n_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $net_obj-E<gt>aliases() +}> would be simply @n_aliases. + +The getnet() funtion is a simple front-end that forwards a numeric +argument to getnetbyaddr(), and the rest +to getnetbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + +The getnet() functions do this in the Perl core: + + sv_setiv(sv, (I32)nent->n_net); + +The gethost() functions do this in the Perl core: + + sv_setpvn(sv, hent->h_addr, len); + +That means that the address comes back in binary for the +host functions, and as a regular perl integer for the net ones. +This seems a bug, but here's how to deal with it: + + use strict; + use Socket; + use Net::netent; + + @ARGV = ('loopback') unless @ARGV; + + my($n, $net); + + for $net ( @ARGV ) { + + unless ($n = getnetbyname($net)) { + warn "$0: no such net: $net\n"; + next; + } + + printf "\n%s is %s%s\n", + $net, + lc($n->name) eq lc($net) ? "" : "*really* ", + $n->name; + + print "\taliases are ", join(", ", @{$n->aliases}), "\n" + if @{$n->aliases}; + + # this is stupid; first, why is this not in binary? + # second, why am i going through these convolutions + # to make it looks right + { + my @a = unpack("C4", pack("N", $n->net)); + shift @a while @a && $a[0] == 0; + printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a; + } + + if ($n = getnetbyaddr($n->net)) { + if (lc($n->name) ne lc($net)) { + printf "\tThat addr reverses to net %s!\n", $n->name; + $net = $n->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Net/protoent.pm b/lib/Net/protoent.pm new file mode 100644 index 0000000000..ffd6acd587 --- /dev/null +++ b/lib/Net/protoent.pm @@ -0,0 +1,92 @@ +package Net::protoent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(getprotobyname getprotobynumber getprotoent); + @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'Net::protoent' => [ + name => '$', + aliases => '@', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $pob = new(); + $p_name = $pob->[0] = $_[0]; + @p_aliases = @{ $pob->[1] } = split ' ', $_[1]; + $p_proto = $pob->[2] = $_[2]; + return $pob; +} + +sub getprotoent ( ) { populate(CORE::getprotoent()) } +sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) } +sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) } + +sub getproto ($;$) { + no strict 'refs'; + return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_); +} + +1; + +__END__ + +=head1 NAME + +Net::protoent - by-name interface to Perl's built-in getproto*() functions + +=head1 SYNOPSIS + + use Net::protoent; + $p = getprotobyname(shift || 'tcp') || die "no proto"; + printf "proto for %s is %d, aliases are %s\n", + $p->name, $p->proto, "@{$p->aliases}"; + + use Net::protoent qw(:FIELDS); + getprotobyname(shift || 'tcp') || die "no proto"; + print "proto for $p_name is $p_proto, aliases are @p_aliases\n"; + +=head1 DESCRIPTION + +This module's default exports override the core getprotoent(), +getprotobyname(), and getnetbyport() functions, replacing them with +versions that return "Net::protoent" objects. They take default +second arguments of "tcp". This object has methods that return the +similarly named structure field name from the C's protoent structure +from F<netdb.h>; namely name, aliases, and proto. The aliases method +returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to +$p_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $proto_obj-E<gt>aliases() +}> would be simply @p_aliases. + +The getproto() function is a simple front-end that forwards a numeric +argument to getprotobyport(), and the rest to getprotobyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Net/servent.pm b/lib/Net/servent.pm new file mode 100644 index 0000000000..8c0fc13890 --- /dev/null +++ b/lib/Net/servent.pm @@ -0,0 +1,109 @@ +package Net::servent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(getservbyname getservbyport getservent getserv); + @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'Net::servent' => [ + name => '$', + aliases => '@', + port => '$', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $sob = new(); + $s_name = $sob->[0] = $_[0]; + @s_aliases = @{ $sob->[1] } = split ' ', $_[1]; + $s_port = $sob->[2] = $_[2]; + $s_proto = $sob->[3] = $_[3]; + return $sob; +} + +sub getservent ( ) { populate(CORE::getservent()) } +sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) } +sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) } + +sub getserv ($;$) { + no strict 'refs'; + return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_); +} + +1; + +__END__ + +=head1 NAME + +Net::servent - by-name interface to Perl's built-in getserv*() functions + +=head1 SYNOPSIS + + use Net::servent; + $s = getservbyname(shift || 'ftp') || die "no service"; + printf "port for %s is %s, aliases are %s\n", + $s->name, $s->port, "@{$s->aliases}"; + + use Net::servent qw(:FIELDS); + getservbyname(shift || 'ftp') || die "no service"; + print "port for $s_name is $s_port, aliases are @s_aliases\n"; + +=head1 DESCRIPTION + +This module's default exports override the core getservent(), +getservbyname(), and +getnetbyport() functions, replacing them with versions that return +"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly +named structure field name from the C's servent structure from F<netdb.h>; +namely name, aliases, port, and proto. The aliases +method returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<n_>. Thus, C<$serv_obj-E<gt>name()> corresponds to +$s_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $serv_obj-E<gt>aliases() +}> would be simply @s_aliases. + +The getserv() function is a simple front-end that forwards a numeric +argument to getservbyport(), and the rest to getservbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + + use Net::servent qw(:FIELDS); + + while (@ARGV) { + my ($service, $proto) = ((split m!/!, shift), 'tcp'); + my $valet = getserv($service, $proto); + unless ($valet) { + warn "$0: No service: $service/$proto\n" + next; + } + printf "service $service/$proto is port %d\n", $valet->port; + print "alias are @s_aliases\n" if @s_aliases; + } + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Pod/Functions.pm b/lib/Pod/Functions.pm index a775cf6165..6db7cfd83c 100644 --- a/lib/Pod/Functions.pm +++ b/lib/Pod/Functions.pm @@ -5,7 +5,7 @@ package Pod::Functions; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(%Kinds %Type %Flavor %Type_Descriptions @Type_Order); +@EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); %Type_Description = ( 'ARRAY' => 'Functions for real @ARRAYs', diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 4faed4904e..9d6636a82f 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,6 +1,6 @@ package Pod::Text; -# Version 1.01 +# Version 1.02 =head1 NAME @@ -73,8 +73,8 @@ if($termcap and !$setuptermcap) { } $SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1)) - || ($ENV{TERMCAP} =~ /co#(\d+)/)[0] || $ENV{COLUMNS} + || ($ENV{TERMCAP} =~ /co#(\d+)/)[0] || (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0] || 72; @@ -86,6 +86,7 @@ $cutting = 1; $DEF_INDENT = 4; $indent = $DEF_INDENT; $needspace = 0; +$begun = ""; open(IN, $file) || die "Couldn't open $file: $!"; @@ -94,6 +95,15 @@ POD_DIRECTIVE: while (<IN>) { next unless /^=/; $cutting = 0; } + if ($begun) { + if (/^=end\s+$begun/) { + $begun = ""; + } + elsif ($begun eq "text") { + print STDOUT $_; + } + next; + } 1 while s{^(.*?)(\t+)(.*)$}{ $1 . (' ' x (length($2) * 8 - length($1) % 8)) @@ -106,6 +116,22 @@ POD_DIRECTIVE: while (<IN>) { next; } + if (/^=for\s+(\S+)\s*/s) { + if ($1 eq "text") { + print STDOUT $',""; + } else { + # ignore unknown for + } + next; + } + elsif (/^=begin\s+(\S+)\s*/s) { + $begun = $1; + if ($1 eq "text") { + print STDOUT $'.""; + } + next; + } + sub prepare_for_output { s/\s*$/\n/; @@ -116,14 +142,14 @@ sub prepare_for_output { $maxnest = 10; while ($maxnest-- && /[A-Z]</) { unless ($FANCY) { - s/C<(.*?)>/`$1'/g; + s/C<(.*?)>/`$1'/sg; } else { - s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/ge; + s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge; } # s/[IF]<(.*?)>/italic($1)/ge; - s/I<(.*?)>/*$1*/g; + s/I<(.*?)>/*$1*/sg; # s/[CB]<(.*?)>/bold($1)/ge; - s/X<.*?>//g; + s/X<.*?>//sg; # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g; # LREF: an =item on another manpage @@ -167,9 +193,9 @@ sub prepare_for_output { ? "the section on \"$2\" in the $1 manpage" : "the section on \"$2\"" } - }gex; + }sgex; - s/[A-Z]<(.*?)>/$1/g; + s/[A-Z]<(.*?)>/$1/sg; } clear_noremap(1); } diff --git a/lib/Search/Dict.pm b/lib/Search/Dict.pm index 1cd5cf8a11..9a229a7bc0 100644 --- a/lib/Search/Dict.pm +++ b/lib/Search/Dict.pm @@ -61,7 +61,7 @@ sub look { <FH> if $min; for (;;) { $min = tell(FH); - $_ = <FH> + defined($_ = <FH>) or last; chop; s/[^\w\s]//g if $dict; diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm index 11dc6a24bf..8d80b575a1 100644 --- a/lib/SelfLoader.pm +++ b/lib/SelfLoader.pm @@ -44,7 +44,7 @@ sub _load_stubs { unless fileno($fh); $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached - while($line = <$fh> and $line !~ m/^__END__/) { + while(defined($line = <$fh>) and $line !~ m/^__END__/) { if ($line =~ m/^sub\s+([\w:]+)\s*(\([\$\@\;\%\\]*\))?/) { # A sub declared push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); $protoype = $2; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 9df3161a63..ee90127340 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -7,6 +7,7 @@ use Carp; @EXPORT = qw(openlog closelog setlogmask syslog); use Socket; +use Sys::Hostname; # adapted from syslog.pl # @@ -85,7 +86,7 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<lwall@sems.com>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt> =cut @@ -190,10 +191,10 @@ sub syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - eval(&$name) || -1; + defined &$name ? &$name : -1; } sub connect { diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index d4d91c6827..5a73ecfc52 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -195,11 +195,8 @@ sub Tgetent { ## public -- static method last; } } - if (defined $entry) { - $entry .= $_; - } else { - $entry = $_; - } + defined $entry or $entry = ''; + $entry .= $_; }; while ($state != 0) { diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm index 884f83fa90..e3c290aa02 100644 --- a/lib/Term/Complete.pm +++ b/lib/Term/Complete.pm @@ -71,6 +71,8 @@ CONFIG: { } sub Complete { + my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @cmp_lst = sort @{$_[0]}; @@ -110,7 +112,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef($r, $return); + undef $r; + undef $return; print("\r\n"); redo LOOP; } diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 5d7d8bfef0..cca05b7291 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,6 +1,7 @@ package Test::Harness; -use 5.002; +require 5.002; + use Exporter; use Benchmark; use Config; diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm index 893f3b1729..ae6797c81a 100644 --- a/lib/Text/Abbrev.pm +++ b/lib/Text/Abbrev.pm @@ -54,10 +54,11 @@ sub abbrev { my $abbrev = shift(@extra); my $len = 1; my $cmp; - foreach $cmp (@cmp) { + WORD: foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { - $abbrev .= shift(@extra); + last WORD unless @extra; + $abbrev .= shift(@extra); ++$len; } } diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 33b683525d..f86c8c2991 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -115,7 +115,7 @@ sub quotewords { last; } else { - while ($_ && !(/^$delim/ || /^['"\\]/)) { + while ($_ ne '' && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm index a334404667..ddc758c94e 100644 --- a/lib/Text/Soundex.pm +++ b/lib/Text/Soundex.pm @@ -48,7 +48,7 @@ sub soundex foreach (@s) { - tr/a-z/A-Z/; + $_ = uc $_; tr/A-Z//cd; if ($_ eq '') diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm index 4024d7b685..acd7afb7d6 100644 --- a/lib/Text/Tabs.pm +++ b/lib/Text/Tabs.pm @@ -7,7 +7,7 @@ require Exporter; @EXPORT = qw(expand unexpand $tabstop); use vars qw($VERSION $tabstop $debug); -$VERSION = 96.051501; +$VERSION = 96.121201; use strict; @@ -27,7 +27,7 @@ sub expand /sex; } return @l if wantarray; - return @l[0]; + return $l[0]; } sub unexpand @@ -60,7 +60,7 @@ sub unexpand $x = join("\n", @lines); } return @l if wantarray; - return @l[0]; + return $l[0]; } 1; @@ -69,15 +69,15 @@ __END__ =head1 NAME -Text::Tabs - expand and unexpand tabs per the unix expand(1) and unexpand(1) +Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) =head1 SYNOPSIS - use Text::Tabs; +use Text::Tabs; - $tabstop = 4; - @lines_without_tabs = expand(@lines_with_tabs); - @lines_with_tabs = unexpand(@lines_without_tabs); +$tabstop = 4; +@lines_without_tabs = expand(@lines_with_tabs); +@lines_with_tabs = unexpand(@lines_without_tabs); =head1 DESCRIPTION @@ -94,4 +94,4 @@ entire document in one string. Instead feed it an array of lines. =head1 AUTHOR -David Muir Sharnoff E<lt>F<muir@idiom.com>E<gt> +David Muir Sharnoff <muir@idiom.com> diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm index 2ffc69ec20..96ccf7ee2d 100644 --- a/lib/Text/Wrap.pm +++ b/lib/Text/Wrap.pm @@ -9,6 +9,7 @@ require Exporter; $VERSION = 96.041801; use vars qw($VERSION $columns $debug); +use strict; BEGIN { $columns = 76; # <= screen width @@ -16,7 +17,6 @@ BEGIN { } use Text::Tabs; -use strict; sub wrap { @@ -63,6 +63,7 @@ sub wrap return $r; } + 1; __DATA__ @@ -82,7 +83,7 @@ Text::Wrap - line wrapping to form simple paragraphs =head1 DESCRIPTION -Text::Wrap is a very simple paragraph formatter. It formats a +Text::Wrap::wrap() is a very simple paragraph formatter. It formats a single paragraph at a time by breaking lines at word boundries. Indentation is controlled for the first line ($initial_tab) and all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns @@ -95,6 +96,38 @@ should be set to the full width of your output device. =head1 AUTHOR -David Muir Sharnoff E<lt>F<muir@idiom.com>E<gt> +David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and +others. =cut + + print fill($initial_tab, $subsequent_tab, @text); + + print fill("", "", `cat book`); + +Text::Wrap::fill() is a simple multi-paragraph formatter. It formats +each paragraph separately and then joins them together when it's done. It +will destory any whitespace in the original text. It breaks text into +paragraphs by looking for whitespace after a newline. In other respects +it acts like wrap(). + +# Tim Pierce did a faster version of this: + +sub fill +{ + my ($ip, $xp, @raw) = @_; + my @para; + my $pp; + + for $pp (split(/\n\s+/, join("\n",@raw))) { + $pp =~ s/\s+/ /g; + my $x = wrap($ip, $xp, $pp); + push(@para, $x); + } + + # if paragraph_indent is the same as line_indent, + # separate paragraphs with blank lines + + return join ($ip eq $xp ? "\n\n" : "\n", @para); +} + diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 20b6777978..2117c54c18 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -98,7 +98,7 @@ L<Config> module. While these do not utilize B<Tie::Hash>, they serve as good working examples. =cut - + use Carp; sub new { diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm new file mode 100644 index 0000000000..66de2572fc --- /dev/null +++ b/lib/Tie/RefHash.pm @@ -0,0 +1,123 @@ +package Tie::RefHash; + +=head1 NAME + +Tie::RefHash - use references as hash keys + +=head1 SYNOPSIS + + require 5.004; + use Tie::RefHash; + tie HASHVARIABLE, 'Tie::RefHash', LIST; + + untie HASHVARIABLE; + +=head1 DESCRIPTION + +This module provides the ability to use references as hash keys if +you first C<tie> the hash variable to this module. + +It is implemented using the standard perl TIEHASH interface. Please +see the C<tie> entry in perlfunc(1) and perltie(1) for more information. + +=head1 EXAMPLE + + use Tie::RefHash; + tie %h, 'Tie::RefHash'; + $a = []; + $b = {}; + $c = \*main; + $d = \"gunk"; + $e = sub { 'foo' }; + %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); + $a->[0] = 'foo'; + $b->{foo} = 'bar'; + for (keys %h) { + print ref($_), "\n"; + } + + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +=head1 VERSION + +Version 1.2 15 Dec 1996 + +=head1 SEE ALSO + +perl(1), perlfunc(1), perltie(1) + +=cut + +require 5.003_11; +use Tie::Hash; +@ISA = qw(Tie::Hash); +use strict; + +sub TIEHASH { + my $c = shift; + my $s = []; + bless $s, $c; + while (@_) { + $s->STORE(shift, shift); + } + return $s; +} + +sub FETCH { + my($s, $k) = @_; + (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; +} + +sub STORE { + my($s, $k, $v) = @_; + if (ref $k) { + $s->[0]{"$k"} = [$k, $v]; + } + else { + $s->[1]{$k} = $v; + } + $v; +} + +sub DELETE { + my($s, $k) = @_; + (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k}); +} + +sub EXISTS { + my($s, $k) = @_; + (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k}); +} + +sub FIRSTKEY { + my $s = shift; + my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]}); + $s->[2] = 0; + $s->NEXTKEY; +} + +sub NEXTKEY { + my $s = shift; + my ($k, $v); + if (!$s->[2]) { + if (($k, $v) = each %{$s->[0]}) { + return $s->[0]{"$k"}[0]; + } + else { + $s->[2] = 1; + } + } + return each %{$s->[1]}; +} + +sub CLEAR { + my $s = shift; + $s->[2] = 0; + %{$s->[0]} = (); + %{$s->[1]} = (); +} + +1; diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 1fab298e0a..0119f9ddb8 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -40,12 +40,12 @@ after the 1st of January, 2038 on most machines. =cut BEGIN { - @epoch = localtime(0); - $SEC = 1; $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAY = 24 * $HR; + $epoch = (localtime(2*$DAY))[5]; # Allow for bugs near localtime == 0. + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; my $t = time; @@ -71,13 +71,13 @@ BEGIN { sub timegm { $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; } sub timelocal { $time = &timegm + $tzsec; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; @@ -88,19 +88,14 @@ sub cheat { $year -= 1900 if $year > 1900; $month = $_[4]; - croak "Month out of range 0..11 in timelocal.pl" - if $month > 11 || $month < 0; - croak "Day out of range 1..31 in timelocal.pl" - if $_[3] > 31 || $_[3] < 1; - croak "Hour out of range 0..23 in timelocal.pl" - if $_[2] > 23 || $_[2] < 0; - croak "Minute out of range 0..59 in timelocal.pl" - if $_[1] > 59 || $_[1] < 0; - croak "Second out of range 0..59 in timelocal.pl" - if $_[0] > 59 || $_[0] < 0; + croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; + croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; + croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; + croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; + croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; + $year += $YearFix if $year < $epoch; $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAY); diff --git a/lib/Time/gmtime.pm b/lib/Time/gmtime.pm new file mode 100644 index 0000000000..35233f586a --- /dev/null +++ b/lib/Time/gmtime.pm @@ -0,0 +1,87 @@ +package Time::gmtime; +use strict; +use Time::tm; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(gmtime gmctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub gmtime (;$) { populate CORE::gmtime(shift||time)} +sub gmctime (;$) { scalar CORE::gmtime(shift||time)} + +1; +__END__ + +=head1 NAME + +Time::gmtime.pm - by-name interface to Perl's built-in gmtime() function + +=head1 SYNOPSIS + + use Time::gmtime; + $gm = gmtime(); + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm->wday() ]; + + use Time::gmtime w(:FIELDS; + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_wday() ]; + + $now = gmctime(); + + use Time::gmtime; + use File::stat; + $date_string = gmctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core gmtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this +still overrides your core functions.) Access these fields as variables +named with a preceding C<tm_> in front their method names. Thus, +C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. + +The gmctime() funtion provides a way of getting at the +scalar sense of the original CORE::gmtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Time/localtime.pm b/lib/Time/localtime.pm new file mode 100644 index 0000000000..2e811e627f --- /dev/null +++ b/lib/Time/localtime.pm @@ -0,0 +1,83 @@ +package Time::localtime; +use strict; +use Time::tm; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(localtime ctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub localtime (;$) { populate CORE::localtime(shift||time)} +sub ctime (;$) { scalar CORE::localtime(shift||time) } + +1; + +__END__ + +=head1 NAME + +Time::localtime.pm - by-name interface to Perl's built-in localtime() function + +=head1 SYNOPSIS + + use Time::localtime; + printf "Year is %d\n", localtime->year() + 1900; + + $now = ctime(); + + use Time::localtime; + use File::stat; + $date_string = ctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core localtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C<tm_> in front their method names. +Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import +the fields. + +The ctime() funtion provides a way of getting at the +scalar sense of the original CORE::localtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/Time/tm.pm b/lib/Time/tm.pm new file mode 100644 index 0000000000..d1df295683 --- /dev/null +++ b/lib/Time/tm.pm @@ -0,0 +1,31 @@ +package Time::tm; +use strict; + +use Class::Template qw(struct); +struct('Time::tm' => [ + map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } +]); + +1; +__END__ + +=head1 NAME + +Time::tm.pm - internal object used by Time::gmtime and Time::localtime + +=head1 SYNOPSIS + +Don't use this module directly. + +=head1 DESCRIPTION + +This module is used internally as a base class by Time::localtime And +Time::gmtime functions. It creates a Time::tm struct object which is +addressable just like's C's tm structure from F<time.h>; namely with sec, +min, hour, mday, mon, year, wday, yday, and isdst. + +This class is an internal interface only. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index c006547db0..c0e7ebdee2 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -38,7 +38,7 @@ C<isa> can be called as either a static or object method call. =item can ( METHOD ) C<can> checks if the object has a method called C<METHOD>. If it does -then a reference to the sub is returned. If it does not the I<undef> +then a reference to the sub is returned. If it does not then I<undef> is returned. C<can> can be called as either a static or object method call. diff --git a/lib/User/grent.pm b/lib/User/grent.pm new file mode 100644 index 0000000000..1185958430 --- /dev/null +++ b/lib/User/grent.pm @@ -0,0 +1,91 @@ +package User::grent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(getgrent getgrgid getgrnam getgr); + @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'User::grent' => [ + name => '$', + passwd => '$', + gid => '$', + members => '@', +]; + +sub populate (@) { + return unless @_; + my $gob = new(); + ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2]; + @gr_members = @{$gob->[3]} = split ' ', $_[3]; + return $gob; +} + +sub getgrent ( ) { populate(CORE::getgrent()) } +sub getgrnam ($) { populate(CORE::getgrnam(shift)) } +sub getgrgid ($) { populate(CORE::getgrgid(shift)) } +sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam } + +1; +__END__ + +=head1 NAME + +User::grent.pm - by-name interface to Perl's built-in getgr*() functions + +=head1 SYNOPSIS + + use User::grent; + $gr = getgrgid(0) or die "No group zero"; + if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) { + print "gid zero name wheel, with other members"; + } + + use User::grent qw(:FIELDS; + getgrgid(0) or die "No group zero"; + if ( $gr_name eq 'wheel' && @gr_members > 1 ) { + print "gid zero name wheel, with other members"; + } + + $gr = getgr($whoever); + +=head1 DESCRIPTION + +This module's default exports override the core getgrent(), getgruid(), +and getgrnam() functions, replacing them with versions that return +"User::grent" objects. This object has methods that return the similarly +named structure field name from the C's passwd structure from F<grp.h>; +namely name, passwd, gid, and members (not mem). The first three +return scalars, the last an array reference. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds +to $gr_gid if you import the fields. Array references are available as +regular array variables, so C<@{ $group_obj-E<gt>members() }> would be +simply @gr_members. + +The getpw() funtion is a simple front-end that forwards +a numeric argument to getpwuid() and the rest to getpwnam(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm new file mode 100644 index 0000000000..9f41fe9f39 --- /dev/null +++ b/lib/User/pwent.pm @@ -0,0 +1,101 @@ +package User::pwent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(getpwent getpwuid getpwnam getpw); + @EXPORT_OK = qw( + $pw_name $pw_passwd $pw_uid + $pw_gid $pw_quota $pw_comment + $pw_gecos $pw_dir $pw_shell + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +use Class::Template qw(struct); +struct 'User::pwent' => [ + name => '$', + passwd => '$', + uid => '$', + gid => '$', + quota => '$', + comment => '$', + gcos => '$', + dir => '$', + shell => '$', +]; + +sub populate (@) { + return unless @_; + my $pwob = new(); + + ( $pw_name, $pw_passwd, $pw_uid, + $pw_gid, $pw_quota, $pw_comment, + $pw_gecos, $pw_dir, $pw_shell, ) = @$pwob = @_; + + return $pwob; +} + +sub getpwent ( ) { populate(CORE::getpwent()) } +sub getpwnam ($) { populate(CORE::getpwnam(shift)) } +sub getpwuid ($) { populate(CORE::getpwuid(shift)) } +sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam } + +1; +__END__ + +=head1 NAME + +User::pwent.pm - by-name interface to Perl's built-in getpw*() functions + +=head1 SYNOPSIS + + use User::pwent; + $pw = getpwnam('daemon') or die "No daemon user"; + if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) { + print "gid 1 on root dir"; + } + + use User::pwent qw(:FIELDS); + getpwnam('daemon') or die "No daemon user"; + if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) { + print "gid 1 on root dir"; + } + + $pw = getpw($whoever); + +=head1 DESCRIPTION + +This module's default exports override the core getpwent(), getpwuid(), +and getpwnam() functions, replacing them with versions that return +"User::pwent" objects. This object has methods that return the similarly +named structure field name from the C's passwd structure from F<pwd.h>; +namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C<pw_> in front their method names. +Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import +the fields. + +The getpw() funtion is a simple front-end that forwards +a numeric argument to getpwuid() and the rest to getpwnam(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Template +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/lib/abbrev.pl b/lib/abbrev.pl index c233d4af7e..62975e66f3 100644 --- a/lib/abbrev.pl +++ b/lib/abbrev.pl @@ -17,7 +17,7 @@ sub main'abbrev { $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; - while (substr($cmp,0,$len) eq $abbrev) { + while (@extra && substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } diff --git a/lib/bigint.pl b/lib/bigint.pl index a274736e44..bfd2efa88c 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -168,11 +168,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/blib.pm b/lib/blib.pm new file mode 100644 index 0000000000..8af1727d8f --- /dev/null +++ b/lib/blib.pm @@ -0,0 +1,70 @@ +package blib; + +=head1 NAME + +blib - Use MakeMaker's uninstalled version of a package + +=head1 SYNOPSIS + + perl -Mblib script [args...] + + perl -Mblib=dir script [args...] + +=head1 DESCRIPTION + +Looks for MakeMaker-like I<'blib'> directory structure starting in +I<dir> (or current directory) and working back up to five levels of '..'. + +Intended for use on command line with B<-M> option as a way of testing +arbitary scripts against an uninstalled version of a package. + +However it is possible to : + + use blib; + or + use blib '..'; + +etc. if you really must. + +=head1 BUGS + +Pollutes global name space for development only task. + +=head1 AUTHOR + +Nick Ing-Simmons nik@tiuk.ti.com + +=cut + +use Cwd; + + +sub import +{ + my $package = shift; + my $dir = getcwd; + if (@_) + { + print join(',',@_),"\n"; + $dir = shift; + $dir =~ s/blib$//; + $dir =~ s,/+$,,; + $dir = '.' unless ($dir); + die "$dir is not a directory\n" unless (-d $dir); + } + my $i = 5; + while ($i--) + { + my $blib = "${dir}/blib"; + if (-d $blib && -d "$blib/arch" && -d "$blib/lib") + { + unshift(@INC,"$blib/arch","$blib/lib"); + warn "Using $blib\n"; + return; + } + $dir .= "/.."; + } + die "Cannot find blib even in $dir\n"; +} + +1; diff --git a/lib/cacheout.pl b/lib/cacheout.pl index 48d594bf82..64378cffc6 100644 --- a/lib/cacheout.pl +++ b/lib/cacheout.pl @@ -35,7 +35,7 @@ $seq = 0; $numopen = 0; if (open(PARAM,'/usr/include/sys/param.h')) { - local($.); + local($_, $.); while (<PARAM>) { $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; } diff --git a/lib/chat2.pl b/lib/chat2.pl index 0d9a7d3d50..8320270175 100644 --- a/lib/chat2.pl +++ b/lib/chat2.pl @@ -264,7 +264,7 @@ ESQ eval $cases; die "$cases:\n$@" if $@; } $eof = $timeout = 0; - do $subname(); + &$subname(); } ## &chat'print([$handle,] @data) diff --git a/lib/complete.pl b/lib/complete.pl index 1e08f9145a..539f2f7798 100644 --- a/lib/complete.pl +++ b/lib/complete.pl @@ -35,7 +35,7 @@ CONFIG: { sub Complete { package Complete; - local($[,$return) = 0; + local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); if ($_[1] =~ /^StB\0/) { ($prompt, *_) = @_; } @@ -75,7 +75,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef($r, $return); + undef $r; + undef $return; print("\r\n"); redo LOOP; } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index a8af08f8c2..b00349f7b0 100755..100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -1,18 +1,4 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -if ($^O eq 'VMS') { - $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) . - '/pod/perldiag.pod'; -} -else { $diagnostics::PODFILE= $Config{privlibexp} . "/pod/perldiag.pod"; } - package diagnostics; -require 5.001; -use English; -use Carp; =head1 NAME @@ -164,8 +150,8 @@ You have to to this instead, and I<before> you load the module. BEGIN { $diagnostics::PRETTY = 1 } I could start up faster by delaying compilation until it should be -needed, but this gets a "panic: top_level" -when using the pragma form in 5.001e. +needed, but this gets a "panic: top_level" when using the pragma form +in Perl 5.001e. While it's true that this documentation is somewhat subserious, if you use a program named I<splain>, you should expect a bit of whimsy. @@ -176,6 +162,18 @@ Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995. =cut +require 5.001; +use English; +use Carp; + +use Config; +if ($^O eq 'VMS') { + $PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod'; +} +else { + $PODFILE = $Config{privlibexp} . "/pod/perldiag.pod"; +} + $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine @@ -334,7 +332,8 @@ EOFUNC $transmo .= " m{^\Q$header\E} && return 1;\n"; } - print STDERR "Already saw $header" if $msg{$header}; + print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" + if $msg{$header}; $msg{$header} = ''; } @@ -353,7 +352,7 @@ EOFUNC if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while ($error = <>) { + while (defined ($error = <>)) { splainthis($error) || print THITHER $error; } exit; @@ -415,10 +414,27 @@ sub warn_trap { sub death_trap { my $exception = $_[0]; - splainthis($exception); + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = 0; + my $i = 0; + while (1) { + my $caller = (caller($i++))[3] or last; + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + splainthis($exception) unless $in_eval; if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. (Actually what does this next + # line do? -PSeibel) + $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; local($Carp::CarpLevel) = 1; confess "Uncaught exception from user code:\n\t$exception"; # up we go; where we stop, nobody knows, but i think we die now diff --git a/lib/find.pl b/lib/find.pl index 29b83b082c..ee5dc5d150 100644 --- a/lib/find.pl +++ b/lib/find.pl @@ -31,9 +31,14 @@ use File::Find (); -*name = *File::Find::name; -*prune = *File::Find::prune; -*dir = *File::Find::dir; +*name = *File::Find::name; +*prune = *File::Find::prune; +*dir = *File::Find::dir; +*topdir = *File::Find::topdir; +*topdev = *File::Find::topdev; +*topino = *File::Find::topino; +*topmode = *File::Find::topmode; +*topnlink = *File::Find::topnlink; sub find { &File::Find::find(\&wanted, @_); diff --git a/lib/finddepth.pl b/lib/finddepth.pl index 5814a44b1f..bfa44bb1bc 100644 --- a/lib/finddepth.pl +++ b/lib/finddepth.pl @@ -30,9 +30,14 @@ use File::Find (); -*name = *File::Find::name; -*prune = *File::Find::prune; -*dir = *File::Find::dir; +*name = *File::Find::name; +*prune = *File::Find::prune; +*dir = *File::Find::dir; +*topdir = *File::Find::topdir; +*topdev = *File::Find::topdev; +*topino = *File::Find::topino; +*topmode = *File::Find::topmode; +*topnlink = *File::Find::topnlink; sub finddepth { &File::Find::finddepth(\&wanted, @_); diff --git a/lib/ftp.pl b/lib/ftp.pl index bfddcb8837..9528360da2 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -140,7 +140,7 @@ $real_site = ""; $ftp_show = 0; sub ftp'debug { - $ftp_show = @_[0]; + $ftp_show = $_[0]; # if( $ftp_show ){ # print STDERR "ftp debugging on\n"; # } @@ -148,7 +148,7 @@ sub ftp'debug sub ftp'set_timeout { - $timeout = @_[0]; + $timeout = $_[0]; $timeout_open = $timeout; $timeout_read = 20 * $timeout; if( $ftp_show ){ diff --git a/lib/getcwd.pl b/lib/getcwd.pl index d8860181c1..9dd694500c 100644 --- a/lib/getcwd.pl +++ b/lib/getcwd.pl @@ -44,9 +44,9 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; - closedir(getcwd'PARENT); #'); - return ''; + # warn "lstat($dotdots/$dir): $!"; + # closedir(getcwd'PARENT); #'); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || diff --git a/lib/getopts.pl b/lib/getopts.pl index a0818d1e3a..852aae89b1 100644 --- a/lib/getopts.pl +++ b/lib/getopts.pl @@ -8,23 +8,22 @@ sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; - local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); - if($pos >= $[) { - if($args[$pos+1] eq ':') { + if($pos >= 0) { + if($pos < $#args && $args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1"; + ${"opt_$first"} = 1; if($rest eq '') { shift(@ARGV); } diff --git a/lib/importenv.pl b/lib/importenv.pl index d56f32633b..c28ffd054d 100644 --- a/lib/importenv.pl +++ b/lib/importenv.pl @@ -8,7 +8,7 @@ local($tmp,$key) = ''; -foreach $key (keys(ENV)) { +foreach $key (keys(%ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; diff --git a/lib/locale.pm b/lib/locale.pm new file mode 100644 index 0000000000..48213ab86c --- /dev/null +++ b/lib/locale.pm @@ -0,0 +1,33 @@ +package locale; + +=head1 NAME + +locale - Perl pragma to use and avoid POSIX locales for built-in operations + +=head1 SYNOPSIS + + @x = sort @y; # ASCII sorting order + { + use locale; + @x = sort @y; # Locale-defined sorting order + } + @x = sort @y; # ASCII sorting order again + +=head1 DESCRIPTION + +This pragma tells the compiler to enable (or disable) the use of POSIX +locales for built-in operations (LC_CTYPE for regular expressions, and +LC_COLLATE for string comparison). Each "use locale" or "no locale" +affects statements to the end of the enclosing BLOCK. + +=cut + +sub import { + $^H |= 0x800; +} + +sub unimport { + $^H &= ~0x800; +} + +1; diff --git a/lib/look.pl b/lib/look.pl index 4c14e64727..e8dc8aacb6 100644 --- a/lib/look.pl +++ b/lib/look.pl @@ -10,7 +10,7 @@ sub look { $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; - $key =~ y/A-Z/a-z/ if $fold; + $key = lc $key if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); @@ -19,7 +19,7 @@ sub look { $_ = <FH>; chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; if ($_ lt $key) { $min = $mid; } @@ -33,7 +33,7 @@ sub look { while (<FH>) { chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; last if $_ ge $key; $min = tell(FH); } diff --git a/lib/open2.pl b/lib/open2.pl index 7d3b97030b..8cf08c2e8b 100644 --- a/lib/open2.pl +++ b/lib/open2.pl @@ -1,54 +1,12 @@ -# &open2: tom christiansen, <tchrist@convex.com> +# This is a compatibility interface to IPC::Open2. New programs should +# do # -# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args'); -# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); +# use IPC::Open2; # -# spawn the given $cmd and connect $rdr for -# reading and $wtr for writing. return pid -# of child, or 0 on failure. -# -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# pipe or fork or exec fails - -package open2; -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || die "open2: rdr should not be null"; - $dad_wtr ne '' || die "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^([^']+$)/$package'$1/; - $dad_wtr =~ s/^([^']+$)/$package'$1/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!"; +# instead of +# +# require 'open2.pl'; - if (($kidpid = fork) < 0) { - die "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - close $dad_rdr; close $dad_wtr; - open(STDIN, "<&$kid_rdr"); - open(STDOUT, ">&$kid_wtr"); - warn "execing @cmd\n" if $debug; - exec @cmd; - die "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open2 'open2'; +1 diff --git a/lib/open3.pl b/lib/open3.pl index 8b3917a851..7fcc931861 100644 --- a/lib/open3.pl +++ b/lib/open3.pl @@ -1,106 +1,12 @@ -# &open3: Marc Horowitz <marc@mit.edu> -# derived mostly from &open2 by tom christiansen, <tchrist@convex.com> +# This is a compatibility interface to IPC::Open3. New programs should +# do # -# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# use IPC::Open3; # -# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# instead of # -# spawn the given $cmd and connect rdr for -# reading, wtr for writing, and err for errors. -# if err is '', or the same as rdr, then stdout and -# stderr of the child are on the same fh. returns pid -# of child, or 0 on failure. +# require 'open3.pl'; - -# if wtr begins with '>&', then wtr will be closed in the parent, and -# the child will read from it directly. if rdr or err begins with -# '>&', then the child will send output directly to that fd. In both -# cases, there will be a dup() instead of a pipe() made. - - -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# pipe or fork or exec fails - -package open3; - -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open3 { - local($kidpid); - local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - local($dup_wtr, $dup_rdr, $dup_err); - - $dad_wtr || die "open3: wtr should not be null"; - $dad_rdr || die "open3: rdr should not be null"; - $dad_err = $dad_rdr if ($dad_err eq ''); - - $dup_wtr = ($dad_wtr =~ s/^\>\&//); - $dup_rdr = ($dad_rdr =~ s/^\>\&//); - $dup_err = ($dad_err =~ s/^\>\&//); - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_wtr =~ s/^([^']+$)/$package'$1/; - $dad_rdr =~ s/^([^']+$)/$package'$1/; - $dad_err =~ s/^([^']+$)/$package'$1/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - local($kid_err) = ++$fh; - - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || die "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || die "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || die "open3: pipe 3 (stderr) failed: $!"; - } - - if (($kidpid = fork) < 0) { - die "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - if ($dup_wtr) { - open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); - } else { - close($dad_wtr); - open(STDIN, "<&$kid_rdr"); - } - if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); - } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_err)); - } else { - close($dad_err); - open(STDERR, ">&$kid_err"); - } - } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); - } - local($")=(" "); - exec @cmd; - die "open2: exec of @cmd failed"; - } - - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); - } - - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open3 'open3'; +1 diff --git a/lib/overload.pm b/lib/overload.pm index 20411ea576..049545995c 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,12 +1,27 @@ package overload; +sub nil {} + sub OVERLOAD { $package = shift; my %arg = @_; - my $hash = \%{$package . "::OVERLOAD"}; + my ($sub, $fb); + $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching. + *{$package . "::()"} = \&nil; # Make it findable via fetchmethod. for (keys %arg) { - $hash->{$_} = $arg{$_}; + if ($_ eq 'fallback') { + $fb = $arg{$_}; + } else { + $sub = $arg{$_}; + if (not ref $sub and $sub !~ /::/) { + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; + } + #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; + *{$package . "::(" . $_} = \&{ $sub }; + } } + ${$package . "::()"} = $fb; # Make it findable too (fallback only). } sub import { @@ -18,44 +33,73 @@ sub import { sub unimport { $package = (caller())[0]; - my $hash = \%{$package . "::OVERLOAD"}; + ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table shift; for (@_) { - delete $hash->{$_}; + if ($_ eq 'fallback') { + undef $ {$package . "::()"}; + } else { + delete $ {$package . "::"}{"(" . $_}; + } } } sub Overloaded { - ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"}; + my $package = shift; + $package = ref $package if ref $package; + $package->can('()'); +} + +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + return $sub if $sub ne \&nil; + return shift->can($ {*$globref}); } sub OverloadedStringify { - ($package = ref $_[0]) and - defined %{$package . "::OVERLOAD"} and - exists $ {$package . "::OVERLOAD"}{'""'} and - defined &{$ {$package . "::OVERLOAD"}{'""'}}; + my $package = shift; + $package = ref $package if ref $package; + #$package->can('(""') + ov_method mycan($package, '(""'), $package; } sub Method { - ($package = ref $_[0]) and - defined %{$package . "::OVERLOAD"} and - $ {$package . "::OVERLOAD"}{$_[1]}; + my $package = shift; + $package = ref $package if ref $package; + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; } sub AddrRef { - $package = ref $_[0]; - bless $_[0], Overload::Fake; # Non-overloaded package + my $package = ref $_[0]; + return "$_[0]" unless $package; + bless $_[0], overload::Fake; # Non-overloaded package my $str = "$_[0]"; bless $_[0], $package; # Back - $str; + $package . substr $str, index $str, '='; } sub StrVal { - (OverloadedStringify) ? - (AddrRef) : + (OverloadedStringify($_[0])) ? + (AddrRef(shift)) : "$_[0]"; } +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + return \*{$package . "::$meth"} if defined &{$package . "::$meth"}; + my $p; + foreach $p (@{$package . "::ISA"}) { + my $out = mycan($p, $meth); + return $out if $out; + } + return undef; +} + 1; __END__ @@ -486,9 +530,13 @@ induces diagnostic messages. =head1 BUGS Because it is used for overloading, the per-package associative array -%OVERLOAD now has a special meaning in Perl. +%OVERLOAD now has a special meaning in Perl. The symbol table is +filled with names looking like line-noise. -As shipped, mathemagical properties are not inherited via the @ISA tree. +For the purpose of inheritance every overloaded package behaves as if +C<fallback> is present (possibly undefined). This may create +interesting effects if some package is not overloaded, but inherits +from two overloaded packages. This document is confusing. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a57475ce06..fce77570f0 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 0.95; +$VERSION = 0.9801; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -17,14 +17,35 @@ $header = "perl5db.pl patch level $VERSION"; # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # -# Perl supplies the values for @line and %sub. It effectively inserts -# a &DB'DB(<linenum>); in front of every place that can have a +# Perl supplies the values for %sub. It effectively inserts +# a &DB'DB(); in front of every place that can have a # breakpoint. Instead of a subroutine call it calls &DB::sub with # $DB::sub being the called subroutine. It also inserts a BEGIN # {require 'perl5db.pl'} before the first line. # +# After each `require'd file is compiled, but before it is executed, a +# call to DB::postponed(*{"_<$filename"}) is emulated. Here the +# $filename is the expanded name of the `require'd file (as found as +# value of %INC). +# +# Additional services from Perl interpreter: +# +# if caller() is called from the package DB, it provides some +# additional data. +# +# The array @{"_<$filename"} is the line-by-line contents of +# $filename. +# +# The hash %{"_<$filename"} contains breakpoints and action (it is +# keyed by line number), and individual entries are settable (as +# opposed to the whole hash). Only true/false is important to the +# interpreter, though the values used by perl5db.pl have the form +# "$break_condition\0$action". Values are magical in numeric context. +# +# The scalar ${"_<$filename"} contains "_<$filename". +# # Note that no subroutine call is possible until &DB::sub is defined -# (for subroutines defined outside this file). In fact the same is +# (for subroutines defined outside of the package DB). In fact the same is # true if $deep is not defined. # # $Log: perldb.pl,v $ @@ -64,8 +85,6 @@ $header = "perl5db.pl patch level $VERSION"; # information into db.out. (If you interrupt it, you would better # reset LineInfo to something "interactive"!) # -# Changes: 0.95: v command shows versions. - ################################################################## # Changelog: @@ -82,6 +101,43 @@ $header = "perl5db.pl patch level $VERSION"; # the deletion of data may be postponed until the next function call, # due to the need to examine the return value. +# Changes: 0.95: `v' command shows versions. +# Changes: 0.96: `v' command shows version of readline. +# primitive completion works (dynamic variables, subs for `b' and `l', +# options). Can `p %var' +# Better help (`h <' now works). New commands <<, >>, {, {{. +# {dump|print}_trace() coded (to be able to do it from <<cmd). +# `c sub' documented. +# At last enough magic combined to stop after the end of debuggee. +# !! should work now (thanks to Emacs bracket matching an extra +# `]' in a regexp is caught). +# `L', `D' and `A' span files now (as documented). +# Breakpoints in `require'd code are possible (used in `R'). +# Some additional words on internal work of debugger. +# `b load filename' implemented. +# `b postpone subr' implemented. +# now only `q' exits debugger (overwriteable on $inhibit_exit). +# When restarting debugger breakpoints/actions persist. +# Buglet: When restarting debugger only one breakpoint/action per +# autoloaded function persists. +# Changes: 0.97: NonStop will not stop in at_exit(). +# Option AutoTrace implemented. +# Trace printed differently if frames are printed too. +# new `inhibitExit' option. +# printing of a very long statement interruptible. +# Changes: 0.98: New command `m' for printing possible methods +# 'l -' is a synonim for `-'. +# Cosmetic bugs in printing stack trace. +# `frame' & 8 to print "expanded args" in stack trace. +# Can list/break in imported subs. +# new `maxTraceLen' option. +# frame & 4 and frame & 8 granted. +# new command `m' +# nonstoppable lines do not have `:' near the line number. +# `b compile subname' implemented. +# Will not use $` any more. +# `-' behaves sane now. + #################################################################### # Needed for the statement after exec(): @@ -101,7 +157,7 @@ warn ( # Do not ;-) @ARGS, $Carp::CarpLevel, $panic, - $first_time, + $second_time, ) if 0; # Command-line + PERLLIB: @@ -111,18 +167,14 @@ warn ( # Do not ;-) $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). -$doret = -2; -$frame = 0; -@stack = (0); - -$option{PrintRet} = 1; +$inhibit_exit = $option{PrintRet} = 1; @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages compactDump veryCompact quote HighBit undefPrint - globPrint PrintRet UsageOnly frame - TTY noTTY ReadLine NonStop LineInfo + globPrint PrintRet UsageOnly frame AutoTrace + TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning - signalLevel warnLevel dieLevel); + signalLevel warnLevel dieLevel inhibit_exit); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -134,7 +186,10 @@ $option{PrintRet} = 1; globPrint => \$dumpvar::globPrint, tkRunning => \$readline::Tk_toloop, UsageOnly => \$dumpvar::usageOnly, - frame => \$frame, + frame => \$frame, + AutoTrace => \$trace, + inhibit_exit => \$inhibit_exit, + maxTraceLen => \$maxtrace, ); %optionAction = ( @@ -165,12 +220,16 @@ $rl = 1 unless defined $rl; $warnLevel = 1 unless defined $warnLevel; $dieLevel = 1 unless defined $dieLevel; $signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; +$maxtrace = 400 unless defined $maxtrace; if (-e "/dev/tty") { $rcfile=".perldb"; @@ -194,9 +253,11 @@ if (exists $ENV{PERLDB_RESTART}) { delete $ENV{PERLDB_RESTART}; # $restart = 1; @hist = get_list('PERLDB_HIST'); - my @visited = get_list("PERLDB_VISITED"); - for (0 .. $#visited) { - %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_"); + %break_on_load = get_list("PERLDB_ON_LOAD"); + %postponed = get_list("PERLDB_POSTPONE"); + my @had_breakpoints= get_list("PERLDB_VISITED"); + for (0 .. $#had_breakpoints) { + %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_"); } my %opt = get_list("PERLDB_OPT"); my ($opt,$val); @@ -277,30 +338,23 @@ if (defined &afterinit) { # May be defined in $rcfile ############################################################ Subroutines sub DB { - unless ($first_time++) { # Do when-running init - if ($runnonstop) { # Disable until signal + # _After_ the perl program is compiled, $single is set to 1: + if ($single and not $second_time++) { + if ($runnonstop) { # Disable until signal for ($i=0; $i <= $#stack; ) { $stack[$i++] &= ~1; } $single = 0; - return; + # return; # Would not print trace! } - # Define a subroutine in which we will stop -# eval <<'EOE'; -# sub at_end::db {"Debuggee terminating";} -# END { -# $DB::step = 1; -# print $OUT "Debuggee terminating.\n"; -# &at_end::db;} -# EOE } + $runnonstop = 0 if $single or $signal; # Disable it if interactive. &save; ($package, $filename, $line) = caller; $filename_ini = $filename; $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas - local(*dbline) = "::_<$filename"; - install_breakpoints($filename) unless $visited{$filename}++; + local(*dbline) = $main::{'_<' . $filename}; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { @@ -310,7 +364,9 @@ sub DB { $dbline{$line} =~ s/;9($|\0)/$1/; } } - if ($single || $trace || $signal) { + my $was_signal = $signal; + $signal = 0; + if ($single || $trace || $was_signal) { $term || &setterm; if ($emacs) { $position = "\032\032$filename:$line:0\n"; @@ -322,43 +378,52 @@ sub DB { $after = ($dbline[$line] =~ /\n$/ ? '' : "\n"); if (length($prefix) > 30) { $position = "$prefix$line):\n$line:\t$dbline[$line]$after"; - print $LINEINFO $position; $prefix = ""; $infix = ":\t"; } else { $infix = "):\t"; $position = "$prefix$line$infix$dbline[$line]$after"; + } + if ($frame) { + print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + } else { print $LINEINFO $position; } for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi last if $dbline[$i] =~ /^\s*[\;\}\#\n]/; + last if $signal; $after = ($dbline[$i] =~ /\n$/ ? '' : "\n"); $incr_pos = "$prefix$i$infix$dbline[$i]$after"; - print $LINEINFO $incr_pos; $position .= $incr_pos; + if ($frame) { + print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + } else { + print $LINEINFO $incr_pos; + } } } } $evalarg = $action, &eval if $action; - if ($single || $signal) { + if ($single || $was_signal) { local $level = $level + 1; - $evalarg = $pre, &eval if $pre; + map {$evalarg = $_, &eval} @$pre; print $OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; + $incr = -1; # for backward motion. + @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { - #{ # <-- Do we know what this brace is for? $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { $cmd .= &readline(" cont: "); redo CMD; }; - $cmd =~ /^q$/ && exit 0; + $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { @@ -372,8 +437,10 @@ sub DB { next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) { + if ($help =~ /^$asked/m) { + while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { print $OUT $1; + } } else { print $OUT "`$asked' is not a debugger command.\n"; } @@ -410,7 +477,11 @@ sub DB { select ($savout); next CMD; }; $cmd =~ s/^x\b/ / && do { # So that will be evaled - $onetimeDump = 1; }; + $onetimeDump = 'dump'; }; + $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { + methods($1); next CMD}; + $cmd =~ s/^m\b/ / && do { # So this will be evaled + $onetimeDump = 'methods'; }; $cmd =~ /^f\b\s*(.*)/ && do { $file = $1; if (!$file) { @@ -425,27 +496,26 @@ sub DB { }} } if (!defined $main::{'_<' . $file}) { - print $OUT "There's no code here matching $file.\n"; + print $OUT "No file matching `$file' is loaded.\n"; next CMD; } elsif ($file ne $filename) { - *dbline = "::_<$file"; - $visited{$file}++; + *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; $start = 1; $cmd = "l"; } }; + $cmd =~ s/^l\s+-\s*$/-/; $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do { $subname = $1; $subname =~ s/\'/::/; $subname = "main::".$subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; - @pieces = split(/:/,$sub{$subname}); + @pieces = split(/:/,find_sub($subname)); $subrange = pop @pieces; $file = join(':', @pieces); if ($file ne $filename) { - *dbline = "::_<$file"; - $visited{$file}++; + *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; } @@ -459,9 +529,10 @@ sub DB { next CMD; } }; $cmd =~ /^\.$/ && do { + $incr = -1; # for backward motion. $start = $line; $filename = $filename_ini; - *dbline = "::_<$filename"; + *dbline = $main::{'_<' . $filename}; $max = $#dbline; print $LINEINFO $position; next CMD }; @@ -472,8 +543,10 @@ sub DB { #print $OUT 'l ' . $start . '-' . ($start + $incr); $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { + $start -= $incr + $window + 1; + $start = 1 if $start <= 0; $incr = $window - 1; - $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd = 'l ' . ($start) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; @@ -488,6 +561,7 @@ sub DB { $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; + $incr = $end - $i; if ($emacs) { print $OUT "\032\032$filename:$i:0\n"; $i = $end; @@ -497,7 +571,7 @@ sub DB { $arrow = ($i==$line and $filename eq $filename_ini) ? '==>' - : ':' ; + : ($dbline[$i]+0 ? ':' : ' ') ; $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; @@ -508,7 +582,13 @@ sub DB { $start = $max if $start > $max; next CMD; }; $cmd =~ /^D$/ && do { - print $OUT "Deleting all breakpoints...\n"; + print $OUT "Deleting all breakpoints...\n"; + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; @@ -517,19 +597,90 @@ sub DB { } } } - next CMD; }; + } + undef %postponed; + undef %postponed_file; + undef %break_on_load; + undef %had_breakpoints; + next CMD; }; $cmd =~ /^L$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { - print $OUT "$i:\t", $dbline[$i]; + print "$file:\n" unless $was++; + print $OUT " $i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); - print $OUT " break if (", $stop, ")\n" + print $OUT " break if (", $stop, ")\n" if $stop; - print $OUT " action: ", $action, "\n" + print $OUT " action: ", $action, "\n" if $action; last if $signal; } } + } + if (%postponed) { + print $OUT "Postponed breakpoints in subroutines:\n"; + my $subname; + for $subname (keys %postponed) { + print $OUT " $subname\t$postponed{$subname}\n"; + last if $signal; + } + } + my @have = map { # Combined keys + keys %{$postponed_file{$_}} + } keys %postponed_file; + if (@have) { + print $OUT "Postponed breakpoints in files:\n"; + my ($file, $line); + for $file (keys %postponed_file) { + my %db = %{$postponed_file{$file}}; + next unless keys %db; + print $OUT " $file:\n"; + for $line (sort {$a <=> $b} keys %db) { + print $OUT " $i:\n"; + my ($stop,$action) = split(/\0/, $db{$line}); + print $OUT " break if (", $stop, ")\n" + if $stop; + print $OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + last if $signal; + } + } + if (%break_on_load) { + print $OUT "Breakpoints on load:\n"; + my $file; + for $file (keys %break_on_load) { + print $OUT " $file\n"; + last if $signal; + } + } + next CMD; }; + $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { + my $file = $1; + { + $break_on_load{$file} = 1; + $break_on_load{$::INC{$file}} = 1 if $::INC{$file}; + $file .= '.pm', redo unless $file =~ /\./; + } + $had_breakpoints{$file} = 1; + print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; + next CMD; }; + $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + my $cond = $3 || '1'; + my ($subname, $break) = ($2, $1 eq 'postpone'); + $subname =~ s/\'/::/; + $subname = "${'package'}::" . $subname + unless $subname =~ /::/; + $subname = "main".$subname if substr($subname,0,2) eq "::"; + $postponed{$subname} = $break + ? "break +0 if $cond" : "compile"; next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; @@ -539,12 +690,12 @@ sub DB { unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; # Filename below can contain ':' - ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/); + ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; - *dbline = "::_<$filename"; - $visited{$filename}++; + *dbline = $main::{'_<' . $filename}; + $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; $dbline{$i} =~ s/^[^\0]*/$cond/; @@ -558,6 +709,7 @@ sub DB { if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { + $had_breakpoints{$filename} = 1; $dbline{$i} =~ s/^[^\0]*/$cond/; } next CMD; }; @@ -567,13 +719,20 @@ sub DB { delete $dbline{$i} if $dbline{$i} eq ''; next CMD; }; $cmd =~ /^A$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } - next CMD; }; + } + next CMD; }; $cmd =~ /^O\s*$/ && do { for (@options) { &dump_option($_); @@ -582,11 +741,26 @@ sub DB { $cmd =~ /^O\s*(\S.*)/ && do { parse_options($1); next CMD; }; + $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE + push @$pre, action($1); + next CMD; }; + $cmd =~ /^>>\s*(.*)/ && do { + push @$post, action($1); + next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = action($1); + $pre = [], next CMD unless $1; + $pre = [action($1)]; next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = action($1); + $post = [], next CMD unless $1; + $post = [action($1)]; + next CMD; }; + $cmd =~ /^\{\{\s*(.*)/ && do { + push @$pretype, $1; + next CMD; }; + $cmd =~ /^\{\s*(.*)/ && do { + $pretype = [], next CMD unless $1; + $pretype = [$1]; next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; $j = $3; @@ -598,22 +772,25 @@ sub DB { } next CMD; }; $cmd =~ /^n$/ && do { + end_report(), next CMD if $finished and $level <= 1; $single = 2; $laststep = $cmd; last CMD; }; $cmd =~ /^s$/ && do { + end_report(), next CMD if $finished and $level <= 1; $single = 1; $laststep = $cmd; last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { + end_report(), next CMD if $finished and $level <= 1; $i = $1; if ($i =~ /\D/) { # subroutine name - ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/); + ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; - *dbline = "::_<$filename"; - $visited{$filename}++; + *dbline = $main::{'_<' . $filename}; + $had_breakpoints{$filename}++; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } else { @@ -633,11 +810,12 @@ sub DB { } last CMD; }; $cmd =~ /^r$/ && do { + end_report(), next CMD if $finished and $level <= 1; $stack[$#stack] |= 1; $doret = $option{PrintRet} ? $#stack - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { - print $OUT "Warning: a lot of settings and command-line options may be lost!\n"; + print $OUT "Warning: some settings and command-line options may be lost!\n"; my (@script, @flags, $cl); push @flags, '-w' if $ini_warn; # Put all the old includes at the start to get @@ -658,52 +836,63 @@ sub DB { set_list("PERLDB_HIST", $term->Features->{getHistory} ? $term->GetHistory : @hist); - my @visited = keys %visited; - set_list("PERLDB_VISITED", @visited); + my @had_breakpoints = keys %had_breakpoints; + set_list("PERLDB_VISITED", @had_breakpoints); set_list("PERLDB_OPT", %option); - for (0 .. $#visited) { - *dbline = "::_<$visited[$_]"; - set_list("PERLDB_FILE_$_", %dbline); + set_list("PERLDB_ON_LOAD", %break_on_load); + my @hard; + for (0 .. $#had_breakpoints) { + my $file = $had_breakpoints[$_]; + *dbline = $main::{'_<' . $file}; + next unless %dbline or %{$postponed_file{$file}}; + (push @hard, $file), next + if $file =~ /^\(eval \d+\)$/; + my @add; + @add = %{$postponed_file{$file}} + if %{$postponed_file{$file}}; + set_list("PERLDB_FILE_$_", %dbline, @add); } + for (@hard) { # Yes, really-really... + # Find the subroutines in this eval + *dbline = $main::{'_<' . $_}; + my ($quoted, $sub, %subs, $line) = quotemeta $_; + for $sub (keys %sub) { + next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; + $subs{$sub} = [$1, $2]; + } + unless (%subs) { + print $OUT + "No subroutines in $_, ignoring breakpoints.\n"; + next; + } + LINES: for $line (keys %dbline) { + # One breakpoint per sub only: + my ($offset, $sub, $found); + SUBS: for $sub (keys %subs) { + if ($subs{$sub}->[1] >= $line # Not after the subroutine + and (not defined $offset # Not caught + or $offset < 0 )) { # or badly caught + $found = $sub; + $offset = $line - $subs{$sub}->[0]; + $offset = "+$offset", last SUBS if $offset >= 0; + } + } + if (defined $offset) { + $postponed{$found} = + "break $offset if $dbline{$line}"; + } else { + print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; + } + } + } + set_list("PERLDB_POSTPONE", %postponed); $ENV{PERLDB_RESTART} = 1; #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS"; exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub); - for ($i = 1; - ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); - $i++) { - @a = (); - for $arg (@args) { - $_ = "$arg"; - s/([\'\\])/\\$1/g; - s/([^\0]*)/'$1'/ - unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - push(@a, $_); - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - $e =~ s/\n\s*\;\s*\Z// if $e; - $e =~ s/[\\\']/\\$1/g if $e; - if ($r) { - $s = "require '$e'"; - } elsif (defined $r) { - $s = "eval '$e'"; - } elsif ($s eq '(eval)') { - $s = "eval {...}"; - } - $f = "file `$f'" unless $f eq '-e'; - push(@sub, "$w$s$a called from $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $OUT $sub[$i]; - } + print_trace($OUT, 1); # skip DB next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; @@ -717,6 +906,7 @@ sub DB { $pat = $inpat; } $end = $start; + $incr = -1; eval ' for (;;) { ++$start; @@ -745,6 +935,7 @@ sub DB { $pat = $inpat; } $end = $start; + $incr = -1; eval ' for (;;) { --$start; @@ -767,7 +958,7 @@ sub DB { $cmd = $hist[$i] . "\n"; print $OUT $cmd; redo CMD; }; - $cmd =~ /^$sh$sh\s*([\x00-\xff]]*)/ && do { + $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); next CMD; }; $cmd =~ /^$rc([^$rc].*)$/ && do { @@ -844,7 +1035,6 @@ sub DB { $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: - #} # <-- Do we know what this brace is for? $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; @@ -872,9 +1062,8 @@ sub DB { $piped= ""; } } # CMD: - if ($post) { - $evalarg = $post; &eval; - } + $exiting = 1 unless defined $cmd; + map {$evalarg = $_; &eval} @$post; } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; (); @@ -885,26 +1074,36 @@ sub DB { sub sub { my ($al, $ret, @ret) = ""; - if ($sub =~ /::AUTOLOAD$/) { - $al = " for $ {$` . '::AUTOLOAD'}"; + if ($sub =~ /(.*)::AUTOLOAD$/) { + $al = " for $ {$1 . '::AUTOLOAD'}"; } - print $LINEINFO ' ' x $#stack, "entering $sub$al\n" if $frame; push(@stack, $single); $single &= 1; $single |= 4 if $#stack == $deep; + ($frame & 4 + ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + # Why -1? But it works! :-( + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; $single |= pop(@stack); print ($OUT "list context return from $sub:\n"), dumpit( \@ret ), $doret = -2 if $doret eq $#stack; - print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1; + ($frame & 4 + ? ( (print $LINEINFO ' ' x $#stack, "out "), + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; @ret; } else { $ret = &$sub; $single |= pop(@stack); print ($OUT "scalar context return from $sub: "), dumpit( $ret ), $doret = -2 if $doret eq $#stack; - print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1; + ($frame & 4 + ? ( (print $LINEINFO ' ' x $#stack, "out "), + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; $ret; } } @@ -929,24 +1128,58 @@ sub eval { $^D = $od; } my $at = $@; + local $saved[0]; # Preserve the old value of $@ eval "&DB::save"; if ($at) { print $OUT $at; - } elsif ($onetimeDump) { + } elsif ($onetimeDump eq 'dump') { dumpit(\@res); + } elsif ($onetimeDump eq 'methods') { + methods($res[0]); + } +} + +sub postponed_sub { + my $subname = shift; + if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { + my $offset = $1 || 0; + # Filename below can contain ':' + my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); + $i += $offset; + if ($i) { + local *dbline = $main::{'_<' . $file}; + local $^W = 0; # != 0 is magical below + $had_breakpoints{$file}++; + my $max = $#dbline; + ++$i until $dbline[$i] != 0 or $i >= $max; + $dbline{$i} = delete $postponed{$subname}; + } else { + print $OUT "Subroutine $subname not found.\n"; } + return; + } + elsif ($postponed{$subname} eq 'compile') { $signal = 1 } + #print $OUT "In postponed_sub for `$subname'.\n"; } -sub install_breakpoints { - my $filename = shift; - return unless exists $postponed{$filename}; - my %break = %{$postponed{$filename}}; - for (keys %break) { - my $i = $_; - #if (/\D/) { # Subroutine name - #} - $dbline{$i} = $break{$_}; # Cannot be done before the file is around +sub postponed { + return &postponed_sub + unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. + # Cannot be done before the file is compiled + local *dbline = shift; + my $filename = $dbline; + $filename =~ s/^_<//; + $signal = 1, print $OUT "'$filename' loaded...\n" + if $break_on_load{$filename}; + print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame; + return unless %{$postponed_file{$filename}}; + $had_breakpoints{$filename}++; + #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic + my $key; + for $key (keys %{$postponed_file{$filename}}) { + $dbline{$key} = $ {$postponed_file{$filename}}{$key}; } + undef %{$postponed_file{$filename}}; } sub dumpit { @@ -969,6 +1202,87 @@ sub dumpit { select ($savout); } +# Tied method do not create a context, so may get wrong message: + +sub print_trace { + my $fh = shift; + my @sub = dump_trace($_[0] + 1, $_[1]); + my $short = $_[2]; # Print short report, next one for sub name + my $s; + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + local $" = ', '; + my $args = defined $sub[$i]{args} + ? "(@{ $sub[$i]{args} })" + : '' ; + $args = (substr $args, 0, $maxtrace - 3) . '...' + if length $args > $maxtrace; + my $file = $sub[$i]{file}; + $file = $file eq '-e' ? $file : "file `$file'" unless $short; + $s = $sub[$i]{sub}; + $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace; + if ($short) { + my $sub = @_ >= 4 ? $_[3] : $s; + print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; + } else { + print $fh "$sub[$i]{context} = $s$args" . + " called from $file" . + " line $sub[$i]{line}\n"; + } + } +} + +sub dump_trace { + my $skip = shift; + my $count = shift || 1e9; + $skip++; + $count += $skip; + my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context); + my $nothard = not $frame & 8; + local $frame = 0; # Do not want to trace this. + my $otrace = $trace; + $trace = 0; + for ($i = $skip; + $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); + $i++) { + @a = (); + for $arg (@args) { + my $type; + if (not defined $arg) { + push @a, "undef"; + } elsif ($nothard and tied $arg) { + push @a, "tied"; + } elsif ($nothard and $type = ref $arg) { + push @a, "ref($type)"; + } else { + local $_ = "$arg"; # Safe to stringify now - should not call f(). + s/([\'\\])/\\$1/g; + s/(.*)/'$1'/s + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + } + $context = $context ? '@' : "\$"; + $args = $h ? [@a] : undef; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/([\\\'])/\\$1/g if $e; + if ($r) { + $sub = "require '$e'"; + } elsif (defined $r) { + $sub = "eval '$e'"; + } elsif ($sub eq '(eval)') { + $sub = "eval {...}"; + } + push(@sub, {context => $context, sub => $sub, args => $args, + file => $file, line => $line}); + last if $signal; + } + $trace = $otrace; + @sub; +} + sub action { my $action = shift; while ($action =~ s/\\$//) { @@ -1032,6 +1346,12 @@ sub setterm { $readline::rl_basic_word_break_characters .= "[:" if defined $readline::rl_basic_word_break_characters and index($readline::rl_basic_word_break_characters, ":") == -1; + $readline::rl_special_prefixes = + $readline::rl_special_prefixes = '$@&%'; + $readline::rl_completer_word_break_characters = + $readline::rl_completer_word_break_characters . '$@&%'; + $readline::rl_completion_function = + $readline::rl_completion_function = \&db_complete; } $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; @@ -1057,6 +1377,14 @@ sub readline { sub dump_option { my ($opt, $val)= @_; + $val = option_val($opt,'N/A'); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} + +sub option_val { + my ($opt, $default)= @_; + my $val; if (defined $optionVars{$opt} and defined $ {$optionVars{$opt}}) { $val = $ {$optionVars{$opt}}; @@ -1067,12 +1395,11 @@ sub dump_option { and not defined $option{$opt} or defined $optionVars{$opt} and not defined $ {$optionVars{$opt}}) { - $val = 'N/A'; + $val = $default; } else { $val = $option{$opt}; } - $val =~ s/([\\\'])/\\$1/g; - printf $OUT "%20s = '%s'\n", $opt, $val; + $val } sub parse_options { @@ -1147,6 +1474,7 @@ sub get_list { sub catch { $signal = 1; + return; # Put nothing on the stack - malloc/free land! } sub warn { @@ -1244,6 +1572,7 @@ sub list_versions { s,\.p[lm]$,,i ; s,/,::,g ; s/^perl5db$/DB/; + s/^Term::ReadLine::readline$/readline/; if (defined $ { $_ . '::VERSION' }) { $version{$file} = "$ { $_ . '::VERSION' } from "; } @@ -1265,8 +1594,8 @@ s [expr] Single step [in expr]. n [expr] Next, steps over subroutine calls [in expr]. <CR> Repeat last n or s command. r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. +c [line|sub] Continue; optionally inserts a one-time-only breakpoint + at the specified position. l min+incr List incr+1 lines starting at min. l min-max List lines min through max. l line List single line. @@ -1275,10 +1604,10 @@ l List next window of lines. - List previous window of lines. w [line] List window around line. . Return to the executed line. -f filename Switch to viewing filename. +f filename Switch to viewing filename. Must be loaded. /pattern/ Search forwards for pattern; final / is optional. ?pattern? Search backwards for pattern; final ? is optional. -L List all breakpoints and actions for the current file. +L List all breakpoints and actions. S [[!]pattern] List subroutine names [not] matching pattern. t Toggle trace mode. t expr Trace through execution of expr. @@ -1287,6 +1616,12 @@ b [line] [condition] condition breaks if it evaluates to true, defaults to '1'. b subname [condition] Set breakpoint at first line of subroutine. +b load filename Set breakpoint on `require'ing the given file. +b postpone subname [condition] + Set breakpoint at first line of subroutine after + it is compiled. +b compile subname + Stop after the subroutine is compiled. d [line] Delete the breakpoint for line. D Delete all breakpoints. a [line] command @@ -1298,11 +1633,17 @@ V [pkg [vars]] List some (default all) variables in package (default current). Use ~pattern and !pattern for positive and negative regexps. X [vars] Same as \"V currentpackage [vars]\". x expr Evals expression in array context, dumps the result. +m expr Evals expression in array context, prints methods callable + on the first element of the result. +m class Prints methods callable via the given class. O [opt[=val]] [opt\"val\"] [opt?]... Set or query values of options. val defaults to 1. opt can be abbreviated. Several options can be listed. recallCommand, ShellBang: chars used to recall command or spawn shell; pager: program for output of \"|cmd\"; + tkRunning: run Tk while prompting (with ReadLine); + signalLevel warnLevel dieLevel: level of verbosity; + inhibit_exit Allows stepping off the end of the script. The following options affect what happens with V, X, and x commands: arrayDepth, hashDepth: print only first N elements ('' for all); compactDump, veryCompact: change style of array and hash dump; @@ -1310,15 +1651,19 @@ O [opt[=val]] [opt\"val\"] [opt?]... DumpDBFiles: dump arrays holding debugged files; DumpPackages: dump symbol tables of packages; quote, HighBit, undefPrint: change style of string dump; - tkRunning: run Tk while prompting (with ReadLine); - signalLevel warnLevel dieLevel: level of verbosity; Option PrintRet affects printing of return value after r command, frame affects printing messages on entry and exit from subroutines. + AutoTrace affects printing messages on every possible breaking point. + maxTraceLen gives maximal length of evals/args listed in stack trace. During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options TTY, noTTY, ReadLine, and NonStop there. -< command Define command to run before each prompt. -> command Define command to run after each prompt. +< command Define Perl command to run before each prompt. +<< command Add to the list of Perl commands to run before each prompt. +> command Define Perl command to run after each prompt. +>> command Add to the list of Perl commands to run after each prompt. +\{ commandline Define debugger command to run before each prompt. +\{{ commandline Add to the list of debugger commands to run before each prompt. $prc number Redo a previous command (default previous command). $prc -number Redo number'th-to-last command. $prc pattern Redo last command that started with pattern. @@ -1334,11 +1679,14 @@ p expr Same as \"print {DB::OUT} expr\" in current package. \= [alias value] Define a command alias, or list current aliases. command Execute as a perl statement in current package. v Show versions of loaded modules. -R Pure-man-restart of debugger, debugger state and command-line - options are lost. +R Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following setting are preserved: + history, breakpoints and actions, debugger Options + and the following command-line options: -w, -I, -e. h [db_command] Get help [on a specific debugger command], enter |h to page. h h Summary of debugger commands. -q or ^D Quit. +q or ^D Quit. Set \$DB::finished to 0 to debug global destruction. "; $summary = <<"END_SUM"; @@ -1348,11 +1696,11 @@ List/search source lines: Control script execution: w [line] List around line n [expr] Next, steps over subs f filename View source in file <CR> Repeat last n or s /pattern/ ?patt? Search forw/backw r Return from subroutine - v Show versions of modules c [line] Continue until line + v Show versions of modules c [ln|sub] Continue until position Debugger controls: L List break pts & actions O [...] Set debugger options t [expr] Toggle trace [trace expr] - < command Command for before prompt b [ln] [c] Set breakpoint - > command Command for after prompt b sub [c] Set breakpoint for sub + <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint + >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub $prc [N|pat] Redo a previous command d [line] Delete a breakpoint H [-num] Display last num commands D Delete all breakpoints = [a val] Define/list an alias a [ln] cmd Do cmd before line @@ -1360,13 +1708,13 @@ Debugger controls: L List break pts & actions |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess q or ^D Quit R Attempt a restart Data Examination: expr Execute perl code, also see: s,n,t expr + x|m expr Evals expr in array context, dumps the result or lists methods. + p expr Print expression (uses script's current package). S [[!]pat] List subroutine names [not] matching pattern V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. X [Vars] Same as \"V current_package [Vars]\". - x expr Evals expression in array context, dumps the result. - p expr Print expression (uses script's current package). END_SUM - # '); # Fix balance of Emacs parsing + # ')}}; # Fix balance of Emacs parsing } sub diesignal { @@ -1479,6 +1827,46 @@ sub signalLevel { $signalLevel; } +sub find_sub { + my $subr = shift; + return unless defined &$subr; + $sub{$subr} or do { + $subr = \&$subr; # Hard reference + my $s; + for (keys %sub) { + $s = $_, last if $subr eq \&$_; + } + $sub{$s} if $s; + } +} + +sub methods { + my $class = shift; + $class = ref $class if ref $class; + local %seen; + local %packs; + methods_via($class, '', 1); + methods_via('UNIVERSAL', 'UNIVERSAL', 0); +} + +sub methods_via { + my $class = shift; + return if $packs{$class}++; + my $prefix = shift; + my $prepend = $prefix ? "via $prefix: " : ''; + my $name; + for $name (grep {defined &{$ {"$ {class}::"}{$_}}} + sort keys %{"$ {class}::"}) { + next if $seen{ \&{$ {"$ {class}::"}{$name}} }++; + print $DB::OUT "$prepend$name\n"; + } + return unless shift; # Recurse? + for $name (@{"$ {class}::ISA"}) { + $prepend = $prefix ? $prefix . " -> $name" : $name; + methods_via($name, $prepend, 1); + } +} + # The following BEGIN is very handy if debugger goes havoc, debugging debugger? BEGIN { # This does not compile, alas. @@ -1500,10 +1888,91 @@ BEGIN { # This does not compile, alas. $db_stop = 0; # Compiler warning $db_stop = 1 << 30; $level = 0; # Level of recursive debugging + # @stack and $doret are needed in sub sub, which is called for DB::postponed. + # Triggers bug (?) in perl is we postpone this until runtime: + @postponed = @stack = (0); + $doret = -2; + $frame = 0; } BEGIN {$^W = $ini_warn;} # Switch warnings back #use Carp; # This did break, left for debuggin +sub db_complete { + my($text, $line, $start) = @_; + my ($itext, $prefix, $pack) = $text; + + if ((substr $text, 0, 1) eq '&') { # subroutines + $text = substr $text, 1; + $prefix = "&"; + return map "$prefix$_", grep /^\Q$text/, keys %sub; + } + if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package + $pack = ($1 eq 'main' ? '' : $1) . '::'; + $prefix = (substr $text, 0, 1) . $1 . '::'; + $text = $2; + my @out + = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) + $pack = ($package eq 'main' ? '' : $package) . '::'; + $prefix = substr $text, 0, 1; + $text = substr $text, 1; + my @out = map "$prefix$_", grep /^\Q$text/, + (grep /^_?[a-zA-Z]/, keys %$pack), + ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + return grep /^\Q$text/, (keys %sub), qw(postpone load compile) # subroutines + if (substr $line, 0, $start) =~ /^[bl]\s+((postpone|compile)\s+)?$/; + return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages + if (substr $line, 0, $start) =~ /^V\s+$/; + if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space + my @out = grep /^\Q$text/, @options; + my $val = option_val($out[0], undef); + my $out = '? '; + if (not defined $val or $val =~ /[\n\r]/) { + # Can do nothing better + } elsif ($val =~ /\s/) { + my $found; + foreach $l (split //, qq/\"\'\#\|/) { + $out = "$l$val$l ", last if (index $val, $l) == -1; + } + } else { + $out = "=$val "; + } + # Default to value if one completion, to question if many + $readline::rl_completer_terminator_character + = $readline::rl_completer_terminator_character + = (@out == 1 ? $out : '? '); + return @out; + } + return &readline::rl_filename_list($text); # filenames +} + +sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" } + +END { + $finished = $inhibit_exit; # So that some keys may be disabled. + # Do not stop in at_exit() and destructors on exit: + $DB::single = !$exiting && !$runnonstop; + DB::fake::at_exit() unless $exiting or $runnonstop; +} + +package DB::fake; + +sub at_exit { + "Debuggee terminated. Use `q' to quit and `R' to restart."; +} + +package DB; # Do not trace this 1; below! + 1; diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm index 378ca899a0..c081123b6b 100644 --- a/lib/sigtrap.pm +++ b/lib/sigtrap.pm @@ -8,7 +8,7 @@ sigtrap - Perl pragma to enable simple signal handling use Carp; -$VERSION = 1.01; +$VERSION = 1.02; $Verbose ||= 0; sub import { @@ -29,13 +29,16 @@ sub import { } } elsif ($_ eq 'normal-signals') { - unshift @_, qw(HUP INT PIPE TERM); + unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); } elsif ($_ eq 'error-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP); + unshift @_, grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); } elsif ($_ eq 'old-interface-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP); + unshift @_, + grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); } elsif ($_ eq 'stack-trace') { $handler = \&handler_traceback; @@ -164,9 +167,9 @@ installed signals. =item B<stack-trace> -The handler used for subsequently installed signals will output a Perl -stack trace to STDERR and then tries to dump core. This is the default -signal handler. +The handler used for subsequently installed signals outputs a Perl stack +trace to STDERR and then tries to dump core. This is the default signal +handler. =item B<die> @@ -183,7 +186,7 @@ assignment to an element of C<%SIG>. =head2 SIGNAL LISTS -B<sigtrap> has two built-in lists of signals to trap. They are: +B<sigtrap> has a few built-in lists of signals to trap. They are: =over 4 @@ -204,17 +207,22 @@ QUIT, SEGV, SYS and TRAP. These are the signals which were trapped by default by the old B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to -B<sigtrap> this list is used. +B<sigtrap>, this list is used. =back +For each of these three lists, the collection of signals set to be +trapped is checked before trapping; if your architecture does not +implement a particular signal, it will not be trapped but rather +silently ignored. + =head2 OTHER =over 4 =item B<untrapped> -This token tells B<sigtrap> only to install handlers for subsequently +This token tells B<sigtrap> to install handlers only for subsequently listed signals which aren't already trapped or ignored. =item B<any> @@ -224,9 +232,9 @@ listed signals. This is the default behavior. =item I<signal> -Any argument which looks like a signals name (that is, -C</^[A-Z][A-Z0-9]*$/>) is taken as a signal name and indicates that -B<sigtrap> should install a handler for it. +Any argument which looks like a signal name (that is, +C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a +handler for that name. =item I<number> diff --git a/lib/splain b/lib/splain deleted file mode 100755 index a8af08f8c2..0000000000 --- a/lib/splain +++ /dev/null @@ -1,507 +0,0 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -if ($^O eq 'VMS') { - $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) . - '/pod/perldiag.pod'; -} -else { $diagnostics::PODFILE= $Config{privlibexp} . "/pod/perldiag.pod"; } - -package diagnostics; -require 5.001; -use English; -use Carp; - -=head1 NAME - -diagnostics - Perl compiler pragma to force verbose warning diagnostics - -splain - standalone program to do the same thing - -=head1 SYNOPSIS - -As a pragma: - - use diagnostics; - use diagnostics -verbose; - - enable diagnostics; - disable diagnostics; - -Aa a program: - - perl program 2>diag.out - splain [-v] [-p] diag.out - - -=head1 DESCRIPTION - -=head2 The C<diagnostics> Pragma - -This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them with the more -explicative and endearing descriptions found in L<perldiag>. Like the -other pragmata, it affects the compilation phase of your program rather -than merely the execution phase. - -To use in your program as a pragma, merely invoke - - use diagnostics; - -at the start (or near the start) of your program. (Note -that this I<does> enable perl's B<-w> flag.) Your whole -compilation will then be subject(ed :-) to the enhanced diagnostics. -These still go out B<STDERR>. - -Due to the interaction between runtime and compiletime issues, -and because it's probably not a very good idea anyway, -you may not use C<no diagnostics> to turn them off at compiletime. -However, you may control there behaviour at runtime using the -disable() and enable() methods to turn them off and on respectively. - -The B<-verbose> flag first prints out the L<perldiag> introduction before -any other diagnostics. The $diagnostics::PRETTY variable can generate nicer -escape sequences for pagers. - -=head2 The I<splain> Program - -While apparently a whole nuther program, I<splain> is actually nothing -more than a link to the (executable) F<diagnostics.pm> module, as well as -a link to the F<diagnostics.pod> documentation. The B<-v> flag is like -the C<use diagnostics -verbose> directive. -The B<-p> flag is like the -$diagnostics::PRETTY variable. Since you're post-processing with -I<splain>, there's no sense in being able to enable() or disable() processing. - -Output from I<splain> is directed to B<STDOUT>, unlike the pragma. - -=head1 EXAMPLES - -The following file is certain to trigger a few errors at both -runtime and compiletime: - - use diagnostics; - print NOWHERE "nothing\n"; - print STDERR "\n\tThis message should be unadorned.\n"; - warn "\tThis is a user warning"; - print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; - my $a, $b = scalar <STDIN>; - print "\n"; - print $x/$y; - -If you prefer to run your program first and look at its problem -afterwards, do this: - - perl -w test.pl 2>test.out - ./splain < test.out - -Note that this is not in general possible in shells of more dubious heritage, -as the theoretical - - (perl -w test.pl >/dev/tty) >& test.out - ./splain < test.out - -Because you just moved the existing B<stdout> to somewhere else. - -If you don't want to modify your source code, but still have on-the-fly -warnings, do this: - - exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- - -Nifty, eh? - -If you want to control warnings on the fly, do something like this. -Make sure you do the C<use> first, or you won't be able to get -at the enable() or disable() methods. - - use diagnostics; # checks entire compilation phase - print "\ntime for 1st bogus diags: SQUAWKINGS\n"; - print BOGUS1 'nada'; - print "done with 1st bogus\n"; - - disable diagnostics; # only turns off runtime warnings - print "\ntime for 2nd bogus: (squelched)\n"; - print BOGUS2 'nada'; - print "done with 2nd bogus\n"; - - enable diagnostics; # turns back on runtime warnings - print "\ntime for 3rd bogus: SQUAWKINGS\n"; - print BOGUS3 'nada'; - print "done with 3rd bogus\n"; - - disable diagnostics; - print "\ntime for 4th bogus: (squelched)\n"; - print BOGUS4 'nada'; - print "done with 4th bogus\n"; - -=head1 INTERNALS - -Diagnostic messages derive from the F<perldiag.pod> file when available at -runtime. Otherwise, they may be embedded in the file itself when the -splain package is built. See the F<Makefile> for details. - -If an extant $SIG{__WARN__} handler is discovered, it will continue -to be honored, but only after the diagnostics::splainthis() function -(the module's $SIG{__WARN__} interceptor) has had its way with your -warnings. - -There is a $diagnostics::DEBUG variable you may set if you're desperately -curious what sorts of things are being intercepted. - - BEGIN { $diagnostics::DEBUG = 1 } - - -=head1 BUGS - -Not being able to say "no diagnostics" is annoying, but may not be -insurmountable. - -The C<-pretty> directive is called too late to affect matters. -You have to to this instead, and I<before> you load the module. - - BEGIN { $diagnostics::PRETTY = 1 } - -I could start up faster by delaying compilation until it should be -needed, but this gets a "panic: top_level" -when using the pragma form in 5.001e. - -While it's true that this documentation is somewhat subserious, if you use -a program named I<splain>, you should expect a bit of whimsy. - -=head1 AUTHOR - -Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995. - -=cut - -$DEBUG ||= 0; -my $WHOAMI = ref bless []; # nobody's business, prolly not even mine - -$OUTPUT_AUTOFLUSH = 1; - -local $_; - -CONFIG: { - $opt_p = $opt_d = $opt_v = $opt_f = ''; - %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); - %exact_duplicate = (); - - unless (caller) { - $standalone++; - require Getopt::Std; - Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; - $PODFILE = $opt_f if $opt_f; - $DEBUG = 2 if $opt_d; - $VERBOSE = $opt_v; - $PRETTY = $opt_p; - } - - if (open(POD_DIAG, $PODFILE)) { - warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; - last CONFIG; - } - - if (caller) { - INCPATH: { - for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { - warn "Checking $file\n" if $DEBUG; - if (open(POD_DIAG, $file)) { - while (<POD_DIAG>) { - next unless /^__END__\s*# wish diag dbase were more accessible/; - print STDERR "podfile is $file\n" if $DEBUG; - last INCPATH; - } - } - } - } - } else { - print STDERR "podfile is <DATA>\n" if $DEBUG; - *POD_DIAG = *main::DATA; - } -} -if (eof(POD_DIAG)) { - die "couldn't find diagnostic data in $PODFILE @INC $0"; -} - - -%HTML_2_Troff = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "A\\*'", # capital A, acute accent - # etc - -); - -%HTML_2_Latin_1 = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1" # capital A, acute accent - - # etc -); - -%HTML_2_ASCII_7 = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "A" # capital A, acute accent - # etc -); - -*HTML_Escapes = do { - if ($standalone) { - $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; - } else { - \%HTML_2_Latin_1; - } -}; - -*THITHER = $standalone ? *STDOUT : *STDERR; - -$transmo = <<EOFUNC; -sub transmo { - local \$^W = 0; # recursive warnings we do NOT need! - study; -EOFUNC - -### sub finish_compilation { # 5.001e panic: top_level for embedded version - print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; - ### local - $RS = ''; - local $_; - while (<POD_DIAG>) { - #s/(.*)\n//; - #$header = $1; - - unescape(); - if ($PRETTY) { - sub noop { return $_[0] } # spensive for a noop - sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } - sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } - s/[BC]<(.*?)>/bold($1)/ges; - s/[LIF]<(.*?)>/italic($1)/ges; - } else { - s/[BC]<(.*?)>/$1/gs; - s/[LIF]<(.*?)>/$1/gs; - } - unless (/^=/) { - if (defined $header) { - if ( $header eq 'DESCRIPTION' && - ( /Optional warnings are enabled/ - || /Some of these messages are generic./ - ) ) - { - next; - } - s/^/ /gm; - $msg{$header} .= $_; - } - next; - } - unless ( s/=item (.*)\s*\Z//) { - - if ( s/=head1\sDESCRIPTION//) { - $msg{$header = 'DESCRIPTION'} = ''; - } - next; - } - $header = $1; - - if ($header =~ /%[sd]/) { - $rhs = $lhs = $header; - #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { - if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { - $lhs =~ s/\\%s/.*?/g; - } else { - # if i had lookbehind negations, i wouldn't have to do this \377 noise - $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; - #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; - $lhs =~ s/\377([^\377]*)$/\Q$1\E/; - $lhs =~ s/\377//g; - } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; - } else { - $transmo .= " m{^\Q$header\E} && return 1;\n"; - } - - print STDERR "Already saw $header" if $msg{$header}; - - $msg{$header} = ''; - } - - - close POD_DIAG unless *main::DATA eq *POD_DIAG; - - die "No diagnostics?" unless %msg; - - $transmo .= " return 0;\n}\n"; - print STDERR $transmo if $DEBUG; - eval $transmo; - die $@ if $@; - $RS = "\n"; -### } - -if ($standalone) { - if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while ($error = <>) { - splainthis($error) || print THITHER $error; - } - exit; -} else { - $old_w = 0; $oldwarn = ''; $olddie = ''; -} - -sub import { - shift; - $old_w = $^W; - $^W = 1; # yup, clobbered the global variable; tough, if you - # want diags, you want diags. - return if $SIG{__WARN__} eq \&warn_trap; - - for (@_) { - - /^-d(ebug)?$/ && do { - $DEBUG++; - next; - }; - - /^-v(erbose)?$/ && do { - $VERBOSE++; - next; - }; - - /^-p(retty)?$/ && do { - print STDERR "$0: I'm afraid it's too late for prettiness.\n"; - $PRETTY++; - next; - }; - - warn "Unknown flag: $_"; - } - - $oldwarn = $SIG{__WARN__}; - $olddie = $SIG{__DIE__}; - $SIG{__WARN__} = \&warn_trap; - $SIG{__DIE__} = \&death_trap; -} - -sub enable { &import } - -sub disable { - shift; - $^W = $old_w; - return unless $SIG{__WARN__} eq \&warn_trap; - $SIG{__WARN__} = $oldwarn; - $SIG{__DIE__} = $olddie; -} - -sub warn_trap { - my $warning = $_[0]; - if (caller eq $WHOAMI or !splainthis($warning)) { - print STDERR $warning; - } - &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; -}; - -sub death_trap { - my $exception = $_[0]; - splainthis($exception); - if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } - &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; - local($Carp::CarpLevel) = 1; - confess "Uncaught exception from user code:\n\t$exception"; - # up we go; where we stop, nobody knows, but i think we die now - # but i'm deeply afraid of the &$olddie guy reraising and us getting - # into an indirect recursion loop -}; - -sub splainthis { - local $_ = shift; - ### &finish_compilation unless %msg; - s/\.?\n+$//; - my $orig = $_; - # return unless defined; - if ($exact_duplicate{$_}++) { - return 1; - } - s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; - s/^\((.*)\)$/$1/; - return 0 unless &transmo; - $orig = shorten($orig); - if ($old_diag{$_}) { - autodescribe(); - print THITHER "$orig (#$old_diag{$_})\n"; - $wantspace = 1; - } else { - autodescribe(); - $old_diag{$_} = ++$count; - print THITHER "\n" if $wantspace; - $wantspace = 0; - print THITHER "$orig (#$old_diag{$_})\n"; - if ($msg{$_}) { - print THITHER $msg{$_}; - } else { - if (0 and $standalone) { - print THITHER " **** Error #$old_diag{$_} ", - ($real ? "is" : "appears to be"), - " an unknown diagnostic message.\n\n"; - } - return 0; - } - } - return 1; -} - -sub autodescribe { - if ($VERBOSE and not $count) { - print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), - "\n$msg{DESCRIPTION}\n"; - } -} - -sub unescape { - s { - E< - ( [A-Za-z]+ ) - > - } { - do { - exists $HTML_Escapes{$1} - ? do { $HTML_Escapes{$1} } - : do { - warn "Unknown escape: $& in $_"; - "E<$1>"; - } - } - }egx; -} - -sub shorten { - my $line = $_[0]; - if (length $line > 79) { - my $space_place = rindex($line, ' ', 79); - if ($space_place != -1) { - substr($line, $space_place, 1) = "\n\t"; - } - } - return $line; -} - - -# have to do this: RS isn't set until run time, but we're executing at compile time -$RS = "\n"; - -1 unless $standalone; # or it'll complain about itself -__END__ # wish diag dbase were more accessible diff --git a/lib/strict.pm b/lib/strict.pm index 4aa55eb4f3..8492e933fd 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -11,7 +11,6 @@ strict - Perl pragma to restrict unsafe constructs use strict "vars"; use strict "refs"; use strict "subs"; - use strict "untie"; use strict; no strict "vars"; @@ -20,8 +19,8 @@ strict - Perl pragma to restrict unsafe constructs If no import list is supplied, all possible restrictions are assumed. (This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are four possible things to be -strict about: "subs", "vars", "refs", and "untie". +casual programming.) Currently, there are three possible things to be +strict about: "subs", "vars", and "refs". =over 6 @@ -66,24 +65,6 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. -=item C<strict untie> - -This generates a runtime error if any references to the object returned -by C<tie> (or C<tied>) still exist when C<untie> is called. Note that -to get this strict behaviour, the C<use strict 'untie'> statement must -be in the same scope as the C<untie>. See L<perlfunc/tie>, -L<perlfunc/untie>, L<perlfunc/tied> and L<perltie>. - - use strict 'untie'; - $a = tie %a, 'SOME_PKG'; - $b = tie %b, 'SOME_PKG'; - $b = 0; - tie %c, PKG; - $c = tied %c; - untie %a ; # blows up, $a is a valid object reference. - untie %b; # ok, $b is not a reference to the object. - untie %c ; # blows up, $c is a valid object reference. - =back See L<perlmod/Pragmatic Modules>. @@ -93,23 +74,23 @@ See L<perlmod/Pragmatic Modules>. sub bits { my $bits = 0; + my $sememe; foreach $sememe (@_) { - $bits |= 0x00000002 if $sememe eq 'refs'; - $bits |= 0x00000200 if $sememe eq 'subs'; - $bits |= 0x00000400 if $sememe eq 'vars'; - $bits |= 0x00000800 if $sememe eq 'untie'; + $bits |= 0x00000002, next if $sememe eq 'refs'; + $bits |= 0x00000200, next if $sememe eq 'subs'; + $bits |= 0x00000400, next if $sememe eq 'vars'; } $bits; } sub import { shift; - $^H |= bits(@_ ? @_ : qw(refs subs vars untie)); + $^H |= bits(@_ ? @_ : qw(refs subs vars)); } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(refs subs vars untie)); + $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); } 1; diff --git a/lib/subs.pm b/lib/subs.pm index 84c913a346..aa4c7e751e 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -15,7 +15,12 @@ This will predeclare all the subroutine whose names are in the list, allowing you to use them without parentheses even before they're declared. -See L<perlmod/Pragmatic Modules> and L<strict/subs>. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + +See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. =cut require 5.000; diff --git a/lib/syslog.pl b/lib/syslog.pl index 614068e7fc..9e03399e4d 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -140,10 +140,10 @@ sub main'syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; - eval(&$name) || -1; + defined &$name ? &$name : -1; } sub connect { diff --git a/lib/termcap.pl b/lib/termcap.pl index e8f108df06..37313432fd 100644 --- a/lib/termcap.pl +++ b/lib/termcap.pl @@ -14,7 +14,7 @@ sub Tgetent { local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; - foreach $key (keys(TC)) { + foreach $key (keys %TC) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; @@ -63,6 +63,9 @@ sub Tgetent { $entry = $1; $_ = $2; s/\\E/\033/g; + s/\\(200)/pack('c',0)/eg; # NUL character + s/\\(0\d\d)/pack('c',oct($1))/eg; # octal + s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; diff --git a/lib/timelocal.pl b/lib/timelocal.pl index 75f1ac1851..ad322756e3 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -4,106 +4,15 @@ ;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); -;# These routines are quite efficient and yet are always guaranteed to agree -;# with localtime() and gmtime(). We manage this by caching the start times -;# of any months we've seen before. If we know the start time of the month, -;# we can always calculate any time within the month. The start times -;# themselves are guessed by successive approximation starting at the -;# current time, since most dates seen in practice are close to the -;# current date. Unlike algorithms that do a binary search (calling gmtime -;# once for each bit of the time value, resulting in 32 calls), this algorithm -;# calls it at most 6 times, and usually only once or twice. If you hit -;# the month cache, of course, it doesn't call it at all. +;# This file has been superseded by the Time::Local library module. +;# It is implemented as a call to that module for backwards compatibility +;# with code written for perl4; new code should use Time::Local directly. -;# timelocal is implemented using the same cache. We just assume that we're -;# translating a GMT time, and then fudge it when we're done for the timezone -;# and daylight savings arguments. The timezone is determined by examining -;# the result of localtime(0) when the package is initialized. The daylight -;# savings offset is currently assumed to be one hour. +;# The current implementation shares with the original the questionable +;# behavior of defining the timelocal() and timegm() functions in the +;# namespace of whatever package was current when the first instance of +;# C<require 'timelocal.pl';> was executed in a program. -;# Both routines return -1 if the integer limit is hit. I.e. for dates -;# after the 1st of January, 2038 on most machines. +use Time::Local; -CONFIG: { - package timelocal; - - local($[) = 0; - @epoch = localtime(0); - $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT - if ($tzmin > 0) { - $tzmin = 24 * 60 - $tzmin; # minutes west of GMT - $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line - } - - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAYS = 24 * $HR; - $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - 1; -} - -sub timegm { - package timelocal; - - local($[) = 0; - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; -} - -sub timelocal { - package timelocal; - - local($[) = 0; - $time = &main'timegm + $tzmin*$MIN; - return -1 if $cheat<0; - @test = localtime($time); - $time -= $HR if $test[2] != $_[2]; - $time; -} - -package timelocal; - -sub cheat { - $year = $_[5]; - $month = $_[4]; - die "Month out of range 0..11 in timelocal.pl\n" - if $month > 11 || $month < 0; - die "Day out of range 1..31 in timelocal.pl\n" - if $_[3] > 31 || $_[3] < 1; - die "Hour out of range 0..23 in timelocal.pl\n" - if $_[2] > 23 || $_[2] < 0; - die "Minute out of range 0..59 in timelocal.pl\n" - if $_[1] > 59 || $_[1] < 0; - die "Second out of range 0..59 in timelocal.pl\n" - if $_[0] > 59 || $_[0] < 0; - $guess = $^T; - @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; - $lastguess = ""; - while ($diff = $year - $g[5]) { - $guess += $diff * (363 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - while ($diff = $month - $g[4]) { - $guess += $diff * (27 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - @gfake = gmtime($guess-1); #still being sceptic - if ("@gfake" eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $g[3]--; - $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; - $cheat{$ym} = $guess; -} +*timelocal::cheat = \&Time::Local::cheat; diff --git a/lib/validate.pl b/lib/validate.pl index 21d0505ad4..ec4a04b543 100644 --- a/lib/validate.pl +++ b/lib/validate.pl @@ -91,11 +91,11 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print stderr $mess,"\n"; + print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print stderr "Can't do $this.\n"; + print STDERR "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; diff --git a/lib/vars.pm b/lib/vars.pm index 0dd5758297..f0a6e54988 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -14,6 +14,11 @@ This will predeclare all the variables whose names are in the list, allowing you to use them under "use strict", and disabling any typo warnings. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + Packages such as the B<AutoLoader> and B<SelfLoader> that delay loading of subroutines within packages can create problems with package lexicals defined using C<my()>. While the B<vars> pragma cannot duplicate the diff --git a/makeaperl.SH b/makeaperl.SH index d621e67f03..16b74350e0 100755 --- a/makeaperl.SH +++ b/makeaperl.SH @@ -20,8 +20,8 @@ echo "Extracting makeaperl (with variable substitutions)" rm -f makeaperl $spitshell >makeaperl <<!GROK!THIS! $startperl - eval 'exec perl -S \$0 "\$@"' - if 0; + eval 'exec $perlpath -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! $spitshell >>makeaperl <<'!NO!SUBS!' @@ -78,9 +78,14 @@ static int findbucket _((union overhead *freep, int srchlen)); #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK -#define RSLOP sizeof (u_int) +# define RSLOP sizeof (u_int) +# ifdef TWO_POT_OPTIMIZE +# define MAX_SHORT_BUCKET 12 +# else +# define MAX_SHORT_BUCKET 13 +# endif #else -#define RSLOP 0 +# define RSLOP 0 #endif #ifdef PACK_MALLOC @@ -112,8 +117,8 @@ static int findbucket _((union overhead *freep, int srchlen)); # define MAX_PACKED 6 # define MAX_2_POT_ALGO ((1<<(MAX_PACKED + 1)) - M_OVERHEAD) # define TWOK_MASK ((1<<11) - 1) -# define TWOK_MASKED(x) ((int)x & ~TWOK_MASK) -# define TWOK_SHIFT(x) ((int)x & TWOK_MASK) +# define TWOK_MASKED(x) ((u_int)(x) & ~TWOK_MASK) +# define TWOK_SHIFT(x) ((u_int)(x) & TWOK_MASK) # define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block))) # define OV_INDEX(block) (*OV_INDEXp(block)) # define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \ @@ -130,11 +135,6 @@ static u_short blk_shift[11 - 3] = {256, 128, 64, 32, # define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */ }; -# ifdef DEBUGGING_MSTATS -static u_int sbrk_slack; -static u_int start_slack; -# endif - #else /* !PACK_MALLOC */ # define OV_MAGIC(block,bucket) (block)->ov_magic @@ -145,6 +145,84 @@ static u_int start_slack; # define M_OVERHEAD (sizeof(union overhead) + RSLOP) /* + * Big allocations are often of the size 2^n bytes. To make them a + * little bit better, make blocks of size 2^n+pagesize for big n. + */ + +#ifdef TWO_POT_OPTIMIZE + +# ifndef PERL_PAGESIZE +# define PERL_PAGESIZE 4096 +# endif +# ifndef FIRST_BIG_TWO_POT +# define FIRST_BIG_TWO_POT 14 /* 16K */ +# endif +# define FIRST_BIG_BLOCK (1<<FIRST_BIG_TWO_POT) /* 16K */ +/* If this value or more, check against bigger blocks. */ +# define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD) +/* If less than this value, goes into 2^n-overhead-block. */ +# define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD) + +#endif /* TWO_POT_OPTIMIZE */ + +#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE) + +#ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ +#endif + +static char *emergency_buffer; +static MEM_SIZE emergency_buffer_size; + +static char * +emergency_sbrk(size) + MEM_SIZE size; +{ + if (size >= BIG_SIZE) { + /* Give the possibility to recover: */ + die("Out of memory during request for %i bytes", size); + /* croak may eat too much memory. */ + } + + if (!emergency_buffer) { + /* First offense, give a possibility to recover by dieing. */ + /* No malloc involved here: */ + GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0); + SV *sv; + char *pv; + + if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0); + if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) + || (SvLEN(sv) < (1<<11) - M_OVERHEAD)) + return (char *)-1; /* Now die die die... */ + + /* Got it, now detach SvPV: */ + pv = SvPV(sv, na); + /* Check alignment: */ + if (((u_int)(pv - M_OVERHEAD)) & ((1<<11) - 1)) { + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); + return (char *)-1; /* die die die */ + } + + emergency_buffer = pv - M_OVERHEAD; + emergency_buffer_size = SvLEN(sv) + M_OVERHEAD; + SvPOK_off(sv); + SvREADONLY_on(sv); + die("Out of memory!"); /* croak may eat too much memory. */ + } + else if (emergency_buffer_size >= size) { + emergency_buffer_size -= size; + return emergency_buffer + emergency_buffer_size; + } + + return (char *)-1; /* poor guy... */ +} + +#else /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */ +# define emergency_sbrk(size) -1 +#endif /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */ + +/* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information * precedes the data area returned to the user. @@ -165,6 +243,9 @@ extern char *sbrk(); * for a given block size. */ static u_int nmalloc[NBUCKETS]; +static u_int goodsbrk; +static u_int sbrk_slack; +static u_int start_slack; #endif #ifdef DEBUGGING @@ -188,22 +269,23 @@ malloc(nbytes) register int bucket = 0; register MEM_SIZE shiftr; -#ifdef safemalloc -#ifdef DEBUGGING +#if defined(DEBUGGING) || defined(RCHECK) MEM_SIZE size = nbytes; #endif -#ifdef MSDOS +#ifdef PERL_CORE +#ifdef HAS_64K_LIMIT if (nbytes > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", (long)nbytes); + PerlIO_printf(PerlIO_stderr(), + "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)nbytes < 0) - croak("panic: malloc"); + croak("panic: malloc"); #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ /* * Convert amount of memory requested into @@ -212,15 +294,18 @@ malloc(nbytes) * space used per block for accounting. */ #ifdef PACK_MALLOC - if (nbytes > MAX_2_POT_ALGO) { -#endif - nbytes += M_OVERHEAD; - nbytes = (nbytes + 3) &~ 3; -#ifdef PACK_MALLOC - } else if (nbytes == 0) { + if (nbytes == 0) nbytes = 1; - } + else if (nbytes > MAX_2_POT_ALGO) #endif + { +#ifdef TWO_POT_OPTIMIZE + if (nbytes >= FIRST_BIG_BOUND) + nbytes -= PERL_PAGESIZE; +#endif + nbytes += M_OVERHEAD; + nbytes = (nbytes + 3) &~ 3; + } shiftr = (nbytes - 1) >> 2; /* apart from this loop, this is O(1) */ while (shiftr >>= 1) @@ -232,7 +317,7 @@ malloc(nbytes) if (nextf[bucket] == NULL) morecore(bucket); if ((p = (union overhead *)nextf[bucket]) == NULL) { -#ifdef safemalloc +#ifdef PERL_CORE if (!nomemok) { PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); my_exit(1); @@ -242,10 +327,10 @@ malloc(nbytes) #endif } -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n", (unsigned long)(p+1),an++,(long)size)); -#endif /* safemalloc */ +#endif /* PERL_CORE */ /* remove from linked list */ #ifdef RCHECK @@ -258,14 +343,12 @@ malloc(nbytes) #ifndef PACK_MALLOC OV_INDEX(p) = bucket; #endif -#ifdef DEBUGGING_MSTATS - nmalloc[bucket]++; -#endif #ifdef RCHECK /* * Record allocated size of block and * bound space with magic numbers. */ + nbytes = (size + M_OVERHEAD + 3) &~ 3; if (nbytes <= 0x10000) p->ov_size = nbytes - 1; p->ov_rmagic = RMAGIC; @@ -284,11 +367,14 @@ morecore(bucket) register union overhead *op; register int rnu; /* 2^rnu bytes will be requested */ register int nblks; /* become nblks blocks of the desired size */ - register MEM_SIZE siz; + register MEM_SIZE siz, needed; int slack = 0; if (nextf[bucket]) return; + if (bucket == (sizeof(MEM_SIZE)*8 - 3)) { + croak("Allocation too large"); + } /* * Insure memory is allocated * on a page boundary. Should @@ -298,13 +384,13 @@ morecore(bucket) op = (union overhead *)sbrk(0); # ifndef I286 # ifdef PACK_MALLOC - if ((int)op & 0x7ff) - (void)sbrk(slack = 2048 - ((int)op & 0x7ff)); + if ((u_int)op & 0x7ff) + (void)sbrk(slack = 2048 - ((u_int)op & 0x7ff)); # else - if ((int)op & 0x3ff) - (void)sbrk(slack = 1024 - ((int)op & 0x3ff)); + if ((u_int)op & 0x3ff) + (void)sbrk(slack = 1024 - ((u_int)op & 0x3ff)); # endif -# if defined(DEBUGGING_MSTATS) && defined(PACK_MALLOC) +# if defined(DEBUGGING_MSTATS) sbrk_slack += slack; # endif # else @@ -321,22 +407,30 @@ morecore(bucket) rnu = (bucket <= 11) ? 14 : bucket + 3; #endif nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ - /* if (rnu < bucket) - rnu = bucket; Why anyone needs this? */ - op = (union overhead *)sbrk(1L << rnu); + needed = (MEM_SIZE)1 << rnu; +#ifdef TWO_POT_OPTIMIZE + needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0); +#endif + op = (union overhead *)sbrk(needed); /* no more room! */ - if ((int)op == -1) + if (op == (union overhead *)-1) { + op = (union overhead *)emergency_sbrk(needed); + if (op == (union overhead *)-1) return; + } +#ifdef DEBUGGING_MSTATS + goodsbrk += needed; +#endif /* * Round up to minimum allocation size boundary * and deduct from block count to reflect. */ #ifndef I286 # ifdef PACK_MALLOC - if ((int)op & 0x7ff) + if ((u_int)op & 0x7ff) croak("panic: Off-page sbrk"); # endif - if ((int)op & 7) { + if ((u_int)op & 7) { op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7); nblks--; } @@ -363,6 +457,9 @@ morecore(bucket) } else op++; /* One chunk per block. */ #endif /* !PACK_MALLOC */ nextf[bucket] = op; +#ifdef DEBUGGING_MSTATS + nmalloc[bucket] += nblks; +#endif while (--nblks > 0) { op->ov_next = (union overhead *)((caddr_t)op + siz); op = (union overhead *)((caddr_t)op + siz); @@ -390,9 +487,9 @@ free(mp) u_char bucket; #endif -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++)); -#endif /* safemalloc */ +#endif /* PERL_CORE */ if (cp == NULL) return; @@ -423,7 +520,7 @@ free(mp) #endif #ifdef RCHECK ASSERT(op->ov_rmagic == RMAGIC); - if (OV_INDEX(op) <= 13) + if (OV_INDEX(op) <= MAX_SHORT_BUCKET) ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC); op->ov_rmagic = RMAGIC - 1; #endif @@ -431,9 +528,6 @@ free(mp) size = OV_INDEX(op); op->ov_next = nextf[size]; nextf[size] = op; -#ifdef DEBUGGING_MSTATS - nmalloc[size]--; -#endif } /* @@ -461,30 +555,31 @@ realloc(mp, nbytes) int was_alloced = 0; char *cp = (char*)mp; -#ifdef safemalloc #ifdef DEBUGGING MEM_SIZE size = nbytes; #endif -#ifdef MSDOS +#ifdef PERL_CORE +#ifdef HAS_64K_LIMIT if (nbytes > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size); + PerlIO_printf(PerlIO_stderr(), + "Reallocation too large: %lx\n", size); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ if (!cp) return malloc(nbytes); #ifdef DEBUGGING if ((long)nbytes < 0) croak("panic: realloc"); #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ op = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); i = OV_INDEX(op); if (OV_MAGIC(op, i) == MAGIC) { - was_alloced++; + was_alloced = 1; } else { /* * Already free, doing "compaction". @@ -507,16 +602,30 @@ realloc(mp, nbytes) #else M_OVERHEAD #endif +#ifdef TWO_POT_OPTIMIZE + + (i >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0) +#endif ; - /* avoid the copy if same size block */ + /* + * avoid the copy if same size block. + * We are not agressive with boundary cases. Note that it is + * possible for small number of cases give false negative if + * both new size and old one are in the bucket for + * FIRST_BIG_TWO_POT, but the new one is near the lower end. + */ if (was_alloced && - nbytes <= onb && nbytes > (onb >> 1) - M_OVERHEAD) { + nbytes <= onb && (nbytes > ( (onb >> 1) - M_OVERHEAD ) +#ifdef TWO_POT_OPTIMIZE + || (i == (FIRST_BIG_TWO_POT - 3) + && nbytes >= LAST_SMALL_BOUND ) +#endif + )) { #ifdef RCHECK /* * Record new allocated size of block and * bound space with magic numbers. */ - if (OV_INDEX(op) <= 13) { + if (OV_INDEX(op) <= MAX_SHORT_BUCKET) { /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -540,7 +649,7 @@ realloc(mp, nbytes) free(cp); } -#ifdef safemalloc +#ifdef PERL_CORE #ifdef DEBUGGING if (debug & 128) { PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) rfree\n",(unsigned long)res,an++); @@ -548,7 +657,7 @@ realloc(mp, nbytes) (unsigned long)res,an++,(long)size); } #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ return ((Malloc_t)res); } @@ -604,7 +713,7 @@ dump_mstats(s) { register int i, j; register union overhead *p; - int topbucket=0, totfree=0, totused=0; + int topbucket=0, totfree=0, total=0; u_int nfree[NBUCKETS]; for (i=0; i < NBUCKETS; i++) { @@ -612,28 +721,23 @@ dump_mstats(s) ; nfree[i] = j; totfree += nfree[i] * (1 << (i + 3)); - totused += nmalloc[i] * (1 << (i + 3)); - if (nfree[i] || nmalloc[i]) + total += nmalloc[i] * (1 << (i + 3)); + if (nmalloc[i]) topbucket = i; } if (s) PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets 8..%d)\n", s, (1 << (topbucket + 3)) ); - PerlIO_printf(PerlIO_stderr(), " %7d free: ", totfree); + PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree); for (i=0; i <= topbucket; i++) { - PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nfree[i]); + PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nfree[i]); } - PerlIO_printf(PerlIO_stderr(), "\n %7d used: ", totused); + PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree); for (i=0; i <= topbucket; i++) { - PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nmalloc[i]); + PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nmalloc[i] - nfree[i]); } - PerlIO_printf(PerlIO_stderr(), "\n"); -#ifdef PACK_MALLOC - if (sbrk_slack || start_slack) { - PerlIO_printf(PerlIO_stderr(), "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n", - sbrk_slack, start_slack); - } -#endif + PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %8d. Odd ends: sbrk(): %7d, malloc(): %7d bytes.\n", + goodsbrk + sbrk_slack, sbrk_slack, start_slack); } #else void @@ -652,10 +756,10 @@ dump_mstats(s) # endif # ifdef PERL_SBRK_VIA_MALLOC -# ifdef HIDEMYMALLOC +# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC) # undef malloc # else -# include "Error: -DPERL_SBRK_VIA_MALLOC requires -DHIDEMYMALLOC" +# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC" # endif /* it may seem schizophrenic to use perl's malloc and let it call system */ @@ -681,7 +785,7 @@ int size; int small, reqsize; if (!size) return 0; -#ifdef safemalloc +#ifdef PERL_CORE reqsize = size; /* just for the DEBUG_m statement */ #endif if (size <= Perl_sbrk_oldsize) { @@ -692,7 +796,7 @@ int size; if (size >= PERLSBRK_32_K) { small = 0; } else { -#ifndef safemalloc +#ifndef PERL_CORE reqsize = size; #endif size = PERLSBRK_64_K; @@ -706,7 +810,7 @@ int size; } } -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", size, reqsize, Perl_sbrk_oldsize, got)); #endif @@ -38,15 +38,13 @@ typedef struct magic_state MGS; static void restore_magic _((void *p)); -static MGS * -save_magic(sv) +static void +save_magic(mgs, sv) +MGS* mgs; SV* sv; { - MGS* mgs; - assert(SvMAGICAL(sv)); - mgs = (MGS*)safemalloc(sizeof(MGS)); mgs->mgs_sv = sv; mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); SAVEDESTRUCTOR(restore_magic, mgs); @@ -54,15 +52,13 @@ SV* sv; SvMAGICAL_off(sv); SvREADONLY_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - - return mgs; } static void restore_magic(p) void* p; { - MGS *mgs = (MGS*)p; + MGS* mgs = (MGS*)p; SV* sv = mgs->mgs_sv; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) @@ -74,8 +70,6 @@ void* p; if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } - - Safefree(mgs); } @@ -101,13 +95,13 @@ int mg_get(sv) SV* sv; { - MGS* mgs; + MGS mgs; MAGIC* mg; MAGIC** mgp; int mgp_valid = 0; ENTER; - mgs = save_magic(sv); + save_magic(&mgs, sv); mgp = &SvMAGIC(sv); while ((mg = *mgp) != 0) { @@ -115,8 +109,9 @@ SV* sv; if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { (*vtbl->svt_get)(sv, mg); /* Ignore this magic if it's been deleted */ - if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP)) - mgs->mgs_flags = 0; + if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && + (mg->mg_flags & MGf_GSKIP)) + mgs.mgs_flags = 0; } /* Advance to next magic (complicated by possible deletion) */ if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { @@ -135,19 +130,19 @@ int mg_set(sv) SV* sv; { - MGS* mgs; + MGS mgs; MAGIC* mg; MAGIC* nextmg; ENTER; - mgs = save_magic(sv); + save_magic(&mgs, sv); for (mg = SvMAGIC(sv); mg; mg = nextmg) { MGVTBL* vtbl = mg->mg_virtual; nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - mgs->mgs_flags = 0; + mgs.mgs_flags = 0; } if (vtbl && vtbl->svt_set) (*vtbl->svt_set)(sv, mg); @@ -168,8 +163,10 @@ SV* sv; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { + MGS mgs; + ENTER; - save_magic(sv); + save_magic(&mgs, sv); /* omit MGf_GSKIP -- not changed here */ len = (*vtbl->svt_len)(sv, mg); LEAVE; @@ -185,10 +182,11 @@ int mg_clear(sv) SV* sv; { + MGS mgs; MAGIC* mg; ENTER; - save_magic(sv); + save_magic(&mgs, sv); for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; @@ -269,18 +267,19 @@ MAGIC *mg; register I32 paren; register char *s; register I32 i; + register REGEXP *rx; char *t; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': - if (curpm) { + if (curpm && (rx = curpm->op_pmregexp)) { paren = atoi(mg->mg_ptr); getparen: - if (curpm->op_pmregexp && - paren <= curpm->op_pmregexp->nparens && - (s = curpm->op_pmregexp->startp[paren]) && - (t = curpm->op_pmregexp->endp[paren]) ) { + if (paren <= rx->nparens && + (s = rx->startp[paren]) && + (t = rx->endp[paren])) + { i = t - s; if (i >= 0) return i; @@ -289,29 +288,28 @@ MAGIC *mg; return 0; break; case '+': - if (curpm) { - paren = curpm->op_pmregexp->lastparen; - if (!paren) - return 0; - goto getparen; + if (curpm && (rx = curpm->op_pmregexp)) { + paren = rx->lastparen; + if (paren) + goto getparen; } return 0; break; case '`': - if (curpm) { - if (curpm->op_pmregexp && - (s = curpm->op_pmregexp->subbeg) ) { - i = curpm->op_pmregexp->startp[0] - s; + if (curpm && (rx = curpm->op_pmregexp)) { + if ((s = rx->subbeg) && rx->startp[0]) { + i = rx->startp[0] - s; if (i >= 0) return i; } } return 0; case '\'': - if (curpm) { - if (curpm->op_pmregexp && - (s = curpm->op_pmregexp->endp[0]) ) { - return (STRLEN) (curpm->op_pmregexp->subend - s); + if (curpm && (rx = curpm->op_pmregexp)) { + if (rx->subend && (s = rx->endp[0])) { + i = rx->subend - s; + if (i >= 0) + return 0; } } return 0; @@ -336,6 +334,7 @@ MAGIC *mg; register I32 paren; register char *s; register I32 i; + register REGEXP *rx; char *t; switch (*mg->mg_ptr) { @@ -399,19 +398,24 @@ MAGIC *mg; break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': - if (curpm) { + if (curpm && (rx = curpm->op_pmregexp)) { paren = atoi(GvENAME((GV*)mg->mg_obj)); getparen: - if (curpm->op_pmregexp && - paren <= curpm->op_pmregexp->nparens && - (s = curpm->op_pmregexp->startp[paren]) && - (t = curpm->op_pmregexp->endp[paren]) ) { + if (paren <= rx->nparens && + (s = rx->startp[paren]) && + (t = rx->endp[paren])) + { i = t - s; + getrx: if (i >= 0) { - MAGIC *tmg; + bool was_tainted; + if (tainting) { + was_tainted = tainted; + tainted = FALSE; + } sv_setpvn(sv,s,i); - if (tainting && (tmg = mg_find(sv,'t'))) - tmg->mg_len = 0; /* guarantee $1 untainted */ + if (tainting) + tainted = was_tainted || rx->exec_tainted; break; } } @@ -419,32 +423,27 @@ MAGIC *mg; sv_setsv(sv,&sv_undef); break; case '+': - if (curpm) { - paren = curpm->op_pmregexp->lastparen; + if (curpm && (rx = curpm->op_pmregexp)) { + paren = rx->lastparen; if (paren) goto getparen; } sv_setsv(sv,&sv_undef); break; case '`': - if (curpm) { - if (curpm->op_pmregexp && - (s = curpm->op_pmregexp->subbeg) ) { - i = curpm->op_pmregexp->startp[0] - s; - if (i >= 0) { - sv_setpvn(sv,s,i); - break; - } + if (curpm && (rx = curpm->op_pmregexp)) { + if ((s = rx->subbeg) && rx->startp[0]) { + i = rx->startp[0] - s; + goto getrx; } } sv_setsv(sv,&sv_undef); break; case '\'': - if (curpm) { - if (curpm->op_pmregexp && - (s = curpm->op_pmregexp->endp[0]) ) { - sv_setpvn(sv,s, curpm->op_pmregexp->subend - s); - break; + if (curpm && (rx = curpm->op_pmregexp)) { + if (rx->subend && (s = rx->endp[0])) { + i = rx->subend - s; + goto getrx; } } sv_setsv(sv,&sv_undef); @@ -625,46 +624,6 @@ MAGIC* mg; return 0; } -#ifdef HAS_SIGACTION -/* set up reliable signal() clone */ - -typedef void (*Sigfunc) _((int)); - -static -Sigfunc rsignal(signo,handler) -int signo; -Sigfunc handler; -{ - struct sigaction act,oact; - - act.sa_handler = handler; - sigemptyset(&act.sa_mask); - act.sa_flags = 0; -#ifdef SA_RESTART - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif - if (sigaction(signo, &act, &oact) < 0) - return(SIG_ERR); - else - return(oact.sa_handler); -} - -#else - -/* ah well, so much for reliability */ - -#define rsignal(x,y) signal(x,y) - -#endif - -static sig_trapped; -static -Signal_t -sig_trap(signo) -int signo; -{ - sig_trapped++; -} int magic_getsig(sv,mg) SV* sv; @@ -677,15 +636,10 @@ MAGIC* mg; if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { - void (*origsig) _((int)); - /* get signal state without losing signals */ - sig_trapped=0; - origsig = rsignal(i,sig_trap); - rsignal(i,origsig); - if(sig_trapped) - kill(getpid(),i); + Sighandler_t sigstate = rsignal_state(i); + /* cache state so we don't fetch it again */ - if(origsig == SIG_IGN) + if(sigstate == SIG_IGN) sv_setpv(sv,"IGNORE"); else sv_setsv(sv,&sv_undef); @@ -759,7 +713,7 @@ MAGIC* mg; } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { if (i) - (void)rsignal(i,sighandler); + (void)rsignal(i, sighandler); else *svp = SvREFCNT_inc(sv); return 0; @@ -767,13 +721,13 @@ MAGIC* mg; s = SvPV_force(sv,na); if (strEQ(s,"IGNORE")) { if (i) - (void)rsignal(i,SIG_IGN); + (void)rsignal(i, SIG_IGN); else *svp = 0; } else if (strEQ(s,"DEFAULT") || !*s) { if (i) - (void)rsignal(i,SIG_DFL); + (void)rsignal(i, SIG_DFL); else *svp = 0; } @@ -785,7 +739,7 @@ MAGIC* mg; sv_setpv(sv,tokenbuf); } if (i) - (void)rsignal(i,sighandler); + (void)rsignal(i, sighandler); else *svp = SvREFCNT_inc(sv); } @@ -1043,6 +997,7 @@ MAGIC* mg; else if (pos > len) pos = len; mg->mg_len = pos; + mg->mg_flags &= ~MGf_MINMATCH; return 0; } @@ -1106,10 +1061,8 @@ magic_gettaint(sv,mg) SV* sv; MAGIC* mg; { - if (mg->mg_len & 1) - tainted = TRUE; - else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */ - tainted = TRUE; + TAINT_IF((mg->mg_len & 1) || + (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ return 0; } @@ -1141,6 +1094,65 @@ MAGIC* mg; } int +magic_getitervar(sv,mg) +SV* sv; +MAGIC* mg; +{ + SV *targ = Nullsv; + if (LvTARGLEN(sv)) { + AV* av = (AV*)LvTARG(sv); + if (LvTARGOFF(sv) <= AvFILL(av)) + targ = AvARRAY(av)[LvTARGOFF(sv)]; + } + else + targ = LvTARG(sv); + sv_setsv(sv, targ ? targ : &sv_undef); + return 0; +} + +int +magic_setitervar(sv,mg) +SV* sv; +MAGIC* mg; +{ + if (LvTARGLEN(sv)) + vivify_itervar(sv); + if (LvTARG(sv)) + sv_setsv(LvTARG(sv), sv); + return 0; +} + +int +magic_freeitervar(sv,mg) +SV* sv; +MAGIC* mg; +{ + SvREFCNT_dec(LvTARG(sv)); + return 0; +} + +void +vivify_itervar(sv) +SV* sv; +{ + AV* av; + + if (!LvTARGLEN(sv)) + return; + av = (AV*)LvTARG(sv); + if (LvTARGOFF(sv) <= AvFILL(av)) { + SV** svp = AvARRAY(av) + LvTARGOFF(sv); + LvTARG(sv) = newSVsv(*svp); + SvREFCNT_dec(*svp); + *svp = SvREFCNT_inc(LvTARG(sv)); + } + else + LvTARG(sv) = Nullsv; + SvREFCNT_dec(av); + LvTARGLEN(sv) = 0; +} + +int magic_setmglob(sv,mg) SV* sv; MAGIC* mg; @@ -1161,6 +1173,16 @@ MAGIC* mg; } int +magic_setfm(sv,mg) +SV* sv; +MAGIC* mg; +{ + sv_unmagic(sv, 'f'); + SvCOMPILED_off(sv); + return 0; +} + +int magic_setuvar(sv,mg) SV* sv; MAGIC* mg; @@ -1172,6 +1194,25 @@ MAGIC* mg; return 0; } +#ifdef USE_LOCALE_COLLATE +int +magic_setcollxfrm(sv,mg) +SV* sv; +MAGIC* mg; +{ + /* + * René Descartes said "I think not." + * and vanished with a faint plop. + */ + if (mg->mg_ptr) { + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + mg->mg_len = -1; + } + return 0; +} +#endif /* USE_LOCALE_COLLATE */ + int magic_set(sv,mg) SV* sv; @@ -1426,7 +1467,8 @@ MAGIC* mg; if (origargv[i] == s + 1) s += strlen(++s); /* this one is ok too */ } - if (origenviron[0] == s + 1) { /* can grab env area too? */ + /* can grab env area too? */ + if (origenviron && origenviron[0] == s + 1) { my_setenv("NoNeSuCh", Nullch); /* force copy of environment */ for (i = 0; origenviron[i]; i++) diff --git a/miniperlmain.c b/miniperlmain.c index 2d66964093..680b04284a 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -40,6 +40,7 @@ char **env; if (!my_perl) exit(1); perl_construct( my_perl ); + perl_destruct_level = 0; } exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL ); @@ -24,7 +24,7 @@ Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) osname=$osname, osvers=$osvers, archname=$archname uname='$myuname' hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction - useperlio=$useperlio d_sfio=$d_sfio + bincompat3=$bincompat3 useperlio=$useperlio d_sfio=$d_sfio Compiler: cc='$cc', optimize='$optimize', gccversion=$gccversion cppflags='$cppflags' @@ -26,8 +26,10 @@ * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,op) \ - ((op_mask && op_mask[type]) \ - ? (croak("%s trapped by operation mask", op_desc[type]), (OP*)op) \ + ((op_mask && op_mask[type]) \ + ? ( op_free((OP*)op), \ + croak("%s trapped by operation mask", op_desc[type]), \ + Nullop ) \ : (*check[type])((OP*)op)) #else #define CHECKOP(type,op) (*check[type])(op) @@ -41,7 +43,7 @@ static OP *scalarboolean _((OP *op)); static OP *too_few_arguments _((OP *op, char* name)); static OP *too_many_arguments _((OP *op, char* name)); static void null _((OP* op)); -static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq, +static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); static char* @@ -104,9 +106,9 @@ OP *op; if (type != OP_AELEM && type != OP_HELEM) { sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); yyerror(tokenbuf); - if (type == OP_RV2HV || type == OP_ENTERSUB) + if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) warn("(Did you mean $ or @ instead of %c?)\n", - type == OP_RV2HV ? '%' : '&'); + type == OP_ENTERSUB ? '&' : '%'); } } @@ -120,8 +122,8 @@ char *name; SV *sv; if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isprint(name[1])) - sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */ + if (!isPRINT(name[1])) + sprintf(name+1, "^%c", toCTRL(name[1])); /* XXX tokenbuf, really */ croak("Can't use global %s in \"my\"",name); } if (AvFILL(comppad_name) >= 0) { @@ -160,11 +162,11 @@ static PADOFFSET pad_findlex(name, newoff, seq, startcv, cx_ix) char *name; PADOFFSET newoff; -I32 seq; +U32 seq; CV* startcv; I32 cx_ix; #else -pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) +pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) #endif { CV *cv; @@ -186,12 +188,21 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) if ((sv = svp[off]) && sv != &sv_undef && seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && + seq > I_32(SvNVX(sv)) && strEQ(SvPVX(sv), name)) { - I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; - AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE); - SV *oldsv = *av_fetch(oldpad, off, TRUE); + I32 depth; + AV *oldpad; + SV *oldsv; + + depth = CvDEPTH(cv); + if (!depth) { + if (newoff && !CvUNIQUE(cv)) + return 0; /* don't clone inactive sub's stack frame */ + depth = 1; + } + oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldsv = *av_fetch(oldpad, off, TRUE); if (!newoff) { /* Not a mere clone operation. */ SV *sv = NEWSV(1103,0); newoff = pad_alloc(OP_PADSV, SVs_PADMY); @@ -201,9 +212,32 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) SvNVX(sv) = (double)curcop->cop_seq; SvIVX(sv) = 999999999; /* A ref, intro immediately */ SvFLAGS(sv) |= SVf_FAKE; + if (CvANON(compcv) || CvFORMAT(compcv)) { + /* "It's closures all the way down." */ + CvCLONE_on(compcv); + if (cv != startcv) { + CV *bcv; + for (bcv = startcv; + bcv && bcv != cv && !CvCLONE(bcv); + bcv = CvOUTSIDE(bcv)) { + if (CvANON(bcv)) + CvCLONE_on(bcv); + else { + if (dowarn) + warn( + "Variable \"%s\" may be unavailable", + name); + break; + } + } + } + } + else if (!CvUNIQUE(compcv)) { + if (dowarn && !CvUNIQUE(cv)) + warn("Variable \"%s\" will not stay shared", name); + } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); - CvCLONE_on(compcv); return newoff; } } @@ -225,10 +259,14 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) } break; case CXt_EVAL: - if (cx->blk_eval.old_op_type != OP_ENTEREVAL && - cx->blk_eval.old_op_type != OP_ENTERTRY) - return 0; /* require must have its own scope */ - saweval = i; + switch (cx->blk_eval.old_op_type) { + case OP_ENTEREVAL: + saweval = i; + break; + case OP_REQUIRE: + /* require must have its own scope */ + return 0; + } break; case CXt_SUB: if (!saweval) @@ -253,14 +291,14 @@ char *name; I32 off; SV *sv; SV **svp = AvARRAY(comppad_name); - I32 seq = cop_seqmax; + U32 seq = cop_seqmax; /* The one we're looking for is probably just before comppad_name_fill. */ for (off = AvFILL(comppad_name); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && + seq > I_32(SvNVX(sv)) && strEQ(SvPVX(sv), name)) { return (PADOFFSET)off; @@ -314,9 +352,21 @@ U32 tmptype; retval = AvFILL(comppad); } else { - do { - sv = *av_fetch(comppad, ++padix, TRUE); - } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)); + SV **names = AvARRAY(comppad_name); + SSize_t names_fill = AvFILL(comppad_name); + for (;;) { + /* + * "foreach" index vars temporarily become aliases to non-"my" + * values. Thus we must skip, not just pad values that are + * marked as current pad values, but also those with names. + */ + if (++padix <= names_fill && + (sv = names[padix]) && sv != &sv_undef) + continue; + sv = *av_fetch(comppad, padix, TRUE); + if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY))) + break; + } retval = padix; } SvFLAGS(sv) |= tmptype; @@ -423,15 +473,20 @@ OP *op; case OP_ENTEREVAL: op->op_targ = 0; /* Was holding hints. */ break; + default: + if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst)) + break; + /* FALL THROUGH */ case OP_GVSV: case OP_GV: + case OP_AELEMFAST: SvREFCNT_dec(cGVOP->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: + Safefree(cCOP->cop_label); SvREFCNT_dec(cCOP->cop_filegv); break; - /* case OP_ANONCODE: XXX breaks eval of anon subs in closures (cf. Opcode) */ case OP_CONST: SvREFCNT_dec(cSVOP->op_sv); break; @@ -453,8 +508,6 @@ OP *op; pregfree(cPMOP->op_pmregexp); SvREFCNT_dec(cPMOP->op_pmshort); break; - default: - break; } if (op->op_targ > 0) @@ -538,7 +591,8 @@ OP *op; OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || error_count) + if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN + || error_count) return op; op->op_flags &= ~OPf_LIST; @@ -609,6 +663,8 @@ OP *op; default: if (!(opargs[op->op_type] & OA_FOLDCONST)) break; + /* FALL THROUGH */ + case OP_REPEAT: if (op->op_flags & OPf_STACKED) break; /* FALL THROUGH */ @@ -727,11 +783,6 @@ OP *op; op->op_ppaddr = ppaddr[OP_PREDEC]; break; - case OP_REPEAT: - scalarvoid(cBINOP->op_first); - useless = op_desc[op->op_type]; - break; - case OP_OR: case OP_AND: case OP_COND_EXPR: @@ -792,7 +843,8 @@ OP *op; OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || error_count) + if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN + || error_count) return op; op->op_flags |= (OPf_KNOW | OPf_LIST); @@ -889,7 +941,6 @@ I32 type; { OP *kid; SV *sv; - char mtype; if (!op || error_count) return op; @@ -911,6 +962,10 @@ I32 type; else croak("That use of $[ is unsupported"); break; + case OP_STUB: + if (op->op_flags & OPf_PARENS) + break; + goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN) && !(op->op_flags & OPf_STACKED)) { @@ -1013,23 +1068,13 @@ I32 type; case OP_KEYS: if (type != OP_SASSIGN) goto nomod; - mtype = 'k'; - goto makelv; + /* FALL THROUGH */ case OP_POS: - mtype = '.'; - goto makelv; case OP_VEC: - mtype = 'v'; - goto makelv; case OP_SUBSTR: - mtype = 'x'; - makelv: pad_free(op->op_targ); op->op_targ = pad_alloc(op->op_type, SVs_PADMY); - sv = PAD_SV(op->op_targ); - sv_upgrade(sv, SVt_PVLV); - sv_magic(sv, Nullsv, mtype, Nullch, 0); - curpad[op->op_targ] = sv; + assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL); if (op->op_flags & OPf_KIDS) mod(cBINOP->op_first->op_sibling, type); break; @@ -1116,8 +1161,10 @@ I32 type; ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_PADSV: - if (type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); op->op_flags |= OPf_MOD; } break; @@ -1144,8 +1191,10 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); - if (type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); op->op_flags |= OPf_MOD; } break; @@ -1269,41 +1318,42 @@ OP *o; } int -block_start() +block_start(full) +int full; { int retval = savestack_ix; - SAVEINT(comppad_name_floor); - if ((comppad_name_fill = AvFILL(comppad_name)) > 0) - comppad_name_floor = comppad_name_fill; - else - comppad_name_floor = 0; - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_floor); + if (full) { + if ((comppad_name_fill = AvFILL(comppad_name)) > 0) + comppad_name_floor = comppad_name_fill; + else + comppad_name_floor = 0; + } + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(padix_floor); + SAVEI32(comppad_name_fill); + SAVEI32(padix_floor); padix_floor = padix; pad_reset_pending = FALSE; - SAVEINT(hints); + SAVEI32(hints); hints &= ~HINT_BLOCK_SCOPE; return retval; } OP* -block_end(line, floor, seq) -int line; -int floor; +block_end(floor, seq) +I32 floor; OP* seq; { int needblockscope = hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); - if (copline > (line_t)line) - copline = line; LEAVE_SCOPE(floor); pad_reset_pending = FALSE; if (needblockscope) hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(comppad_name_fill); + cop_seqmax++; return retval; } @@ -1821,6 +1871,9 @@ I32 flags; pmop->op_flags = flags; pmop->op_private = 0 | (flags >> 8); + if (hints & HINT_LOCALE) + pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE); + /* link into pm list */ if (type != OP_TRANS && curstash) { pmop->op_pmnext = HvPMROOT(curstash); @@ -2299,23 +2352,9 @@ I32 flags; char *label; OP *op; { + U32 seq = intro_my(); register COP *cop; - /* Introduce my variables. */ - if (min_intro_pending) { - SV **svp = AvARRAY(comppad_name); - I32 i; - SV *sv; - for (i = min_intro_pending; i <= max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { - SvIVX(sv) = 999999999; /* Don't know scope end yet. */ - SvNVX(sv) = (double)cop_seqmax; - } - } - min_intro_pending = 0; - comppad_name_fill = max_intro_pending; /* Needn't search higher */ - } - Newz(1101, cop, 1, COP); if (perldb && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; @@ -2333,7 +2372,7 @@ OP *op; cop->cop_label = label; hints |= HINT_BLOCK_SCOPE; } - cop->cop_seq = cop_seqmax++; + cop->cop_seq = seq; cop->cop_arybase = curcop->cop_arybase; if (copline == NOLINE) @@ -2342,7 +2381,7 @@ OP *op; cop->cop_line = copline; copline = NOLINE; } - cop->cop_filegv = GvREFCNT_inc(curcop->cop_filegv); + cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; if (perldb && curstash != debstash) { @@ -2357,6 +2396,29 @@ OP *op; return prepend_elem(OP_LINESEQ, (OP*)cop, op); } +/* "Introduce" my variables to visible status. */ +U32 +intro_my() +{ + SV **svp; + SV *sv; + I32 i; + + if (! min_intro_pending) + return cop_seqmax; + + svp = AvARRAY(comppad_name); + for (i = min_intro_pending; i <= max_intro_pending; i++) { + if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { + SvIVX(sv) = 999999999; /* Don't know scope end yet. */ + SvNVX(sv) = (double)cop_seqmax; + } + } + min_intro_pending = 0; + comppad_name_fill = max_intro_pending; /* Needn't search higher */ + return cop_seqmax++; +} + OP * newLOGOP(type, flags, first, other) I32 type; @@ -2404,6 +2466,32 @@ OP* other; else scalar(other); } + else if (dowarn && (first->op_flags & OPf_KIDS)) { + OP *k1 = ((UNOP*)first)->op_first; + OP *k2 = k1->op_sibling; + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV)) + warnop = k2->op_type; + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB) + warnop = k1->op_type; + break; + } + if (warnop) { + line_t oldline = curcop->cop_line; + curcop->cop_line = copline; + warn("Value of %s construct can be \"0\"; test with defined()", + op_desc[warnop]); + curcop->cop_line = oldline; + } + } if (!other) return first; @@ -2674,7 +2762,7 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont else { sv = newGVOP(OP_GV, 0, defgv); } - if (expr->op_type == OP_RV2AV) { + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = scalar(ref(expr, OP_ITER)); iterflags |= OPf_STACKED; } @@ -2727,35 +2815,79 @@ CV *cv; CvROOT(cv) = Nullop; LEAVE; } + CvFLAGS(cv) = 0; SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvPADLIST(cv)) { - I32 i = AvFILL(CvPADLIST(cv)); - while (i >= 0) { - SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - SvREFCNT_dec(*svp); + /* may be during global destruction */ + if (SvREFCNT(CvPADLIST(cv))) { + I32 i = AvFILL(CvPADLIST(cv)); + while (i >= 0) { + SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); + if (svp) + SvREFCNT_dec(*svp); + } + SvREFCNT_dec((SV*)CvPADLIST(cv)); } - SvREFCNT_dec((SV*)CvPADLIST(cv)); CvPADLIST(cv) = Nullav; } } -CV * -cv_clone(proto) +#ifdef DEBUG_CLOSURES +static void +cv_dump(cv) +CV* cv; +{ + CV *outside = CvOUTSIDE(cv); + AV* padlist = CvPADLIST(cv); + AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE); + AV* pad = (AV*)*av_fetch(padlist, 1, FALSE); + SV** pname = AvARRAY(pad_name); + SV** ppad = AvARRAY(pad); + I32 ix; + + PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", + cv, + (CvANON(cv) ? "ANON" + : (cv == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), + outside, + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + + for (ix = 1; ix <= AvFILL(pad); ix++) { + if (SvPOK(pname[ix])) + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\" %ld-%ld)\n", + ix, ppad[ix], SvPVX(pname[ix]), + (long)I_32(SvNVX(pname[ix])), + (long)SvIVX(pname[ix])); + } +} +#endif /* DEBUG_CLOSURES */ + +static CV * +cv_clone2(proto, outside) CV* proto; +CV* outside; { AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); - SV** svp = AvARRAY(protopad); + SV** pname = AvARRAY(protopad_name); + SV** ppad = AvARRAY(protopad); AV* comppadlist; CV* cv; + assert(!CvUNIQUE(proto)); + ENTER; SAVESPTR(curpad); SAVESPTR(comppad); @@ -2764,14 +2896,16 @@ CV* proto; cv = compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)cv, SVt_PVCV); CvCLONED_on(cv); + if (CvANON(proto)) + CvANON_on(cv); CvFILEGV(cv) = CvFILEGV(proto); - CvGV(cv) = GvREFCNT_inc(CvGV(proto)); + CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = CvROOT(proto); CvSTART(cv) = CvSTART(proto); - if (CvOUTSIDE(proto)) - CvOUTSIDE(cv) = (CV*)SvREFCNT_inc((SV*)CvOUTSIDE(proto)); + if (outside) + CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); comppad = newAV(); @@ -2780,7 +2914,7 @@ CV* proto; av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name)); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(cv) = comppadlist; - av_extend(comppad, AvFILL(protopad)); + av_fill(comppad, AvFILL(protopad)); curpad = AvARRAY(comppad); av = newAV(); /* will be @_ */ @@ -2788,37 +2922,77 @@ CV* proto; av_store(comppad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; - svp = AvARRAY(protopad_name); - for ( ix = AvFILL(protopad); ix > 0; ix--) { - SV *sv; - if (svp[ix] != &sv_undef) { - char *name = SvPVX(svp[ix]); /* XXX */ - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), - cxstack_ix); - if (off != ix) + for (ix = AvFILL(protopad); ix > 0; ix--) { + SV* sv; + if (pname[ix] != &sv_undef) { + char *name = SvPVX(pname[ix]); /* XXX */ + if (SvFLAGS(pname[ix]) & SVf_FAKE) { /* lexical from outside? */ + I32 off = pad_findlex(name, ix, SvIVX(pname[ix]), + CvOUTSIDE(cv), cxstack_ix); + if (!off) + curpad[ix] = SvREFCNT_inc(ppad[ix]); + else if (off != ix) croak("panic: cv_clone: %s", name); } else { /* our own lexical */ - if (*name == '@') - av_store(comppad, ix, sv = (SV*)newAV()); + if (*name == '&') { + /* anon code -- we'll come back for it */ + sv = SvREFCNT_inc(ppad[ix]); + } + else if (*name == '@') + sv = (SV*)newAV(); else if (*name == '%') - av_store(comppad, ix, sv = (SV*)newHV()); + sv = (SV*)newHV(); else - av_store(comppad, ix, sv = NEWSV(0,0)); - SvPADMY_on(sv); + sv = NEWSV(0,0); + if (!SvPADBUSY(sv)) + SvPADMY_on(sv); + curpad[ix] = sv; } } else { - av_store(comppad, ix, sv = NEWSV(0,0)); + sv = NEWSV(0,0); SvPADTMP_on(sv); + curpad[ix] = sv; + } + } + + /* Now that vars are all in place, clone nested closures. */ + + for (ix = AvFILL(protopad); ix > 0; ix--) { + if (pname[ix] != &sv_undef + && !(SvFLAGS(pname[ix]) & SVf_FAKE) + && *SvPVX(pname[ix]) == '&' + && CvCLONE(ppad[ix])) + { + CV *kid = cv_clone2((CV*)ppad[ix], cv); + SvREFCNT_dec(ppad[ix]); + CvCLONE_on(kid); + SvPADMY_on(kid); + curpad[ix] = (SV*)kid; } } +#ifdef DEBUG_CLOSURES + PerlIO_printf(Perl_debug_log, "Cloned inside:\n"); + cv_dump(outside); + PerlIO_printf(Perl_debug_log, " from:\n"); + cv_dump(proto); + PerlIO_printf(Perl_debug_log, " to:\n"); + cv_dump(cv); +#endif + LEAVE; return cv; } +CV * +cv_clone(proto) +CV* proto; +{ + return cv_clone2(proto, CvOUTSIDE(proto)); +} + SV * cv_const_sv(cv) CV *cv; @@ -2850,21 +3024,24 @@ OP *op; OP *proto; OP *block; { + char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch; + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - char *name = op ? SvPVx(cSVOP->op_sv, na) : "__ANON__"; - GV* gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV); - AV* av; - char *s; + AV *av; I32 ix; if (op) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ + SAVEFREEOP(op); + if (cv = (name ? GvCV(gv) : Nullcv)) { + if (GvCVGEN(gv)) { + /* just a cached method */ + SvREFCNT_dec(cv); + cv = 0; + } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { - SV* const_sv = cv_const_sv(cv); + /* already defined (or promised) */ + SV* const_sv = cv_const_sv(cv); char *p = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; if((!proto != !SvPOK(cv)) || (p && strNE(SvPV((SV*)cv,na), p))) { @@ -2872,10 +3049,8 @@ OP *block; SvPOK(cv) ? SvPV((SV*)cv,na) : "none", p ? p : "none"); } - - if ((const_sv || dowarn) && strNE(name, "BEGIN")) {/* already defined (or promised)? */ + if (const_sv || dowarn) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; warn(const_sv ? "Constant subroutine %s redefined" : "Subroutine %s redefined",name); @@ -2887,6 +3062,7 @@ OP *block; } if (cv) { /* must reuse cv if autoloaded */ cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(compcv); CvOUTSIDE(cv) = CvOUTSIDE(compcv); CvOUTSIDE(compcv) = 0; CvPADLIST(cv) = CvPADLIST(compcv); @@ -2897,11 +3073,14 @@ OP *block; } else { cv = compcv; + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } } - GvCV(gv) = cv; - GvCVGEN(gv) = 0; + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - CvGV(cv) = GvREFCNT_inc(gv); CvSTASH(cv) = curstash; if (proto) { @@ -2915,8 +3094,6 @@ OP *block; block = Nullop; } if (!block) { - CvROOT(cv) = 0; - op_free(op); copline = NOLINE; LEAVE_SCOPE(floor); return cv; @@ -2928,7 +3105,7 @@ OP *block; AvFLAGS(av) = AVf_REIFY; for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) + if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) SvPADTMP_on(curpad[ix]); } @@ -2939,59 +3116,72 @@ OP *block; CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN") && !error_count) { - line_t oldline = compiling.cop_line; - SV *oldrs = rs; - ENTER; - SAVESPTR(compiling.cop_filegv); - SAVEI32(perldb); - if (!beginav) - beginav = newAV(); - av_push(beginav, (SV *)cv); - DEBUG_x( dump_sub(gv) ); - rs = SvREFCNT_inc(nrs); - SvREFCNT_inc(cv); - calllist(beginav); - if (GvCV(gv) == cv) { /* Detach it. */ - SvREFCNT_dec(cv); - GvCV(gv) = 0; /* Was above calllist, why? IZ */ + if (name) { + char *s; + + if (perldb && curstash != debstash) { + SV *sv; + SV *tmpstr = sv_newmortal(); + static GV *db_postponed; + CV *cv; + HV *hv; + + sprintf(buf, "%s:%ld", + SvPVX(GvSV(curcop->cop_filegv)), (long)subline); + sv = newSVpv(buf,0); + sv_catpv(sv,"-"); + sprintf(buf,"%ld",(long)curcop->cop_line); + sv_catpv(sv,buf); + gv_efullname3(tmpstr, gv, Nullch); + hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + if (!db_postponed) { + db_postponed = gv_fetchpv("DB::postponed", TRUE, SVt_PVHV); + } + hv = GvHVn(db_postponed); + if (HvFILL(hv) >= 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + && (cv = GvCV(db_postponed))) { + dSP; + PUSHMARK(sp); + XPUSHs(tmpstr); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } } - SvREFCNT_dec(rs); - rs = oldrs; - curcop = &compiling; - curcop->cop_line = oldline; /* might have recursed to yylex */ - LEAVE; - } - else if (strEQ(s, "END") && !error_count) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(cv)); - } - if (perldb && curstash != debstash) { - SV *sv; - SV *tmpstr = sv_newmortal(); - sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), (long)subline); - sv = newSVpv(buf,0); - sv_catpv(sv,"-"); - sprintf(buf,"%ld",(long)curcop->cop_line); - sv_catpv(sv,buf); - gv_efullname3(tmpstr, gv, Nullch); - hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + if ((s = strrchr(name,':'))) + s++; + else + s = name; + if (strEQ(s, "BEGIN") && !error_count) { + ENTER; + SAVESPTR(compiling.cop_filegv); + SAVEI16(compiling.cop_line); + SAVEI32(perldb); + save_svref(&rs); + sv_setsv(rs, nrs); + + if (!beginav) + beginav = newAV(); + DEBUG_x( dump_sub(gv) ); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + calllist(beginav); + + curcop = &compiling; + LEAVE; + } + else if (strEQ(s, "END") && !error_count) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } } - op_free(op); + copline = NOLINE; LEAVE_SCOPE(floor); - if (!op) { - GvCV(gv) = 0; /* Will remember in SVOP instead. */ - CvANON_on(cv); - } return cv; } @@ -3016,19 +3206,19 @@ char *name; void (*subaddr) _((CV*)); char *filename; { + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - GV *gv = gv_fetchpv((name ? name : "__ANON__"), GV_ADDMULTI, SVt_PVCV); - char *s; - - if (name) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv)) { /* already defined? */ + + if (cv = (name ? GvCV(gv) : Nullcv)) { + if (GvCVGEN(gv)) { + /* just a cached method */ + SvREFCNT_dec(cv); + cv = 0; + } + else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + /* already defined (or promised) */ if (dowarn) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; warn("Subroutine %s redefined",name); curcop->cop_line = oldline; @@ -3037,40 +3227,45 @@ char *filename; cv = 0; } } - if (cv) { /* must reuse cv if autoloaded */ - assert(SvREFCNT(CvGV(cv)) > 1); - SvREFCNT_dec(CvGV(cv)); - } + + if (cv) /* must reuse cv if autoloaded */ + cv_undef(cv); else { cv = (CV*)NEWSV(1105,0); sv_upgrade((SV *)cv, SVt_PVCV); + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } } - GvCV(gv) = cv; - CvGV(cv) = GvREFCNT_inc(gv); - GvCVGEN(gv) = 0; + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = gv_fetchfile(filename); CvXSUB(cv) = subaddr; - if (!name) - s = "__ANON__"; - else if (s = strrchr(name,':')) - s++; + + if (name) { + char *s = strrchr(name,':'); + if (s) + s++; + else + s = name; + if (strEQ(s, "BEGIN")) { + if (!beginav) + beginav = newAV(); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + } + else if (strEQ(s, "END")) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } + } else - s = name; - if (strEQ(s, "BEGIN")) { - if (!beginav) - beginav = newAV(); - av_push(beginav, SvREFCNT_inc(gv)); - } - else if (strEQ(s, "END")) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(gv)); - } - if (!name) { - GvCV(gv) = 0; /* Will remember elsewhere instead. */ CvANON_on(cv); - } + return cv; } @@ -3103,11 +3298,11 @@ OP *block; } cv = compcv; GvFORM(gv) = cv; - CvGV(cv) = GvREFCNT_inc(gv); + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) + if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) SvPADTMP_on(curpad[ix]); } @@ -3261,6 +3456,35 @@ OP *o; /* Check routines. */ OP * +ck_anoncode(op) +OP *op; +{ + PADOFFSET ix; + SV* name; + + name = NEWSV(1106,0); + sv_upgrade(name, SVt_PVNV); + sv_setpvn(name, "&", 1); + SvIVX(name) = -1; + SvNVX(name) = 1; + ix = pad_alloc(op->op_type, SVs_PADMY); + av_store(comppad_name, ix, name); + av_store(comppad, ix, cSVOP->op_sv); + SvPADMY_on(cSVOP->op_sv); + cSVOP->op_sv = Nullsv; + cSVOP->op_targ = ix; + return op; +} + +OP * +ck_bitop(op) +OP *op; +{ + op->op_private = hints; + return op; +} + +OP * ck_concat(op) OP *op; { @@ -3276,7 +3500,8 @@ OP *op; if (op->op_flags & OPf_KIDS) { OP* newop; OP* kid; - op = modkids(ck_fun(op), op->op_type); + OPCODE type = op->op_type; + op = modkids(ck_fun(op), type); kid = cUNOP->op_first; newop = kUNOP->op_first->op_sibling; if (newop && @@ -3299,10 +3524,14 @@ ck_delete(op) OP *op; { op = ck_fun(op); + op->op_private = 0; if (op->op_flags & OPf_KIDS) { OP *kid = cUNOP->op_first; - if (kid->op_type != OP_HELEM) - croak("%s argument is not a HASH element", op_desc[op->op_type]); + if (kid->op_type == OP_HSLICE) + op->op_private |= OPpSLICE; + else if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element or slice", + op_desc[op->op_type]); null(kid); } return op; @@ -3384,6 +3613,20 @@ OP *op; } OP * +ck_exists(op) +OP *op; +{ + op = ck_fun(op); + if (op->op_flags & OPf_KIDS) { + OP *kid = cUNOP->op_first; + if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element", op_desc[op->op_type]); + null(kid); + } + return op; +} + +OP * ck_gvconst(o) register OP *o; { @@ -3401,9 +3644,31 @@ register OP *op; op->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - int iscv = (op->op_type==OP_RV2CV)*2; - GV *gv = 0; + char *name; + int iscv; + GV *gv; + + name = SvPV(kid->op_sv, na); + if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + char *badthing = Nullch; + switch (op->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + } + if (badthing) + croak( + "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", + name, badthing); + } kid->op_type = OP_GV; + iscv = (op->op_type == OP_RV2CV) * 2; for (gv = 0; !gv; iscv++) { /* * This is a little tricky. We only want to add the symbol if we @@ -3413,7 +3678,7 @@ register OP *op; * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - gv = gv_fetchpv(SvPVx(kid->op_sv, na), + gv = gv_fetchpv(name, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -3432,13 +3697,6 @@ register OP *op; } OP * -ck_formline(op) -OP *op; -{ - return ck_fun(op); -} - -OP * ck_ftst(op) OP *op; { @@ -3687,7 +3945,7 @@ OP *op; if (op->op_flags & OPf_KIDS) { OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_CONST) - fbm_compile(((SVOP*)kid)->op_sv, 0); + fbm_compile(((SVOP*)kid)->op_sv); } return ck_fun(op); } @@ -3704,14 +3962,16 @@ OP * ck_lfun(op) OP *op; { - return modkids(ck_fun(op), op->op_type); + OPCODE type = op->op_type; + return modkids(ck_fun(op), type); } OP * ck_rfun(op) OP *op; { - return refkids(ck_fun(op), op->op_type); + OPCODE type = op->op_type; + return refkids(ck_fun(op), type); } OP * @@ -3742,7 +4002,43 @@ OP *op; if (!kid) append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); - return listkids(op); + op = listkids(op); + + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; +} + +OP * +ck_fun_locale(op) +OP *op; +{ + op = ck_fun(op); + + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; +} + +OP * +ck_scmp(op) +OP *op; +{ + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; } OP * @@ -3847,6 +4143,12 @@ OP * ck_sort(op) OP *op; { + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + if (op->op_flags & OPf_STACKED) { OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ OP *k; @@ -3883,6 +4185,7 @@ OP *op; op->op_flags |= OPf_SPECIAL; } } + return op; } @@ -3964,7 +4267,7 @@ OP *op; null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV) { - cv = GvCV(tmpop->op_sv); + cv = GvCVu(tmpop->op_sv); if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) proto = SvPV((SV*)cv,na); } @@ -4149,7 +4452,7 @@ register OP* o; case OP_GV: if (o->op_next->op_type == OP_RV2SV) { - if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) { + if (!(o->op_next->op_private & OPpDEREF)) { null(o->op_next); o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; o->op_next = o->op_next->op_next; @@ -4163,8 +4466,7 @@ register OP* o; if (pop->op_type == OP_CONST && (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & - (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) && + !(pop->op_next->op_private & (OPpDEREF|OPpLVAL_INTRO)) && (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) <= 255 && i >= 0) @@ -4178,7 +4480,7 @@ register OP* o; o->op_type = OP_AELEMFAST; o->op_ppaddr = ppaddr[OP_AELEMFAST]; o->op_private = (U8)i; - GvAVn((GV*)(((SVOP*)o)->op_sv)); + GvAVn(((GVOP*)o)->op_gv); } } o->op_seq = op_seqmax++; @@ -86,8 +86,10 @@ typedef U32 PADOFFSET; /* (lower bits carry hints) */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ #define OPpENTERSUB_DB 16 /* Debug subroutine. */ -#define OPpDEREF_AV 32 /* Want ref to AV. */ -#define OPpDEREF_HV 64 /* Want ref to HV. */ +#define OPpDEREF (32|64) /* Want ref to something: */ +#define OPpDEREF_AV 32 /* Want ref to AV. */ +#define OPpDEREF_HV 64 /* Want ref to HV. */ +#define OPpDEREF_SV (32|64) /* Want ref to SV. */ /* Private for OP_CONST */ #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ @@ -100,9 +102,15 @@ typedef U32 PADOFFSET; /* Private for OP_LIST */ #define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */ -/* Private for OP_LEAVE and friends */ +/* Private for OP_LEAVE, OP_DELETE, and friends(?) */ #define OPpLEAVE_VOID 64 /* No need to copy out values. */ +/* Private for OP_DELETE */ +#define OPpSLICE 32 /* Operating on a list of keys */ + +/* Private for OP_SORT, OP_PRTF, OP_SPRINTF, string cmp'n, and case changers */ +#define OPpLOCALE 64 /* Use locale */ + struct op { BASEOP }; @@ -167,7 +175,7 @@ struct pmop { #define PMf_WHITE 0x0800 /* pattern is \s+ */ #define PMf_MULTILINE 0x1000 /* assume multiple lines */ #define PMf_SINGLELINE 0x2000 /* assume single line */ -#define PMf_UNUSED 0x4000 /* (unused) */ +#define PMf_LOCALE 0x4000 /* use locale for character types */ #define PMf_EXTENDED 0x8000 /* chuck embedded whitespace */ struct svop { @@ -1052,14 +1052,17 @@ EXT char *op_desc[] = { }; #endif +OP * ck_anoncode _((OP* op)); +OP * ck_bitop _((OP* op)); OP * ck_concat _((OP* op)); OP * ck_delete _((OP* op)); OP * ck_eof _((OP* op)); OP * ck_eval _((OP* op)); OP * ck_exec _((OP* op)); -OP * ck_formline _((OP* op)); +OP * ck_exists _((OP* op)); OP * ck_ftst _((OP* op)); OP * ck_fun _((OP* op)); +OP * ck_fun_locale _((OP* op)); OP * ck_glob _((OP* op)); OP * ck_grep _((OP* op)); OP * ck_index _((OP* op)); @@ -1072,6 +1075,7 @@ OP * ck_repeat _((OP* op)); OP * ck_require _((OP* op)); OP * ck_rfun _((OP* op)); OP * ck_rvconst _((OP* op)); +OP * ck_scmp _((OP* op)); OP * ck_select _((OP* op)); OP * ck_shift _((OP* op)); OP * ck_sort _((OP* op)); @@ -1797,7 +1801,7 @@ EXT OP * (*check[]) _((OP *op)) = { ck_rvconst, /* rv2sv */ ck_null, /* av2arylen */ ck_rvconst, /* rv2cv */ - ck_null, /* anoncode */ + ck_anoncode, /* anoncode */ ck_null, /* prototype */ ck_spair, /* refgen */ ck_null, /* srefgen */ @@ -1845,8 +1849,8 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* i_subtract */ ck_concat, /* concat */ ck_fun, /* stringify */ - ck_null, /* left_shift */ - ck_null, /* right_shift */ + ck_bitop, /* left_shift */ + ck_bitop, /* right_shift */ ck_null, /* lt */ ck_null, /* i_lt */ ck_null, /* gt */ @@ -1861,20 +1865,20 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* i_ne */ ck_null, /* ncmp */ ck_null, /* i_ncmp */ - ck_null, /* slt */ - ck_null, /* sgt */ - ck_null, /* sle */ - ck_null, /* sge */ + ck_scmp, /* slt */ + ck_scmp, /* sgt */ + ck_scmp, /* sle */ + ck_scmp, /* sge */ ck_null, /* seq */ ck_null, /* sne */ - ck_null, /* scmp */ - ck_null, /* bit_and */ - ck_null, /* bit_xor */ - ck_null, /* bit_or */ + ck_scmp, /* scmp */ + ck_bitop, /* bit_and */ + ck_bitop, /* bit_xor */ + ck_bitop, /* bit_or */ ck_null, /* negate */ ck_null, /* i_negate */ ck_null, /* not */ - ck_null, /* complement */ + ck_bitop, /* complement */ ck_fun, /* atan2 */ ck_fun, /* sin */ ck_fun, /* cos */ @@ -1892,15 +1896,15 @@ EXT OP * (*check[]) _((OP *op)) = { ck_fun, /* vec */ ck_index, /* index */ ck_index, /* rindex */ - ck_fun, /* sprintf */ - ck_formline, /* formline */ + ck_fun_locale, /* sprintf */ + ck_fun, /* formline */ ck_fun, /* ord */ ck_fun, /* chr */ ck_fun, /* crypt */ - ck_fun, /* ucfirst */ - ck_fun, /* lcfirst */ - ck_fun, /* uc */ - ck_fun, /* lc */ + ck_fun_locale, /* ucfirst */ + ck_fun_locale, /* lcfirst */ + ck_fun_locale, /* uc */ + ck_fun_locale, /* lc */ ck_fun, /* quotemeta */ ck_rvconst, /* rv2av */ ck_null, /* aelemfast */ @@ -1910,7 +1914,7 @@ EXT OP * (*check[]) _((OP *op)) = { ck_fun, /* values */ ck_fun, /* keys */ ck_delete, /* delete */ - ck_delete, /* exists */ + ck_exists, /* exists */ ck_rvconst, /* rv2hv */ ck_null, /* helem */ ck_null, /* hslice */ @@ -2195,8 +2199,8 @@ EXT U32 opargs[] = { 0x0000111e, /* i_subtract */ 0x0000110e, /* concat */ 0x0000010e, /* stringify */ - 0x0000111e, /* left_shift */ - 0x0000111e, /* right_shift */ + 0x0000110e, /* left_shift */ + 0x0000110e, /* right_shift */ 0x00001136, /* lt */ 0x00001116, /* i_lt */ 0x00001136, /* gt */ @@ -2247,11 +2251,11 @@ EXT U32 opargs[] = { 0x0000099e, /* ord */ 0x0000098e, /* chr */ 0x0000110e, /* crypt */ - 0x0000010e, /* ucfirst */ - 0x0000010e, /* lcfirst */ - 0x0000010e, /* uc */ - 0x0000010e, /* lc */ - 0x0000010e, /* quotemeta */ + 0x0000098e, /* ucfirst */ + 0x0000098e, /* lcfirst */ + 0x0000098e, /* uc */ + 0x0000098e, /* lc */ + 0x0000098e, /* quotemeta */ 0x00000048, /* rv2av */ 0x00001304, /* aelemfast */ 0x00001304, /* aelem */ @@ -2259,7 +2263,7 @@ EXT U32 opargs[] = { 0x00000408, /* each */ 0x00000408, /* values */ 0x00000408, /* keys */ - 0x00000104, /* delete */ + 0x00000100, /* delete */ 0x00000114, /* exists */ 0x00000048, /* rv2hv */ 0x00001404, /* helem */ @@ -1,5 +1,6 @@ #!/usr/bin/perl +unlink "opcode.h"; open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n"; select OC; @@ -213,7 +214,7 @@ rv2gv ref-to-glob cast ck_rvconst ds rv2sv scalar deref ck_rvconst ds av2arylen array length ck_null is rv2cv subroutine deref ck_rvconst d -anoncode anonymous subroutine ck_null 0 +anoncode anonymous subroutine ck_anoncode 0 prototype subroutine prototype ck_null s S refgen reference constructor ck_spair m L srefgen scalar ref constructor ck_null fs S @@ -278,8 +279,8 @@ i_subtract integer subtraction ck_null ifst S S concat concatenation ck_concat fst S S stringify string ck_fun fst S -left_shift left bitshift ck_null ifst S S -right_shift right bitshift ck_null ifst S S +left_shift left bitshift ck_bitop fst S S +right_shift right bitshift ck_bitop fst S S lt numeric lt ck_null Iifs S S i_lt integer lt ck_null ifs S S @@ -296,22 +297,22 @@ i_ne integer ne ck_null ifs S S ncmp spaceship operator ck_null Iifst S S i_ncmp integer spaceship ck_null ifst S S -slt string lt ck_null ifs S S -sgt string gt ck_null ifs S S -sle string le ck_null ifs S S -sge string ge ck_null ifs S S +slt string lt ck_scmp ifs S S +sgt string gt ck_scmp ifs S S +sle string le ck_scmp ifs S S +sge string ge ck_scmp ifs S S seq string eq ck_null ifs S S sne string ne ck_null ifs S S -scmp string comparison ck_null ifst S S +scmp string comparison ck_scmp ifst S S -bit_and bitwise and ck_null fst S S -bit_xor bitwise xor ck_null fst S S -bit_or bitwise or ck_null fst S S +bit_and bitwise and ck_bitop fst S S +bit_xor bitwise xor ck_bitop fst S S +bit_or bitwise or ck_bitop fst S S negate negate ck_null Ifst S i_negate integer negate ck_null ifst S not not ck_null ifs S -complement 1's complement ck_null fst S +complement 1's complement ck_bitop fst S # High falutin' math. @@ -338,16 +339,16 @@ 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 mst S L -formline formline ck_formline ms S L +sprintf sprintf ck_fun_locale mst S L +formline formline ck_fun ms S L ord ord ck_fun ifstu S? chr chr ck_fun fstu S? crypt crypt ck_fun fst S S -ucfirst upper case first ck_fun fst S -lcfirst lower case first ck_fun fst S -uc upper case ck_fun fst S -lc lower case ck_fun fst S -quotemeta quote metachars ck_fun fst S +ucfirst upper case first ck_fun_locale fstu S? +lcfirst lower case first ck_fun_locale fstu S? +uc upper case ck_fun_locale fstu S? +lc lower case ck_fun_locale fstu S? +quotemeta quote metachars ck_fun fstu S? # Arrays. @@ -361,8 +362,8 @@ aslice array slice ck_null m A L each each ck_fun t H values values ck_fun t H keys keys ck_fun t H -delete delete ck_delete s S -exists exists operator ck_delete is S +delete delete ck_delete 0 S +exists exists operator ck_exists is S rv2hv associative array deref ck_rvconst dt helem associative array elem ck_null s H S hslice associative array slice ck_null m H L diff --git a/os2/Changes b/os2/Changes index 9a9524f161..902783295f 100644 --- a/os2/Changes +++ b/os2/Changes @@ -104,3 +104,26 @@ after 5.003_05: perl___ - cannot fork, can dynalink. The build of the first one - perl - is rather convoluted, and requires a build of miniperl_. + +after 5.003_07: + custom tmpfile and tmpname which may use $TMP, $TEMP. + all the calls to OS/2 API wrapped so that it is safe to use + them under DOS (may die(), though). + Tested that popen works under DOS with modified PDKSH and RSX. + File::Copy works under DOS. + MakeMaker modified to work under DOS (perlmain.c.tmp and sh -c true). + +after 5.003_08: + OS2::PrfDB exports symbols as documented; + should work on OS/2 2.1 again. + uses reliable signals when spawing. + do not use popen() any more - no intermediate shell unless needed. + +after 5.003_11: + Functions emx_{malloc,realloc,calloc,free} are exported from DLL. + get_sysinfo() bugs corrected (flags were not used and wrongly defined). + +after 5.003_20: + _isterm is substituted instead of isatty, s?random instead of srand. + `register' disabled if -DDEBUGGING and not AOUT build: stupid SD386. + 3-argument select() was stomping over memory. diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index a1fcaa49ed..6b07e72dba 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -16,7 +16,7 @@ AOUT_LIBPERL = libperl$aout_lib_ext AOUT_CLDFLAGS = $aout_ldflags AOUT_LIBPERL_DLL = libperl_dll$aout_lib_ext -AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -g +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 !GROK!THIS! @@ -30,6 +30,10 @@ $(AOUT_LIBPERL_DLL): perl.imp perl.dll perl5.def perl.imp: perl5.def emximp -o perl.imp perl5.def + echo 'emx_calloc emxlibcm 400 ?' >> $@ + echo 'emx_free emxlibcm 401 ?' >> $@ + echo 'emx_malloc emxlibcm 402 ?' >> $@ + echo 'emx_realloc emxlibcm 403 ?' >> $@ perl.dll: $(obj) perl5.def perl$(OBJ_EXT) $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def @@ -48,7 +52,8 @@ perl5.def: perl.linkexp echo ' "dlopen"' >>$@ echo ' "dlsym"' >>$@ echo ' "dlerror"' >>$@ - echo ' "perl_init_i18nl10n"' >>$@ + echo ' "my_tmpfile"' >>$@ + echo ' "my_tmpnam"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then @@ -63,16 +68,12 @@ $spitshell >>Makefile <<'!NO!SUBS!' # grep -v '"\(malloc\|realloc\|free\)"' perl.linkexp >>$@ -# We assume here that perl is available somewhere ... - perl.exports: perl.exp EXTERN.h perl.h - (echo '#include "EXTERN.h"'; echo '#include "perl.h"' ; \ - echo '#include "perl.exp"') | \ + (echo "#include \"EXTERN.h\" \n#include \"perl.h\" \n#include \"perl.exp\""; \ + echo "malloc\nrealloc\ncalloc\nfree") | \ $(CC) -DEMBED -E - | \ awk '{if ($$2 == "") print $$1}' | sort | uniq > $@ -# perl -ne 'print if (/^#!/ .. /^#\s/) && s/^(\w+) *$$/$$1/' > $@ - perl.linkexp: perl.exports perl.map cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp diff --git a/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL index 4e8498f10c..35680288b8 100644 --- a/os2/OS2/ExtAttr/Makefile.PL +++ b/os2/OS2/ExtAttr/Makefile.PL @@ -4,6 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::ExtAttr', 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION + MAN3PODS => ' ', # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL index c591c0490c..39521685df 100644 --- a/os2/OS2/PrfDB/Makefile.PL +++ b/os2/OS2/PrfDB/Makefile.PL @@ -4,6 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::PrfDB', 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION + MAN3PODS => ' ', # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/PrfDB/PrfDB.pm b/os2/OS2/PrfDB/PrfDB.pm index d404c8b1d3..41d7dba2f1 100644 --- a/os2/OS2/PrfDB/PrfDB.pm +++ b/os2/OS2/PrfDB/PrfDB.pm @@ -34,7 +34,7 @@ sub SystemIni { use vars qw{$debug @ISA}; use Tie::Hash; -@ISA = qw{Tie::Hash}; +push @ISA, qw{Tie::Hash}; # Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL index ff4deabef6..b7a295f857 100644 --- a/os2/OS2/Process/Makefile.PL +++ b/os2/OS2/Process/Makefile.PL @@ -4,6 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::Process', 'VERSION' => '0.1', + MAN3PODS => ' ', # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 07f6cc67ea..c27cb0d905 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -3,5 +3,6 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::REXX', VERSION => '0.2', + MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', ); diff --git a/os2/diff.configure b/os2/diff.configure index cf2ec6748b..d19bf4a823 100644 --- a/os2/diff.configure +++ b/os2/diff.configure @@ -51,38 +51,6 @@ case "$libs" in '') ;; *) for thislib in $libs; do -@@ -3401,12 +3409,14 @@ - : - elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then - : -- elif try=`./loc lib$thislib.a X $libpth`; $test -f "$try"; then -+ elif try=`./loc lib$thislib$lib_ext X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then - : - 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.a X $xlibpth`; $test -f "$try"; then - : - else -@@ -3457,11 +3467,11 @@ - fi - elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - echo "Your C library seems to be in $libc, as you said before." --elif $test -r $incpath/usr/lib/libc.a; then -- libc=$incpath/usr/lib/libc.a; -+elif $test -r $incpath/usr/lib/libc$lib_ext; then -+ libc=$incpath/usr/lib/libc$lib_ext; - echo "Your C library seems to be in $libc. That's fine." --elif $test -r /lib/libc.a; then -- libc=/lib/libc.a; -+elif $test -r /lib/libc$lib_ext; then -+ libc=/lib/libc$lib_ext; - echo "Your C library seems to be in $libc. You're normal." - else - if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then @@ -3583,6 +3593,10 @@ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then @@ -171,15 +139,6 @@ echo "Your vsprintf() returns (int)." >&4 val2="$undef" else -@@ -5876,7 +5900,7 @@ - cryptlib=-lcrypt - fi - if $test -z "$cryptlib"; then -- cryptlib=`./loc libcrypt.a "" $libpth` -+ cryptlib=`./loc libcrypt$lib_ext "" $libpth` - else - cryptlib=-lcrypt - fi @@ -6148,7 +6172,7 @@ EOCP : check sys/file.h first to get FREAD on Sun @@ -207,30 +166,6 @@ d_mymalloc="$define" case "$libs" in *-lmalloc*) -@@ -7286,10 +7310,10 @@ - : we will have to assume that it supports the 4.2 BSD interface - d_oldsock="$undef" - else -- echo "You don't have Berkeley networking in libc.a..." >&4 -- if test -f /usr/lib/libnet.a; then -- ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ -- ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list -+ echo "You don't have Berkeley networking in libc$lib_ext..." >&4 -+ if test -f /usr/lib/libnet$lib_ext; then -+ ( (nm $nm_opt /usr/lib/libnet$lib_ext | eval $nm_extract) || \ -+ $ar t /usr/lib/libnet$lib_ext) 2>/dev/null >> libc.list - if $contains socket libc.list >/dev/null 2>&1; then - echo "...but the Wollongong group seems to have hacked it in." >&4 - socketlib="-lnet" -@@ -7302,7 +7326,7 @@ - d_oldsock="$define" - fi - else -- echo "or even in libnet.a, which is peculiar." >&4 -+ echo "or even in libnet$lib_ext, which is peculiar." >&4 - d_socket="$undef" - d_oldsock="$undef" - fi @@ -7867,7 +7891,7 @@ printf("%d\n", (char *)&try.bar - (char *)&try.foo); } @@ -258,31 +193,6 @@ dflt=`try` else dflt='?' -@@ -8364,18 +8388,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.a bar2.o bar1.o >/dev/null 2>&1 --if $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && -+$ar rc bar$lib_ext bar2$obj_ext bar1$obj_ext >/dev/null 2>&1 -+if $cc $ccflags $ldflags -o foobar foo$obj_ext 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.a >/dev/null 2>&1 && -- $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && -+elif $ar ts bar$lib_ext >/dev/null 2>&1 && -+ $cc $ccflags $ldflags -o foobar foo$obj_ext 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'." - orderlib=false -- ranlib="ar ts" -+ ranlib="$ar ts" - else - case "$ranlib" in - :) ranlib='';; @@ -8447,7 +8471,7 @@ '') $echo $n ".$c" if $cc $ccflags \ @@ -13,11 +13,37 @@ #include <errno.h> #include <limits.h> #include <process.h> +#include <fcntl.h> #include "EXTERN.h" #include "perl.h" /*****************************************************************************/ +/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ +static PFN ExtFCN[2]; /* Labeled by ord below. */ +static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ +#define ORD_QUERY_ELP 0 +#define ORD_SET_ELP 1 + +APIRET +loadByOrd(ULONG ord) +{ + if (ExtFCN[ord] == NULL) { + static HMODULE hdosc = 0; + BYTE buf[20]; + PFN fcn; + APIRET rc; + + if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, + "doscalls", &hdosc))) + || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) + die("This version of OS/2 does not support doscalls.%i", + loadOrd[ord]); + ExtFCN[ord] = fcn; + } + if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); +} + /* priorities */ static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, self inverse. */ @@ -34,7 +60,7 @@ get_sysinfo(ULONG pid, ULONG flags) rc = QuerySysState(flags, pid, pbuffer, buf_len); while (rc == ERROR_BUFFER_OVERFLOW) { Renew(pbuffer, buf_len *= 2, char); - rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len); + rc = QuerySysState(flags, pid, pbuffer, buf_len); } if (rc) { FillOSError(rc); @@ -73,6 +99,7 @@ setpriority(int which, int pid, int val) prio = sys_prio(pid); + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { /* Do not change class. */ return CheckOSError(DosSetPriority((pid < 0) @@ -114,6 +141,7 @@ getpriority(int which /* ignored */, int pid) PIB *pib; ULONG rc, ret; + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ /* DosGetInfoBlocks has old priority! */ /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ /* if (pid != pib->pib_ulpid) { */ @@ -128,6 +156,7 @@ getpriority(int which /* ignored */, int pid) /*****************************************************************************/ /* spawn */ +typedef void (*Sigfunc) _((int)); static int result(int flag, int pid) @@ -144,22 +173,22 @@ result(int flag, int pid) return pid; #ifdef __EMX__ - ihand = signal(SIGINT, SIG_IGN); - qhand = signal(SIGQUIT, SIG_IGN); + ihand = rsignal(SIGINT, SIG_IGN); + qhand = rsignal(SIGQUIT, SIG_IGN); do { r = wait4pid(pid, &status, 0); } while (r == -1 && errno == EINTR); - signal(SIGINT, ihand); - signal(SIGQUIT, qhand); + rsignal(SIGINT, ihand); + rsignal(SIGQUIT, qhand); statusvalue = (U16)status; if (r < 0) return -1; return status & 0xFFFF; #else - ihand = signal(SIGINT, SIG_IGN); + ihand = rsignal(SIGINT, SIG_IGN); r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); - signal(SIGINT, ihand); + rsignal(SIGINT, ihand); statusvalue = res.codeResult << 8 | res.codeTerminate; if (r) return -1; @@ -199,7 +228,7 @@ register SV **sp; if (flag == P_WAIT) flag = P_NOWAIT; - if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH; + if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path; if (Argv[0][0] != '/' && Argv[0][0] != '\\' && !(Argv[0][0] && Argv[0][1] == ':' @@ -224,6 +253,7 @@ register SV **sp; #define EXECF_SPAWN 0 #define EXECF_EXEC 1 #define EXECF_TRUEEXEC 2 +#define EXECF_SPAWN_NOWAIT 3 int do_spawn2(cmd, execf) @@ -250,7 +280,7 @@ int execf; have a shell which will not change between computers with the same architecture, to avoid "action on a distance". And to have simple build, this shell should be sh. */ - shell = SH_PATH; + shell = sh_path; copt = "-c"; #endif @@ -258,10 +288,10 @@ int execf; cmd++; if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { - STRLEN l = strlen(SH_PATH); + STRLEN l = strlen(sh_path); New(4545, news, strlen(cmd) - 7 + l, char); - strcpy(news, SH_PATH); + strcpy(news, sh_path); strcpy(news + l, cmd + 7); cmd = news; } @@ -290,6 +320,8 @@ int execf; return execl(shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_EXEC) return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); + else if (execf == EXECF_SPAWN_NOWAIT) + return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); /* In the ak code internal P_NOWAIT is P_WAIT ??? */ rc = result(P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); @@ -320,6 +352,8 @@ int execf; rc = execvp(Argv[0],Argv); else if (execf == EXECF_EXEC) rc = spawnvp(P_OVERLAY,Argv[0],Argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(P_NOWAIT,Argv[0],Argv); else rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); if (rc < 0 && dowarn) @@ -341,6 +375,13 @@ char *cmd; return do_spawn2(cmd, EXECF_SPAWN); } +int +do_spawn_nowait(cmd) +char *cmd; +{ + return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); +} + bool do_exec(cmd) char *cmd; @@ -360,22 +401,74 @@ my_syspopen(cmd,mode) char *cmd; char *mode; { +#ifndef USE_POPEN + + int p[2]; + register I32 this, that, newfd; + register I32 pid, rc; + PerlIO *res; + SV *sv; + + if (pipe(p) < 0) + return Nullfp; + /* `this' is what we use in the parent, `that' in the child. */ + this = (*mode == 'w'); + that = !this; + if (tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); + } + /* Now we need to spawn the child. */ + newfd = dup(*mode == 'r'); /* Preserve std* */ + if (p[that] != (*mode == 'r')) { + dup2(p[that], *mode == 'r'); + close(p[that]); + } + /* Where is `this' and newfd now? */ + fcntl(p[this], F_SETFD, FD_CLOEXEC); + fcntl(newfd, F_SETFD, FD_CLOEXEC); + pid = do_spawn_nowait(cmd); + if (newfd != (*mode == 'r')) { + dup2(newfd, *mode == 'r'); /* Return std* back. */ + close(newfd); + } + close(p[that]); + if (pid == -1) { + close(p[this]); + return NULL; + } + if (p[that] < p[this]) { + dup2(p[this], p[that]); + close(p[this]); + p[this] = p[that]; + } + sv = *av_fetch(fdpid,p[this],TRUE); + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = pid; + forkprocess = pid; + return PerlIO_fdopen(p[this], mode); + +#else /* USE_POPEN */ + PerlIO *res; SV *sv; -#ifdef TRYSHELL +# ifdef TRYSHELL res = popen(cmd, mode); -#else +# else char *shell = getenv("EMXSHELL"); - my_setenv("EMXSHELL", SH_PATH); + my_setenv("EMXSHELL", sh_path); res = popen(cmd, mode); my_setenv("EMXSHELL", shell); -#endif +# endif sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = -1; /* A cooky. */ return res; + +#endif /* USE_POPEN */ + } /******************************************************************/ @@ -409,6 +502,8 @@ tcp0(char *name) { static BYTE buf[20]; PFN fcn; + + if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -421,6 +516,8 @@ tcp1(char *name, int arg) { static BYTE buf[20]; PFN fcn; + + if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -601,6 +698,7 @@ os2error(int rc) static char buf[300]; ULONG len; + if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ if (rc == 0) return NULL; if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) @@ -610,8 +708,6 @@ os2error(int rc) return buf; } -char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI; - char * perllib_mangle(char *s, unsigned int l) { @@ -622,6 +718,8 @@ perllib_mangle(char *s, unsigned int l) if (!newp && !notfound) { newp = getenv("PERLLIB_PREFIX"); if (newp) { + char *s; + oldp = newp; while (*newp && !isSPACE(*newp) && *newp != ';') { newp++; oldl++; /* Skip digits. */ @@ -633,6 +731,12 @@ perllib_mangle(char *s, unsigned int l) if (newl == 0 || oldl == 0) { die("Malformed PERLLIB_PREFIX"); } + strcpy(ret, newp); + s = ret; + while (*s) { + if (*s == '\\') *s = '/'; + s++; + } } else { notfound = 1; } @@ -649,7 +753,6 @@ perllib_mangle(char *s, unsigned int l) if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { die("Malformed PERLLIB_PREFIX"); } - strncpy(ret, newp, newl); strcpy(ret + newl, s + oldl); return ret; } @@ -883,15 +986,23 @@ XS(XS_Cwd_sys_abspath) } XSRETURN(1); } +typedef APIRET (*PELP)(PSZ path, ULONG type); -#define extLibpath(type) \ - (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \ - : BEGIN_LIBPATH))) \ +APIRET +ExtLIBPATH(ULONG ord, PSZ path, ULONG type) +{ + loadByOrd(ord); /* Guarantied to load or die! */ + return (*(PELP)ExtFCN[ord])(path, type); +} + +#define extLibpath(type) \ + (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH))) \ ? NULL : to ) #define extLibpath_set(p,type) \ - (!CheckOSError(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \ - : BEGIN_LIBPATH)))) + (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH)))) XS(XS_Cwd_extLibpath) { @@ -947,8 +1058,12 @@ Xs_OS2_init() char *file = __FILE__; { GV *gv; - - newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + + if (_emx_env & 0x200) { /* OS/2 */ + newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); + newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); + } newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); newXS("Cwd::current_drive", XS_Cwd_current_drive, file); newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); @@ -958,8 +1073,6 @@ Xs_OS2_init() newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); - newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); - newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -978,17 +1091,50 @@ Perl_OS2_init() settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; if ( (shell = getenv("PERL_SH_DRIVE")) ) { + New(404, sh_path, strlen(SH_PATH) + 1, char); + strcpy(sh_path, SH_PATH); sh_path[0] = shell[0]; } else if ( (shell = getenv("PERL_SH_DIR")) ) { - int l = strlen(shell); + int l = strlen(shell), i; if (shell[l-1] == '/' || shell[l-1] == '\\') { l--; } - if (l > STATIC_FILE_LENGTH - 7) { - die("PERL_SH_DIR too long"); - } + New(404, sh_path, l + 8, char); strncpy(sh_path, shell, l); strcpy(sh_path + l, "/sh.exe"); + for (i = 0; i < l; i++) { + if (sh_path[i] == '\\') sh_path[i] = '/'; + } } } +#undef tmpnam +#undef tmpfile + +char * +my_tmpnam (char *str) +{ + char *p = getenv("TMP"), *tpath; + int len; + + if (!p) p = getenv("TEMP"); + tpath = tempnam(p, "pltmp"); + if (str && tpath) { + strcpy(str, tpath); + return str; + } + return tpath; +} + +FILE * +my_tmpfile () +{ + struct stat s; + + stat(".", &s); + if (s.st_mode & S_IWOTH) { + return tmpfile(); + } + return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but + grants TMP. */ +} diff --git a/os2/os2ish.h b/os2/os2ish.h index 6510a1f145..ade419912f 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -37,6 +37,18 @@ */ #undef ACME_MESS /**/ +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + #ifndef SIGABRT # define SIGABRT SIGILL #endif @@ -47,12 +59,6 @@ #define BIT_BUCKET "/dev/nul" /* Will this work? */ -/* SH_PATH_INI: - * Duplicate for SH_PATH. This symbol allows redefinition of SH_PATH, - * which may be needed to make a binary distribution. - */ -#define SH_PATH_INI SH_PATH /**/ - #if defined(I_SYS_UN) && !defined(TCPIPV4) /* It is not working without TCPIPV4 defined. */ # undef I_SYS_UN @@ -99,6 +105,14 @@ extern char *tmppath; PerlIO *my_syspopen(char *cmd, char *mode); /* Cannot prototype with I32 at this point. */ int my_syspclose(PerlIO *f); +FILE *my_tmpfile (void); +char *my_tmpnam (char *); + +#define tmpfile my_tmpfile +#define tmpnam my_tmpnam +#define isatty _isterm +#define rand random +#define srand srandom /* * fwrite1() should be a routine with the same calling sequence as fwrite(), @@ -110,6 +124,11 @@ int my_syspclose(PerlIO *f); #define my_getenv(var) getenv(var) +void *emx_calloc (size_t, size_t); +void emx_free (void *); +void *emx_malloc (size_t); +void *emx_realloc (void *, size_t); + /*****************************************************************************/ #include <stdlib.h> /* before the following definitions */ @@ -150,6 +169,11 @@ int my_syspclose(PerlIO *f); #endif +/* With SD386 it is impossible to debug register variables. */ +#if !defined(PERL_IS_AOUT) && defined(DEBUGGING) && !defined(register) +# define register +#endif + /* Our private OS/2 specific data. */ typedef struct OS2_Perl_data { @@ -192,9 +216,7 @@ extern OS2_Perl_data_t OS2_Perl_data; } #define STATIC_FILE_LENGTH 127 -extern char sh_path[STATIC_FILE_LENGTH+1]; -#undef SH_PATH -#define SH_PATH sh_path + #define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n)) char *perllib_mangle(char *, unsigned int); @@ -206,8 +228,8 @@ char *os2error(int rc); Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz) #define QSS_PROCESS 1 -#define QSS_MODULE 2 -#define QSS_SEMAPHORES 4 +#define QSS_MODULE 4 +#define QSS_SEMAPHORES 2 #define QSS_FILE 8 /* Buggy until fixpack18 */ #define QSS_SHARED 16 diff --git a/patchlevel.h b/patchlevel.h index 30bb120609..529bcbd608 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 7 +#define SUBVERSION 21 /* local_patches -- list of locally applied less-than-subversion patches. @@ -20,7 +20,7 @@ #include <unistd.h> #endif -dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; +dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -34,7 +34,31 @@ dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #endif #endif +#define I_REINIT \ + STMT_START { \ + chopset = " \n-"; \ + copline = NOLINE; \ + curcop = &compiling; \ + curcopdb = NULL; \ + cxstack_ix = -1; \ + cxstack_max = 128; \ + dbargs = 0; \ + dlmax = 128; \ + laststatval = -1; \ + laststype = OP_STAT; \ + maxscream = -1; \ + maxsysfd = MAXSYSFD; \ + statname = Nullsv; \ + tmps_floor = -1; \ + tmps_ix = -1; \ + op_mask = NULL; \ + dlmax = 128; \ + laststatval = -1; \ + laststype = OP_STAT; \ + } STMT_END + static void find_beginning _((void)); +static void forbid_setid _((char *)); static void incpush _((char *)); static void init_ids _((void)); static void init_debugger _((void)); @@ -92,6 +116,8 @@ register PerlInterpreter *sv_interp; nrs = newSVpv("\n", 1); rs = SvREFCNT_inc(nrs); + pidstatus = newHV(); + #ifdef MSDOS /* * There is no way we can refer to them from Perl so close them to save @@ -104,22 +130,16 @@ register PerlInterpreter *sv_interp; } #ifdef MULTIPLICITY - chopset = " \n-"; - copline = NOLINE; - curcop = &compiling; - dbargs = 0; - dlmax = 128; - laststatval = -1; - laststype = OP_STAT; - maxscream = -1; - maxsysfd = MAXSYSFD; - rsfp = Nullfp; - statname = Nullsv; - tmps_floor = -1; + I_REINIT; + perl_destruct_level = 1; +#else + if(perl_destruct_level > 0) + I_REINIT; #endif init_ids(); + SET_NUMERIC_STANDARD(); #if defined(SUBVERSION) && SUBVERSION > 0 sprintf(patchlevel, "%7.5f", (double) 5 + ((double) PATCHLEVEL / (double) 1000) @@ -136,7 +156,6 @@ register PerlInterpreter *sv_interp; PerlIO_init(); /* Hook to IO system */ fdpid = newAV(); /* for remembering popen pids by fd */ - pidstatus = newHV();/* for remembering status of dead pids */ init_stacks(); ENTER; @@ -157,11 +176,22 @@ register PerlInterpreter *sv_interp; #ifdef DEBUGGING { char *s; - if (s = getenv("PERL_DESTRUCT_LEVEL")) - destruct_level = atoi(s); + if (s = getenv("PERL_DESTRUCT_LEVEL")) { + int i = atoi(s); + if (destruct_level < i) + destruct_level = i; + } } #endif + /* unhook hooks which will soon be, or use, destroyed data */ + SvREFCNT_dec(warnhook); + warnhook = Nullsv; + SvREFCNT_dec(diehook); + diehook = Nullsv; + SvREFCNT_dec(parsehook); + parsehook = Nullsv; + LEAVE; FREETMPS; @@ -190,15 +220,125 @@ register PerlInterpreter *sv_interp; return; } - /* unhook hooks which may now point to, or use, broken code */ - if (warnhook && SvREFCNT(warnhook)) - SvREFCNT_dec(warnhook); - if (diehook && SvREFCNT(diehook)) - SvREFCNT_dec(diehook); - if (parsehook && SvREFCNT(parsehook)) - SvREFCNT_dec(parsehook); - + /* loosen bonds of global variables */ + + if(rsfp) { + (void)PerlIO_close(rsfp); + rsfp = Nullfp; + } + + /* Filters for program text */ + SvREFCNT_dec(rsfp_filters); + rsfp_filters = Nullav; + + /* switches */ + preprocess = FALSE; + minus_n = FALSE; + minus_p = FALSE; + minus_l = FALSE; + minus_a = FALSE; + minus_F = FALSE; + doswitches = FALSE; + dowarn = FALSE; + doextract = FALSE; + sawampersand = FALSE; /* must save all match strings */ + sawstudy = FALSE; /* do fbm_instr on all strings */ + sawvec = FALSE; + unsafe = FALSE; + + Safefree(inplace); + inplace = Nullch; + + Safefree(e_tmpname); + e_tmpname = Nullch; + + if (e_fp) { + PerlIO_close(e_fp); + e_fp = Nullfp; + } + + /* magical thingies */ + + Safefree(ofs); /* $, */ + ofs = Nullch; + + Safefree(ors); /* $\ */ + ors = Nullch; + + SvREFCNT_dec(nrs); /* $\ helper */ + nrs = Nullsv; + + multiline = 0; /* $* */ + + SvREFCNT_dec(statname); + statname = Nullsv; + statgv = Nullgv; + + /* defgv, aka *_ should be taken care of elsewhere */ + +#if 0 /* just about all regexp stuff, seems to be ok */ + + /* shortcuts to regexp stuff */ + leftgv = Nullgv; + ampergv = Nullgv; + + SAVEFREEOP(curpm); + SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */ + + regprecomp = NULL; /* uncompiled string. */ + regparse = NULL; /* Input-scan pointer. */ + regxend = NULL; /* End of input for compile */ + regnpar = 0; /* () count. */ + regcode = NULL; /* Code-emit pointer; ®dummy = don't. */ + regsize = 0; /* Code size. */ + regnaughty = 0; /* How bad is this pattern? */ + regsawback = 0; /* Did we see \1, ...? */ + + reginput = NULL; /* String-input pointer. */ + regbol = NULL; /* Beginning of input, for ^ check. */ + regeol = NULL; /* End of input, for $ check. */ + regstartp = (char **)NULL; /* Pointer to startp array. */ + regendp = (char **)NULL; /* Ditto for endp. */ + reglastparen = 0; /* Similarly for lastparen. */ + regtill = NULL; /* How far we are required to go. */ + regflags = 0; /* are we folding, multilining? */ + regprev = (char)NULL; /* char before regbol, \n if none */ + +#endif /* if 0 */ + + /* clean up after study() */ + SvREFCNT_dec(lastscream); + lastscream = Nullsv; + Safefree(screamfirst); + screamfirst = 0; + Safefree(screamnext); + screamnext = 0; + + /* startup and shutdown function lists */ + SvREFCNT_dec(beginav); + SvREFCNT_dec(endav); + beginav = Nullav; + endav = Nullav; + + /* temp stack during pp_sort() */ + SvREFCNT_dec(sortstack); + sortstack = Nullav; + + /* shortcuts just get cleared */ + envgv = Nullgv; + siggv = Nullgv; + incgv = Nullgv; + errgv = Nullgv; + argvgv = Nullgv; + argvoutgv = Nullgv; + stdingv = Nullgv; + last_in_gv = Nullgv; + + /* reset so print() ends up where we expect */ + setdefout(Nullgv); + /* Prepare to destruct main symbol table. */ + hv = defstash; defstash = 0; SvREFCNT_dec(hv); @@ -259,8 +399,10 @@ register PerlInterpreter *sv_interp; warn("Scalars leaked: %d\n", sv_count); sv_free_arenas(); - - linestr = NULL; /* No SVs have survived, need to clean out */ + + /* No SVs have survived, need to clean out */ + linestr = NULL; + pidstatus = Nullhv; if (origfilename) Safefree(origfilename); nuke_stacks(); @@ -414,7 +556,7 @@ setuid perl scripts securely.\n"); (void)PerlIO_putc(e_fp,'\n'); break; case 'I': - taint_not("-I"); + forbid_setid("-I"); sv_catpv(sv,"-"); sv_catpv(sv,s); sv_catpv(sv," "); @@ -429,12 +571,12 @@ setuid perl scripts securely.\n"); } break; case 'P': - taint_not("-P"); + forbid_setid("-P"); preprocess = TRUE; s++; goto reswitch; case 'S': - taint_not("-S"); + forbid_setid("-S"); dosearch = TRUE; s++; goto reswitch; @@ -524,7 +666,7 @@ setuid perl scripts securely.\n"); else if (scriptname == Nullch) { #ifdef MSDOS if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("v"); + moreswitches("h"); #endif scriptname = "-"; } @@ -540,6 +682,7 @@ setuid perl scripts securely.\n"); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); + CvUNIQUE_on(compcv); comppad = newAV(); av_push(comppad, Nullsv); @@ -737,13 +880,13 @@ char* name; I32 create; { GV* gv = gv_fetchpv(name, create, SVt_PVCV); - if (create && !GvCV(gv)) + if (create && !GvCVu(gv)) return newSUB(start_subparse(), newSVOP(OP_CONST, 0, newSVpv(name,0)), Nullop, Nullop); if (gv) - return GvCV(gv); + return GvCVu(gv); return Nullcv; } @@ -824,8 +967,12 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_ARRAY) myop.op_flags |= OPf_LIST; - if (perldb && curstash != debstash - && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */ + if (perldb && curstash != debstash + /* Handle first BEGIN of -d. */ + && (DBcv || (DBcv = GvCV(DBsub))) + /* Try harder, since this may have been a sighandler, thus + * curstash may be meaningless. */ + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)) op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { @@ -1152,7 +1299,7 @@ char *s; s++; return s; case 'd': - taint_not("-d"); + forbid_setid("-d"); s++; if (*s == ':' || *s == '=') { sprintf(buf, "use Devel::%s;", ++s); @@ -1166,7 +1313,7 @@ char *s; return s; case 'D': #ifdef DEBUGGING - taint_not("-D"); + forbid_setid("-D"); if (isALPHA(s[1])) { static char debopts[] = "psltocPmfrxuLHXD"; char *d; @@ -1197,7 +1344,7 @@ char *s; *s = '\0'; break; case 'I': - taint_not("-I"); + forbid_setid("-I"); if (*++s) { char *e; for (e = s; *e && !isSPACE(*e); e++) ; @@ -1230,10 +1377,10 @@ char *s; } return s; case 'M': - taint_not("-M"); /* XXX ? */ + forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ case 'm': - taint_not("-m"); /* XXX ? */ + forbid_setid("-m"); /* XXX ? */ if (*++s) { char *start; char *use = "use "; @@ -1273,7 +1420,7 @@ char *s; s++; return s; case 's': - taint_not("-s"); + forbid_setid("-s"); doswitches = TRUE; s++; return s; @@ -1296,10 +1443,13 @@ char *s; printf("\nThis is perl, version %s",patchlevel); #endif - printf("\n\nCopyright 1987-1996, Larry Wall\n"); + printf("\n\nCopyright 1987-1997, Larry Wall\n"); printf("\n\t+ suidperl security patch"); #ifdef MSDOS - printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); +#endif +#ifdef DJGPP + printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" @@ -1311,9 +1461,6 @@ char *s; printf("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); -#ifdef MSDOS - usage(origargv[0]); -#endif exit(0); case 'w': dowarn = TRUE; @@ -1517,7 +1664,8 @@ SV *sv; if (fdscript >= 0) { rsfp = PerlIO_fdopen(fdscript,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + if (rsfp) + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } else if (preprocess) { @@ -1589,19 +1737,20 @@ sed %s -e \"/^[^#]/b\" \ rsfp = my_popen(buf,"r"); } else if (!*scriptname) { - taint_not("program input from stdin"); + forbid_setid("program input from stdin"); rsfp = PerlIO_stdin(); } else { rsfp = PerlIO_open(scriptname,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + if (rsfp) + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } if (e_tmpname) { e_fp = rsfp; } - if ((PerlIO*)rsfp == Nullfp) { + if (!rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && @@ -1867,7 +2016,7 @@ find_beginning() /* skip forward in input to the real script? */ - taint_not("-x"); + forbid_setid("-x"); while (doextract) { if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) croak("No Perl script found in input\n"); @@ -1904,6 +2053,16 @@ init_ids() } static void +forbid_setid(s) +char *s; +{ + if (euid != uid) + croak("No %s allowed while running setuid", s); + if (egid != gid) + croak("No %s allowed while running setgid", s); +} + +static void init_debugger() { curstash = debstash; @@ -1925,15 +2084,32 @@ static void init_stacks() { curstack = newAV(); - mainstack = curstack; /* remember in case we switch stacks */ - AvREAL_off(curstack); /* not a real array */ + mainstack = curstack; /* remember in case we switch stacks */ + AvREAL_off(curstack); /* not a real array */ av_extend(curstack,127); stack_base = AvARRAY(curstack); stack_sp = stack_base; stack_max = stack_base + 127; - /* Shouldn't these stacks be per-interpreter? */ + cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,CONTEXT); + cxstack_ix = -1; + + New(50,tmps_stack,128,SV*); + tmps_ix = -1; + tmps_max = 128; + + DEBUG( { + New(51,debname,128,char); + New(52,debdelim,128,char); + } ) + + /* + * The following stacks almost certainly should be per-interpreter, + * but for now they're not. XXX + */ + if (markstack) { markstack_ptr = markstack; } else { @@ -1964,20 +2140,7 @@ init_stacks() New(54,retstack,16,OP*); retstack_ix = 0; retstack_max = 16; - } - - cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,CONTEXT); - cxstack_ix = -1; - - New(50,tmps_stack,128,SV*); - tmps_ix = -1; - tmps_max = 128; - - DEBUG( { - New(51,debname,128,char); - New(52,debdelim,128,char); - } ) + } } static void @@ -1985,14 +2148,18 @@ nuke_stacks() { Safefree(cxstack); Safefree(tmps_stack); + DEBUG( { + Safefree(debname); + Safefree(debdelim); + } ) } static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ + static void init_lexer() { tmpfp = rsfp; - lex_start(linestr); rsfp = tmpfp; subname = newSVpv("main",4); @@ -2069,7 +2236,7 @@ register char **env; sv_setpvn(bodytarget, "", 0); formtarget = bodytarget; - tainted = 1; + TAINT; if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { sv_setpv(GvSV(tmpgv),origfilename); magicname("0", "0", 1); @@ -2118,10 +2285,9 @@ register char **env; #endif hv_magic(hv, envgv, 'E'); } - tainted = 0; + TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) sv_setiv(GvSV(tmpgv),(I32)getpid()); - } static void @@ -16,12 +16,19 @@ * Above symbol is defined via -D in 'x2p/Makefile.SH' * Decouple x2p stuff from some of perls more extreme eccentricities. */ -#undef MULTIPLICITY #undef EMBED +#undef NO_EMBED +#define NO_EMBED +#undef MULTIPLICITY #undef USE_STDIO #define USE_STDIO #endif /* PERL_FOR_X2P */ +#define VOIDUSED 1 +#include "config.h" + +#include "embed.h" + /* * STMT_START { statements; } STMT_END; * can be used as a single statement, as in @@ -45,10 +52,15 @@ # endif #endif -#include "embed.h" - -#define VOIDUSED 1 -#include "config.h" +/* + * SOFT_CAST can be used for args to prototyped functions to retain some + * type checking; it only casts if the compiler does not know prototypes. + */ +#if defined(CAN_PROTOTYPE) && defined(DEBUGGING_COMPILE) +#define SOFT_CAST(type) +#else +#define SOFT_CAST(type) (type) +#endif #ifndef BYTEORDER # define BYTEORDER 0x1234 @@ -86,10 +98,11 @@ # define VOL #endif -#define TAINT_IF(c) (tainted |= (c)) -#define TAINT_NOT (tainted = 0) -#define TAINT_PROPER(s) if (tainting) taint_proper(no_security, s) -#define TAINT_ENV() if (tainting) taint_env() +#define TAINT (tainted = TRUE) +#define TAINT_NOT (tainted = FALSE) +#define TAINT_IF(c) if (c) { tainted = TRUE; } +#define TAINT_ENV() if (tainting) { taint_env(); } +#define TAINT_PROPER(s) if (tainting) { taint_proper(no_security, s); } /* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. @@ -175,16 +188,28 @@ #include <ctype.h> #endif /* USE_NEXT_CTYPE */ -#ifdef I_LOCALE -#include <locale.h> -#endif - -EXT int lc_collate_active; - #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ #undef METHOD #endif +#ifdef I_LOCALE +# include <locale.h> +#endif + +#if !defined(NO_LOCALE) && defined(HAS_SETLOCALE) +# define USE_LOCALE +# if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \ + && defined(HAS_STRXFRM) +# define USE_LOCALE_COLLATE +# endif +# if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE) +# define USE_LOCALE_CTYPE +# endif +# if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC) +# define USE_LOCALE_NUMERIC +# endif +#endif /* !NO_LOCALE && HAS_SETLOCALE */ + #include <setjmp.h> #ifdef I_SYS_PARAM @@ -198,27 +223,46 @@ EXT int lc_collate_active; /* Use all the "standard" definitions? */ #if defined(STANDARD_C) && defined(I_STDLIB) # include <stdlib.h> -#endif /* STANDARD_C */ +#endif + +/* This comes after <stdlib.h> so we don't try to change the standard + * library prototypes; we'll use our own in proto.h instead. */ -/* Maybe this comes after <stdlib.h> so we don't try to change - the standard library prototypes?. We'll use our own in - proto.h instead. I guess. The patch had no explanation. -*/ #ifdef MYMALLOC + # ifdef HIDEMYMALLOC -# define malloc Mymalloc +# define malloc Mymalloc +# define calloc Mycalloc # define realloc Myremalloc -# define free Myfree -# define calloc Mycalloc +# define free Myfree +# endif +# ifdef EMBEDMYMALLOC +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_free # endif -# define safemalloc malloc + +# undef safemalloc +# undef safecalloc +# undef saferealloc +# undef safefree +# define safemalloc malloc +# define safecalloc calloc # define saferealloc realloc -# define safefree free -# define safecalloc calloc -#endif +# define safefree free + +#endif /* MYMALLOC */ #define MEM_SIZE Size_t +#if defined(STANDARD_C) && defined(I_STDDEF) +# include <stddef.h> +# define STRUCT_OFFSET(s,m) offsetof(s,m) +#else +# define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) +#endif + #if defined(I_STRING) || defined(__cplusplus) # include <string.h> #else @@ -230,10 +274,6 @@ EXT int lc_collate_active; #define strrchr rindex #endif -#if defined(mips) && defined(ultrix) && !defined(__STDC__) -# undef HAS_MEMCMP -#endif - #ifdef I_MEMORY # include <memory.h> #endif @@ -271,18 +311,6 @@ EXT int lc_collate_active; # endif #endif /* HAS_MEMSET */ -#ifdef HAS_MEMCMP -# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) -# ifndef memcmp - extern int memcmp _((char*, char*, int)); -# endif -# endif -#else -# ifndef memcmp -# define memcmp my_memcmp -# endif -#endif /* HAS_MEMCMP */ - #if !defined(HAS_MEMMOVE) && !defined(memmove) # if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY) # define memmove(d,s,l) bcopy(s,d,l) @@ -295,6 +323,31 @@ EXT int lc_collate_active; # endif #endif +#if defined(mips) && defined(ultrix) && !defined(__STDC__) +# undef HAS_MEMCMP +#endif + +#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) +# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) +# ifndef memcmp + extern int memcmp _((char*, char*, int)); +# endif +# endif +# ifdef BUGGY_MSC + # pragma function(memcmp) +# endif +#else +# ifndef memcmp +# define memcmp my_memcmp +# endif +#endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */ + +#ifndef HAS_BCMP +# ifndef bcmp +# define bcmp(s1,s2,l) memcmp(s1,s2,l) +# endif +#endif /* !HAS_BCMP */ + #ifdef I_NETINET_IN # include <netinet/in.h> #endif @@ -335,10 +388,8 @@ EXT int lc_collate_active; # endif #endif -#ifndef MSDOS -# if defined(HAS_TIMES) && defined(I_SYS_TIMES) +#if defined(HAS_TIMES) && defined(I_SYS_TIMES) # include <sys/times.h> -# endif #endif #if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR)) @@ -367,10 +418,8 @@ EXT int lc_collate_active; # define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END #endif -#ifndef MSDOS -# ifndef errno +#ifndef errno extern int errno; /* ANSI allows errno to be an lvalue expr */ -# endif #endif #ifdef HAS_STRERROR @@ -811,6 +860,7 @@ typedef struct magic MAGIC; typedef struct xrv XRV; typedef struct xpv XPV; typedef struct xpviv XPVIV; +typedef struct xpvuv XPVUV; typedef struct xpvnv XPVNV; typedef struct xpvmg XPVMG; typedef struct xpvlv XPVLV; @@ -1136,20 +1186,27 @@ I32 unlnk _((char*)); # endif #endif +typedef Signal_t (*Sighandler_t) _((int)); + +#ifdef HAS_SIGACTION +typedef struct sigaction Sigsave_t; +#else +typedef Sighandler_t Sigsave_t; +#endif + #define SCAN_DEF 0 #define SCAN_TR 1 #define SCAN_REPL 2 -#ifdef MYMALLOC -# ifndef DEBUGGING_MSTATS -# define DEBUGGING_MSTATS -# endif -#endif - #ifdef DEBUGGING # ifndef register # define register # endif +# ifdef MYMALLOC +# ifndef DEBUGGING_MSTATS +# define DEBUGGING_MSTATS +# endif +# endif # define PAD_SV(po) pad_sv(po) #else # define PAD_SV(po) curpad[po] @@ -1185,9 +1242,11 @@ EXT U32 evalseq; /* eval sequence number */ EXT U32 sub_generation; /* inc to force methods to be looked up again */ EXT char ** origenviron; EXT U32 origalen; +EXT HV * pidstatus; /* pid-to-status mappings for waitpid */ EXT U32 * profiledata; EXT int maxo INIT(MAXO);/* Number of ops */ EXT char * osname; /* operating system */ +EXT char * sh_path INIT(SH_PATH); /* full path of shell */ EXT XPV* xiv_arenaroot; /* list of allocated xiv areas */ EXT IV ** xiv_root; /* free xiv list--shared by interpreters */ @@ -1227,7 +1286,6 @@ EXT SV ** curpad; /* temp space */ EXT SV * Sv; -EXT HE He; EXT XPV * Xpv; EXT char buf[2048]; /* should be longer than PATH_MAX */ EXT char tokenbuf[256]; @@ -1243,43 +1301,43 @@ EXT short * ds; EXT char * dc; /* handy constants */ -EXT char * Yes INIT("1"); -EXT char * No INIT(""); -EXT char * hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); -EXT char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"); -EXT char * vert INIT("|"); +EXTCONST char * Yes INIT("1"); +EXTCONST char * No INIT(""); +EXTCONST char * hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); +EXTCONST char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"); +EXTCONST char * vert INIT("|"); -EXT char warn_uninit[] +EXTCONST char warn_uninit[] INIT("Use of uninitialized value"); -EXT char warn_nosemi[] +EXTCONST char warn_nosemi[] INIT("Semicolon seems to be missing"); -EXT char warn_reserved[] +EXTCONST char warn_reserved[] INIT("Unquoted string \"%s\" may clash with future reserved word"); -EXT char warn_nl[] +EXTCONST char warn_nl[] INIT("Unsuccessful %s on filename containing newline"); -EXT char no_wrongref[] +EXTCONST char no_wrongref[] INIT("Can't use %s ref as %s ref"); -EXT char no_symref[] +EXTCONST char no_symref[] INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); -EXT char no_usym[] +EXTCONST char no_usym[] INIT("Can't use an undefined value as %s reference"); -EXT char no_aelem[] +EXTCONST char no_aelem[] INIT("Modification of non-creatable array value attempted, subscript %d"); -EXT char no_helem[] +EXTCONST char no_helem[] INIT("Modification of non-creatable hash value attempted, subscript \"%s\""); -EXT char no_modify[] +EXTCONST char no_modify[] INIT("Modification of a read-only value attempted"); -EXT char no_mem[] +EXTCONST char no_mem[] INIT("Out of memory!\n"); -EXT char no_security[] +EXTCONST char no_security[] INIT("Insecure dependency in %s%s"); -EXT char no_sock_func[] +EXTCONST char no_sock_func[] INIT("Unsupported socket function \"%s\" called"); -EXT char no_dir_func[] +EXTCONST char no_dir_func[] INIT("Unsupported directory function \"%s\" called"); -EXT char no_func[] +EXTCONST char no_func[] INIT("The %s function is unimplemented"); -EXT char no_myglob[] +EXTCONST char no_myglob[] INIT("\"my\" variable %s can't be in a package"); EXT SV sv_undef; @@ -1302,8 +1360,49 @@ EXT SV * psig_ptr[]; EXT SV * psig_name[]; #endif +/* fast case folding tables */ + +#ifdef DOINIT +EXTCONST unsigned char fold[] = { + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 +}; +#else +EXTCONST unsigned char fold[]; +#endif + #ifdef DOINIT -EXT unsigned char fold[] = { /* fast case folding table */ +EXT unsigned char fold_locale[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -1338,11 +1437,11 @@ EXT unsigned char fold[] = { /* fast case folding table */ 248, 249, 250, 251, 252, 253, 254, 255 }; #else -EXT unsigned char fold[]; +EXT unsigned char fold_locale[]; #endif #ifdef DOINIT -EXT unsigned char freq[] = { /* letter frequencies for mixed English/C */ +EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, @@ -1377,12 +1476,12 @@ EXT unsigned char freq[] = { /* letter frequencies for mixed English/C */ 138, 139, 141, 142, 143, 144, 145, 146 }; #else -EXT unsigned char freq[]; +EXTCONST unsigned char freq[]; #endif #ifdef DEBUGGING #ifdef DOINIT -EXT char* block_type[] = { +EXTCONST char* block_type[] = { "NULL", "SUB", "EVAL", @@ -1391,7 +1490,7 @@ EXT char* block_type[] = { "BLOCK", }; #else -EXT char* block_type[]; +EXTCONST char* block_type[]; #endif #endif @@ -1483,7 +1582,7 @@ EXT U32 hints; /* various compilation flags */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 #define HINT_STRICT_VARS 0x00000400 -#define HINT_STRICT_UNTIE 0x00000800 +#define HINT_LOCALE 0x00000800 /**************************************************************************/ /* This regexp stuff is global since it always happens within 1 expr eval */ @@ -1558,7 +1657,6 @@ IEXT bool Idowarn; IEXT bool Idoextract; IEXT bool Isawampersand; /* must save all match strings */ IEXT bool Isawstudy; /* do fbm_instr on all strings */ -IEXT bool Isawi; /* study must assume case insensitive */ IEXT bool Isawvec; IEXT bool Iunsafe; IEXT char * Iinplace; @@ -1566,7 +1664,7 @@ IEXT char * Ie_tmpname; IEXT PerlIO * Ie_fp; IEXT U32 Iperldb; /* This value may be raised by extensions for testing purposes */ -IEXT int Iperl_destruct_level; /* 0=none, 1=full, 2=full with checks */ +IEXT int Iperl_destruct_level IINIT(0); /* 0=none, 1=full, 2=full with checks */ /* magical thingies */ IEXT Time_t Ibasetime; /* $^T */ @@ -1643,7 +1741,6 @@ IEXT int Iforkprocess; /* so do_open |- can return proc# */ /* subprocess state */ IEXT AV * Ifdpid; /* keep fd-to-pid mappings for my_popen */ -IEXT HV * Ipidstatus; /* keep pid-to-status mappings for waitpid */ /* internal state */ IEXT VOL int Iin_eval; /* trap "fatal" errors? */ @@ -1746,6 +1843,7 @@ extern "C" { /* The following must follow proto.h */ #ifdef DOINIT + EXT MGVTBL vtbl_sv = {magic_get, magic_set, magic_len, @@ -1792,9 +1890,19 @@ EXT MGVTBL vtbl_pos = {magic_getpos, 0, 0, 0}; EXT MGVTBL vtbl_bm = {0, magic_setbm, 0, 0, 0}; +EXT MGVTBL vtbl_fm = {0, magic_setfm, + 0, 0, 0}; EXT MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0}; +EXT MGVTBL vtbl_itervar = {magic_getitervar,magic_setitervar, + 0, 0, magic_freeitervar}; + +#ifdef USE_LOCALE_COLLATE +EXT MGVTBL vtbl_collxfrm = {0, + magic_setcollxfrm, + 0, 0, 0}; +#endif #ifdef OVERLOAD EXT MGVTBL vtbl_amagic = {0, magic_setamagic, @@ -1803,7 +1911,8 @@ EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic, 0, 0, magic_setamagic}; #endif /* OVERLOAD */ -#else +#else /* !DOINIT */ + EXT MGVTBL vtbl_sv; EXT MGVTBL vtbl_env; EXT MGVTBL vtbl_envelem; @@ -1823,67 +1932,85 @@ EXT MGVTBL vtbl_substr; EXT MGVTBL vtbl_vec; EXT MGVTBL vtbl_pos; EXT MGVTBL vtbl_bm; +EXT MGVTBL vtbl_fm; EXT MGVTBL vtbl_uvar; +EXT MGVTBL vtbl_itervar; + +#ifdef USE_LOCALE_COLLATE +EXT MGVTBL vtbl_collxfrm; +#endif #ifdef OVERLOAD EXT MGVTBL vtbl_amagic; EXT MGVTBL vtbl_amagicelem; #endif /* OVERLOAD */ -#endif +#endif /* !DOINIT */ #ifdef OVERLOAD EXT long amagic_generation; -#define NofAMmeth 29 +#define NofAMmeth 58 #ifdef DOINIT -EXT char * AMG_names[NofAMmeth][2] = { - {"fallback","abs"}, - {"bool", "nomethod"}, - {"\"\"", "0+"}, - {"+","+="}, - {"-","-="}, - {"*", "*="}, - {"/", "/="}, - {"%", "%="}, - {"**", "**="}, - {"<<", "<<="}, - {">>", ">>="}, - {"&", "&="}, - {"|", "|="}, - {"^", "^="}, - {"<", "<="}, - {">", ">="}, - {"==", "!="}, - {"<=>", "cmp"}, - {"lt", "le"}, - {"gt", "ge"}, - {"eq", "ne"}, - {"!", "~"}, - {"++", "--"}, - {"atan2", "cos"}, - {"sin", "exp"}, - {"log", "sqrt"}, - {"x","x="}, - {".",".="}, - {"=","neg"} +EXTCONST char * AMG_names[NofAMmeth] = { + "fallback", "abs", /* "fallback" should be the first. */ + "bool", "nomethod", + "\"\"", "0+", + "+", "+=", + "-", "-=", + "*", "*=", + "/", "/=", + "%", "%=", + "**", "**=", + "<<", "<<=", + ">>", ">>=", + "&", "&=", + "|", "|=", + "^", "^=", + "<", "<=", + ">", ">=", + "==", "!=", + "<=>", "cmp", + "lt", "le", + "gt", "ge", + "eq", "ne", + "!", "~", + "++", "--", + "atan2", "cos", + "sin", "exp", + "log", "sqrt", + "x", "x=", + ".", ".=", + "=", "neg" }; #else -EXT char * AMG_names[NofAMmeth][2]; +EXTCONST char * AMG_names[NofAMmeth]; #endif /* def INITAMAGIC */ -struct am_table { +struct am_table { long was_ok_sub; long was_ok_am; - CV* table[NofAMmeth*2]; + U32 flags; + CV* table[NofAMmeth]; long fallback; }; +struct am_table_short { + long was_ok_sub; + long was_ok_am; + U32 flags; +}; typedef struct am_table AMT; +typedef struct am_table_short AMTS; #define AMGfallNEVER 1 #define AMGfallNO 2 #define AMGfallYES 3 +#define AMTf_AMAGIC 1 +#define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) +#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) +#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) + enum { fallback_amg, abs_amg, bool__amg, nomethod_amg, @@ -1917,6 +2044,39 @@ enum { }; #endif /* OVERLOAD */ +#ifdef USE_LOCALE_COLLATE +EXT U32 collation_ix; /* Collation generation index */ +EXT char * collation_name; /* Name of current collation */ +EXT bool collation_standard INIT(TRUE); /* Assume simple collation */ +EXT Size_t collxfrm_base; /* Basic overhead in *xfrm() */ +EXT Size_t collxfrm_mult INIT(2); /* Expansion factor in *xfrm() */ +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + +EXT char * numeric_name; /* Name of current numeric locale */ +EXT bool numeric_standard INIT(TRUE); /* Assume simple numerics */ +EXT bool numeric_local INIT(TRUE); /* Assume local numerics */ + +#define SET_NUMERIC_STANDARD() \ + STMT_START { \ + if (! numeric_standard) \ + perl_set_numeric_standard(); \ + } STMT_END + +#define SET_NUMERIC_LOCAL() \ + STMT_START { \ + if (! numeric_local) \ + perl_set_numeric_local(); \ + } STMT_END + +#else /* !USE_LOCALE_NUMERIC */ + +#define SET_NUMERIC_STANDARD() /**/ +#define SET_NUMERIC_LOCAL() /**/ + +#endif /* !USE_LOCALE_NUMERIC */ + #if !defined(PERLIO_IS_STDIO) && defined(HAS_ATTRIBUTE) /* * Now we have __attribute__ out of the way diff --git a/perl_exp.SH b/perl_exp.SH index 3a44e279b2..d964bdf60d 100755 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -1,34 +1,78 @@ #!/bin/sh - +# # Written: Nov 1994 Wayne Scott (wscott@ichips.intel.com) - +# # Create the export list for perl. # Needed by AIX to do dynamic linking. - +# # This simple program relys on 'global.sym' being up to date # with all of the global symbols that a dynamicly link library # might want to access. +# +# Most symbols have a Perl_ prefix because that's what embed.h sticks +# in front of them. Variations depend on binary compatibility with +# Perl 5.003. +# -# All symbols have a Perl_ prefix because that's what embed.h -# sticks in front of them. +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac echo "Extracting perl.exp" rm -f perl.exp echo "#!" > perl.exp -sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym >> perl.exp +case "$bincompat3" in +y*) + ( + global=/tmp/exp$$g + interp=/tmp/exp$$i + compat3=/tmp/exp$$c + trap 'rm -f $global $interp $compat3' 0 + trap 'exit 1' 1 2 3 13 15 + grep '^[A-Za-z]' global.sym | sort >$global + grep '^[A-Za-z]' interp.sym | sort >$interp + grep '^[A-Za-z]' compat3.sym | sort >$compat3 + comm -23 $global $compat3 | sed 's/^/Perl_/' >> perl.exp + comm -12 $interp $compat3 | sed 's/^/Perl_/' >> perl.exp + comm -12 $global $compat3 >> perl.exp + comm -23 $interp $compat3 >> perl.exp + ) + ;; +*) + sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym interp.sym >> perl.exp + ;; +esac -# also add symbols from interp.sym -# They are only needed if -DMULTIPLICITY is not set but it -# doesn't hurt to include them anyway. -sed -n '/^[A-Za-z]/ p' interp.sym >> perl.exp +# +# Extra globals not included above (including a few that might +# not actually be defined, but there's no harm in that). +# -# extra globals not included above. cat <<END >> perl.exp -perl_init_ext -perl_init_fold +perl_init_i18nl10n perl_init_i18nl14n +perl_new_collate +perl_new_ctype +perl_new_numeric +perl_set_numeric_local +perl_set_numeric_standard perl_alloc perl_construct perl_destruct @@ -44,8 +88,12 @@ perl_call_pv perl_call_method perl_call_sv perl_requirepv -safecalloc -safemalloc -saferealloc -safefree +Mymalloc +Mycalloc +Myremalloc +Myfree +Perl_malloc +Perl_calloc +Perl_realloc +Perl_free END @@ -145,7 +145,7 @@ PerlIO_set_cnt(f,cnt) PerlIO *f; int cnt; { - if (cnt < 0) + if (cnt < -1) warn("Setting cnt to %d\n",cnt); #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) FILE_cnt(f) = cnt; @@ -158,19 +158,19 @@ int cnt; void PerlIO_set_ptrcnt(f,ptr,cnt) PerlIO *f; -char *ptr; +STDCHAR *ptr; int cnt; { #ifdef FILE_bufsiz - char *e = (char *)(FILE_base(f) + FILE_bufsiz(f)); - int ec = e - ptr; - if (ptr > e) - warn("Setting ptr %p > base %p\n",ptr, FILE_base(f)+FILE_bufsiz(f)); + STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); + int ec = e - ptr; + if (ptr > e + 1) + warn("Setting ptr %p > end+1 %p\n", ptr, e + 1); if (cnt != ec) warn("Setting cnt to %d, ptr implies %d\n",cnt,ec); #endif #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) - FILE_ptr(f) = (STDCHAR *) ptr; + FILE_ptr(f) = ptr; #else croak("Cannot set 'ptr' of FILE * on this system"); #endif @@ -208,12 +208,12 @@ PerlIO *f; } #undef PerlIO_get_ptr -char * +STDCHAR * PerlIO_get_ptr(f) PerlIO *f; { #ifdef FILE_ptr - return (char *) FILE_ptr(f); + return FILE_ptr(f); #else croak("Cannot get 'ptr' of FILE * on this system"); return NULL; @@ -221,12 +221,12 @@ PerlIO *f; } #undef PerlIO_get_base -char * +STDCHAR * PerlIO_get_base(f) PerlIO *f; { #ifdef FILE_base - return (char *) FILE_base(f); + return FILE_base(f); #else croak("Cannot get 'base' of FILE * on this system"); return NULL; @@ -161,7 +161,7 @@ extern int PerlIO_fast_gets _((PerlIO *)); extern int PerlIO_canset_cnt _((PerlIO *)); #endif #ifndef PerlIO_get_ptr -extern char * PerlIO_get_ptr _((PerlIO *)); +extern STDCHAR * PerlIO_get_ptr _((PerlIO *)); #endif #ifndef PerlIO_get_cnt extern int PerlIO_get_cnt _((PerlIO *)); @@ -170,10 +170,10 @@ extern int PerlIO_get_cnt _((PerlIO *)); extern void PerlIO_set_cnt _((PerlIO *,int)); #endif #ifndef PerlIO_set_ptrcnt -extern void PerlIO_set_ptrcnt _((PerlIO *,char *,int)); +extern void PerlIO_set_ptrcnt _((PerlIO *,STDCHAR *,int)); #endif #ifndef PerlIO_get_base -extern char * PerlIO_get_base _((PerlIO *)); +extern STDCHAR * PerlIO_get_base _((PerlIO *)); #endif #ifndef PerlIO_get_bufsiz extern int PerlIO_get_bufsiz _((PerlIO *)); @@ -12,1088 +12,1001 @@ dep() deprecate("\"do\" to call subroutines"); } +#line 16 "perly.c" #define YYERRCODE 256 short yylhs[] = { -1, - 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, - 7, 21, 21, 21, 21, 21, 21, 11, 11, 11, - 9, 9, 9, 9, 30, 30, 8, 8, 8, 8, - 8, 8, 8, 8, 10, 10, 25, 25, 29, 29, - 1, 1, 1, 1, 2, 2, 32, 32, 28, 28, - 4, 33, 33, 34, 13, 13, 13, 12, 12, 12, - 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 22, 22, 23, 23, 23, 20, - 15, 16, 17, 18, 19, 24, 24, 24, 24, + 45, 0, 9, 7, 10, 8, 11, 11, 11, 12, + 12, 12, 12, 24, 24, 24, 24, 24, 24, 15, + 15, 15, 14, 14, 42, 42, 13, 13, 13, 13, + 13, 13, 13, 26, 26, 27, 27, 28, 29, 30, + 31, 32, 44, 44, 1, 1, 1, 1, 3, 38, + 38, 46, 4, 5, 6, 39, 40, 40, 41, 41, + 47, 47, 49, 48, 16, 16, 16, 25, 25, 25, + 36, 36, 36, 36, 36, 36, 36, 50, 36, 37, + 37, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 33, 33, 34, 34, 34, + 2, 2, 43, 23, 18, 19, 20, 21, 22, 35, + 35, 35, 35, }; short yylen[] = { 2, - 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, - 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, - 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, - 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, - 1, 1, 1, 1, 4, 3, 5, 5, 0, 1, - 0, 3, 2, 6, 3, 3, 1, 2, 3, 1, - 3, 5, 6, 3, 5, 2, 4, 4, 1, 1, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 5, 3, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 3, 2, 3, 2, 4, 3, - 4, 1, 5, 1, 4, 5, 4, 1, 1, 1, - 5, 6, 5, 6, 5, 4, 5, 1, 1, 3, - 4, 3, 2, 2, 4, 5, 4, 5, 1, 2, - 2, 1, 2, 2, 2, 1, 3, 1, 3, 4, - 4, 6, 1, 1, 0, 1, 0, 1, 2, 2, - 2, 2, 2, 2, 2, 1, 1, 1, 1, + 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, + 1, 2, 3, 1, 1, 3, 3, 3, 3, 0, + 2, 6, 7, 7, 0, 2, 8, 8, 10, 9, + 8, 11, 3, 0, 1, 0, 1, 1, 1, 1, + 1, 1, 0, 1, 1, 1, 1, 1, 4, 1, + 0, 5, 0, 0, 0, 1, 0, 1, 1, 1, + 3, 2, 0, 7, 3, 3, 1, 2, 3, 1, + 3, 5, 6, 3, 5, 2, 4, 0, 5, 1, + 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 5, 3, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 3, 2, 3, 2, 4, + 3, 4, 1, 5, 1, 4, 5, 4, 1, 1, + 1, 5, 6, 5, 6, 5, 4, 5, 1, 1, + 3, 4, 3, 2, 2, 4, 5, 4, 5, 1, + 2, 2, 1, 2, 2, 2, 1, 3, 1, 3, + 4, 4, 6, 1, 1, 0, 1, 0, 1, 2, + 1, 1, 1, 2, 2, 2, 2, 2, 2, 1, + 1, 1, 1, }; short yydefred[] = { 1, - 0, 5, 0, 40, 51, 51, 0, 51, 6, 41, - 7, 9, 0, 42, 43, 44, 0, 0, 0, 53, - 0, 12, 4, 143, 0, 0, 118, 0, 138, 0, - 51, 51, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 7, 0, 44, 55, 53, 0, 53, 8, 45, + 9, 11, 0, 46, 47, 48, 0, 0, 0, 62, + 63, 14, 4, 154, 0, 0, 129, 0, 149, 0, + 54, 54, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 161, 162, 0, + 0, 0, 0, 0, 0, 0, 0, 12, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 10, 0, 0, + 0, 0, 119, 121, 0, 0, 0, 0, 155, 50, + 0, 56, 0, 61, 0, 7, 170, 173, 172, 171, + 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, + 4, 4, 0, 0, 0, 0, 0, 144, 0, 0, + 0, 0, 76, 0, 168, 0, 135, 0, 0, 0, + 0, 0, 164, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 109, 0, 165, 166, 167, 169, 0, + 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 10, 0, 0, 0, - 0, 0, 0, 0, 0, 8, 0, 0, 0, 0, - 0, 108, 110, 0, 0, 0, 144, 0, 46, 0, - 52, 0, 5, 156, 159, 158, 157, 0, 0, 0, + 0, 0, 0, 101, 102, 0, 0, 0, 0, 0, + 0, 0, 0, 13, 0, 49, 58, 0, 0, 0, + 74, 0, 0, 78, 0, 0, 0, 0, 0, 0, + 0, 4, 148, 150, 0, 0, 0, 0, 0, 0, + 0, 111, 0, 133, 0, 0, 108, 26, 0, 0, + 19, 0, 0, 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 154, 0, 124, - 0, 0, 0, 0, 0, 0, 150, 0, 0, 0, - 0, 66, 0, 133, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 98, 0, 151, 152, 153, 155, - 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 90, 91, 0, 0, 0, 0, - 0, 0, 0, 0, 11, 45, 50, 0, 0, 0, - 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 36, 0, 137, 139, - 0, 0, 0, 0, 0, 0, 100, 0, 122, 0, - 0, 0, 97, 26, 0, 0, 0, 0, 0, 0, - 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 69, 0, 70, - 0, 0, 0, 0, 0, 0, 0, 120, 0, 48, - 47, 0, 3, 0, 141, 0, 68, 101, 0, 29, - 0, 30, 0, 0, 0, 23, 0, 24, 0, 0, - 0, 140, 149, 67, 0, 125, 0, 127, 0, 99, - 0, 0, 0, 0, 0, 0, 0, 107, 0, 105, - 0, 116, 0, 121, 54, 65, 0, 0, 0, 0, - 19, 0, 0, 0, 0, 0, 62, 126, 128, 115, - 0, 113, 0, 0, 106, 0, 111, 117, 103, 142, - 27, 28, 21, 0, 22, 0, 32, 0, 114, 112, - 63, 0, 0, 31, 0, 0, 20, 33, + 0, 80, 0, 81, 0, 0, 0, 0, 0, 0, + 0, 131, 0, 0, 60, 59, 52, 0, 3, 0, + 152, 0, 0, 112, 0, 41, 0, 42, 0, 0, + 0, 0, 163, 0, 0, 35, 40, 0, 0, 0, + 151, 160, 77, 0, 136, 0, 138, 0, 110, 0, + 0, 0, 0, 0, 0, 0, 118, 0, 116, 0, + 127, 0, 132, 0, 75, 0, 79, 0, 0, 0, + 0, 0, 0, 0, 0, 72, 137, 139, 126, 0, + 124, 0, 0, 117, 0, 122, 128, 114, 64, 153, + 6, 0, 0, 0, 0, 0, 0, 0, 0, 125, + 123, 73, 7, 27, 28, 0, 0, 23, 24, 0, + 31, 0, 0, 0, 21, 0, 0, 0, 30, 5, + 0, 29, 0, 0, 32, 0, 22, }; short yydgoto[] = { 1, - 9, 10, 83, 17, 86, 3, 11, 12, 66, 195, - 266, 67, 202, 69, 70, 71, 72, 73, 74, 75, - 197, 122, 203, 88, 187, 77, 241, 178, 13, 142, - 2, 14, 15, 16, + 9, 66, 10, 18, 95, 17, 86, 333, 89, 322, + 3, 11, 12, 68, 338, 260, 70, 71, 72, 73, + 74, 75, 76, 266, 78, 267, 256, 258, 261, 269, + 257, 259, 113, 197, 91, 79, 235, 81, 83, 178, + 247, 142, 264, 13, 2, 14, 15, 16, 85, 253, }; short yysindex[] = { 0, - 0, 0, 303, 0, 0, 0, -53, 0, 0, 0, - 0, 0, 607, 0, 0, 0, -111, -242, -32, 0, - -216, 0, 0, 0, 149, 149, 0, 8, 0, 2109, - 0, 0, -15, -8, 4, 6, 32, 2109, 13, 20, - 57, 149, 994, 2109, 1057, -206, 149, 2109, 938, 1291, - 2109, 2109, 2109, 2109, 2109, 1347, 0, 2109, 2109, 1403, - 149, 149, 149, 149, -203, 0, 68, 664, 491, -67, - -52, 0, 0, -21, 73, 65, 0, 7, 0, -135, - 0, -126, 0, 0, 0, 0, 0, 2109, 92, 2109, - 491, 7, -135, 2109, 7, 2109, 7, 2109, 7, 2109, - 7, 1466, 101, 491, 112, 1700, 938, 0, 102, 0, - 1228, -22, 1228, 39, -58, 2109, 0, 68, 0, 68, - -67, 0, 2109, 0, 1228, 472, 472, 472, -88, -88, - 78, -10, 472, 472, 0, -85, 0, 0, 0, 0, - 7, 0, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 0, 0, -29, 2109, 2109, 2109, - 2109, 2109, 2109, 1756, 0, 0, 0, -46, 2109, 391, - 0, 2109, -25, 2109, 7, -214, 129, -203, -5, -203, - 1, -167, 9, -167, 117, 52, 0, 2109, 0, 0, - 23, 60, 132, 2109, 1812, 1875, 0, 53, 0, 68, - 2109, 86, 0, 0, 491, -214, -214, -214, -214, -147, - 0, -54, 382, 1228, 1090, 771, 115, 491, 2942, 1523, - 314, 1554, 392, 677, 472, 472, 2109, 0, 2109, 0, - 141, 89, -42, 99, 46, 114, 64, 0, 26, 0, - 0, 124, 0, 143, 0, 2109, 0, 0, 7, 0, - 7, 0, 7, 7, 146, 0, 7, 0, 2109, 7, - 35, 0, 0, 0, 37, 0, 49, 0, 55, 0, - 130, 2109, 63, 2109, 67, 166, 2109, 0, 66, 0, - 71, 0, 74, 0, 0, 0, 1170, -203, -203, -167, - 0, 2109, -167, 131, -203, 7, 0, 0, 0, 0, - 185, 0, 1119, 76, 0, 161, 0, 0, 0, 0, - 0, 0, 0, 58, 0, 1466, 0, -203, 0, 0, - 0, 7, 162, 0, -167, 7, 0, 0, + 0, 0, -126, 0, 0, 0, -58, 0, 0, 0, + 0, 0, 827, 0, 0, 0, -242, -235, -21, 0, + 0, 0, 0, 0, -33, -33, 0, 11, 0, 1816, + 0, 0, 13, 15, 30, 45, -29, 1816, 67, 68, + 70, 1002, 939, -33, 1236, 1292, -227, 0, 0, -33, + 1816, 1816, 1816, 1816, 1816, 1816, 1173, 0, 1816, 1816, + 1348, -33, -33, -33, -33, 1816, -220, 0, -169, 3558, + -78, -59, 0, 0, -62, 73, 42, 65, 0, 0, + -5, 0, -149, 0, -134, 0, 0, 0, 0, 0, + 1816, 97, 1816, 1847, -5, -149, 0, 0, 0, 0, + 0, 0, 99, 3558, 105, 1407, 939, 0, 1847, 0, + -78, 65, 0, 1816, 0, 107, 0, 1847, -23, 36, + -51, 1816, 0, 65, -82, -82, -82, -54, -54, 57, + -27, -82, -82, 0, -87, 0, 0, 0, 0, 1847, + -5, 0, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, + 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, + 1816, 1816, 1816, 0, 0, -32, 1816, 1816, 1816, 1816, + 1816, 1816, 1582, 0, 1816, 0, 0, -36, -108, 665, + 0, 1816, 209, 0, -5, 1816, 1816, 1816, 1816, 114, + 1641, 0, 0, 0, -16, 6, 111, 1816, 65, 1697, + 1753, 0, 38, 0, 1816, 74, 0, 0, -251, -251, + 0, -251, -251, -131, 0, 18, 3516, 1847, 1089, 382, + 92, 3558, 3594, 3689, 369, 1060, 482, 285, -82, -82, + 1816, 0, 1816, 0, 128, 33, 23, 58, 25, 69, + 27, 0, -14, 3558, 0, 0, 0, 1816, 0, 131, + 0, 1816, 1816, 0, -251, 0, 134, 0, 136, -251, + 139, 141, 0, 144, -169, 0, 0, 156, 135, 1816, + 0, 0, 0, -12, 0, -10, 0, 1, 0, 71, + 1816, 75, 1816, 29, 86, 1816, 0, 76, 0, 78, + 0, 81, 0, 148, 0, 339, 0, 85, 85, 85, + 85, 1816, 85, 1816, 168, 0, 0, 0, 0, 88, + 0, 3653, 89, 0, 172, 0, 0, 0, 0, 0, + 0, -220, -220, -178, -178, 175, -220, 160, 85, 0, + 0, 0, 0, 0, 0, 85, 203, 0, 0, 85, + 0, 1641, -220, 688, 0, 1816, -220, 180, 0, 0, + 196, 0, 85, 85, 0, -178, 0, }; short yyrindex[] = { 0, 0, 0, 269, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 122, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2076, 1906, 0, + 0, 2716, 2784, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 79, 0, -7, 181, + 2827, 2871, 0, 0, 2142, 1965, 0, 21, 0, 0, + 0, 0, -31, 0, 0, 0, 0, 0, 0, 0, + 2201, 0, 0, 3299, 0, 129, 0, 0, 0, 0, + 0, 0, 0, 197, 0, 0, 213, 0, 3343, 444, + 545, 2312, 0, 0, 0, 2028, 0, 3386, 2827, 0, + 0, 2201, 0, 2437, 2914, 2952, 2990, 606, 723, 2480, + 0, 3063, 3107, 0, 0, 0, 0, 0, 0, 3424, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 2241, 1964, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 2857, 2901, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 107, 0, 360, -1, 62, 3027, - 3078, 0, 0, 2286, 2020, 0, 0, 0, 0, -12, - 0, 0, 0, 0, 0, 0, 0, 2415, 0, 0, - 1251, 0, 82, 173, 0, 0, 0, 0, 0, 0, - 0, 157, 0, 1661, 0, 0, 178, 0, 2150, 0, - 3927, 3027, 3958, 0, 0, 2415, 0, 2537, 454, 2581, - 548, 0, 0, 0, 3989, 3384, 3425, 3461, 3122, 3163, - 2636, 0, 3497, 3533, 0, 0, 0, 0, 0, 0, - 0, 0, 2680, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 2548, 0, 0, 0, 0, 883, + 0, 213, 0, 0, 0, 234, 0, 0, 0, 0, + 218, 0, 0, 0, 0, 239, 0, 0, 2591, 0, + 0, 0, 0, 0, 0, 2635, 0, 0, -2, 8, + 0, 22, 24, 525, 0, 0, 3579, 1448, 1504, 3226, + -39, 338, 0, 2490, 3535, 3498, 3462, 3262, 3150, 3188, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 163, 882, - 0, 178, 0, 2415, 0, 2, 0, 107, 0, 107, - 0, 175, 0, 175, 0, 165, 0, 0, 0, 0, - 0, 180, 0, 0, 0, 0, 0, 0, 0, 2723, - 0, 2985, 0, 0, 2785, 11, 14, 33, 59, 833, - 0, 0, -30, 4020, 4036, 3817, 3850, 3275, 0, 1611, - 4179, 4114, 4098, 3894, 3569, 3646, 0, 0, 0, 0, + 0, 0, 0, 1870, 0, 0, 0, 230, 0, 0, + 0, 0, 2201, 0, 37, 0, 0, 0, 0, 251, + 0, 0, 0, 0, 61, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 213, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 168, 0, + 0, 0, 0, 238, 0, 0, 0, 0, 0, 0, + 0, 718, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 79, 79, 153, 153, 0, 79, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 178, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 107, 107, 175, - 0, 0, 175, 0, 107, 0, 0, 0, 0, 0, - 0, 0, 2462, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 190, 0, 107, 0, 0, - 0, 0, 0, 0, 175, 0, 0, 0, + 0, 260, 79, 883, 0, 0, 79, 0, 0, 0, + 0, 0, 0, 0, 0, 153, 0, }; short yygindex[] = { 0, - 0, 0, 0, 148, -13, 106, 0, 0, 0, -91, - -184, 452, -11, 4373, 886, 0, 0, 0, 0, 0, - 234, -62, -173, 460, -20, 0, 0, 174, 0, -131, - 0, 0, 0, 0, + 0, 0, 0, 300, 278, 0, -26, 0, 892, 1004, + -76, 0, 0, 0, -313, -13, 3871, 3724, 0, 0, + 0, 0, 0, 304, -25, 0, 0, 169, -175, -8, + 53, 152, 384, -161, 901, 0, 0, 0, 0, 281, + 0, -287, 0, 0, 0, 0, 0, 0, 0, 0, }; -#define YYTABLESIZE 4657 -short yytable[] = { 65, - 208, 68, 168, 79, 283, 20, 61, 213, 254, 268, - 80, 23, 250, 80, 80, 255, 289, 206, 256, 95, - 97, 99, 101, 170, 94, 181, 81, 80, 80, 110, - 212, 96, 80, 115, 150, 261, 124, 157, 172, 13, - 82, 263, 38, 98, 132, 100, 49, 90, 136, 267, - 116, 16, 105, 209, 17, 169, 260, 13, 262, 106, - 38, 239, 80, 272, 176, 168, 294, 61, 170, 16, - 171, 102, 17, 14, 141, 306, 23, 307, 184, 148, - 149, 188, 186, 190, 189, 192, 191, 194, 193, 308, - 196, 14, 270, 237, 201, 309, 107, 150, 332, 15, - 169, 173, 60, 273, 291, 60, 25, 23, 264, 265, - 49, 143, 174, 316, 23, 323, 252, 15, 325, 60, - 60, 257, 293, 175, 177, 314, 23, 214, 23, 23, - 179, 182, 216, 217, 218, 219, 220, 221, 222, 25, - 198, 205, 25, 25, 25, 78, 25, 149, 25, 25, - 337, 25, 199, 18, 60, 21, 242, 243, 244, 245, - 246, 247, 249, 207, 251, 25, 321, 322, 211, 259, - 25, 258, 274, 327, 18, 269, 282, 280, 92, 93, - 287, 288, 295, 296, 61, 302, 271, 312, 180, 326, - 317, 290, 275, 277, 279, 318, 334, 25, 319, 281, - 330, 331, 336, 19, 49, 168, 292, 18, 148, 149, - 18, 18, 18, 37, 18, 35, 18, 18, 147, 18, - 148, 145, 310, 13, 167, 285, 37, 286, 238, 25, - 35, 25, 25, 18, 333, 148, 149, 150, 18, 148, - 149, 80, 80, 80, 80, 298, 76, 299, 304, 300, - 301, 148, 149, 303, 0, 151, 305, 186, 315, 152, - 153, 154, 155, 80, 80, 18, 185, 80, 2, 0, - 311, 23, 156, 158, 159, 160, 161, 329, 162, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 148, 149, - 324, 0, 328, 0, 148, 149, 0, 18, 0, 18, - 18, 39, 148, 149, 39, 39, 39, 0, 39, 0, - 39, 39, 0, 39, 68, 0, 148, 149, 335, 148, - 149, 0, 338, 144, 145, 146, 147, 39, 148, 149, - 148, 149, 39, 60, 60, 60, 60, 0, 0, 148, - 149, 0, 148, 149, 0, 148, 149, 0, 148, 149, - 0, 148, 149, 148, 149, 60, 60, 148, 149, 39, - 148, 149, 25, 25, 25, 25, 25, 25, 0, 25, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 148, 149, 0, 25, 25, 0, 25, 25, - 25, 39, 148, 149, 39, 25, 25, 25, 25, 25, - 57, 154, 25, 25, 168, 84, 0, 148, 149, 25, - 85, 0, 0, 25, 0, 25, 25, 0, 57, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 0, 0, - 18, 18, 18, 18, 18, 18, 150, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 0, 0, 57, 18, 18, 0, 18, 18, 18, 148, - 149, 0, 0, 18, 18, 18, 18, 18, 0, 0, - 18, 18, 168, 0, 0, 0, 0, 18, 148, 149, - 0, 18, 168, 18, 18, 89, 156, 0, 0, 156, - 156, 156, 0, 156, 143, 156, 156, 143, 156, 118, - 120, 108, 0, 0, 150, 0, 117, 0, 123, 0, - 0, 143, 143, 0, 150, 253, 143, 156, 0, 0, - 137, 138, 139, 140, 39, 39, 39, 39, 39, 39, - 0, 39, 39, 39, 0, 0, 0, 39, 0, 120, - 39, 39, 39, 39, 143, 0, 143, 39, 39, 0, - 39, 39, 39, 157, 0, 0, 0, 39, 39, 39, - 39, 39, 168, 0, 39, 39, 204, 120, 4, 5, - 6, 39, 7, 8, 210, 39, 143, 39, 39, 156, - 157, 168, 0, 157, 157, 157, 0, 157, 102, 157, - 157, 102, 157, 0, 150, 0, 0, 0, 152, 153, - 154, 155, 0, 0, 0, 102, 102, 0, 0, 0, - 102, 157, 0, 150, 160, 161, 0, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 120, 57, 57, 57, 57, 120, 0, 0, 0, 51, - 102, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 57, 57, 0, 4, 5, 6, 0, - 7, 8, 0, 0, 0, 57, 152, 153, 154, 155, - 62, 0, 0, 157, 0, 0, 152, 153, 154, 155, - 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, - 0, 0, 165, 166, 167, 162, 163, 60, 0, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 0, 0, - 156, 156, 156, 156, 156, 0, 156, 156, 156, 0, - 0, 0, 156, 0, 0, 143, 143, 143, 143, 23, - 0, 0, 52, 156, 143, 156, 156, 156, 143, 143, - 143, 143, 156, 156, 156, 156, 156, 143, 143, 156, - 156, 143, 143, 143, 143, 143, 156, 143, 143, 0, - 156, 143, 156, 156, 143, 143, 143, 168, 0, 0, - 0, 151, 0, 0, 0, 152, 153, 154, 155, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 156, 158, - 159, 160, 161, 0, 162, 163, 0, 0, 164, 150, - 0, 165, 166, 167, 157, 157, 157, 157, 157, 0, - 157, 157, 157, 0, 0, 0, 157, 0, 0, 102, - 102, 102, 102, 0, 0, 0, 0, 157, 102, 157, - 157, 157, 102, 102, 102, 102, 157, 157, 157, 157, - 157, 102, 102, 157, 157, 102, 102, 102, 102, 102, - 157, 102, 102, 0, 157, 102, 157, 157, 102, 102, - 102, 168, 22, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 56, 0, 32, 56, 0, 33, 34, - 35, 36, 0, 0, 0, 37, 38, 0, 39, 40, - 41, 56, 0, 150, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 0, 0, 0, 0, 0, 50, - 87, 87, 0, 53, 39, 54, 55, 39, 39, 39, - 0, 39, 103, 39, 39, 56, 39, 87, 112, 0, - 0, 0, 87, 0, 121, 144, 145, 146, 147, 0, - 39, 0, 0, 0, 0, 39, 87, 87, 87, 87, - 0, 0, 0, 0, 0, 0, 0, 148, 149, 0, - 0, 0, 0, 154, 155, 0, 0, 0, 0, 0, - 51, 0, 39, 61, 63, 47, 0, 56, 0, 64, - 59, 163, 58, 0, 164, 0, 0, 165, 166, 167, - 0, 0, 121, 0, 0, 0, 0, 0, 0, 0, - 0, 62, 0, 0, 39, 0, 0, 39, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 51, 0, 60, 61, - 63, 47, 0, 56, 0, 64, 59, 0, 58, 0, +#define YYTABLESIZE 4154 +short yytable[] = { 69, + 20, 85, 62, 62, 85, 207, 62, 203, 167, 180, + 102, 339, 169, 206, 80, 268, 201, 112, 85, 85, + 250, 82, 245, 85, 271, 124, 293, 57, 306, 122, + 307, 171, 121, 15, 334, 335, 167, 84, 18, 341, + 149, 308, 357, 131, 168, 147, 148, 135, 38, 272, + 93, 15, 97, 85, 98, 349, 18, 141, 233, 352, + 172, 67, 16, 170, 17, 112, 38, 169, 149, 99, + 186, 187, 188, 189, 190, 191, 282, 37, 25, 67, + 16, 288, 17, 290, 100, 292, 23, 313, 199, 23, + 231, 57, 195, 196, 305, 37, 112, 336, 337, 168, + 174, 39, 143, 144, 145, 146, 105, 106, 175, 107, + 177, 25, 173, 67, 25, 25, 25, 23, 25, 15, + 25, 25, 179, 25, 315, 287, 326, 147, 148, 209, + 210, 212, 213, 214, 215, 216, 182, 25, 192, 4, + 5, 6, 25, 7, 8, 193, 200, 205, 248, 62, + 289, 273, 20, 236, 237, 238, 239, 240, 241, 243, + 202, 291, 279, 309, 281, 270, 148, 286, 196, 25, + 351, 295, 255, 210, 298, 210, 299, 265, 314, 300, + 330, 301, 167, 302, 274, 20, 276, 278, 20, 20, + 20, 280, 20, 304, 20, 20, 303, 20, 19, 311, + 316, 25, 317, 25, 25, 318, 319, 321, 329, 147, + 148, 20, 332, 331, 149, 340, 20, 284, 342, 285, + 353, 70, 112, 87, 70, 232, 163, 112, 88, 164, + 165, 166, 85, 85, 85, 85, 354, 141, 70, 70, + 141, 85, 346, 20, 51, 147, 148, 85, 85, 251, + 85, 57, 252, 158, 141, 141, 344, 85, 85, 166, + 85, 85, 85, 85, 85, 85, 101, 310, 2, 147, + 148, 156, 196, 70, 36, 20, 34, 20, 20, 159, + 147, 148, 147, 148, 147, 148, 147, 148, 156, 141, + 255, 39, 67, 67, 67, 67, 36, 147, 148, 167, + 34, 43, 147, 148, 43, 43, 43, 21, 43, 96, + 43, 43, 211, 43, 147, 148, 77, 67, 67, 147, + 148, 147, 148, 147, 148, 147, 148, 43, 69, 147, + 148, 149, 43, 348, 25, 25, 25, 25, 25, 25, + 262, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 147, 148, 328, 25, 25, 43, + 25, 25, 25, 25, 25, 147, 148, 147, 148, 25, + 25, 25, 25, 25, 25, 167, 185, 25, 82, 320, + 153, 82, 147, 148, 147, 148, 25, 0, 25, 25, + 0, 43, 0, 0, 43, 82, 82, 162, 0, 0, + 163, 156, 0, 164, 165, 166, 0, 149, 20, 20, + 20, 20, 20, 20, 0, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 0, 167, + 82, 20, 20, 0, 20, 20, 20, 20, 20, 0, + 0, 0, 0, 20, 20, 20, 20, 20, 20, 0, + 0, 20, 70, 70, 70, 70, 0, 0, 0, 167, + 20, 149, 20, 20, 0, 0, 0, 0, 141, 141, + 141, 141, 167, 0, 181, 0, 170, 70, 70, 170, + 170, 170, 0, 170, 154, 170, 170, 154, 170, 150, + 0, 149, 0, 141, 141, 151, 152, 153, 154, 0, + 0, 154, 154, 0, 149, 204, 154, 170, 155, 157, + 158, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 43, 43, 43, 43, 43, 43, + 0, 43, 43, 43, 154, 0, 154, 43, 0, 0, + 43, 43, 43, 43, 0, 0, 0, 43, 43, 0, + 43, 43, 43, 43, 43, 0, 0, 0, 0, 43, + 43, 43, 43, 43, 43, 66, 154, 43, 66, 170, + 0, 0, 167, 153, 154, 0, 43, 171, 43, 43, + 171, 171, 171, 66, 171, 113, 171, 171, 113, 171, + 162, 0, 0, 163, 0, 0, 164, 165, 166, 0, + 0, 0, 113, 113, 149, 0, 0, 113, 171, 82, + 82, 82, 82, 0, 0, 0, 0, 66, 0, 150, + 0, 0, 0, 0, 0, 151, 152, 153, 154, 0, + 0, 294, 0, 0, 82, 82, 297, 113, 155, 157, + 158, 159, 160, 161, 162, 0, 103, 163, 0, 103, + 164, 165, 166, 0, 0, 151, 152, 153, 154, 0, + 0, 0, 0, 103, 103, 0, 0, 0, 103, 0, + 171, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 162, 0, 0, + 163, 0, 0, 164, 165, 166, 0, 0, 103, 0, + 170, 170, 170, 170, 170, 0, 170, 170, 170, 0, + 0, 0, 170, 0, 0, 154, 154, 154, 154, 0, + 0, 0, 0, 170, 154, 170, 170, 170, 170, 170, + 154, 154, 154, 154, 170, 170, 170, 170, 170, 170, + 154, 154, 170, 154, 154, 154, 154, 154, 154, 154, + 0, 170, 154, 170, 170, 154, 154, 154, 94, 0, + 0, 94, 0, 104, 0, 0, 104, 0, 151, 152, + 153, 154, 0, 0, 0, 94, 94, 0, 0, 0, + 104, 104, 0, 0, 0, 104, 161, 162, 0, 249, + 163, 0, 0, 164, 165, 166, 66, 66, 66, 66, + 0, 171, 171, 171, 171, 171, 0, 171, 171, 171, + 94, 0, 350, 171, 0, 104, 113, 113, 113, 113, + 0, 66, 0, 0, 171, 113, 171, 171, 171, 171, + 171, 113, 113, 113, 113, 171, 171, 171, 171, 171, + 171, 113, 113, 171, 113, 113, 113, 113, 113, 113, + 113, 0, 171, 113, 171, 171, 113, 113, 113, 52, + 0, 0, 62, 64, 50, 0, 57, 0, 65, 60, + 0, 59, 0, 0, 0, 0, 0, 103, 103, 103, + 103, 0, 0, 0, 0, 58, 103, 0, 0, 0, + 63, 0, 103, 103, 103, 103, 0, 0, 0, 0, + 0, 0, 103, 103, 67, 103, 103, 103, 103, 103, + 103, 103, 0, 0, 103, 43, 0, 61, 43, 43, + 43, 0, 43, 0, 43, 43, 92, 43, 0, 0, + 4, 5, 6, 108, 7, 8, 117, 0, 0, 0, + 0, 43, 0, 114, 115, 0, 43, 0, 0, 23, + 123, 0, 53, 4, 5, 6, 0, 7, 8, 0, + 0, 0, 136, 137, 138, 139, 0, 0, 0, 0, + 0, 52, 176, 43, 62, 64, 50, 0, 57, 0, + 65, 60, 0, 59, 0, 0, 184, 0, 0, 94, + 94, 94, 94, 0, 104, 104, 104, 104, 0, 0, + 0, 0, 63, 104, 0, 43, 0, 198, 43, 104, + 104, 104, 104, 0, 94, 94, 0, 94, 0, 104, + 104, 0, 104, 104, 104, 104, 104, 104, 104, 61, + 0, 104, 208, 0, 52, 0, 0, 62, 64, 50, + 0, 57, 0, 65, 60, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 240, 0, 0, 0, 0, 62, 0, 0, - 23, 0, 0, 52, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 163, 0, 0, 164, 0, - 0, 165, 166, 167, 60, 0, 0, 0, 0, 51, - 0, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 0, 56, 56, 56, 56, 0, 0, - 0, 0, 0, 0, 0, 114, 23, 0, 0, 52, - 62, 0, 0, 0, 0, 0, 56, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, - 39, 39, 39, 0, 39, 39, 39, 60, 0, 0, - 39, 0, 0, 39, 39, 39, 39, 0, 0, 0, - 39, 39, 0, 39, 39, 39, 0, 0, 0, 0, - 39, 39, 39, 39, 39, 0, 0, 39, 39, 0, - 168, 157, 52, 0, 39, 0, 0, 0, 39, 0, - 39, 39, 0, 0, 119, 25, 26, 27, 28, 85, - 29, 30, 31, 0, 0, 0, 32, 0, 0, 168, - 320, 0, 150, 0, 0, 0, 0, 38, 0, 39, - 40, 41, 0, 0, 0, 0, 42, 43, 44, 45, - 46, 0, 157, 48, 49, 0, 0, 0, 0, 0, - 50, 150, 0, 0, 53, 0, 54, 55, 0, 0, - 109, 25, 26, 27, 28, 0, 29, 30, 31, 0, - 168, 0, 32, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 38, 0, 39, 40, 41, 0, 0, - 0, 0, 42, 43, 44, 45, 46, 0, 0, 48, - 49, 135, 150, 0, 135, 0, 50, 0, 0, 0, - 53, 0, 54, 55, 0, 0, 0, 0, 135, 135, - 0, 0, 0, 24, 25, 26, 27, 28, 168, 29, - 30, 31, 0, 51, 0, 32, 61, 63, 47, 0, - 56, 0, 64, 59, 0, 58, 38, 0, 39, 40, - 41, 0, 0, 135, 0, 42, 43, 44, 45, 46, - 150, 0, 48, 49, 62, 0, 0, 0, 0, 50, - 0, 0, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 0, 0, 152, 0, 154, 155, 0, 51, - 0, 60, 61, 63, 47, 0, 56, 131, 64, 59, - 0, 58, 0, 162, 163, 0, 0, 164, 0, 151, - 165, 166, 167, 152, 153, 154, 155, 0, 0, 0, - 62, 0, 0, 23, 0, 0, 52, 158, 159, 160, - 161, 0, 162, 163, 0, 0, 164, 0, 0, 165, - 166, 167, 0, 0, 0, 51, 0, 60, 61, 63, - 47, 0, 56, 0, 64, 59, 0, 58, 0, 0, - 151, 0, 0, 0, 152, 153, 154, 155, 0, 0, - 0, 0, 0, 0, 0, 0, 62, 156, 158, 159, - 160, 161, 52, 162, 163, 0, 0, 164, 0, 0, - 165, 166, 167, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 60, 0, 135, 0, 0, 51, 0, - 0, 61, 63, 47, 0, 56, 0, 64, 59, 0, - 58, 0, 0, 0, 154, 155, 0, 0, 0, 0, - 0, 0, 135, 135, 135, 135, 0, 0, 52, 62, - 0, 162, 163, 0, 0, 164, 0, 0, 165, 166, - 167, 0, 0, 0, 135, 135, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 60, 0, 0, 32, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, - 43, 44, 45, 46, 0, 0, 48, 49, 0, 0, - 0, 52, 0, 50, 0, 0, 0, 53, 0, 54, - 55, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 168, 0, 32, 0, 0, 0, 0, + 0, 23, 0, 0, 53, 63, 0, 0, 0, 246, + 0, 0, 0, 0, 0, 0, 254, 0, 0, 0, + 0, 0, 22, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 61, 0, 0, 32, 0, 0, 33, 34, + 35, 36, 0, 0, 0, 37, 38, 0, 39, 40, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 23, 51, 0, 53, 0, 0, + 0, 0, 0, 0, 54, 0, 55, 56, 43, 43, + 43, 43, 43, 43, 0, 43, 43, 43, 0, 0, + 167, 43, 0, 0, 43, 43, 43, 43, 0, 0, + 0, 43, 43, 0, 43, 43, 43, 43, 43, 0, + 0, 0, 0, 43, 43, 43, 43, 43, 43, 167, + 0, 43, 149, 0, 0, 0, 0, 0, 0, 0, + 43, 0, 43, 43, 0, 110, 25, 26, 27, 28, + 88, 29, 30, 31, 0, 52, 0, 32, 62, 64, + 50, 149, 57, 130, 65, 60, 0, 59, 38, 0, + 39, 40, 41, 42, 43, 0, 0, 0, 0, 44, + 45, 46, 47, 48, 49, 0, 63, 51, 0, 0, + 0, 0, 0, 0, 0, 0, 54, 0, 55, 56, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 25, + 26, 27, 28, 61, 29, 30, 31, 0, 52, 0, + 32, 62, 64, 50, 0, 57, 0, 65, 60, 0, + 59, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 53, 63, + 51, 0, 323, 324, 325, 0, 327, 0, 0, 54, + 0, 55, 56, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 52, 0, 61, 62, 64, 50, + 0, 57, 343, 65, 60, 0, 59, 0, 0, 345, + 0, 0, 0, 347, 0, 0, 151, 152, 153, 154, + 120, 0, 0, 0, 0, 63, 355, 356, 23, 0, + 0, 53, 0, 160, 161, 162, 0, 0, 163, 0, + 0, 164, 165, 166, 0, 151, 0, 153, 154, 0, + 52, 0, 61, 62, 64, 50, 0, 57, 0, 65, + 60, 0, 59, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 0, 0, 0, + 0, 63, 0, 0, 0, 0, 0, 53, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 24, + 25, 26, 27, 28, 0, 29, 30, 31, 61, 52, + 134, 32, 62, 64, 50, 0, 57, 194, 65, 60, + 0, 59, 38, 0, 39, 40, 41, 42, 43, 0, + 0, 0, 0, 44, 45, 46, 47, 48, 49, 0, + 63, 51, 0, 53, 0, 0, 0, 0, 0, 0, + 54, 0, 55, 56, 0, 0, 0, 0, 87, 0, + 0, 87, 116, 25, 26, 27, 28, 61, 29, 30, + 31, 0, 0, 0, 32, 87, 87, 0, 0, 0, + 87, 0, 0, 0, 0, 38, 0, 39, 40, 41, + 42, 43, 0, 0, 0, 0, 44, 45, 46, 47, + 48, 49, 53, 0, 51, 0, 0, 0, 0, 0, + 87, 0, 0, 54, 88, 55, 56, 88, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 0, 0, 0, + 32, 88, 88, 0, 0, 0, 88, 0, 0, 0, + 0, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 0, 0, + 51, 0, 0, 0, 0, 0, 88, 0, 0, 54, + 0, 55, 56, 0, 24, 25, 26, 27, 28, 0, + 29, 30, 31, 0, 52, 0, 32, 62, 64, 50, + 0, 57, 242, 65, 60, 0, 59, 38, 0, 39, + 40, 41, 42, 43, 0, 0, 0, 0, 44, 45, + 46, 47, 48, 49, 0, 63, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 54, 0, 55, 56, 0, + 0, 0, 0, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 61, 52, 0, 32, 62, 64, 50, 0, + 57, 0, 65, 60, 0, 59, 38, 0, 39, 40, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 63, 51, 0, 53, 0, 0, + 0, 0, 0, 0, 54, 0, 55, 56, 0, 87, + 87, 87, 87, 0, 0, 0, 0, 0, 87, 52, + 0, 61, 62, 64, 50, 87, 57, 275, 65, 60, + 0, 59, 0, 0, 87, 87, 0, 87, 87, 87, + 87, 87, 0, 0, 0, 0, 0, 0, 0, 0, + 63, 0, 0, 0, 0, 0, 53, 0, 0, 0, + 0, 0, 0, 0, 0, 88, 88, 88, 88, 0, + 0, 0, 0, 0, 88, 52, 0, 61, 62, 64, + 50, 0, 57, 277, 65, 60, 0, 59, 0, 0, + 88, 88, 0, 88, 88, 88, 88, 88, 0, 0, + 0, 0, 0, 0, 0, 0, 63, 0, 0, 0, + 0, 0, 53, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 25, + 26, 27, 28, 61, 29, 30, 31, 0, 52, 0, + 32, 62, 64, 50, 0, 57, 0, 65, 60, 0, + 59, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 53, 63, + 51, 0, 0, 0, 0, 0, 0, 0, 0, 54, + 0, 55, 56, 0, 0, 0, 22, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 61, 0, 0, 32, + 69, 0, 0, 69, 0, 0, 0, 0, 0, 0, + 38, 0, 39, 40, 41, 42, 43, 69, 69, 0, + 0, 44, 45, 46, 47, 48, 49, 167, 0, 51, + 0, 53, 0, 0, 0, 0, 147, 0, 54, 147, + 55, 56, 0, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 69, 147, 147, 32, 0, 0, 147, 149, 0, 0, 0, 0, 0, 0, 38, 0, 39, 40, - 41, 0, 0, 0, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 168, 150, 0, 0, 0, 50, - 0, 82, 0, 53, 82, 54, 55, 0, 0, 24, - 25, 26, 27, 28, 0, 29, 30, 31, 82, 82, - 0, 32, 0, 82, 0, 0, 150, 0, 0, 0, - 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, - 0, 42, 43, 44, 45, 46, 0, 0, 48, 49, - 0, 130, 0, 82, 130, 50, 0, 0, 0, 53, - 0, 54, 55, 0, 0, 0, 0, 0, 130, 130, - 0, 22, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 0, 51, 0, 32, 61, 63, 47, 0, 56, - 200, 64, 59, 0, 58, 38, 0, 39, 40, 41, - 0, 0, 0, 130, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 62, 0, 0, 0, 0, 50, 0, - 0, 0, 53, 0, 54, 55, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 51, 0, - 60, 61, 63, 47, 0, 56, 248, 64, 59, 0, - 58, 0, 0, 0, 0, 0, 0, 152, 153, 154, - 155, 0, 0, 0, 0, 0, 0, 0, 0, 62, - 0, 0, 159, 160, 161, 52, 162, 163, 0, 0, - 164, 0, 0, 165, 166, 167, 0, 0, 152, 153, - 154, 155, 0, 0, 51, 0, 60, 61, 63, 47, - 0, 56, 276, 64, 59, 161, 58, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 0, 0, 0, 0, 0, 62, 0, 0, 0, 0, - 0, 52, 82, 82, 82, 82, 0, 0, 0, 0, - 0, 82, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 60, 0, 82, 82, 0, 51, 82, 82, - 61, 63, 47, 0, 56, 278, 64, 59, 0, 58, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 130, 130, 130, 130, 0, 52, 62, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 130, 130, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 60, 0, 0, 32, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, - 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, - 44, 45, 46, 0, 0, 48, 49, 0, 0, 0, - 52, 0, 50, 0, 136, 0, 53, 136, 54, 55, - 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 136, 136, 0, 32, 0, 136, 0, 0, 0, - 0, 0, 0, 0, 0, 38, 0, 39, 40, 41, - 0, 0, 0, 0, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 0, 136, 0, 136, 0, 50, 0, - 119, 0, 53, 119, 54, 55, 0, 0, 24, 25, - 26, 27, 28, 0, 29, 30, 31, 119, 119, 0, - 32, 0, 119, 0, 0, 0, 136, 0, 0, 0, - 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, - 42, 43, 44, 45, 46, 0, 0, 48, 49, 0, - 119, 0, 119, 0, 50, 0, 0, 0, 53, 0, - 54, 55, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, - 0, 51, 119, 32, 61, 63, 47, 0, 56, 0, - 64, 59, 0, 58, 38, 0, 39, 40, 41, 0, - 0, 0, 0, 42, 43, 44, 45, 46, 0, 0, - 48, 49, 62, 0, 0, 0, 0, 50, 0, 0, - 0, 53, 0, 54, 55, 0, 0, 0, 0, 0, - 143, 0, 0, 143, 0, 0, 0, 0, 0, 60, - 0, 0, 0, 0, 0, 0, 0, 143, 143, 0, - 0, 0, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 52, 136, 136, 136, 136, 0, - 143, 0, 143, 0, 136, 0, 0, 0, 136, 136, - 136, 136, 0, 0, 0, 0, 0, 136, 136, 0, - 0, 136, 136, 136, 136, 136, 0, 136, 136, 0, - 0, 136, 143, 0, 136, 136, 136, 0, 0, 0, - 0, 129, 0, 0, 129, 0, 0, 0, 0, 0, - 0, 119, 119, 119, 119, 0, 0, 0, 129, 129, - 119, 0, 0, 129, 119, 119, 119, 119, 0, 0, - 0, 0, 0, 119, 119, 0, 0, 119, 119, 119, - 119, 119, 0, 119, 119, 0, 104, 119, 0, 104, - 119, 119, 119, 129, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 104, 104, 0, 0, 0, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 129, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 0, 0, 104, 32, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, - 39, 40, 41, 0, 0, 0, 0, 42, 43, 44, - 45, 46, 0, 0, 48, 49, 0, 0, 0, 0, - 0, 50, 0, 0, 0, 53, 0, 54, 55, 0, - 0, 143, 143, 143, 143, 0, 0, 0, 0, 0, - 143, 0, 0, 0, 143, 143, 143, 143, 0, 0, - 0, 0, 0, 143, 143, 0, 0, 143, 143, 143, - 143, 143, 0, 143, 143, 145, 0, 143, 145, 0, - 143, 143, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 145, 145, 0, 0, 0, 145, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 83, 0, 0, 83, 0, 145, 0, 0, - 0, 0, 129, 129, 129, 129, 0, 0, 0, 83, - 83, 129, 0, 0, 0, 129, 129, 129, 129, 0, - 0, 0, 0, 0, 129, 129, 0, 145, 129, 129, - 129, 129, 129, 0, 129, 129, 0, 0, 129, 0, - 0, 129, 129, 129, 83, 0, 0, 104, 104, 104, - 104, 0, 0, 0, 0, 0, 104, 0, 0, 0, - 104, 104, 104, 104, 0, 0, 0, 131, 0, 104, - 104, 0, 0, 104, 104, 104, 104, 104, 0, 104, - 104, 0, 0, 104, 131, 131, 104, 104, 104, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 0, 0, 131, 0, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 146, 146, - 0, 0, 0, 146, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 131, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 0, 51, 147, 0, 147, 0, + 0, 0, 0, 0, 54, 130, 55, 56, 130, 24, + 25, 26, 27, 28, 0, 29, 30, 31, 0, 0, + 0, 32, 130, 130, 0, 0, 0, 130, 147, 0, + 0, 0, 38, 0, 39, 40, 41, 42, 43, 0, + 0, 0, 0, 44, 45, 46, 47, 48, 49, 0, + 0, 51, 0, 0, 0, 130, 0, 130, 0, 0, + 54, 0, 55, 56, 0, 0, 0, 0, 154, 0, + 0, 154, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 0, 0, 0, 32, 154, 154, 130, 0, 0, + 154, 0, 0, 0, 0, 38, 0, 39, 40, 41, + 42, 43, 0, 0, 0, 0, 44, 45, 46, 47, + 48, 49, 0, 0, 51, 0, 140, 0, 154, 140, + 154, 0, 0, 54, 0, 55, 56, 0, 0, 0, + 0, 0, 0, 140, 140, 153, 154, 0, 140, 0, + 0, 69, 69, 69, 69, 0, 0, 0, 0, 0, + 154, 161, 162, 0, 0, 163, 0, 0, 164, 165, + 166, 0, 0, 0, 0, 0, 69, 69, 140, 0, + 0, 0, 0, 0, 0, 0, 0, 147, 147, 147, + 147, 0, 115, 0, 0, 115, 147, 0, 0, 0, + 0, 0, 147, 147, 147, 147, 0, 0, 140, 115, + 115, 0, 147, 147, 115, 147, 147, 147, 147, 147, + 147, 147, 0, 0, 147, 0, 0, 147, 147, 147, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 146, 0, 0, 96, 0, 0, 96, - 0, 0, 0, 0, 0, 0, 145, 145, 145, 145, - 0, 0, 0, 96, 96, 145, 0, 0, 96, 145, - 145, 145, 145, 146, 0, 0, 0, 0, 145, 145, - 0, 0, 145, 145, 145, 145, 145, 0, 145, 145, - 58, 0, 145, 58, 0, 145, 145, 145, 96, 0, - 0, 0, 0, 83, 83, 83, 83, 58, 58, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 83, 83, 0, 96, 83, - 0, 0, 0, 61, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 61, 61, 0, 0, 0, 61, 0, 0, 0, 0, + 0, 0, 115, 0, 115, 0, 130, 130, 130, 130, + 0, 156, 0, 0, 156, 130, 0, 0, 0, 0, + 0, 130, 130, 130, 130, 0, 0, 0, 156, 156, + 0, 130, 130, 156, 130, 130, 130, 130, 130, 130, + 130, 0, 0, 130, 0, 0, 130, 130, 130, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 131, 131, - 131, 131, 0, 61, 0, 61, 0, 131, 0, 0, - 0, 131, 131, 131, 131, 59, 0, 0, 59, 0, - 131, 131, 0, 0, 131, 131, 131, 131, 131, 0, - 131, 131, 59, 59, 131, 61, 0, 131, 131, 131, - 0, 0, 146, 146, 146, 146, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 146, 146, 146, 146, 0, - 0, 0, 0, 0, 146, 146, 0, 59, 146, 146, - 146, 146, 146, 0, 146, 146, 0, 0, 146, 0, - 0, 146, 146, 146, 0, 0, 0, 145, 0, 0, - 145, 0, 0, 0, 0, 0, 0, 96, 96, 96, - 96, 0, 0, 0, 145, 145, 96, 0, 0, 145, - 96, 96, 96, 96, 0, 0, 0, 0, 0, 96, - 96, 0, 0, 96, 96, 96, 96, 96, 0, 96, - 96, 132, 0, 96, 132, 0, 96, 96, 96, 145, - 0, 58, 58, 58, 58, 0, 0, 0, 132, 132, - 58, 0, 0, 132, 58, 58, 58, 58, 0, 0, - 0, 0, 0, 58, 58, 0, 0, 58, 58, 58, - 58, 58, 0, 58, 58, 0, 0, 58, 0, 0, - 58, 58, 58, 132, 61, 61, 61, 61, 0, 284, - 0, 0, 0, 61, 157, 0, 0, 61, 61, 61, - 61, 0, 0, 0, 0, 0, 61, 61, 0, 0, - 61, 61, 61, 61, 61, 95, 61, 61, 95, 0, - 61, 0, 168, 61, 61, 61, 0, 0, 0, 0, - 0, 0, 95, 95, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, - 0, 0, 0, 0, 150, 0, 0, 102, 0, 0, - 102, 0, 0, 0, 0, 0, 0, 95, 59, 59, - 0, 0, 0, 0, 102, 102, 0, 0, 0, 102, + 0, 0, 0, 156, 0, 0, 0, 0, 0, 154, + 154, 154, 154, 0, 0, 0, 0, 0, 154, 0, + 0, 0, 0, 0, 154, 154, 154, 154, 0, 0, + 0, 0, 0, 156, 154, 154, 0, 154, 154, 154, + 154, 154, 154, 154, 0, 0, 154, 0, 0, 154, + 154, 154, 0, 0, 0, 0, 0, 140, 140, 140, + 140, 0, 157, 0, 0, 0, 140, 0, 0, 0, + 0, 0, 140, 140, 140, 140, 0, 0, 0, 157, + 157, 0, 140, 140, 157, 140, 140, 140, 140, 140, + 140, 140, 0, 0, 140, 0, 0, 140, 140, 140, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 109, 102, - 0, 109, 0, 0, 0, 0, 0, 0, 145, 145, - 145, 145, 0, 0, 0, 109, 109, 145, 0, 0, - 109, 145, 145, 145, 145, 0, 0, 0, 0, 0, - 145, 145, 0, 0, 145, 145, 145, 145, 145, 0, - 145, 145, 92, 0, 145, 92, 0, 145, 145, 145, - 109, 0, 132, 132, 132, 132, 0, 0, 0, 92, - 92, 132, 0, 0, 92, 132, 132, 132, 132, 0, - 0, 0, 0, 0, 132, 132, 0, 0, 132, 132, - 132, 132, 132, 93, 132, 132, 93, 0, 132, 0, - 0, 132, 132, 132, 92, 0, 0, 0, 0, 0, - 93, 93, 151, 0, 0, 93, 152, 153, 154, 155, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 156, - 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, - 0, 0, 165, 166, 167, 93, 95, 95, 95, 95, - 0, 0, 0, 0, 0, 95, 0, 0, 0, 95, - 95, 95, 95, 0, 0, 0, 0, 0, 95, 95, - 0, 0, 95, 95, 95, 95, 95, 0, 95, 95, - 0, 0, 95, 0, 0, 95, 95, 95, 102, 102, - 102, 102, 0, 0, 0, 0, 0, 102, 0, 0, - 0, 102, 102, 102, 102, 71, 0, 0, 71, 0, - 102, 102, 0, 0, 102, 102, 102, 102, 102, 0, - 102, 102, 71, 71, 102, 0, 0, 102, 102, 102, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 109, - 109, 109, 109, 0, 0, 0, 0, 0, 109, 0, - 0, 0, 109, 109, 109, 109, 0, 71, 0, 0, - 0, 109, 109, 0, 0, 109, 109, 109, 109, 109, - 0, 109, 109, 0, 0, 109, 0, 0, 109, 109, - 109, 0, 0, 92, 92, 92, 92, 0, 0, 0, - 0, 0, 92, 0, 0, 0, 92, 92, 92, 92, - 0, 0, 0, 0, 0, 92, 92, 0, 0, 92, - 92, 92, 92, 92, 87, 92, 92, 87, 0, 92, - 0, 0, 0, 0, 93, 93, 93, 93, 0, 0, - 0, 87, 87, 93, 0, 0, 87, 93, 93, 93, - 93, 0, 0, 0, 0, 0, 93, 93, 0, 0, - 93, 93, 93, 93, 93, 88, 93, 93, 88, 0, - 93, 0, 0, 0, 0, 0, 87, 0, 0, 0, - 0, 0, 88, 88, 0, 0, 0, 88, 0, 0, + 0, 0, 157, 0, 157, 0, 0, 0, 0, 0, + 0, 0, 0, 115, 115, 115, 115, 0, 0, 0, + 0, 0, 115, 0, 0, 0, 0, 0, 115, 115, + 115, 115, 0, 0, 157, 0, 0, 0, 115, 115, + 0, 115, 115, 115, 115, 115, 115, 115, 0, 0, + 115, 0, 0, 115, 115, 115, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 89, 0, 0, 89, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 88, 89, 89, - 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 85, 0, 0, - 85, 0, 0, 0, 0, 0, 71, 71, 71, 71, - 0, 0, 0, 89, 85, 85, 0, 0, 0, 85, - 0, 0, 0, 0, 0, 0, 0, 0, 71, 71, - 0, 0, 0, 86, 0, 0, 86, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, - 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, - 0, 0, 84, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 86, 84, 84, 0, 0, - 0, 84, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 156, 156, 156, 156, 0, 142, 0, 0, + 0, 156, 0, 0, 0, 0, 0, 156, 156, 156, + 156, 0, 0, 0, 142, 142, 0, 156, 156, 142, + 156, 156, 156, 156, 156, 156, 156, 0, 0, 156, + 0, 0, 156, 156, 156, 0, 0, 0, 0, 0, + 107, 0, 0, 107, 0, 0, 0, 142, 0, 142, + 93, 0, 0, 93, 0, 0, 0, 107, 107, 0, + 0, 0, 107, 0, 0, 0, 0, 93, 93, 0, + 0, 0, 93, 0, 0, 0, 0, 0, 0, 142, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 87, 87, 87, 87, 0, - 0, 84, 0, 0, 87, 0, 0, 0, 87, 87, - 87, 87, 0, 0, 0, 0, 0, 87, 87, 0, - 0, 87, 87, 87, 87, 87, 72, 87, 87, 72, - 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, - 0, 0, 0, 72, 72, 88, 0, 0, 72, 88, - 88, 88, 88, 0, 0, 0, 0, 0, 88, 88, - 0, 0, 88, 88, 88, 88, 88, 0, 88, 88, - 0, 0, 89, 89, 89, 89, 0, 0, 72, 0, - 0, 89, 0, 0, 0, 89, 89, 89, 89, 0, - 0, 0, 0, 0, 89, 89, 0, 0, 89, 89, - 89, 89, 89, 0, 89, 89, 0, 0, 85, 85, - 85, 85, 0, 0, 0, 0, 0, 85, 0, 0, - 0, 85, 85, 85, 85, 0, 0, 0, 0, 0, - 85, 85, 0, 0, 85, 85, 85, 85, 85, 0, - 85, 85, 0, 0, 86, 86, 86, 86, 0, 0, - 0, 0, 0, 86, 0, 0, 0, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 86, 86, 0, 0, - 86, 86, 86, 86, 86, 0, 86, 86, 0, 0, - 84, 84, 84, 84, 0, 0, 0, 0, 0, 84, - 0, 0, 0, 84, 84, 84, 84, 73, 0, 0, - 73, 0, 84, 84, 0, 0, 84, 84, 84, 84, - 84, 0, 84, 84, 73, 73, 0, 0, 0, 73, + 0, 0, 107, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 93, 157, 157, 157, 157, 0, 68, 0, + 0, 68, 157, 0, 0, 0, 0, 0, 157, 157, + 157, 157, 107, 0, 0, 68, 68, 0, 157, 157, + 68, 157, 157, 157, 157, 157, 157, 157, 0, 0, + 157, 0, 0, 157, 157, 157, 0, 0, 0, 0, + 0, 71, 0, 0, 0, 0, 0, 0, 0, 0, + 68, 0, 0, 0, 0, 0, 0, 0, 71, 71, + 0, 0, 0, 71, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 74, 0, 0, 74, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 74, 74, 73, - 0, 0, 74, 0, 0, 0, 0, 72, 72, 72, - 72, 0, 0, 0, 0, 0, 72, 0, 0, 0, - 72, 72, 72, 72, 75, 0, 0, 75, 0, 72, - 72, 0, 74, 72, 72, 72, 72, 72, 0, 72, - 72, 75, 75, 0, 0, 0, 75, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, - 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 123, 123, 75, 0, 0, 123, - 0, 0, 0, 0, 0, 0, 0, 0, 94, 0, - 0, 94, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 94, 94, 0, 0, 123, - 94, 0, 0, 0, 0, 0, 0, 0, 0, 134, - 0, 0, 134, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 134, 134, 0, 0, - 94, 134, 0, 0, 0, 0, 0, 0, 0, 0, - 76, 0, 0, 76, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 77, 76, 76, 77, - 0, 134, 76, 0, 0, 0, 0, 0, 73, 73, - 73, 73, 0, 77, 77, 0, 0, 73, 77, 0, - 0, 73, 73, 73, 73, 0, 0, 0, 0, 0, - 73, 73, 76, 0, 73, 73, 73, 73, 73, 0, - 73, 74, 74, 74, 74, 0, 0, 0, 77, 0, - 74, 0, 0, 0, 74, 74, 0, 74, 78, 0, - 0, 78, 0, 74, 74, 0, 0, 74, 74, 74, - 74, 74, 0, 74, 79, 78, 78, 79, 0, 0, - 78, 0, 0, 0, 0, 75, 75, 75, 75, 0, - 0, 79, 79, 0, 75, 0, 79, 0, 75, 75, - 0, 0, 0, 0, 0, 0, 0, 75, 75, 0, - 78, 75, 75, 75, 75, 75, 0, 75, 123, 123, - 123, 123, 0, 0, 0, 0, 79, 123, 0, 0, - 0, 123, 123, 0, 0, 0, 0, 0, 0, 81, - 123, 123, 81, 0, 123, 123, 123, 123, 123, 94, - 94, 94, 94, 0, 0, 0, 81, 81, 94, 0, - 0, 81, 94, 94, 0, 0, 0, 0, 0, 0, - 0, 94, 94, 0, 0, 94, 94, 94, 94, 94, - 134, 134, 134, 134, 0, 0, 0, 0, 0, 134, - 0, 81, 0, 134, 134, 0, 0, 0, 0, 0, - 0, 0, 134, 134, 0, 0, 134, 134, 134, 134, - 134, 76, 76, 76, 76, 0, 0, 0, 0, 0, - 76, 0, 0, 0, 0, 76, 0, 77, 77, 77, - 77, 0, 0, 76, 76, 0, 77, 76, 76, 76, - 76, 76, 0, 0, 0, 0, 0, 0, 0, 77, - 77, 0, 0, 77, 77, 77, 77, 77, 0, 0, + 68, 0, 0, 0, 0, 106, 0, 0, 106, 0, + 0, 71, 0, 71, 0, 0, 0, 0, 0, 0, + 0, 0, 106, 106, 0, 0, 0, 106, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 142, 142, + 142, 142, 0, 71, 0, 0, 0, 142, 0, 0, + 0, 0, 0, 142, 142, 142, 142, 106, 0, 0, + 0, 0, 0, 142, 142, 0, 142, 142, 142, 142, + 142, 142, 142, 0, 0, 142, 0, 0, 142, 142, + 142, 107, 107, 107, 107, 0, 143, 106, 0, 143, + 107, 93, 93, 93, 93, 0, 107, 107, 107, 107, + 93, 0, 0, 143, 143, 0, 107, 107, 143, 107, + 107, 107, 107, 107, 107, 107, 93, 93, 107, 93, + 93, 107, 107, 107, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 143, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 68, + 68, 68, 68, 0, 156, 0, 0, 156, 68, 0, + 0, 0, 0, 0, 68, 68, 68, 68, 0, 0, + 0, 156, 156, 0, 68, 68, 156, 68, 68, 68, + 68, 68, 68, 68, 0, 0, 68, 0, 0, 68, + 68, 68, 71, 71, 71, 71, 0, 113, 0, 0, + 113, 71, 0, 0, 0, 0, 156, 71, 71, 71, + 71, 0, 0, 0, 113, 113, 0, 71, 71, 113, + 71, 71, 71, 71, 71, 71, 71, 0, 0, 71, + 0, 0, 71, 71, 71, 0, 106, 106, 106, 106, + 0, 120, 0, 0, 120, 106, 0, 0, 0, 113, + 0, 106, 106, 106, 106, 0, 0, 0, 120, 120, + 0, 106, 106, 120, 106, 106, 106, 106, 106, 106, + 106, 0, 0, 106, 0, 0, 106, 106, 106, 0, + 0, 0, 0, 0, 98, 0, 0, 98, 0, 0, + 0, 0, 0, 120, 0, 0, 0, 0, 0, 0, + 0, 98, 98, 0, 0, 0, 98, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 143, 143, 143, + 143, 0, 99, 0, 0, 99, 143, 0, 0, 0, + 0, 0, 143, 143, 143, 143, 98, 0, 0, 99, + 99, 0, 143, 143, 99, 143, 143, 143, 143, 143, + 143, 143, 0, 0, 143, 0, 0, 143, 143, 143, + 100, 0, 0, 100, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 99, 0, 0, 100, 100, 0, + 0, 0, 100, 0, 0, 156, 156, 156, 156, 0, + 0, 0, 0, 0, 156, 0, 0, 0, 0, 0, + 156, 156, 156, 156, 0, 0, 0, 0, 0, 0, + 156, 156, 100, 156, 156, 156, 156, 156, 156, 156, + 0, 0, 156, 0, 0, 156, 156, 156, 113, 113, + 113, 113, 0, 96, 0, 0, 96, 113, 0, 0, + 0, 0, 0, 113, 113, 113, 113, 0, 0, 0, + 96, 96, 0, 113, 113, 96, 113, 113, 113, 113, + 113, 113, 113, 0, 0, 113, 0, 0, 113, 113, + 113, 0, 120, 120, 120, 120, 0, 97, 0, 0, + 97, 120, 0, 0, 0, 96, 0, 120, 120, 120, + 120, 0, 0, 0, 97, 97, 0, 120, 120, 97, + 120, 120, 120, 120, 120, 120, 120, 0, 0, 120, + 0, 0, 120, 120, 120, 98, 98, 98, 98, 0, + 95, 0, 0, 95, 98, 0, 0, 0, 0, 97, + 98, 98, 98, 98, 0, 0, 0, 95, 95, 0, + 98, 98, 95, 98, 98, 98, 98, 98, 98, 98, + 0, 0, 0, 99, 99, 99, 99, 0, 83, 0, + 0, 83, 99, 0, 0, 0, 0, 0, 99, 99, + 99, 99, 95, 0, 0, 83, 83, 0, 99, 99, + 83, 99, 99, 99, 99, 99, 99, 99, 0, 0, + 0, 100, 100, 100, 100, 0, 84, 0, 0, 84, + 100, 0, 0, 0, 0, 0, 100, 100, 100, 100, + 83, 0, 0, 84, 84, 0, 100, 100, 84, 100, + 100, 100, 100, 100, 100, 100, 0, 0, 0, 0, + 0, 0, 86, 0, 0, 86, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 84, 86, + 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 96, 96, 96, 96, 0, 146, + 0, 0, 146, 96, 0, 0, 0, 0, 0, 96, + 96, 96, 96, 0, 86, 0, 146, 146, 0, 96, + 96, 146, 96, 96, 96, 96, 96, 96, 96, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 97, 97, + 97, 97, 0, 145, 0, 0, 145, 97, 0, 0, + 0, 146, 0, 97, 97, 97, 97, 0, 0, 0, + 145, 145, 0, 97, 97, 145, 97, 97, 97, 97, + 97, 97, 97, 0, 0, 0, 0, 0, 0, 0, + 0, 95, 95, 95, 95, 0, 134, 0, 0, 134, + 95, 0, 0, 0, 0, 145, 95, 95, 95, 95, + 0, 0, 0, 134, 134, 0, 95, 95, 134, 95, + 95, 95, 95, 95, 95, 95, 0, 0, 0, 83, + 83, 83, 83, 0, 105, 0, 0, 105, 83, 0, + 0, 0, 0, 0, 83, 83, 83, 83, 134, 0, + 0, 105, 105, 0, 83, 83, 105, 83, 83, 83, + 83, 83, 83, 83, 0, 0, 0, 84, 84, 84, + 84, 0, 89, 0, 0, 89, 84, 0, 0, 0, + 0, 0, 84, 84, 84, 84, 105, 0, 0, 89, + 89, 0, 84, 84, 89, 84, 84, 84, 84, 84, + 84, 0, 0, 86, 86, 86, 86, 0, 90, 0, + 0, 90, 86, 0, 0, 0, 0, 0, 86, 86, + 0, 0, 0, 0, 89, 90, 90, 0, 86, 86, + 90, 86, 86, 86, 86, 86, 86, 0, 0, 0, + 146, 146, 146, 146, 0, 92, 0, 0, 92, 146, + 0, 0, 0, 0, 0, 146, 146, 0, 0, 0, + 90, 0, 92, 92, 0, 146, 146, 92, 146, 146, + 146, 146, 146, 0, 0, 0, 167, 0, 0, 0, + 0, 0, 0, 0, 145, 145, 145, 145, 0, 91, + 156, 0, 91, 145, 0, 0, 0, 92, 0, 145, + 145, 0, 0, 0, 0, 0, 91, 91, 149, 145, + 145, 91, 145, 145, 145, 145, 145, 0, 167, 0, + 0, 283, 0, 0, 0, 0, 156, 134, 134, 134, + 134, 0, 0, 0, 0, 0, 134, 0, 0, 0, + 0, 91, 134, 134, 0, 0, 0, 0, 0, 0, + 149, 0, 134, 134, 167, 134, 134, 134, 134, 134, + 0, 0, 0, 0, 0, 105, 105, 105, 105, 0, + 0, 0, 0, 0, 105, 0, 0, 0, 0, 0, + 105, 105, 0, 0, 0, 156, 149, 0, 0, 0, + 105, 105, 0, 105, 105, 105, 105, 105, 0, 0, + 0, 0, 0, 89, 89, 89, 89, 0, 0, 0, + 0, 0, 89, 167, 0, 0, 0, 0, 90, 90, + 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, + 103, 89, 89, 89, 89, 89, 111, 90, 119, 90, + 90, 90, 90, 90, 0, 149, 0, 0, 90, 167, + 0, 0, 0, 0, 0, 90, 90, 90, 90, 0, + 0, 0, 0, 0, 90, 90, 0, 90, 90, 90, + 90, 0, 151, 152, 153, 154, 92, 92, 92, 92, + 0, 149, 0, 0, 0, 92, 157, 158, 159, 160, + 161, 162, 0, 0, 163, 0, 0, 164, 165, 166, + 111, 92, 92, 0, 92, 92, 92, 0, 150, 0, + 0, 0, 0, 0, 151, 152, 153, 154, 0, 0, + 91, 91, 91, 91, 0, 0, 0, 155, 157, 158, + 159, 160, 161, 162, 0, 0, 163, 0, 0, 164, + 165, 166, 0, 0, 150, 91, 91, 0, 91, 0, + 151, 152, 153, 154, 0, 0, 0, 0, 0, 234, + 0, 0, 0, 155, 157, 158, 159, 160, 161, 162, + 94, 0, 163, 0, 0, 164, 165, 166, 104, 0, + 0, 0, 109, 263, 0, 118, 0, 0, 0, 0, + 0, 0, 125, 126, 127, 128, 129, 0, 0, 132, + 133, 0, 0, 150, 0, 0, 140, 0, 0, 151, + 152, 153, 154, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 157, 158, 159, 160, 161, 162, 0, + 0, 163, 0, 183, 164, 165, 166, 0, 0, 0, + 0, 0, 0, 0, 0, 151, 152, 153, 154, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 158, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 78, - 78, 78, 78, 0, 0, 0, 0, 0, 78, 0, - 0, 0, 0, 0, 0, 79, 79, 79, 79, 0, - 0, 78, 78, 0, 79, 78, 78, 78, 78, 78, - 0, 0, 91, 0, 0, 0, 0, 79, 79, 0, - 104, 79, 79, 79, 79, 111, 113, 0, 0, 0, - 0, 0, 125, 126, 127, 128, 129, 130, 0, 0, - 133, 134, 0, 0, 0, 0, 0, 0, 0, 0, + 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, + 227, 228, 229, 230, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 244, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 81, 81, 81, 81, 0, 0, 0, 0, 0, 81, - 0, 0, 183, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 81, 81, 0, 0, 81, 81, 81, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 215, 0, 0, 0, 0, - 0, 0, 0, 223, 224, 225, 226, 227, 228, 229, - 230, 231, 232, 233, 234, 235, 236, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 296, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 297, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 313, + 0, 0, 0, 312, }; short yycheck[] = { 13, - 59, 13, 91, 17, 59, 59, 36, 93, 182, 194, - 41, 123, 59, 44, 257, 41, 59, 40, 44, 33, - 34, 35, 36, 91, 40, 88, 59, 58, 59, 43, - 41, 40, 63, 45, 123, 41, 50, 63, 91, 41, - 257, 41, 41, 40, 56, 40, 59, 40, 60, 41, - 257, 41, 40, 116, 41, 123, 188, 59, 190, 40, - 59, 91, 93, 41, 78, 91, 41, 36, 91, 59, - 123, 40, 59, 41, 278, 41, 123, 41, 92, 294, - 295, 95, 94, 97, 96, 99, 98, 101, 100, 41, - 102, 59, 41, 123, 106, 41, 40, 123, 41, 41, - 123, 123, 41, 44, 59, 44, 0, 123, 276, 277, - 123, 44, 40, 287, 123, 300, 179, 59, 303, 58, - 59, 184, 59, 59, 260, 59, 123, 141, 123, 123, - 257, 40, 144, 145, 146, 147, 148, 149, 150, 33, - 40, 40, 36, 37, 38, 257, 40, 295, 42, 43, - 335, 45, 41, 6, 93, 8, 168, 169, 170, 171, - 172, 173, 174, 125, 178, 59, 298, 299, 91, 41, - 64, 185, 41, 305, 0, 59, 91, 125, 31, 32, - 40, 93, 59, 41, 36, 40, 198, 125, 83, 59, - 125, 93, 204, 205, 206, 125, 328, 91, 125, 211, - 125, 41, 41, 257, 123, 91, 93, 33, 294, 295, - 36, 37, 38, 41, 40, 59, 42, 43, 41, 45, - 41, 59, 93, 59, 313, 237, 59, 239, 258, 123, - 41, 125, 126, 59, 326, 294, 295, 123, 64, 294, - 295, 272, 273, 274, 275, 259, 13, 261, 269, 263, - 264, 294, 295, 267, -1, 281, 270, 269, 93, 285, - 286, 287, 288, 294, 295, 91, 93, 298, 0, -1, - 282, 123, 298, 299, 300, 301, 302, 93, 304, 305, - -1, -1, 308, 294, 295, 311, 312, 313, 294, 295, - 302, -1, 306, -1, 294, 295, -1, 123, -1, 125, - 126, 33, 294, 295, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 326, -1, 294, 295, 332, 294, - 295, -1, 336, 272, 273, 274, 275, 59, 294, 295, - 294, 295, 64, 272, 273, 274, 275, -1, -1, 294, - 295, -1, 294, 295, -1, 294, 295, -1, 294, 295, - -1, 294, 295, 294, 295, 294, 295, 294, 295, 91, - 294, 295, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, - 274, 275, 294, 295, -1, 279, 280, -1, 282, 283, - 284, 123, 294, 295, 126, 289, 290, 291, 292, 293, - 41, 287, 296, 297, 91, 257, -1, 294, 295, 303, - 262, -1, -1, 307, -1, 309, 310, -1, 59, 305, - -1, -1, 308, 294, 295, 311, 312, 313, -1, -1, - 256, 257, 258, 259, 260, 261, 123, 263, 264, 265, - 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, - -1, -1, 93, 279, 280, -1, 282, 283, 284, 294, - 295, -1, -1, 289, 290, 291, 292, 293, -1, -1, - 296, 297, 91, -1, -1, -1, -1, 303, 294, 295, - -1, 307, 91, 309, 310, 26, 33, -1, -1, 36, - 37, 38, -1, 40, 41, 42, 43, 44, 45, 48, - 49, 42, -1, -1, 123, -1, 47, -1, 49, -1, - -1, 58, 59, -1, 123, 125, 63, 64, -1, -1, - 61, 62, 63, 64, 256, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, -1, 269, -1, 88, - 272, 273, 274, 275, 91, -1, 93, 279, 280, -1, - 282, 283, 284, 63, -1, -1, -1, 289, 290, 291, - 292, 293, 91, -1, 296, 297, 107, 116, 266, 267, - 268, 303, 270, 271, 123, 307, 123, 309, 310, 126, - 33, 91, -1, 36, 37, 38, -1, 40, 41, 42, - 43, 44, 45, -1, 123, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, 58, 59, -1, -1, -1, - 63, 64, -1, 123, 301, 302, -1, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - 179, 272, 273, 274, 275, 184, -1, -1, -1, 33, - 93, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, 294, 295, -1, 266, 267, 268, -1, - 270, 271, -1, -1, -1, 59, 285, 286, 287, 288, - 64, -1, -1, 126, -1, -1, 285, 286, 287, 288, - 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, - -1, -1, 311, 312, 313, 304, 305, 91, -1, 308, - -1, -1, 311, 312, 313, -1, -1, -1, -1, -1, + 59, 41, 36, 36, 44, 93, 36, 59, 91, 86, + 40, 325, 91, 41, 257, 191, 40, 43, 58, 59, + 182, 257, 59, 63, 41, 51, 41, 59, 41, 257, + 41, 91, 46, 41, 322, 323, 91, 59, 41, 327, + 123, 41, 356, 57, 123, 297, 298, 61, 41, 44, + 40, 59, 40, 93, 40, 343, 59, 278, 91, 347, + 123, 41, 41, 123, 41, 91, 59, 91, 123, 40, + 97, 98, 99, 100, 101, 102, 59, 41, 0, 59, + 59, 59, 59, 59, 40, 59, 123, 59, 114, 123, + 123, 123, 106, 107, 270, 59, 122, 276, 277, 123, + 59, 41, 272, 273, 274, 275, 40, 40, 44, 40, + 260, 33, 40, 93, 36, 37, 38, 123, 40, 59, + 42, 43, 257, 45, 286, 93, 302, 297, 298, 143, + 144, 145, 146, 147, 148, 149, 40, 59, 40, 266, + 267, 268, 64, 270, 271, 41, 40, 91, 257, 36, + 93, 41, 0, 167, 168, 169, 170, 171, 172, 173, + 125, 93, 125, 93, 91, 192, 298, 40, 182, 91, + 346, 41, 186, 187, 41, 189, 41, 191, 93, 41, + 93, 41, 91, 40, 198, 33, 200, 201, 36, 37, + 38, 205, 40, 59, 42, 43, 41, 45, 257, 125, + 125, 123, 125, 125, 126, 125, 59, 123, 41, 297, + 298, 59, 41, 125, 123, 41, 64, 231, 59, 233, + 41, 41, 248, 257, 44, 258, 309, 253, 262, 312, + 313, 314, 272, 273, 274, 275, 41, 41, 58, 59, + 44, 281, 40, 91, 123, 297, 298, 287, 288, 41, + 290, 123, 44, 41, 58, 59, 333, 297, 298, 314, + 300, 301, 302, 303, 304, 305, 296, 281, 0, 297, + 298, 63, 286, 93, 41, 123, 59, 125, 126, 41, + 297, 298, 297, 298, 297, 298, 297, 298, 59, 93, + 304, 41, 272, 273, 274, 275, 59, 297, 298, 91, + 41, 33, 297, 298, 36, 37, 38, 8, 40, 32, + 42, 43, 144, 45, 297, 298, 13, 297, 298, 297, + 298, 297, 298, 297, 298, 297, 298, 59, 342, 297, + 298, 123, 64, 342, 256, 257, 258, 259, 260, 261, + 189, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 272, 273, 274, 275, 297, 298, 304, 279, 280, 91, + 282, 283, 284, 285, 286, 297, 298, 297, 298, 291, + 292, 293, 294, 295, 296, 91, 96, 299, 41, 41, + 289, 44, 297, 298, 297, 298, 308, -1, 310, 311, + -1, 123, -1, -1, 126, 58, 59, 306, -1, -1, + 309, 63, -1, 312, 313, 314, -1, 123, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 272, 273, 274, 275, -1, 91, + 93, 279, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + -1, 299, 272, 273, 274, 275, -1, -1, -1, 91, + 308, 123, 310, 311, -1, -1, -1, -1, 272, 273, + 274, 275, 91, -1, 91, -1, 33, 297, 298, 36, + 37, 38, -1, 40, 41, 42, 43, 44, 45, 281, + -1, 123, -1, 297, 298, 287, 288, 289, 290, -1, + -1, 58, 59, -1, 123, 122, 63, 64, 300, 301, + 302, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, 256, 257, 258, 259, 260, 261, + -1, 263, 264, 265, 91, -1, 93, 269, -1, -1, + 272, 273, 274, 275, -1, -1, -1, 279, 280, -1, + 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, + 292, 293, 294, 295, 296, 41, 123, 299, 44, 126, + -1, -1, 91, 289, 290, -1, 308, 33, 310, 311, + 36, 37, 38, 59, 40, 41, 42, 43, 44, 45, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, + -1, -1, 58, 59, 123, -1, -1, 63, 64, 272, + 273, 274, 275, -1, -1, -1, -1, 93, -1, 281, + -1, -1, -1, -1, -1, 287, 288, 289, 290, -1, + -1, 248, -1, -1, 297, 298, 253, 93, 300, 301, + 302, 303, 304, 305, 306, -1, 41, 309, -1, 44, + 312, 313, 314, -1, -1, 287, 288, 289, 290, -1, + -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, + 126, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, 93, -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - -1, -1, 269, -1, -1, 272, 273, 274, 275, 123, - -1, -1, 126, 280, 281, 282, 283, 284, 285, 286, + -1, -1, 269, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, - 297, 298, 299, 300, 301, 302, 303, 304, 305, -1, - 307, 308, 309, 310, 311, 312, 313, 91, -1, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, 308, - -1, -1, 311, 312, 313, -1, -1, -1, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, 123, - -1, 311, 312, 313, 257, 258, 259, 260, 261, -1, - 263, 264, 265, -1, -1, -1, 269, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, 280, 281, 282, - 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, - 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, - 303, 304, 305, -1, 307, 308, 309, 310, 311, 312, - 313, 91, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, -1, 41, -1, 269, 44, -1, 272, 273, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + -1, 308, 309, 310, 311, 312, 313, 314, 41, -1, + -1, 44, -1, 41, -1, -1, 44, -1, 287, 288, + 289, 290, -1, -1, -1, 58, 59, -1, -1, -1, + 58, 59, -1, -1, -1, 63, 305, 306, -1, 125, + 309, -1, -1, 312, 313, 314, 272, 273, 274, 275, + -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, + 93, -1, 125, 269, -1, 93, 272, 273, 274, 275, + -1, 297, -1, -1, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 33, + -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, -1, -1, -1, 59, 281, -1, -1, -1, + 64, -1, 287, 288, 289, 290, -1, -1, -1, -1, + -1, -1, 297, 298, 13, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, 33, -1, 91, 36, 37, + 38, -1, 40, -1, 42, 43, 26, 45, -1, -1, + 266, 267, 268, 42, 270, 271, 45, -1, -1, -1, + -1, 59, -1, 43, 44, -1, 64, -1, -1, 123, + 50, -1, 126, 266, 267, 268, -1, 270, 271, -1, + -1, -1, 62, 63, 64, 65, -1, -1, -1, -1, + -1, 33, 81, 91, 36, 37, 38, -1, 40, -1, + 42, 43, -1, 45, -1, -1, 95, -1, -1, 272, + 273, 274, 275, -1, 272, 273, 274, 275, -1, -1, + -1, -1, 64, 281, -1, 123, -1, 107, 126, 287, + 288, 289, 290, -1, 297, 298, -1, 300, -1, 297, + 298, -1, 300, 301, 302, 303, 304, 305, 306, 91, + -1, 309, 141, -1, 33, -1, -1, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 123, -1, -1, 126, 64, -1, -1, -1, 178, + -1, -1, -1, -1, -1, -1, 185, -1, -1, -1, + -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, -1, -1, 269, -1, -1, 272, 273, 274, 275, -1, -1, -1, 279, 280, -1, 282, 283, - 284, 59, -1, 123, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, -1, -1, -1, -1, -1, 303, - 25, 26, -1, 307, 33, 309, 310, 36, 37, 38, - -1, 40, 37, 42, 43, 93, 45, 42, 43, -1, - -1, -1, 47, -1, 49, 272, 273, 274, 275, -1, - 59, -1, -1, -1, -1, 64, 61, 62, 63, 64, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - -1, -1, -1, 287, 288, -1, -1, -1, -1, -1, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, 123, 299, -1, 126, -1, -1, + -1, -1, -1, -1, 308, -1, 310, 311, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, -1, + 91, 269, -1, -1, 272, 273, 274, 275, -1, -1, + -1, 279, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, 91, + -1, 299, 123, -1, -1, -1, -1, -1, -1, -1, + 308, -1, 310, 311, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, -1, 33, -1, 269, 36, 37, + 38, 123, 40, 41, 42, 43, -1, 45, 280, -1, + 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, + 292, 293, 294, 295, 296, -1, 64, 299, -1, -1, + -1, -1, -1, -1, -1, -1, 308, -1, 310, 311, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 91, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, 126, 64, + 299, -1, 299, 300, 301, -1, 303, -1, -1, 308, + -1, 310, 311, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 33, -1, 91, 36, 37, 38, + -1, 40, 329, 42, 43, -1, 45, -1, -1, 336, + -1, -1, -1, 340, -1, -1, 287, 288, 289, 290, + 59, -1, -1, -1, -1, 64, 353, 354, 123, -1, + -1, 126, -1, 304, 305, 306, -1, -1, 309, -1, + -1, 312, 313, 314, -1, 287, -1, 289, 290, -1, 33, -1, 91, 36, 37, 38, -1, 40, -1, 42, - 43, 305, 45, -1, 308, -1, -1, 311, 312, 313, - -1, -1, 107, -1, -1, -1, -1, -1, -1, -1, - -1, 64, -1, -1, 123, -1, -1, 126, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 33, -1, 91, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 167, -1, -1, -1, -1, 64, -1, -1, - 123, -1, -1, 126, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 91, -1, -1, -1, -1, 33, - -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, 272, 273, 274, 275, -1, -1, - -1, -1, -1, -1, -1, 59, 123, -1, -1, 126, - 64, -1, -1, -1, -1, -1, 294, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 256, 257, 258, - 259, 260, 261, -1, 263, 264, 265, 91, -1, -1, - 269, -1, -1, 272, 273, 274, 275, -1, -1, -1, - 279, 280, -1, 282, 283, 284, -1, -1, -1, -1, - 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, - 91, 63, 126, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, 257, 258, 259, 260, 261, 262, - 263, 264, 265, -1, -1, -1, 269, -1, -1, 91, - 41, -1, 123, -1, -1, -1, -1, 280, -1, 282, - 283, 284, -1, -1, -1, -1, 289, 290, 291, 292, - 293, -1, 63, 296, 297, -1, -1, -1, -1, -1, - 303, 123, -1, -1, 307, -1, 309, 310, -1, -1, - 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - 91, -1, 269, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 280, -1, 282, 283, 284, -1, -1, - -1, -1, 289, 290, 291, 292, 293, -1, -1, 296, - 297, 41, 123, -1, 44, -1, 303, -1, -1, -1, - 307, -1, 309, 310, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 257, 258, 259, 260, 261, 91, 263, - 264, 265, -1, 33, -1, 269, 36, 37, 38, -1, + 43, -1, 45, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, + -1, 64, -1, -1, -1, -1, -1, 126, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 91, 33, + 93, 269, 36, 37, 38, -1, 40, 41, 42, 43, + -1, 45, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + 64, 299, -1, 126, -1, -1, -1, -1, -1, -1, + 308, -1, 310, 311, -1, -1, -1, -1, 41, -1, + -1, 44, 257, 258, 259, 260, 261, 91, 263, 264, + 265, -1, -1, -1, 269, 58, 59, -1, -1, -1, + 63, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, + 295, 296, 126, -1, 299, -1, -1, -1, -1, -1, + 93, -1, -1, 308, 41, 310, 311, 44, 257, 258, + 259, 260, 261, -1, 263, 264, 265, -1, -1, -1, + 269, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, -1, -1, + 299, -1, -1, -1, -1, -1, 93, -1, -1, 308, + -1, 310, 311, -1, 257, 258, 259, 260, 261, -1, + 263, 264, 265, -1, 33, -1, 269, 36, 37, 38, + -1, 40, 41, 42, 43, -1, 45, 280, -1, 282, + 283, 284, 285, 286, -1, -1, -1, -1, 291, 292, + 293, 294, 295, 296, -1, 64, 299, -1, -1, -1, + -1, -1, -1, -1, -1, 308, -1, 310, 311, -1, + -1, -1, -1, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, 33, -1, 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, 280, -1, 282, 283, - 284, -1, -1, 93, -1, 289, 290, 291, 292, 293, - 123, -1, 296, 297, 64, -1, -1, -1, -1, 303, - -1, -1, -1, 307, -1, 309, 310, -1, -1, -1, - -1, -1, -1, -1, 285, -1, 287, 288, -1, 33, - -1, 91, 36, 37, 38, -1, 40, 41, 42, 43, - -1, 45, -1, 304, 305, -1, -1, 308, -1, 281, - 311, 312, 313, 285, 286, 287, 288, -1, -1, -1, - 64, -1, -1, 123, -1, -1, 126, 299, 300, 301, - 302, -1, 304, 305, -1, -1, 308, -1, -1, 311, - 312, 313, -1, -1, -1, 33, -1, 91, 36, 37, - 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, - 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, - -1, -1, -1, -1, -1, -1, 64, 298, 299, 300, - 301, 302, 126, 304, 305, -1, -1, 308, -1, -1, - 311, 312, 313, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 91, -1, 93, -1, -1, 33, -1, - -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, 287, 288, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, 126, 64, - -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, - 313, -1, -1, -1, 294, 295, -1, 257, 258, 259, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, 64, 299, -1, 126, -1, -1, + -1, -1, -1, -1, 308, -1, 310, 311, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, 33, + -1, 91, 36, 37, 38, 288, 40, 41, 42, 43, + -1, 45, -1, -1, 297, 298, -1, 300, 301, 302, + 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, + 64, -1, -1, -1, -1, -1, 126, -1, -1, -1, + -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, 33, -1, 91, 36, 37, + 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, + 297, 298, -1, 300, 301, 302, 303, 304, -1, -1, + -1, -1, -1, -1, -1, -1, 64, -1, -1, -1, + -1, -1, 126, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 91, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, 126, 64, + 299, -1, -1, -1, -1, -1, -1, -1, -1, 308, + -1, 310, 311, -1, -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, 265, 91, -1, -1, 269, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, - 290, 291, 292, 293, -1, -1, 296, 297, -1, -1, - -1, 126, -1, 303, -1, -1, -1, 307, -1, 309, - 310, -1, -1, 257, 258, 259, 260, 261, -1, 263, - 264, 265, -1, 91, -1, 269, -1, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, + 280, -1, 282, 283, 284, 285, 286, 58, 59, -1, + -1, 291, 292, 293, 294, 295, 296, 91, -1, 299, + -1, 126, -1, -1, -1, -1, 41, -1, 308, 44, + 310, 311, -1, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 93, 58, 59, 269, -1, -1, 63, 123, -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, - 284, -1, -1, -1, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, 91, 123, -1, -1, -1, 303, - -1, 41, -1, 307, 44, 309, 310, -1, -1, 257, - 258, 259, 260, 261, -1, 263, 264, 265, 58, 59, - -1, 269, -1, 63, -1, -1, 123, -1, -1, -1, - -1, -1, 280, -1, 282, 283, 284, -1, -1, -1, - -1, 289, 290, 291, 292, 293, -1, -1, 296, 297, - -1, 41, -1, 93, 44, 303, -1, -1, -1, 307, - -1, 309, 310, -1, -1, -1, -1, -1, 58, 59, - -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, - 265, -1, 33, -1, 269, 36, 37, 38, -1, 40, - 41, 42, 43, -1, 45, 280, -1, 282, 283, 284, - -1, -1, -1, 93, 289, 290, 291, 292, 293, -1, - -1, 296, 297, 64, -1, -1, -1, -1, 303, -1, - -1, -1, 307, -1, 309, 310, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, - 91, 36, 37, 38, -1, 40, 41, 42, 43, -1, - 45, -1, -1, -1, -1, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, -1, -1, -1, 64, - -1, -1, 300, 301, 302, 126, 304, 305, -1, -1, - 308, -1, -1, 311, 312, 313, -1, -1, 285, 286, - 287, 288, -1, -1, 33, -1, 91, 36, 37, 38, - -1, 40, 41, 42, 43, 302, 45, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, - -1, 126, 272, 273, 274, 275, -1, -1, -1, -1, - -1, 281, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 91, -1, 294, 295, -1, 33, 298, 299, - 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, 126, 64, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 294, 295, 257, 258, 259, 260, - 261, -1, 263, 264, 265, 91, -1, -1, 269, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, - -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, - 291, 292, 293, -1, -1, 296, 297, -1, -1, -1, - 126, -1, 303, -1, 41, -1, 307, 44, 309, 310, - -1, -1, 257, 258, 259, 260, 261, -1, 263, 264, - 265, 58, 59, -1, 269, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - -1, -1, -1, -1, 289, 290, 291, 292, 293, -1, - -1, 296, 297, -1, 91, -1, 93, -1, 303, -1, - 41, -1, 307, 44, 309, 310, -1, -1, 257, 258, - 259, 260, 261, -1, 263, 264, 265, 58, 59, -1, - 269, -1, 63, -1, -1, -1, 123, -1, -1, -1, - -1, 280, -1, 282, 283, 284, -1, -1, -1, -1, - 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, - 91, -1, 93, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, - -1, 33, 123, 269, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 280, -1, 282, 283, 284, -1, - -1, -1, -1, 289, 290, 291, 292, 293, -1, -1, - 296, 297, 64, -1, -1, -1, -1, 303, -1, -1, - -1, 307, -1, 309, 310, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, 91, - -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 126, 272, 273, 274, 275, -1, - 91, -1, 93, -1, 281, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, -1, -1, 294, 295, -1, - -1, 298, 299, 300, 301, 302, -1, 304, 305, -1, - -1, 308, 123, -1, 311, 312, 313, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, 272, 273, 274, 275, -1, -1, -1, 58, 59, - 281, -1, -1, 63, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, -1, 41, 308, -1, 44, - 311, 312, 313, 93, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 123, -1, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, 91, 269, 93, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, - 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, - 292, 293, -1, -1, 296, 297, -1, -1, -1, -1, - -1, 303, -1, -1, -1, 307, -1, 309, 310, -1, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, -1, 299, 91, -1, 93, -1, + -1, -1, -1, -1, 308, 41, 310, 311, 44, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, -1, + -1, 269, 58, 59, -1, -1, -1, 63, 123, -1, + -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + -1, 299, -1, -1, -1, 91, -1, 93, -1, -1, + 308, -1, 310, 311, -1, -1, -1, -1, 41, -1, + -1, 44, 257, 258, 259, 260, 261, -1, 263, 264, + 265, -1, -1, -1, 269, 58, 59, 123, -1, -1, + 63, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, + 295, 296, -1, -1, 299, -1, 41, -1, 91, 44, + 93, -1, -1, 308, -1, 310, 311, -1, -1, -1, + -1, -1, -1, 58, 59, 289, 290, -1, 63, -1, -1, 272, 273, 274, 275, -1, -1, -1, -1, -1, - 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, 41, -1, 308, 44, -1, - 311, 312, 313, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, + 123, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, -1, -1, -1, -1, 297, 298, 93, -1, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, -1, -1, 123, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 91, -1, 93, -1, 272, 273, 274, 275, + -1, 41, -1, -1, 44, 281, -1, -1, -1, -1, + -1, 287, 288, 289, 290, -1, -1, -1, 58, 59, + -1, 297, 298, 63, 300, 301, 302, 303, 304, 305, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, 93, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, -1, 58, - 59, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, 123, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 93, -1, -1, 272, 273, 274, - 275, -1, -1, -1, -1, -1, 281, -1, -1, -1, - 285, 286, 287, 288, -1, -1, -1, 41, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, - 305, -1, -1, 308, 58, 59, 311, 312, 313, 63, + -1, -1, -1, 93, -1, -1, -1, -1, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + -1, -1, -1, 123, 297, 298, -1, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, -1, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, -1, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 91, -1, 93, -1, -1, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, -1, -1, 123, -1, -1, -1, 297, 298, + -1, 300, 301, 302, 303, 304, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, -1, -1, -1, 91, -1, 93, - -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, + -1, -1, 272, 273, 274, 275, -1, 41, -1, -1, + -1, 281, -1, -1, -1, -1, -1, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, 91, -1, 93, + 41, -1, -1, 44, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 91, -1, 93, -1, -1, 41, -1, -1, 44, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 58, 59, 281, -1, -1, 63, 285, - 286, 287, 288, 123, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - 41, -1, 308, 44, -1, 311, 312, 313, 93, -1, - -1, -1, -1, 272, 273, 274, 275, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 294, 295, -1, 123, 298, - -1, -1, -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, + -1, -1, 93, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, 123, -1, -1, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, + -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, + 93, -1, -1, -1, -1, -1, -1, -1, 58, 59, + -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, 91, -1, 93, -1, 281, -1, -1, - -1, 285, 286, 287, 288, 41, -1, -1, 44, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 58, 59, 308, 123, -1, 311, 312, 313, - -1, -1, 272, 273, 274, 275, -1, -1, -1, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, 93, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, -1, - -1, 311, 312, 313, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 272, 273, 274, - 275, -1, -1, -1, 58, 59, 281, -1, -1, 63, - 285, 286, 287, 288, -1, -1, -1, -1, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, - 305, 41, -1, 308, 44, -1, 311, 312, 313, 93, - -1, 272, 273, 274, 275, -1, -1, -1, 58, 59, - 281, -1, -1, 63, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, -1, -1, 308, -1, -1, - 311, 312, 313, 93, 272, 273, 274, 275, -1, 58, - -1, -1, -1, 281, 63, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, - 308, -1, 91, 311, 312, 313, -1, -1, -1, -1, + 123, -1, -1, -1, -1, 41, -1, -1, 44, -1, + -1, 91, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, -1, 123, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 93, 294, 295, - -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 123, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 41, 93, - -1, 44, -1, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, -1, -1, 58, 59, 281, -1, -1, - 63, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 41, -1, 308, 44, -1, 311, 312, 313, - 93, -1, 272, 273, 274, 275, -1, -1, -1, 58, - 59, 281, -1, -1, 63, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, -1, 298, 299, - 300, 301, 302, 41, 304, 305, 44, -1, 308, -1, - -1, 311, 312, 313, 93, -1, -1, -1, -1, -1, - 58, 59, 281, -1, -1, 63, 285, 286, 287, 288, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 298, - 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, - -1, -1, 311, 312, 313, 93, 272, 273, 274, 275, - -1, -1, -1, -1, -1, 281, -1, -1, -1, 285, - 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - -1, -1, 308, -1, -1, 311, 312, 313, 272, 273, - 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, - -1, 285, 286, 287, 288, 41, -1, -1, 44, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 58, 59, 308, -1, -1, 311, 312, 313, + -1, -1, -1, -1, -1, -1, -1, -1, 272, 273, + 274, 275, -1, 123, -1, -1, -1, 281, -1, -1, + -1, -1, -1, 287, 288, 289, 290, 93, -1, -1, + -1, -1, -1, 297, 298, -1, 300, 301, 302, 303, + 304, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, 272, 273, 274, 275, -1, 41, 123, -1, 44, + 281, 272, 273, 274, 275, -1, 287, 288, 289, 290, + 281, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, 297, 298, 309, 300, + 301, 312, 313, 314, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, - -1, -1, 285, 286, 287, 288, -1, 93, -1, -1, - -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, - -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, - 313, -1, -1, 272, 273, 274, 275, -1, -1, -1, - -1, -1, 281, -1, -1, -1, 285, 286, 287, 288, - -1, -1, -1, -1, -1, 294, 295, -1, -1, 298, - 299, 300, 301, 302, 41, 304, 305, 44, -1, 308, - -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, - -1, 58, 59, 281, -1, -1, 63, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, - 308, -1, -1, -1, -1, -1, 93, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 93, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 93, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 294, 295, - -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 93, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 93, -1, -1, 281, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, -1, -1, 294, 295, -1, - -1, 298, 299, 300, 301, 302, 41, 304, 305, 44, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 58, 59, 281, -1, -1, 63, 285, - 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - -1, -1, 272, 273, 274, 275, -1, -1, 93, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, -1, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 272, 273, - 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, - -1, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, -1, -1, 272, 273, 274, 275, -1, -1, - -1, -1, -1, 281, -1, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, -1, 304, 305, -1, -1, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, -1, -1, 285, 286, 287, 288, 41, -1, -1, - 44, -1, 294, 295, -1, -1, 298, 299, 300, 301, - 302, -1, 304, 305, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 273, 274, 275, -1, 41, -1, -1, 44, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + -1, 58, 59, -1, 297, 298, 63, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, 272, 273, 274, 275, -1, 41, -1, -1, + 44, 281, -1, -1, -1, -1, 93, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, -1, 272, 273, 274, 275, + -1, 41, -1, -1, 44, 281, -1, -1, -1, 93, + -1, 287, 288, 289, 290, -1, -1, -1, 58, 59, + -1, 297, 298, 63, 300, 301, 302, 303, 304, 305, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, + -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, 93, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 58, 59, 93, - -1, -1, 63, -1, -1, -1, -1, 272, 273, 274, + -1, -1, -1, -1, 93, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, + 287, 288, 289, 290, -1, -1, -1, -1, -1, -1, + 297, 298, 93, 300, 301, 302, 303, 304, 305, 306, + -1, -1, 309, -1, -1, 312, 313, 314, 272, 273, + 274, 275, -1, 41, -1, -1, 44, 281, -1, -1, + -1, -1, -1, 287, 288, 289, 290, -1, -1, -1, + 58, 59, -1, 297, 298, 63, 300, 301, 302, 303, + 304, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, 272, 273, 274, 275, -1, 41, -1, -1, + 44, 281, -1, -1, -1, 93, -1, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, 272, 273, 274, 275, -1, + 41, -1, -1, 44, 281, -1, -1, -1, -1, 93, + 287, 288, 289, 290, -1, -1, -1, 58, 59, -1, + 297, 298, 63, 300, 301, 302, 303, 304, 305, 306, + -1, -1, -1, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, 93, -1, -1, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, 306, -1, -1, + -1, 272, 273, 274, 275, -1, 41, -1, -1, 44, + 281, -1, -1, -1, -1, -1, 287, 288, 289, 290, + 93, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, -1, -1, -1, -1, + -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, 58, + 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, 41, + -1, -1, 44, 281, -1, -1, -1, -1, -1, 287, + 288, 289, 290, -1, 93, -1, 58, 59, -1, 297, + 298, 63, 300, 301, 302, 303, 304, 305, 306, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 272, 273, + 274, 275, -1, 41, -1, -1, 44, 281, -1, -1, + -1, 93, -1, 287, 288, 289, 290, -1, -1, -1, + 58, 59, -1, 297, 298, 63, 300, 301, 302, 303, + 304, 305, 306, -1, -1, -1, -1, -1, -1, -1, + -1, 272, 273, 274, 275, -1, 41, -1, -1, 44, + 281, -1, -1, -1, -1, 93, 287, 288, 289, 290, + -1, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, -1, -1, -1, 272, + 273, 274, 275, -1, 41, -1, -1, 44, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, 93, -1, + -1, 58, 59, -1, 297, 298, 63, 300, 301, 302, + 303, 304, 305, 306, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, 93, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, -1, -1, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + -1, -1, -1, -1, 93, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, -1, -1, -1, + 272, 273, 274, 275, -1, 41, -1, -1, 44, 281, + -1, -1, -1, -1, -1, 287, 288, -1, -1, -1, + 93, -1, 58, 59, -1, 297, 298, 63, 300, 301, + 302, 303, 304, -1, -1, -1, 91, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, 41, + 63, -1, 44, 281, -1, -1, -1, 93, -1, 287, + 288, -1, -1, -1, -1, -1, 58, 59, 123, 297, + 298, 63, 300, 301, 302, 303, 304, -1, 91, -1, + -1, 58, -1, -1, -1, -1, 63, 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, -1, - 285, 286, 287, 288, 41, -1, -1, 44, -1, 294, - 295, -1, 93, 298, 299, 300, 301, 302, -1, 304, - 305, 58, 59, -1, -1, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 58, 59, 93, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, - -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 58, 59, -1, -1, 93, - 63, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - 93, 63, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 41, 58, 59, 44, - -1, 93, 63, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, 58, 59, -1, -1, 281, 63, -1, - -1, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, 93, -1, 298, 299, 300, 301, 302, -1, - 304, 272, 273, 274, 275, -1, -1, -1, 93, -1, - 281, -1, -1, -1, 285, 286, -1, 288, 41, -1, - -1, 44, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 41, 58, 59, 44, -1, -1, - 63, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 58, 59, -1, 281, -1, 63, -1, 285, 286, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - 93, 298, 299, 300, 301, 302, -1, 304, 272, 273, - 274, 275, -1, -1, -1, -1, 93, 281, -1, -1, - -1, 285, 286, -1, -1, -1, -1, -1, -1, 41, - 294, 295, 44, -1, 298, 299, 300, 301, 302, 272, - 273, 274, 275, -1, -1, -1, 58, 59, 281, -1, - -1, 63, 285, 286, -1, -1, -1, -1, -1, -1, - -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, 93, -1, 285, 286, -1, -1, -1, -1, -1, - -1, -1, 294, 295, -1, -1, 298, 299, 300, 301, - 302, 272, 273, 274, 275, -1, -1, -1, -1, -1, - 281, -1, -1, -1, -1, 286, -1, 272, 273, 274, - 275, -1, -1, 294, 295, -1, 281, 298, 299, 300, - 301, 302, -1, -1, -1, -1, -1, -1, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, 93, 287, 288, -1, -1, -1, -1, -1, -1, + 123, -1, 297, 298, 91, 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 294, 295, -1, 281, 298, 299, 300, 301, 302, - -1, -1, 30, -1, -1, -1, -1, 294, 295, -1, - 38, 298, 299, 300, 301, 43, 44, -1, -1, -1, - -1, -1, 50, 51, 52, 53, 54, 55, -1, -1, - 58, 59, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, -1, 90, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 294, 295, -1, -1, 298, 299, 300, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, + 287, 288, -1, -1, -1, 63, 123, -1, -1, -1, + 297, 298, -1, 300, 301, 302, 303, 304, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, 91, -1, -1, -1, -1, 25, 26, + -1, -1, -1, -1, -1, -1, -1, -1, 297, 298, + 37, 300, 301, 302, 303, 304, 43, 44, 45, 272, + 273, 274, 275, 50, -1, 123, -1, -1, 281, 91, + -1, -1, -1, -1, -1, 62, 63, 64, 65, -1, + -1, -1, -1, -1, 297, 298, -1, 300, 301, 302, + 303, -1, 287, 288, 289, 290, 272, 273, 274, 275, + -1, 123, -1, -1, -1, 281, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, + 107, 297, 298, -1, 300, 301, 302, -1, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + 272, 273, 274, 275, -1, -1, -1, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, -1, -1, 281, 297, 298, -1, 300, -1, + 287, 288, 289, 290, -1, -1, -1, -1, -1, 166, + -1, -1, -1, 300, 301, 302, 303, 304, 305, 306, + 30, -1, 309, -1, -1, 312, 313, 314, 38, -1, + -1, -1, 42, 190, -1, 45, -1, -1, -1, -1, + -1, -1, 52, 53, 54, 55, 56, -1, -1, 59, + 60, -1, -1, 281, -1, -1, 66, -1, -1, 287, + 288, 289, 290, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 301, 302, 303, 304, 305, 306, -1, + -1, 309, -1, 93, 312, 313, 314, -1, -1, -1, + -1, -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 143, -1, -1, -1, -1, - -1, -1, -1, 151, 152, 153, 154, 155, 156, 157, - 158, 159, 160, 161, 162, 163, 164, -1, -1, -1, + 302, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 175, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, @@ -1101,16 +1014,16 @@ short yycheck[] = { 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 256, -1, + -1, -1, 252, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 284, + -1, -1, -1, 283, }; #define YYFINAL 1 #ifndef YYDEBUG #define YYDEBUG 0 #endif -#define YYMAXTOKEN 313 +#define YYMAXTOKEN 314 #if YYDEBUG char *yyname[] = { "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, @@ -1123,9 +1036,9 @@ char *yyname[] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","FUNCMETH","THING", "PMFUNC","PRIVATEREF","FUNC0SUB","UNIOPSUB","LSTOPSUB","LABEL","FORMAT","SUB", "ANONSUB","PACKAGE","USE","WHILE","UNTIL","IF","UNLESS","ELSE","ELSIF", -"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","RELOP","EQOP", -"MULOP","ADDOP","DOLSHARP","DO","LOCAL","HASHBRACK","NOAMP","OROP","ANDOP", -"NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP", +"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","UNIOP","LSTOP", +"RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","HASHBRACK","NOAMP","LOCAL","MY", +"OROP","ANDOP","NOTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP", "SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", "POSTDEC","ARROW", }; @@ -1135,6 +1048,8 @@ char *yyrule[] = { "prog : $$1 lineseq", "block : '{' remember lineseq '}'", "remember :", +"mblock : '{' mremember lineseq '}'", +"mremember :", "lineseq :", "lineseq : lineseq decl", "lineseq : lineseq line", @@ -1147,44 +1062,52 @@ char *yyrule[] = { "sideff : expr IF expr", "sideff : expr UNLESS expr", "sideff : expr WHILE expr", -"sideff : expr UNTIL expr", +"sideff : expr UNTIL iexpr", "else :", -"else : ELSE block", -"else : ELSIF '(' expr ')' block else", -"cond : IF '(' expr ')' block else", -"cond : UNLESS '(' expr ')' block else", -"cond : IF block block else", -"cond : UNLESS block block else", +"else : ELSE mblock", +"else : ELSIF '(' mexpr ')' mblock else", +"cond : IF '(' remember mexpr ')' mblock else", +"cond : UNLESS '(' remember miexpr ')' mblock else", "cont :", "cont : CONTINUE block", -"loop : label WHILE '(' texpr ')' block cont", -"loop : label UNTIL '(' expr ')' block cont", -"loop : label WHILE block block cont", -"loop : label UNTIL block block cont", -"loop : label FOR scalar '(' expr ')' block cont", -"loop : label FOR '(' expr ')' block cont", -"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", +"loop : label WHILE '(' remember mtexpr ')' mblock cont", +"loop : label UNTIL '(' remember miexpr ')' mblock cont", +"loop : label FOR MY remember my_scalar '(' mexpr ')' mblock cont", +"loop : label FOR scalar '(' remember mexpr ')' mblock cont", +"loop : label FOR '(' remember mexpr ')' mblock cont", +"loop : label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock", "loop : label block cont", "nexpr :", "nexpr : sideff", "texpr :", "texpr : expr", +"iexpr : expr", +"mexpr : expr", +"mnexpr : nexpr", +"mtexpr : texpr", +"miexpr : iexpr", "label :", "label : LABEL", "decl : format", "decl : subrout", "decl : package", "decl : use", -"format : FORMAT startsub WORD block", -"format : FORMAT startsub block", -"subrout : SUB startsub WORD proto block", -"subrout : SUB startsub WORD proto ';'", +"format : FORMAT startformsub formname block", +"formname : WORD", +"formname :", +"subrout : SUB startsub subname proto subbody", +"startsub :", +"startanonsub :", +"startformsub :", +"subname : WORD", "proto :", "proto : THING", -"startsub :", +"subbody : block", +"subbody : ';'", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", -"use : USE startsub WORD WORD listexpr ';'", +"$$2 :", +"use : USE startsub $$2 WORD WORD listexpr ';'", "expr : expr ANDOP expr", "expr : expr OROP expr", "expr : argexpr", @@ -1198,7 +1121,8 @@ char *yyrule[] = { "listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", "listop : FUNC '(' listexprcom ')'", -"listop : LSTOPSUB startsub block listexpr", +"$$3 :", +"listop : LSTOPSUB startanonsub block $$3 listexpr", "method : METHOD", "method : scalar", "term : term ASSIGNOP term", @@ -1224,14 +1148,14 @@ char *yyrule[] = { "term : term POSTDEC", "term : PREINC term", "term : PREDEC term", -"term : LOCAL term", +"term : local term", "term : '(' expr ')'", "term : '(' ')'", "term : '[' expr ']'", "term : '[' ']'", "term : HASHBRACK expr ';' '}'", "term : HASHBRACK ';' '}'", -"term : ANONSUB startsub proto block", +"term : ANONSUB startanonsub proto block", "term : scalar", "term : star '{' expr ';' '}'", "term : star", @@ -1280,6 +1204,9 @@ char *yyrule[] = { "listexprcom :", "listexprcom : expr", "listexprcom : expr ','", +"local : LOCAL", +"local : MY", +"my_scalar : scalar", "amper : '&' indirob", "scalar : '$' indirob", "ary : '@' indirob", @@ -1312,9 +1239,9 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 571 "perly.y" +#line 626 "perly.y" /* PROGRAM */ -#line 1388 "y.tab.c" +#line 1315 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1539,7 +1466,7 @@ yyreduce: switch (yyn) { case 1: -#line 84 "perly.y" +#line 86 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1548,38 +1475,50 @@ case 1: } break; case 2: -#line 91 "perly.y" +#line 93 "perly.y" { newPROG(yyvsp[0].opval); } break; case 3: -#line 95 "perly.y" -{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } +#line 97 "perly.y" +{ if (copline > (line_t)yyvsp[-3].ival) + copline = yyvsp[-3].ival; + yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 4: -#line 99 "perly.y" -{ yyval.ival = block_start(); } +#line 103 "perly.y" +{ yyval.ival = block_start(TRUE); } break; case 5: -#line 103 "perly.y" -{ yyval.opval = Nullop; } +#line 107 "perly.y" +{ if (copline > (line_t)yyvsp[-3].ival) + copline = yyvsp[-3].ival; + yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 6: -#line 105 "perly.y" -{ yyval.opval = yyvsp[-1].opval; } +#line 113 "perly.y" +{ yyval.ival = block_start(FALSE); } break; case 7: -#line 107 "perly.y" +#line 117 "perly.y" +{ yyval.opval = Nullop; } +break; +case 8: +#line 119 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 9: +#line 121 "perly.y" { yyval.opval = append_list(OP_LINESEQ, (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); pad_reset_pending = TRUE; if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; } break; -case 8: -#line 114 "perly.y" +case 10: +#line 128 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; -case 10: -#line 117 "perly.y" +case 12: +#line 131 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1589,467 +1528,503 @@ case 10: } expect = XSTATE; } break; -case 11: -#line 126 "perly.y" +case 13: +#line 140 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); expect = XSTATE; } break; -case 12: -#line 131 "perly.y" -{ yyval.opval = Nullop; } -break; -case 13: -#line 133 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; case 14: -#line 135 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } +#line 145 "perly.y" +{ yyval.opval = Nullop; } break; case 15: -#line 137 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } +#line 147 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 16: -#line 139 "perly.y" -{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } +#line 149 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 17: -#line 141 "perly.y" -{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} +#line 151 "perly.y" +{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 18: -#line 145 "perly.y" -{ yyval.opval = Nullop; } +#line 153 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 19: -#line 147 "perly.y" -{ yyval.opval = scope(yyvsp[0].opval); } +#line 155 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; case 20: -#line 149 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, 0, - newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); - hints |= HINT_BLOCK_SCOPE; } +#line 159 "perly.y" +{ yyval.opval = Nullop; } break; case 21: -#line 156 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 161 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } break; case 22: -#line 159 "perly.y" +#line 163 "perly.y" { copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, - invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } + yyval.opval = newSTATEOP(0, Nullch, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); + hints |= HINT_BLOCK_SCOPE; } break; case 23: -#line 163 "perly.y" -{ copline = yyvsp[-3].ival; - deprecate("if BLOCK BLOCK"); - yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 170 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; case 24: -#line 167 "perly.y" -{ copline = yyvsp[-3].ival; - deprecate("unless BLOCK BLOCK"); - yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), - scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 174 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; case 25: -#line 174 "perly.y" +#line 180 "perly.y" { yyval.opval = Nullop; } break; case 26: -#line 176 "perly.y" +#line 182 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 27: -#line 180 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 186 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 28: -#line 185 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 192 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: -#line 190 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 198 "perly.y" +{ yyval.opval = block_end(yyvsp[-6].ival, + newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 30: -#line 195 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } +#line 201 "perly.y" +{ yyval.opval = block_end(yyvsp[-4].ival, + newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP), + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 31: -#line 200 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP), - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 205 "perly.y" +{ yyval.opval = block_end(yyvsp[-4].ival, + newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 32: -#line 203 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 209 "perly.y" +{ copline = yyvsp[-9].ival; + yyval.opval = block_end(yyvsp[-7].ival, + append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval), + newSTATEOP(0, yyvsp[-10].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + scalar(yyvsp[-4].opval), + yyvsp[0].opval, scalar(yyvsp[-2].opval))))); } break; case 33: -#line 206 "perly.y" -{ copline = yyvsp[-8].ival; - yyval.opval = append_elem(OP_LINESEQ, - newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), - newSTATEOP(0, yyvsp[-9].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } -break; -case 34: -#line 213 "perly.y" +#line 217 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; -case 35: -#line 219 "perly.y" +case 34: +#line 223 "perly.y" { yyval.opval = Nullop; } break; -case 37: -#line 224 "perly.y" +case 36: +#line 228 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; +case 38: +#line 233 "perly.y" +{ yyval.opval = invert(scalar(yyvsp[0].opval)); } +break; case 39: -#line 229 "perly.y" -{ yyval.pval = Nullch; } +#line 237 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } +break; +case 40: +#line 241 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 41: -#line 234 "perly.y" -{ yyval.ival = 0; } +#line 245 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 42: -#line 236 "perly.y" -{ yyval.ival = 0; } +#line 249 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 43: -#line 238 "perly.y" -{ yyval.ival = 0; } -break; -case 44: -#line 240 "perly.y" -{ yyval.ival = 0; } +#line 253 "perly.y" +{ yyval.pval = Nullch; } break; case 45: -#line 244 "perly.y" -{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +#line 258 "perly.y" +{ yyval.ival = 0; } break; case 46: -#line 246 "perly.y" -{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } +#line 260 "perly.y" +{ yyval.ival = 0; } break; case 47: -#line 250 "perly.y" -{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 262 "perly.y" +{ yyval.ival = 0; } break; case 48: -#line 252 "perly.y" -{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; } +#line 264 "perly.y" +{ yyval.ival = 0; } break; case 49: -#line 256 "perly.y" -{ yyval.opval = Nullop; } +#line 268 "perly.y" +{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 50: +#line 271 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 51: -#line 261 "perly.y" -{ yyval.ival = start_subparse(); } +#line 272 "perly.y" +{ yyval.opval = Nullop; } break; case 52: -#line 265 "perly.y" -{ package(yyvsp[-1].opval); } +#line 276 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 53: -#line 267 "perly.y" -{ package(Nullop); } +#line 280 "perly.y" +{ yyval.ival = start_subparse(); } break; case 54: -#line 271 "perly.y" -{ utilize(yyvsp[-5].ival, yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } +#line 284 "perly.y" +{ yyval.ival = start_subparse(); + CvANON_on(compcv); } break; case 55: -#line 275 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 289 "perly.y" +{ yyval.ival = start_subparse(); + CvFORMAT_on(compcv); } break; case 56: -#line 277 "perly.y" +#line 293 "perly.y" +{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END")) + CvUNIQUE_on(compcv); + yyval.opval = yyvsp[0].opval; } +break; +case 57: +#line 300 "perly.y" +{ yyval.opval = Nullop; } +break; +case 59: +#line 304 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 60: +#line 305 "perly.y" +{ yyval.opval = Nullop; expect = XSTATE; } +break; +case 61: +#line 309 "perly.y" +{ package(yyvsp[-1].opval); } +break; +case 62: +#line 311 "perly.y" +{ package(Nullop); } +break; +case 63: +#line 315 "perly.y" +{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } +break; +case 64: +#line 317 "perly.y" +{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } +break; +case 65: +#line 321 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 66: +#line 323 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 58: -#line 282 "perly.y" +case 68: +#line 328 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 59: -#line 284 "perly.y" +case 69: +#line 330 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 61: -#line 289 "perly.y" +case 71: +#line 335 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; -case 62: -#line 292 "perly.y" +case 72: +#line 338 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; -case 63: -#line 295 "perly.y" +case 73: +#line 341 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval), + prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; -case 64: -#line 300 "perly.y" +case 74: +#line 346 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; -case 65: -#line 305 "perly.y" +case 75: +#line 351 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; -case 66: -#line 310 "perly.y" +case 76: +#line 356 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 67: -#line 312 "perly.y" +case 77: +#line 358 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 68: -#line 314 "perly.y" +case 78: +#line 360 "perly.y" +{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } +break; +case 79: +#line 362 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval), - yyvsp[-3].opval)); } + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; -case 71: -#line 325 "perly.y" +case 82: +#line 372 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; -case 72: -#line 327 "perly.y" +case 83: +#line 374 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 73: -#line 329 "perly.y" +case 84: +#line 376 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; -case 74: -#line 333 "perly.y" +case 85: +#line 380 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 75: -#line 335 "perly.y" +case 86: +#line 382 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 76: -#line 337 "perly.y" +case 87: +#line 384 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 77: -#line 339 "perly.y" +case 88: +#line 386 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 78: -#line 341 "perly.y" +case 89: +#line 388 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 79: -#line 343 "perly.y" +case 90: +#line 390 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 80: -#line 345 "perly.y" +case 91: +#line 392 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; -case 81: -#line 347 "perly.y" +case 92: +#line 394 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 82: -#line 349 "perly.y" +case 93: +#line 396 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 83: -#line 351 "perly.y" +case 94: +#line 398 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 84: -#line 353 "perly.y" +case 95: +#line 400 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 85: -#line 356 "perly.y" +case 96: +#line 403 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; -case 86: -#line 358 "perly.y" +case 97: +#line 405 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 87: -#line 360 "perly.y" +case 98: +#line 407 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 88: -#line 362 "perly.y" +case 99: +#line 409 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; -case 89: -#line 364 "perly.y" +case 100: +#line 411 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; -case 90: -#line 366 "perly.y" +case 101: +#line 413 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; -case 91: -#line 369 "perly.y" +case 102: +#line 416 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; -case 92: -#line 372 "perly.y" +case 103: +#line 419 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; -case 93: -#line 375 "perly.y" +case 104: +#line 422 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; -case 94: -#line 378 "perly.y" +case 105: +#line 425 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; -case 95: -#line 380 "perly.y" +case 106: +#line 427 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; -case 96: -#line 382 "perly.y" +case 107: +#line 429 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; -case 97: -#line 384 "perly.y" +case 108: +#line 431 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; -case 98: -#line 386 "perly.y" +case 109: +#line 433 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; -case 99: -#line 388 "perly.y" +case 110: +#line 435 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; -case 100: -#line 390 "perly.y" +case 111: +#line 437 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; -case 101: -#line 392 "perly.y" +case 112: +#line 439 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 102: -#line 394 "perly.y" +case 113: +#line 441 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 103: -#line 396 "perly.y" +case 114: +#line 443 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; -case 104: -#line 398 "perly.y" +case 115: +#line 445 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 105: -#line 400 "perly.y" +case 116: +#line 447 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; -case 106: -#line 402 "perly.y" +case 117: +#line 449 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 107: -#line 406 "perly.y" +case 118: +#line 453 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 108: -#line 410 "perly.y" +case 119: +#line 457 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 109: -#line 412 "perly.y" +case 120: +#line 459 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 110: -#line 414 "perly.y" +case 121: +#line 461 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; -case 111: -#line 416 "perly.y" +case 122: +#line 463 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 112: -#line 419 "perly.y" +case 123: +#line 466 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 113: -#line 424 "perly.y" +case 124: +#line 471 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 114: -#line 429 "perly.y" +case 125: +#line 476 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; -case 115: -#line 431 "perly.y" +case 126: +#line 478 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; -case 116: -#line 433 "perly.y" +case 127: +#line 480 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, list(yyvsp[-1].opval), ref(yyvsp[-3].opval, OP_ASLICE))); } break; -case 117: -#line 439 "perly.y" +case 128: +#line 486 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2057,38 +2032,38 @@ case 117: ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); expect = XOPERATOR; } break; -case 118: -#line 446 "perly.y" +case 129: +#line 493 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 119: -#line 448 "perly.y" +case 130: +#line 495 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; -case 120: -#line 450 "perly.y" +case 131: +#line 497 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; -case 121: -#line 452 "perly.y" +case 132: +#line 499 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; -case 122: -#line 455 "perly.y" +case 133: +#line 502 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 123: -#line 458 "perly.y" +case 134: +#line 505 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; -case 124: -#line 460 "perly.y" +case 135: +#line 507 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; -case 125: -#line 462 "perly.y" +case 136: +#line 509 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2097,8 +2072,8 @@ case 125: scalar(yyvsp[-2].opval) )),Nullop)); dep();} break; -case 126: -#line 470 "perly.y" +case 137: +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2108,139 +2083,151 @@ case 126: scalar(yyvsp[-3].opval) )))); dep();} break; -case 127: -#line 479 "perly.y" +case 138: +#line 526 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; -case 128: -#line 483 "perly.y" +case 139: +#line 530 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; -case 129: -#line 488 "perly.y" +case 140: +#line 535 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; -case 130: -#line 491 "perly.y" +case 141: +#line 538 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 131: -#line 493 "perly.y" +case 142: +#line 540 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 132: -#line 495 "perly.y" +case 143: +#line 542 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 133: -#line 497 "perly.y" +case 144: +#line 544 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 134: -#line 499 "perly.y" +case 145: +#line 546 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 135: -#line 501 "perly.y" +case 146: +#line 548 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 136: -#line 504 "perly.y" +case 147: +#line 551 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 137: -#line 506 "perly.y" +case 148: +#line 553 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; -case 138: -#line 508 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUB, 0, +case 149: +#line 555 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; -case 139: -#line 511 "perly.y" +case 150: +#line 558 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; -case 140: -#line 513 "perly.y" +case 151: +#line 560 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 141: -#line 515 "perly.y" +case 152: +#line 562 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; -case 142: -#line 517 "perly.y" +case 153: +#line 564 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; -case 145: -#line 523 "perly.y" +case 156: +#line 570 "perly.y" { yyval.opval = Nullop; } break; -case 146: -#line 525 "perly.y" +case 157: +#line 572 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 147: -#line 529 "perly.y" +case 158: +#line 576 "perly.y" { yyval.opval = Nullop; } break; -case 148: -#line 531 "perly.y" +case 159: +#line 578 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 149: -#line 533 "perly.y" +case 160: +#line 580 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 150: -#line 537 "perly.y" +case 161: +#line 583 "perly.y" +{ yyval.ival = 0; } +break; +case 162: +#line 584 "perly.y" +{ yyval.ival = 1; } +break; +case 163: +#line 588 "perly.y" +{ in_my = 0; yyval.opval = my(yyvsp[0].opval); } +break; +case 164: +#line 592 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 151: -#line 541 "perly.y" +case 165: +#line 596 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; -case 152: -#line 545 "perly.y" +case 166: +#line 600 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 153: -#line 549 "perly.y" +case 167: +#line 604 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; -case 154: -#line 553 "perly.y" +case 168: +#line 608 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 155: -#line 557 "perly.y" +case 169: +#line 612 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; -case 156: -#line 561 "perly.y" +case 170: +#line 616 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 157: -#line 563 "perly.y" +case 171: +#line 618 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 158: -#line 565 "perly.y" +case 172: +#line 620 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 159: -#line 568 "perly.y" +case 173: +#line 623 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2230 "y.tab.c" +#line 2217 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/perly.c.diff b/perly.c.diff index f31072a25f..4bae11aa35 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,82 +1,84 @@ -*** perly.c.orig Sun Jul 7 23:27:45 1996 ---- perly.c Sun Jul 7 23:27:46 1996 +Index: perly.c *************** -*** 12,82 **** - deprecate("\"do\" to call subroutines"); +*** 13,82 **** } -- #line 29 "perly.y" -- typedef union { -- I32 ival; -- char *pval; -- OP *opval; -- GV *gvval; -- } YYSTYPE; -- #line 23 "y.tab.c" -- #define WORD 257 -- #define METHOD 258 -- #define FUNCMETH 259 -- #define THING 260 -- #define PMFUNC 261 -- #define PRIVATEREF 262 -- #define FUNC0SUB 263 -- #define UNIOPSUB 264 -- #define LSTOPSUB 265 -- #define LABEL 266 -- #define FORMAT 267 -- #define SUB 268 -- #define ANONSUB 269 -- #define PACKAGE 270 -- #define USE 271 -- #define WHILE 272 -- #define UNTIL 273 -- #define IF 274 -- #define UNLESS 275 -- #define ELSE 276 -- #define ELSIF 277 -- #define CONTINUE 278 -- #define FOR 279 -- #define LOOPEX 280 -- #define DOTDOT 281 -- #define FUNC0 282 -- #define FUNC1 283 -- #define FUNC 284 -- #define RELOP 285 -- #define EQOP 286 -- #define MULOP 287 -- #define ADDOP 288 -- #define DOLSHARP 289 -- #define DO 290 -- #define LOCAL 291 -- #define HASHBRACK 292 -- #define NOAMP 293 -- #define OROP 294 -- #define ANDOP 295 -- #define NOTOP 296 -- #define LSTOP 297 -- #define ASSIGNOP 298 -- #define OROR 299 -- #define ANDAND 300 -- #define BITOROP 301 -- #define BITANDOP 302 -- #define UNIOP 303 -- #define SHIFTOP 304 -- #define MATCHOP 305 -- #define UMINUS 306 -- #define REFGEN 307 -- #define POWOP 308 -- #define PREINC 309 -- #define PREDEC 310 -- #define POSTINC 311 -- #define POSTDEC 312 -- #define ARROW 313 +! #line 29 "perly.y" +! typedef union { +! I32 ival; +! char *pval; +! OP *opval; +! GV *gvval; +! } YYSTYPE; +! #line 23 "y.tab.c" +! #define WORD 257 +! #define METHOD 258 +! #define FUNCMETH 259 +! #define THING 260 +! #define PMFUNC 261 +! #define PRIVATEREF 262 +! #define FUNC0SUB 263 +! #define UNIOPSUB 264 +! #define LSTOPSUB 265 +! #define LABEL 266 +! #define FORMAT 267 +! #define SUB 268 +! #define ANONSUB 269 +! #define PACKAGE 270 +! #define USE 271 +! #define WHILE 272 +! #define UNTIL 273 +! #define IF 274 +! #define UNLESS 275 +! #define ELSE 276 +! #define ELSIF 277 +! #define CONTINUE 278 +! #define FOR 279 +! #define LOOPEX 280 +! #define DOTDOT 281 +! #define FUNC0 282 +! #define FUNC1 283 +! #define FUNC 284 +! #define UNIOP 285 +! #define LSTOP 286 +! #define RELOP 287 +! #define EQOP 288 +! #define MULOP 289 +! #define ADDOP 290 +! #define DOLSHARP 291 +! #define DO 292 +! #define HASHBRACK 293 +! #define NOAMP 294 +! #define LOCAL 295 +! #define MY 296 +! #define OROP 297 +! #define ANDOP 298 +! #define NOTOP 299 +! #define ASSIGNOP 300 +! #define OROR 301 +! #define ANDAND 302 +! #define BITOROP 303 +! #define BITANDOP 304 +! #define SHIFTOP 305 +! #define MATCHOP 306 +! #define UMINUS 307 +! #define REFGEN 308 +! #define POWOP 309 +! #define PREINC 310 +! #define PREDEC 311 +! #define POSTINC 312 +! #define POSTDEC 313 +! #define ARROW 314 + #define YYERRCODE 256 + short yylhs[] = { -1, +--- 13,17 ---- + } + +! #line 16 "perly.c" #define YYERRCODE 256 short yylhs[] = { -1, - 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, ---- 12,17 ---- *************** -*** 1375,1387 **** - int yynerrs; +*** 1303,1313 **** int yyerrflag; int yychar; - short *yyssp; @@ -86,14 +88,12 @@ - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 571 "perly.y" + #line 626 "perly.y" /* PROGRAM */ - #line 1388 "y.tab.c" ---- 1310,1317 ---- +--- 1238,1243 ---- *************** -*** 1388,1401 **** ---- 1318,1376 ---- - #define YYABORT goto yyabort +*** 1316,1327 **** +--- 1246,1302 ---- #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab + @@ -138,7 +138,7 @@ register char *yys; extern char *getenv(); + #endif - ++ + struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + SAVEDESTRUCTOR(yydestruct, ysave); + ysave->oldyydebug = yydebug; @@ -147,15 +147,13 @@ + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; -+ + + #if YYDEBUG if (yys = getenv("YYDEBUG")) { - yyn = *yys; *************** -*** 1408,1413 **** ---- 1383,1396 ---- - yyerrflag = 0; +*** 1336,1339 **** +--- 1311,1322 ---- yychar = (-1); + /* @@ -168,27 +166,21 @@ + yyssp = yyss; yyvsp = yyvs; - *yyssp = yystate = 0; *************** -*** 1423,1429 **** - yys = 0; +*** 1351,1355 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } - #endif ---- 1406,1412 ---- - yys = 0; +--- 1334,1338 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } - #endif *************** -*** 1433,1444 **** - { +*** 1361,1370 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, shifting to state %d\n", @@ -199,9 +191,7 @@ ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; ---- 1416,1441 ---- - { +--- 1344,1367 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, "yydebug: state %d, shifting to state %d\n", @@ -226,10 +216,8 @@ ! yyvsp = yyvs + yypv_index; } *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; *************** -*** 1474,1485 **** - { +*** 1402,1411 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, error recovery shifting\ @@ -240,9 +228,7 @@ ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; ---- 1471,1497 ---- - { +--- 1399,1423 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -268,19 +254,15 @@ ! yyvsp = yyvs + yypv_index; } *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; *************** -*** 1489,1496 **** - { +*** 1417,1422 **** #if YYDEBUG if (yydebug) ! printf("yydebug: error recovery discarding state %d\n", ! *yyssp); #endif if (yyssp <= yyss) goto yyabort; - --yyssp; ---- 1501,1509 ---- - { +--- 1429,1435 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -288,19 +270,15 @@ ! *yyssp); #endif if (yyssp <= yyss) goto yyabort; - --yyssp; *************** -*** 1507,1514 **** - yys = 0; +*** 1435,1440 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, error recovery discards token %d (%s)\n", ! yystate, yychar, yys); } #endif - yychar = (-1); ---- 1520,1528 ---- - yys = 0; +--- 1448,1454 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, @@ -308,36 +286,28 @@ ! yystate, yychar, yys); } #endif - yychar = (-1); *************** -*** 1517,1523 **** - yyreduce: +*** 1445,1449 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif - yym = yylen[yyn]; ---- 1531,1537 ---- - yyreduce: +--- 1459,1463 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif - yym = yylen[yyn]; *************** -*** 2236,2243 **** - { +*** 2224,2229 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state 0 to\ ! state %d\n", YYFINAL); #endif yystate = YYFINAL; - *++yyssp = YYFINAL; ---- 2250,2258 ---- - { +--- 2238,2244 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -345,27 +315,21 @@ ! YYFINAL); #endif yystate = YYFINAL; - *++yyssp = YYFINAL; *************** -*** 2251,2257 **** - yys = 0; +*** 2239,2243 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } - #endif ---- 2266,2272 ---- - yys = 0; +--- 2254,2258 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } - #endif *************** -*** 2266,2285 **** - yystate = yydgoto[yym]; +*** 2254,2263 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state %d \ @@ -376,17 +340,7 @@ ! goto yyoverflow; } *++yyssp = yystate; - *++yyvsp = yyval; - goto yyloop; - yyoverflow: -! yyerror("yacc stack overflow"); - yyabort: -! return (1); - yyaccept: -! return (0); - } ---- 2281,2315 ---- - yystate = yydgoto[yym]; +--- 2269,2293 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -412,7 +366,17 @@ ! yyvsp = yyvs + yypv_index; } *++yyssp = yystate; - *++yyvsp = yyval; +*************** +*** 2265,2272 **** + goto yyloop; + yyoverflow: +! yyerror("yacc stack overflow"); + yyabort: +! return (1); + yyaccept: +! return (0); + } +--- 2295,2302 ---- goto yyloop; yyoverflow: ! yyerror("Out of memory for yacc stack"); @@ -26,35 +26,36 @@ #define FUNC0 282 #define FUNC1 283 #define FUNC 284 -#define RELOP 285 -#define EQOP 286 -#define MULOP 287 -#define ADDOP 288 -#define DOLSHARP 289 -#define DO 290 -#define LOCAL 291 -#define HASHBRACK 292 -#define NOAMP 293 -#define OROP 294 -#define ANDOP 295 -#define NOTOP 296 -#define LSTOP 297 -#define ASSIGNOP 298 -#define OROR 299 -#define ANDAND 300 -#define BITOROP 301 -#define BITANDOP 302 -#define UNIOP 303 -#define SHIFTOP 304 -#define MATCHOP 305 -#define UMINUS 306 -#define REFGEN 307 -#define POWOP 308 -#define PREINC 309 -#define PREDEC 310 -#define POSTINC 311 -#define POSTDEC 312 -#define ARROW 313 +#define UNIOP 285 +#define LSTOP 286 +#define RELOP 287 +#define EQOP 288 +#define MULOP 289 +#define ADDOP 290 +#define DOLSHARP 291 +#define DO 292 +#define HASHBRACK 293 +#define NOAMP 294 +#define LOCAL 295 +#define MY 296 +#define OROP 297 +#define ANDOP 298 +#define NOTOP 299 +#define ASSIGNOP 300 +#define OROR 301 +#define ANDAND 302 +#define BITOROP 303 +#define BITANDOP 304 +#define SHIFTOP 305 +#define MATCHOP 306 +#define UMINUS 307 +#define REFGEN 308 +#define POWOP 309 +#define PREINC 310 +#define PREDEC 311 +#define POSTINC 312 +#define POSTDEC 313 +#define ARROW 314 typedef union { I32 ival; char *pval; @@ -62,3 +63,4 @@ typedef union { GV *gvval; } YYSTYPE; extern YYSTYPE yylval; +extern YYSTYPE yylval; @@ -41,22 +41,24 @@ dep() %token <ival> FORMAT SUB ANONSUB PACKAGE USE %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR %token <ival> LOOPEX DOTDOT -%token <ival> FUNC0 FUNC1 FUNC +%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP %token <ival> RELOP EQOP MULOP ADDOP -%token <ival> DOLSHARP DO LOCAL HASHBRACK NOAMP +%token <ival> DOLSHARP DO HASHBRACK NOAMP +%token LOCAL MY -%type <ival> prog decl format remember startsub '&' -%type <opval> block lineseq line loop cond nexpr else argexpr +%type <ival> prog decl local format startsub startanonsub startformsub +%type <ival> remember mremember '&' +%type <opval> block mblock lineseq line loop cond else %type <opval> expr term scalar ary hsh arylen star amper sideff -%type <opval> listexpr listexprcom indirob -%type <opval> texpr listop method proto +%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr +%type <opval> listexpr listexprcom indirob listop method +%type <opval> formname subname proto subbody cont my_scalar %type <pval> label -%type <opval> cont %left <ival> OROP %left ANDOP %right NOTOP -%nonassoc <ival> LSTOP +%nonassoc LSTOP LSTOPSUB %left ',' %right <ival> ASSIGNOP %right '?' ':' @@ -67,7 +69,7 @@ dep() %left <ival> BITANDOP %nonassoc EQOP %nonassoc RELOP -%nonassoc <ival> UNIOP +%nonassoc UNIOP UNIOPSUB %left <ival> SHIFTOP %left ADDOP %left MULOP @@ -92,11 +94,23 @@ prog : /* NULL */ ; block : '{' remember lineseq '}' - { $$ = block_end($1,$2,$3); } + { if (copline > (line_t)$1) + copline = $1; + $$ = block_end($2, $3); } ; -remember: /* NULL */ /* start a lexical scope */ - { $$ = block_start(); } +remember: /* NULL */ /* start a full lexical scope */ + { $$ = block_start(TRUE); } + ; + +mblock : '{' mremember lineseq '}' + { if (copline > (line_t)$1) + copline = $1; + $$ = block_end($2, $3); } + ; + +mremember: /* NULL */ /* start a partial lexical scope */ + { $$ = block_start(FALSE); } ; lineseq : /* NULL */ @@ -137,37 +151,29 @@ sideff : error { $$ = newLOGOP(OP_OR, 0, $3, $1); } | expr WHILE expr { $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); } - | expr UNTIL expr - { $$ = newLOOPOP(OPf_PARENS, 1, invert(scalar($3)), $1);} + | expr UNTIL iexpr + { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1);} ; else : /* NULL */ { $$ = Nullop; } - | ELSE block + | ELSE mblock { $$ = scope($2); } - | ELSIF '(' expr ')' block else + | ELSIF '(' mexpr ')' mblock else { copline = $1; - $$ = newSTATEOP(0, 0, - newCONDOP(0, $3, scope($5), $6)); + $$ = newSTATEOP(0, Nullch, + newCONDOP(0, $3, scope($5), $6)); hints |= HINT_BLOCK_SCOPE; } ; -cond : IF '(' expr ')' block else - { copline = $1; - $$ = newCONDOP(0, $3, scope($5), $6); } - | UNLESS '(' expr ')' block else +cond : IF '(' remember mexpr ')' mblock else { copline = $1; - $$ = newCONDOP(0, - invert(scalar($3)), scope($5), $6); } - | IF block block else + $$ = block_end($3, + newCONDOP(0, $4, scope($6), $7)); } + | UNLESS '(' remember miexpr ')' mblock else { copline = $1; - deprecate("if BLOCK BLOCK"); - $$ = newCONDOP(0, scope($2), scope($3), $4); } - | UNLESS block block else - { copline = $1; - deprecate("unless BLOCK BLOCK"); - $$ = newCONDOP(0, invert(scalar(scope($2))), - scope($3), $4); } + $$ = block_end($3, + newCONDOP(0, $4, scope($6), $7)); } ; cont : /* NULL */ @@ -176,39 +182,37 @@ cont : /* NULL */ { $$ = scope($2); } ; -loop : label WHILE '(' texpr ')' block cont - { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - $4, $6, $7) ); } - | label UNTIL '(' expr ')' block cont - { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar($4)), $6, $7) ); } - | label WHILE block block cont +loop : label WHILE '(' remember mtexpr ')' mblock cont { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - scope($3), $4, $5) ); } - | label UNTIL block block cont + $$ = block_end($4, + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + $5, $7, $8))); } + | label UNTIL '(' remember miexpr ')' mblock cont { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar(scope($3))), $4, $5)); } - | label FOR scalar '(' expr ')' block cont - { $$ = newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP), - $5, $7, $8); } - | label FOR '(' expr ')' block cont - { $$ = newFOROP(0, $1, $2, Nullop, $4, $6, $7); } - | label FOR '(' nexpr ';' texpr ';' nexpr ')' block + $$ = block_end($4, + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + $5, $7, $8))); } + | label FOR MY remember my_scalar '(' mexpr ')' mblock cont + { $$ = block_end($4, + newFOROP(0, $1, $2, $5, $7, $9, $10)); } + | label FOR scalar '(' remember mexpr ')' mblock cont + { $$ = block_end($5, + newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP), + $6, $8, $9)); } + | label FOR '(' remember mexpr ')' mblock cont + { $$ = block_end($4, + newFOROP(0, $1, $2, Nullop, $5, $7, $8)); } + | label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock /* basically fake up an initialize-while lineseq */ - { copline = $2; - $$ = append_elem(OP_LINESEQ, - newSTATEOP(0, $1, scalar($4)), - newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar($6), $10, scalar($8)) )); } + { copline = $2; + $$ = block_end($4, + append_elem(OP_LINESEQ, scalar($5), + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + scalar($7), + $11, scalar($9))))); } | label block cont /* a block is a loop that happens once */ { $$ = newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, @@ -225,6 +229,26 @@ texpr : /* NULL means true */ | expr ; +iexpr : expr + { $$ = invert(scalar($1)); } + ; + +mexpr : expr + { $$ = $1; intro_my(); } + ; + +mnexpr : nexpr + { $$ = $1; intro_my(); } + ; + +mtexpr : texpr + { $$ = $1; intro_my(); } + ; + +miexpr : iexpr + { $$ = $1; intro_my(); } + ; + label : /* empty */ { $$ = Nullch; } | LABEL @@ -240,25 +264,45 @@ decl : format { $$ = 0; } ; -format : FORMAT startsub WORD block +format : FORMAT startformsub formname block { newFORM($2, $3, $4); } - | FORMAT startsub block - { newFORM($2, Nullop, $3); } ; -subrout : SUB startsub WORD proto block +formname: WORD { $$ = $1; } + | /* NULL */ { $$ = Nullop; } + ; + +subrout : SUB startsub subname proto subbody { newSUB($2, $3, $4, $5); } - | SUB startsub WORD proto ';' - { newSUB($2, $3, $4, Nullop); expect = XSTATE; } + ; + +startsub: /* NULL */ /* start a subroutine scope */ + { $$ = start_subparse(); } + ; + +startanonsub: /* NULL */ /* start an anonymous subroutine scope */ + { $$ = start_subparse(); + CvANON_on(compcv); } + ; + +startformsub: /* NULL */ /* start a format subroutine scope */ + { $$ = start_subparse(); + CvFORMAT_on(compcv); } + ; + +subname : WORD { char *name = SvPVx(((SVOP*)$1)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END")) + CvUNIQUE_on(compcv); + $$ = $1; } ; proto : /* NULL */ { $$ = Nullop; } | THING ; - -startsub: /* NULL */ /* start a subroutine scope */ - { $$ = start_subparse(); } + +subbody : block { $$ = $1; } + | ';' { $$ = Nullop; expect = XSTATE; } ; package : PACKAGE WORD ';' @@ -267,8 +311,10 @@ package : PACKAGE WORD ';' { package(Nullop); } ; -use : USE startsub WORD WORD listexpr ';' - { utilize($1, $2, $3, $4, $5); } +use : USE startsub + { CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } + WORD WORD listexpr ';' + { utilize($1, $2, $4, $5, $6); } ; expr : expr ANDOP expr @@ -294,7 +340,7 @@ listop : LSTOP indirob argexpr | term ARROW method '(' listexprcom ')' { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, $1, $5), + prepend_elem(OP_LIST, scalar($1), $5), newUNOP(OP_METHOD, 0, $3))); } | METHOD indirob listexpr { $$ = convert(OP_ENTERSUB, OPf_STACKED, @@ -310,11 +356,12 @@ listop : LSTOP indirob argexpr { $$ = convert($1, 0, $2); } | FUNC '(' listexprcom ')' { $$ = convert($1, 0, $3); } - | LSTOPSUB startsub block listexpr %prec LSTOP + | LSTOPSUB startanonsub block + { $3 = newANONSUB($2, 0, $3); } + listexpr %prec LSTOP { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - prepend_elem(OP_LIST, newANONSUB($2, 0, $3), $4), - $1)); } + append_elem(OP_LIST, + prepend_elem(OP_LIST, $3, $5), $1)); } ; method : METHOD @@ -374,7 +421,7 @@ term : term ASSIGNOP term | PREDEC term { $$ = newUNOP(OP_PREDEC, 0, mod(scalar($2), OP_PREDEC)); } - | LOCAL term %prec UNIOP + | local term %prec UNIOP { $$ = localize($2,$1); } | '(' expr ')' { $$ = sawparens($2); } @@ -388,7 +435,7 @@ term : term ASSIGNOP term { $$ = newANONHASH($2); } | HASHBRACK ';' '}' %prec '(' { $$ = newANONHASH(Nullop); } - | ANONSUB startsub proto block %prec '(' + | ANONSUB startanonsub proto block %prec '(' { $$ = newANONSUB($2, $3, $4); } | scalar %prec '(' { $$ = $1; } @@ -505,7 +552,7 @@ term : term ASSIGNOP term | FUNC0 '(' ')' { $$ = newOP($1, 0); } | FUNC0SUB - { $$ = newUNOP(OP_ENTERSUB, 0, + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } | FUNC1 '(' ')' { $$ = newOP($1, OPf_SPECIAL); } @@ -533,6 +580,14 @@ listexprcom: /* NULL */ { $$ = $1; } ; +local : LOCAL { $$ = 0; } + | MY { $$ = 1; } + ; + +my_scalar: scalar + { in_my = 0; $$ = my($1); } + ; + amper : '&' indirob { $$ = newCVREF($1,$2); } ; diff --git a/plan9/buildinfo b/plan9/buildinfo index 849d3cef65..4fcbae698f 100644 --- a/plan9/buildinfo +++ b/plan9/buildinfo @@ -1 +1 @@ -p9pvers = 5.003_05 +p9pvers = 5.003_08 diff --git a/plan9/config.plan9 b/plan9/config.plan9 index 1e4ec52521..b10c75852f 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -1,22 +1,14 @@ -/* This file (config_H) is a sample config.h file. If you are unable - to successfully run Configure, copy this file to config.h and - edit it to suit your system. -*/ /* - * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by - * running Configure. - * - * Feel free to modify any of this as the need arises. Note, however, - * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit config.sh and rerun config_h.SH. - * - * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ - */ + * This file is mangled by fndvers (and perhaps other scripts) to produce the config.h + * for Plan 9. It was handwritten because the standard configuration scripts were + * written in a shell dialect incomprehensible to Plan 9. + * config.h for Plan 9 + * Version: 5.004 + */ -/* Configuration time: Thu Feb 8 17:15:11 EST 1996 - * Configured by: doughera - * Target system: sunos fractal 5.4 generic_101946-29 i86pc i386 +/* Configuration time: 21-Oct-1996 15:11 + * Configured by: Luther Huffman, lutherh@stratcom.com + * Target system: Plan 9 */ #ifndef _config_h_ @@ -43,7 +35,15 @@ * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. */ -#define MEM_ALIGNBYTES 8 /* config-skip */ +#if (_P9P_OBJTYPE == 386) || (_P9P_OBJTYPE==power) +# define MEM_ALIGNBYTES 4 /* config-skip */ +#else +# if _P9P_OBJTYPE == 68020 +# define MEM_ALIGNBYTES 2 /* config-skip */ +# else +# define MEM_ALIGNBYTES 8 /* config-skip */ +# endif +#endif /* BIN: * This symbol holds the path of the bin directory where the package will diff --git a/plan9/exclude b/plan9/exclude index 2b941ff99c..7d9fc3c8af 100644 --- a/plan9/exclude +++ b/plan9/exclude @@ -2,6 +2,8 @@ comp/cpp.t io/dup.t io/fs.t lib/anydbm.t +lib/complex.t +lib/filefind.t lib/io_dup.t lib/io_pipe.t lib/io_sock.t diff --git a/plan9/genconfig.pl b/plan9/genconfig.pl index edcaf338db..c23bd885b6 100644 --- a/plan9/genconfig.pl +++ b/plan9/genconfig.pl @@ -82,7 +82,6 @@ eunicefix=':' hint='none' hintfile='' intsize='4' -alignbytes='8' shrplib='define' usemymalloc='n' usevfork='true' @@ -127,24 +126,26 @@ print OUT "siglongjmp='siglongjmp(buf,retval) '\n"; print OUT "exe_ext=''\n"; if ($p9p_objtype eq '386') { $objext = '.8'; + $alignbytes = '4'; + $cstflags = 2; } elsif ($p9p_objtype eq '68020') { $objext = '.2'; + $alignbytes = '2'; + $cstflags = 0; } elsif ($p9p_objtype eq 'mips') { $objext = '.v'; + $alignbytes = '8'; + $cstflags = 0; } elsif ($p9p_objtype eq 'sparc') { $objext = '.k'; -} -print OUT "obj_ext='$objext'\n"; - -if ($p9p_objtype eq '386') { - $cstflags = 2; -} -else { + $alignbytes = '4'; $cstflags = 0; } +print OUT "obj_ext='$objext'\n"; +print OUT "alignbytes='$alignbytes'\n"; print OUT "castflags='$cstflags'\n"; $myname = $ENV{'site'} ; diff --git a/plan9/mkfile b/plan9/mkfile index dc10cf6a70..e3102f5ef0 100644 --- a/plan9/mkfile +++ b/plan9/mkfile @@ -8,7 +8,7 @@ archlib = /$objtype/lib/perl/$p9pvers sitelib = $privlib/site_perl sitearch = $archlib/site_perl -CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DNO_EMBED -DMY_UV_MAX=0x7fffffffUL +CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DMY_UV_MAX=0x7fffffffUL LDFLAGS = -B CCCMD = $CC -c $CFLAGS @@ -20,7 +20,7 @@ perlshr = $archlib/CORE/libperlshr.a installman1dir = /sys/man/1 installman3dir = /sys/man/2 -podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlovl perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut +podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut libpods = ${podnames:%=pod/%.pod} @@ -40,6 +40,7 @@ testlist = base/*.t comp/*.t cmd/*.t io/*.t op/*.t install:V: perl preplibrary cp perl /$objtype/bin/perl cp plan9/aperl /rc/bin/Perl + mk man perl: config.h miniperlmain.$O miniperl $archlib/Config.pm perlmain.$O $perlshr $LD $CFLAGS -o perl perlmain.$O $perllib $perlshr diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 6613c362e6..c225d286a3 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -73,6 +73,18 @@ */ #define ACME_MESS /**/ +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) # include <signal.h> #endif diff --git a/plan9/setup.rc b/plan9/setup.rc index 037ecfb25c..dd96c1f9c7 100644 --- a/plan9/setup.rc +++ b/plan9/setup.rc @@ -9,8 +9,11 @@ awk -f versnum ../patchlevel.h . buildinfo builddir = `{ cd .. ; pwd } -if(flag a) platforms = (386 mips sparc 68020) -if not platforms = $objtype +if (~ $#* 0) platforms = $objtype +if not switch($1) { + case -a ; platforms = (386 mips sparc 68020) + case * ; echo 'Usage: setup.rc [-a]' >[1=2] ; exit +} sourcedir=/sys/src/cmd/perl/$p9pvers privlib=/sys/lib/perl sitelib=$privlib/site_perl diff --git a/pod/Makefile b/pod/Makefile index 564a63a192..cd01028069 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -3,149 +3,153 @@ CONVERTERS = pod2html pod2latex pod2man pod2text checkpods all: $(CONVERTERS) man PERL = ../miniperl -POD = \ +POD = \ perl.pod \ - perlapio.pod \ - perlbook.pod \ - perlbot.pod \ - perlcall.pod \ + perlnews.pod \ perldata.pod \ - perldebug.pod \ - perldiag.pod \ - perldsc.pod \ - perlembed.pod \ - perlform.pod \ - perlfunc.pod \ - perlguts.pod \ - perli18n.pod \ - perlipc.pod \ - perllol.pod \ - perlmod.pod \ - perlobj.pod \ + perlsyn.pod \ perlop.pod \ - perlovl.pod \ - perlpod.pod \ perlre.pod \ - perlref.pod \ perlrun.pod \ - perlsec.pod \ - perlstyle.pod \ + perlfunc.pod \ + perlvar.pod \ perlsub.pod \ - perlsyn.pod \ + perlmod.pod \ + perlform.pod \ + perllocale.pod \ + perlref.pod \ + perldsc.pod \ + perllol.pod \ + perltoot.pod \ + perlobj.pod \ perltie.pod \ - perltoc.pod \ + perlbot.pod \ + perlipc.pod \ + perldebug.pod \ + perldiag.pod \ + perlsec.pod \ perltrap.pod \ - perlvar.pod \ + perlstyle.pod \ + perlpod.pod \ + perlbook.pod \ + perlembed.pod \ + perlapio.pod \ perlxs.pod \ - perlxstut.pod + perlxstut.pod \ + perlguts.pod \ + perlcall.pod \ + perltoc.pod -MAN = \ +MAN = \ perl.man \ - perlapio.man \ - perlbook.man \ - perlbot.man \ - perlcall.man \ + perlnews.man \ perldata.man \ - perldebug.man \ - perldiag.man \ - perldsc.man \ - perlembed.man \ - perlform.man \ - perlfunc.man \ - perlguts.man \ - perli18n.man \ - perlipc.man \ - perllol.man \ - perlmod.man \ - perlobj.man \ + perlsyn.man \ perlop.man \ - perlovl.man \ - perlpod.man \ perlre.man \ - perlref.man \ perlrun.man \ - perlsec.man \ - perlstyle.man \ + perlfunc.man \ + perlvar.man \ perlsub.man \ - perlsyn.man \ + perlmod.man \ + perlform.man \ + perllocale.man \ + perlref.man \ + perldsc.man \ + perllol.man \ + perltoot.man \ + perlobj.man \ perltie.man \ - perltoc.man \ + perlbot.man \ + perlipc.man \ + perldebug.man \ + perldiag.man \ + perlsec.man \ perltrap.man \ - perlvar.man \ + perlstyle.man \ + perlpod.man \ + perlbook.man \ + perlembed.man \ + perlapio.man \ perlxs.man \ - perlxstut.man + perlxstut.man \ + perlguts.man \ + perlcall.man \ + perltoc.man -HTML = \ +HTML = \ perl.html \ - perlapio.html \ - perlbook.html \ - perlbot.html \ - perlcall.html \ + perlnews.html \ perldata.html \ - perldebug.html \ - perldiag.html \ - perldsc.html \ - perlembed.html \ - perlform.html \ - perlfunc.html \ - perlguts.html \ - perli18n.html \ - perlipc.html \ - perllol.html \ - perlmod.html \ - perlobj.html \ + perlsyn.html \ perlop.html \ - perlovl.html \ - perlpod.html \ perlre.html \ - perlref.html \ perlrun.html \ - perlsec.html \ - perlstyle.html \ + perlfunc.html \ + perlvar.html \ perlsub.html \ - perlsyn.html \ + perlmod.html \ + perlform.html \ + perllocale.html \ + perlref.html \ + perldsc.html \ + perllol.html \ + perltoot.html \ + perlobj.html \ perltie.html \ - perltoc.html \ + perlbot.html \ + perlipc.html \ + perldebug.html \ + perldiag.html \ + perlsec.html \ perltrap.html \ - perlvar.html \ + perlstyle.html \ + perlpod.html \ + perlbook.html \ + perlembed.html \ + perlapio.html \ perlxs.html \ - perlxstut.html + perlxstut.html \ + perlguts.html \ + perlcall.html \ + perltoc.html -TEX = \ +TEX = \ perl.tex \ - perlapio.tex \ - perlbook.tex \ - perlbot.tex \ - perlcall.tex \ + perlnews.tex \ perldata.tex \ - perldebug.tex \ - perldiag.tex \ - perldsc.tex \ - perlembed.tex \ - perlform.tex \ - perlfunc.tex \ - perlguts.tex \ - perli18n.tex \ - perlipc.tex \ - perllol.tex \ - perlmod.tex \ - perlobj.tex \ + perlsyn.tex \ perlop.tex \ - perlovl.tex \ - perlpod.tex \ perlre.tex \ - perlref.tex \ perlrun.tex \ - perlsec.tex \ - perlstyle.tex \ + perlfunc.tex \ + perlvar.tex \ perlsub.tex \ - perlsyn.tex \ + perlmod.tex \ + perlform.tex \ + perllocale.tex \ + perlref.tex \ + perldsc.tex \ + perllol.tex \ + perltoot.tex \ + perlobj.tex \ perltie.tex \ - perltoc.tex \ + perlbot.tex \ + perlipc.tex \ + perldebug.tex \ + perldiag.tex \ + perlsec.tex \ perltrap.tex \ - perlvar.tex \ + perlstyle.tex \ + perlpod.tex \ + perlbook.tex \ + perlembed.tex \ + perlapio.tex \ perlxs.tex \ - perlxstut.tex + perlxstut.tex \ + perlguts.tex \ + perlcall.tex \ + perltoc.tex man: pod2man $(MAN) @@ -156,6 +160,9 @@ html: pod2html tex: pod2latex $(TEX) +toc: + $(PERL) -I../lib buildtoc >perltoc.pod + .SUFFIXES: .pm .pod .man .pm.man: pod2man @@ -182,6 +189,7 @@ tex: pod2latex $(TEX) clean: rm -f $(MAN) $(HTML) $(TEX) + rm -f *.aux *.log realclean: clean rm -f $(CONVERTERS) diff --git a/pod/buildtoc b/pod/buildtoc index 8a9b7ff5cb..da458568da 100644 --- a/pod/buildtoc +++ b/pod/buildtoc @@ -1,21 +1,23 @@ use File::Find; use Cwd; +use Text::Wrap; -@pods = qw{ - perl - perldata perlsyn perlop perlre perlrun perlfunc perlvar - perlsub perlmod perlform - perlref perldsc perllol perlobj perltie perlbot perlipc - perldebug perldiag perlsec perltrap perlstyle - perlpod perlbook +sub output ($); + +@pods = qw( + perl perlnews perldata perlsyn perlop perlre perlrun perlfunc + perlvar perlsub perlmod perlform perllocale perlref perldsc + perllol perltoot perlobj perltie perlbot perlipc perldebug + perldiag perlsec perltrap perlstyle perlpod perlbook perlembed perlapio perlxs perlxstut perlguts perlcall - }; -for (@pods) { s/$/.pod/ } + ); + +for (@pods) { s/$/.pod/ } $/ = ''; @ARGV = @pods; -($_= <<EOPOD2B) =~ s/^\t//gm && print; +($_= <<EOPOD2B) =~ s/^\t//gm && output($_); =head1 NAME @@ -23,38 +25,40 @@ $/ = ''; =head1 DESCRIPTION - This page provides a brief table of contents for the rest of the Perl - documentation set. It is meant to be be quickly scanned or grepped + This page provides a brief table of contents for the rest of the Perl + documentation set. It is meant to be scanned quickly or grepped through to locate the proper section you're looking for. =head1 BASIC DOCUMENTATION EOPOD2B +#' make emacs happy podset(@pods); find \&getpods => qw(../lib ../ext); + sub getpods { - if (/\.p(od|m)$/) { - my $tmp; + if (/\.p(od|m)$/) { # Skip .pm files that have corresponding .pod files, and Functions.pm. - return if (($tmp = $_) =~ s/\.pm$/.pod/ && -f $tmp); - return if ($_ eq '../lib/Pod/Functions.pm');####Used only by pod itself - + return if /(.*)\.pm$/ && -f "$1.pod"; my $file = $File::Find::name; + return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself + die "tut $name" if $file =~ /TUT/; unless (open (F, "< $_\0")) { warn "bogus <$file>: $!"; system "ls", "-l", $file; - } else { + } + else { my $line; while ($line = <F>) { if ($line =~ /^=head1\s+NAME\b/) { push @modpods, $file; #warn "GOOD $file\n"; return; - } - } + } + } warn "EVIL $file\n"; } } @@ -71,14 +75,14 @@ for (@modpods) { if ($done{$name}++) { # warn "already did $_\n"; next; - } + } push @modules, $_; push @modname, $name; - } -} + } +} + +($_= <<EOPOD2B) =~ s/^\t//gm && output($_); -($_= <<EOPOD2B) =~ s/^\t//gm && print; - =head1 PRAGMA DOCUMENTATION @@ -87,8 +91,8 @@ EOPOD2B podset(sort @pragmata); -($_= <<EOPOD2B) =~ s/^\t//gm && print; - +($_= <<EOPOD2B) =~ s/^\t//gm && output($_); + =head1 MODULE DOCUMENTATION @@ -98,41 +102,41 @@ EOPOD2B podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] ); ($_= <<EOPOD2B) =~ s/^\t//gm; - + =head1 AUXILIARY DOCUMENTATION - Here should be listed all the extra programs' docs, but they - don't all have man pages yet: + Here should be listed all the extra programs' documentation, but they + don't all have manual pages yet: =item a2p =item s2p =item find2perl - + =item h2ph - + =item c2ph =item h2xs =item xsubpp - =item pod2man + =item pod2man =item wrapsuid =head1 AUTHOR - Larry Wall E<lt>F<lwall\@sems.com>E<gt>, with the help of oodles + Larry Wall E<lt>F<larry\@wall.org>E<gt>, with the help of oodles of other folks. EOPOD2B -print; - +output $_; +output "\n"; # flush $LINE exit; sub podset { @@ -141,36 +145,30 @@ sub podset { while(<>) { if (s/^=head1 (NAME)\s*/=head2 /) { $pod = path2modname($ARGV); - sub path2modname { - local $_ = shift; - s/\.p(m|od)$//; - s-.*?/(lib|ext)/--; - s-/-::-g; - s/(\w+)::\1/$1/; - return $_; - } - unitem(); unhead2(); - print "\n \n\n=head2 "; + unitem(); + unhead2(); + output "\n \n\n=head2 "; $_ = <>; if ( /^\s*$pod\b/ ) { - print; + s/$pod\.pm/$pod/; # '.pm' in NAME !? + output $_; } else { s/^/$pod, /; - print; - } + output $_; + } next; } if (s/^=head1 (.*)/=item $1/) { unitem(); unhead2(); - print; nl(); next; - } + output $_; nl(); next; + } if (s/^=head2 (.*)/=item $1/) { unitem(); - print "=over\n\n" unless $inhead2; + output "=over\n\n" unless $inhead2; $inhead2 = 1; - print; nl(); next; + output $_; nl(); next; - } + } if (s/^=item (.*)\n/$1/) { next if $pod eq 'perldiag'; s/^\s*\*\s*$// && next; @@ -179,31 +177,62 @@ sub podset { next if /^[\d.]+$/; next if $pod eq 'perlmod' && /^ftp:/; ##print "=over\n\n" unless $initem; - print ", " if $initem; + output ", " if $initem; $initem = 1; s/\.$//; - print; next; - } - } + s/^-X\b/-I<X>/; + output $_; next; + } + } +} -} +sub path2modname { + local $_ = shift; + s/\.p(m|od)$//; + s-.*?/(lib|ext)/--; + s-/-::-g; + s/(\w+)::\1/$1/; + return $_; +} sub unhead2 { if ($inhead2) { - print "\n\n=back\n\n"; - } - $inhead2 = 0; - $initem = 0; -} + output "\n\n=back\n\n"; + } + $inhead2 = 0; + $initem = 0; +} sub unitem { if ($initem) { - print "\n\n"; + output "\n\n"; ##print "\n\n=back\n\n"; - } + } $initem = 0; -} +} sub nl { - print "\n"; -} + output "\n"; +} + +my $NEWLINE; # how many newlines have we seen recently +my $LINE; # what remains to be printed + +sub output ($) { + for (split /(\n)/, shift) { + if ($_ eq "\n") { + if ($LINE) { + print wrap('', '', $LINE); + $LINE = ''; + } + if ($NEWLINE < 2) { + print; + $NEWLINE++; + } + } + elsif (/\S/ && length) { + $LINE .= $_; + $NEWLINE = 0; + } + } +} diff --git a/pod/checkpods.PL b/pod/checkpods.PL index 25d1f18fb6..c4721a6118 100644 --- a/pod/checkpods.PL +++ b/pod/checkpods.PL @@ -12,11 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($Config{'osname'} eq 'VMS' or - $Config{'osname'} eq 'OS2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -26,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. diff --git a/pod/perl.pod b/pod/perl.pod index 2487a5e742..7ac7094f57 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -19,7 +19,7 @@ For ease of access, the Perl manual has been split up into a number of sections: perl Perl overview (this section) - perltoc Perl documentation table of contents + perlnews Perl news about changes from previous version perldata Perl data structures perlsyn Perl syntax @@ -31,11 +31,12 @@ of sections: perlsub Perl subroutines perlmod Perl modules perlform Perl formats - perli18n Perl internalization + perllocale Perl locale support perlref Perl references perldsc Perl data structures intro perllol Perl data structures: lists of lists + perltoot Perl OO tutorial perlobj Perl objects perltie Perl objects hidden behind simple variables perlbot Perl OO tricks and examples @@ -69,7 +70,7 @@ in the appropriate start-up files. To find out where these are, type: perl -V:man.dir If the directories were F</usr/local/man/man1> and F</usr/local/man/man3>, -you would only need to add F</usr/local/man> to your MANPATH. If +you would need to add only F</usr/local/man> to your MANPATH. If they are different, you'll have to add both stems. If that doesn't work for some reason, you can still use the @@ -82,7 +83,7 @@ will often point out exactly where the trouble is. =head1 DESCRIPTION -Perl is an interpreted language optimized for scanning arbitrary +Perl is a language optimized for scanning arbitrary text files, extracting information from those text files, and printing reports based on that information. It's also a good language for many system management tasks. The language is intended to be practical @@ -138,7 +139,8 @@ will continue to work unchanged. Perl variables may now be declared within a lexical scope, like "auto" variables in C. Not only is this more efficient, but it contributes -to better privacy for "programming in the large". +to better privacy for "programming in the large". Anonymous +subroutines exhibit deep binding of lexical variables (closures). =item * Arbitrarily nested data structures @@ -166,7 +168,7 @@ Perl may now be embedded easily in your C or C++ application, and can either call or be called by your routines through a documented interface. The XS preprocessor is provided to make it easy to glue your C or C++ routines into Perl. Dynamic loading of modules is -supported. +supported, and Perl itself can be made into a dynamic library. =item * POSIX compliant @@ -191,7 +193,7 @@ to an object class which defines its access methods. =item * Subroutine definitions may now be autoloaded In fact, the AUTOLOAD mechanism also allows you to define any arbitrary -semantics for undefined subroutine calls. It's not just for autoloading. +semantics for undefined subroutine calls. It's not for just autoloading. =item * Regular expression enhancements @@ -201,6 +203,18 @@ with embedded whitespace and comments for readability. A consistent extensibility mechanism has been added that is upwardly compatible with all old regular expressions. +=item * Innumerable Unbundled Modules + +The Comprehensive Perl Archive Network described in L<perlmod> +contains hundreds of plug-and-play modules full of reusable +code. See F<http://www.perl.com/CPAN> for a site near you. + +=item * Compilability + +While not yet in full production mode, a working perl-to-C compiler +does exist. It can generate portable bytecode, simple C, or +optimized C code. + =back Ok, that's I<definitely> enough hype. @@ -239,6 +253,12 @@ The command used to get the debugger code. If unset, uses BEGIN { require 'perl5db.pl' } +=item PERL_DESTRUCT_LEVEL + +Relevant only if your perl executable was built with B<-DDEBUGGING>, +this controls the behavior of global destruction of objects and other +references. + =item PERLLIB A colon-separated list of directories in which to look for Perl library @@ -247,8 +267,8 @@ directory. If PERL5LIB is defined, PERLLIB is not used. =back -Perl also has environment variables that control how Perl handles -language-specific data. Please consult the L<perli18n> section. +Perl also has environment variables that control how Perl handles data +specific to particular natural languages. See L<perllocale>. Apart from these, Perl uses no other environment variables, except to make them available to the script being executed, and to child @@ -267,7 +287,7 @@ Larry Wall E<lt>F<larry@wall.org>E<gt>, with the help of oodles of other folks. =head1 FILES "/tmp/perl-e$$" temporary file for -e commands - "@INC" locations of perl 5 libraries + "@INC" locations of perl libraries =head1 SEE ALSO @@ -297,8 +317,8 @@ switch? The B<-w> switch is not mandatory. Perl is at the mercy of your machine's definitions of various -operations such as type casting, atof() and sprintf(). The latter -can even trigger a coredump when passed ludicrous input values. +operations such as type casting, atof(), and sprintf(). The latter +can even trigger a core dump when passed ludicrous input values. If your stdio requires a seek or eof between reads and writes on a particular stream, so does Perl. (This doesn't apply to sysread() @@ -310,7 +330,7 @@ given variable name may not be longer than 255 characters, and no component of your PATH may be longer than 255 if you use B<-S>. A regular expression may not compile to more than 32767 bytes internally. -See the perl bugs database at F<http://perl.com/perl/bugs/>. You may +See the perl bugs database at F<http://www.perl.com/perl/bugs/>. You may mail your bug reports (be sure to include full configuration information as output by the myconfig program in the perl source tree, or by C<perl -V>) to F<perlbug@perl.com>. diff --git a/pod/perlapio.pod b/pod/perlapio.pod index d2fd74ab5c..2a2a99fc60 100644 --- a/pod/perlapio.pod +++ b/pod/perlapio.pod @@ -1,6 +1,6 @@ =head1 NAME -perlio - perl's IO abstraction interface. +perlapio - perl's IO abstraction interface. =head1 SYNOPSIS @@ -128,7 +128,7 @@ the meaning of "fileno" may not match UNIX. =item B<PerlIO_clearerr(f)> -This corresponds to clearerr(), i.e. clears 'eof' and 'error' +This corresponds to clearerr(), i.e., clears 'eof' and 'error' flags for the "stream". =item B<PerlIO_flush(f)> @@ -156,7 +156,7 @@ in terms of PerlIO_seek() at some point. =item B<PerlIO_tmpfile()> -This corresponds to tmpfile(), i.e. returns an anonymous +This corresponds to tmpfile(), i.e., returns an anonymous PerlIO which will automatically be deleted when closed. =back @@ -201,7 +201,7 @@ behaviour. =item B<PerlIO_setlinebuf(f)> This corresponds to setlinebuf(). Use is deprecated pending -further discussion. (Perl core I<only> uses it when "dumping" +further discussion. (Perl core uses it I<only> when "dumping" is has nothing to do with $| auto-flush.) =back @@ -209,7 +209,7 @@ is has nothing to do with $| auto-flush.) In addition to user API above there is an "implementation" interface which allows perl to get at internals of PerlIO. The following calls correspond to the various FILE_xxx macros determined -by Configure. This section is really only of interest to those +by Configure. This section is really of interest to only those concerned with detailed perl-core behaviour or implementing a PerlIO mapping. @@ -236,7 +236,7 @@ bytes in the buffer. =item B<PerlIO_fast_gets(f)> Implementation has all the interfaces required to -allow perls fast code to handle <FILE> mechanism. +allow perl's fast code to handle <FILE> mechanism. PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \ PerlIO_canset_cnt(f) && \ @@ -245,14 +245,14 @@ allow perls fast code to handle <FILE> mechanism. =item B<PerlIO_set_ptrcnt(f,p,c)> Set pointer into buffer, and a count of bytes still in the -buffer. Should only be used to set +buffer. Should be used only to set pointer to within range implied by previous calls to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>. =item B<PerlIO_set_cnt(f,c)> Obscure - set count of bytes in the buffer. Deprecated. -Currently only used in doio.c to force count < -1 to -1. +Currently used in only doio.c to force count < -1 to -1. Perhaps should be PerlIO_set_empty or similar. This call may actually do nothing if "count" is deduced from pointer and a "limit". diff --git a/pod/perlbot.pod b/pod/perlbot.pod index 0f7078f197..30d00558b4 100644 --- a/pod/perlbot.pod +++ b/pod/perlbot.pod @@ -57,7 +57,7 @@ See L<CLASS CONTEXT AND THE OBJECT>. =item 7 -IO syntax is certainly less noisy, but it is also prone to ambiguities which +IO syntax is certainly less noisy, but it is also prone to ambiguities that can cause difficult-to-find bugs. Allow people to use the sure-thing OO syntax, even if you don't like it. @@ -404,7 +404,7 @@ This problem can be solved by using the object to define the context of the method. Let the method look in the object for a reference to the data. The alternative is to force the method to go hunting for the data ("Is it in my class, or in a subclass? Which subclass?"), and this can be inconvenient -and will lead to hackery. It is better to just let the object tell the +and will lead to hackery. It is better just to let the object tell the method where that data is located. package Bar; diff --git a/pod/perlcall.pod b/pod/perlcall.pod index ac9229fbb1..20c863cc57 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -5,7 +5,7 @@ perlcall - Perl calling conventions from C =head1 DESCRIPTION The purpose of this document is to show you how to call Perl subroutines -directly from C, i.e. how to write I<callbacks>. +directly from C, i.e., how to write I<callbacks>. Apart from discussing the C interface provided by Perl for writing callbacks the document uses a series of examples to show how the @@ -30,7 +30,7 @@ called instead. The classic example of where callbacks are used is when writing an event driven program like for an X windows application. In this case you register functions to be called whenever specific events occur, -e.g. a mouse button is pressed, the cursor moves into a window or a +e.g., a mouse button is pressed, the cursor moves into a window or a menu item is selected. =back @@ -61,7 +61,7 @@ subroutines. They are The key function is I<perl_call_sv>. All the other functions are fairly simple wrappers which make it easier to call Perl subroutines in special cases. At the end of the day they will all call I<perl_call_sv> -to actually invoke the Perl subroutine. +to invoke the Perl subroutine. All the I<perl_call_*> functions have a C<flags> parameter which is used to pass a bit mask of options to Perl. This bit mask operates @@ -84,9 +84,9 @@ use of I<perl_call_sv>. The function, I<perl_call_pv>, is similar to I<perl_call_sv> except it expects its first parameter to be a C char* which identifies the Perl -subroutine you want to call, e.g. C<perl_call_pv("fred", 0)>. If the +subroutine you want to call, e.g., C<perl_call_pv("fred", 0)>. If the subroutine you want to call is in another package, just include the -package name in the string, e.g. C<"pkg::fred">. +package name in the string, e.g., C<"pkg::fred">. =item B<perl_call_method> @@ -208,10 +208,10 @@ automatically for you. Note that it is still possible to indicate a context to the Perl subroutine by using either G_SCALAR or G_ARRAY. If you do not set this flag then it is I<very> important that you make -sure that any temporaries (i.e. parameters passed to the Perl +sure that any temporaries (i.e., parameters passed to the Perl subroutine and values returned from the subroutine) are disposed of yourself. The section I<Returning a Scalar> gives details of how to -explicitly dispose of these temporaries and the section I<Using Perl to +dispose of these temporaries explicitly and the section I<Using Perl to dispose of temporaries> discusses the specific circumstances where you can ignore the problem and let Perl deal with it for you. @@ -254,7 +254,7 @@ belongs to C<joe>. =head2 G_EVAL It is possible for the Perl subroutine you are calling to terminate -abnormally, e.g. by calling I<die> explicitly or by not actually +abnormally, e.g., by calling I<die> explicitly or by not actually existing. By default, when either of these of events occurs, the process will terminate immediately. If though, you want to trap this type of event, specify the G_EVAL flag. It will put an I<eval { }> @@ -408,7 +408,7 @@ Enough of the definition talk, let's have a few examples. Perl provides many macros to assist in accessing the Perl stack. Wherever possible, these macros should always be used when interfacing -to Perl internals. Hopefully this should make the code less vulnerable +to Perl internals. We hope this should make the code less vulnerable to any changes made to Perl in the future. Another point worth noting is that in the first series of examples I @@ -458,7 +458,7 @@ specified. =item 3. We aren't interested in anything returned from I<PrintUID>, so -G_DISCARD is specified. Even if I<PrintUID> was changed to actually +G_DISCARD is specified. Even if I<PrintUID> was changed to return some value(s), having specified G_DISCARD will mean that they will be wiped by the time control returns from I<perl_call_pv>. @@ -529,15 +529,15 @@ have used this macro. The exception to this rule is if you are calling a Perl subroutine directly from an XSUB function. In this case it is not necessary to -explicitly use the C<dSP> macro - it will be declared for you +use the C<dSP> macro explicitly - it will be declared for you automatically. =item 3. Any parameters to be pushed onto the stack should be bracketed by the C<PUSHMARK> and C<PUTBACK> macros. The purpose of these two macros, in -this context, is to automatically count the number of parameters you -are pushing. Then whenever Perl is creating the C<@_> array for the +this context, is to count the number of parameters you are +pushing automatically. Then whenever Perl is creating the C<@_> array for the subroutine, it knows how big to make it. The C<PUSHMARK> macro tells Perl to make a mental note of the current @@ -555,7 +555,7 @@ local copy, I<not> the global copy. =item 4. -The only flag specified this time is G_DISCARD. Since we are passing 2 +The only flag specified this time is G_DISCARD. Because we are passing 2 parameters to the Perl subroutine this time, we have not specified G_NOARGS. @@ -580,7 +580,7 @@ function. Now for an example of dealing with the items returned from a Perl subroutine. -Here is a Perl subroutine, I<Adder>, which takes 2 integer parameters +Here is a Perl subroutine, I<Adder>, that takes 2 integer parameters and simply returns their sum. sub Adder @@ -589,7 +589,7 @@ and simply returns their sum. $a + $b ; } -Since we are now concerned with the return value from I<Adder>, the C +Because we are now concerned with the return value from I<Adder>, the C function required to call it is now a bit more complex. static void @@ -685,7 +685,7 @@ Expecting a single value is not quite the same as knowing that there will be one. If someone modified I<Adder> to return a list and we didn't check for that possibility and take appropriate action the Perl stack would end up in an inconsistent state. That is something you -I<really> don't want to ever happen. +I<really> don't want to happen ever. =item 5. @@ -998,7 +998,7 @@ refers to the C equivalent of C<$@>. Note that the stack is popped using C<POPs> in the block where C<SvTRUE(GvSV(errgv))> is true. This is necessary because whenever a I<perl_call_*> function invoked with G_EVAL|G_SCALAR returns an error, -the top of the stack holds the value I<undef>. Since we want the +the top of the stack holds the value I<undef>. Because we want the program to continue after detecting this error, it is essential that the stack is tidied up by removing the I<undef>. @@ -1026,7 +1026,7 @@ version of the call_Subtract example above inside a destructor: This example will fail to recognize that an error occurred inside the C<eval {}>. Here's why: the call_Subtract code got executed while perl -was cleaning up temporaries when exiting the eval block, and since +was cleaning up temporaries when exiting the eval block, and because call_Subtract is implemented with I<perl_call_pv> using the G_EVAL flag, it promptly reset C<$@>. This results in the failure of the outermost test for C<$@>, and thereby the failure of the error trap. @@ -1064,7 +1064,7 @@ Here is a snippet of XSUB which defines I<CallSubPV>. perl_call_pv(name, G_DISCARD|G_NOARGS) ; That is fine as far as it goes. The thing is, the Perl subroutine -can be specified only as a string. For Perl 4 this was adequate, +can be specified as only a string. For Perl 4 this was adequate, but Perl 5 allows references to subroutines and anonymous subroutines. This is where I<perl_call_sv> is useful. @@ -1079,7 +1079,7 @@ I<perl_call_sv> instead of I<perl_call_pv>. PUSHMARK(sp) ; perl_call_sv(name, G_DISCARD|G_NOARGS) ; -Since we are using an SV to call I<fred> the following can all be used +Because we are using an SV to call I<fred> the following can all be used CallSubSV("fred") ; CallSubSV(\&fred) ; @@ -1092,7 +1092,7 @@ how you can specify the Perl subroutine. You should note that if it is necessary to store the SV (C<name> in the example above) which corresponds to the Perl subroutine so that it can -be used later in the program, it not enough to just store a copy of the +be used later in the program, it not enough just to store a copy of the pointer to the SV. Say the code above had been like this static SV * rememberSub ; @@ -1143,7 +1143,7 @@ the version of Perl you are using) The variable C<$ref> may have referred to the subroutine C<fred> whenever the call to C<SaveSub1> was made but by the time -C<CallSavedSub1> gets called it now holds the number C<47>. Since we +C<CallSavedSub1> gets called it now holds the number C<47>. Because we saved only a pointer to the original SV in C<SaveSub1>, any changes to C<$ref> will be tracked by the pointer C<rememberSub>. This means that whenever C<CallSavedSub1> gets called, it will attempt to execute the @@ -1185,7 +1185,7 @@ SV. The code below shows C<SaveSub2> modified to do that PUSHMARK(sp) ; perl_call_sv(keepSub, G_DISCARD|G_NOARGS) ; -In order to avoid creating a new SV every time C<SaveSub2> is called, +To avoid creating a new SV every time C<SaveSub2> is called, the function first checks to see if it has been called before. If not, then space for a new SV is allocated and the reference to the Perl subroutine, C<name> is copied to the variable C<keepSub> in one @@ -1247,9 +1247,9 @@ Consider the following Perl code } } -It just implements a very simple class to manage an array. Apart from +It implements just a very simple class to manage an array. Apart from the constructor, C<new>, it declares methods, one static and one -virtual. The static method, C<PrintID>, simply prints out the class +virtual. The static method, C<PrintID>, prints out simply the class name and a version number. The virtual method, C<Display>, prints out a single element of the array. Here is an all Perl example of using it. @@ -1346,7 +1346,7 @@ The output from that will be =head2 Using Perl to dispose of temporaries In the examples given to date, any temporaries created in the callback -(i.e. parameters passed on the stack to the I<perl_call_*> function or +(i.e., parameters passed on the stack to the I<perl_call_*> function or values returned via the stack) have been freed by one of these methods =over 5 @@ -1441,7 +1441,7 @@ the extreme left. So what is the big problem? Well, if you are expecting Perl to tidy up those temporaries for you, you might be in for a long wait. For Perl -to actually dispose of your temporaries, control must drop back to the +to dispose of your temporaries, control must drop back to the enclosing scope at some stage. In the event driven scenario that may never happen. This means that as time goes on, your program will create more and more temporaries, none of which will ever be freed. As @@ -1450,7 +1450,7 @@ eventually consume all the available memory in your system - kapow! So here is the bottom line - if you are sure that control will revert back to the enclosing Perl scope fairly quickly after the end of your -callback, then it isn't absolutely necessary to explicitly dispose of +callback, then it isn't absolutely necessary to dispose explicitly of any temporaries you may have created. Mind you, if you are at all uncertain about what to do, it doesn't do any harm to tidy up anyway. @@ -1524,7 +1524,7 @@ registers, C<pcb1>, might look like this The mapping between the C callback and the Perl equivalent is stored in the global variable C<callback>. -This will be adequate if you ever need to have only 1 callback +This will be adequate if you ever need to have only one callback registered at any time. An example could be an error handler like the code sketched out above. Remember though, repeated calls to C<register_fatal> will replace the previously registered callback @@ -1761,7 +1761,7 @@ series of C functions to act as the interface to Perl, thus asynch_close(fh) ; -In this case the functions C<fn1>, C<fn2> and C<fn3> are used to +In this case the functions C<fn1>, C<fn2>, and C<fn3> are used to remember the Perl subroutine to be called. Each of the functions holds a separate hard-wired index which is used in the function C<Pcb> to access the C<Map> array and actually call the Perl subroutine. diff --git a/pod/perldata.pod b/pod/perldata.pod index 34fd199005..407a25204f 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -19,7 +19,7 @@ I<identifier>, that is, a string beginning with a letter or underscore, and containing letters, underscores, and digits. In some cases, it may be a chain of identifiers, separated by C<::> (or by C<'>, but that's deprecated); all but the last are interpreted as names of -packages, in order to locate the namespace in which to look +packages, to locate the namespace in which to look up the final identifier (see L<perlmod/Packages> for details). It's possible to substitute for a simple identifier an expression which produces a reference to the value at runtime; this is @@ -65,14 +65,14 @@ This means that $foo and @foo are two different variables. It also means that C<$foo[1]> is a part of @foo, not a part of $foo. This may seem a bit weird, but that's okay, because it is weird. -Since variable and array references always start with '$', '@', or '%', +Because variable and array references always start with '$', '@', or '%', the "reserved" words aren't in fact reserved with respect to variable names. (They ARE reserved with respect to labels and filehandles, however, which don't have an initial special character. You can't have a filehandle named "log", for instance. Hint: you could say C<open(LOG,'logfile')> rather than C<open(log,'logfile')>. Using uppercase filehandles also improves readability and protects you from conflict -with future reserved words.) Case I<IS> significant--"FOO", "Foo" and +with future reserved words.) Case I<IS> significant--"FOO", "Foo", and "foo" are all different names. Names that start with a letter or underscore may also contain digits and underscores. @@ -80,9 +80,9 @@ It is possible to replace such an alphanumeric name with an expression that returns a reference to an object of that type. For a description of this, see L<perlref>. -Names that start with a digit may only contain more digits. Names +Names that start with a digit may contain only more digits. Names which do not start with a letter, underscore, or digit are limited to -one character, e.g. C<$%> or C<$$>. (Most of these one character names +one character, e.g., C<$%> or C<$$>. (Most of these one character names have a predefined significance to Perl. For instance, C<$$> is the current process id.) @@ -135,7 +135,7 @@ Scalar variables may contain various kinds of singular data, such as numbers, strings, and references. In general, conversion from one form to another is transparent. (A scalar may not contain multiple values, but may contain a reference to an array or hash containing multiple values.) -Because of the automatic conversion of scalars, operations and functions +Because of the automatic conversion of scalars, operations, and functions that return scalars don't need to care (and, in fact, can't care) whether the context is looking for a string or a number. @@ -183,7 +183,7 @@ for details on regular expressions. The length of an array is a scalar value. You may find the length of array @days by evaluating C<$#days>, as in B<csh>. (Actually, it's not -the length of the array, it's the subscript of the last element, since +the length of the array, it's the subscript of the last element, because there is (ordinarily) a 0th element.) Assigning to C<$#days> changes the length of the array. Shortening an array by this method destroys intervening values. Lengthening an array that was previously shortened @@ -207,7 +207,7 @@ last value, like the C comma operator.) The following is always true: Version 5 of Perl changed the semantics of C<$[>: files that don't set the value of C<$[> no longer need to worry about whether another file changed its value. (In other words, use of C<$[> is deprecated.) -So in general you can just assume that +So in general you can assume that scalar(@whatever) == $#whatever + 1; @@ -220,7 +220,7 @@ If you evaluate a hash in a scalar context, it returns a value which is true if and only if the hash contains any key/value pairs. (If there are any key/value pairs, the value returned is a string consisting of the number of used buckets and the number of allocated buckets, separated -by a slash. This is pretty much only useful to find out whether Perl's +by a slash. This is pretty much useful only to find out whether Perl's (compiled in) hashing algorithm is performing poorly on your data set. For example, you stick 10,000 things in a hash, but evaluating %HASH in scalar context reveals "1/16", which means only one out of sixteen buckets @@ -239,14 +239,15 @@ integer formats: 0377 # octal 4_294_967_296 # underline for legibility -String literals are usually delimited by either single or double quotes. They -work much like shell quotes: double-quoted string literals are subject -to backslash and variable substitution; single-quoted strings are not -(except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making -characters such as newline, tab, etc., as well as some more exotic -forms. See L<perlop/qq> for a list. +String literals are usually delimited by either single or double +quotes. They work much like shell quotes: double-quoted string +literals are subject to backslash and variable substitution; +single-quoted strings are not (except for "C<\'>" and "C<\\>"). +The usual Unix backslash rules apply for making characters such as +newline, tab, etc., as well as some more exotic forms. See +L<perlop/Quote and Quotelike Operators> for a list. -You can also embed newlines directly in your strings, i.e. they can end +You can also embed newlines directly in your strings, i.e., they can end on a different line than they begin. This is nice, but if you forget your trailing quote, the error will not be reported until Perl finds another line containing the quote character, which may be much further @@ -275,16 +276,16 @@ in the subscript will be interpreted as an expression. Note that a single-quoted string must be separated from a preceding word by a -space, since single quote is a valid (though deprecated) character in +space, because single quote is a valid (though deprecated) character in a variable name (see L<perlmod/Packages>). Two special literals are __LINE__ and __FILE__, which represent the current line number and filename at that point in your program. They -may only be used as separate tokens; they will not be interpolated into +may be used only as separate tokens; they will not be interpolated into strings. In addition, the token __END__ may be used to indicate the logical end of the script before the actual end of file. Any following text is ignored, but may be read via the DATA filehandle. (The DATA -filehandle may read data only from the main script, but not from any +filehandle may read data from only the main script, but not from any required file or evaluated string.) The two control characters ^D and ^Z are synonyms for __END__ (or __DATA__ in a module; see L<SelfLoader> for details on __DATA__). @@ -324,17 +325,18 @@ and is almost always right. If it does guess wrong, or if you're just plain paranoid, you can force the correct interpretation with curly brackets as above. -A line-oriented form of quoting is based on the shell "here-doc" syntax. -Following a C<E<lt>E<lt>> you specify a string to terminate the quoted material, -and all lines following the current line down to the terminating string -are the value of the item. The terminating string may be either an -identifier (a word), or some quoted text. If quoted, the type of -quotes you use determines the treatment of the text, just as in regular -quoting. An unquoted identifier works like double quotes. There must -be no space between the C<E<lt>E<lt>> and the identifier. (If you put a space it -will be treated as a null identifier, which is valid, and matches the -first blank line.) The terminating string must appear by itself -(unquoted and with no surrounding whitespace) on the terminating line. +A line-oriented form of quoting is based on the shell "here-doc" +syntax. Following a C<E<lt>E<lt>> you specify a string to terminate +the quoted material, and all lines following the current line down to +the terminating string are the value of the item. The terminating +string may be either an identifier (a word), or some quoted text. If +quoted, the type of quotes you use determines the treatment of the +text, just as in regular quoting. An unquoted identifier works like +double quotes. There must be no space between the C<E<lt>E<lt>> and +the identifier. (If you put a space it will be treated as a null +identifier, which is valid, and matches the first blank line.) The +terminating string must appear by itself (unquoted and with no +surrounding whitespace) on the terminating line. print <<EOF; The price is $Price. @@ -430,7 +432,7 @@ put the list in parentheses to avoid ambiguity. Examples: $time = (stat($file))[8]; # SYNTAX ERROR HERE. - $time = stat($file)[8]; # OOPS, FORGOT PARENS + $time = stat($file)[8]; # OOPS, FORGOT PARENTHESES # Find a hex digit. $hexdigit = ('a','b','c','d','e','f')[$digit-10]; @@ -452,7 +454,7 @@ produced by the expression on the right side of the assignment: $x = (($foo,$bar) = f()); # set $x to f()'s return count This is very handy when you want to do a list assignment in a Boolean -context, since most list functions return a null list when finished, +context, because most list functions return a null list when finished, which when assigned produces a 0, which is interpreted as FALSE. The final element may be an array or a hash: @@ -511,17 +513,19 @@ Note that just because a hash is initialized in that order doesn't mean that it comes out in that order. See L<perlfunc/sort> for examples of how to arrange for an output ordering. -=head2 Typeglobs and FileHandles +=head2 Typeglobs and Filehandles Perl uses an internal type called a I<typeglob> to hold an entire symbol table entry. The type prefix of a typeglob is a C<*>, because it represents all types. This used to be the preferred way to pass arrays and hashes by reference into a function, but now that -we have real references, this is seldom needed. +we have real references, this is seldom needed. It also used to be the +preferred way to pass filehandles into a function, but now +that we have the *foo{THING} notation it isn't often needed for that, +either. It is still needed to pass new filehandles into functions +(*HANDLE{IO} only works if HANDLE has already been used). -One place where you still use typeglobs (or references thereto) -is for passing or storing filehandles. If you want to save away -a filehandle, do it this way: +If you need to use a typeglob to save away a filehandle, do it this way: $fh = *STDOUT; @@ -529,7 +533,7 @@ or perhaps as a real reference, like this: $fh = \*STDOUT; -This is also the way to create a local filehandle. For example: +This is also a way to create a local filehandle. For example: sub newopen { my $path = shift; @@ -539,6 +543,8 @@ This is also the way to create a local filehandle. For example: } $fh = newopen('/etc/passwd'); -See L<perlref>, L<perlsub>, and L<perlmod/"Symbols Tables"> for more -discussion on typeglobs. See L<perlfunc/open> for other ways of -generating filehandles. +Another way to create local filehandles is with IO::Handle and its ilk, +see the bottom of L<perlfunc/open()>. + +See L<perlref>, L<perlsub>, and L<perlmod/"Symbol Tables"> for more +discussion on typeglobs. diff --git a/pod/perldebug.pod b/pod/perldebug.pod index f77bc92a70..77502f27d3 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -11,7 +11,7 @@ First of all, have you tried using the B<-w> switch? 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 -source code, set breakpoints, get stack backtraces, change the values of +source code, set breakpoints, get stack back-traces, change the values of variables, etc. This is so convenient that you often fire up the debugger all by itself just to test out Perl constructs interactively to see what they do. For example: @@ -62,16 +62,18 @@ it's run through your pager, as in =item p expr -Same as C<print DB::OUT expr> in the current package. In particular, -since this is just Perl's own B<print> function, this means that nested +Same as C<print {$DB::OUT} expr> in the current package. In particular, +because this is just Perl's own B<print> function, this means that nested data structures and objects are not dumped, unlike with the C<x> command. =item x expr -Evals its expression in list context and dumps out the result +Evaluates its expression in list context and dumps out the result in a pretty-printed fashion. Nested data structures are printed out recursively, unlike the C<print> function. +The details of printout are governed by multiple C<O>ptions. + =item V [pkg [vars]] Display all (or some) variables in package (defaulting to the C<main> @@ -87,13 +89,15 @@ Use C<~pattern> and C<!pattern> for positive and negative regexps. Nested data structures are printed out in a legible fashion, unlike the C<print> function. +The details of printout are governed by multiple C<O>ptions. + =item X [vars] Same as C<V currentpackage [vars]>. =item T -Produce a stack backtrace. See below for details on its output. +Produce a stack back-trace. See below for details on its output. =item s [expr] @@ -110,10 +114,10 @@ of the next statement. Repeat last C<n> or C<s> command. -=item c [line] +=item c [line|sub] Continue, optionally inserting a one-time-only breakpoint -at the specified line. +at the specified line or subroutine. =item l @@ -162,7 +166,7 @@ Search backwards for pattern; final ? is optional. =item L -List all breakpoints and actions for the current file. +List all breakpoints and actions. =item S [[!]pattern] @@ -170,7 +174,7 @@ List subroutine names [not] matching pattern. =item t -Toggle trace mode. +Toggle trace mode (see also C<AutoTrace> C<O>ption). =item t expr @@ -194,23 +198,45 @@ Trace through execution of expr. For example: main::foo((eval 168):2): main::bar((eval 170):2): 42 - DB<4> q + +or, with the C<O>ption C<frame=2> set, + + DB<4> O f=2 + frame = '2' + DB<5> t print foo() * bar() + 3: foo() * bar() + entering main::foo + 2: sub foo { 14 }; + exited main::foo + entering main::bar + 2: sub bar { 3 }; + exited main::bar + 42 =item b [line] [condition] Set a breakpoint. If line is omitted, sets a breakpoint on the line that is about to be executed. If a condition is specified, it's evaluated each time the statement is reached and a breakpoint is taken -only if the condition is true. Breakpoints may only be set on lines +only if the condition is true. Breakpoints may be set on only lines that begin an executable statement. Conditions don't use B<if>: b 237 $x > 30 + b 237 ++$count237 < 11 b 33 /pattern/i =item b subname [condition] Set a breakpoint at the first line of the named subroutine. +=item b postpone subname [condition] + +Set breakpoint at first line of subroutine after it is compiled. + +=item b load filename + +Set breakpoint at the first executed line of the file. + =item d [line] Delete a breakpoint at the specified line. If line is omitted, deletes @@ -225,29 +251,11 @@ Delete all installed breakpoints. Set an action to be done before the line is executed. The sequence of steps taken by the debugger is -=over 3 - -=item 1 - -check for a breakpoint at this line - -=item 2 - -print the line if necessary (tracing) - -=item 3 - -do any actions associated with that line - -=item 4 - -prompt user if at a breakpoint or in single-step - -=item 5 - -evaluate line - -=back + 1. check for a breakpoint at this line + 2. print the line if necessary (tracing) + 3. do any actions associated with that line + 4. prompt user if at a breakpoint or in single-step + 5. evaluate line For example, this will print out C<$foo> every time line 53 is passed: @@ -276,6 +284,41 @@ Program to use for output of pager-piped commands (those beginning with a C<|> character.) By default, C<$ENV{PAGER}> will be used. +=item tkRunning + +Run Tk while prompting (with ReadLine). + +=item signalLevel, warnLevel, dieLevel + +Level of verbosity. + +=item AutoTrace + +Where to print all the breakable points in the executed program +(similar to C<t> command, but can be put into C<PERLDB_OPTS>). + +=item LineInfo + +File or pipe to print line number info to. If it is a +pipe, then a short, "emacs like" message is used. + +=item C<inhibit_exit> + +If 0, allows I<stepping off> the end of the script. + +=item C<PrintRet> + +affects printing of return value after C<r> command. + +=item C<frame> + +affects printing messages on entry and exit from subroutines. If +C<frame & 2> is false, messages are printed on entry only. (Printing +on exit may be useful if inter(di)spersed with other messages.) + +If C<frame & 4>, arguments to functions are printed as well as the +context and caller info. + =back The following options affect what happens with C<V>, C<X>, and C<x> @@ -307,26 +350,60 @@ Dump symbol tables of packages. Change style of string dump. -=item tkRunning +=back -Run Tk while prompting (with ReadLine). +During startup options are initialized from C<$ENV{PERLDB_OPTS}>. +You can put additional initialization options C<TTY>, C<noTTY>, +C<ReadLine>, and C<NonStop> there. -=item signalLevel, warnLevel. dieLevel +Example rc file: -Level of verbosity. + &parse_options("NonStop=1 LineInfo=db.out AutoTrace"); -=back +The script will run without human intervention, putting trace information +into the file I<db.out>. (If you interrupt it, you would better reset +C<LineInfo> to something "interactive"!) -The option C<PrintRet> affects printing of return value after C<r> -command, The option C<frame> affects printing messages on entry and exit -from subroutines. If C<frame> is 1, messages are printed on entry only; -if it's set to more than that, they'll will be printed on exit as well, -which may be useful if interdispersed with other messages. +=over 12 -During startup options are initialized from $ENV{PERLDB_OPTS}. -You can put additional initialization options C<TTY>, C<noTTY>, -C<ReadLine>, and C<NonStop> there. Here's an example of using -the C<$ENV{PERLDB_OPTS}> variable: +=item C<TTY> + +The TTY to use for debugging I/O. + +=item noTTY + +If set, goes in C<NonStop> mode. On interrupt if TTY is not set uses the +value of C<noTTY> or "/tmp/perldbtty$$" to find TTY using +C<Term::Rendezvous>. Current variant is to have the name of TTY in this +file. + +=item C<noTTY> + +If set, goes in C<NonStop> mode, and would not connect to a TTY. If +interrupt (or if control goes to debugger via explicit setting of +$DB::signal or $DB::single from the Perl script), connects to a TTY +specified by the C<TTY> option at startup, or to a TTY found at +runtime using C<Term::Rendezvous> module of your choice. + +This module should implement a method C<new> which returns an object +with two methods: C<IN> and C<OUT>, returning two filehandles to use +for debugging input and output correspondingly. Method C<new> may +inspect an argument which is a value of C<$ENV{PERLDB_NOTTY}> at +startup, or is C<"/tmp/perldbtty$$"> otherwise. + +=item C<ReadLine> + +If false, readline support in debugger is disabled, so you can debug +ReadLine applications. + +=item C<NonStop> + +If set, debugger goes into non-interactive mode until interrupted, or +programmatically by setting $DB::signal or $DB::single. + +=back + +Here's an example of using the C<$ENV{PERLDB_OPTS}> variable: $ PERLDB_OPTS="N f=2" perl -d myprogram @@ -334,20 +411,65 @@ will run the script C<myprogram> without human intervention, printing out the call tree with entry and exit points. Note that C<N f=2> is equivalent to C<NonStop=1 frame=2>. Note also that at the moment when this documentation was written all the options to the debugger could -be uniquely abbreviated by the first letter. +be uniquely abbreviated by the first letter (with exception of +C<Dump*> options). -See "Debugger Internals" below for more details. +Other examples may include -=item E<lt> command + $ PERLDB_OPTS="N f A L=listing" perl -d myprogram + +- runs script non-interactively, printing info on each entry into a +subroutine and each executed line into the file F<listing>. (If you +interrupt it, you would better reset C<LineInfo> to something +"interactive"!) -Set an action to happen before every debugger prompt. A multiline -command may be entered by backslashing the newlines. + + $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram + +may be useful for debugging a program which uses C<Term::ReadLine> +itself. Do not forget detach shell from the TTY in the window which +corresponds to F</dev/ttyc>, say, by issuing a command like + + $ sleep 1000000 + +See L<"Debugger Internals"> below for more details. + +=over 12 + +=item E<lt> [ command ] + +Set an action (Perl command) to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. If +C<command> is missing, resets the list of actions. + +=item E<lt>E<lt> command + +Add an action (Perl command) to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. =item E<gt> command -Set an action to happen after the prompt when you've just given a -command to return to executing the script. A multiline command may be -entered by backslashing the newlines. +Set an action (Perl command) to happen after the prompt when you've +just given a command to return to executing the script. A multi-line +command may be entered by backslashing the newlines. If C<command> is +missing, resets the list of actions. + +=item E<gt>E<gt> command + +Adds an action (Perl command) to happen after the prompt when you've +just given a command to return to executing the script. A multi-line +command may be entered by backslashing the newlines. + +=item { [ command ] + +Set an action (debugger command) to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. If +C<command> is missing, resets the list of actions. + +=item {{ command + +Add an action (debugger command) to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. =item ! number @@ -374,7 +496,12 @@ listed. If number is omitted, lists them all. =item q or ^D -Quit. ("quit" doesn't work for this.) +Quit. ("quit" doesn't work for this.) This is the only supported way +to exit the debugger, though typing C<exit> twice may do it too. + +Set an C<O>ption C<inhibit_exit> to 0 if you want to be able to I<step +off> the end the script. You may also need to set C<$finished> to 0 at +some moment if you want to step through global destruction. =item R @@ -382,6 +509,10 @@ Restart the debugger by B<exec>ing a new session. It tries to maintain your history across this, but internal settings and command line options may be lost. +Currently the following setting are preserved: history, breakpoints, +actions, debugger C<O>ptions, and the following command-line +options: B<-w>, B<-I>, and B<-e>. + =item |dbcmd Run debugger command, piping DB::OUT to current pager. @@ -419,11 +550,12 @@ or even DB<<17>> where that number is the command number, which you'd use to access with -the built-in B<csh>-like history mechanism, e.g. C<!17> would repeat +the built-in B<csh>-like history mechanism, e.g., C<!17> would repeat command number 17. The number of angle brackets indicates the depth of the debugger. You could get more than one set of brackets, for example, if you'd already at a breakpoint and then printed out the result of a -function call that itself also has a breakpoint. +function call that itself also has a breakpoint, or you step into an +expression via C<s/n/t expression> command. If you want to enter a multi-line command, such as a subroutine definition with several statements, you may escape the newline that would @@ -440,7 +572,7 @@ normally end the debugger command with a backslash. Here's an example: Note that this business of escaping a newline is specific to interactive commands typed into the debugger. -Here's an example of what a stack backtrace might look like: +Here's an example of what a stack back-trace might look like: $ = main::infested called from file `Ambulation.pm' line 10 @ = Ambulation::legs(1, 2, 3, 4) called from file `camel_flea' line 7 @@ -459,7 +591,9 @@ but from line 4. If you have any compile-time executable statements (code within a BEGIN block or a C<use> statement), these will C<NOT> be stopped by debugger, -although C<require>s will. From your own Perl code, however, you can +although C<require>s will (and compile-time statements can be traced +with C<AutoTrace> option set in C<PERLDB_OPTS>). From your own Perl +code, however, you can transfer control back to the debugger using the following statement, which is harmless if the debugger is not running: @@ -472,11 +606,10 @@ having typed the C<t> command. =head2 Debugger Customization -If you want to modify the debugger, copy F<perl5db.pl> from the Perl -library to another name and modify it as necessary. You'll also want -to set your PERL5DB environment variable to say something like this: - - BEGIN { require "myperl5db.pl" } +Most probably you not want to modify the debugger, it contains enough +hooks to satisfy most needs. You may change the behaviour of debugger +from the debugger itself, using C<O>ptions, from the command line via +C<PERLDB_OPTS> environment variable, and from I<customization files>. You can do some customization by setting up a F<.perldb> file which contains initialization code. For instance, you could make aliases @@ -487,6 +620,25 @@ like these (the last one is one people expect to be there): $DB::alias{'ps'} = 's/^ps\b/p scalar /'; $DB::alias{'quit'} = 's/^quit(\s*)/exit\$/'; +One changes options from F<.perldb> file via calls like this one; + + parse_options("NonStop=1 LineInfo=db.out AutoTrace=1 frame=2"); + +(the code is executed in the package C<DB>). Note that F<.perldb> is +processed before processing C<PERLDB_OPTS>. If F<.perldb> defines the +subroutine C<afterinit>, it is called after all the debugger +initialization ends. F<.perldb> may be contained in the current +directory, or in the C<LOGDIR>/C<HOME> directory. + +If you want to modify the debugger, copy F<perl5db.pl> from the Perl +library to another name and modify it as necessary. You'll also want +to set your C<PERL5DB> environment variable to say something like this: + + BEGIN { require "myperl5db.pl" } + +As the last resort, one can use C<PERL5DB> to customize debugger by +directly setting internal variables or calling debugger functions. + =head2 Readline Support As shipped, the only command line history supplied is a simplistic one @@ -529,83 +681,131 @@ to a file called F<tmon.out>. A tool like B<dprofpp> (also supplied with the Devel::DProf package) can be used to interpret the information which is in that profile. -=head2 Debugger Internals +=head2 Debugger support in perl When you call the B<caller> function from package DB, Perl sets the C<@DB::args> array to contain the arguments that stack frame was called -with. It also maintains other magical internal variables, such as -C<@DB::dbline>, an array of the source code lines for the currently -selected (with the debugger's C<f> command) file. Perl effectively -inserts a call to the function C<DB::DB>(I<linenum>) in front of every -place that can have a breakpoint. Instead of a subroutine call it calls -C<DB::sub> setting C<$DB::sub> being the called subroutine. It also -inserts a C<BEGIN {require 'perl5db.pl'}> before the first line. +with. -Note that no subroutine call is possible until C<&DB::sub> is defined -(for subroutines defined outside this file). In fact, the same is -true if C<$DB::deep> (how many levels of recursion deep into the -debugger you are) is not defined. +If perl is run with B<-d> option, the following additional features +are enabled: -At the start, the debugger reads your rc file (F<./.perldb> or -F<~/.perldb> under UNIX), which can set important options. This file may -define a subroutine C<&afterinit> to be executed after the debugger is -initialized. +=over -After the rc file is read, the debugger reads environment variable -PERLDB_OPTS and parses it as a rest of C<O ...> line in debugger prompt. +=item * -The following options can only be specified at startup. To set them in -your rc file, call C<&parse_options("optionName=new_value")>. +Perl inserts the contents of C<$ENV{PERL5DB}> (or C<BEGIN {require +'perl5db.pl'}> if not present) before the first line of the +application. -=over 12 +=item * -=item TTY +The array C<@{"_<$filename"}> is the line-by-line contents of +$filename for all the compiled files. Same for C<eval>ed strings which +contain subroutines, or which are currently executed. The C<$filename> +for C<eval>ed strings looks like C<(eval 34)>. -The TTY to use for debugging I/O. +=item * -=item noTTY +The hash C<%{"_<$filename"}> contains breakpoints and action (it is +keyed by line number), and individual entries are settable (as opposed +to the whole hash). Only true/false is important to Perl, though the +values used by F<perl5db.pl> have the form +C<"$break_condition\0$action">. Values are magical in numeric context: +they are zeros if the line is not breakable. -If set, goes in C<NonStop> mode. On interrupt if TTY is not set uses the -value of C<noTTY> or "/tmp/perldbtty$$" to find TTY using -C<Term::Rendezvous>. Current variant is to have the name of TTY in this -file. +Same for evaluated strings which contain subroutines, or which are +currently executed. The C<$filename> for C<eval>ed strings looks like +C<(eval 34)>. -=item ReadLine +=item * -If false, dummy ReadLine is used, so you can debug -ReadLine applications. +The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for +evaluated strings which contain subroutines, or which are currently +executed. The C<$filename> for C<eval>ed strings looks like C<(eval +34)>. -=item NonStop +=item * -If true, no I/O is performed until an interrupt. +After each C<require>d file is compiled, but before it is executed, +C<DB::postponed(*{"_<$filename"})> is called (if subroutine +C<DB::postponed> exists). Here the $filename is the expanded name of +the C<require>d file (as found in values of C<%INC>). -=item LineInfo +=item * -File or pipe to print line number info to. If it is a -pipe, then a short, "emacs like" message is used. +After each subroutine C<subname> is compiled existence of +C<$DB::postponed{subname}> is checked. If this key exists, +C<DB::postponed(subname)> is called (if subroutine C<DB::postponed> +exists). -Example rc file: +=item * - &parse_options("NonStop=1 LineInfo=db.out"); - sub afterinit { $trace = 1; } +A hash C<%DB::sub> is maintained, with keys being subroutine names, +values having the form C<filename:startline-endline>. C<filename> has +the form C<(eval 31)> for subroutines defined inside C<eval>s. -The script will run without human intervention, putting trace information -into the file I<db.out>. (If you interrupt it, you would better reset -C<LineInfo> to something "interactive"!) +=item * + +When execution of the application reaches a place that can have +a breakpoint, a call to C<DB::DB()> is performed if any one of +variables $DB::trace, $DB::single, or $DB::signal is true. (Note that +these variables are not C<local>izable.) This feature is disabled when +the control is inside C<DB::DB()> or functions called from it (unless +C<$^D & 1 E<lt>E<lt> 30>). + +=item * + +When execution of the application reaches a subroutine call, a call +to C<&DB::sub>(I<args>) is performed instead, with C<$DB::sub> being +the name of the called subroutine. (Unless the subroutine is compiled +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>). (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.) + +=head2 Debugger Internals + +At the start, the debugger reads your rc file (F<./.perldb> or +F<~/.perldb> under UNIX), which can set important options. This file may +define a subroutine C<&afterinit> to be executed after the debugger is +initialized. + +After the rc file is read, the debugger reads environment variable +PERLDB_OPTS and parses it as a rest of C<O ...> line in debugger prompt. + +It also maintains magical internal variables, such as C<@DB::dbline>, +C<%DB::dbline>, which are aliases for C<@{"::_<current_file"}> +C<%{"::_<current_file"}>. Here C<current_file> is the currently +selected (with the debugger's C<f> command, or by flow of execution) +file. + +Some functions are provided to simplify customization. See L<"Debugger +Customization"> for description of C<DB::parse_options(string)>. The +function C<DB::dump_trace(skip[, count])> skips the specified number +of frames, and returns an array containing info about the caller +frames (all if C<count> is missing). Each entry is a hash with keys +C<context> (C<$> or C<@>), C<sub> (subroutine name, or info about +eval), C<args> (C<undef> or a reference to an array), C<file>, and +C<line>. + +The function C<DB::print_trace(FH, skip[, count[, short]])> prints +formatted info about caller frames. The last two functions may be +convenient as arguments to C<E<lt>>, C<E<lt>E<lt>> commands. + =head2 Other resources You did try the B<-w> switch, didn't you? =head1 BUGS -If your program exit()s or die()s, so too does the debugger. - You cannot get the stack frame information or otherwise debug functions that were not compiled by Perl, such as C or C++ extensions. If you alter your @_ arguments in a subroutine (such as with B<shift> -or B<pop>, the stack backtrace will not show the original values. - +or B<pop>, the stack back-trace will not show the original values. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 4eed9deb98..d08d2dc452 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -53,7 +53,7 @@ no useful value. See L<perlmod>. =item % may only be used in unpack -(F) You can't pack a string by supplying a checksum, since the +(F) You can't pack a string by supplying a checksum, because the checksumming process loses information, and you can't go the other way. See L<perlfunc/unpack>. @@ -61,15 +61,27 @@ way. See L<perlfunc/unpack>. (W) You've run afoul of the rule that says that any list operator followed by parentheses turns into a function, with all the list operators arguments -found inside the parens. See L<perlop/Terms and List Operators (Leftward)>. +found inside the parentheses. See L<perlop/Terms and List Operators (Leftward)>. =item %s argument is not a HASH element -(F) The argument to delete() or exists() must be a hash element, such as +(F) The argument to exists() must be a hash element, such as $foo{$bar} $ref->[12]->{"susie"} +=item %s argument is not a HASH element or slice + +(F) The argument to delete() must be either a hash element, such as + + $foo{$bar} + $ref->[12]->{"susie"} + +or a hash slice, such as + + @foo{$bar, $baz, $xyzzy} + @{$ref->[12]}{"susie", "queue"} + =item %s did not return a true value (F) A required (or used) file must return a true value to indicate that @@ -162,7 +174,11 @@ the return value of your socket() call? See L<perlfunc/accept>. =item Allocation too large: %lx -(F) You can't allocate more than 64K on an MSDOS machine. +(X) You can't allocate more than 64K on an MSDOS machine. + +=item Allocation too large + +(F) You can't allocate more than 2^31+"small amount" bytes. =item Arg too short for msgsnd @@ -172,7 +188,7 @@ the return value of your socket() call? See L<perlfunc/accept>. (W)(S) You said something that may not be interpreted the way you thought. Normally it's pretty easy to disambiguate it by supplying -a missing quote, operator, paren pair or declaration. +a missing quote, operator, parenthesis pair or declaration. =item Args must match #! line @@ -210,6 +226,13 @@ know which context to supply to the right side. be garbage collected on exit. An SV was discovered to be outside any of those arenas. +=item Attempt to free non-existent shared string + +(P) Perl maintains a reference counted internal table of strings to +optimize the storage and access of hash keys and other strings. This +indicates someone tried to decrement the reference count of a string +that can no longer be found in the table. + =item Attempt to free temp prematurely (W) Mortalized values are supposed to be freed by the free_tmps() @@ -241,7 +264,7 @@ dereference it first. See L<perlfunc/substr>. (F) You passed a buffer of the wrong size to one of msgctl(), semctl() or shmctl(). In C parlance, the correct sizes are, respectively, -S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)> and +S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)>, and S<sizeof(struct shmid_ds *)>. =item Bad associative array @@ -325,7 +348,7 @@ exited by calling exit. except that there's this itty bitty problem called there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get the same -effect though, since the inner curlies will be considered a block +effect though, because the inner curlies will be considered a block that loops once. See L<perlfunc/last>. =item Can't "next" outside a block @@ -333,7 +356,7 @@ that loops once. See L<perlfunc/last>. (F) A "next" statement was executed to reiterate the current block, but there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get -the same effect though, since the inner curlies will be considered a block +the same effect though, because the inner curlies will be considered a block that loops once. See L<perlfunc/last>. =item Can't "redo" outside a block @@ -341,7 +364,7 @@ that loops once. See L<perlfunc/last>. (F) A "redo" statement was executed to restart the current block, but there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get -the same effect though, since the inner curlies will be considered a block +the same effect though, because the inner curlies will be considered a block that loops once. See L<perlfunc/last>. =item Can't bless non-reference value @@ -387,7 +410,7 @@ that you can chdir to, possibly because it doesn't exist. =item Can't coerce %s to integer in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. So you can't +(typeglobs), can't be forced to stop being what they are. So you can't say things like: *foo += 1; @@ -402,12 +425,12 @@ but then $foo no longer contains a glob. =item Can't coerce %s to number in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. +(typeglobs), can't be forced to stop being what they are. =item Can't coerce %s to string in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. +(typeglobs), can't be forced to stop being what they are. =item Can't create pipe mailbox @@ -416,14 +439,14 @@ or other plumbing problems. =item Can't declare %s in my -(F) Only scalar, array and hash variables may be declared as lexical variables. +(F) Only scalar, array, and hash variables may be declared as lexical variables. They must have ordinary identifiers as names. =item Can't do inplace edit on %s: %s (S) The creation of the new file failed for the indicated reason. -=item Can't do inplace edit without backup +=item Can't do in-place edit without backup (F) You're on a system such as MSDOS that gets confused if you try reading from a deleted (but still opened) file. You have to say B<-i>C<.bak>, or some @@ -473,7 +496,7 @@ For example, it'd be kind of silly to put a B<-x> on the #! line. =item Can't exec "%s": %s -(W) An system(), exec() or piped open call could not execute the named +(W) An system(), exec(), or piped open call could not execute the named program for the indicated reason. Typical reasons include: the permissions were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the executable in question was compiled for another architecture, or the @@ -499,7 +522,7 @@ for us to go to. See L<perlfunc/goto>. =item Can't find string terminator %s anywhere before EOF (F) Perl strings can stretch over multiple lines. This message means that -the closing delimiter was omitted. Since bracketed quotes count nesting +the closing delimiter was omitted. Because bracketed quotes count nesting levels, the following is missing its final parenthesis: print q(The character '(' starts a side comment.) @@ -526,7 +549,7 @@ assumes that the stat buffer contains all the necessary information, and passes it, instead of the filespec, to the access checking routine. It will try to retrieve the filespec using the device name and FID present in the stat buffer, but this works only if you haven't made a subsequent call to the CRTL stat() -routine, since the device name is overwritten with each call. If this warning +routine, because the device name is overwritten with each call. If this warning appears, the name lookup failed, and the access checking routine gave up and returned FALSE, just to be conservative. (Note: The access checking routine knows about the Perl C<stat> operator and file tests, so you shouldn't ever @@ -547,7 +570,7 @@ mailbox buffers to be, and didn't get an answer. (F) The deeply magical "goto subroutine" call can only replace one subroutine call for another. It can't manufacture one out of whole cloth. In general -you should only be calling it out of an AUTOLOAD routine anyway. See +you should be calling it out of only an AUTOLOAD routine anyway. See L<perlfunc/goto>. =item Can't localize a reference @@ -591,16 +614,16 @@ a B<-e> switch. Maybe your /tmp partition is full, or clobbered. =item Can't modify %s in %s (F) You aren't allowed to assign to the item indicated, or otherwise try to -change it, such as with an autoincrement. +change it, such as with an auto-increment. =item Can't modify non-existent substring (P) The internal routine that does assignment to a substr() was handed a NULL. -=item Can't msgrcv to readonly var +=item Can't msgrcv to read-only var -(F) The target of a msgrcv must be modifiable in order to be used as a receive +(F) The target of a msgrcv must be modifiable to be used as a receive buffer. =item Can't open %s: %s @@ -612,7 +635,7 @@ Usually this is because you don't have read permission for the file. (W) You tried to say C<open(CMD, "|cmd|")>, which is not supported. You can try any of several modules in the Perl library to do this, such as -"open2.pl". Alternately, direct the pipe's output to a file using "E<gt>", +IPC::Open2. Alternately, direct the pipe's output to a file using "E<gt>", and then read it in under a different file handle. =item Can't open error file %s as stderr @@ -673,7 +696,7 @@ of suidperl. =item Can't take log of %g -(F) Logarithms are only defined on positive real numbers. +(F) Logarithms are defined on only positive real numbers. =item Can't take sqrt of %g @@ -692,11 +715,6 @@ redefined subroutine while the old routine is running. Go figure. (F) You tried to unshift an "unreal" array that can't be unshifted, such as the main Perl stack. -=item Can't untie: %d inner references still exist - -(F) With "use strict untie" in effect, a copy of the object returned -from C<tie> (or C<tied>) was still valid when C<untie> was called. - =item Can't upgrade that kind of scalar (P) The internal sv_upgrade routine adds "members" to an SV, making @@ -732,10 +750,15 @@ test the type of the reference, if need be. (W) In an ordinary expression, backslash is a unary operator that creates a reference to its argument. The use of backslash to indicate a backreference -to a matched substring is only valid as part of a regular expression pattern. +to a matched substring is valid only as part of a regular expression pattern. Trying to do this in ordinary Perl code produces a value that prints out looking like SCALAR(0xdecaf). Use the $1 form instead. +=item Can't use bareword ("%s") as %s ref while \"strict refs\" in use + +(F) Only hard references are allowed by "strict refs". Symbolic references +are disallowed. See L<perlref>. + =item Can't use string ("%s") as %s ref while "strict refs" in use (F) Only hard references are allowed by "strict refs". Symbolic references @@ -749,7 +772,7 @@ be a defined value. This helps to de-lurk some insidious errors. =item Can't use global %s in "my" (F) You tried to declare a magical variable as a lexical variable. This is -not allowed, because the magic can only be tied to one location (namely +not allowed, because the magic can be tied to only one location (namely the global variable) and it would be incredibly confusing to have variables in your program that looked like magical variables but weren't. @@ -765,7 +788,7 @@ didn't look like an array reference, or anything else subscriptable. (F) The write routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. -=item Can't x= to readonly value +=item Can't x= to read-only value (F) You tried to repeat a constant value (often the undefined value) with an assignment operator, which implies modifying the value itself. @@ -794,6 +817,12 @@ to 01411. Octal constants are introduced with a leading 0 in Perl, as in C. (W) You tried to do a connect on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/connect>. +=item Constant subroutine %s redefined + +(S) You redefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + =item Corrupt malloc ptr 0x%lx at 0x%lx (P) The malloc package that comes with Perl had an internal failure. @@ -824,7 +853,12 @@ case it indicates something else. (W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}. On the other hand, maybe you just meant %hash and got carried away. -=item Do you need to predeclare %s? +=item Died + +(F) You passed die() an empty string (the equivalent of C<die "">) or +you called it with no args and both C<$@> and C<$_> were empty. + +=item Do you need to pre-declare %s? (S) This is an educated guess made in conjunction with the message "%s found where operator expected". It often means a subroutine or module @@ -863,7 +897,7 @@ The interpreter is immediately exited. =item Error converting file specification %s -(F) An error peculiar to VMS. Since Perl may have to deal with file +(F) An error peculiar to VMS. Because Perl may have to deal with file specifications in either VMS or Unix syntax, it converts them to a single form when it must operate on them directly. Either you've passed an invalid file specification to Perl, or you've found a @@ -906,20 +940,20 @@ PDP-11 or something? You need to do an open() or a socket() call, or call a constructor from the FileHandle package. -=item Filehandle %s opened only for input +=item Filehandle %s opened for only input (W) You tried to write on a read-only filehandle. If you intended it to be a read-write filehandle, you needed to open it with "+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing. If -you only intended to write the file, use "E<gt>" or "E<gt>E<gt>". See +you intended only to write the file, use "E<gt>" or "E<gt>E<gt>". See L<perlfunc/open>. -=item Filehandle only opened for input +=item Filehandle opened for only input (W) You tried to write on a read-only filehandle. If you intended it to be a read-write filehandle, you needed to open it with "+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing. If -you only intended to write the file, use "E<gt>" or "E<gt>E<gt>". See +you intended only to write the file, use "E<gt>" or "E<gt>E<gt>". See L<perlfunc/open>. =item Final $ should be \$ or $name @@ -1016,8 +1050,8 @@ is now heavily deprecated. (W) A warning peculiar to VMS. A logical name was encountered when preparing to iterate over %ENV which violates the syntactic rules governing logical -names. Since it cannot be translated normally, it is skipped, and will not -appear in %ENV. This may be a benign occurence, as some software packages +names. Because it cannot be translated normally, it is skipped, and will not +appear in %ENV. This may be a benign occurrence, as some software packages might directly modify logical name tables and introduce non-standard names, or it may indicate that a logical name table has been corrupted. @@ -1063,10 +1097,22 @@ setgid script if C<$ENV{PATH}> is derived from data supplied (or potentially supplied) by the user. The script must set the path to a known value, using trustworthy data. See L<perlsec>. +=item Integer overflow in hex number + +(S) The literal hex number you have specified is too big for your +architecture. On a 32-bit architecture the largest hex literal is +0xFFFFFFFF. + +=item Integer overflow in octal number + +(S) The literal octal number you have specified is too big for your +architecture. On a 32-bit architecture the largest octal literal is +037777777777. + =item Internal inconsistency in tracking vforks (S) A warning peculiar to VMS. Perl keeps track of the number -of times you've called C<fork> and C<exec>, in order to determine +of times you've called C<fork> and C<exec>, to determine whether the current call to C<exec> should affect the current script or a subprocess (see L<perlvms/exec>). Somehow, this count has become scrambled, so Perl is making a guess and treating @@ -1174,7 +1220,7 @@ 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 -constant. You didn't, of course, try "2 = 1", since the compiler +constant. You didn't, of course, try "2 = 1", because the compiler catches that. But an easy way to do the same thing is: sub mod { $_[0] = 1 } @@ -1220,10 +1266,10 @@ that is less than 0. This is difficult to imagine. =item nested *?+ in regexp -(F) You can't quantify a quantifier without intervening parens. So +(F) You can't quantify a quantifier without intervening parentheses. So things like ** or +* or ?* are illegal. -Note, however, that the minimal matching quantifiers, *?, +? and ?? appear +Note, however, that the minimal matching quantifiers, C<*?>, C<+?>, and C<??> appear to be nested quantifiers, but aren't. See L<perlre>. =item No #! line @@ -1266,7 +1312,7 @@ right. =item No dbm on this machine (P) This is counted as an internal error, because every machine should -supply dbm nowadays, since Perl comes with SDBM. See L<SDBM_File>. +supply dbm nowadays, because Perl comes with SDBM. See L<SDBM_File>. =item No DBsub routine @@ -1344,7 +1390,7 @@ format, but this indicates you did, and that it didn't exist. =item Not a GLOB reference -(F) Perl was trying to evaluate a reference to a "type glob" (that is, +(F) Perl was trying to evaluate a reference to a "typeglob" (that is, a symbol table entry that looks like C<*foo>), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L<perlref>. @@ -1396,9 +1442,15 @@ See L<perlform>. =item Null filename used -(F) You can't require the null filename, especially since on many machines +(F) You can't require the null filename, especially because on many machines that means the current directory! See L<perlfunc/require>. +=item Null picture in formline + +(F) The first argument to formline must be a valid format picture +specification. It was found to be empty, which probably means you +supplied it an uninitialized value. See L<perlform>. + =item NULL OP IN RUN (P) Some internal routine called run() with a null opcode pointer. @@ -1409,7 +1461,7 @@ that means the current directory! See L<perlfunc/require>. =item NULL regexp argument -(P) The internal pattern matching routines blew it bigtime. +(P) The internal pattern matching routines blew it big time. =item NULL regexp parameter @@ -1418,7 +1470,14 @@ that means the current directory! See L<perlfunc/require>. =item Odd number of elements in hash list (S) You specified an odd number of elements to a hash list, which is odd, -since hash lists come in key/value pairs. +because hash lists come in key/value pairs. + +=item Offset outside string + +(F) You tried to do a read/write/send/recv operation with an offset +pointing outside the buffer. This is difficult to imagine. +The sole exception to this is that C<sysread()>ing past the buffer +will extend the buffer and zero pad the new area. =item oops: oopsAV @@ -1433,6 +1492,17 @@ since hash lists come in key/value pairs. (F) An attempt was made to use an entry in an overloading table that somehow no longer points to a valid method. See L<overload>. +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importing stubs. +Stubs should never be implicitely created, but explicit calls to C<can> +may break this. + +=item Cannot resolve method `%s' overloading `%s' in package `s' + +(P) Internal error trying to resolve overloading specified by a method +name (as opposed to a subroutine reference). + =item Operator or semicolon missing before %s (S) You used a variable or subroutine call where the parser was @@ -1448,8 +1518,21 @@ but realloc() wouldn't give it more memory, virtual or otherwise. =item Out of memory! -(X) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +The request was judged to be small, so the possibility to trap it +depends on the way perl was compiled. By default it is not trappable. +However, if compiled for this, Perl may use the contents of C<$^M> as +an emergency pool after die()ing with this message. In this case the +error is trappable I<once>. + +=item Out of memory during request for %s + +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so +a possibility to shut down by trapping this error is granted. =item page overflow @@ -1510,7 +1593,7 @@ it wasn't a block context. =item panic: leave_scope clearsv -(P) A writable lexical variable became readonly somehow within the scope. +(P) A writable lexical variable became read-only somehow within the scope. =item panic: leave_scope inconsistency @@ -1596,7 +1679,7 @@ was string. (P) The lexer got into a bad state while processing a case modifier. -=item Parens missing around "%s" list +=item Pareneses missing around "%s" list (W) You said something like @@ -1629,6 +1712,30 @@ perspective, it's probably not what you intended. (F) Your C compiler uses POSIX getpgrp(), which takes no argument, unlike the BSD version, which takes a pid. +=item Possible attempt to put comments in qw() list + +(W) You probably wrote something like this: + + qw( a # a comment + b # another comment + ) ; + +when you should have written this: + + qw( a + b + ) ; + +=item Possible attempt to separate words with commas + +(W) You probably wrote something like this: + + qw( a, b, c ); + +when you should have written this: + + qw( a b c ); + =item Possible memory corruption: %s overflowed 3rd argument (F) An ioctl() or fcntl() returned more than Perl was bargaining for. @@ -1648,7 +1755,7 @@ is now misinterpreted as because of the strict regularization of Perl 5's grammar into unary and list operators. (The old open was a little of both.) You must put -parens around the filehandle, or use the new "or" operator instead of "||". +parentheses around the filehandle, or use the new "or" operator instead of "||". =item print on closed filehandle %s @@ -1670,7 +1777,7 @@ last argument of the previous construct, for example: =item Prototype mismatch: (%s) vs (%s) -(S) The subroutine being defined had a predeclared (forward) declaration +(S) The subroutine being defined had a pre-declared (forward) declaration with a different function prototype. =item Read on closed filehandle E<lt>%sE<gt> @@ -1730,15 +1837,29 @@ shifting or popping (for array variables). See L<perlform>. =item Scalar value @%s[%s] better written as $%s[%s] -(W) You've used an array slice (indicated by @) to select a single value of +(W) You've used an array slice (indicated by @) to select a single element of an array. Generally it's better to ask for a scalar value (indicated by $). The difference is that C<$foo[&bar]> always behaves like a scalar, both when assigning to it and when evaluating its argument, while C<@foo[&bar]> behaves like a list when you assign to it, and provides a list context to its -subscript, which can do weird things if you're only expecting one subscript. +subscript, which can do weird things if you're expecting only one subscript. On the other hand, if you were actually hoping to treat the array -element as a list, you need to look into how references work, since +element as a list, you need to look into how references work, because +Perl will not magically convert between scalars and lists for you. See +L<perlref>. + +=item Scalar value @%s{%s} better written as $%s{%s} + +(W) You've used a hash slice (indicated by @) to select a single element of +a hash. Generally it's better to ask for a scalar value (indicated by $). +The difference is that C<$foo{&bar}> always behaves like a scalar, both when +assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves +like a list when you assign to it, and provides a list context to its +subscript, which can do weird things if you're expecting only one subscript. + +On the other hand, if you were actually hoping to treat the hash +element as a list, you need to look into how references work, because Perl will not magically convert between scalars and lists for you. See L<perlref>. @@ -1783,7 +1904,7 @@ Check your logic flow. =item Sequence (?#... not terminated (F) A regular expression comment must be terminated by a closing -parenthesis. Embedded parens aren't allowed. See L<perlre>. +parenthesis. Embedded parentheses aren't allowed. See L<perlre>. =item Sequence (?%s...) not implemented @@ -1895,7 +2016,7 @@ by itself. (P) The substitution was looping infinitely. (Obviously, a substitution shouldn't iterate more times than there are characters of input, which is what happened.) See the discussion of substitution in -L<perlop/"Quote and Quotelike Operators">. +L<perlop/"Quote and Quote-like Operators">. =item Substitution pattern not terminated @@ -1933,7 +2054,7 @@ Often there will be another error message associated with the syntax error giving more information. (Sometimes it helps to turn on B<-w>.) The error message itself often tells you where it was in the line when it decided to give up. Sometimes the actual error is several tokens -before this, since Perl is good at understanding random input. +before this, because Perl is good at understanding random input. Occasionally the line number may be misleading, and once in a blue moon the only way to figure out what's triggering the error is to call C<perl -c> repeatedly, chopping away half the program each time to see @@ -1947,7 +2068,7 @@ into Perl yourself. =item System V IPC is not implemented on this machine -(F) You tried to do something with a function beginning with "sem", "shm" +(F) You tried to do something with a function beginning with "sem", "shm", or "msg". See L<perlfunc/semctl>, for example. =item Syswrite on closed filehandle @@ -1968,7 +2089,7 @@ open. Check your logic. See also L<perlfunc/-X>. =item That use of $[ is unsupported (F) Assignment to C<$[> is now strictly circumscribed, and interpreted as -a compiler directive. You may only say one of +a compiler directive. You may say only one of $[ = 0; $[ = 1; @@ -2019,7 +2140,7 @@ into Perl yourself. =item Too many args to syscall -(F) Perl only supports a maximum of 14 args to syscall(). +(F) Perl supports a maximum of only 14 args to syscall(). =item Too many arguments for %s @@ -2054,7 +2175,7 @@ certain type. Arrays must be @NAME or C<@{EXPR}>. Hashes must be =item umask: argument is missing initial 0 -(W) A umask of 222 is incorrect. It should be 0222, since octal literals +(W) A umask of 222 is incorrect. It should be 0222, because octal literals always start with 0 in Perl, as in C. =item Unable to create sub named "%s" @@ -2118,13 +2239,13 @@ representative, who probably put it there in the first place. =item Unknown BYTEORDER -(F) There are no byteswapping functions for a machine with this byte order. +(F) There are no byte-swapping functions for a machine with this byte order. =item unmatched () in regexp (F) Unbackslashed parentheses must always be balanced in regular expressions. If you're a vi user, the % key is valuable for finding -the matching paren. See L<perlre>. +the matching parenthesis. See L<perlre>. =item Unmatched right bracket @@ -2195,15 +2316,15 @@ Use an explicit printf() or sprintf() instead. =item Use of $* is deprecated -(D) This variable magically turned on multiline pattern matching, both for +(D) This variable magically turned on multi-line pattern matching, both for you and for any luckless subroutine that you happen to call. You should use the new C<//m> and C<//s> modifiers now to do that without the dangerous action-at-a-distance effects of C<$*>. =item Use of %s in printf format not supported -(F) You attempted to use a feature of printf that is accessible only -from C. This usually means there's a better way to do it in Perl. +(F) You attempted to use a feature of printf that is accessible from +only C. This usually means there's a better way to do it in Perl. =item Use of %s is deprecated @@ -2259,6 +2380,19 @@ a scalar context, the comma is treated like C's comma operator, which throws away the left argument, which is not what you want. See L<perlref> for more on this. +=item untie attempted while %d inner references still exist + +(W) A copy of the object returned from C<tie> (or C<tied>) was still +valid when C<untie> was called. + +=item Value of %s construct can be "0"; test with defined() + +(W) In a conditional expression, you used <HANDLE>, <*> (glob), or +C<readdir> as a boolean value. Each of these constructs can return a +value of "0"; that would make the conditional expression false, which +is probably not what you intended. When using these constructs in +conditional expressions, test their values with the C<defined> operator. + =item Variable "%s" is not exported (F) While "use strict" in effect, you referred to a global variable @@ -2267,18 +2401,67 @@ something else of the same name (usually a subroutine) is exported by that module. It usually means you put the wrong funny character on the front of your variable. +=item Variable "%s" may be unavailable + +(W) An inner (nested) I<anonymous> subroutine is inside a I<named> +subroutine, and outside that is another subroutine; and the anonymous +(innermost) subroutine is referencing a lexical variable defined in +the outermost subroutine. For example: + + sub outermost { my $a; sub middle { sub { $a } } } + +If the anonymous subroutine is called or referenced (directly or +indirectly) from the outermost subroutine, it will share the variable +as you would expect. But if the anonymous subroutine is called or +referenced when the outermost subroutine is not active, it will see +the value of the shared variable as it was before and during the +*first* call to the outermost subroutine, which is probably not what +you want. + +In these circumstances, it is usually best to make the middle +subroutine anonymous, using the C<sub {}> syntax. Perl has specific +support for shared variables in nested anonymous subroutines; a named +subroutine in between interferes with this feature. + +=item Variable "%s" will not stay shared + +(W) An inner (nested) I<named> subroutine is referencing a lexical +variable defined in an outer subroutine. + +When the inner subroutine is called, it will probably see the value of +the outer subroutine's variable as it was before and during the +*first* call to the outer subroutine; in this case, after the first +call to the outer subroutine is complete, the inner and outer +subroutines will no longer share a common value for the variable. In +other words, the variable will no longer be shared. + +Furthermore, if the outer subroutine is anonymous and references a +lexical variable outside itself, then the outer and inner subroutines +will I<never> share the given variable. + +This problem can usually be solved by making the inner subroutine +anonymous, using the C<sub {}> syntax. When inner anonymous subs that +reference variables in outer subroutines are called or referenced, +they are automatically re-bound to the current values of such +variables. + =item Variable syntax. (A) You've accidentally run your script through B<csh> instead of Perl. Check the E<lt>#!E<gt> line, or manually feed your script into Perl yourself. +=item Warning: something's wrong + +(W) You passed warn() an empty string (the equivalent of C<warn "">) or +you called it with no args and C<$_> was empty. + =item Warning: unable to close filehandle %s properly. (S) The implicit close() done by an open() got an error indication on the -close(). This usually indicates your filesystem ran out of disk space. +close(). This usually indicates your file system ran out of disk space. -=item Warning: Use of "%s" without parens is ambiguous +=item Warning: Use of "%s" without parentheses is ambiguous (S) You wrote a unary operator followed by something that looks like a binary operator that could also have been interpreted as a term or @@ -2295,7 +2478,7 @@ but in actual fact, you got rand(+5); -So put in parens to say what you really mean. +So put in parentheses to say what you really mean. =item Write on closed filehandle @@ -2328,7 +2511,7 @@ Use a filename instead. =item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! -(F) And you probably never will, since you probably don't have the +(F) And you probably never will, because you probably don't have the sources to your kernel, and your vendor probably doesn't give a rip about what you want. Your best bet is to use the wrapsuid script in the eg directory to put a setuid C wrapper around your script. @@ -2349,7 +2532,7 @@ See L<perlfunc/getsockopt>. =item \1 better written as $1 (W) Outside of patterns, backreferences live on as variables. The use -of backslashes is grandfathered on the righthand side of a +of backslashes is grandfathered on the right-hand side of a substitution, but stylistically it's better to use the variable form because other Perl programmers will expect it, and it works better if there are more than 9 backreferences. @@ -2378,7 +2561,7 @@ streams, such as =item Got an error from DosAllocMem: (P) An error peculiar to OS/2. Most probably you use an obsolete version -of perl, and should not happen anyway. +of perl, and this should not happen anyway. =item Malformed PERLLIB_PREFIX diff --git a/pod/perldsc.pod b/pod/perldsc.pod index 6991e7a085..a6d6480dbf 100644 --- a/pod/perldsc.pod +++ b/pod/perldsc.pod @@ -30,7 +30,7 @@ with three dimensions! Alas, however simple this may appear, underneath it's a much more elaborate construct than meets the eye! -How do you print it out? Why can't you just say C<print @LoL>? How do +How do you print it out? Why can't you say just C<print @LoL>? How do you sort it? How can you pass it to a function or get one of these back from a function? Is is an object? Can you save it to disk to read back later? How do you access whole rows or columns of that matrix? Do @@ -41,14 +41,14 @@ of the blame for this can be attributed to the reference-based implementation, it's really more due to a lack of existing documentation with examples designed for the beginner. -This document is meant to be a detailed but understandable treatment of -the many different sorts of data structures you might want to develop. It should -also serve as a cookbook of examples. That way, when you need to create one of these -complex data structures, you can just pinch, pilfer, or purloin -a drop-in example from here. +This document is meant to be a detailed but understandable treatment of the +many different sorts of data structures you might want to develop. It +should also serve as a cookbook of examples. That way, when you need to +create one of these complex data structures, you can just pinch, pilfer, or +purloin a drop-in example from here. Let's look at each of these possible constructs in detail. There are separate -documents on each of the following: +sections on each of the following: =over 5 @@ -62,10 +62,6 @@ documents on each of the following: =item * more elaborate constructs -=item * recursive and self-referential data structures - -=item * objects - =back But for now, let's look at some of the general issues common to all @@ -76,15 +72,15 @@ of these types of data structures. The most important thing to understand about all data structures in Perl -- including multidimensional arrays--is that even though they might appear otherwise, Perl C<@ARRAY>s and C<%HASH>es are all internally -one-dimensional. They can only hold scalar values (meaning a string, +one-dimensional. They can hold only scalar values (meaning a string, number, or a reference). They cannot directly contain other arrays or hashes, but instead contain I<references> to other arrays or hashes. -You can't use a reference to a array or hash in quite the same way that -you would a real array or hash. For C or C++ programmers unused to distinguishing -between arrays and pointers to the same, this can be confusing. If so, -just think of it as the difference between a structure and a pointer to a -structure. +You can't use a reference to a array or hash in quite the same way that you +would a real array or hash. For C or C++ programmers unused to +distinguishing between arrays and pointers to the same, this can be +confusing. If so, just think of it as the difference between a structure +and a pointer to a structure. You can (and should) read more about references in the perlref(1) man page. Briefly, references are rather like pointers that know what they @@ -102,7 +98,7 @@ multidimensional arrays work as well. $hash{string}[7] # hash of arrays $hash{string}{'another string'} # hash of hashes -Now, because the top level only contains references, if you try to print +Now, because the top level contains only references, if you try to print out your array in with a simple print() function, you'll get something that doesn't look very nice, like this: @@ -149,7 +145,7 @@ again and again: $LoL[$i] = \@list; # WRONG! } -So, just what's the big problem with that? It looks right, doesn't it? +So, what's the big problem with that? It looks right, doesn't it? After all, I just told you that you need an array of references, so by golly, you've made me one! @@ -218,7 +214,7 @@ something is "interesting", that rather than meaning "intriguing", they're disturbingly more apt to mean that it's "annoying", "difficult", or both? :-) -So just remember to always use the array or hash constructors with C<[]> +So just remember always to use the array or hash constructors with C<[]> or C<{}>, and you'll be fine, although it's not always optimally efficient. @@ -290,21 +286,21 @@ this: my $listref = [ [ "fred", "barney", "pebbles", "bambam", "dino", ], [ "homer", "bart", "marge", "maggie", ], - [ "george", "jane", "alroy", "judy", ], + [ "george", "jane", "elroy", "judy", ], ]; print $listref[2][2]; The compiler would immediately flag that as an error I<at compile time>, because you were accidentally accessing C<@listref>, an undeclared -variable, and it would thereby remind you to instead write: +variable, and it would thereby remind you to write instead: print $listref->[2][2] =head1 DEBUGGING -Before 5.002, the standard Perl debugger didn't do a very nice job of -printing out complex data structures. With version 5.002 or above, the +Before version 5.002, the standard Perl debugger didn't do a very nice job of +printing out complex data structures. With 5.002 or above, the debugger includes several new features, including command line editing as well as the C<x> command to dump out complex data structures. For example, given the assignment to $LoL above, here's the debugger output: @@ -325,7 +321,7 @@ example, given the assignment to $LoL above, here's the debugger output: 2 ARRAY(0x13b540) 0 'george' 1 'jane' - 2 'alroy' + 2 'elroy' 3 'judy' There's also a lower-case B<x> command which is nearly the same. @@ -387,7 +383,7 @@ types of data structures. # print the whole thing one at a time for $i ( 0 .. $#LoL ) { - for $j ( 0 .. $#{$LoL[$i]} ) { + for $j ( 0 .. $#{ $LoL[$i] } ) { print "elt $i $j is $LoL[$i][$j]\n"; } } @@ -397,9 +393,9 @@ types of data structures. =head2 Declaration of a HASH OF LISTS %HoL = ( - "flintstones" => [ "fred", "barney" ], - "jetsons" => [ "george", "jane", "elroy" ], - "simpsons" => [ "homer", "marge", "bart" ], + flintstones => [ "fred", "barney" ], + jetsons => [ "george", "jane", "elroy" ], + simpsons => [ "homer", "marge", "bart" ], ); =head2 Generation of a HASH OF LISTS @@ -449,19 +445,24 @@ types of data structures. # print the whole thing with indices foreach $family ( keys %HoL ) { print "family: "; - foreach $i ( 0 .. $#{ $HoL{$family} ) { + foreach $i ( 0 .. $#{ $HoL{$family} } ) { print " $i = $HoL{$family}[$i]"; } print "\n"; } # print the whole thing sorted by number of members - foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$b}} } keys %HoL ) { + foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$a}} } keys %HoL ) { print "$family: @{ $HoL{$family} }\n" } # print the whole thing sorted by number of members and name - foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$a}} } keys %HoL ) { + foreach $family ( sort { + @{$HoL{$b}} <=> @{$HoL{$a}} + || + $a cmp $b + } keys %HoL ) + { print "$family: ", join(", ", sort @{ $HoL{$family}), "\n"; } @@ -560,19 +561,19 @@ types of data structures. =head2 Declaration of a HASH OF HASHES %HoH = ( - "flintstones" => { - "lead" => "fred", - "pal" => "barney", + flintstones => { + lead => "fred", + pal => "barney", }, - "jetsons" => { - "lead" => "george", - "wife" => "jane", - "his boy" => "elroy", + jetsons => { + lead => "george", + wife => "jane", + "his boy" => "elroy", }, - "simpsons" => { - "lead" => "homer", - "wife" => "marge", - "kid" => "bart", + simpsons => { + lead => "homer", + wife => "marge", + kid => "bart", }, ); @@ -614,8 +615,8 @@ types of data structures. # append new members to an existing family %new_folks = ( - "wife" => "wilma", - "pet" => "dino"; + wife => "wilma", + pet => "dino"; ); for $what (keys %new_folks) { @@ -650,7 +651,7 @@ types of data structures. # print the whole thing sorted by number of members - foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) { + foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$a}} } keys %HoH ) { print "$family: { "; for $role ( sort keys %{ $HoH{$family} } ) { print "$role=$HoH{$family}{$role} "; @@ -663,10 +664,10 @@ types of data structures. for ( qw(lead wife son daughter pal pet) ) { $rank{$_} = ++$i } # now print the whole thing sorted by number of members - foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) { + foreach $family ( sort { keys %{ $HoH{$b} } <=> keys %{ $HoH{$a} } } keys %HoH ) { print "$family: { "; # and print these according to rank order - for $role ( sort { $rank{$a} <=> $rank{$b} keys %{ $HoH{$family} } } ) { + for $role ( sort { $rank{$a} <=> $rank{$b} } keys %{ $HoH{$family} } ) { print "$role=$HoH{$family}{$role} "; } print "}\n"; @@ -710,7 +711,7 @@ many different sorts: =head2 Declaration of a HASH OF COMPLEX RECORDS %TV = ( - "flintstones" => { + flintstones => { series => "flintstones", nights => [ qw(monday thursday friday) ], members => [ @@ -720,7 +721,7 @@ many different sorts: ], }, - "jetsons" => { + jetsons => { series => "jetsons", nights => [ qw(wednesday saturday) ], members => [ @@ -730,7 +731,7 @@ many different sorts: ], }, - "simpsons" => { + simpsons => { series => "simpsons", nights => [ qw(monday) ], members => [ @@ -746,7 +747,7 @@ many different sorts: # reading from file # this is most easily done by having the file itself be # in the raw data format as shown above. perl is happy - # to parse complex datastructures if declared as data, so + # to parse complex data structures if declared as data, so # sometimes it's easiest to do that # here's a piece by piece build up @@ -776,7 +777,7 @@ many different sorts: foreach $family (keys %TV) { $rec = $TV{$family}; # temp pointer @kids = (); - for $person ( @{$rec->{members}} ) { + for $person ( @{ $rec->{members} } ) { if ($person->{role} =~ /kid|son|daughter/) { push @kids, $person; } @@ -805,7 +806,7 @@ many different sorts: for $who ( @{ $TV{$family}{members} } ) { print " $who->{name} ($who->{role}), age $who->{age}\n"; } - print "it turns out that $TV{$family}{'lead'} has "; + print "it turns out that $TV{$family}{lead} has "; print scalar ( @{ $TV{$family}{kids} } ), " kids named "; print join (", ", map { $_->{name} } @{ $TV{$family}{kids} } ); print "\n"; @@ -817,7 +818,7 @@ You cannot easily tie a multilevel data structure (such as a hash of hashes) to a dbm file. The first problem is that all but GDBM and Berkeley DB have size limitations, but beyond that, you also have problems with how references are to be represented on disk. One experimental -module that does attempt to partially address this need is the MLDBM +module that does partially attempt to address this need is the MLDBM module. Check your nearest CPAN site as described in L<perlmod> for source code to MLDBM. @@ -830,4 +831,4 @@ perlref(1), perllol(1), perldata(1), perlobj(1) Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> Last update: -Mon Jul 8 05:22:49 MDT 1996 +Wed Oct 23 04:57:50 MET DST 1996 diff --git a/pod/perlembed.pod b/pod/perlembed.pod index d636a151f4..e55ee633c9 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -16,12 +16,12 @@ Read L<perlcall> and L<perlxs>. =item B<Use a UNIX program from Perl?> -Read about backquotes and about C<system> and C<exec> in L<perlfunc>. +Read about back-quotes and about C<system> and C<exec> in L<perlfunc>. =item B<Use Perl from Perl?> -Read about C<do> and C<eval> in L<perlfunc> and C<use> -and C<require> in L<perlmod>. +Read about C<do> and C<eval> in L<perlfunc/do> and L<perlfunc/eval> and C<use> +and C<require> in L<perlmod> and L<perlfunc/require>, L<perlfunc/use>. =item B<Use C from C?> @@ -37,7 +37,7 @@ Read on... L<Compiling your C program> -There's one example in each of the six sections: +There's one example in each of the eight sections: L<Adding a Perl interpreter to your C program> @@ -49,6 +49,10 @@ L<Performing Perl pattern matches and substitutions from your C program> L<Fiddling with the Perl stack from your C program> +L<Maintaining a persistent interpreter> + +L<Maintaining multiple interpreter instances> + L<Using Perl modules, which themselves use C libraries, from your C program> This documentation is UNIX specific. @@ -69,7 +73,7 @@ Your C program will--usually--allocate, "run", and deallocate a I<PerlInterpreter> object, which is defined in the perl library. If your copy of Perl is recent enough to contain this documentation -(5.002 or later), then the perl library (and I<EXTERN.h> and +(version 5.002 or later), then the perl library (and I<EXTERN.h> and I<perl.h>, which you'll also need) will reside in a directory resembling this: @@ -124,7 +128,6 @@ In a sense, perl (the C program) is a good example of embedding Perl from the source distribution. Here's a bastardized, non-portable version of I<miniperlmain.c> containing the essentials of embedding: - #include <stdio.h> #include <EXTERN.h> /* from the Perl distribution */ #include <perl.h> /* from the Perl distribution */ @@ -142,7 +145,7 @@ I<miniperlmain.c> containing the essentials of embedding: Note that we do not use the C<env> pointer here or in any of the following examples. -Normally handed to C<perl_parse> as it's final argument, +Normally handed to C<perl_parse> as its final argument, we hand it a B<NULL> instead, in which case the current environment is used. @@ -171,12 +174,12 @@ calling I<perl_run()>. =head2 Calling a Perl subroutine from your C program -To call individual Perl subroutines, you'll need to remove the call to -I<perl_run()> and replace it with a call to I<perl_call_argv()>. +To call individual Perl subroutines, you can use any of the B<perl_call_*> +functions documented in the L<perlcall> man page. +In this example we'll use I<perl_call_argv>. That's shown below, in a program I'll call I<showtime.c>. - #include <stdio.h> #include <EXTERN.h> #include <perl.h> @@ -184,13 +187,16 @@ That's shown below, in a program I'll call I<showtime.c>. int main(int argc, char **argv, char **env) { + char *args[] = { NULL }; my_perl = perl_alloc(); perl_construct(my_perl); perl_parse(my_perl, NULL, argc, argv, NULL); - /*** This replaces perl_run() ***/ - perl_call_argv("showtime", G_DISCARD | G_NOARGS, argv); + /*** skipping perl_run() ***/ + + perl_call_argv("showtime", G_DISCARD | G_NOARGS, args); + perl_destruct(my_perl); perl_free(my_perl); } @@ -218,56 +224,56 @@ yielding the number of seconds that elapsed between January 1, 1970 (the beginning of the UNIX epoch), and the moment I began writing this sentence. -If you want to pass some arguments to the Perl subroutine, or -you want to access the return value, you'll need to manipulate the +Note that in this particular case we are not required to call I<perl_run>, +however, in general it's considered good practice to ensure proper +initialization of library code including execution of all object C<DESTROY> +methods and package C<END {}> blocks. + +If you want to pass some arguments to the Perl subroutine, you may add +strings to the C<NULL> terminated C<args> list passed to I<perl_call_argv>. +In order to pass arguments of another data type and/or examine return values +of the subroutine you'll need to manipulate the Perl stack, demonstrated in the last section of this document: L<Fiddling with the Perl stack from your C program> =head2 Evaluating a Perl statement from your C program -NOTE: This section, and the next, employ some very brittle techniques -for evaluating strings of Perl code. Perl 5.002 contains some nifty -features that enable A Better Way (such as with L<perlguts/perl_eval_sv>). -Look for updates to this document soon. - -One way to evaluate a Perl string is to define a function (we'll call -ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>. +One way to evaluate pieces of Perl code is to use L<perlguts/perl_eval_sv>. +We have wrapped this function with our own I<perl_eval()> function, which +converts a command string to an SV, passing this and the L<perlcall/G_DISCARD> +flag to L<perlguts/perl_eval_sv>. Arguably, this is the only routine you'll ever need to execute snippets of Perl code from within your C program. Your string can be as long as you wish; it can contain multiple statements; it can -use L<perlmod/require> or L<perlfunc/do> to include external Perl -files. +include L<perlfunc/use>, L<perlfunc/require> and L<perlfunc/do> to +include external Perl files. Our I<perl_eval()> lets us evaluate individual Perl strings, and then extract variables for coercion into C types. The following program, I<string.c>, executes three Perl strings, extracting an C<int> from the first, a C<float> from the second, and a C<char *> from the third. - #include <stdio.h> #include <EXTERN.h> #include <perl.h> static PerlInterpreter *my_perl; - int perl_eval(char *string) + I32 perl_eval(char *string) { - char *argv[2]; - argv[0] = string; - argv[1] = NULL; - perl_call_argv("_eval_", 0, argv); + return perl_eval_sv(newSVpv(string,0), G_DISCARD); } main (int argc, char **argv, char **env) { - char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" }; + char *embedding[] = { "", "-e", "0" }; STRLEN length; my_perl = perl_alloc(); perl_construct( my_perl ); perl_parse(my_perl, NULL, 3, embedding, NULL); - + perl_run(my_perl); /** Treat $a as an integer **/ perl_eval("$a = 3; $a **= 2"); printf("a = %d\n", SvIV(perl_get_sv("a", FALSE))); @@ -303,14 +309,14 @@ substitutions: I<match()>, I<substitute()>, and I<matches()>. char match(char *string, char *pattern); -Given a string and a pattern (e.g. "m/clasp/" or "/\b\w*\b/", which in +Given a string and a pattern (e.g., "m/clasp/" or "/\b\w*\b/", which in your program might be represented as C<"/\\b\\w*\\b/">), returns 1 if the string matches the pattern and 0 otherwise. int substitute(char *string[], char *pattern); -Given a pointer to a string and an "=~" operation (e.g. "s/bob/robert/g" or +Given a pointer to a string and an "=~" operation (e.g., "s/bob/robert/g" or "tr[A-Z][a-z]"), modifies the string according to the operation, returning the number of substitutions made. @@ -324,16 +330,12 @@ 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 <stdio.h> #include <EXTERN.h> #include <perl.h> static PerlInterpreter *my_perl; - int perl_eval(char *string) + I32 perl_eval(char *string) { - char *argv[2]; - argv[0] = string; - argv[1] = NULL; - perl_call_argv("_eval_", 0, argv); + return perl_eval_sv(newSVpv(string,0), G_DISCARD); } /** match(string, pattern) ** @@ -346,7 +348,7 @@ been wrapped here): char *command; command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37); sprintf(command, "$string = '%s'; $return = $string =~ %s", - string, pattern); + string, pattern); perl_eval(command); free(command); return SvIV(perl_get_sv("return", FALSE)); @@ -364,11 +366,11 @@ been wrapped here): STRLEN length; command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35); sprintf(command, "$string = '%s'; $ret = ($string =~ %s)", - *string, pattern); - perl_eval(command); - free(command); - *string = SvPV(perl_get_sv("string", FALSE), length); - return SvIV(perl_get_sv("ret", FALSE)); + *string, pattern); + perl_eval(command); + free(command); + *string = SvPV(perl_get_sv("string", FALSE), length); + return SvIV(perl_get_sv("ret", FALSE)); } /** matches(string, pattern, matches) ** @@ -387,7 +389,7 @@ been wrapped here): int i; command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38); sprintf(command, "$string = '%s'; @array = ($string =~ %s)", - string, pattern); + string, pattern); perl_eval(command); free(command); array = perl_get_av("array", FALSE); @@ -401,13 +403,15 @@ been wrapped here): } main (int argc, char **argv, char **env) { - char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" }; + char *embedding[] = { "", "-e", "0" }; char *text, **match_list; int num_matches, i; int j; my_perl = perl_alloc(); 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 \ @@ -439,7 +443,7 @@ been wrapped here): num_matches = substitute(&text, "s/[aeiou]//gi"); if (num_matches) { printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", - num_matches); + num_matches); printf("Now text is: %s\n\n", text); } /** Attempt a substitution **/ @@ -488,9 +492,9 @@ described in L<perlcall>. Once you've understood those, embedding Perl in C is easy. -Since C has no built-in function for integer exponentiation, let's +Because C has no built-in function for integer exponentiation, let's make Perl's ** operator available to it (this is less useful than it -sounds, since Perl implements ** with C's I<pow()> function). First +sounds, because Perl implements ** with C's I<pow()> function). First I'll create a stub exponentiation function in I<power.pl>: sub expo { @@ -503,7 +507,6 @@ I<PerlPower()> that contains all the perlguts necessary to push the two arguments into I<expo()> and to pop the return value out. Take a deep breath... - #include <stdio.h> #include <EXTERN.h> #include <perl.h> @@ -539,6 +542,7 @@ deep breath... sprintf(my_argv[1], "power.pl"); perl_parse(my_perl, NULL, argc, my_argv, NULL); + perl_run(my_perl); PerlPower(3, 4); /*** Compute 3 ** 4 ***/ @@ -555,6 +559,296 @@ Compile and run: % power 3 to the 4th power is 81. +=head2 Maintaining a persistent interpreter + +When developing interactive, potentially long-running applications, it's +a good idea to maintain a persistent interpreter rather than allocating +and constructing a new interpreter multiple times. The major gain here is +speed, avoiding the penalty of Perl start-up time. However, a persistent +interpreter will require you to be more cautious in your use of namespace +and variable scoping. In previous examples we've been using global variables +in the default package B<main>. We knew exactly what code would be run, +making it safe to assume we'd avoid any variable collision or outrageous +symbol table growth. + +Let's say your application is a server, which must run perl code from an +arbitrary file during each transaction. Your server has no way of knowing +what code is inside anyone of these files. +If the file was pulled in by B<perl_parse()>, compiled into a newly +constructed interpreter, then cleaned out with B<perl_destruct()> after the +the transaction, you'd be shielded from most namespace troubles. + +One way to avoid namespace collisions in this scenerio, is to translate the +file name into a valid Perl package name, which is most likely to be unique, +then compile the code into that package using L<perlfunc/eval>. +In the example below, each file will only be compiled once, unless it is +updated on disk. +Optionally, the application may choose to clean out the symbol table +associated with the file after we are done with it. We'll call the subroutine +B<Embed::Persistent::eval_file> which lives in the file B<persistent.pl>, with +L<perlcall/perl_call_argv>, passing the filename and boolean cleanup/cache +flag as arguments. + +Note that the process will continue to grow for each file that is compiled, +and each file it pulls in via L<perlfunc/require>, L<perlfunc/use> or +L<perlfunc/do>. In addition, there maybe B<AUTOLOAD>ed subroutines and +other conditions that cause Perl's symbol table to grow. You may wish to +add logic which keeps track of process size or restarts itself after n number +of requests to ensure memory consumption is kept to a minimum. You also need +to consider the importance of variable scoping with L<perlfunc/my> to futher +reduce symbol table growth. + + + package Embed::Persistent; + #persistent.pl + + use strict; + use vars '%Cache'; + + #use Devel::Symdump (); + + sub valid_package_name { + my($string) = @_; + $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; + # second pass only for words starting with a digit + $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; + + # Dress it up as a real package name + $string =~ s|/|::|g; + return "Embed" . $string; + } + + #borrowed from Safe.pm + sub delete_package { + my $pkg = shift; + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "main::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + my $stem_symtab = *{$stem}{HASH}; + + delete $stem_symtab->{$leaf}; + } + + sub eval_file { + my($filename, $delete) = @_; + my $package = valid_package_name($filename); + my $mtime = -M $filename; + if(defined $Cache{$package}{mtime} + && + $Cache{$package}{mtime} <= $mtime) + { + # we have compiled this subroutine already, + # it has not been updated on disk, nothing left to do + print STDERR "already compiled $package->handler\n"; + } + else { + local *FH; + open FH, $filename or die "open '$filename' $!"; + local($/) = undef; + my $sub = <FH>; + close FH; + + #wrap the code into a subroutine inside our unique package + my $eval = qq{package $package; sub handler { $sub; }}; + { + # hide our variables within this block + my($filename,$mtime,$package,$sub); + eval $eval; + } + die $@ if $@; + + #cache it unless we're cleaning out each time + $Cache{$package}{mtime} = $mtime unless $delete; + } + + eval {$package->handler;}; + die $@ if $@; + + delete_package($package) if $delete; + + #take a look if you want + #print Devel::Symdump->rnew($package)->as_string, $/; + } + + 1; + + __END__ + + /* persistent.c */ + #include <EXTERN.h> + #include <perl.h> + + /* 1 = clean out filename's symbol table after each request, 0 = don't */ + #ifndef DO_CLEAN + #define DO_CLEAN 0 + #endif + + static PerlInterpreter *perl = NULL; + + int + main(int argc, char **argv, char **env) + { + char *embedding[] = { "", "persistent.pl" }; + char *args[] = { "", DO_CLEAN, NULL }; + char filename [1024]; + int exitstatus = 0; + + if((perl = perl_alloc()) == NULL) { + fprintf(stderr, "no memory!"); + exit(1); + } + perl_construct(perl); + + exitstatus = perl_parse(perl, NULL, 2, embedding, NULL); + + if(!exitstatus) { + exitstatus = perl_run(perl); + + while(printf("Enter file name: ") && gets(filename)) { + + /* call the subroutine, passing it the filename as an argument */ + args[0] = filename; + perl_call_argv("Embed::Persistent::eval_file", + G_DISCARD | G_EVAL, args); + + /* check $@ */ + if(SvTRUE(GvSV(errgv))) + fprintf(stderr, "eval error: %s\n", SvPV(GvSV(errgv),na)); + } + } + + perl_destruct_level = 0; + perl_destruct(perl); + perl_free(perl); + exit(exitstatus); + } + + +Now compile: + + % cc -o persistent persistent.c `perl -MExtUtils::Embed -e ldopts` + +Here's a example script file: + + #test.pl + my $string = "hello"; + foo($string); + + sub foo { + print "foo says: @_\n"; + } + +Now run: + + % persistent + Enter file name: test.pl + foo says: hello + Enter file name: test.pl + already compiled Embed::test_2epl->handler + foo says: hello + Enter file name: ^C + +=head2 Maintaining multiple interpreter instances + +The previous examples have gone through several steps to startup, use and +shutdown an embedded Perl interpreter. Certain applications may require +more than one instance of an interpreter to be created during the lifespan +of a single process. Such an application may take different approaches in +it's use of interpreter objects. For example, a particular transaction may +want to create an interpreter instance, then release any resources associated +with the object once the transaction is completed. When a single process +does this once, resources are released upon exit of the program and the next +time it starts, the interpreter's global state is fresh. + +In the same process, the program must take care to ensure that these +actions take place before constructing a new interpreter. By default, the +global variable C<perl_destruct_level> is set to C<0> since extra cleaning +is not needed when a program constructs a single interpreter, such as the +perl executable itself in C</usr/bin/perl> or some such. + +You can tell Perl to make everything squeeky clean by setting +C<perl_destruct_level> to C<1>. + + perl_destruct_level = 1; /* perl global variable */ + while(1) { + ... + /* reset global variables here with perl_destruct_level = 1 */ + perl_contruct(my_perl); + ... + /* clean and reset _everything_ during perl_destruct */ + perl_destruct(my_perl); /* ah, nice and fresh */ + perl_free(my_perl); + ... + /* let's go do it again! */ + } + +Now, when I<perl_destruct()> is called, the interpreter's syntax parsetree +and symbol tables are cleaned out, along with reseting global variables. + +So, we've seen how to startup and shutdown an interpreter more than once +in the same process, but there was only one instance in existance at any +one time. Hmm, wonder if we can have more than one interpreter instance +running at the _same_ time? +Indeed this is possible, however when you build Perl, you must compile with +C<-DMULTIPLICITY>. + +It's a little tricky for the Perl runtime to handle multiple interpreters, +introducing some overhead that most programs with a single interpreter don't +get burdened with. When you compile with C<-DMULTIPLICITY>, by default, +C<perl_destruct_level> is set to C<1> for each interpreter. + +Let's give it a try: + + + #include <EXTERN.h> + #include <perl.h> + + + /* we're going to embed two interpreters */ + /* we're going to embed two interpreters */ + + + #define SAY_HELLO "-e", "print qq(Hi, I'm $^X\n)" + + + int main(int argc, char **argv, char **env) + { + PerlInterpreter + *one_perl = perl_alloc(), + *two_perl = perl_alloc(); + char *one_args[] = { "one_perl", SAY_HELLO }; + char *two_args[] = { "two_perl", SAY_HELLO }; + + perl_construct(one_perl); + perl_construct(two_perl); + + perl_parse(one_perl, NULL, 3, one_args, (char **)NULL); + perl_parse(two_perl, NULL, 3, two_args, (char **)NULL); + + perl_run(one_perl); + perl_run(two_perl); + + perl_destruct(one_perl); + perl_destruct(two_perl); + + perl_free(one_perl); + perl_free(two_perl); + } + + +Compile as usual: + + % cc -o multiplicity multiplicity.c `perl -MExtUtils::Embed -e ccopts -e ldopts` + +Run it, Run it: + + % multiplicity + Hi, I'm one_perl + Hi, I'm two_perl + =head2 Using Perl modules, which themselves use C libraries, from your C program If you've played with the examples above and tried to embed a script @@ -612,7 +906,7 @@ counterpart for each of the extension's XSUBs. Don't worry about this part; leave that to the I<xsubpp> and extension authors. If your extension is dynamically loaded, DynaLoader creates I<Module::bootstrap()> for you on the fly. In fact, if you have a working DynaLoader then there -is rarely any need to statically link in any other extensions. +is rarely any need to link in any other extensions statically. Once you have this code, slap it into the second argument of I<perl_parse()>: @@ -644,7 +938,7 @@ Consult L<perlxs> and L<perlguts> for more details. =head1 MORAL You can sometimes I<write faster code> in C, but -you can always I<write code faster> in Perl. Since you can use +you can always I<write code faster> in Perl. Because you can use each from the other, combine them as you wish. diff --git a/pod/perlform.pod b/pod/perlform.pod index a9ce4a7876..b11936b534 100644 --- a/pod/perlform.pod +++ b/pod/perlform.pod @@ -72,7 +72,14 @@ separated by commas. The expressions are all evaluated in a list context before the line is processed, so a single list expression could produce multiple list elements. The expressions may be spread out to more than one line if enclosed in braces. If so, the opening brace must be the first -token on the first line. +token on the first line. If an expression evaluates to a number with a +decimal part, and if the corresponding picture specifies that the decimal +part should appear in the output (that is, any picture except multiple "#" +characters B<without> an embedded "."), the character used for the decimal +point is B<always> determined by the current LC_NUMERIC locale. This +means that, if, for example, the run-time environment happens to specify a +German locale, "," will be used instead of the default ".". See +L<perllocale> and L<"WARNINGS"> for more information. Picture fields that begin with ^ rather than @ are treated specially. With a # field, the field is blanked out if the value is undefined. For @@ -198,7 +205,7 @@ Much better! =head1 NOTES -Since the values line may contain arbitrary expressions (for at fields, +Because the values line may contain arbitrary expressions (for at fields, not caret fields), you can farm out more sophisticated processing to other functions, like sprintf() or one of your own. For example: @@ -306,10 +313,20 @@ is to printf(), do this: END print $string; -=head1 WARNING +=head1 WARNINGS Lexical variables (declared with "my") are not visible within a format unless the format is declared within the scope of the lexical variable. (They weren't visible at all before version 5.001.) Furthermore, lexical aliases will not be compiled correctly: see L<perlfunc/my> for other issues. + +Formats are the only part of Perl which unconditionally use information +from a program's locale; if a program's environment specifies an +LC_NUMERIC locale, it is always used to specify the decimal point +character in formatted output. Perl ignores all other aspects of locale +handling unless the C<use locale> pragma is in effect. Formatted output +cannot be controlled by C<use locale> because the pragma is tied to the +block structure of the program, and, for historical reasons, formats +exist outside that block structure. See L<perllocale> for further +discussion of locale handling. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index cb2d93fef1..65bba93bbb 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -14,8 +14,8 @@ a unary operator, but merely separates the arguments of a list operator. A unary operator generally provides a scalar context to its argument, while a list operator may provide either scalar and list contexts for its arguments. If it does both, the scalar arguments will -be first, and the list argument will follow. (Note that there can only -ever be one list argument.) For instance, splice() has three scalar +be first, and the list argument will follow. (Note that there can ever +be only one list argument.) For instance, splice() has three scalar arguments followed by a list. In the syntax descriptions that follow, list operators that expect a @@ -28,7 +28,7 @@ Elements of the LIST should be separated by commas. Any function in the list below may be used either with or without parentheses around its arguments. (The syntax descriptions omit the -parens.) If you use the parens, the simple (but occasionally +parentheses.) If you use the parentheses, the simple (but occasionally surprising) rule is this: It I<LOOKS> like a function, therefore it I<IS> a function, and precedence doesn't matter. Otherwise it's a list operator or unary operator, and precedence does matter. And whitespace @@ -56,9 +56,7 @@ Remember the following rule: =over 8 -=item - -I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!> +=item I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!> =back @@ -252,12 +250,12 @@ operator may be any of: -C Same for inode change time. The interpretation of the file permission operators C<-r>, C<-R>, C<-w>, -C<-W>, C<-x> and C<-X> is based solely on the mode of the file and the +C<-W>, C<-x>, and C<-X> is based solely on the mode of the file and the uids and gids of the user. There may be other reasons you can't actually read, write or execute the file. Also note that, for the superuser, -C<-r>, C<-R>, C<-w> and C<-W> always return 1, and C<-x> and C<-X> return +C<-r>, C<-R>, C<-w>, and C<-W> always return 1, and C<-x> and C<-X> return 1 if any execute bit is set in the mode. Scripts run by the superuser may -thus need to do a stat() in order to determine the actual mode of the +thus need to do a stat() to determine the actual mode of the file, or temporarily set the uid to something else. Example: @@ -283,8 +281,8 @@ file, or a file at EOF when testing a filehandle. Because you have to read a file to do the C<-T> test, on most occasions you want to use a C<-f> against the file first, as in C<next unless -f $file && -T $file>. -If any of the file tests (or either the stat() or lstat() operators) are given the -special filehandle consisting of a solitary underline, then the stat +If any of the file tests (or either the stat() or lstat() operators) are given +the special filehandle consisting of a solitary underline, then the stat structure of the previous file test (or stat operator) is used, saving a system call. (This doesn't work with C<-t>, and you need to remember that lstat() and C<-l> will leave values in the stat structure for the @@ -304,7 +302,10 @@ symbolic link, not the real file.) Example: =item abs VALUE +=item abs + Returns the absolute value of its argument. +If VALUE is omitted, uses $_. =item accept NEWSOCKET,GENERICSOCKET @@ -314,8 +315,11 @@ See example in L<perlipc/"Sockets: Client/Server Communication">. =item alarm SECONDS +=item alarm + Arranges to have a SIGALRM delivered to this process after the -specified number of seconds have elapsed. (On some machines, +specified number of seconds have elapsed. If SECONDS is not specified, +the value stored in $_ is used. (On some machines, unfortunately, the elapsed time may be up to one second less than you specified because of how seconds are counted.) Only one timer may be counting at once. Each call disables the previous timer, and an @@ -328,10 +332,34 @@ syscall() interface to access setitimer(2) if your system supports it, or else see L</select()> below. It is not advised to intermix alarm() and sleep() calls. +If you want to use alarm() to time out a system call you need to use an +eval/die pair. You can't rely on the alarm causing the system call to +fail with $! set to EINTR because Perl sets up signal handlers to +restart system calls on some systems. Using eval/die always works. + + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; # NB \n required + alarm $timeout; + $nread = sysread SOCKET, $buffer, $size; + alarm 0; + }; + die if $@ && $@ ne "alarm\n"; # propagate errors + if ($@) { + # timed out + } + else { + # didn't + } + =item atan2 Y,X Returns the arctangent of Y/X in the range -PI to PI. +For the tangent operation, you may use the POSIX::tan() +function, or use the familiar relation: + + sub tan { sin($_[0]) / cos($_[0]) } + =item bind SOCKET,NAME Binds a network address to a socket, just as the bind system call @@ -357,10 +385,10 @@ is taken as the name of the filehandle. =item bless REF -This function tells the referenced object (passed as REF) that it is now +This function tells the thingy referenced by REF that it is now an object in the CLASSNAME package--or the current package if no CLASSNAME is specified, which is often the case. It returns the reference for -convenience, since a bless() is often the last thing in a constructor. +convenience, because a bless() is often the last thing in a constructor. Always use the two-argument version if the function doing the blessing might be inherited by a derived class. See L<perlobj> for more about the blessing (and blessings) of objects. @@ -370,8 +398,9 @@ blessing (and blessings) of objects. =item caller Returns the context of the current subroutine call. In a scalar context, -returns TRUE if there is a caller, that is, if we're in a subroutine or -eval() or require(), and FALSE otherwise. In a list context, returns +returns the caller's package name if there is a caller, that is, if +we're in a subroutine or eval() or require(), and the undefined value +otherwise. In a list context, returns ($package, $filename, $line) = caller; @@ -380,7 +409,7 @@ print a stack trace. The value of EXPR indicates how many call frames to go back before the current one. ($package, $filename, $line, - $subroutine, $hasargs, $wantargs) = caller($i); + $subroutine, $hasargs, $wantarray) = caller($i); Furthermore, when called from within the DB package, caller returns more detailed information: it sets the list variable @DB::args to be the @@ -409,12 +438,12 @@ number. Returns the number of files successfully changed. This is a slightly safer version of chop (see below). It removes any line ending that corresponds to the current value of C<$/> (also known as -$INPUT_RECORD_SEPARATOR in the C<English> module). It returns the number -of characters removed. It's often used to remove the newline from the -end of an input record when you're worried that the final record may be -missing its newline. When in paragraph mode (C<$/ = "">), it removes all -trailing newlines from the string. If VARIABLE is omitted, it chomps -$_. Example: +$INPUT_RECORD_SEPARATOR in the C<English> module). It returns the total +number of characters removed from all its arguments. It's often used to +remove the newline from the end of an input record when you're worried +that the final record may be missing its newline. When in paragraph mode +(C<$/ = "">), it removes all trailing newlines from the string. If +VARIABLE is omitted, it chomps $_. Example: while (<>) { chomp; # avoid \n on last field @@ -488,15 +517,21 @@ restrictions may be relaxed, but this is not a portable assumption. =item chr NUMBER +=item chr + Returns the character represented by that NUMBER in the character set. For example, C<chr(65)> is "A" in ASCII. +If NUMBER is omitted, uses $_. + =item chroot FILENAME +=item chroot + This function works as the system call by the same name: it makes the named directory the new root directory for all further pathnames that begin with a "/" by your process and all of its children. (It doesn't -change your current working directory is unaffected.) For security +change your current working directory, which is unaffected.) For security reasons, this call is restricted to the superuser. If FILENAME is omitted, does chroot to $_. @@ -505,7 +540,7 @@ omitted, does chroot to $_. Closes the file or pipe associated with the file handle, returning TRUE only if stdio successfully flushes buffers and closes the system file descriptor. You don't have to close FILEHANDLE if you are immediately -going to do another open() on it, since open() will close it for you. (See +going to do another open() on it, because open() will close it for you. (See open().) However, an explicit close on an input file resets the line counter ($.), while the implicit close done by open() does not. Also, closing a pipe will wait for the process executing on the pipe to @@ -546,6 +581,11 @@ statement). Returns the cosine of EXPR (expressed in radians). If EXPR is omitted takes cosine of $_. +For the inverse cosine operation, you may use the POSIX::acos() +function, or use this relation: + + sub acos { atan2( sqrt(1 - $_[0] * $_[0]), $_[0] ) } + =item crypt PLAINTEXT,SALT Encrypts a string exactly like the crypt(3) function in the C library @@ -572,7 +612,7 @@ their own password: print "ok\n"; } -Of course, typing in your own password to whoever asks you +Of course, typing in your own password to whomever asks you for it is unwise. =item dbmclose ASSOC_ARRAY @@ -591,7 +631,7 @@ normal open, the first argument is I<NOT> a filehandle, even though it looks like one). DBNAME is the name of the database (without the F<.dir> or F<.pag> extension if any). If the database does not exist, it is created with protection specified by MODE (as modified by the umask()). -If your system only supports the older DBM functions, you may perform only +If your system supports only the older DBM functions, you may perform only one dbmopen() in your program. In older versions of Perl, if your system had neither DBM nor ndbm, calling dbmopen() produced a fatal error; it now falls back to sdbm(3). @@ -618,10 +658,13 @@ rich implementation. =item defined EXPR +=item defined + Returns a boolean value saying whether EXPR has a real value -or not. Many operations return the undefined value under exceptional -conditions, such as end of file, uninitialized variable, system error -and such. This function allows you to distinguish between an undefined +or not. If EXPR is not present, $_ will be checked. Many operations +return the undefined value under exceptional conditions, such as end of +file, uninitialized variable, system error and such. This function +allows you to distinguish between an undefined null scalar and a defined null scalar with operations that might return a real null string, such as referencing elements of an array. You may also check to see if arrays or subroutines exist. Use of defined on @@ -653,38 +696,62 @@ matched "nothing". But it didn't really match nothing--rather, it matched something that happened to be 0 characters long. This is all very above-board and honest. When a function returns an undefined value, it's an admission that it couldn't give you an honest answer. So -you should only use defined() when you're questioning the integrity +you should use defined() only when you're questioning the integrity of what you're trying to do. At other times, a simple comparison to 0 or "" is what you want. +Another surprise is that using defined() on an entire array or +hash reports whether memory for that aggregate has ever been +allocated. So an array you set to the empty list appears undefined +initially, and one that once was full and that you then set to +the empty list still appears defined. You should instead use a +simple test for size: + + if (@an_array) { print "has array elements\n" } + if (%a_hash) { print "has hash members\n" } + +Using undef() on these, however, does clear their memory and then report +them as not defined anymore, but you shoudln't do that unless you don't +plan to use them again, because it saves time when you load them up +again to have memory already ready to be filled. + +This counter-intuitive behaviour of defined() on aggregates may be +changed, fixed, or broken in a future release of Perl. + =item delete EXPR -Deletes the specified value from its hash array. Returns the deleted -value, or the undefined value if nothing was deleted. Deleting from -C<$ENV{}> modifies the environment. Deleting from an array tied to a DBM -file deletes the entry from the DBM file. (But deleting from a tie()d -hash doesn't necessarily return anything.) +Deletes the specified key(s) and their associated values from a hash +array. For each key, returns the deleted value associated with that key, +or the undefined value if there was no such key. Deleting from C<$ENV{}> +modifies the environment. Deleting from an array tied to a DBM file +deletes the entry from the DBM file. (But deleting from a tie()d hash +doesn't necessarily return anything.) The following deletes all the values of an associative array: - foreach $key (keys %ARRAY) { - delete $ARRAY{$key}; + foreach $key (keys %HASH) { + delete $HASH{$key}; } -(But it would be faster to use the undef() command.) Note that the -EXPR can be arbitrarily complicated as long as the final operation is -a hash key lookup: +And so does this: + + delete @HASH{keys %HASH} + +(But both of these are slower than the undef() command.) Note that the +EXPR can be arbitrarily complicated as long as the final operation is a +hash element lookup or hash slice: delete $ref->[$x][$y]{$key}; + delete @{$ref->[$x][$y]}{$key1, $key2, @morekeys}; =item die LIST Outside of an eval(), prints the value of LIST to C<STDERR> and exits with the current value of C<$!> (errno). If C<$!> is 0, exits with the value of -C<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 8)> is 0, -exits with 255. Inside an eval(), the error message is stuffed into C<$@>, -and the eval() is terminated with the undefined value; this makes die() -the way to raise an exception. +C<($? E<gt>E<gt> 8)> (back-tick `command` status). If C<($? E<gt>E<gt> 8)> +is 0, exits with 255. Inside an eval(), the error message is stuffed into +C<$@>, and the eval() is terminated with the undefined value; this makes +die() the way to raise an exception. Equivalent examples: @@ -734,7 +801,7 @@ except that it's more efficient, more concise, keeps track of the current filename for error messages, and searches all the B<-I> libraries if the file isn't in the current directory (see also the @INC array in L<perlvar/Predefined Names>). It's the same, however, in that it does -reparse the file every time you call it, so you probably don't want to +re-parse the file every time you call it, so you probably don't want to do this inside a loop. Note that inclusion of library modules is better done with the @@ -779,7 +846,7 @@ Example: When called in a list context, returns a 2-element array consisting of the key and value for the next element of an associative array, so that you can iterate over it. When called in a scalar context, -returns the key only for the next element in the associative array. +returns the key for only the next element in the associative array. Entries are returned in an apparently random order. When the array is entirely read, a null array is returned in list context (which when assigned produces a FALSE (0) value), and C<undef> is returned in a @@ -787,7 +854,7 @@ scalar context. The next call to each() after that will start iterating again. The iterator can be reset only by reading all the elements from the array. You should not add elements to an array while you're iterating over it. There is a single iterator for each -associative array, shared by all each(), keys() and values() function +associative array, shared by all each(), keys(), and values() function calls in the program. The following prints out your environment like the printenv(1) program, only in a different order: @@ -813,7 +880,7 @@ as terminals may lose the end-of-file condition if you do. An C<eof> without an argument uses the last file read as argument. Empty parentheses () may be used to indicate -the pseudofile formed of the files listed on the command line, i.e. +the pseudo file formed of the files listed on the command line, i.e., C<eof()> is reasonable to use inside a while (E<lt>E<gt>) loop to detect the end of only the last file. Use C<eof(ARGV)> or eof without the parentheses to test I<EACH> file in a while (E<lt>E<gt>) loop. Examples: @@ -843,9 +910,11 @@ input operators return undef when they run out of data. EXPR is parsed and executed as if it were a little Perl program. It is executed in the context of the current Perl program, so that any -variable settings, subroutine or format definitions remain afterwards. +variable settings or subroutine and format definitions remain afterwards. The value returned is the value of the last expression evaluated, or a -return statement may be used, just as with subroutines. +return statement may be used, just as with subroutines. The last +expression is evaluated in scalar or array context, depending on the +context of the eval. If there is a syntax error or runtime error, or a die() statement is executed, an undefined value is returned by eval(), and C<$@> is set to the @@ -853,7 +922,7 @@ error message. If there was no error, C<$@> is guaranteed to be a null string. If EXPR is omitted, evaluates $_. The final semicolon, if any, may be omitted from the expression. -Note that, since eval() traps otherwise-fatal errors, it is useful for +Note that, because eval() traps otherwise-fatal errors, it is useful for determining whether a particular feature (such as socket() or symlink()) is implemented. It is also Perl's exception trapping mechanism, where the die operator is used to raise exceptions. @@ -898,8 +967,10 @@ instead, as in case 6. =item exec LIST -The exec() function executes a system command I<AND NEVER RETURNS>. Use -the system() function if you want it to return. +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. 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 @@ -936,7 +1007,7 @@ if the corresponding value is undefined. print "Defined\n" if defined $array{$key}; print "True\n" if $array{$key}; -A hash element can only be TRUE if it's defined, and defined if +A hash element can be TRUE only if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. Note that the EXPR can be arbitrarily complicated as long as the final @@ -956,8 +1027,14 @@ are called before exit.) Example: See also die(). If EXPR is omitted, exits with 0 status. +You shouldn't use exit() to abort a subroutine if there's any chance that +someone might want to trap whatever error happened. Use die() instead, +which can be trapped by an eval(). + =item exp EXPR +=item exp + Returns I<e> (the natural logarithm base) to the power of EXPR. If EXPR is omitted, gives C<exp($_)>. @@ -983,31 +1060,49 @@ value is taken as the name of the filehandle. =item flock FILEHANDLE,OPERATION -Calls flock(2) on FILEHANDLE. See L<flock(2)> for definition of -OPERATION. Returns TRUE for success, FALSE on failure. Will produce a -fatal error if used on a machine that doesn't implement either flock(2) or -fcntl(2). The fcntl(2) system call will be automatically used if flock(2) -is missing from your system. This makes flock() the portable file locking -strategy, although it will only lock entire files, not records. Note also -that some versions of flock() cannot lock things over the network; you -would need to use the more system-specific fcntl() for that. +Calls flock(2), or an emulation of it, on FILEHANDLE. Returns TRUE for +success, FALSE on failure. Will produce a fatal error if used on a +machine that doesn't implement flock(2), fcntl(2) locking, or lockf(3). +flock() is Perl's portable file locking interface, although it will lock +only entire files, not records. + +OPERATION is one of LOCK_SH, LOCK_EX, or LOCK_UN, possibly combined with +LOCK_NB. These constants are traditionally valued 1, 2, 8 and 4, but +you can use the symbolic names if you pull them in with an explicit +request to the Fcntl module. The names can be requested as a group with +the :flock tag (or they can be requested individually, of course). +LOCK_SH requests a shared lock, LOCK_EX requests an exclusive lock, and +LOCK_UN releases a previously requested lock. If LOCK_NB is added to +LOCK_SH or LOCK_EX then flock() will return immediately rather than +blocking waiting for the lock (check the return status to see if you got +it). + +Note that the emulation built with lockf(3) doesn't provide shared +locks, and it requires that FILEHANDLE be open with write intent. These +are the semantics that lockf(3) implements. Most (all?) systems +implement lockf(3) in terms of fcntl(2) locking, though, so the +differing semantics shouldn't bite too many people. + +Note also that some versions of flock() cannot lock things over the +network; you would need to use the more system-specific fcntl() for +that. If you like you can force Perl to ignore your system's flock(2) +function, and so provide its own fcntl(2)-based emulation, by passing +the switch C<-Ud_flock> to the F<Configure> program when you configure +perl. Here's a mailbox appender for BSD systems. - $LOCK_SH = 1; - $LOCK_EX = 2; - $LOCK_NB = 4; - $LOCK_UN = 8; + use Fcntl ':flock'; # import LOCK_* constants sub lock { - flock(MBOX,$LOCK_EX); + flock(MBOX,LOCK_EX); # and, in case someone appended # while we were waiting... seek(MBOX, 0, 2); } sub unlock { - flock(MBOX,$LOCK_UN); + flock(MBOX,LOCK_UN); } open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") @@ -1024,8 +1119,8 @@ See also L<DB_File> for other flock() examples. Does a fork(2) system call. Returns the child pid to the parent process and 0 to the child process, or C<undef> if the fork is unsuccessful. Note: unflushed buffers remain unflushed in both processes, which means -you may need to set C<$|> ($AUTOFLUSH in English) or call the -autoflush() FileHandle method to avoid duplicate output. +you may need to set C<$|> ($AUTOFLUSH in English) or call the autoflush() +method of IO::Handle to avoid duplicate output. If you fork() without ever waiting on your children, you will accumulate zombies: @@ -1050,6 +1145,11 @@ fork() returns omitted); See also L<perlipc> for more examples of forking and reaping moribund children. +Note that if your forked child inherits system file descriptors like +STDIN and STDOUT that are actually connected by a pipe or socket, even +if you exit, the remote server (such as, say, httpd or rsh) won't think +you're done. You should reopen those to /dev/null if it's any issue. + =item format Declare a picture format with use by the write() function. For @@ -1083,7 +1183,7 @@ that the C<~> and C<~~> tokens will treat the entire PICTURE as a single line. You may therefore need to use multiple formlines to implement a single record format, just like the format compiler. -Be careful if you put double quotes around the picture, since an "C<@>" +Be careful if you put double quotes around the picture, because an "C<@>" character may be taken to mean the beginning of an array name. formline() always returns TRUE. See L<perlform> for other examples. @@ -1109,15 +1209,17 @@ single-characters, however. For that, try something more like: system "stty -cbreak </dev/tty >/dev/tty 2>&1"; } else { - system "stty", 'icanon', 'eol', '^@'; # ascii null + system "stty", 'icanon', 'eol', '^@'; # ASCII null } print "\n"; Determination of whether to whether $BSD_STYLE should be set is left as an exercise to the reader. +The POSIX::getattr() function can do this more portably on systems +alleging POSIX compliance. See also the C<Term::ReadKey> module from your nearest CPAN site; -details on CPAN can be found on L<perlmod/CPAN> +details on CPAN can be found on L<perlmod/CPAN>. =item getlogin @@ -1277,7 +1379,7 @@ operator, except it's easier to use. =item gmtime EXPR Converts a time as returned by the time function to a 9-element array -with the time localized for the standard Greenwich timezone. +with the time localized for the standard Greenwich time zone. Typically used as follows: @@ -1332,13 +1434,15 @@ or equivalently, @foo = grep {!/^#/} @bar; # weed out comments -Note that, since $_ is a reference into the list value, it can be used +Note that, because $_ is a reference into the list value, it can be used to modify the elements of the array. While this is useful and supported, it can cause bizarre results if the LIST is not a named array. =item hex EXPR +=item hex + Interprets EXPR as a hex string and returns the corresponding decimal value. (To convert strings that might start with 0 or 0x see oct().) If EXPR is omitted, uses $_. @@ -1362,6 +1466,8 @@ one less than the base, ordinarily -1. =item int EXPR +=item int + Returns the integer portion of EXPR. If EXPR is omitted, uses $_. =item ioctl FILEHANDLE,FUNCTION,SCALAR @@ -1447,6 +1553,21 @@ function. Here's a descending numeric sort of a hash by its values: printf "%4d %s\n", $hash{$key}, $key; } +As an lvalue C<keys> allows you to increase the number of hash buckets +allocated for the given associative array. This can gain you a measure +of efficiency if you know the hash is going to get big. (This is +similar to pre-extending an array by assigning a larger number to +$#array.) If you say + + keys %hash = 200; + +then C<%hash> will have at least 200 buckets allocated for it. These +buckets will be retained even if you do C<%hash = ()>, use C<undef +%hash> if you want to free the storage while C<%hash> is still in scope. +You can't shrink the number of buckets allocated for the hash using +C<keys> in this way (but you needn't worry about doing this by accident, +as trying has no effect). + =item kill LIST Sends a signal to a list of processes. The first element of @@ -1478,18 +1599,28 @@ C<continue> block, if any, is not executed: =item lc EXPR +=item lc + Returns an lowercased version of EXPR. This is the internal function implementing the \L escape in double-quoted strings. -Should respect any POSIX setlocale() settings. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. + +If EXPR is omitted, uses $_. =item lcfirst EXPR +=item lcfirst + Returns the value of EXPR with the first character lowercased. This is the internal function implementing the \l escape in double-quoted strings. -Should respect any POSIX setlocale() settings. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. + +If EXPR is omitted, uses $_. =item length EXPR +=item length + Returns the length in characters of the value of EXPR. If EXPR is omitted, returns length of $_. @@ -1506,8 +1637,8 @@ it succeeded, FALSE otherwise. See example in L<perlipc/"Sockets: Client/Server =item local EXPR A local modifies the listed variables to be local to the enclosing block, -subroutine, C<eval{}> or C<do>. If more than one value is listed, the -list must be placed in parens. See L<perlsub/"Temporary Values via +subroutine, C<eval{}>, or C<do>. If more than one value is listed, the +list must be placed in parentheses. See L<perlsub/"Temporary Values via local()"> for details. But you really probably want to be using my() instead, because local() isn't @@ -1517,7 +1648,7 @@ via my()"> for details. =item localtime EXPR Converts a time as returned by the time function to a 9-element array -with the time analyzed for the local timezone. Typically used as +with the time analyzed for the local time zone. Typically used as follows: ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @@ -1529,13 +1660,15 @@ the range 0..6. If EXPR is omitted, does localtime(time). In a scalar context, prints out the ctime(3) value: - $now_string = localtime; # e.g. "Thu Oct 13 04:54:34 1994" + $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994" Also see the F<timelocal.pl> library, and the strftime(3) function available via the POSIX module. =item log EXPR +=item log + Returns logarithm (base I<e>) of EXPR. If EXPR is omitted, returns log of $_. @@ -1543,10 +1676,14 @@ of $_. =item lstat EXPR +=item lstat + Does the same thing as the stat() function, but stats a symbolic link instead of the file the symbolic link points to. If symbolic links are unimplemented on your system, a normal stat() is done. +If EXPR is omitted, stats $_. + =item m// The match operator. See L<perlop>. @@ -1611,7 +1748,7 @@ an error. A "my" declares the listed variables to be local (lexically) to the enclosing block, subroutine, C<eval>, or C<do/require/use>'d file. If -more than one value is listed, the list must be placed in parens. See +more than one value is listed, the list must be placed in parentheses. See L<perlsub/"Private Variables via my()"> for details. =item next LABEL @@ -1636,6 +1773,8 @@ See the "use" function, which "no" is the opposite of. =item oct EXPR +=item oct + Interprets EXPR as an octal string and returns the corresponding decimal value. (If EXPR happens to start off with 0x, interprets it as a hex string instead.) The following will handle decimal, octal, and @@ -1650,23 +1789,30 @@ If EXPR is omitted, uses $_. =item open FILEHANDLE Opens the file whose filename is given by EXPR, and associates it with -FILEHANDLE. If FILEHANDLE is an expression, its value is used as the name -of the real filehandle wanted. If EXPR is omitted, the scalar variable of -the same name as the FILEHANDLE contains the filename. If the filename -begins with "E<lt>" or nothing, the file is opened for input. If the filename -begins with "E<gt>", the file is opened for output. If the filename begins -with "E<gt>E<gt>", the file is opened for appending. You can put a '+' in -front of the 'E<gt>' or 'E<lt>' to indicate that you want both read and write -access to the file; thus '+E<lt>' is usually preferred for read/write -updates--the '+E<gt>' mode would clobber the file first. These correspond to -the fopen(3) modes of 'r', 'r+', 'w', 'w+', 'a', and 'a+'. - -If the filename begins with "|", the filename is interpreted -as a command to which output is to be piped, and if the filename ends with -a "|", the filename is interpreted See L<perlipc/"Using open() for IPC"> -for more examples of this. as command which pipes input to us. (You may -not have a raw open() to a command that pipes both in I<and> out, but see L<open2>, -L<open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.) +FILEHANDLE. If FILEHANDLE is an expression, its value is used as the +name of the real filehandle wanted. If EXPR is omitted, the scalar +variable of the same name as the FILEHANDLE contains the filename. +(Note that lexical variables--those declared with C<my>--will not work +for this purpose; so if you're using C<my>, specify EXPR in your call +to open.) + +If the filename begins with '<' or nothing, the file is opened for input. +If the filename begins with '>', the file is truncated and opened for +output. If the filename begins with '>>', the file is opened for +appending. You can put a '+' in front of the '>' or '<' to indicate that +you want both read and write access to the file; thus '+<' is almost +always preferred for read/write updates--the '+>' mode would clobber the +file first. The prefix and the filename may be separated with spaces. +These various prefixes correspond to the fopen(3) modes of 'r', 'r+', 'w', +'w+', 'a', and 'a+'. + +If the filename begins with "|", the filename is interpreted as a command +to which output is to be piped, and if the filename ends with a "|", the +filename is interpreted See L<perlipc/"Using open() for IPC"> for more +examples of this. as command which pipes input to us. (You may not have +a raw open() to a command that pipes both in I<and> out, but see +L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication"> +for alternatives.) Opening '-' opens STDIN and opening 'E<gt>-' opens STDOUT. Open returns non-zero upon success, the undefined value otherwise. If the open @@ -1722,7 +1868,7 @@ You may also, in the Bourne shell tradition, specify an EXPR beginning with "E<gt>&", in which case the rest of the string is interpreted as the name of a filehandle (or file descriptor, if numeric) which is to be duped and opened. You may use & after E<gt>, E<gt>E<gt>, E<lt>, +E<gt>, -+E<gt>E<gt> and +E<lt>. The ++E<gt>E<gt>, and +E<lt>. The mode you specify should match the mode of the original filehandle. (Duping a filehandle does not take into account any existing contents of stdio buffers.) @@ -1758,7 +1904,7 @@ parsimonious of file descriptors. For example: open(FILEHANDLE, "<&=$fd") -If you open a pipe on the command "-", i.e. either "|-" or "-|", then +If you open a pipe on the command "-", i.e., either "|-" or "-|", then there is an implicit fork done, and the return value of open is the pid of the child within the parent process, and 0 within the child process. (Use C<defined($pid)> to determine whether the open was successful.) @@ -1785,16 +1931,17 @@ Note: on any operation which may do a fork, unflushed buffers remain unflushed in both processes, which means you may need to set C<$|> to avoid duplicate output. -Using the FileHandle constructor from the FileHandle package, +Using the constructor from the IO::Handle package (or one of its +subclasses, such as IO::File or IO::Socket), you can generate anonymous filehandles which have the scope of whatever variables hold references to them, and automatically close whenever and however you leave that scope: - use FileHandle; + use IO::File; ... sub read_myfile_munged { my $ALL = shift; - my $handle = new FileHandle; + my $handle = new IO::File; open($handle, "myfile") or die "myfile: $!"; $first = <$handle> or return (); # Automatically closed here. @@ -1804,7 +1951,7 @@ and however you leave that scope: } The filename that is passed to open will have leading and trailing -whitespace deleted. In order to open a file with arbitrary weird +whitespace deleted. To open a file with arbitrary weird characters in it, it's necessary to protect any leading and trailing whitespace thusly: @@ -1815,7 +1962,7 @@ If you want a "real" C open() (see L<open(2)> on your system), then you should use the sysopen() function. This is another way to protect your filenames from interpretation. For example: - use FileHandle; + use IO::Handle; sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL, 0700) or die "sysopen $path: $!"; HANDLE->autoflush(1); @@ -1828,11 +1975,13 @@ See L</seek()> for some details about mixing reading and writing. =item opendir DIRHANDLE,EXPR Opens a directory named EXPR for processing by readdir(), telldir(), -seekdir(), rewinddir() and closedir(). Returns TRUE if successful. +seekdir(), rewinddir(), and closedir(). Returns TRUE if successful. DIRHANDLEs have their own namespace separate from FILEHANDLEs. =item ord EXPR +=item ord + Returns the numeric ascii value of the first character of EXPR. If EXPR is omitted, uses $_. @@ -1882,7 +2031,7 @@ follows: @ Null fill to absolute position. Each letter may optionally be followed by a number which gives a repeat -count. With all types except "a", "A", "b", "B", "h" and "H", and "P" the +count. With all types except "a", "A", "b", "B", "h", "H", and "P" the pack function will gobble up that many values from the LIST. A * for the repeat count means to use however many items are left. The "a" and "A" types gobble just one value, but pack it as a string of length count, @@ -1898,7 +2047,7 @@ point data written on one machine may not be readable on another - even if both use IEEE floating point arithmetic (as the endian-ness of the memory representation is not part of the IEEE spec). Note that Perl uses doubles internally for all numeric calculation, and converting from double into -float and thence back to double again will lose precision (i.e. +float and thence back to double again will lose precision (i.e., C<unpack("f", pack("f", $foo)>) will not in general equal $foo). Examples: @@ -1939,11 +2088,11 @@ Declares the compilation unit as being in the given namespace. The scope of the package declaration is from the declaration itself through the end of the enclosing block (the same scope as the local() operator). All further unqualified dynamic identifiers will be in this namespace. A package -statement only affects dynamic variables--including those you've used +statement affects only dynamic variables--including those you've used local() on--but I<not> lexical variables created with my(). Typically it would be the first declaration in a file to be included by the C<require> or C<use> operator. You can switch into a package in more than one place; -it merely influences which symbol table is used by the compiler for the +it influences merely which symbol table is used by the compiler for the rest of that block. You can refer to variables and filehandles in other packages by prefixing the identifier with the package name and a double colon: C<$Package::Variable>. If the package name is null, the C<main> @@ -1960,11 +2109,13 @@ unless you are very careful. In addition, note that Perl's pipes use stdio buffering, so you may need to set C<$|> to flush your WRITEHANDLE after each command, depending on the application. -See L<open2>, L<open3>, and L<perlipc/"Bidirectional Communication"> +See L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication"> for examples of such things. =item pop ARRAY +=item pop + Pops and returns the last value of the array, shortening the array by 1. Has a similar effect to @@ -1977,8 +2128,13 @@ like shift(). =item pos SCALAR +=item pos + Returns the offset of where the last C<m//g> search left off for the variable -in question. May be modified to change that offset. +is in question ($_ is used when the variable is not specified). May be +modified to change that offset. Such modification will also influence +the C<\G> zero-width assertion in regular expressions. See L<perlre> and +L<perlop>. =item print FILEHANDLE LIST @@ -1991,7 +2147,7 @@ if successful. FILEHANDLE may be a scalar variable name, in which case the variable contains the name of or a reference to the filehandle, thus introducing one level of indirection. (NOTE: If FILEHANDLE is a variable and the next token is a term, it may be misinterpreted as an operator unless you -interpose a + or put parens around the arguments.) If FILEHANDLE is +interpose a + or put parentheses around the arguments.) If FILEHANDLE is omitted, prints by default to standard output (or to the last selected output channel--see L</select>). If LIST is also omitted, prints $_ to STDOUT. To set the default output channel to something other than @@ -2001,7 +2157,7 @@ subroutine that you call will have one or more of its expressions evaluated in a list context. Also be careful not to follow the print keyword with a left parenthesis unless you want the corresponding right parenthesis to terminate the arguments to the print--interpose a + or -put parens around all the arguments. +put parentheses around all the arguments. Note that if you're storing FILEHANDLES in an array or other expression, you will have to use a block returning its value instead: @@ -2009,18 +2165,24 @@ you will have to use a block returning its value instead: print { $files[$i] } "stuff\n"; print { $OK ? STDOUT : STDERR } "stuff\n"; -=item printf FILEHANDLE LIST +=item printf FILEHANDLE FORMAT, LIST -=item printf LIST +=item printf FORMAT, LIST -Equivalent to a "print FILEHANDLE sprintf(LIST)". The first argument -of the list will be interpreted as the printf format. +Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>. The first argument +of the list will be interpreted as the printf format. If C<use locale> is +in effect, the character used for the decimal point in formatted real numbers +is affected by the LC_NUMERIC locale. See L<perllocale>. + +Don't fall into the trap of using a printf() when a simple +print() would do. The print() is more efficient, and less +error prone. =item prototype FUNCTION Returns the prototype of a function as a string (or C<undef> if the -function has no prototype). FUNCTION is a reference to the the -function whose prototype you want to retrieve. +function has no prototype). FUNCTION is a reference to, or the name of, +the function whose prototype you want to retrieve. =item push ARRAY,LIST @@ -2046,10 +2208,17 @@ Generalized quotes. See L<perlop>. =item quotemeta EXPR -Returns the value of EXPR with with all regular expression -metacharacters backslashed. This is the internal function implementing +=item quotemeta + +Returns the value of EXPR with with all non-alphanumeric +characters backslashed. (That is, all characters not matching +C</[A-Za-z_0-9]/> will be preceded by a backslash in the +returned string, regardless of any locale settings.) +This is the internal function implementing the \Q escape in double-quoted strings. +If EXPR is omitted, uses $_. + =item rand EXPR =item rand @@ -2086,7 +2255,7 @@ directory. If there are no more entries, returns an undefined value in a scalar context or a null list in a list context. If you're planning to filetest the return values out of a readdir(), you'd -better prepend the directory in question. Otherwise, since we didn't +better prepend the directory in question. Otherwise, because we didn't chdir() there, it would have been testing the wrong file. opendir(DIR, $some_dir) || die "can't opendir $some_dir: $!"; @@ -2095,6 +2264,8 @@ chdir() there, it would have been testing the wrong file. =item readlink EXPR +=item readlink + Returns the value of a symbolic link, if symbolic links are implemented. If not, gives a fatal error. If there is some system error, returns the undefined value and sets C<$!> (errno). If EXPR is @@ -2139,8 +2310,11 @@ themselves about what was just input: =item ref EXPR -Returns a TRUE value if EXPR is a reference, FALSE otherwise. The value -returned depends on the type of thing the reference is a reference to. +=item ref + +Returns a TRUE value if EXPR is a reference, FALSE otherwise. If EXPR +is not specified, $_ will be used. The value returned depends on the +type of thing the reference is a reference to. Builtin types include: REF @@ -2165,7 +2339,7 @@ See also L<perlref>. =item rename OLDNAME,NEWNAME Changes the name of a file. Returns 1 for success, 0 otherwise. Will -not work across filesystem boundaries. +not work across file system boundaries. =item require EXPR @@ -2224,16 +2398,16 @@ variables and reset ?? searches so that they work again. The expression is interpreted as a list of single characters (hyphens allowed for ranges). All variables and arrays beginning with one of those letters are reset to their pristine state. If the expression is -omitted, one-match searches (?pattern?) are reset to match again. Only -resets variables or searches in the current package. Always returns +omitted, one-match searches (?pattern?) are reset to match again. Resets +only variables or searches in the current package. Always returns 1. Examples: reset 'X'; # reset all X variables reset 'a-z'; # reset lower case variables reset; # just reset ?? searches -Resetting "A-Z" is not recommended since you'll wipe out your -ARGV and ENV arrays. Only resets package variables--lexical variables +Resetting "A-Z" is not recommended because you'll wipe out your +ARGV and ENV arrays. Resets only package variables--lexical variables are unaffected, but they clean themselves up on scope exit anyway, so you'll probably want to use them instead. See L</my>. @@ -2270,6 +2444,8 @@ last occurrence at or before that position. =item rmdir FILENAME +=item rmdir + Deletes the directory specified by FILENAME if it is empty. If it succeeds it returns 1, otherwise it returns 0 and sets C<$!> (errno). If FILENAME is omitted, uses $_. @@ -2312,7 +2488,7 @@ EOF on your read, and then sleep for a while, you might have to stick in a seek() to reset things. First the simple trick listed above to clear the filepointer. The seek() doesn't change the current position, but it I<does> clear the end-of-file condition on the handle, so that the next -C<E<lt>FILEE<gt>> makes Perl try again to read something. Hopefully. +C<E<lt>FILEE<gt>> makes Perl try again to read something. We hope. If that doesn't work (some stdios are particularly cantankerous), then you may need something more like this: @@ -2357,12 +2533,12 @@ actual filehandle. Thus: Some programmers may prefer to think of filehandles as objects with methods, preferring to write the last example as: - use FileHandle; + use IO::Handle; STDERR->autoflush(1); =item select RBITS,WBITS,EBITS,TIMEOUT -This calls the select(2) system call with the bitmasks specified, which +This calls the select(2) system call with the bit masks specified, which can be constructed using fileno() and vec(), along these lines: $rin = $win = $ein = ''; @@ -2392,15 +2568,15 @@ or to block until something becomes ready just do this $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); -Most systems do not both to return anything useful in $timeleft, so +Most systems do not bother to return anything useful in $timeleft, so calling select() in a scalar context just returns $nfound. -Any of the bitmasks can also be undef. The timeout, if specified, is +Any of the bit masks can also be undef. The timeout, if specified, is in seconds, which may be fractional. Note: not all implementations are capable of returning the $timeleft. If not, they always return $timeleft equal to the supplied $timeout. -You can effect a 250-millisecond sleep this way: +You can effect a sleep of 250 milliseconds this way: select(undef, undef, undef, 0.25); @@ -2450,7 +2626,7 @@ See L<perlipc/"UDP: Message Passing"> for examples. Sets the current process group for the specified PID, 0 for the current process. Will produce a fatal error if used on a machine that doesn't -implement setpgrp(2). If the arguments are ommitted, it defaults to +implement setpgrp(2). If the arguments are omitted, it defaults to 0,0. Note that the POSIX version of setpgrp() does not accept any arguments, so only setpgrp 0,0 is portable. @@ -2508,9 +2684,16 @@ has the same interpretation as in the system call of the same name. =item sin EXPR +=item sin + Returns the sine of EXPR (expressed in radians). If EXPR is omitted, returns sine of $_. +For the inverse sine operation, you may use the POSIX::sin() +function, or use this relation: + + sub asin { atan2($_[0], sqrt(1 - $_[0] * $_[0])) } + =item sleep EXPR =item sleep @@ -2518,7 +2701,7 @@ returns sine of $_. Causes the script to sleep for EXPR seconds, or forever if no EXPR. May be interrupted by sending the process a SIGALRM. Returns the number of seconds actually slept. You probably cannot mix alarm() and -sleep() calls, since sleep() is often implemented using alarm(). +sleep() calls, because sleep() is often implemented using alarm(). On some older systems, it may sleep up to a full second less than what you requested, depending on how it counts seconds. Most modern systems @@ -2528,17 +2711,19 @@ For delays of finer granularity than one second, you may use Perl's syscall() interface to access setitimer(2) if your system supports it, or else see L</select()> below. +See also the POSIX module's sigpause() function. + =item socket SOCKET,DOMAIN,TYPE,PROTOCOL Opens a socket of the specified kind and attaches it to filehandle -SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the +SOCKET. DOMAIN, TYPE, and PROTOCOL are specified the same as for the system call of the same name. You should "use Socket;" first to get the proper definitions imported. See the example in L<perlipc/"Sockets: Client/Server Communication">. =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL Creates an unnamed pair of sockets in the specified domain, of the -specified type. DOMAIN, TYPE and PROTOCOL are specified the same as +specified type. DOMAIN, TYPE, and PROTOCOL are specified the same as for the system call of the same name. If unimplemented, yields a fatal error. Returns TRUE if successful. @@ -2566,6 +2751,9 @@ the subroutine not via @_ but as the package global variables $a and $b (see example below). They are passed by reference, so don't modify $a and $b. And don't try to declare them as lexicals either. +When C<use locale> is in effect, C<sort LIST> sorts LIST according to the +current collation locale. See L<perllocale>. + Examples: # sort lexically @@ -2593,7 +2781,7 @@ Examples: @sortedclass = sort byage @class; # this sorts the %age associative arrays by value - # instead of key using an inline function + # instead of key using an in-line function @eldest = sort { $age{$b} <=> $age{$a} } keys %age; sub backwards { $b cmp $a; } @@ -2653,6 +2841,13 @@ but if you're in the C<FooPack> package, it's @articles = sort {$FooPack::b <=> $FooPack::a} @files; +The comparison function is required to behave. If it returns +inconsistent results (sometimes saying $x[1] is less than $x[2] and +sometimes saying the opposite, for example) the Perl interpreter will +probably crash and dump core. This is entirely due to and dependent +upon your system's qsort(3) library routine; this routine often avoids +sanity checks in the interest of speed. + =item splice ARRAY,OFFSET,LENGTH,LIST =item splice ARRAY,OFFSET,LENGTH @@ -2663,7 +2858,7 @@ Removes the elements designated by OFFSET and LENGTH from an array, and replaces them with the elements of LIST, if any. Returns the elements removed from the array. The array grows or shrinks as necessary. If LENGTH is omitted, removes everything from OFFSET onward. The -following equivalencies hold (assuming C<$[ == 0>): +following equivalences hold (assuming C<$[ == 0>): push(@a,$x,$y) splice(@a,$#a+1,0,$x,$y) pop(@a) splice(@a,-1) @@ -2718,7 +2913,7 @@ characters at each point it matches that way. For example: produces the output 'h:i:t:h:e:r:e'. -The LIMIT parameter can be used to partially split a line +The LIMIT parameter can be used to split a line partially ($login, $passwd, $remainder) = split(/:/, $_, 3); @@ -2767,37 +2962,73 @@ Example: (Note that $shell above will still have a newline on it. See L</chop>, L</chomp>, and L</join>.) -=item sprintf FORMAT,LIST +=item sprintf FORMAT, LIST Returns a string formatted by the usual printf conventions of the C language. See L<sprintf(3)> or L<printf(3)> on your system for details. (The * character for an indirectly specified length is not supported, but you can get the same effect by interpolating a variable -into the pattern.) Some C libraries' implementations of sprintf() can +into the pattern.) If C<use locale> is +in effect, the character used for the decimal point in formatted real numbers +is affected by the LC_NUMERIC locale. See L<perllocale>. +Some C libraries' implementations of sprintf() can dump core when fed ludicrous arguments. =item sqrt EXPR +=item sqrt + Return the square root of EXPR. If EXPR is omitted, returns square root of $_. =item srand EXPR Sets the random number seed for the C<rand> operator. If EXPR is omitted, -uses a semirandom value based on the current time and process ID, among -other things. Of course, you'd need something much more random than that for -cryptographic purposes, since it's easy to guess the current time. -Checksumming the compressed output of rapidly changing operating system -status programs is the usual method. Examples are posted regularly to -the comp.security.unix newsgroup. +uses a semi-random value based on the current time and process ID, among +other things. +Simply seeding with time() and the process ID isn't particularly random, +especially if they vary together. + +Try something like this instead: + + srand( time() ^ ($$ + ($$ << 15)) ); + +Of course, you'd need something much more random than that for +serious cryptographic purposes, since it's easy to guess the current time. +Checksumming the compressed output of one or more rapidly changing operating +system status programs is the usual method. For example: + + srand (time ^ $$ ^ unpack "%L*", `ps axww | gzip`); + +Do I<not>fP call srand() multiple times in your program unless you know +exactly what you're doing and why you're doing it. The point of the +function is to "seed" the rand() function so that rand() can produce +a different sequence each time you run your program. Just do it once at the +top of your program, or you I<won't> get random numbers out of rand()! + +Frequently called programs (like CGI scripts) that simply use + + time ^ $$ + +for a seed can fall prey to the mathematical property that + + a^b == (a+1)^(b+1) + +one-third of the time. If you're particularly concerned with this, +see the Math::TrulyRandom module in CPAN. + =item stat FILEHANDLE =item stat EXPR +=item stat + Returns a 13-element array giving the status info for a file, either the -file opened via FILEHANDLE, or named by EXPR. Returns a null list if -the stat fails. Typically used as follows: +file opened via FILEHANDLE, or named by EXPR. If EXPR is omitted, it +stats $_. Returns a null list if the stat fails. Typically used as +follows: + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) @@ -2811,13 +3042,13 @@ meaning of the fields: mode file mode (type and permissions) nlink number of (hard) links to the file uid numeric user ID of file's owner - gid numer group ID of file's owner + gid numeric group ID of file's owner rdev the device identifier (special files only) size total size of file, in bytes atime last access time since the epoch mtime last modify time since the epoch ctime inode change time (NOT creation type!) since the epoch - blksize preferred blocksize for file system I/O + blksize preferred block size for file system I/O blocks actual number of blocks allocated (The epoch was at 00:00 January 1, 1970 GMT.) @@ -2830,7 +3061,7 @@ last stat or filetest are returned. Example: print "$file is executable NFS file\n"; } -(This only works on machines for which the device number is negative under NFS.) +(This works on machines only for which the device number is negative under NFS.) =item study SCALAR @@ -2841,7 +3072,7 @@ doing many pattern matches on the string before it is next modified. This may or may not save time, depending on the nature and number of patterns you are searching on, and on the distribution of character frequencies in the string to be searched--you probably want to compare -runtimes with and without it to see which runs faster. Those loops +run times with and without it to see which runs faster. Those loops which scan for many short constant strings (including the constant parts of more complex patterns) will benefit most. You may have only one study active at a time--if you study a different scalar the first @@ -2886,7 +3117,7 @@ out the names of those files that contain a match: @ARGV = @files; undef $/; eval $search; # this screams - $/ = "\n"; # put back to normal input delim + $/ = "\n"; # put back to normal input delimiter foreach $file (sort keys(%seen)) { print $file, "\n"; } @@ -2945,7 +3176,7 @@ like numbers. require 'syscall.ph'; # may need to run h2ph syscall(&SYS_write, fileno(STDOUT), "hi there\n", 9); -Note that Perl only supports passing of up to 14 arguments to your system call, +Note that Perl supports passing of up to only 14 arguments to your system call, which in practice should usually suffice. =item sysopen FILEHANDLE,FILENAME,MODE @@ -2969,6 +3200,9 @@ the value of PERMS specifies the permissions of the newly created file. If PERMS is omitted, the default value is 0666, which allows read and write for all. This default is reasonable: see C<umask>. +The IO::File module provides a more object-oriented approach, if you're +into that kind of thing. + =item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET =item sysread FILEHANDLE,SCALAR,LENGTH @@ -2977,9 +3211,15 @@ Attempts to read LENGTH bytes of data into variable SCALAR from the specified FILEHANDLE, using the system call read(2). It bypasses stdio, so mixing this with other kinds of reads may cause confusion. Returns the number of bytes actually read, or undef if there was an -error. SCALAR will be grown or shrunk to the length actually read. An -OFFSET may be specified to place the read data at some other place than -the beginning of the string. +error. SCALAR will be grown or shrunk so that the last byte actually +read is the last byte of the scalar after the read. + +An OFFSET may be specified to place the read data at some place in the +string other than the beginning. A negative OFFSET specifies +placement at that many bytes counting backwards from the end of the +string. A positive OFFSET greater than the length of SCALAR results +in the string being padded to the required size with "\0" bytes before +the result of the read is appended. =item system LIST @@ -2989,9 +3229,42 @@ Note that argument processing varies depending on the number of arguments. The return value is the exit status of the program as returned by the wait() call. To get the actual exit value divide by 256. See also L</exec>. This is I<NOT> what you want to use to capture -the output from a command, for that you should merely use backticks, as -described in L<perlop/"`STRING`">. +the output from a command, for that you should use merely back-ticks or +qx//, as described in L<perlop/"`STRING`">. + +Because system() and back-ticks block SIGINT and SIGQUIT, killing the +program they're running doesn't actually interrupt your program. + + @args = ("command", "arg1", "arg2"); + system(@args) == 0 + or die "system @args failed: $?" +Here's a more elaborate example of analysing the return value from +system() on a UNIX system to check for all possibilities, including for +signals and coredumps. + + $rc = 0xffff & system @args; + printf "system(%s) returned %#04x: ", "@args", $rc; + if ($rc == 0) { + print "ran with normal exit\n"; + } + elsif ($rc == 0xff00) { + print "command failed: $!\n"; + } + elsif ($rc > 0x80) { + $rc >>= 8; + print "ran with non-zero exit status $rc\n"; + } + else { + print "ran with "; + if ($rc & 0x80) { + $rc &= ~0x80; + print "coredump from "; + } + print "signal $rc\n" + } + $ok = ($rc != 0); + =item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET =item syswrite FILEHANDLE,SCALAR,LENGTH @@ -2999,9 +3272,13 @@ described in L<perlop/"`STRING`">. Attempts to write LENGTH bytes of data from variable SCALAR to the specified FILEHANDLE, using the system call write(2). It bypasses stdio, so mixing this with prints may cause confusion. Returns the -number of bytes actually written, or undef if there was an error. An -OFFSET may be specified to get the write data from some other place than -the beginning of the string. +number of bytes actually written, or undef if there was an error. +If the length is greater than the available data, only as much data as +is available will be written. + +An OFFSET may be specified to write the data from some part of the +string other than the beginning. A negative OFFSET specifies writing +from that many bytes counting backwards from the end of the string. =item tell FILEHANDLE @@ -3108,28 +3385,36 @@ on your system. =item uc EXPR +=item uc + Returns an uppercased version of EXPR. This is the internal function implementing the \U escape in double-quoted strings. -Should respect any POSIX setlocale() settings. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. + +If EXPR is omitted, uses $_. =item ucfirst EXPR +=item ucfirst + Returns the value of EXPR with the first character uppercased. This is the internal function implementing the \u escape in double-quoted strings. -Should respect any POSIX setlocale() settings. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. + +If EXPR is omitted, uses $_. =item umask EXPR =item umask Sets the umask for the process and returns the old one. If EXPR is -omitted, merely returns current umask. +omitted, returns merely the current umask. =item undef EXPR =item undef -Undefines the value of EXPR, which must be an lvalue. Use only on a +Undefines the value of EXPR, which must be an lvalue. Use on only a scalar value, an entire array, or a subroutine name (using "&"). (Using undef() will probably not do what you expect on most predefined variables or DBM list values, so don't do that.) Always returns the undefined value. You can omit @@ -3146,6 +3431,8 @@ subroutine. Examples: =item unlink LIST +=item unlink + Deletes a list of files. Returns the number of files successfully deleted. @@ -3158,11 +3445,13 @@ the B<-U> flag is supplied to Perl. Even if these conditions are met, be warned that unlinking a directory can inflict damage on your filesystem. Use rmdir instead. +If LIST is omitted, uses $_. + =item unpack TEMPLATE,EXPR Unpack does the reverse of pack: it takes a string representing a structure and expands it out into a list value, returning the array -value. (In a scalar context, it merely returns the first value +value. (In a scalar context, it returns merely the first value produced.) The TEMPLATE has the same format as in the pack function. Here's a subroutine that does substring: @@ -3236,7 +3525,9 @@ call into the "Module" package to tell the module to import the list of features back into the current package. The module can implement its import method any way it likes, though most modules just choose to derive their import method via inheritance from the Exporter class that -is defined in the Exporter module. See L<Exporter>. +is defined in the Exporter module. See L<Exporter>. If no import +method can be found then the error is currently silently ignored. This +may change to a fatal error in a future version. If you don't want your namespace altered, explicitly supply an empty list: @@ -3247,8 +3538,11 @@ That is exactly equivalent to BEGIN { require Module; } If the VERSION argument is present between Module and LIST, then the -C<use> will fail if the C<$VERSION> variable in package Module is -less than VERSION. +C<use> will call the VERSION method in class Module with the given +version as an argument. The default VERSION method, inherited from +the Universal class, croaks if the given version is larger than the +value of the variable $Module::VERSION. (Note that there is not a +comma after VERSION!) Because this is a wide-open interface, pragmas (compiler directives) are also implemented this way. Currently implemented pragmas are: @@ -3259,16 +3553,18 @@ are also implemented this way. Currently implemented pragmas are: use strict qw(subs vars refs); use subs qw(afunc blurfl); -These pseudomodules import semantics into the current block scope, unlike +These pseudo-modules import semantics into the current block scope, unlike ordinary modules, which import symbols into the current package (which are effective through the end of the file). There's a corresponding "no" command that unimports meanings imported -by use, i.e. it calls C<unimport Module LIST> instead of C<import>. +by use, i.e., it calls C<unimport Module LIST> instead of C<import>. no integer; no strict 'refs'; +If no unimport method can be found the call fails with a fatal error. + See L<perlmod> for a list of standard modules and pragmas. =item utime LIST @@ -3294,16 +3590,16 @@ on the same array. See also keys(), each(), and sort(). =item vec EXPR,OFFSET,BITS Treats the string in EXPR as a vector of unsigned integers, and -returns the value of the bitfield specified by OFFSET. BITS specifies +returns the value of the bit field specified by OFFSET. BITS specifies the number of bits that are reserved for each entry in the bit vector. This must be a power of two from 1 to 32. vec() may also be -assigned to, in which case parens are needed to give the expression +assigned to, in which case parentheses are needed to give the expression the correct precedence as in vec($image, $max_x * $x + $y, 8) = 3; Vectors created with vec() can also be manipulated with the logical -operators |, & and ^, which will assume a bit vector operation is +operators |, &, and ^, which will assume a bit vector operation is desired when both operands are strings. To transform a bit vector into a string or array of 0's and 1's, use these: @@ -3325,12 +3621,12 @@ Waits for a particular child process to terminate and returns the pid of the deceased process, or -1 if there is no such child process. The status is returned in C<$?>. If you say - use POSIX ":wait_h"; + use POSIX ":sys_wait_h"; ... waitpid(-1,&WNOHANG); then you can do a non-blocking wait for any process. Non-blocking wait -is only available on machines supporting either the waitpid(2) or +is available on machines supporting either the waitpid(2) or wait4(2) system calls. However, waiting for a particular pid with FLAGS of 0 is implemented everywhere. (Perl emulates the system call by remembering the status values of processes that have exited but have diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 2e89807dd3..55014fb404 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -8,7 +8,7 @@ This document attempts to describe some of the internal functions of the Perl executable. It is far from complete and probably contains many errors. Please refer any questions or comments to the author below. -=head1 Datatypes +=head2 Datatypes Perl has three typedefs that handle Perl's three main data types: @@ -20,13 +20,13 @@ Each typedef has specific routines that manipulate the various data types. =head2 What is an "IV"? -Perl uses a special typedef IV which is large enough to hold either an -integer or a pointer. +Perl uses a special typedef IV which is a simple integer type that is +guaranteed to be large enough to hold a pointer (as well as an integer). Perl also uses two special typedefs, I32 and I16, which will always be at least 32-bits and 16-bits long, respectively. -=head2 Working with SVs +=head2 Working with SV's An SV can be created and loaded with one command. There are four types of values that can be loaded: an integer value (IV), a double (NV), a string, @@ -54,6 +54,14 @@ argument to C<newSVpv>. Be warned, though, that Perl will determine the string's length by using C<strlen>, which depends on the string terminating with a NUL character. +All SV's that will contain strings should, but need not, be terminated +with a NUL character. If it is not NUL-terminated there is a risk of +core dumps and corruptions from code which passes the string to C +functions or system calls which expect a NUL-terminated string. +Perl's own functions typically add a trailing NUL for this reason. +Nevertheless, you should be very careful when you pass a string stored +in an SV to a C function or system call. + To access the actual value that an SV points to, you can use the macros: SvIV(SV*) @@ -67,9 +75,9 @@ In the C<SvPV> macro, the length of the string returned is placed into the variable C<len> (this is a macro, so you do I<not> use C<&len>). If you do not care what the length of the data is, use the global variable C<na>. Remember, however, that Perl allows arbitrary strings of data that may both contain -NULs and not be terminated by a NUL. +NUL's and might not be terminated by a NUL. -If you simply want to know if the scalar value is TRUE, you can use: +If you want to know if the scalar value is TRUE, you can use: SvTRUE(SV*) @@ -80,7 +88,9 @@ Perl to allocate more memory for your SV, you can use the macro which will determine if more memory needs to be allocated. If so, it will call the function C<sv_grow>. Note that C<SvGROW> can only increase, not -decrease, the allocated memory of an SV. +decrease, the allocated memory of an SV and that it does not automatically +add a byte for the a trailing NUL (perl's own string functions typically do +C<SvGROW(sv, len + 1)>). If you have an SV and want to know what kind of data Perl thinks is stored in it, you can use the following macros to check the type of SV you have. @@ -118,7 +128,7 @@ be interpreted as a string. If you know the name of a scalar variable, you can get a pointer to its SV by using the following: - SV* perl_get_sv("varname", FALSE); + SV* perl_get_sv("package::varname", FALSE); This returns NULL if the variable does not exist. @@ -146,16 +156,16 @@ Take this code: This code tries to return a new SV (which contains the value 42) if it should return a real value, or undef otherwise. Instead it has returned a null pointer which, somewhere down the line, will cause a segmentation violation, -or just weird results. Change the zero to C<&sv_undef> in the first line and -all will be well. +bus error, or just weird results. Change the zero to C<&sv_undef> in the first +line and all will be well. To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this -call is not necessary. See the section on B<MORTALITY>. +call is not necessary (see the section on L<Mortality>). =head2 What's Really Stored in an SV? Recall that the usual method of determining the type of scalar you have is -to use C<Sv*OK> macros. Since a scalar can be both a number and a string, +to use C<Sv*OK> macros. Because a scalar can be both a number and a string, usually these macros will always return TRUE and calling the C<Sv*V> macros will do the appropriate conversion of string to integer/double or integer/double to string. @@ -170,23 +180,23 @@ pointer in an SV, you can use the following three macros instead: These will tell you if you truly have an integer, double, or string pointer stored in your SV. The "p" stands for private. -In general, though, it's best to just use the C<Sv*V> macros. +In general, though, it's best to use the C<Sv*V> macros. -=head2 Working with AVs +=head2 Working with AV's -There are two ways to create and load an AV. The first method just creates -an empty AV: +There are two ways to create and load an AV. The first method creates an +empty AV: AV* newAV(); -The second method both creates the AV and initially populates it with SVs: +The second method both creates the AV and initially populates it with SV's: AV* av_make(I32 num, SV **ptr); -The second argument points to an array containing C<num> C<SV*>s. Once the -AV has been created, the SVs can be destroyed, if so desired. +The second argument points to an array containing C<num> C<SV*>'s. Once the +AV has been created, the SV's can be destroyed, if so desired. -Once the AV has been created, the following operations are possible on AVs: +Once the AV has been created, the following operations are possible on AV's: void av_push(AV*, SV*); SV* av_pop(AV*); @@ -200,63 +210,77 @@ to these new elements. Here are some other functions: - I32 av_len(AV*); /* Returns highest index value in array */ - + I32 av_len(AV*); SV** av_fetch(AV*, I32 key, I32 lval); - /* Fetches value at key offset, but it stores an undef value - at the offset if lval is non-zero */ SV** av_store(AV*, I32 key, SV* val); - /* Stores val at offset key */ -Take note that C<av_fetch> and C<av_store> return C<SV**>s, not C<SV*>s. +The C<av_len> function returns the highest index value in array (just +like $#array in Perl). If the array is empty, -1 is returned. The +C<av_fetch> function returns the value at index C<key>, but if C<lval> +is non-zero, then C<av_fetch> will store an undef value at that index. +The C<av_store> function stores the value C<val> at index C<key>. +note that C<av_fetch> and C<av_store> both return C<SV**>'s, not C<SV*>'s +as their return value. void av_clear(AV*); - /* Clear out all elements, but leave the array */ void av_undef(AV*); - /* Undefines the array, removing all elements */ void av_extend(AV*, I32 key); - /* Extend the array to a total of key elements */ + +The C<av_clear> function deletes all the elements in the AV* array, but +does not actually delete the array itself. The C<av_undef> function will +delete all the elements in the array plus the array itself. The +C<av_extend> function extends the array so that it contains C<key> +elements. If C<key> is less than the current length of the array, then +nothing is done. If you know the name of an array variable, you can get a pointer to its AV by using the following: - AV* perl_get_av("varname", FALSE); + AV* perl_get_av("package::varname", FALSE); This returns NULL if the variable does not exist. -=head2 Working with HVs +=head2 Working with HV's To create an HV, you use the following routine: HV* newHV(); -Once the HV has been created, the following operations are possible on HVs: +Once the HV has been created, the following operations are possible on HV's: SV** hv_store(HV*, char* key, U32 klen, SV* val, U32 hash); SV** hv_fetch(HV*, char* key, U32 klen, I32 lval); -The C<klen> parameter is the length of the key being passed in. The C<val> -argument contains the SV pointer to the scalar being stored, and C<hash> is -the pre-computed hash value (zero if you want C<hv_store> to calculate it -for you). The C<lval> parameter indicates whether this fetch is actually a -part of a store operation. +The C<klen> parameter is the length of the key being passed in (Note that +you cannot pass 0 in as a value of C<klen> to tell Perl to measure the +length of the key). The C<val> argument contains the SV pointer to the +scalar being stored, and C<hash> is the pre-computed hash value (zero if +you want C<hv_store> to calculate it for you). The C<lval> parameter +indicates whether this fetch is actually a part of a store operation, in +which case a new undefined value will be added to the HV with the supplied +key and C<hv_fetch> will return as if the value had already existed. -Remember that C<hv_store> and C<hv_fetch> return C<SV**>s and not just -C<SV*>. In order to access the scalar value, you must first dereference -the return value. However, you should check to make sure that the return -value is not NULL before dereferencing it. +Remember that C<hv_store> and C<hv_fetch> return C<SV**>'s and not just +C<SV*>. To access the scalar value, you must first dereference the return +value. However, you should check to make sure that the return value is +not NULL before dereferencing it. These two functions check if a hash table entry exists, and deletes it. bool hv_exists(HV*, char* key, U32 klen); SV* hv_delete(HV*, char* key, U32 klen, I32 flags); +If C<flags> does not include the C<G_DISCARD> flag then C<hv_delete> will +create and return a mortal copy of the deleted value. + And more miscellaneous functions: void hv_clear(HV*); - /* Clears all entries in hash table */ void hv_undef(HV*); - /* Undefines the hash table */ + +Like their AV counterparts, C<hv_clear> deletes all the entries in the hash +table but does not actually delete the hash table. The C<hv_undef> deletes +both the entries and the hash table itself. Perl keeps the actual data in linked list of structures with a typedef of HE. These contain the actual key and value pointers (plus extra administrative @@ -284,11 +308,11 @@ specified below. If you know the name of a hash variable, you can get a pointer to its HV by using the following: - HV* perl_get_hv("varname", FALSE); + HV* perl_get_hv("package::varname", FALSE); This returns NULL if the variable does not exist. -The hash algorithm, for those who are interested, is: +The hash algorithm is defined in the C<PERL_HASH(hash, key, klen)> macro: i = klen; hash = 0; @@ -301,13 +325,18 @@ The hash algorithm, for those who are interested, is: References are a special type of scalar that point to other data types (including references). -To create a reference, use the following command: +To create a reference, use either of the following functions: - SV* newRV((SV*) thing); + SV* newRV_inc((SV*) thing); + SV* newRV_noinc((SV*) thing); -The C<thing> argument can be any of an C<SV*>, C<AV*>, or C<HV*>. Once -you have a reference, you can use the following macro to dereference the -reference: +The C<thing> argument can be any of an C<SV*>, C<AV*>, or C<HV*>. The +functions are identical except that C<newRV_inc> increments the reference +count of the C<thing>, while C<newRV_noinc> does not. For historical +reasons, C<newRV> is a synonym for C<newRV_inc>. + +Once you have a reference, you can use the following macro to dereference +the reference: SvRV(SV*) @@ -318,8 +347,8 @@ To determine if an SV is a reference, you can use the following macro: SvROK(SV*) -To actually discover what the reference refers to, you must use the following -macro and then check the value returned. +To discover what type of value the reference refers to, use the following +macro and then check the return value. SvTYPE(SvRV(SV*)) @@ -328,10 +357,14 @@ The most useful types that will be returned are: SVt_IV Scalar SVt_NV Scalar SVt_PV Scalar + SVt_RV Scalar SVt_PVAV Array SVt_PVHV Hash SVt_PVCV Code - SVt_PVMG Blessed Scalar + SVt_PVGV Glob (possible a file handle) + SVt_PVMG Blessed or Magical Scalar + + See the sv.h header file for more details. =head2 Blessed References and Class Objects @@ -345,134 +378,113 @@ A reference can be blessed into a package with the following function: SV* sv_bless(SV* sv, HV* stash); The C<sv> argument must be a reference. The C<stash> argument specifies -which class the reference will belong to. See the L<"Stashes"> +which class the reference will belong to. See the section on L<Stashes> for information on converting class names into stashes. /* Still under construction */ Upgrades rv to reference if not already one. Creates new SV for rv to -point to. -If classname is non-null, the SV is blessed into the specified class. -SV is returned. +point to. If C<classname> is non-null, the SV is blessed into the specified +class. SV is returned. SV* newSVrv(SV* rv, char* classname); -Copies integer or double into an SV whose reference is rv. SV is blessed -if classname is non-null. +Copies integer or double into an SV whose reference is C<rv>. SV is blessed +if C<classname> is non-null. SV* sv_setref_iv(SV* rv, char* classname, IV iv); SV* sv_setref_nv(SV* rv, char* classname, NV iv); -Copies pointer (I<not a string!>) into an SV whose reference is rv. -SV is blessed if classname is non-null. +Copies the pointer value (I<the address, not the string!>) into an SV whose +reference is rv. SV is blessed if C<classname> is non-null. SV* sv_setref_pv(SV* rv, char* classname, PV iv); -Copies string into an SV whose reference is rv. -Set length to 0 to let Perl calculate the string length. -SV is blessed if classname is non-null. +Copies string into an SV whose reference is C<rv>. Set length to 0 to let +Perl calculate the string length. SV is blessed if C<classname> is non-null. SV* sv_setref_pvn(SV* rv, char* classname, PV iv, int length); int sv_isa(SV* sv, char* name); int sv_isobject(SV* sv); -=head1 Creating New Variables +=head2 Creating New Variables -To create a new Perl variable, which can be accessed from your Perl script, -use the following routines, depending on the variable type. +To create a new Perl variable with an undef value which can be accessed from +your Perl script, use the following routines, depending on the variable type. - SV* perl_get_sv("varname", TRUE); - AV* perl_get_av("varname", TRUE); - HV* perl_get_hv("varname", TRUE); + SV* perl_get_sv("package::varname", TRUE); + AV* perl_get_av("package::varname", TRUE); + HV* perl_get_hv("package::varname", TRUE); Notice the use of TRUE as the second parameter. The new variable can now be set, using the routines appropriate to the data type. -There are additional bits that may be OR'ed with the TRUE argument to enable -certain extra features. Those bits are: - - 0x02 Marks the variable as multiply defined, thus preventing the - "Identifier <varname> used only once: possible typo" warning. - 0x04 Issues a "Had to create <varname> unexpectedly" warning if - the variable didn't actually exist. This is useful if - you expected the variable to already exist and want to propagate - this warning back to the user. - -If the C<varname> argument does not contain a package specifier, it is -created in the current package. - -=head1 XSUBs and the Argument Stack - -The XSUB mechanism is a simple way for Perl programs to access C subroutines. -An XSUB routine will have a stack that contains the arguments from the Perl -program, and a way to map from the Perl data structures to a C equivalent. - -The stack arguments are accessible through the C<ST(n)> macro, which returns -the C<n>'th stack argument. Argument 0 is the first argument passed in the -Perl subroutine call. These arguments are C<SV*>, and can be used anywhere -an C<SV*> is used. - -Most of the time, output from the C routine can be handled through use of -the RETVAL and OUTPUT directives. However, there are some cases where the -argument stack is not already long enough to handle all the return values. -An example is the POSIX tzname() call, which takes no arguments, but returns -two, the local timezone's standard and summer time abbreviations. - -To handle this situation, the PPCODE directive is used and the stack is -extended using the macro: - - EXTEND(sp, num); - -where C<sp> is the stack pointer, and C<num> is the number of elements the -stack should be extended by. - -Now that there is room on the stack, values can be pushed on it using the -macros to push IVs, doubles, strings, and SV pointers respectively: - - PUSHi(IV) - PUSHn(double) - PUSHp(char*, I32) - PUSHs(SV*) - -And now the Perl program calling C<tzname>, the two values will be assigned -as in: - - ($standard_abbrev, $summer_abbrev) = POSIX::tzname; - -An alternate (and possibly simpler) method to pushing values on the stack is -to use the macros: - - XPUSHi(IV) - XPUSHn(double) - XPUSHp(char*, I32) - XPUSHs(SV*) - -These macros automatically adjust the stack for you, if needed. - -For more information, consult L<perlxs>. - -=head1 Mortality - -In Perl, values are normally "immortal" -- that is, they are not freed unless -explicitly done so (via the Perl C<undef> call or other routines in Perl -itself). - -Add cruft about reference counts. - int SvREFCNT(SV* sv); - void SvREFCNT_inc(SV* sv); - void SvREFCNT_dec(SV* sv); - -In the above example with C<tzname>, we needed to create two new SVs to push -onto the argument stack, that being the two strings. However, we don't want -these new SVs to stick around forever because they will eventually be -copied into the SVs that hold the two scalar variables. - -An SV (or AV or HV) that is "mortal" acts in all ways as a normal "immortal" -SV, AV, or HV, but is only valid in the "current context". When the Perl -interpreter leaves the current context, the mortal SV, AV, or HV is -automatically freed. Generally the "current context" means a single -Perl statement. +There are additional macros whose values may be bitwise OR'ed with the +C<TRUE> argument to enable certain extra features. Those bits are: + + GV_ADDMULTI Marks the variable as multiply defined, thus preventing the + "Indentifier <varname> used only once: possible typo" warning. + GV_ADDWARN Issues the warning "Had to create <varname> unexpectedly" if + the variable did not exist before the function was called. + +If you do not specify a package name, the variable is created in the current +package. + +=head2 Reference Counts and Mortality + +Perl uses an reference count-driven garbage collection mechanism. SV's, +AV's, or HV's (xV for short in the following) start their life with a +reference count of 1. If the reference count of an xV ever drops to 0, +then it will be destroyed and its memory made available for reuse. + +This normally doesn't happen at the Perl level unless a variable is +undef'ed or the last variable holding a reference to it is changed or +overwritten. At the internal level, however, reference counts can be +manipulated with the following macros: + + int SvREFCNT(SV* sv); + SV* SvREFCNT_inc(SV* sv); + void SvREFCNT_dec(SV* sv); + +However, there is one other function which manipulates the reference +count of its argument. The C<newRV_inc> function, you will recall, +creates a reference to the specified argument. As a side effect, +it increments the argument's reference count. If this is not what +you want, use C<newRV_noinc> instead. + +For example, imagine you want to return a reference from an XSUB function. +Inside the XSUB routine, you create an SV which initially has a reference +count of one. Then you call C<newRV_inc>, passing it the just-created SV. +This returns the reference as a new SV, but the reference count of the +SV you passed to C<newRV_inc> has been incremented to two. Now you +return the reference from the XSUB routine and forget about the SV. +But Perl hasn't! Whenever the returned reference is destroyed, the +reference count of the original SV is decreased to one and nothing happens. +The SV will hang around without any way to access it until Perl itself +terminates. This is a memory leak. + +The correct procedure, then, is to use C<newRV_noinc> instead of +C<newRV_inc>. Then, if and when the last reference is destroyed, +the reference count of the SV will go to zero and it will be destroyed, +stopping any memory leak. + +There are some convenience functions available that can help with the +destruction of xV's. These functions introduce the concept of "mortality". +An xV that is mortal has had its reference count marked to be decremented, +but not actually decremented, until "a short time later". Generally the +term "short time later" means a single Perl statement, such as a call to +an XSUB function. The actual determinant for when mortal xV's have their +reference count decremented depends on two macros, SAVETMPS and FREETMPS. +See L<perlcall> and L<perlxs> for more details on these macros. + +"Mortalization" then is at its simplest a deferred C<SvREFCNT_dec>. +However, if you mortalize a variable twice, the reference count will +later be decremented twice. + +You should be careful about creating mortal variables. Strange things +can happen if you make the same value mortal within multiple contexts, +or if you make a variable mortal multiple times. To create a mortal variable, use the functions: @@ -480,27 +492,15 @@ To create a mortal variable, use the functions: SV* sv_2mortal(SV*) SV* sv_mortalcopy(SV*) -The first call creates a mortal SV, the second converts an existing SV to -a mortal SV, the third creates a mortal copy of an existing SV. - -The mortal routines are not just for SVs -- AVs and HVs can be made mortal -by passing their address (and casting them to C<SV*>) to the C<sv_2mortal> or -C<sv_mortalcopy> routines. +The first call creates a mortal SV, the second converts an existing +SV to a mortal SV (and thus defers a call to C<SvREFCNT_dec>), and the +third creates a mortal copy of an existing SV. -From Ilya: -Beware that the sv_2mortal() call is eventually equivalent to -svREFCNT_dec(). A value can happily be mortal in two different contexts, -and it will be svREFCNT_dec()ed twice, once on exit from these -contexts. It can also be mortal twice in the same context. This means -that you should be very careful to make a value mortal exactly as many -times as it is needed. The value that go to the Perl stack I<should> -be mortal. +The mortal routines are not just for SV's -- AV's and HV's can be +made mortal by passing their address (type-casted to C<SV*>) to the +C<sv_2mortal> or C<sv_mortalcopy> routines. -You should be careful about creating mortal variables. It is possible for -strange things to happen should you make the same value mortal within -multiple contexts. - -=head1 Stashes +=head2 Stashes and Globs A stash is a hash table (associative array) that contains all of the different objects that are contained within a package. Each key of the @@ -517,11 +517,11 @@ objects of that name, including (but not limited to) the following: Format Subroutine -Perl stores various stashes in a separate GV structure (for global -variable) but represents them with an HV structure. The keys in this -larger GV are the various package names; the values are the C<GV*>s -which are stashes. It may help to think of a stash purely as an HV, -and that the term "GV" means the global variable hash. +There is a single stash called "defstash" that holds the items that exist +in the "main" package. To get at the items in other packages, append the +string "::" to the package name. The items in the "Foo" package are in +the stash "Foo::" in defstash. The items in the "Bar::Baz" package are +in the stash "Baz::" in "Bar::"'s stash. To get the stash pointer for a particular package, use the function: @@ -546,8 +546,8 @@ then use the following to get the package name itself: char* HvNAME(HV* stash); -If you need to return a blessed value to your Perl script, you can use the -following function: +If you need to bless or re-bless an object you can use the following +function: SV* sv_bless(SV*, HV* stash) @@ -557,14 +557,14 @@ as any other SV. For more information on references and blessings, consult L<perlref>. -=head1 Magic +=head2 Magic [This section still under construction. Ignore everything here. Post no bills. Everything not permitted is forbidden.] Any SV may be magical, that is, it has special features that a normal SV does not have. These features are stored in the SV structure in a -linked list of C<struct magic>s, typedef'ed to C<MAGIC>. +linked list of C<struct magic>'s, typedef'ed to C<MAGIC>. struct magic { MAGIC* mg_moremagic; @@ -597,7 +597,7 @@ associated with an SV. The C<name> and C<namlem> arguments are used to associate a string with the magic, typically the name of a variable. C<namlem> is stored in the -C<mg_len> field and if C<name> is non-null and C<namlem> E<gt>= 0 a malloc'd +C<mg_len> field and if C<name> is non-null and C<namlem> >= 0 a malloc'd copy of the name is stored in C<mg_ptr> field. The sv_magic function uses C<how> to determine which, if any, predefined @@ -663,8 +663,8 @@ 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 magicalness - ------- ------ ------------------- + mg_type MGVTBL Type of magical + ------- ------ ---------------------------- \0 vtbl_sv Regexp??? A vtbl_amagic Operator Overloading a vtbl_amagicelem Operator Overloading @@ -677,6 +677,7 @@ The current kinds of Magic Virtual Tables are: i vtbl_isaelem @ISA array element L 0 (but sets RMAGICAL) Perl Module/Debugger??? l vtbl_dbline Debugger? + 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 @@ -686,16 +687,29 @@ The current kinds of Magic Virtual Tables are: 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 - ~ Reserved for extensions, but multiple extensions may clash + ~ None Used by certain extensions When an upper-case and lower-case letter both exist in the table, then the upper-case letter is used to represent some kind of composite type (a list or a hash), and the lower-case 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). + +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. + =head2 Finding Magic MAGIC* mg_find(SV*, int type); /* Finds the magic pointer of that type */ @@ -710,7 +724,7 @@ This routine checks to see what types of magic C<sv> has. If the mg_type field is an upper-case letter, then the mg_obj is copied to C<nsv>, but the mg_type field is changed to be the lower-case letter. -=head1 Double-Typed SVs +=head2 Double-Typed SV's Scalar variables normally contain only one type of value, an integer, double, pointer, or reference. Perl will automatically convert the @@ -750,7 +764,58 @@ following code: If the order of C<sv_setiv> and C<sv_setpv> had been reversed, then the macro C<SvPOK_on> would need to be called instead of C<SvIOK_on>. -=head1 Calling Perl Routines from within C Programs +=head2 XSUB's and the Argument Stack + +The XSUB mechanism is a simple way for Perl programs to access C subroutines. +An XSUB routine will have a stack that contains the arguments from the Perl +program, and a way to map from the Perl data structures to a C equivalent. + +The stack arguments are accessible through the C<ST(n)> macro, which returns +the C<n>'th stack argument. Argument 0 is the first argument passed in the +Perl subroutine call. These arguments are C<SV*>, and can be used anywhere +an C<SV*> is used. + +Most of the time, output from the C routine can be handled through use of +the RETVAL and OUTPUT directives. However, there are some cases where the +argument stack is not already long enough to handle all the return values. +An example is the POSIX tzname() call, which takes no arguments, but returns +two, the local time zone's standard and summer time abbreviations. + +To handle this situation, the PPCODE directive is used and the stack is +extended using the macro: + + EXTEND(sp, num); + +where C<sp> is the stack pointer, and C<num> is the number of elements the +stack should be extended by. + +Now that there is room on the stack, values can be pushed on it using the +macros to push IV's, doubles, strings, and SV pointers respectively: + + PUSHi(IV) + PUSHn(double) + PUSHp(char*, I32) + PUSHs(SV*) + +And now the Perl program calling C<tzname>, the two values will be assigned +as in: + + ($standard_abbrev, $summer_abbrev) = POSIX::tzname; + +An alternate (and possibly simpler) method to pushing values on the stack is +to use the macros: + + XPUSHi(IV) + XPUSHn(double) + XPUSHp(char*, I32) + XPUSHs(SV*) + +These macros automatically adjust the stack for you, if needed. Thus, you +do not need to call C<EXTEND> to extend the stack. + +For more information, consult L<perlxs> and L<perlxstut>. + +=head2 Calling Perl Routines from within C Programs There are four routines that can be used to call a Perl subroutine from within a C program. These four are: @@ -785,26 +850,30 @@ functions: XPUSH*() POP*() -For more information, consult L<perlcall>. +For a detailed description of calling conventions from C to Perl, +consult L<perlcall>. -=head1 Memory Allocation +=head2 Memory Allocation -It is strongly suggested that you use the version of malloc that is distributed -with Perl. It keeps pools of various sizes of unallocated memory in order to -more quickly satisfy allocation requests. -However, on some platforms, it may cause spurious malloc or free errors. +It is suggested that you use the version of malloc that is distributed +with Perl. It keeps pools of various sizes of unallocated memory in +order to satisfy allocation requests more quickly. However, on some +platforms, it may cause spurious malloc or free errors. New(x, pointer, number, type); Newc(x, pointer, number, type, cast); Newz(x, pointer, number, type); -These three macros are used to initially allocate memory. The first argument -C<x> was a "magic cookie" that was used to keep track of who called the macro, -to help when debugging memory problems. However, the current code makes no -use of this feature (Larry has switched to using a run-time memory checker), -so this argument can be any number. +These three macros are used to initially allocate memory. + +The first argument C<x> was a "magic cookie" that was used to keep track +of who called the macro, to help when debugging memory problems. However, +the current code makes no use of this feature (most Perl developers now +use run-time memory checkers), so this argument can be any number. + +The second argument C<pointer> should be the name of a variable that will +point to the newly allocated memory. -The second argument C<pointer> will point to the newly allocated memory. The third and fourth arguments C<number> and C<type> specify how many of the specified type of data structure should be allocated. The argument C<type> is passed to C<sizeof>. The final argument to C<Newc>, C<cast>, @@ -833,7 +902,78 @@ destination starting points. Perl will move, copy, or zero out C<number> instances of the size of the C<type> data structure (using the C<sizeof> function). -=head1 API LISTING +=head2 PerlIO + +The most recent development releases of Perl has been experimenting with +removing Perl's dependency on the "normal" standard I/O suite and allowing +other stdio implementations to be used. This involves creating a new +abstraction layer that then calls whichever implementation of stdio Perl +was compiled with. All XSUB's should now use the functions in the PerlIO +abstraction layer and not make any assumptions about what kind of stdio +is being used. + +For a complete description of the PerlIO abstraction, consult L<perlapio>. + +=head2 Scratchpads + +=head2 Putting a C value on Perl stack + +A lot of opcodes (this is an elementary operation in the internal perl +stack machine) put an SV* on the stack. However, as an optimization +the corresponding SV is (usually) not recreated each time. The opcodes +reuse specially assigned SVs (I<target>s) which are (as a corollary) +not constantly freed/created. + +Each of the targets is created only once (but see +L<Scratchpads and recursion> below), and when an opcode needs to put +an integer, a double, or a string on stack, it just sets the +corresponding parts of its I<target> and puts the I<target> on stack. + +The macro to put this target on stack is C<PUSHTARG>, and it is +directly used in some opcodes, as well as indirectly in zillions of +others, which use it via C<(X)PUSH[pni]>. + +=head2 Scratchpads + +The question remains on when the SV's which are I<target>s for opcodes +are created. The answer is that they are created when the current unit -- +a subroutine or a file (for opcodes for statements outside of +subroutines) -- is compiled. During this time a special anonymous Perl +array is created, which is called a scratchpad for the current +unit. + +A scratchpad keeps SV's which are lexicals for the current unit and are +targets for opcodes. One can deduce that an SV lives on a scratchpad +by looking on its flags: lexicals have C<SVs_PADMY> set, and +I<target>s have C<SVs_PADTMP> set. + +The correspondence between OP's and I<target>s is not 1-to-1. Different +OP's in the compile tree of the unit can use the same target, if this +would not conflict with the expected life of the temporary. + +=head2 Scratchpads and recursions + +In fact it is not 100% true that a compiled unit contains a pointer to +the scratchpad AV. In fact it contains a pointer to an AV of +(initially) one element, and this element is the scratchpad AV. Why do +we need an extra level of indirection? + +The answer is B<recursion>, and maybe (sometime soon) B<threads>. Both +these can create several execution pointers going into the same +subroutine. For the subroutine-child not write over the temporaries +for the subroutine-parent (lifespan of which covers the call to the +child), the parent and the child should have different +scratchpads. (I<And> the lexicals should be separate anyway!) + +So each subroutine is born with an array of scratchpads (of length 1). +On each entry to the subroutine it is checked that the current +depth of the recursion is not more than the length of this array, and +if it is, new scratchpad is created and pushed into the array. + +The I<target>s on this scratchpad are C<undef>s, but they are already +marked with correct flags. + +=head2 API LISTING This is a listing of functions, macros, flags, and variables that may be useful to extension writers or that may be found while reading other @@ -876,7 +1016,7 @@ Returns the highest index in the array. Returns -1 if the array is empty. Creates a new AV and populates it with a list of SVs. The SVs are copied into the array, so they may be freed after the call to av_make. The new AV -will have a refcount of 1. +will have a reference count of 1. AV* av_make _((I32 size, SV** svp)); @@ -1046,6 +1186,39 @@ Indicates that no arguments are being sent to a callback. See L<perlcall>. Used to indicate scalar context. See C<GIMME> and L<perlcall>. +=item gv_fetchmeth + +Returns the glob with the given C<name> and a defined subroutine or +C<NULL>. The glob lives in the given C<stash>, or in the stashes accessable +via @ISA and @<UNIVERSAL>. + +As a side-effect creates a glob with the given C<name> in the given C<stash> +which in the case of success contains an alias for the subroutine, and +sets up caching info for this glob. Similarly for all the searched +stashes. + + GV* gv_fetchmeth _((HV* stash, char* name, STRLEN len, I32 level)); + +=item gv_fetchmethod + +Returns the glob which contains the subroutine to call to invoke the +method on the C<stash>. In fact in the presense of autoloading this may +be the glob for "AUTOLOAD". In this case the corresponing variable +$AUTOLOAD is already setup. + +Note that if you want to keep this glob for a long time, you need to +check for it being "AUTOLOAD", since at the later time the the call +may load a different subroutine due to $AUTOLOAD changing its value. +Use the glob created via a side effect to do this. + +This function grants C<"SUPER"> token as prefix of name or postfix of +the stash name. + +Has the same side-effects and as C<gv_fetchmeth()>. C<name> should be +writable if contains C<':'> or C<'\''>. + + GV* gv_fetchmethod _((HV* stash, char* name)); + =item gv_stashpv Returns a pointer to the stash for a specified package. If C<create> is set @@ -1060,13 +1233,20 @@ Returns a pointer to the stash for a specified package. See C<gv_stashpv>. HV* gv_stashsv _((SV* sv, I32 create)); -=item GvSV +=item he_free -Return the SV from the GV. +Releases a hash entry, such as while iterating though the hash. See +C<hv_iternext>. -=item he_free + void he_free _((HV* hv, HE* hent)); + +=item he_delayfree -Releases a hash entry from an iterator. See C<hv_iternext>. +Releases a hash entry, such as while iterating though the hash, but +delays actual freeing of key and value until the end of the current +statement (or thereabouts) with C<sv_2mortal>. See C<hv_iternext>. + + void he_delayfree _((HV* hv, HE* hent)); =item hv_clear @@ -1163,7 +1343,7 @@ Undefines the hash. =item isALNUM Returns a boolean indicating whether the C C<char> is an ascii alphanumeric -character. +character or digit. int isALNUM (char c) @@ -1300,49 +1480,58 @@ memory is zeroed with C<memzero>. =item newAV -Creates a new AV. The refcount is set to 1. +Creates a new AV. The reference count is set to 1. AV* newAV _((void)); =item newHV -Creates a new HV. The refcount is set to 1. +Creates a new HV. The reference count is set to 1. HV* newHV _((void)); -=item newRV +=item newRV_inc -Creates an RV wrapper for an SV. The refcount for the original SV is +Creates an RV wrapper for an SV. The reference count for the original SV is incremented. - SV* newRV _((SV* ref)); + SV* newRV_inc _((SV* ref)); + +For historical reasons, "newRV" is a synonym for "newRV_inc". + +=item newRV_noinc + +Creates an RV wrapper for an SV. The reference count for the original +SV is B<not> incremented. + + SV* newRV_noinc _((SV* ref)); =item newSV Creates a new SV. The C<len> parameter indicates the number of bytes of -pre-allocated string space the SV should have. The refcount for the new SV -is set to 1. +pre-allocated string space the SV should have. The reference count for the +new SV is set to 1. SV* newSV _((STRLEN len)); =item newSViv -Creates a new SV and copies an integer into it. The refcount for the SV is -set to 1. +Creates a new SV and copies an integer into it. The reference count for the +SV is set to 1. SV* newSViv _((IV i)); =item newSVnv -Creates a new SV and copies a double into it. The refcount for the SV is -set to 1. +Creates a new SV and copies a double into it. The reference count for the +SV is set to 1. SV* newSVnv _((NV i)); =item newSVpv -Creates a new SV and copies a string into it. The refcount for the SV is -set to 1. If C<len> is zero then Perl will compute the length. +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. If C<len> is zero then Perl will compute the length. SV* newSVpv _((char* s, STRLEN len)); @@ -1351,7 +1540,7 @@ set to 1. If C<len> is zero then Perl will compute the length. Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then it will be upgraded to one. If C<classname> is non-null then the new SV will be blessed in the specified package. The new SV is returned and its -refcount is 1. +reference count is 1. SV* newSVrv _((SV* rv, char* classname)); @@ -1616,7 +1805,7 @@ C<SPAGAIN>. =item SPAGAIN -Refetch the stack pointer. Used after a callback. See L<perlcall>. +Re-fetch the stack pointer. Used after a callback. See L<perlcall>. SPAGAIN; @@ -1690,8 +1879,8 @@ ends. =item sv_bless Blesses an SV into a specified package. The SV must be an RV. The package -must be designated by its stash (see C<gv_stashpv()>). The refcount of the -SV is unaffected. +must be designated by its stash (see C<gv_stashpv()>). The reference count +of the SV is unaffected. SV* sv_bless _((SV* sv, HV* stash)); @@ -1745,13 +1934,13 @@ Set the length of the string which is in the SV. See C<SvCUR>. =item sv_dec -Autodecrement of the value in the SV. +Auto-decrement of the value in the SV. void sv_dec _((SV* sv)); =item sv_dec -Autodecrement of the value in the SV. +Auto-decrement of the value in the SV. void sv_dec _((SV* sv)); @@ -1784,7 +1973,7 @@ Use C<SvGROW>. =item sv_inc -Autoincrement of the value in the SV. +Auto-increment of the value in the SV. void sv_inc _((SV* sv)); @@ -1892,7 +2081,7 @@ Returns a boolean indicating whether the value is an SV. =item sv_newmortal -Creates a new SV which is mortal. The refcount of the SV is set to 1. +Creates a new SV which is mortal. The reference count of the SV is set to 1. SV* sv_newmortal _((void)); @@ -2022,19 +2211,19 @@ Returns a pointer to the string in the SV. The SV must contain a string. =item SvREFCNT -Returns the value of the object's refcount. +Returns the value of the object's reference count. int SvREFCNT (SV* sv); =item SvREFCNT_dec -Decrements the refcount of the given SV. +Decrements the reference count of the given SV. void SvREFCNT_dec (SV* sv) =item SvREFCNT_inc -Increments the refcount of the given SV. +Increments the reference count of the given SV. void SvREFCNT_inc (SV* sv) @@ -2093,7 +2282,7 @@ Copies an integer into a new SV, optionally blessing the SV. The C<rv> argument will be upgraded to an RV. That RV will be modified to point to the new SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV -will be returned and will have a refcount of 1. +will be returned and will have a reference count of 1. SV* sv_setref_iv _((SV *rv, char *classname, IV iv)); @@ -2103,7 +2292,7 @@ Copies a double into a new SV, optionally blessing the SV. The C<rv> argument will be upgraded to an RV. That RV will be modified to point to the new SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV -will be returned and will have a refcount of 1. +will be returned and will have a reference count of 1. SV* sv_setref_nv _((SV *rv, char *classname, double nv)); @@ -2114,7 +2303,7 @@ argument will be upgraded to an RV. That RV will be modified to point to the new SV. If the C<pv> argument is NULL then C<sv_undef> will be placed into the SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV -will be returned and will have a refcount of 1. +will be returned and will have a reference count of 1. SV* sv_setref_pv _((SV *rv, char *classname, void* pv)); @@ -2130,7 +2319,7 @@ string must be specified with C<n>. The C<rv> argument will be upgraded to an RV. That RV will be modified to point to the new SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV will be returned and will have -a refcount of 1. +a reference count of 1. SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n)); @@ -2212,9 +2401,9 @@ This is the C<undef> SV. Always refer to this as C<&sv_undef>. =item sv_unref -Unsets the RV status of the SV, and decrements the refcount of whatever was -being referenced by the RV. This can almost be thought of as a reversal of -C<newSVrv>. See C<SvROK_off>. +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C<newSVrv>. See C<SvROK_off>. void sv_unref _((SV* sv)); @@ -2396,16 +2585,16 @@ destination, C<n> is the number of items, and C<t> is the type. =back -=head1 AUTHOR +=head1 EDITOR -Jeff Okamoto E<lt>F<okamoto@corp.hp.com>E<gt> +Jeff Okamoto <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, and Spider Boardman. +Bowers, Matthew Green, Tim Bunce, Spider Boardman, and Ulrich Pfeifer. -API Listing by Dean Roehrich E<lt>F<roehrich@cray.com>E<gt>. +API Listing by Dean Roehrich <roehrich@cray.com>. =head1 DATE -Version 22: 1996/9/23 +Version 28.1: 1997/1/13 diff --git a/pod/perli18n.pod b/pod/perli18n.pod deleted file mode 100644 index 891f95ef48..0000000000 --- a/pod/perli18n.pod +++ /dev/null @@ -1,190 +0,0 @@ -=head1 NAME - -perl18n - Perl i18n (internalization) - -=head1 DESCRIPTION - -Perl supports the language-specific notions of data like -"is this a letter" and "which letter comes first". These -are very important issues especially for languages other -than English -- but also for English: it would be very -naïve indeed to think that C<A-Za-z> defines all the letters. - -Perl understands the language-specific data via the standardized -(ISO C, XPG4, POSIX 1.c) method called "the locale system". -The locale system is controlled per application using one -function call and several environment variables. - -=head1 USING LOCALES - -If your operating system supports the locale system and you have -installed the locale system and you have set your locale environment -variables correctly (please see below) before running Perl, Perl will -understand your data correctly according to your locale settings. - -In runtime you can switch locales using the POSIX::setlocale(). - - # setlocale is the function call - # LC_CTYPE will be explained later - - use POSIX qw(setlocale LC_CTYPE); - - # query and save the old locale. - $old_locale = setlocale(LC_CTYPE); - - setlocale(LC_CTYPE, "fr_CA.ISO8859-1"); - # for LC_CTYPE now in locale "French, Canada, codeset ISO 8859-1" - - setlocale(LC_CTYPE, ""); - # for LC_CTYPE now in locale what the LC_ALL / LC_CTYPE / LANG define. - # see below for documentation about the LC_ALL / LC_CTYPE / LANG. - - # restore the old locale - setlocale(LC_CTYPE, $old_locale); - -The first argument of C<setlocale()> is called B<the category> and the -second argument B<the locale>. The category tells in what aspect of data -processing we want to apply language-specific rules, the locale tells -in what language-country/territory-codeset - but read on for the naming -of the locales: not all systems name locales as in the example. - -For further information about the categories, please consult your -L<setlocale(3)> manual. For the locales available in your system, also -consult the L<setlocale(3)> manual and see whether it leads you to the -list of the available locales (search for the C<SEE ALSO> section). If -that fails, try out in command line the following commands: - -=over 12 - -=item locale -a - -=item nlsinfo - -=item ls /usr/lib/nls/loc - -=item ls /usr/lib/locale - -=item ls /usr/lib/nls - -=back - -and see whether they list something resembling these - - en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5 - en_US de_DE ru_RU - en de ru - english german russian - english.iso88591 german.iso88591 russian.iso88595 - -Sadly enough even if the calling interface has been standardized -the names of the locales are not. The naming usually is -language-country/territory-codeset but the latter parts may -not be present. Two special locales are worth special mention: - - "C" - -and - "POSIX" - -Currently and effectively these are the same locale: the difference is -mainly that the first one is defined by the C standard and the second -one is defined by the POSIX standard. What they mean and define is the -B<default locale> in which every program does start in. The language -is (American) English and the character codeset C<ASCII>. -B<NOTE>: not all systems have the C<"POSIX"> locale (not all systems -are POSIX): use the C<"C"> locale when you need the default locale. - -=head2 Category LC_CTYPE: CHARACTER TYPES - -Starting from Perl version 5.002 perl has obeyed the C<LC_CTYPE> -environment variable which controls application's notions on -which characters are alphabetic characters. This affects in -Perl the regular expression metanotation - - \w - -which stands for alphanumeric characters, that is, alphabetic and -numeric characters (please consult L<perlre> for more information -about regular expressions). Thanks to the C<LC_CTYPE>, depending on -your locale settings, characters like C<Æ>, C<É>, C<ß>, C<ø>, can be -understood as C<\w> characters. - -=head2 Category LC_COLLATE: COLLATION - -Starting from Perl version 5.003_06 perl has obeyed the B<LC_COLLATE> -environment variable which controls application's notions on the -collation (ordering) of the characters. C<B> does in most Latin -alphabets follow the C<A> but where do the C<Á> and C<Ä> belong? - -Here is a code snippet that will tell you what are the alphanumeric -characters in the current locale, in the locale order: - - perl -le 'print sort grep /\w/, map { chr() } 0..255' - -As noted above, this will work only for Perl versions 5.003_06 and up. - -B<NOTE>: in the pre-5.003_06 Perl releases the per-locale collation -was possible using the C<I18N::Collate> library module. This is now -mildly obsolete and to be avoided. The C<LC_COLLATE> functionality is -integrated into the Perl core language and one can use scalar data -completely normally -- there is no need to juggle with the scalar -references of C<I18N::Collate>. - -=head1 ENVIRONMENT - -=over 12 - -=item PERL_BADLANG - -A string that controls whether Perl warns in its startup about failed -locale settings. This can happen if the locale support in the -operating system is lacking (broken) is some way. If this string has -an integer value differing from zero, Perl will not complain. -B<NOTE>: this is just hiding the warning message: the message tells -about some problem in your system's locale support and you should -investigate what the problem is. - -=back - -The following environment variables are not specific to Perl: they are -part of the standardized (ISO C, XPG4, POSIX 1.c) setlocale method to -control an application's opinion on data. - -=over 12 - -=item LC_ALL - -C<LC_ALL> is the "override-all" locale environment variable. If it is -set, it overrides all the rest of the locale environment variables. - -=item LC_CTYPE - -C<LC_ALL> controls the classification of characters, see above. - -If this is unset and the C<LC_ALL> is set, the C<LC_ALL> is used as -the C<LC_CTYPE>. If both this and the C<LC_ALL> are unset but the C<LANG> -is set, the C<LANG> is used as the C<LC_CTYPE>. -If none of these three is set, the default locale C<"C"> -is used as the C<LC_CTYPE>. - -=item LC_COLLATE - -C<LC_ALL> controls the collation of characters, see above. - -If this is unset and the C<LC_ALL> is set, the C<LC_ALL> is used as -the C<LC_CTYPE>. If both this and the C<LC_ALL> are unset but the -C<LANG> is set, the C<LANG> is used as the C<LC_COLLATE>. -If none of these three is set, the default locale C<"C"> -is used as the C<LC_COLLATE>. - -=item LANG - -LC_ALL is the "catch-all" locale environment variable. If it is set, -it is used as the last resort if neither of the C<LC_ALL> and the -category-specific C<LC_...> are set. - -=back - -There are further locale-controlling environment variables -(C<LC_MESSAGES, LC_MONETARY, LC_NUMERIC, LC_TIME>) but Perl -B<does not> currently obey them. diff --git a/pod/perlipc.pod b/pod/perlipc.pod index ed80850541..83f3d4ba34 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -47,7 +47,7 @@ indexed by name to get the number: $i++; } -So to check whether signal 17 and SIGALRM were the same, just do this: +So to check whether signal 17 and SIGALRM were the same, do just this: print "signal #17 = $signame[17]\n"; if ($signo{ALRM}) { @@ -103,21 +103,23 @@ reasonable BSD and POSIX fashion. So you'll see defensive people writing signal handlers like this: sub REAPER { - $SIG{CHLD} = \&REAPER; # loathe sysV $waitedpid = wait; + # loathe sysV: it makes us not only reinstate + # the handler, but place it after the wait + $SIG{CHLD} = \&REAPER; } $SIG{CHLD} = \&REAPER; # now do something that forks... or even the more elaborate: - use POSIX ":wait_h"; + use POSIX ":sys_wait_h"; sub REAPER { my $child; - $SIG{CHLD} = \&REAPER; # loathe sysV while ($child = waitpid(-1,WNOHANG)) { $Kid_Status{$child} = $?; } + $SIG{CHLD} = \&REAPER; # still loathe sysV } $SIG{CHLD} = \&REAPER; # do something that forks... @@ -171,9 +173,9 @@ on the other end. For example, let's say you'd like to have your F<.signature> file be a named pipe that has a Perl program on the other end. Now every time any -program (like a mailer, newsreader, finger program, etc.) tries to read +program (like a mailer, news reader, finger program, etc.) tries to read from that file, the reading program will block and your program will -supply the the new signature. We'll use the pipe-checking file test B<-p> +supply the new signature. We'll use the pipe-checking file test B<-p> to find out whether anyone (or anything) has accidentally removed our fifo. chdir; # go home @@ -191,7 +193,7 @@ to find out whether anyone (or anything) has accidentally removed our fifo. open (FIFO, "> $FIFO") || die "can't write $FIFO: $!"; print FIFO "John Smith (smith\@host.org)\n", `fortune -s`; close FIFO; - sleep 2; # to avoid dup sigs + sleep 2; # to avoid dup signals } @@ -229,7 +231,7 @@ read from the file F<f1>, the process F<cmd1>, standard input (F<tmpfile> in this case), the F<f2> file, the F<cmd2> command, and finally the F<f3> file. Pretty nifty, eh? -You might notice that you could use backticks for much the +You might notice that you could use back-ticks for much the same effect as opening a pipe for reading: print grep { !/^(tcp|udp)/ } `netstat -an 2>&1`; @@ -248,7 +250,7 @@ exist: the open() will in all likelihood succeed (it only reflects the fork()'s success), but then your output will fail--spectacularly. Perl can't know whether the command worked because your command is actually running in a separate process whose exec() might have failed. Therefore, -while readers of bogus commands just return a quick end of file, writers +while readers of bogus commands return just a quick end of file, writers to bogus command will trigger a signal they'd better be prepared to handle. Consider: @@ -296,11 +298,11 @@ you opened whatever your kid writes to his STDOUT. Another common use for this construct is when you need to execute something without the shell's interference. With system(), it's -straightforward, but you can't use a pipe open or backticks safely. +straightforward, but you can't use a pipe open or back-ticks safely. That's because there's no way to stop the shell from getting its hands on your arguments. Instead, use lower-level control to call exec() directly. -Here's a safe backtick or pipe open for read: +Here's a safe back-tick or pipe open for read: # add error processing as above $pid = open(KID_TO_READ, "-|"); @@ -340,7 +342,7 @@ And here's a safe pipe open for writing: Note that these operations are full Unix forks, which means they may not be correctly implemented on alien systems. Additionally, these are not true -multithreading. If you'd like to learn more about threading, see the +multi-threading. If you'd like to learn more about threading, see the F<modules> file mentioned below in the SEE ALSO section. =head2 Bidirectional Communication @@ -357,7 +359,7 @@ entirely on the diagnostic message: Can't do bidirectional pipe at -e line 1. If you really want to, you can use the standard open2() library function -to catch both ends. There's also an open3() for tridirectional I/O so you +to catch both ends. There's also an open3() for tri-directional I/O so you can also catch your child's STDERR, but doing so would then require an awkward select() loop and wouldn't allow you to use normal Perl input operations. @@ -378,10 +380,10 @@ Here's an example of using open2(): print Writer "stuff\n"; $got = <Reader>; -The problem with this is that Unix buffering is going to really -ruin your day. Even though your C<Writer> filehandle is autoflushed, +The problem with this is that Unix buffering is really going to +ruin your day. Even though your C<Writer> filehandle is auto-flushed, and the process on the other end will get your data in a timely manner, -you can't usually do anything to force it to actually give it back to you +you can't usually do anything to force it to give it back to you in a similarly quick fashion. In this case, we could, because we gave I<cat> a B<-u> flag to make it unbuffered. But very few Unix commands are designed to operate over pipes, so this seldom works @@ -400,17 +402,17 @@ pseudo-ttys to make your program behave more reasonably: This way you don't have to have control over the source code of the program you're using. The F<Comm> library also has expect() -and interact() functions. Find the library (and hopefully its +and interact() functions. Find the library (and we hope its successor F<IPC::Chat>) at your nearest CPAN archive as detailed in the SEE ALSO section below. =head1 Sockets: Client/Server Communication -While not limited to Unix-derived operating systems (e.g. WinSock on PCs +While not limited to Unix-derived operating systems (e.g., WinSock on PCs provides socket support, as do some VMS libraries), you may not have sockets on your system, in which case this section probably isn't going to do -you much good. With sockets, you can do both virtual circuits (i.e. TCP -streams) and datagrams (i.e. UDP packets). You may be able to do even more +you much good. With sockets, you can do both virtual circuits (i.e., TCP +streams) and datagrams (i.e., UDP packets). You may be able to do even more depending on your system. The Perl function calls for dealing with sockets have the same names as @@ -458,7 +460,7 @@ Here's a sample TCP client using Internet-domain sockets: And here's a corresponding server to go along with it. We'll leave the address as INADDR_ANY so that the kernel can choose -the appropriate interface on multihomed hosts. If you want sit +the appropriate interface on multi-homed hosts. If you want sit on a particular interface (like the external side of a gateway or firewall machine), you should fill this in with your real address instead. @@ -474,6 +476,8 @@ instead. my $port = shift || 2345; my $proto = getprotobyname('tcp'); + $port = $1 if $port =~ /(\d+)/; # untaint port number + socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; @@ -498,7 +502,7 @@ instead. scalar localtime, "\n"; } -And here's a multithreaded version. It's multithreaded in that +And here's a multi-threaded version. It's multi-threaded in that like most typical servers, it spawns (forks) a slave server to handle the client request so that the master server can quickly go back to service a new client. @@ -529,8 +533,8 @@ go back to service a new client. my $paddr; sub REAPER { - $SIG{CHLD} = \&REAPER; # loathe sysV $waitedpid = wait; + $SIG{CHLD} = \&REAPER; # loathe sysV logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); } @@ -540,7 +544,7 @@ go back to service a new client. ($paddr = accept(Client,Server)) || $waitedpid; $waitedpid = 0, close Client) { - next if $waitedpid; + next if $waitedpid and not $paddr; my($port,$iaddr) = sockaddr_in($paddr); my $name = gethostbyaddr($iaddr,AF_INET); @@ -569,9 +573,9 @@ go back to service a new client. return; } elsif ($pid) { logmsg "begat $pid"; - return; # i'm the parent + return; # I'm the parent } - # else i'm the child -- go spawn + # else I'm the child -- go spawn open(STDIN, "<&Client") || die "can't dup client to stdin"; open(STDOUT, ">&Client") || die "can't dup client to stdout"; @@ -721,7 +725,7 @@ all, let alone in order and unmangled. Still, UDP offers some advantages over TCP, including being able to "broadcast" or "multicast" to a whole bunch of destination hosts at once (usually on your local subnet). If you find yourself overly concerned about reliability and start building checks -into your message system, then you probably should just use TCP to start +into your message system, then you probably should use just TCP to start with. Here's a UDP program similar to the sample Internet TCP client given @@ -894,7 +898,7 @@ B<-T> taint checking flag to the pound-bang line for servers: All these routines create system-specific portability problems. As noted elsewhere, Perl is at the mercy of your C libraries for much of its system behaviour. It's probably safest to assume broken SysV semantics for -signals and to stick with simple TCP and UDP socket operations; e.g. don't +signals and to stick with simple TCP and UDP socket operations; e.g., don't try to pass open file descriptors over a local UDP datagram socket if you want your code to stand a chance of being portable. @@ -913,7 +917,7 @@ Besides the obvious functions in L<perlfunc>, you should also check out the F<modules> file at your nearest CPAN site. (See L<perlmod> or best yet, the F<Perl FAQ> for a description of what CPAN is and where to get it.) Section 5 of the F<modules> file is devoted to "Networking, Device Control -(modems) and Interprocess Communication", and contains numerous unbundled +(modems), and Interprocess Communication", and contains numerous unbundled modules numerous networking modules, Chat and Expect operations, CGI programming, DCE, FTP, IPC, NNTP, Proxy, Ptty, RPC, SNMP, SMTP, Telnet, Threads, and ToolTalk--just to name a few. diff --git a/pod/perllocale.pod b/pod/perllocale.pod new file mode 100644 index 0000000000..7a48752649 --- /dev/null +++ b/pod/perllocale.pod @@ -0,0 +1,811 @@ +=head1 NAME + +perllocale - Perl locale handling (internationalization and localization) + +=head1 DESCRIPTION + +Perl supports language-specific notions of data such as "is this a +letter", "what is the upper-case equivalent of this letter", and "which +of these letters comes first". These are important issues, especially +for languages other than English - but also for English: it would be +very naE<iuml>ve to think that C<A-Za-z> defines all the "letters". Perl +is also aware that some character other than '.' may be preferred as a +decimal point, and that output date representations may be +language-specific. The process of making an application take account of +its users' preferences in such matters is called B<internationalization> +(often abbreviated as B<i18n>); telling such an application about a +particular set of preferences is known as B<localization> (B<l10n>). + +Perl can understand language-specific data via the standardized (ISO C, +XPG4, POSIX 1.c) method called "the locale system". The locale system is +controlled per application using one pragma, one function call, and +several environment variables. + +B<NOTE>: This feature is new in Perl 5.004, and does not apply unless an +application specifically requests it - see L<Backward compatibility>. +The one exception is that write() now B<always> uses the current locale +- see L<"NOTES">. + +=head1 PREPARING TO USE LOCALES + +If Perl applications are to be able to understand and present your data +correctly according a locale of your choice, B<all> of the following +must be true: + +=over 4 + +=item * + +B<Your operating system must support the locale system>. If it does, +you should find that the setlocale() function is a documented part of +its C library. + +=item * + +B<Definitions for the locales which you use must be installed>. You, or +your system administrator, must make sure that this is the case. The +available locales, the location in which they are kept, and the manner +in which they are installed, vary from system to system. Some systems +provide only a few, hard-wired, locales, and do not allow more to be +added; others allow you to add "canned" locales provided by the system +supplier; still others allow you or the system administrator to define +and add arbitrary locales. (You may have to ask your supplier to +provide canned locales which are not delivered with your operating +system.) Read your system documentation for further illumination. + +=item * + +B<Perl must believe that the locale system is supported>. If it does, +C<perl -V:d_setlocale> will say that the value for C<d_setlocale> is +C<define>. + +=back + +If you want a Perl application to process and present your data +according to a particular locale, the application code should include +the S<C<use locale>> pragma (see L<The use locale Pragma>) where +appropriate, and B<at least one> of the following must be true: + +=over 4 + +=item * + +B<The locale-determining environment variables (see L<"ENVIRONMENT">) +must be correctly set up>, either by yourself, or by the person who set +up your system account, at the time the application is started. + +=item * + +B<The application must set its own locale> using the method described in +L<The setlocale function>. + +=back + +=head1 USING LOCALES + +=head2 The use locale pragma + +By default, Perl ignores the current locale. The S<C<use locale>> +pragma tells Perl to use the current locale for some operations: + +=over 4 + +=item * + +B<The comparison operators> (C<lt>, C<le>, C<cmp>, C<ge>, and C<gt>) and +the POSIX string collation functions strcoll() and strxfrm() use +C<LC_COLLATE>. sort() is also affected if it is used without an +explicit comparison function because it uses C<cmp> by default. + +B<Note:> C<eq> and C<ne> are unaffected by the locale: they always +perform a byte-by-byte comparison of their scalar operands. What's +more, if C<cmp> finds that its operands are equal according to the +collation sequence specified by the current locale, it goes on to +perform a byte-by-byte comparison, and only returns I<0> (equal) if the +operands are bit-for-bit identical. If you really want to know whether +two strings - which C<eq> and C<cmp> may consider different - are equal +as far as collation in the locale is concerned, see the discussion in +L<Category LC_COLLATE: Collation>. + +=item * + +B<Regular expressions and case-modification functions> (uc(), lc(), +ucfirst(), and lcfirst()) use C<LC_CTYPE> + +=item * + +B<The formatting functions> (printf(), sprintf() and write()) use +C<LC_NUMERIC> + +=item * + +B<The POSIX date formatting function> (strftime()) uses C<LC_TIME>. + +=back + +C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in L<LOCALE +CATEGORIES>. + +The default behavior returns with S<C<no locale>> or on reaching the +end of the enclosing block. + +Note that the string result of any operation that uses locale +information is tainted, as it is possible for a locale to be +untrustworthy. See L<"SECURITY">. + +=head2 The setlocale function + +You can switch locales as often as you wish at run time with the +POSIX::setlocale() function: + + # This functionality not usable prior to Perl 5.004 + require 5.004; + + # Import locale-handling tool set from POSIX module. + # This example uses: setlocale -- the function call + # LC_CTYPE -- explained below + use POSIX qw(locale_h); + + # query and save the old locale + $old_locale = setlocale(LC_CTYPE); + + setlocale(LC_CTYPE, "fr_CA.ISO8859-1"); + # LC_CTYPE now in locale "French, Canada, codeset ISO 8859-1" + + setlocale(LC_CTYPE, ""); + # LC_CTYPE now reset to default defined by LC_ALL/LC_CTYPE/LANG + # environment variables. See below for documentation. + + # restore the old locale + setlocale(LC_CTYPE, $old_locale); + +The first argument of setlocale() gives the B<category>, the second the +B<locale>. The category tells in what aspect of data processing you +want to apply locale-specific rules. Category names are discussed in +L<LOCALE CATEGORIES> and L<"ENVIRONMENT">. The locale is the name of a +collection of customization information corresponding to a particular +combination of language, country or territory, and codeset. Read on for +hints on the naming of locales: not all systems name locales as in the +example. + +If no second argument is provided, the function returns a string naming +the current locale for the category. You can use this value as the +second argument in a subsequent call to setlocale(). If a second +argument is given and it corresponds to a valid locale, the locale for +the category is set to that value, and the function returns the +now-current locale value. You can use this in a subsequent call to +setlocale(). (In some implementations, the return value may sometimes +differ from the value you gave as the second argument - think of it as +an alias for the value that you gave.) + +As the example shows, if the second argument is an empty string, the +category's locale is returned to the default specified by the +corresponding environment variables. Generally, this results in a +return to the default which was in force when Perl started up: changes +to the environment made by the application after start-up may or may not +be noticed, depending on the implementation of your system's C library. + +If the second argument does not correspond to a valid locale, the locale +for the category is not changed, and the function returns I<undef>. + +For further information about the categories, consult L<setlocale(3)>. +For the locales available in your system, also consult L<setlocale(3)> +and see whether it leads you to the list of the available locales +(search for the I<SEE ALSO> section). If that fails, try the following +command lines: + + locale -a + + nlsinfo + + ls /usr/lib/nls/loc + + ls /usr/lib/locale + + ls /usr/lib/nls + +and see whether they list something resembling these + + en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5 + en_US de_DE ru_RU + en de ru + english german russian + english.iso88591 german.iso88591 russian.iso88595 + +Sadly, even though the calling interface for setlocale() has been +standardized, the names of the locales and the directories where +the configuration is, have not. The basic form of the name is +I<language_country/territory>B<.>I<codeset>, but the +latter parts are not always present. + +Two special locales are worth particular mention: "C" and "POSIX". +Currently these are effectively the same locale: the difference is +mainly that the first one is defined by the C standard and the second by +the POSIX standard. What they define is the B<default locale> in which +every program starts in the absence of locale information in its +environment. (The default default locale, if you will.) Its language +is (American) English and its character codeset ASCII. + +B<NOTE>: Not all systems have the "POSIX" locale (not all systems are +POSIX-conformant), so use "C" when you need explicitly to specify this +default locale. + +=head2 The localeconv function + +The POSIX::localeconv() function allows you to get particulars of the +locale-dependent numeric formatting information specified by the current +C<LC_NUMERIC> and C<LC_MONETARY> locales. (If you just want the name of +the current locale for a particular category, use POSIX::setlocale() +with a single parameter - see L<The setlocale function>.) + + use POSIX qw(locale_h); + + # Get a reference to a hash of locale-dependent info + $locale_values = localeconv(); + + # Output sorted list of the values + for (sort keys %$locale_values) { + printf "%-20s = %s\n", $_, $locale_values->{$_} + } + +localeconv() takes no arguments, and returns B<a reference to> a hash. +The keys of this hash are formatting variable names such as +C<decimal_point> and C<thousands_sep>; the values are the corresponding +values. See L<POSIX (3)/localeconv> for a longer example, which lists +all the categories an implementation might be expected to provide; some +provide more and others fewer, however. Note that you don't need C<use +locale>: as a function with the job of querying the locale, localeconv() +always observes the current locale. + +Here's a simple-minded example program which rewrites its command line +parameters as integers formatted correctly in the current locale: + + # See comments in previous example + require 5.004; + use POSIX qw(locale_h); + + # Get some of locale's numeric formatting parameters + my ($thousands_sep, $grouping) = + @{localeconv()}{'thousands_sep', 'grouping'}; + + # Apply defaults if values are missing + $thousands_sep = ',' unless $thousands_sep; + $grouping = 3 unless $grouping; + + # Format command line params for current locale + for (@ARGV) { + $_ = int; # Chop non-integer part + 1 while + s/(\d)(\d{$grouping}($|$thousands_sep))/$1$thousands_sep$2/; + print "$_"; + } + print "\n"; + +=head1 LOCALE CATEGORIES + +The subsections which follow describe basic locale categories. As well +as these, there are some combination categories which allow the +manipulation of more than one basic category at a time. See +L<"ENVIRONMENT"> for a discussion of these. + +=head2 Category LC_COLLATE: Collation + +When in the scope of S<C<use locale>>, Perl looks to the C<LC_COLLATE> +environment variable to determine the application's notions on the +collation (ordering) of characters. ('b' follows 'a' in Latin +alphabets, but where do 'E<aacute>' and 'E<aring>' belong?) + +Here is a code snippet that will tell you what are the alphanumeric +characters in the current locale, in the locale order: + + use locale; + print +(sort grep /\w/, map { chr() } 0..255), "\n"; + +Compare this with the characters that you see and their order if you +state explicitly that the locale should be ignored: + + no locale; + print +(sort grep /\w/, map { chr() } 0..255), "\n"; + +This machine-native collation (which is what you get unless S<C<use +locale>> has appeared earlier in the same block) must be used for +sorting raw binary data, whereas the locale-dependent collation of the +first example is useful for natural text. + +As noted in L<USING LOCALES>, C<cmp> compares according to the current +collation locale when C<use locale> is in effect, but falls back to a +byte-by-byte comparison for strings which the locale says are equal. You +can use POSIX::strcoll() if you don't want this fall-back: + + use POSIX qw(strcoll); + $equal_in_locale = + !strcoll("space and case ignored", "SpaceAndCaseIgnored"); + +$equal_in_locale will be true if the collation locale specifies a +dictionary-like ordering which ignores space characters completely, and +which folds case. Alternatively, you can use this idiom: + + use locale; + $s_a = "space and case ignored"; + $s_b = "SpaceAndCaseIgnored"; + $equal_in_locale = $s_a ge $s_b && $s_a le $s_b; + +which works because neither C<ne> nor C<ge> falls back to doing a +byte-by-byte comparison when the operands are equal according to the +locale. The idiom may be less efficient than using strcoll(), but, +unlike that function, it is not confused by strings containing embedded +nulls. + +If you have a single string which you want to check for "equality in +locale" against several others, you might think you could gain a little +efficiency by using POSIX::strxfrm() in conjunction with C<eq>: + + use POSIX qw(strxfrm); + $xfrm_string = strxfrm("Mixed-case string"); + print "locale collation ignores spaces\n" + if $xfrm_string eq strxfrm("Mixed-casestring"); + print "locale collation ignores hyphens\n" + if $xfrm_string eq strxfrm("Mixedcase string"); + print "locale collation ignores case\n" + if $xfrm_string eq strxfrm("mixed-case string"); + +strxfrm() takes a string and maps it into a transformed string for use +in byte-by-byte comparisons against other transformed strings during +collation. "Under the hood", locale-affected Perl comparison operators +call strxfrm() for both their operands, then do a byte-by-byte +comparison of the transformed strings. By calling strxfrm() explicitly, +and using a non locale-affected comparison, the example attempts to save +a couple of transformations. In fact, it doesn't save anything: Perl +magic (see L<perlguts/Magic>) creates the transformed version of a +string the first time it's needed in a comparison, then keeps it around +in case it's needed again. An example rewritten the easy way with +C<cmp> runs just about as fast. It also copes with null characters +embedded in strings; if you call strxfrm() directly, it treats the first +null it finds as a terminator. And don't expect the transformed strings +it produces to be portable across systems - or even from one revision +of your operating system to the next. In short, don't call strxfrm() +directly: let Perl do it for you. + +Note: C<use locale> isn't shown in some of these examples, as it isn't +needed: strcoll() and strxfrm() exist only to generate locale-dependent +results, and so always obey the current C<LC_COLLATE> locale. + +=head2 Category LC_CTYPE: Character Types + +When in the scope of S<C<use locale>>, Perl obeys the C<LC_CTYPE> locale +setting. This controls the application's notion of which characters are +alphabetic. This affects Perl's C<\w> regular expression metanotation, +which stands for alphanumeric characters - that is, alphabetic and +numeric characters. (Consult L<perlre> for more information about +regular expressions.) Thanks to C<LC_CTYPE>, depending on your locale +setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and +'E<oslash>' may be understood as C<\w> characters. + +The C<LC_CTYPE> locale also provides the map used in translating +characters between lower- and upper-case. This affects the case-mapping +functions - lc(), lcfirst, uc() and ucfirst(); case-mapping +interpolation with C<\l>, C<\L>, C<\u> or <\U> in double-quoted strings +and in C<s///> substitutions; and case-independent regular expression +pattern matching using the C<i> modifier. + +Finally, C<LC_CTYPE> affects the POSIX character-class test functions - +isalpha(), islower() and so on. For example, if you move from the "C" +locale to a 7-bit Scandinavian one, you may find - possibly to your +surprise - that "|" moves from the ispunct() class to isalpha(). + +B<Note:> A broken or malicious C<LC_CTYPE> locale definition may result +in clearly ineligible characters being considered to be alphanumeric by +your application. For strict matching of (unaccented) letters and +digits - for example, in command strings - locale-aware applications +should use C<\w> inside a C<no locale> block. See L<"SECURITY">. + +=head2 Category LC_NUMERIC: Numeric Formatting + +When in the scope of S<C<use locale>>, Perl obeys the C<LC_NUMERIC> +locale information, which controls application's idea of how numbers +should be formatted for human readability by the printf(), sprintf(), +and write() functions. String to numeric conversion by the +POSIX::strtod() function is also affected. In most implementations the +only effect is to change the character used for the decimal point - +perhaps from '.' to ',': these functions aren't aware of such niceties +as thousands separation and so on. (See L<The localeconv function> if +you care about these things.) + +Note that output produced by print() is B<never> affected by the +current locale: it is independent of whether C<use locale> or C<no +locale> is in effect, and corresponds to what you'd get from printf() +in the "C" locale. The same is true for Perl's internal conversions +between numeric and string formats: + + use POSIX qw(strtod); + use locale; + + $n = 5/2; # Assign numeric 2.5 to $n + + $a = " $n"; # Locale-independent conversion to string + + print "half five is $n\n"; # Locale-independent output + + printf "half five is %g\n", $n; # Locale-dependent output + + print "DECIMAL POINT IS COMMA\n" + if $n == (strtod("2,5"))[0]; # Locale-dependent conversion + +=head2 Category LC_MONETARY: Formatting of monetary amounts + +The C standard defines the C<LC_MONETARY> category, but no function that +is affected by its contents. (Those with experience of standards +committees will recognize that the working group decided to punt on the +issue.) Consequently, Perl takes no notice of it. If you really want +to use C<LC_MONETARY>, you can query its contents - see L<The localeconv +function> - and use the information that it returns in your +application's own formatting of currency amounts. However, you may well +find that the information, though voluminous and complex, does not quite +meet your requirements: currency formatting is a hard nut to crack. + +=head2 LC_TIME + +The output produced by POSIX::strftime(), which builds a formatted +human-readable date/time string, is affected by the current C<LC_TIME> +locale. Thus, in a French locale, the output produced by the C<%B> +format element (full month name) for the first month of the year would +be "janvier". Here's how to get a list of the long month names in the +current locale: + + use POSIX qw(strftime); + for (0..11) { + $long_month_name[$_] = + strftime("%B", 0, 0, 0, 1, $_, 96); + } + +Note: C<use locale> isn't needed in this example: as a function which +exists only to generate locale-dependent results, strftime() always +obeys the current C<LC_TIME> locale. + +=head2 Other categories + +The remaining locale category, C<LC_MESSAGES> (possibly supplemented by +others in particular implementations) is not currently used by Perl - +except possibly to affect the behavior of library functions called by +extensions which are not part of the standard Perl distribution. + +=head1 SECURITY + +While the main discussion of Perl security issues can be found in +L<perlsec>, a discussion of Perl's locale handling would be incomplete +if it did not draw your attention to locale-dependent security issues. +Locales - particularly on systems which allow unprivileged users to +build their own locales - are untrustworthy. A malicious (or just plain +broken) locale can make a locale-aware application give unexpected +results. Here are a few possibilities: + +=over 4 + +=item * + +Regular expression checks for safe file names or mail addresses using +C<\w> may be spoofed by an C<LC_CTYPE> locale which claims that +characters such as "E<gt>" and "|" are alphanumeric. + +=item * + +String interpolation with case-mapping, as in, say, C<$dest = +"C:\U$name.$ext">, may produce dangerous results if a bogus LC_CTYPE +case-mapping table is in effect. + +=item * + +If the decimal point character in the C<LC_NUMERIC> locale is +surreptitiously changed from a dot to a comma, C<sprintf("%g", +0.123456e3)> produces a string result of "123,456". Many people would +interpret this as one hundred and twenty-three thousand, four hundred +and fifty-six. + +=item * + +A sneaky C<LC_COLLATE> locale could result in the names of students with +"D" grades appearing ahead of those with "A"s. + +=item * + +An application which takes the trouble to use the information in +C<LC_MONETARY> may format debits as if they were credits and vice versa +if that locale has been subverted. Or it make may make payments in US +dollars instead of Hong Kong dollars. + +=item * + +The date and day names in dates formatted by strftime() could be +manipulated to advantage by a malicious user able to subvert the +C<LC_DATE> locale. ("Look - it says I wasn't in the building on +Sunday.") + +=back + +Such dangers are not peculiar to the locale system: any aspect of an +application's environment which may maliciously be modified presents +similar challenges. Similarly, they are not specific to Perl: any +programming language which allows you to write programs which take +account of their environment exposes you to these issues. + +Perl cannot protect you from all of the possibilities shown in the +examples - there is no substitute for your own vigilance - but, when +C<use locale> is in effect, Perl uses the tainting mechanism (see +L<perlsec>) to mark string results which become locale-dependent, and +which may be untrustworthy in consequence. Here is a summary of the +tainting behavior of operators and functions which may be affected by +the locale: + +=over 4 + +=item B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>): + +Scalar true/false (or less/equal/greater) result is never tainted. + +=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or <\U>) + +Result string containing interpolated material is tainted if +C<use locale> is in effect. + +=item B<Matching operator> (C<m//>): + +Scalar true/false result never tainted. + +Subpatterns, either delivered as an array-context result, or as $1 etc. +are tainted if C<use locale> is in effect, and the subpattern regular +expression contains C<\w> (to match an alphanumeric character), C<\W> +(non-alphanumeric character), C<\s> (white-space character), or C<\S> +(non white-space character). The matched pattern variable, $&, $` +(pre-match), $' (post-match), and $+ (last match) are also tainted if +C<use locale> is in effect and the regular expression contains C<\w>, +C<\W>, C<\s>, or C<\S>. + +=item B<Substitution operator> (C<s///>): + +Has the same behavior as the match operator. Also, the left +operand of C<=~> becomes tainted when C<use locale> in effect, +if it is modified as a result of a substitution based on a regular +expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of +case-mapping with C<\l>, C<\L>,C<\u> or <\U>. + +=item B<In-memory formatting function> (sprintf()): + +Result is tainted if "use locale" is in effect. + +=item B<Output formatting functions> (printf() and write()): + +Success/failure result is never tainted. + +=item B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()): + +Results are tainted if C<use locale> is in effect. + +=item B<POSIX locale-dependent functions> (localeconv(), strcoll(), +strftime(), strxfrm()): + +Results are never tainted. + +=item B<POSIX character class tests> (isalnum(), isalpha(), isdigit(), +isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(), +isxdigit()): + +True/false results are never tainted. + +=back + +Three examples illustrate locale-dependent tainting. +The first program, which ignores its locale, won't run: a value taken +directly from the command-line may not be used to name an output file +when taint checks are enabled. + + #/usr/local/bin/perl -T + # Run with taint checking + + # Command-line sanity check omitted... + $tainted_output_file = shift; + + open(F, ">$tainted_output_file") + or warn "Open of $untainted_output_file failed: $!\n"; + +The program can be made to run by "laundering" the tainted value through +a regular expression: the second example - which still ignores locale +information - runs, creating the file named on its command-line +if it can. + + #/usr/local/bin/perl -T + + $tainted_output_file = shift; + $tainted_output_file =~ m%[\w/]+%; + $untainted_output_file = $&; + + open(F, ">$untainted_output_file") + or warn "Open of $untainted_output_file failed: $!\n"; + +Compare this with a very similar program which is locale-aware: + + #/usr/local/bin/perl -T + + $tainted_output_file = shift; + use locale; + $tainted_output_file =~ m%[\w/]+%; + $localized_output_file = $&; + + open(F, ">$localized_output_file") + or warn "Open of $localized_output_file failed: $!\n"; + +This third program fails to run because $& is tainted: it is the result +of a match involving C<\w> when C<use locale> is in effect. + +=head1 ENVIRONMENT + +=over 12 + +=item PERL_BADLANG + +A string that can suppress Perl's warning about failed locale settings +at start-up. Failure can occur if the locale support in the operating +system is lacking (broken) is some way - or if you mistyped the name of +a locale when you set up your environment. If this environment variable +is absent, or has a value which does not evaluate to integer zero - that +is "0" or "" - Perl will complain about locale setting failures. + +B<NOTE>: PERL_BADLANG only gives you a way to hide the warning message. +The message tells about some problem in your system's locale support, +and you should investigate what the problem is. + +=back + +The following environment variables are not specific to Perl: They are +part of the standardized (ISO C, XPG4, POSIX 1.c) setlocale() method +for controlling an application's opinion on data. + +=over 12 + +=item LC_ALL + +C<LC_ALL> is the "override-all" locale environment variable. If it is +set, it overrides all the rest of the locale environment variables. + +=item LC_CTYPE + +In the absence of C<LC_ALL>, C<LC_CTYPE> chooses the character type +locale. In the absence of both C<LC_ALL> and C<LC_CTYPE>, C<LANG> +chooses the character type locale. + +=item LC_COLLATE + +In the absence of C<LC_ALL>, C<LC_COLLATE> chooses the collation +(sorting) locale. In the absence of both C<LC_ALL> and C<LC_COLLATE>, +C<LANG> chooses the collation locale. + +=item LC_MONETARY + +In the absence of C<LC_ALL>, C<LC_MONETARY> chooses the monetary +formatting locale. In the absence of both C<LC_ALL> and C<LC_MONETARY>, +C<LANG> chooses the monetary formatting locale. + +=item LC_NUMERIC + +In the absence of C<LC_ALL>, C<LC_NUMERIC> chooses the numeric format +locale. In the absence of both C<LC_ALL> and C<LC_NUMERIC>, C<LANG> +chooses the numeric format. + +=item LC_TIME + +In the absence of C<LC_ALL>, C<LC_TIME> chooses the date and time +formatting locale. In the absence of both C<LC_ALL> and C<LC_TIME>, +C<LANG> chooses the date and time formatting locale. + +=item LANG + +C<LANG> is the "catch-all" locale environment variable. If it is set, it +is used as the last resort after the overall C<LC_ALL> and the +category-specific C<LC_...>. + +=back + +=head1 NOTES + +=head2 Backward compatibility + +Versions of Perl prior to 5.004 B<mostly> ignored locale information, +generally behaving as if something similar to the C<"C"> locale (see +L<The setlocale function>) was always in force, even if the program +environment suggested otherwise. By default, Perl still behaves this +way so as to maintain backward compatibility. If you want a Perl +application to pay attention to locale information, you B<must> use +the S<C<use locale>> pragma (see L<The S<C<use locale>> Pragma>) to +instruct it to do so. + +Versions of Perl from 5.002 to 5.003 did use the C<LC_CTYPE> +information if that was available, that is, C<\w> did understand what +are the letters according to the locale environment variables. +The problem was that the user had no control over the feature: +if the C library supported locales, Perl used them. + +=head2 I18N:Collate obsolete + +In versions of Perl prior to 5.004 per-locale collation was possible +using the C<I18N::Collate> library module. This module is now mildly +obsolete and should be avoided in new applications. The C<LC_COLLATE> +functionality is now integrated into the Perl core language: One can +use locale-specific scalar data completely normally with C<use locale>, +so there is no longer any need to juggle with the scalar references of +C<I18N::Collate>. + +=head2 Sort speed and memory use impacts + +Comparing and sorting by locale is usually slower than the default +sorting; slow-downs of two to four times have been observed. It will +also consume more memory: once a Perl scalar variable has participated +in any string comparison or sorting operation obeying the locale +collation rules, it will take 3-15 times more memory than before. (The +exact multiplier depends on the string's contents, the operating system +and the locale.) These downsides are dictated more by the operating +system's implementation of the locale system than by Perl. + +=head2 write() and LC_NUMERIC + +Formats are the only part of Perl which unconditionally use information +from a program's locale; if a program's environment specifies an +LC_NUMERIC locale, it is always used to specify the decimal point +character in formatted output. Formatted output cannot be controlled by +C<use locale> because the pragma is tied to the block structure of the +program, and, for historical reasons, formats exist outside that block +structure. + +=head2 Freely available locale definitions + +There is a large collection of locale definitions at +C<ftp://dkuug.dk/i18n/WG15-collection>. You should be aware that it is +unsupported, and is not claimed to be fit for any purpose. If your +system allows the installation of arbitrary locales, you may find the +definitions useful as they are, or as a basis for the development of +your own locales. + +=head2 I18n and l10n + +"Internationalization" is often abbreviated as B<i18n> because its first +and last letters are separated by eighteen others. (You may guess why +the internalin ... internaliti ... i18n tends to get abbreviated.) In +the same way, "localization" is often abbreviated to B<l10n>. + +=head2 An imperfect standard + +Internationalization, as defined in the C and POSIX standards, can be +criticized as incomplete, ungainly, and having too large a granularity. +(Locales apply to a whole process, when it would arguably be more useful +to have them apply to a single thread, window group, or whatever.) They +also have a tendency, like standards groups, to divide the world into +nations, when we all know that the world can equally well be divided +into bankers, bikers, gamers, and so on. But, for now, it's the only +standard we've got. This may be construed as a bug. + +=head1 BUGS + +=head2 Broken systems + +In certain system environments the operating system's locale support +is broken and cannot be fixed or used by Perl. Such deficiencies can +and will result in mysterious hangs and/or Perl core dumps when the +C<use locale> is in effect. When confronted with such a system, +please report in excruciating detail to C<perlbug@perl.com>, and +complain to your vendor: maybe some bug fixes exist for these problems +in your operating system. Sometimes such bug fixes are called an +operating system upgrade. + +=head1 SEE ALSO + +L<POSIX (3)/isalnum>, L<POSIX (3)/isalpha>, L<POSIX (3)/isdigit>, +L<POSIX (3)/isgraph>, L<POSIX (3)/islower>, L<POSIX (3)/isprint>, +L<POSIX (3)/ispunct>, L<POSIX (3)/isspace>, L<POSIX (3)/isupper>, +L<POSIX (3)/isxdigit>, L<POSIX (3)/localeconv>, L<POSIX (3)/setlocale>, +L<POSIX (3)/strcoll>, L<POSIX (3)/strftime>, L<POSIX (3)/strtod>, +L<POSIX (3)/strxfrm> + +=head1 HISTORY + +Jarkko Hietaniemi's original F<perli18n.pod> heavily hacked by Dominic +Dunlop, assisted by the perl5-porters. + +Last update: Tue Dec 31 01:30:55 EST 1996 diff --git a/pod/perllol.pod b/pod/perllol.pod index c97aac918d..b2d5dbe537 100644 --- a/pod/perllol.pod +++ b/pod/perllol.pod @@ -27,7 +27,7 @@ a declaration of the array: Now you should be very careful that the outer bracket type is a round one, that is, parentheses. That's because you're assigning to -an @list, so you need parens. If you wanted there I<not> to be an @LoL, +an @list, so you need parentheses. If you wanted there I<not> to be an @LoL, but rather just a reference to it, you could do something more like this: # assign a reference to list of list references @@ -144,10 +144,10 @@ you'd have to do something like this: push @$ref_to_LoL, [ split ]; } -Actually, if you were using strict, you'd not only have to declare $ref_to_LoL as -you had to declare @LoL, but you'd I<also> having to initialize it to a -reference to an empty list. (This was a bug in 5.001m that's been fixed -for the 5.002 release.) +Actually, if you were using strict, you'd have to declare not only +$ref_to_LoL as you had to declare @LoL, but you'd I<also> having to +initialize it to a reference to an empty list. (This was a bug in +perl version 5.001m that's been fixed for the 5.002 release.) my $ref_to_LoL = []; while (<>) { @@ -155,7 +155,7 @@ for the 5.002 release.) } Ok, now you can add new rows. What about adding new columns? If you're -just dealing with matrices, it's often easiest to use simple assignment: +dealing with just matrices, it's often easiest to use simple assignment: for $x (1 .. 10) { for $y (1 .. 10) { @@ -171,13 +171,13 @@ It doesn't matter whether those elements are already there or not: it'll gladly create them for you, setting intervening elements to C<undef> as need be. -If you just wanted to append to a row, you'd have +If you wanted just to append to a row, you'd have to do something a bit funnier looking: # add new columns to an existing row push @{ $LoL[0] }, "wilma", "betty"; -Notice that I I<couldn't> just say: +Notice that I I<couldn't> say just: push $LoL[0], "wilma", "betty"; # WRONG! @@ -187,17 +187,17 @@ to push() must be a real array, not just a reference to such. =head1 Access and Printing Now it's time to print your data structure out. How -are you going to do that? Well, if you only want one +are you going to do that? Well, if you want only one of the elements, it's trivial: print $LoL[0][0]; If you want to print the whole thing, though, you can't -just say +say print @LoL; # WRONG -because you'll just get references listed, and perl will never +because you'll get just references listed, and perl will never automatically dereference things for you. Instead, you have to roll yourself a loop or two. This prints the whole structure, using the shell-style for() construct to loop across the outer @@ -231,7 +231,7 @@ sometimes is easier to take a temporary on your way through: } } -Hm... that's still a bit ugly. How about this: +Hmm... that's still a bit ugly. How about this: for $i ( 0 .. $#LoL ) { $aref = $LoL[$i]; @@ -266,7 +266,7 @@ That same loop could be replaced with a slice operation: but as you might well imagine, this is pretty rough on the reader. Ah, but what if you wanted a I<two-dimensional slice>, such as having -$x run from 4..8 and $y run from 7 to 12? Hm... here's the simple way: +$x run from 4..8 and $y run from 7 to 12? Hmm... here's the simple way: @newLoL = (); for ($startx = $x = 4; $x <= 8; $x++) { diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 731b25e67c..c2b1f6c961 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -13,11 +13,11 @@ Perl. The package statement declares the compilation unit as being in the given namespace. The scope of the package declaration is from the declaration itself through the end of the enclosing block (the same scope as the local() operator). All further unqualified dynamic identifiers -will be in this namespace. A package statement only affects dynamic +will be in this namespace. A package statement affects only dynamic variables--including those you've used local() on--but I<not> lexical variables created with my(). Typically it would be the first declaration in a file to be included by the C<require> or C<use> operator. You can -switch into a package in more than one place; it merely influences which +switch into a package in more than one place; it influences merely which symbol table is used by the compiler for the rest of that block. You can refer to variables and filehandles in other packages by prefixing the identifier with the package name and a double colon: @@ -39,10 +39,10 @@ It would treat package C<INNER> as a totally separate global package. Only identifiers starting with letters (or underscore) are stored in a package's symbol table. All other symbols are kept in package C<main>, including all of the punctuation variables like $_. In addition, the -identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC and SIG are +identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC, and SIG are forced to be in package C<main>, even when used for other purposes than their built-in one. Note also that, if you have a package called C<m>, -C<s> or C<y>, then you can't use the qualified form of an identifier +C<s>, or C<y>, then you can't use the qualified form of an identifier because it will be interpreted instead as a pattern match, a substitution, or a translation. @@ -62,7 +62,7 @@ temporarily switches back to the C<main> package to evaluate various expressions in the context of the C<main> package (or wherever you came from). See L<perldebug>. -See L<perlsub> for other scoping issues related to my() and local(), +See L<perlsub> for other scoping issues related to my() and local(), or L<perlref> regarding closures. =head2 Symbol Tables @@ -119,9 +119,9 @@ Assignment to a typeglob performs an aliasing operation, i.e., *dick = *richard; -causes variables, subroutines and file handles accessible via the +causes variables, subroutines, and file handles accessible via the identifier C<richard> to also be accessible via the identifier C<dick>. If -you only want to alias a particular variable or subroutine, you can +you want to alias only a particular variable or subroutine, you can assign a reference instead: *dick = \$richard; @@ -140,10 +140,10 @@ thing. # now use %hashsym normally, and you # will affect the caller's %another_hash my %nhash = (); # do what you want - return \%nhash; + return \%nhash; } -On return, the reference wil overwrite the hash slot in the +On return, the reference will overwrite the hash slot in the symbol table specified by the *some_hash typeglob. This is a somewhat tricky way of passing around references cheaply when you won't want to have to remember to dereference variables @@ -155,6 +155,25 @@ Another use of symbol tables is for making "constant" scalars. Now you cannot alter $PI, which is probably a good thing all in all. +You can say C<*foo{PACKAGE}> and C<*foo{NAME}> to find out what name and +package the *foo symbol table entry comes from. This may be useful +in a subroutine which is passed typeglobs as arguments + + sub identify_typeglob { + my $glob = shift; + print 'You gave me ', *{$glob}{PACKAGE}, '::', *{$glob}{NAME}, "\n"; + } + identify_typeglob *foo; + identify_typeglob *bar::baz; + +This prints + + You gave me main::foo + You gave me bar::baz + +The *foo{THING} notation can also be used to obtain references to the +individual elements of *foo, see L<perlref>. + =head2 Package Constructors and Destructors There are two special subroutine definitions that function as package @@ -178,7 +197,7 @@ order of definition; that is: last in, first out (LIFO). Inside an C<END> subroutine C<$?> contains the value that the script is going to pass to C<exit()>. You can modify C<$?> to change the exit -value of the script. Beware of changing C<$?> by accident (eg, by +value of the script. Beware of changing C<$?> by accident (e.g.,, by running something via C<system>). Note that when you use the B<-n> and B<-p> switches to Perl, C<BEGIN> @@ -189,7 +208,7 @@ and C<END> work just as they do in B<awk>, as a degenerate case. There is no special class syntax in Perl, but a package may function as a class if it provides subroutines that function as methods. Such a package may also derive some of its methods from another class package -by listing the other package name in its @ISA array. +by listing the other package name in its @ISA array. For more on this, see L<perlobj>. @@ -206,15 +225,18 @@ symbols. Or it can do a little of both. For example, to start a normal module called Fred, create a file called Fred.pm and put this at the start of it: - package Fred; - use Exporter (); + package Fred; + use strict; + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK); @ISA = qw(Exporter); - @EXPORT = qw(func1 func2); - @EXPORT_OK = qw($sally @listabob %harry func3); + @EXPORT = qw(&func1 &func2); + @EXPORT_OK = qw($sally @listabob %harry &func3); + use vars qw($sally @listabob %harry); Then go on to declare and use your variables in functions without any qualifications. -See L<Exporter> and the I<Perl Modules File> for details on +See L<Exporter> and the I<Perl Modules File> for details on mechanics and style issues in module creation. Perl modules are included into your program by saying @@ -259,7 +281,7 @@ instead of C<use>. With require you can get into this problem: require Cwd; # make Cwd:: accessible $here = Cwd::getcwd(); - use Cwd; # import names from Cwd:: + use Cwd; # import names from Cwd:: $here = getcwd(); require Cwd; # make Cwd:: accessible @@ -280,7 +302,7 @@ the module. If so, these will be entirely transparent to the user of the module. It is the responsibility of the F<.pm> file to load (or arrange to autoload) any additional functionality. The POSIX module happens to do both dynamic loading and autoloading, but the user can -just say C<use POSIX> to get it all. +say just C<use POSIX> to get it all. For more information on writing extension modules, see L<perlxs> and L<perlguts>. @@ -296,14 +318,14 @@ because it has a shotgun. The module and its user have a contract, part of which is common law, and part of which is "written". Part of the common law contract is that a module doesn't pollute any namespace it wasn't asked to. The -written contract for the module (AKA documentation) may make other +written contract for the module (A.K.A. documentation) may make other provisions. But then you know when you C<use RedefineTheWorld> that you're redefining the world and willing to take the consequences. =head1 THE PERL MODULE LIBRARY -A number of modules are included the the Perl distribution. These are -described below, and all end in F<.pm>. You may also discover files in +A number of modules are included the Perl distribution. These are +described below, and all end in F<.pm>. You may also discover files in the library directory that end in either F<.pl> or F<.ph>. These are old libraries supplied so that old programs that use them still run. The F<.pl> files will all eventually be converted into standard modules, and @@ -315,54 +337,74 @@ conversion, but it's just a mechanical process, so is far from bulletproof. =head2 Pragmatic Modules They work somewhat like pragmas in that they tend to affect the compilation of -your program, and thus will usually only work well when used within a -C<use>, or C<no>. These are locally scoped, so an inner BLOCK -may countermand any of these by saying +your program, and thus will usually work well only when used within a +C<use>, or C<no>. Most of these are locally scoped, so an inner BLOCK +may countermand any of these by saying: no integer; no strict 'refs'; which lasts until the end of that BLOCK. -The following programs are defined (and have their own documentation). +Unlike the pragmas that effect the C<$^H> hints variable, the C<use +vars> and C<use subs> declarations are not BLOCK-scoped. They allow +you to pre-declare a variables or subroutines within a particular +<I>file</I> rather than just a block. Such declarations are effective +for the entire file for which they were declared. You cannot rescind +them with C<no vars> or C<no subs>. + +The following pragmas are defined (and have their own documentation). =over 12 +=item blib + +manipulate @INC at compile time to use MakeMaker's uninstalled version +of a package + =item diagnostics -Pragma to produce enhanced diagnostics +force verbose warning diagnostics =item integer -Pragma to compute arithmetic in integer instead of double +compute arithmetic in integer instead of double =item less -Pragma to request less of something from the compiler +request less of something from the compiler + +=item lib + +manipulate @INC at compile time + +=item locale + +use or ignore current locale for built-in operations (see L<perllocale>) =item ops -Pragma to restrict use of unsafe opcodes +restrict named opcodes when compiling or running Perl code =item overload -Pragma for overloading operators +overload basic Perl operations =item sigtrap -Pragma to enable stack backtrace on unexpected signals +enable simple signal handling =item strict -Pragma to restrict unsafe constructs +restrict unsafe constructs =item subs -Pragma to predeclare sub names +pre-declare sub names =item vars -Pragma to predeclare global symbols +pre-declare global variable names =back @@ -390,13 +432,29 @@ split a package for autoloading benchmark running times of code +=item CPAN + +interface to Comprehensive Perl Archive Network + +=item CPAN::FirstTime + +create a CPAN configuration file + +=item CPAN::Nox + +run CPAN while avoiding compiled extensions + =item Carp warn of errors (from perspective of caller) +=item Class::Template + +struct/member template builder + =item Config -access Perl configuration option +access Perl configuration information =item Cwd @@ -404,32 +462,56 @@ get pathname of current working directory =item DB_File -Perl access to Berkeley DB +access to Berkeley DB =item Devel::SelfStubber generate stubs for a SelfLoading module +=item DirHandle + +supply object methods for directory handles + =item DynaLoader -Dynamically load C libraries into Perl code +dynamically load C libraries into Perl code =item English -use nice English (or B<awk>) names for ugly punctuation variables +use nice English (or awk) names for ugly punctuation variables =item Env -perl module that imports environment variables +import environment variables =item Exporter -provide import/export controls for Perl modules +implements default import method for modules + +=item ExtUtils::Embed + +utilities for embedding Perl in C/C++ applications + +=item ExtUtils::Install + +install files from here to there =item ExtUtils::Liblist determine libraries to use and how to use them +=item ExtUtils::MM_OS2 + +methods to override UN*X behaviour in ExtUtils::MakeMaker + +=item ExtUtils::MM_Unix + +methods used by ExtUtils::MakeMaker + +=item ExtUtils::MM_VMS + +methods to override UN*X behaviour in ExtUtils::MakeMaker + =item ExtUtils::MakeMaker create an extension Makefile @@ -442,9 +524,17 @@ utilities to write and check a MANIFEST file make a bootstrap file for use by DynaLoader -=item ExtUtils::Miniperl +=item ExtUtils::Mksymlists + +write linker options files for dynamic extension + +=item ExtUtils::testlib + +add blib/* directories to @INC -!!!GOOD QUESTION!!! +=item Fatal + +replace functions with equivalents which succeed or die =item Fcntl @@ -452,64 +542,196 @@ load the C Fcntl.h defines =item File::Basename -parse file specifications +split a pathname into pieces =item File::CheckTree run many filetest checks on a tree +=item File::Compare + +compare files or filehandles + +=item File::Copy + +copy files or filehandles + =item File::Find traverse a file tree +=item File::Path + +create or remove a series of directories + +=item File::stat + +by-name interface to Perl's built-in stat() functions + +=item FileCache + +keep more files open than the system permits + =item FileHandle supply object methods for filehandles -=item File::Path +=item FindBin -create or remove a series of directories +locate directory of original perl script + +=item GDBM_File + +access to the gdbm library =item Getopt::Long -extended getopt processing +extended processing of command line options =item Getopt::Std -Process single-character switches with switch clustering +process single-character switches with switch clustering =item I18N::Collate compare 8-bit scalar data according to the current locale +=item IO + +load various IO modules + +=item IO::File + +supply object methods for filehandles + +=item IO::Handle + +supply object methods for I/O handles + +=item IO::Pipe + +supply object methods for pipes + +=item IO::Seekable + +supply seek based methods for I/O objects + +=item IO::Select + +OO interface to the select system call + +=item IO::Socket + +object interface to socket communications + =item IPC::Open2 -a process for both reading and writing +open a process for both reading and writing =item IPC::Open3 open a process for reading, writing, and error handling +=item Math::BigFloat + +arbitrary length float math package + +=item Math::BigInt + +arbitrary size integer math package + +=item Math::Complex + +complex numbers and associated mathematical functions + +=item NDBM_File + +tied access to ndbm files + =item Net::Ping -check a host for upness +Hello, anybody home? + +=item Net::hostent + +by-name interface to Perl's built-in gethost*() functions + +=item Net::netent + +by-name interface to Perl's built-in getnet*() functions + +=item Net::protoent + +by-name interface to Perl's built-in getproto*() functions + +=item Net::servent + +by-name interface to Perl's built-in getserv*() functions + +=item Opcode + +disable named opcodes when compiling or running perl code + +=item Pod::Text + +convert POD data to formatted ASCII text =item POSIX -Perl interface to IEEE Std 1003.1 +interface to IEEE Standard 1003.1 + +=item SDBM_File + +tied access to sdbm files + +=item Safe + +compile and execute code in restricted compartments + +=item Search::Dict + +search for key in dictionary file + +=item SelectSaver + +save and restore selected file handle =item SelfLoader load functions only on demand -=item Safe +=item Shell -Creation controlled compartments in which perl code can be evaluated. +run shell commands transparently within perl =item Socket load the C socket.h defines and structure manipulators +=item Symbol + +manipulate Perl symbols and their names + +=item Sys::Hostname + +try every conceivable way to get hostname + +=item Sys::Syslog + +interface to the UNIX syslog(3) calls + +=item Term::Cap + +termcap interface + +=item Term::Complete + +word completion module + +=item Term::ReadLine + +interface to various C<readline> packages + =item Test::Harness run perl standard test scripts with statistics @@ -518,6 +740,66 @@ run perl standard test scripts with statistics create an abbreviation table from a list +=item Text::ParseWords + +parse text into an array of tokens + +=item Text::Soundex + +implementation of the Soundex Algorithm as described by Knuth + +=item Text::Tabs + +expand and unexpand tabs per the unix expand(1) and unexpand(1) + +=item Text::Wrap + +line wrapping to form simple paragraphs + +=item Tie::Hash + +base class definitions for tied hashes + +=item Tie::RefHash + +base class definitions for tied hashes with references as keys + +=item Tie::Scalar + +base class definitions for tied scalars + +=item Tie::SubstrHash + +fixed-table-size, fixed-key-length hashing + +=item Time::Local + +efficiently compute time from local and GMT time + +=item Time::gmtime + +by-name interface to Perl's built-in gmtime() function + +=item Time::localtime + +by-name interface to Perl's built-in localtime() function + +=item Time::tm + +internal object used by Time::gmtime and Time::localtime + +=item UNIVERSAL + +base class for ALL classes (blessed references) + +=item User::grent + +by-name interface to Perl's built-in getgr*() functions + +=item User::pwent + +by-name interface to Perl's built-in getpw*() functions + =back To find out I<all> the modules installed on your system, including @@ -535,7 +817,7 @@ dynamically loaded into Perl if and when you need them. Supported extension modules include the Socket, Fcntl, and POSIX modules. Many popular C extension modules do not come bundled (at least, not -completely) due to their size, volatility, or simply lack of time for +completely) due to their sizes, volatility, or simply lack of time for adequate testing and configuration across the multitude of platforms on which Perl was beta-tested. You are encouraged to look for them in archie(1L), the Perl FAQ or Meta-FAQ, the WWW page, and even with their @@ -545,13 +827,13 @@ disposition. =head1 CPAN CPAN stands for the Comprehensive Perl Archive Network. This is a globally -replicated collection of all known Perl materials, including hundreds +replicated collection of all known Perl materials, including hundreds of unbundled modules. Here are the major categories of modules: =over =item * -Language Extensions and Documentation Tools +Language Extensions and Documentation Tools =item * Development Support @@ -578,16 +860,16 @@ Interfaces to / Emulations of Other Programming Languages File Names, File Systems and File Locking (see also File Handles) =item * -String Processing, Language Text Processing, Parsing and Searching +String Processing, Language Text Processing, Parsing, and Searching =item * -Option, Argument, Parameter and Configuration File Processing +Option, Argument, Parameter, and Configuration File Processing =item * Internationalization and Locale =item * -Authentication, Security and Encryption +Authentication, Security, and Encryption =item * World Wide Web, HTML, HTTP, CGI, MIME @@ -599,7 +881,7 @@ Server and Daemon Utilities Archiving and Compression =item * -Images, Pixmap and Bitmap Manipulation, Drawing and Graphing +Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing =item * Mail and Usenet News @@ -688,15 +970,15 @@ ftp://ftp.is.co.za/programming/perl/CPAN/ =back -For an up-to-date listing of CPAN sites, +For an up-to-date listing of CPAN sites, see F<http://www.perl.com/perl/CPAN> or F<ftp://ftp.perl.com/perl/>. -=head1 Modules: Creation, Use and Abuse +=head1 Modules: Creation, Use, and Abuse (The following section is borrowed directly from Tim Bunce's modules file, available at your nearest CPAN site.) -Perl 5 implements a class using a package, but the presence of a +Perl implements a class using a package, but the presence of a package doesn't imply the presence of a class. A package is just a namespace. A class is a package that provides subroutines that can be used as methods. A method is just a subroutine that expects, as its @@ -734,9 +1016,9 @@ scheme as the original author. Use blessed references. Use the two argument form of bless to bless into the class name given as the first parameter of the constructor, -e.g.: +e.g.,: - sub new { + sub new { my $class = shift; return bless {}, $class; } @@ -744,7 +1026,7 @@ e.g.: or even this if you'd like it to be used as either a static or a virtual method. - sub new { + sub new { my $self = shift; my $class = ref($self) || $self; return bless {}, $class; @@ -811,7 +1093,7 @@ or nature of a variable. For example: $no_caps_here function scope my() or local() variables Function and method names seem to work best as all lowercase. -E.g., C<$obj-E<gt>as_string()>. +e.g.,, C<$obj-E<gt>as_string()>. You can use a leading underscore to indicate that a variable or function should not be used outside the package that defined it. @@ -829,11 +1111,11 @@ short or common names to reduce the risk of name clashes. Generally anything not exported is still accessible from outside the module using the ModuleName::item_name (or C<$blessed_ref-E<gt>method>) syntax. By convention you can use a leading underscore on names to -informally indicate that they are 'internal' and not for public use. +indicate informally that they are 'internal' and not for public use. (It is actually possible to get private functions by saying: C<my $subref = sub { ... }; &$subref;>. But there's no way to call that -directly as a method, since a method must have a name in the symbol +directly as a method, because a method must have a name in the symbol table.) As a general rule, if the module is trying to be object oriented @@ -842,12 +1124,12 @@ then export nothing. If it's just a collection of functions then =item Select a name for the module. -This name should be as descriptive, accurate and complete as +This name should be as descriptive, accurate, and complete as possible. Avoid any risk of ambiguity. Always try to use two or more whole words. Generally the name should reflect what is special about what the module does rather than how it does it. Please use -nested module names to informally group or categorise a module. -A module should have a very good reason not to have a nested name. +nested module names to group informally or categorize a module. +There should be a very good reason for a module not to have a nested name. Module names should begin with a capital letter. Having 57 modules all called Sort will not make life easy for anyone @@ -932,11 +1214,11 @@ The general mechanism is to assert your Copyright and then make a declaration of how others may copy/use/modify your work. Perl, for example, is supplied with two types of license: The GNU -GPL and The Artistic License (see the files README, Copying and +GPL and The Artistic License (see the files README, Copying, and Artistic). Larry has good reasons for NOT just using the GNU GPL. -My personal recommendation, out of respect for Larry, Perl and the -perl community at large is to simply state something like: +My personal recommendation, out of respect for Larry, Perl, and the +perl community at large is to state something simply like: Copyright (c) 1995 Your Name. All rights reserved. This program is free software; you can redistribute it and/or @@ -950,8 +1232,8 @@ Remember to include the other words in addition to the Copyright. To be fully compatible with the Exporter and MakeMaker modules you should store your module's version number in a non-my package -variable called $VERSION. This should be a valid floating point -number with at least two digits after the decimal (ie hundredths, +variable called $VERSION. This should be a floating point +number with at least two digits after the decimal (i.e., hundredths, e.g, C<$VERSION = "0.01">). Don't use a "1.3.2" style version. See Exporter.pm in Perl5.001m or later for details. @@ -968,7 +1250,7 @@ Usenet newsgroup. This will at least ensure very wide once-off distribution. If possible you should place the module into a major ftp archive and -include details of it's location in your announcement. +include details of its location in your announcement. Some notes about ftp archives: Please use a long descriptive file name which includes the version number. Most incoming directories @@ -985,10 +1267,10 @@ Follow the instructions and links on http://franz.ww.tu-berlin.de/modulelist -or upload to one of these sites: +or upload to one of these sites: ftp://franz.ww.tu-berlin.de/incoming - ftp://ftp.cis.ufl.edu/incoming + ftp://ftp.cis.ufl.edu/incoming and notify upload@franz.ww.tu-berlin.de. @@ -1079,8 +1361,7 @@ fragment of code built on top of the reusable modules. In these cases the application could invoked as: perl -e 'use Module::Name; method(@ARGV)' ... -or +or perl -mModule::Name ... (in perl5.002) =back - diff --git a/pod/perlnews.pod b/pod/perlnews.pod new file mode 100644 index 0000000000..3cd71de7d1 --- /dev/null +++ b/pod/perlnews.pod @@ -0,0 +1,666 @@ +=head1 NAME + +perlnews - what's new for perl5.004 + +=head1 DESCRIPTION + +This document describes differences between the 5.003 release (as +documented in I<Programming Perl>, second edition--the Camel Book) and +this one. + +=head1 Supported Environments + +Perl5.004 builds out of the box on Unix, Plan9, LynxOS, VMS, OS/2, +QNX, and AmigaOS. + +=head1 Core Changes + +Most importantly, many bugs were fixed. See the F<Changes> +file in the distribution for details. + +=head2 Compilation Option: Binary Compatibility With 5.003 + +There is a new Configure question that asks if you want to maintain +binary compatibility with Perl 5.003. If you choose binary +compatibility, you do not have to recompile your extensions, but you +might have symbol conflicts if you embed Perl in another application, +just as in the 5.003 release. + +=head2 New Opcode Module and Revised Safe Module + +A new Opcode module supports the creation, manipulation and +application of opcode masks. The revised Safe module has a new API +and is implemented using the new Opcode module. Please read the new +Opcode and Safe documentation. + +=head2 Internal Change: FileHandle Deprecated + +Filehandles are now stored internally as type IO::Handle. +Although C<use FileHandle> and C<*STDOUT{FILEHANDLE}> +are still supported for backwards compatibility +C<use IO::Handle> (or C<IO::Seekable> or C<IO::File>) and +C<*STDOUT{IO}> are the way of the future. + +=head2 Internal Change: PerlIO internal IO abstraction interface + +It is now possible to build Perl with AT&T's sfio IO package +instead of stdio. See L<perlapio> for more details, and +the F<INSTALL> file for how to use it. + +=head2 New and Changed Built-in Variables + +=over + +=item $^E + +Extended error message under some platforms ($EXTENDED_OS_ERROR +if you C<use English>). + +=item $^H + +The current set of syntax checks enabled by C<use strict>. See the +documentation of C<strict> for more details. Not actually new, but +newly documented. +Because it is intended for internal use by Perl core components, +there is no C<use English> long name for this variable. + +=item $^M + +By default, running out of memory it is not trappable. However, if +compiled for this, Perl may use the contents of C<$^M> as an emergency +pool after die()ing with this message. Suppose that your Perl were +compiled with -DEMERGENCY_SBRK and used Perl's malloc. Then + + $^M = 'a' x (1<<16); + +would allocate 64K buffer for use when in emergency. +See the F<INSTALL> file for information on how to enable this option. +As a disincentive to casual use of this advanced feature, +there is no C<use English> long name for this variable. + +=back + +=head2 New and Changed Built-in Functions + +=over + +=item delete on slices + +This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>) + +=item flock + +is now supported on more platforms, and prefers fcntl +to lockf when emulating. + +=item keys as an lvalue + +As an lvalue, C<keys> allows you to increase the number of hash buckets +allocated for the given associative array. This can gain you a measure +of efficiency if you know the hash is going to get big. (This is +similar to pre-extending an array by assigning a larger number to +$#array.) If you say + + keys %hash = 200; + +then C<%hash> will have at least 200 buckets allocated for it. These +buckets will be retained even if you do C<%hash = ()>; use C<undef +%hash> if you want to free the storage while C<%hash> is still in scope. +You can't shrink the number of buckets allocated for the hash using +C<keys> in this way (but you needn't worry about doing this by accident, +as trying has no effect). + +=item my() in Control Structures + +You can now use my() (with or without the parentheses) in the control +expressions of control structures such as: + + while (my $line = <>) { + $line = lc $line; + } continue { + print $line; + } + + if ((my $answer = <STDIN>) =~ /^yes$/i) { + user_agrees(); + } elsif ($answer =~ /^no$/i) { + user_disagrees(); + } else { + chomp $answer; + die "'$answer' is neither 'yes' nor 'no'"; + } + +Also, you can declare a foreach loop control variable as lexical by +preceding it with the word "my". For example, in: + + foreach my $i (1, 2, 3) { + some_function(); + } + +$i is a lexical variable, and the scope of $i extends to the end of +the loop, but not beyond it. + +Note that you still cannot use my() on global punctuation variables +such as $_ and the like. + +=item unpack() and pack() + +A new format 'w' represents a BER compressed integer (as defined in +ASN.1). Its format is a sequence of one or more bytes, each of which +provides seven bits of the total value, with the most significant +first. Bit eight of each byte is set, except for the last byte, in +which bit eight is clear. + +=item use VERSION + +If the first argument to C<use> is a number, it is treated as a version +number instead of a module name. If the version of the Perl interpreter +is less than VERSION, then an error message is printed and Perl exits +immediately. This is often useful if you need to check the current +Perl version before C<use>ing library modules which have changed in +incompatible ways from older versions of Perl. (We try not to do +this more than we have to.) + +=item use Module VERSION LIST + +If the VERSION argument is present between Module and LIST, then the +C<use> will call the VERSION method in class Module with the given +version as an argument. The default VERSION method, inherited from +the Universal class, croaks if the given version is larger than the +value of the variable $Module::VERSION. (Note that there is not a +comma after VERSION!) + +This version-checking mechanism is similar to the one currently used +in the Exporter module, but it is faster and can be used with modules +that don't use the Exporter. It is the recommended method for new +code. + +=item prototype(FUNCTION) + +Returns the prototype of a function as a string (or C<undef> if the +function has no prototype). FUNCTION is a reference to or the name of the +function whose prototype you want to retrieve. +(Not actually new; just never documented before.) + +=item $_ as Default + +Functions documented in the Camel to default to $_ now in +fact do, and all those that do are so documented in L<perlfunc>. + +=head2 C<m//g> does not trigger a pos() reset on failure + +The C<m//g> match iteration construct used to reset the iteration +when it failed to match (so that the next C<m//g> match would start at +the beginning of the string). You now have to explicitly do a +C<pos $str = 0;> to reset the "last match" position, or modify the +string in some way. This change makes it practical to chain C<m//g> +matches together in conjunction with ordinary matches using the C<\G> +zero-width assertion. See L<perlop> and L<perlre>. + +=back + +=head2 New Built-in Methods + +The C<UNIVERSAL> package automatically contains the following methods that +are inherited by all other classes: + +=over 4 + +=item isa(CLASS) + +C<isa> returns I<true> if its object is blessed into a sub-class of C<CLASS> + +C<isa> is also exportable and can be called as a sub with two arguments. This +allows the ability to check what a reference points to. Example: + + use UNIVERSAL qw(isa); + + if(isa($ref, 'ARRAY')) { + ... + } + +=item can(METHOD) + +C<can> checks to see if its object has a method called C<METHOD>, +if it does then a reference to the sub is returned; if it does not then +I<undef> is returned. + +=item VERSION( [NEED] ) + +C<VERSION> returns the version number of the class (package). If the +NEED argument is given then it will check that the current version (as +defined by the $VERSION variable in the given package) not less than +NEED; it will die if this is not the case. This method is normally +called as a class method. This method is called automatically by the +C<VERSION> form of C<use>. + + use A 1.2 qw(some imported subs); + # implies: + A->VERSION(1.2); + +=item class() + +C<class> returns the class name of its object. + +=item is_instance() + +C<is_instance> returns true if its object is an instance of some +class, false if its object is the class (package) itself. Example + + A->is_instance(); # False + + $var = 'A'; + $var->is_instance(); # False + + $ref = bless [], 'A'; + $ref->is_instance(); # True + +=back + +B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and +C<isa> uses a very similar method and cache-ing strategy. This may cause +strange effects if the Perl code dynamically changes @ISA in any package. + +You may add other methods to the UNIVERSAL class via Perl or XS code. +You do not need to C<use UNIVERSAL> in order to make these methods +available to your program. This is necessary only if you wish to +have C<isa> available as a plain subroutine in the current package. + +=head2 TIEHANDLE Now Supported + +=over + +=item TIEHANDLE classname, LIST + +This is the constructor for the class. That means it is expected to +return an object of some sort. The reference can be used to +hold some internal information. + + sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift } + +=item PRINT this, LIST + +This method will be triggered every time the tied handle is printed to. +Beyond its self reference it also expects the list that was passed to +the print function. + + sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ } + +=item READLINE this + +This method will be called when the handle is read from. The method +should return undef when there is no more data. + + sub READLINE { $r = shift; "PRINT called $$r times\n"; } + +=item DESTROY this + +As with the other types of ties, this method will be called when the +tied handle is about to be destroyed. This is useful for debugging and +possibly for cleaning up. + + sub DESTROY { print "</shout>\n" } + +=back + +=head1 Pragmata + +Three new pragmatic modules exist: + +=over + +=item use blib + +Looks for MakeMaker-like I<'blib'> directory structure starting in +I<dir> (or current directory) and working back up to five levels of +parent directories. + +Intended for use on command line with B<-M> option as a way of testing +arbitrary scripts against an uninstalled version of a package. + +=item use locale + +Tells the compiler to enable (or disable) the use of POSIX locales for +built-in operations. + +When C<use locale> is in effect, the current LC_CTYPE locale is used +for regular expressions and case mapping; LC_COLLATE for string +ordering; and LC_NUMERIC for numeric formating in printf and sprintf +(but B<not> in print). LC_NUMERIC is always used in write, since +lexical scoping of formats is problematic at best. + +Each C<use locale> or C<no locale> affects statements to the end of +the enclosing BLOCK or, if not inside a BLOCK, to the end of the +current file. Locales can be switched and queried with +POSIX::setlocale(). + +See L<perllocale> for more information. + +=item use ops + +Disable unsafe opcodes, or any named opcodes, when compiling Perl code. + +=back + +=head1 Modules + +=head2 Module Information Summary + +Brand new modules: + + IO.pm Top-level interface to IO::* classes + IO/File.pm IO::File extension Perl module + IO/Handle.pm IO::Handle extension Perl module + IO/Pipe.pm IO::Pipe extension Perl module + IO/Seekable.pm IO::Seekable extension Perl module + IO/Select.pm IO::Select extension Perl module + IO/Socket.pm IO::Socket extension Perl module + + Opcode.pm Disable named opcodes when compiling Perl code + + ExtUtils/Embed.pm Utilities for embedding Perl in C programs + ExtUtils/testlib.pm Fixes up @INC to use just-built extension + + Fatal.pm Make do-or-die equivalents of functions + FindBin.pm Find path of currently executing program + + Class/Template.pm Structure/member template builder + File/stat.pm Object-oriented wrapper around CORE::stat + Net/hostent.pm Object-oriented wrapper around CORE::gethost* + Net/netent.pm Object-oriented wrapper around CORE::getnet* + Net/protoent.pm Object-oriented wrapper around CORE::getproto* + Net/servent.pm Object-oriented wrapper around CORE::getserv* + Time/gmtime.pm Object-oriented wrapper around CORE::gmtime + Time/localtime.pm Object-oriented wrapper around CORE::localtime + Time/tm.pm Perl implementation of "struct tm" for {gm,local}time + User/grent.pm Object-oriented wrapper around CORE::getgr* + User/pwent.pm Object-oriented wrapper around CORE::getpw* + + lib/Tie/RefHash.pm Base class for tied hashes with references as keys + + UNIVERSAL.pm Base class for *ALL* classes + +=head2 IO + +The IO module provides a simple mechanism to load all of the IO modules at one +go. Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its +respective documentation. + +=head2 Math::Complex + +The Math::Complex module has been totally rewritten, and now supports +more operations. These are overloaded: + + + - * / ** <=> neg ~ abs sqrt exp log sin cos atan2 "" (stringify) + +And these functions are now exported: + + pi i Re Im arg + log10 logn cbrt root + tan cotan asin acos atan acotan + sinh cosh tanh cotanh asinh acosh atanh acotanh + cplx cplxe + +=head2 Overridden Built-ins + +Many of the Perl built-ins returning lists now have +object-oriented overrides. These are: + + File::stat + Net::hostent + Net::netent + Net::protoent + Net::servent + Time::gmtime + Time::localtime + User::grent + User::pwent + +For example, you can now say + + use File::stat; + use User::pwent; + $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid); + +=head1 Efficiency Enhancements + +All hash keys with the same string are only allocated once, so +even if you have 100 copies of the same hash, the immutable keys +never have to be re-allocated. + +Functions that have an empty prototype and that do nothing but return +a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). + +=head1 Documentation Changes + +Many of the base and library pods were updated. These +new pods are included in section 1: + +=over 4 + +=item L<perlnews> + +This document. + +=item L<perllocale> + +Locale support (internationalization and localization). + +=item L<perltoot> + +Tutorial on Perl OO programming. + +=item L<perlapio> + +Perl internal IO abstraction interface. + +=item L<perldebug> + +Although not new, this has been massively updated. + +=item L<perlsec> + +Although not new, this has been massively updated. + +=back + +=head1 New Diagnostics + +Several new conditions will trigger warnings that were +silent before. Some only affect certain platforms. +The following new warnings and errors +outline these: + +=over 4 + +=item "my" variable %s masks earlier declaration in same scope + +(S) A lexical variable has been redeclared in the same scope, effectively +eliminating all access to the previous instance. This is almost always +a typographical error. Note that the earlier variable will still exist +until the end of the scope or until all closure referents to it are +destroyed. + +=item Allocation too large: %lx + +(X) You can't allocate more than 64K on an MSDOS machine. + +=item Allocation too large + +(F) You can't allocate more than 2^31+"small amount" bytes. + +=item Attempt to free non-existent shared string + +(P) Perl maintains a reference counted internal table of strings to +optimize the storage and access of hash keys and other strings. This +indicates someone tried to decrement the reference count of a string +that can no longer be found in the table. + +=item Attempt to use reference as lvalue in substr + +(W) You supplied a reference as the first argument to substr() used +as an lvalue, which is pretty strange. Perhaps you forgot to +dereference it first. See L<perlfunc/substr>. + +=item Unsupported function fork + +(F) Your version of executable does not support forking. + +Note that under some systems, like OS/2, there may be different flavors of +Perl executables, some of which may support fork, some not. Try changing +the name you call Perl by to C<perl_>, C<perl__>, and so on. + +=item Ill-formed logical name |%s| in prime_env_iter + +(W) A warning peculiar to VMS. A logical name was encountered when preparing +to iterate over %ENV which violates the syntactic rules governing logical +names. Since it cannot be translated normally, it is skipped, and will not +appear in %ENV. This may be a benign occurrence, as some software packages +might directly modify logical name tables and introduce non-standard names, +or it may indicate that a logical name table has been corrupted. + +=item Integer overflow in hex number + +(S) The literal hex number you have specified is too big for your +architecture. On a 32-bit architecture the largest hex literal is +0xFFFFFFFF. + +=item Integer overflow in octal number + +(S) The literal octal number you have specified is too big for your +architecture. On a 32-bit architecture the largest octal literal is +037777777777. + +=item Null picture in formline + +(F) The first argument to formline must be a valid format picture +specification. It was found to be empty, which probably means you +supplied it an uninitialized value. See L<perlform>. + +=item Offset outside string + +(F) You tried to do a read/write/send/recv operation with an offset +pointing outside the buffer. This is difficult to imagine. +The sole exception to this is that C<sysread()>ing past the buffer +will extend the buffer and zero pad the new area. + +=item Out of memory! + +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +The request was judged to be small, so the possibility to trap it +depends on the way Perl was compiled. By default it is not trappable. +However, if compiled for this, Perl may use the contents of C<$^M> as +an emergency pool after die()ing with this message. In this case the +error is trappable I<once>. + +=item Out of memory during request for %s + +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so +a possibility to shut down by trapping this error is granted. + +=item Possible attempt to put comments in qw() list + +(W) You probably wrote something like this: + + qw( a # a comment + b # another comment + ) ; + +when you should have written this: + + qw( a + b + ) ; + +=item Possible attempt to separate words with commas + +(W) You probably wrote something like this: + + qw( a, b, c ); + +when you should have written this: + + qw( a b c ); + +=item untie attempted while %d inner references still exist + +(W) A copy of the object returned from C<tie> (or C<tied>) was still +valid when C<untie> was called. + +=item Got an error from DosAllocMem: + +(P) An error peculiar to OS/2. Most probably you use an obsolete version +of Perl, and should not happen anyway. + +=item Malformed PERLLIB_PREFIX + +(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form + + prefix1;prefix2 + +or + + prefix1 prefix2 + +with non-empty prefix1 and prefix2. If C<prefix1> is indeed a prefix of +a builtin library search path, prefix2 is substituted. The error may appear +if components are not found, or are too long. See L<perlos2/"PERLLIB_PREFIX">. + +=item PERL_SH_DIR too long + +(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the +C<sh>-shell in. See L<perlos2/"PERL_SH_DIR">. + +=item Process terminated by SIG%s + +(W) This is a standard message issued by OS/2 applications, while *nix +applications die in silence. It is considered a feature of the OS/2 +port. One can easily disable this by appropriate sighandlers, see +L<perlipc/"Signals">. See L<perlos2/"Process terminated by SIGTERM/SIGINT">. + +=back + +=head1 BUGS + +If you find what you think is a bug, you might check the headers +of recently posted articles +in the comp.lang.perl.misc newsgroup. There may also be +information at http://www.perl.com/perl/, the Perl Home Page. + +If you believe you have an unreported bug, please run the B<perlbug> +program included with your release. Make sure you trim your bug +down to a tiny but sufficient test case. Your bug report, along +with the output of C<perl -V>, will be sent off to perlbug@perl.com +to be analysed by the Perl porting team. + +=head1 SEE ALSO + +The F<Changes> file for exhaustive details on what changed. + +The F<INSTALL> file for how to build Perl. This file has been +significantly updated for 5.004, so even veteran users should +look through it. + +The F<README> file for general stuff. + +The F<Copying> file for copyright information. + +=head1 HISTORY + +Constructed by Tom Christiansen, grabbing material with permission +from innumerable contributors, with kibitzing by more than a few Perl +porters. + +Last update: Tue Jan 14 14:03:02 EST 1997 diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 54e052ff45..9b1ede111f 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -4,10 +4,13 @@ perlobj - Perl objects =head1 DESCRIPTION -First of all, you need to understand what references are in Perl. See -L<perlref> for that. +First of all, you need to understand what references are in Perl. +See L<perlref> for that. Second, if you still find the following +reference work too complicated, a tutorial on object-oriented programming +in Perl can be found in L<perltoot>. -Here are three very simple definitions that you should find reassuring. +If you're still with us, then +here are three very simple definitions that you should find reassuring. =over 4 @@ -24,7 +27,7 @@ with object references. =item 3. A method is simply a subroutine that expects an object reference (or -a package name, for static methods) as the first argument. +a package name, for class methods) as the first argument. =back @@ -44,7 +47,7 @@ constructor: The C<{}> constructs a reference to an anonymous hash containing no key/value pairs. The bless() takes that reference and tells the object it references that it's now a Critter, and returns the reference. -This is for convenience, since the referenced object itself knows that +This is for convenience, because the referenced object itself knows that it has been blessed, and its reference to it could have been returned directly, like this: @@ -65,7 +68,7 @@ that wish to call methods in the class as part of the construction: } If you care about inheritance (and you should; see -L<perlmod/"Modules: Creation, Use and Abuse">), +L<perlmod/"Modules: Creation, Use, and Abuse">), then you want to use the two-arg form of bless so that your constructors may be inherited: @@ -94,17 +97,17 @@ object into: Within the class package, the methods will typically deal with the reference as an ordinary reference. Outside the class package, the reference is generally treated as an opaque value that may -only be accessed through the class's methods. +be accessed only through the class's methods. A constructor may re-bless a referenced object currently belonging to another class, but then the new class is responsible for all cleanup -later. The previous blessing is forgotten, as an object may only -belong to one class at a time. (Although of course it's free to +later. The previous blessing is forgotten, as an object may belong +to only one class at a time. (Although of course it's free to inherit methods from many classes.) A clarification: Perl objects are blessed. References are not. Objects know which package they belong to. References do not. The bless() -function simply uses the reference in order to find the object. Consider +function uses the reference to find the object. Consider the following example: $a = {}; @@ -118,7 +121,7 @@ operated on the object and not on the reference. =head2 A Class is Simply a Package Unlike say C++, Perl doesn't provide any special syntax for class -definitions. You just use a package as a class by putting method +definitions. You use a package as a class by putting method definitions into the class. There is a special array within each package called @ISA which says @@ -143,7 +146,7 @@ supplied in the UNIVERSAL class; see L<"Default UNIVERSAL methods"> for more details.) If that doesn't work, Perl finally gives up and complains. -Perl classes only do method inheritance. Data inheritance is left +Perl classes do only method inheritance. Data inheritance is left up to the class itself. By and large, this is not a problem in Perl, because most classes model the attributes of their object using an anonymous hash, which serves as its own little namespace to be @@ -156,17 +159,18 @@ Unlike say C++, Perl doesn't provide any special syntax for method definition. (It does provide a little syntax for method invocation though. More on that later.) A method expects its first argument to be the object or package it is being invoked on. There are just two -types of methods, which we'll call static and virtual, in honor of -the two C++ method types they most closely resemble. +types of methods, which we'll call class and instance. +(Sometimes you'll hear these called static and virtual, in honor of +the two C++ method types they most closely resemble.) -A static method expects a class name as the first argument. It +A class method expects a class name as the first argument. It provides functionality for the class as a whole, not for any individual -object belonging to the class. Constructors are typically static -methods. Many static methods simply ignore their first argument, since +object belonging to the class. Constructors are typically class +methods. Many class methods simply ignore their first argument, because they already know what package they're in, and don't care what package -they were invoked via. (These aren't necessarily the same, since -static methods follow the inheritance tree just like ordinary virtual -methods.) Another typical use for static methods is to look up an +they were invoked via. (These aren't necessarily the same, because +class methods follow the inheritance tree just like ordinary instance +methods.) Another typical use for class methods is to look up an object by name: sub find { @@ -174,7 +178,7 @@ object by name: $objtable{$name}; } -A virtual method expects an object reference as its first argument. +An instance method expects an object reference as its first argument. Typically it shifts the first argument into a "self" or "this" variable, and then uses that as an ordinary reference. @@ -194,9 +198,9 @@ already had an "indirect object" syntax that you use when you say print STDERR "help!!!\n"; -This same syntax can be used to call either static or virtual methods. -We'll use the two methods defined above, the static method to lookup -an object reference and the virtual method to print out its attributes. +This same syntax can be used to call either class or instance methods. +We'll use the two methods defined above, the class method to lookup +an object reference and the instance method to print out its attributes. $fred = find Critter "Fred"; display $fred 'Height', 'Weight'; @@ -223,7 +227,7 @@ Indirect object method calls are parsed using the same rule as list operators: "If it looks like a function, it is a function". (Presuming for the moment that you think two words in a row can look like a function name. C++ programmers seem to think so with some regularity, -especially when the first word is "new".) Thus, the parens of +especially when the first word is "new".) Thus, the parentheses of new Critter ('Barney', 1.5, 70) @@ -245,8 +249,8 @@ call, being sure to pass the requisite first argument explicitly: $fred = MyCritter::find("Critter", "Fred"); MyCritter::display($fred, 'Height', 'Weight'); -Note however, that this does not do any inheritance. If you merely -wish to specify that Perl should I<START> looking for a method in a +Note however, that this does not do any inheritance. If you wish +merely to specify that Perl should I<START> looking for a method in a particular package, use an ordinary method call, but qualify the method name with the package like this: @@ -254,13 +258,13 @@ name with the package like this: $fred->MyCritter::display('Height', 'Weight'); If you're trying to control where the method search begins I<and> you're -executing in the class itself, then you may use the SUPER pseudoclass, +executing in the class itself, then you may use the SUPER pseudo class, which says to start looking in your base class's @ISA list without having -to explicitly name it: +to name it explicitly: $self->SUPER::display('Height', 'Weight'); -Please note that the C<SUPER::> construct is I<only> meaningful within the +Please note that the C<SUPER::> construct is meaningful I<only> within the class. Sometimes you want to call a method when you don't know the method name @@ -277,7 +281,7 @@ are inherited by all other classes: =over 4 -=item isa ( CLASS ) +=item isa(CLASS) C<isa> returns I<true> if its object is blessed into a sub-class of C<CLASS> @@ -290,30 +294,30 @@ allows the ability to check what a reference points to. Example ... } -=item can ( METHOD ) +=item can(METHOD) C<can> checks to see if its object has a method called C<METHOD>, if it does then a reference to the sub is returned, if it does not then I<undef> is returned. -=item VERSION ( [ VERSION ] ) - -C<VERSION> returns the VERSION number of the class (package). If -an argument is given then it will check that the current version is not -less that the given argument. This method is normally called as a static -method. This method is also called when the C<VERSION> form of C<use> is -used. +=item VERSION( [NEED] ) +C<VERSION> returns the version number of the class (package). If the +NEED argument is given then it will check that the current version (as +defined by the $VERSION variable in the given package) not less than +NEED; it will die if this is not the case. This method is normally +called as a class method. This method is called automatically by the +C<VERSION> form of C<use>. use A 1.2 qw(some imported subs); - - A->require_version( 1.2 ); + # implies: + A->VERSION(1.2); -=item class () +=item class() C<class> returns the class name of its object. -=item is_instance () +=item is_instance() C<is_instance> returns true if its object is an instance of some class, false if its object is the class (package) itself. Example @@ -333,6 +337,9 @@ C<isa> uses a very similar method and cache-ing strategy. This may cause strange effects if the Perl code dynamically changes @ISA in any package. You may add other methods to the UNIVERSAL class via Perl or XS code. +You do not need to C<use UNIVERSAL> in order to make these methods +available to your program. This is necessary only if you wish to +have C<isa> available as a plain subroutine in the current package. =head2 Destructors @@ -344,9 +351,9 @@ your class. It will automatically be called at the appropriate moment, and you can do any extra cleanup you need to do. Perl doesn't do nested destruction for you. If your constructor -reblessed a reference from one of your base classes, your DESTROY may -need to call DESTROY for any base classes that need it. But this only -applies to reblessed objects--an object reference that is merely +re-blessed a reference from one of your base classes, your DESTROY may +need to call DESTROY for any base classes that need it. But this applies +to only re-blessed objects--an object reference that is merely I<CONTAINED> in the current object will be freed and destroyed automatically when the current object is freed. @@ -367,7 +374,7 @@ are equivalent, but AB and CD are different: =head2 Summary -That's about all there is to it. Now you just need to go off and buy a +That's about all there is to it. Now you need just to go off and buy a book about object-oriented design methodology, and bang your forehead with it for the next six months or so. @@ -413,7 +420,7 @@ When an interpreter thread finally shuts down (usually when your program exits), then a rather costly but complete mark-and-sweep style of garbage collection is performed, and everything allocated by that thread gets destroyed. This is essential to support Perl as an embedded or a -multithreadable language. For example, this program demonstrates Perl's +multi-threadable language. For example, this program demonstrates Perl's two-phased garbage collection: #!/usr/bin/perl @@ -462,7 +469,7 @@ garbage collector reaching the unreachable. Objects are always destructed, even when regular refs aren't and in fact are destructed in a separate pass before ordinary refs just to try to prevent object destructors from using refs that have been themselves -destructed. Plain refs are only garbage collected if the destruct level +destructed. Plain refs are only garbage-collected if the destruct level is greater than 0. You can test the higher levels of global destruction by setting the PERL_DESTRUCT_LEVEL environment variable, presuming C<-DDEBUGGING> was enabled during perl build time. @@ -472,6 +479,8 @@ at a future date. =head1 SEE ALSO +A kinder, gentler tutorial on object-oriented programming in Perl can +be found in L<perltoot>. You should also check out L<perlbot> for other object tricks, traps, and tips, as well as L<perlmod> for some style guides on constructing both modules and classes. diff --git a/pod/perlop.pod b/pod/perlop.pod index 4752148dbe..dd3aeab663 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -43,7 +43,7 @@ In the following sections, these operators are covered in precedence order. =head2 Terms and List Operators (Leftward) Any TERM is of highest precedence of Perl. These includes variables, -quote and quotelike operators, any expression in parentheses, +quote and quote-like operators, any expression in parentheses, and any function whose arguments are parenthesized. Actually, there aren't really functions in this sense, just list operators and unary operators behaving as functions because you put parentheses around @@ -66,7 +66,7 @@ the commas on the right of the sort are evaluated before the sort, but the commas on the left are evaluated after. In other words, list operators tend to gobble up all the arguments that follow them, and then act like a simple TERM with regard to the preceding expression. -Note that you have to be careful with parens: +Note that you have to be careful with parentheses: # These evaluate exit before doing the print: print($foo, exit); # Obviously not what you want. @@ -88,7 +88,7 @@ Also parsed as terms are the C<do {}> and C<eval {}> constructs, as well as subroutine and method calls, and the anonymous constructors C<[]> and C<{}>. -See also L<Quote and Quotelike Operators> toward the end of this section, +See also L<Quote and Quote-Like Operators> toward the end of this section, as well as L<"I/O Operators">. =head2 The Arrow Operator @@ -104,16 +104,16 @@ containing the method name, and the left side must either be an object (a blessed reference) or a class name (that is, a package name). See L<perlobj>. -=head2 Autoincrement and Autodecrement +=head2 Auto-increment and Auto-decrement "++" and "--" work as in C. That is, if placed before a variable, they increment or decrement the variable before returning the value, and if placed after, increment or decrement the variable after returning the value. -The autoincrement operator has a little extra built-in magic to it. If +The auto-increment operator has a little extra built-in magic to it. If you increment a variable that is numeric, or that has ever been used in a numeric context, you get a normal increment. If, however, the -variable has only been used in string contexts since it was set, and +variable has been used in only string contexts since it was set, and has a value that is not null and matches the pattern C</^[a-zA-Z]*[0-9]*$/>, the increment is done as a string, preserving each character within its range, with carry: @@ -123,7 +123,7 @@ character within its range, with carry: print ++($foo = 'Az'); # prints 'Ba' print ++($foo = 'zz'); # prints 'aaa' -The autodecrement operator is not magical. +The auto-decrement operator is not magical. =head2 Exponentiation @@ -134,7 +134,7 @@ internally.) =head2 Symbolic Unary Operators -Unary "!" performs logical negation, i.e. "not". See also C<not> for a lower +Unary "!" performs logical negation, i.e., "not". See also C<not> for a lower precedence version of this. Unary "-" performs arithmetic negation if the operand is numeric. If @@ -144,7 +144,8 @@ starts with a plus or minus, a string starting with the opposite sign is returned. One effect of these rules is that C<-bareword> is equivalent to C<"-bareword">. -Unary "~" performs bitwise negation, i.e. 1's complement. +Unary "~" performs bitwise negation, i.e., 1's complement. +(See also L<Integer Arithmetic>.) Unary "+" has no effect whatsoever, even on strings. It is useful syntactically for separating a function name from a parenthesized expression @@ -166,7 +167,7 @@ supposed to be searched, substituted, or translated instead of the default $_. The return value indicates the success of the operation. (If the right argument is an expression rather than a search pattern, substitution, or translation, it is interpreted as a search pattern at run -time. This is less efficient than an explicit search, since the pattern +time. This is less efficient than an explicit search, because the pattern must be compiled every time the expression is evaluated--unless you've used C</o>.) @@ -184,7 +185,7 @@ Binary "%" computes the modulus of the two numbers. Binary "x" is the repetition operator. In a scalar context, it returns a string consisting of the left operand repeated the number of times specified by the right operand. In a list context, if the left -operand is a list in parens, it repeats the list. +operand is a list in parentheses, it repeats the list. print '-' x 80; # print row of dashes @@ -204,13 +205,13 @@ Binary "." concatenates two strings. =head2 Shift Operators -Binary "E<lt>E<lt>" returns the value of its left argument shifted left by the -number of bits specified by the right argument. Arguments should be -integers. +Binary "<<" returns the value of its left argument shifted left by the +number of bits specified by the right argument. Arguments should be +integers. (See also L<Integer Arithmetic>.) -Binary "E<gt>E<gt>" returns the value of its left argument shifted right by the -number of bits specified by the right argument. Arguments should be -integers. +Binary ">>" returns the value of its left argument shifted right by +the number of bits specified by the right argument. Arguments should +be integers. (See also L<Integer Arithmetic>.) =head2 Named Unary Operators @@ -289,15 +290,21 @@ to the right argument. Binary "cmp" returns -1, 0, or 1 depending on whether the left argument is stringwise less than, equal to, or greater than the right argument. +"lt", "le", "ge", "gt" and "cmp" use the collation (sort) order specified +by the current locale if C<use locale> is in effect. See L<perllocale>. + =head2 Bitwise And Binary "&" returns its operators ANDed together bit by bit. +(See also L<Integer Arithmetic>.) =head2 Bitwise Or and Exclusive Or Binary "|" returns its operators ORed together bit by bit. +(See also L<Integer Arithmetic>.) Binary "^" returns its operators XORed together bit by bit. +(See also L<Integer Arithmetic>.) =head2 C-style Logical And @@ -385,7 +392,7 @@ As a list operator: @foo = @foo[$#foo-4 .. $#foo]; # slice last 5 items The range operator (in a list context) makes use of the magical -autoincrement algorithm if the operands are strings. You +auto-increment algorithm if the operands are strings. You can say @alphabet = ('A' .. 'Z'); @@ -502,14 +509,14 @@ It's the equivalent of "!" except for the very low precedence. Binary "and" returns the logical conjunction of the two surrounding expressions. It's equivalent to && except for the very low -precedence. This means that it short-circuits: i.e. the right +precedence. This means that it short-circuits: i.e., the right expression is evaluated only if the left expression is true. =head2 Logical or and Exclusive Or Binary "or" returns the logical disjunction of the two surrounding expressions. It's equivalent to || except for the very low -precedence. This means that it short-circuits: i.e. the right +precedence. This means that it short-circuits: i.e., the right expression is evaluated only if the left expression is false. Binary "xor" returns the exclusive-OR of the two surrounding expressions. @@ -536,7 +543,7 @@ Type casting operator. =back -=head2 Quote and Quotelike Operators +=head2 Quote and Quote-like Operators While we usually think of quotes as literal values, in Perl they function as operators, providing various kinds of interpolating and @@ -576,6 +583,9 @@ are interpolated, as are the following sequences: \E end case modification \Q quote regexp metacharacters till \E +If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> +and <\U> is taken from the current locale. See L<perllocale>. + Patterns are subject to an additional level of interpretation as a regular expression. This is done as a second pass, after variables are interpolated, so that regular expressions may be incorporated into the @@ -583,13 +593,13 @@ pattern from the variables. If this is not what you want, use C<\Q> to interpolate a variable literally. Apart from the above, there are no multiple levels of interpolation. In -particular, contrary to the expectations of shell programmers, backquotes +particular, contrary to the expectations of shell programmers, back-quotes do I<NOT> interpolate within double quotes, nor do single quotes impede evaluation of variables when used within double quotes. -=head2 Regexp Quotelike Operators +=head2 Regexp Quote-Like Operators -Here are the quotelike operators that apply to pattern +Here are the quote-like operators that apply to pattern matching and related activities. =over 8 @@ -598,7 +608,7 @@ matching and related activities. This is just like the C</pattern/> search, except that it matches only once between calls to the reset() operator. This is a useful -optimization when you only want to see the first occurrence of +optimization when you want to see only the first occurrence of something in each file of a set of files, for instance. Only C<??> patterns local to the current package are reset. @@ -615,13 +625,15 @@ C<!~> operator, the $_ string is searched. (The string specified with C<=~> need not be an lvalue--it may be the result of an expression evaluation, but remember the C<=~> binds rather tightly.) See also L<perlre>. +See L<perllocale> for discussion of additional considerations which apply +when C<use locale> is in effect. Options are: - g Match globally, i.e. find all occurrences. + g Match globally, i.e., find all occurrences. i Do case-insensitive pattern matching. m Treat string as multiple lines. - o Only compile pattern once. + o Compile pattern only once. s Treat string as single line. x Use extended regular expressions. @@ -645,7 +657,7 @@ successfully executed regular expression is used instead. If used in a context that requires a list value, a pattern match returns a list consisting of the subexpressions matched by the parentheses in the -pattern, i.e. (C<$1>, $2, $3...). (Note that here $1 etc. are also set, and +pattern, i.e., (C<$1>, $2, $3...). (Note that here $1 etc. are also set, and that this differs from Perl 4's behavior.) If the match fails, a null array is returned. If the match succeeds, but there were no parentheses, a list value of (1) is returned. @@ -668,8 +680,8 @@ Examples: if (($F1, $F2, $Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) This last example splits $foo into the first two words and the -remainder of the line, and assigns those three fields to $F1, $F2 and -$Etc. The conditional is true if any variables were assigned, i.e. if +remainder of the line, and assigns those three fields to $F1, $F2, and +$Etc. The conditional is true if any variables were assigned, i.e., if the pattern matched. The C</g> modifier specifies global pattern matching--that is, matching @@ -683,7 +695,10 @@ In a scalar context, C<m//g> iterates through the string, returning TRUE each time it matches, and FALSE when it eventually runs out of matches. (In other words, it remembers where it left off last time and restarts the search at that point. You can actually find the current -match position of a string using the pos() function--see L<perlfunc>.) +match position of a string or set it using the pos() function--see +L<perlfunc/pos>.) Note that you can use this feature to stack C<m//g> +matches or intermix C<m//g> matches with C<m/\G.../>. + If you modify the string in any way, the match position is reset to the beginning. Examples: @@ -691,7 +706,7 @@ beginning. Examples: ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); # scalar context - $/ = ""; $* = 1; # $* deprecated in Perl 5 + $/ = ""; $* = 1; # $* deprecated in modern perls while ($paragraph = <>) { while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { $sentences++; @@ -699,6 +714,30 @@ beginning. Examples: } print "$sentences\n"; + # using m//g with \G + $_ = "ppooqppq"; + while ($i++ < 2) { + print "1: '"; + print $1 while /(o)/g; print "', pos=", pos, "\n"; + print "2: '"; + print $1 if /\G(q)/; print "', pos=", pos, "\n"; + print "3: '"; + print $1 while /(p)/g; print "', pos=", pos, "\n"; + } + +The last example should print: + + 1: 'oo', pos=4 + 2: 'q', pos=4 + 3: 'pp', pos=7 + 1: '', pos=7 + 2: 'q', pos=7 + 3: '', pos=7 + +Note how C<m//g> matches change the value reported by C<pos()>, but the +non-global match doesn't. + + =item q/STRING/ =item C<'STRING'> @@ -755,34 +794,36 @@ made. Otherwise it returns false (specifically, the empty string). If no string is specified via the C<=~> or C<!~> operator, the C<$_> variable is searched and modified. (The string specified with C<=~> must be a scalar variable, an array element, a hash element, or an assignment -to one of those, i.e. an lvalue.) +to one of those, i.e., an lvalue.) If the delimiter chosen is single quote, no variable interpolation is done on either the PATTERN or the REPLACEMENT. Otherwise, if the PATTERN contains a $ that looks like a variable rather than an end-of-string test, the variable will be interpolated into the pattern -at run-time. If you only want the pattern compiled once the first time +at run-time. If you want the pattern compiled only once the first time the variable is interpolated, use the C</o> option. If the pattern evaluates to a null string, the last successfully executed regular expression is used instead. See L<perlre> for further explanation on these. +See L<perllocale> for discussion of additional considerations which apply +when C<use locale> is in effect. Options are: e Evaluate the right side as an expression. - g Replace globally, i.e. all occurrences. + g Replace globally, i.e., all occurrences. i Do case-insensitive pattern matching. m Treat string as multiple lines. - o Only compile pattern once. + o Compile pattern only once. s Treat string as single line. x Use extended regular expressions. Any non-alphanumeric, non-whitespace delimiter may replace the slashes. If single quotes are used, no interpretation is done on the replacement string (the C</e> modifier overrides this, however). Unlike -Perl 4, Perl 5 treats backticks as normal delimiters; the replacement +Perl 4, Perl 5 treats back-ticks as normal delimiters; the replacement text is not evaluated as a command. If the PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own -pair of quotes, which may or may not be bracketing quotes, e.g. +pair of quotes, which may or may not be bracketing quotes, e.g., C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the replacement portion to be interpreter as a full-fledged Perl expression and eval()ed right then and there. It is, however, syntax checked at @@ -825,10 +866,10 @@ Examples: s/([^ ]*) *([^ ]*)/$2 $1/; # reverse 1st two fields Note the use of $ instead of \ in the last example. Unlike -B<sed>, we only use the \E<lt>I<digit>E<gt> form in the left hand side. +B<sed>, we use the \E<lt>I<digit>E<gt> form in only the left hand side. Anywhere else it's $E<lt>I<digit>E<gt>. -Occasionally, you can't just use a C</g> to get all the changes +Occasionally, you can't use just a C</g> to get all the changes to occur. Here are two common cases: # put commas in the right places in an integer @@ -848,10 +889,10 @@ with the corresponding character in the replacement list. It returns the number of characters replaced or deleted. If no string is specified via the =~ or !~ operator, the $_ string is translated. (The string specified with =~ must be a scalar variable, an array element, -or an assignment to one of those, i.e. an lvalue.) For B<sed> devotees, +or an assignment to one of those, i.e., an lvalue.) For B<sed> devotees, C<y> is provided as a synonym for C<tr>. If the SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST has its own pair of -quotes, which may or may not be bracketing quotes, e.g. C<tr[A-Z][a-z]> +quotes, which may or may not be bracketing quotes, e.g., C<tr[A-Z][a-z]> or C<tr(+-*/)/ABCD/>. Options: @@ -916,7 +957,7 @@ an eval(): =head2 I/O Operators There are several I/O operators you should know about. -A string is enclosed by backticks (grave accents) first undergoes +A string is enclosed by back-ticks (grave accents) first undergoes variable substitution just like a double quoted string. It is then interpreted as a command, and the output of that command is the value of the pseudo-literal, like in a shell. In a scalar context, a single @@ -929,7 +970,7 @@ of C<$?>). Unlike in B<csh>, no translation is done on the return data--newlines remain newlines. Unlike in any of the shells, single quotes do not hide variable names in the command from interpretation. To pass a $ through to the shell you need to hide it with a backslash. -The generalized form of backticks is C<qx//>. (Because backticks +The generalized form of back-ticks is C<qx//>. (Because back-ticks always undergo shell expansion as well, see L<perlsec> for security concerns.) @@ -950,8 +991,8 @@ write.) Anyway, the following lines are equivalent to each other: print while defined($_ = <STDIN>); print while <STDIN>; -The filehandles STDIN, STDOUT and STDERR are predefined. (The -filehandles C<stdin>, C<stdout> and C<stderr> will also work except in +The filehandles STDIN, STDOUT, and STDERR are predefined. (The +filehandles C<stdin>, C<stdout>, and C<stderr> will also work except in packages, where they would be interpreted as local identifiers rather than global.) Additional filehandles may be created with the open() function. See L<perlfunc/open()> for details on this. @@ -985,9 +1026,9 @@ is equivalent to the following Perl-like pseudo code: except that it isn't so cumbersome to say, and will actually work. It really does shift array @ARGV and put the current filename into variable -$ARGV. It also uses filehandle I<ARGV> internally--E<lt>E<gt> is just a synonym -for E<lt>ARGVE<gt>, which is magical. (The pseudo code above doesn't work -because it treats E<lt>ARGVE<gt> as non-magical.) +$ARGV. It also uses filehandle I<ARGV> internally--E<lt>E<gt> is just a +synonym for E<lt>ARGVE<gt>, which is magical. (The pseudo code above +doesn't work because it treats E<lt>ARGVE<gt> as non-magical.) You can modify @ARGV before the first E<lt>E<gt> as long as the array ends up containing the list of filenames you really want. Line numbers (C<$.>) @@ -1014,7 +1055,7 @@ this it will assume you are processing another @ARGV list, and if you haven't set @ARGV, will input from STDIN. If the string inside the angle brackets is a reference to a scalar -variable (e.g. E<lt>$fooE<gt>), then that variable contains the name of the +variable (e.g., E<lt>$fooE<gt>), then that variable contains the name of the filehandle to input from, or a reference to the same. For example: $fh = \*STDIN; @@ -1051,11 +1092,11 @@ machine.) Of course, the shortest way to do the above is: chmod 0644, <*.c>; Because globbing invokes a shell, it's often faster to call readdir() yourself -and just do your own grep() on the filenames. Furthermore, due to its current +and do your own grep() on the filenames. Furthermore, due to its current implementation of using a shell, the glob() routine may get "Arg list too long" errors (unless you've installed tcsh(1L) as F</bin/csh>). -A glob only evaluates its (embedded) argument when it is starting a new +A glob evaluates its (embedded) argument only when it is starting a new list. All values must be read before it will start over. In a list context this isn't important, because you automatically get them all anyway. In a scalar context, however, the operator returns the next value @@ -1103,7 +1144,7 @@ expression represents so that the interpreter won't have to. -=head2 Integer arithmetic +=head2 Integer Arithmetic By default Perl assumes that it must do most of its arithmetic in floating point. But by saying @@ -1118,3 +1159,9 @@ countermand this by saying which lasts until the end of that BLOCK. +The bitwise operators ("&", "|", "^", "~", "<<", and ">>") always +produce integral results. However, C<use integer> still has meaning +for them. By default, their results are interpreted as unsigned +integers. However, if C<use integer> is in effect, their results are +interpreted as signed integers. For example, C<~0> usually evaluates +to a large integral value. However, C<use integer; ~0> is -1. diff --git a/pod/perlovl.pod b/pod/perlovl.pod deleted file mode 100644 index 208456d239..0000000000 --- a/pod/perlovl.pod +++ /dev/null @@ -1,15 +0,0 @@ -=head1 NAME - -perlovl - overload perl mathematical functions [superseded] - -=head1 DESCRIPTION - -This man page has been superseded by L<overload>. - -=head1 WARNING - -The old interface involving %OVERLOAD is deprecated and will go away -RSN. Convert your scripts to -use overload ...; -style. - diff --git a/pod/perlpod.pod b/pod/perlpod.pod index ce02970013..ce092214b8 100644 --- a/pod/perlpod.pod +++ b/pod/perlpod.pod @@ -31,18 +31,21 @@ use however it pleases. Currently recognized commands are =back =cut =pod + =for X + =begin X + =end X The "=pod" directive does nothing beyond telling the compiler to lay -off of through the next "=cut". It's useful for adding another -paragraph to the doc if you're mixing up code and pod a lot. +off parsing code through the next "=cut". It's useful for adding +another paragraph to the doc if you're mixing up code and pod a lot. -Head1 and head2 produce first and second level headings, with the text on -the same paragraph as "=headn" forming the heading description. +Head1 and head2 produce first and second level headings, with the text in +the same paragraph as the "=headn" directive forming the heading description. -Item, over, and back require a little more explanation: Over starts a -section specifically for the generation of a list using =item commands. At -the end of your list, use =back to end it. You will probably want to give -"4" as the number to =over, as some formatters will use this for indentation. +Item, over, and back require a little more explanation: "=over" starts a +section specifically for the generation of a list using "=item" commands. At +the end of your list, use "=back" to end it. You will probably want to give +"4" as the number to "=over", as some formatters will use this for indentation. This should probably be a default. Note also that there are some basic rules to using =item: don't use them outside of an =over/=back block, use at least one inside an =over/=back block, you don't _have_ to include the =back if @@ -51,9 +54,46 @@ items consistent: either use "=item *" for all of them, to produce bullets, or use "=item 1.", "=item 2.", etc., to produce numbered lists, or use "=item foo", "=item bar", etc., i.e., things that looks nothing like bullets or numbers. If you start with bullets or numbers, stick with them, as many -formatters use the first =item type to decide how to format the list. +formatters use the first "=item" type to decide how to format the list. -And don't forget, when using any command, that that command lasts up until +For, begin, and end let you include sections that are not interpreted +as pod text, but passed directly to particular formatters. A formatter +that can utilize that format will use the section, otherwise it will be +completely ignored. The directive "=for" specifies that the entire next +paragraph is in the format indicated by the first word after +"=for", like this: + + =for html <br> + <p> This is a raw HTML paragraph </p> + +The paired commands "=begin" and "=end" work very similarly to "=for", but +instead of only accepting a single paragraph, all text from "=begin" to a +paragraph with a matching "=end" are treated as a particular format. + +Here are some examples of how to use these: + + =begin html + + <br>Figure 1.<IMG SRC="figure1.png"><br> + + =end html + + =begin text + + --------------- + | foo | + | bar | + --------------- + + ^^^^ Figure 1. ^^^^ + + =end text + +Some format names that formatters currently are known to accept include +"roff", "man", "latex", "tex", "text", and "html". (Some formatters will +treat some of these as synonyms.) + +And don't forget, when using any command, that the command lasts up until the end of the B<paragraph>, not the line. Hence in the examples below, you can see the blank lines after each command to end its paragraph. @@ -94,15 +134,23 @@ here and in commands: S<text> text contains non-breaking spaces C<code> literal code L<name> A link (cross reference) to name - L<name> manpage - L<name/ident> item in manpage - L<name/"sec"> section in other manpage - L<"sec"> section in this manpage + L<name> manual page + L<name/ident> item in manual page + L<name/"sec"> section in other manual page + L<"sec"> section in this manual page (the quotes are optional) L</"sec"> ditto F<file> Used for filenames X<index> An index entry - Z<> A zero-width character + ZE<lt>E<gt> A zero-width character + E<escape> A named character (very similar to HTML escapes) + E<lt> A literal < + E<gt> A literal > + (these are optional except in other interior + sequences and when preceded by a capital letter) + E<n> Character number n (probably in ASCII) + E<html> Some non-numeric HTML entity, such + as E<Agrave> =back @@ -111,7 +159,7 @@ to look like paragraphs (block format), so that they stand out visually, and so that I could run them through fmt easily to reformat them (that's F7 in my version of B<vi>). I wanted the translator (and not me) to worry about whether " or ' is a left quote or a right quote -within filled text, and I wanted it to leave the quotes alone dammit in +within filled text, and I wanted it to leave the quotes alone, dammit, in verbatim mode, so I could slurp in a working program, shift it over 4 spaces, and have it print out, er, verbatim. And presumably in a constant width font. @@ -136,15 +184,16 @@ B<pod2html>, B<pod2latex>, and B<pod2fm>. =head1 Embedding Pods in Perl Modules You can embed pod documentation in your Perl scripts. Start your -documentation with a =head1 command at the beg, and end it with -an =cut command. Perl will ignore the pod text. See any of the -supplied library modules for examples. If you're going to put -your pods at the end of the file, and you're using an __END__ -or __DATA__ cut mark, make sure to put a blank line there before -the first pod directive. +documentation with a "=head1" command at the beginning, and end it +with a "=cut" command. Perl will ignore the pod text. See any of the +supplied library modules for examples. If you're going to put your +pods at the end of the file, and you're using an __END__ or __DATA__ +cut mark, make sure to put a blank line there before the first pod +directive. __END__ + =head1 NAME modern - I am a modern module @@ -152,6 +201,36 @@ the first pod directive. If you had not had that blank line there, then the translators wouldn't have seen it. +=head1 Common Pod Pitfalls + +=over 4 + +=item * + +Pod translators usually will require paragraphs to be separated by +completely empty lines. If you have an apparently blank line with +some spaces on it, this can cause odd formatting. + +=item * + +Translators will mostly add wording around a LE<lt>E<gt> link, so that +C<LE<lt>foo(1)E<gt>> becomes "the I<foo>(1) manpage", for example (see +B<pod2man> for details). Thus, you shouldn't write things like C<the +LE<lt>fooE<gt> manpage>, if you want the translated document to read +sensibly. + +=item * + +The script F<pod/checkpods.PL> in the Perl source distribution +provides skeletal checking for lines that look blank but aren't +B<only>, but is there as a placeholder until someone writes +Pod::Checker. The best way to check your pod is to pass it through +one or more translators and proofread the result, or print out the +result and proofread that. Some of the problems found may be bugs in +the translators, which you may or may not wish to work around. + +=back + =head1 SEE ALSO L<pod2man> and L<perlsyn/"PODs: Embedded Documentation"> diff --git a/pod/perlre.pod b/pod/perlre.pod index 55dc1209bc..a4c0a7d9de 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -5,7 +5,7 @@ perlre - Perl regular expressions =head1 DESCRIPTION This page describes the syntax of regular expressions in Perl. For a -description of how to actually I<use> regular expressions in matching +description of how to I<use> regular expressions in matching operations, plus various examples of the same, see C<m//> and C<s///> in L<perlop>. @@ -13,10 +13,31 @@ The matching operations can have various modifiers, some of which relate to the interpretation of the regular expression inside. These are: - i Do case-insensitive pattern matching. - m Treat string as multiple lines. - s Treat string as single line. - x Extend your pattern's legibility with whitespace and comments. +=over 4 + +=item i + +Do case-insensitive pattern matching. + +If C<use locale> is in effect, the case map is taken from the current +locale. See L<perllocale>. + +=item m + +Treat string as multiple lines. That is, change "^" and "$" from matching +at only the very start or end of the string to the start or end of any +line anywhere within the string, + +=item s + +Treat string as single line. That is, change "." to match any character +whatsoever, even a newline, which it normally would not match. + +=item x + +Extend your pattern's legibility by permitting whitespace and comments. + +=back These are usually written as "the C</x> modifier", even though the delimiter in question might not actually be a slash. In fact, any of these @@ -24,13 +45,15 @@ modifiers may also be embedded within the regular expression itself using the new C<(?...)> construct. See below. The C</x> modifier itself needs a little more explanation. It tells -the regular expression parser to ignore whitespace that is not -backslashed or within a character class. You can use this to break up +the regular expression parser to ignore whitespace that is neither +backslashed nor within a character class. You can use this to break up your regular expression into (slightly) more readable parts. The C<#> -character is also treated as a metacharacter introducing a comment, -just as in ordinary Perl code. Taken together, these features go a -long way towards making Perl 5 a readable language. See the C comment -deletion code in L<perlop>. +character is also treated as a meta-character introducing a comment, +just as in ordinary Perl code. This also means that if you want real +whitespace or C<#> characters in the pattern that you'll have to either +escape them or encode them using octal or hex escapes. Taken together, +these features go a long way towards making Perl's regular expressions +more readable. See the C comment deletion code in L<perlop>. =head2 Regular Expressions @@ -43,7 +66,7 @@ See L<Version 8 Regular Expressions> for details. In particular the following metacharacters have their standard I<egrep>-ish meanings: - \ Quote the next metacharacter + \ Quote the next meta-character ^ Match the beginning of the line . Match any character (except newline) $ Match the end of the line (or before newline at the end) @@ -51,8 +74,8 @@ meanings: () Grouping [] Character class -By default, the "^" character is guaranteed to match only at the -beginning of the string, the "$" character only at the end (or before the +By default, the "^" character is guaranteed to match at only the +beginning of the string, the "$" character at only the end (or before the newline at the end) and Perl does certain optimizations with the assumption that the string contains only one line. Embedded newlines will not be matched by "^" or "$". You may, however, wish to treat a @@ -60,10 +83,10 @@ string as a multi-line buffer, such that the "^" will match after any newline within the string, and "$" will match before any newline. At the cost of a little more overhead, you can do this by using the /m modifier on the pattern match operator. (Older programs did this by setting C<$*>, -but this practice is deprecated in Perl 5.) +but this practice is now deprecated.) To facilitate multi-line substitutions, the "." character never matches a -newline unless you use the C</s> modifier, which tells Perl to pretend +newline unless you use the C</s> modifier, which in effect tells Perl to pretend the string is a single line--even if it isn't. The C</s> modifier also overrides the setting of C<$*>, in case you have some (badly behaved) older code that sets it in another module. @@ -82,7 +105,7 @@ as a regular character.) The "*" modifier is equivalent to C<{0,}>, the "+" modifier to C<{1,}>, and the "?" modifier to C<{0,1}>. n and m are limited to integral values less than 65536. -By default, a quantified subpattern is "greedy", that is, it will match as +By default, a quantified sub-pattern is "greedy", that is, it will match as many times as possible without causing the rest of the pattern not to match. The standard quantifiers are all "greedy", in that they match as many occurrences as possible (given a particular starting location) without @@ -97,7 +120,7 @@ Note that the meanings don't change, just the "gravity": {n,}? Match at least n times {n,m}? Match at least n but not more than m times -Since patterns are processed as double quoted strings, the following +Because patterns are processed as double quoted strings, the following also work: \t tab (HT, TAB) @@ -116,6 +139,9 @@ also work: \E end case modification (think vi) \Q quote regexp metacharacters till \E +If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> +and <\U> is taken from the current locale. See L<perllocale>. + In addition, Perl defines the following: \w Match a "word" character (alphanumeric plus "_") @@ -126,16 +152,18 @@ In addition, Perl defines the following: \D Match a non-digit character Note that C<\w> matches a single alphanumeric character, not a whole -word. To match a word you'd need to say C<\w+>. You may use C<\w>, -C<\W>, C<\s>, C<\S>, C<\d> and C<\D> within character classes (though not -as either end of a range). +word. To match a word you'd need to say C<\w+>. If C<use locale> is in +effect, the list of alphabetic characters generated by C<\w> is taken +from the current locale. See L<perllocale>. You may use C<\w>, C<\W>, +C<\s>, C<\S>, C<\d>, and C<\D> within character classes (though not as +either end of a range). Perl defines the following zero-width assertions: \b Match a word boundary \B Match a non-(word boundary) - \A Match only at beginning of string - \Z Match only at end of string (or before newline at the end) + \A Match at only beginning of string + \Z Match at only end of string (or before newline at the end) \G Match only where previous m//g left off A word boundary (C<\b>) is defined as a spot between two characters that @@ -146,7 +174,10 @@ represents backspace rather than a word boundary.) The C<\A> and C<\Z> are just like "^" and "$" except that they won't match multiple times when the C</m> modifier is used, while "^" and "$" will match at every internal line boundary. To match the actual end of the string, not ignoring newline, -you can use C<\Z(?!\n)>. +you can use C<\Z(?!\n)>. The C<\G> assertion can be used to mix global +matches (using C<m//g>) and non-global ones, as described in L<perlop>. +The actual location where C<\G> will match can also be influenced +by using C<pos()> as an lvalue. See L<perlfunc/pos>. When the bracketing construct C<( ... )> is used, \E<lt>digitE<gt> matches the digit'th substring. Outside of the pattern, always use "$" instead of "\" @@ -155,13 +186,13 @@ outside the current pattern, this should not be relied upon. See the WARNING below.) The scope of $E<lt>digitE<gt> (and C<$`>, C<$&>, and C<$'>) extends to the end of the enclosing BLOCK or eval string, or to the next successful pattern match, whichever comes first. If you want to use -parentheses to delimit a subpattern (e.g. a set of alternatives) without +parentheses to delimit a subpattern (e.g., a set of alternatives) without saving it as a subpattern, follow the ( with a ?:. You may have as many parentheses as you wish. If you have more than 9 substrings, the variables $10, $11, ... refer to the corresponding substring. Within the pattern, \10, \11, etc. refer back -to substrings if there have been at least that many left parens before +to substrings if there have been at least that many left parentheses before the backreference. Otherwise (for backward compatibility) \10 is the same as \010, a backspace, and \11 the same as \011, a tab. And so on. (\1 through \9 are always backreferences.) @@ -183,9 +214,9 @@ 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 +interpreted as a literal character, not a meta-character. This makes it simple to quote a string that you want to use for a pattern but that -you are afraid might contain metacharacters. Simply quote all the +you are afraid might contain metacharacters. Quote simply all the non-alphanumeric characters: $pattern =~ s/(\W)/\\$1/g; @@ -196,11 +227,11 @@ is to say /$unquoted\Q$quoted\E$unquoted/ -Perl 5 defines a consistent extension syntax for regular expressions. -The syntax is a pair of parens with a question mark as the first thing -within the parens (this was a syntax error in Perl 4). The character -after the question mark gives the function of the extension. Several -extensions are already supported: +Perl defines a consistent extension syntax for regular expressions. +The syntax is a pair of parentheses with a question mark as the first +thing within the parentheses (this was a syntax error in older +versions of Perl). The character after the question mark gives the +function of the extension. Several extensions are already supported: =over 10 @@ -248,7 +279,7 @@ easier just to say: One or more embedded pattern-match modifiers. This is particularly useful for patterns that are specified in a table somewhere, some of which want to be case sensitive, and some of which don't. The case -insensitive ones merely need to include C<(?i)> at the front of the +insensitive ones need to include merely C<(?i)> at the front of the pattern. For example: $pattern = "foobar"; @@ -370,11 +401,10 @@ As you see, this can be a bit tricky. It's important to realize that a regular expression is merely a set of assertions that gives a definition of success. There may be 0, 1, or several different ways that the definition might succeed against a particular string. And if there are -multiple ways it might succeed, you need to understand backtracking in -order to know which variety of success you will achieve. +multiple ways it might succeed, you need to understand backtracking to know which variety of success you will achieve. When using lookahead assertions and negations, this can all get even -tricker. Imagine you'd like to find a sequence of nondigits not +tricker. Imagine you'd like to find a sequence of non-digits not followed by "123". You might try to write that as $_ = "ABC123"; @@ -401,12 +431,12 @@ This prints 3: got AB 4: got ABC -You might have expected test 3 to fail because it just seems to a more +You might have expected test 3 to fail because it seems to a more general purpose version of test 1. The important difference between them is that test 3 contains a quantifier (C<\D*>) and so can use backtracking, whereas test 1 will not. What's happening is that you've asked "Is it true that at the start of $x, following 0 or more -nondigits, you have something that's not 123?" If the pattern matcher had +non-digits, you have something that's not 123?" If the pattern matcher had let C<\D*> expand to "ABC", this would have caused the whole pattern to fail. The search engine will initially match C<\D*> with "ABC". Then it will @@ -417,7 +447,7 @@ in the hope of matching the complete regular expression. Well now, the pattern really, I<really> wants to succeed, so it uses the -standard regexp backoff-and-retry and lets C<\D*> expand to just "AB" this +standard regexp back-off-and-retry and lets C<\D*> expand to just "AB" this time. Now there's indeed something following "AB" that is not "123". It's in fact "C123", which suffices. @@ -457,10 +487,10 @@ it would take literally forever--or until you ran out of stack space. In case you're not familiar with the "regular" Version 8 regexp routines, here are the pattern-matching rules not described above. -Any single character matches itself, unless it is a I<metacharacter> +Any single character matches itself, unless it is a I<meta-character> with a special meaning described here or above. You can cause characters which normally function as metacharacters to be interpreted -literally by prefixing them with a "\" (e.g. "\." matches a ".", not any +literally by prefixing them with a "\" (e.g., "\." matches a ".", not any character; "\\" matches a "\"). A series of characters matches that series of characters in the target string, so the pattern C<blurfl> would match "blurfl" in the target string. @@ -472,13 +502,13 @@ 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. -Characters may be specified using a metacharacter syntax much like that +Characters may be specified using a meta-character syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, "\f" a form feed, etc. More generally, \I<nnn>, where I<nnn> is a string of octal digits, matches the character whose ASCII value is I<nnn>. Similarly, \xI<nn>, where I<nn> are hexadecimal digits, matches the character whose ASCII value is I<nn>. The expression \cI<x> matches the -ASCII character control-I<x>. Finally, the "." metacharacter matches any +ASCII character control-I<x>. Finally, the "." meta-character matches any character except "\n" (unless you use C</s>). You can specify a series of alternatives for a pattern using "|" to @@ -493,14 +523,14 @@ start and end. Note however that "|" is interpreted as a literal with square brackets, so if you write C<[fee|fie|foe]> you're really only matching C<[feio|]>. -Within a pattern, you may designate subpatterns for later reference by +Within a pattern, you may designate sub-patterns for later reference by enclosing them in parentheses, and you may refer back to the I<n>th -subpattern later in the pattern using the metacharacter \I<n>. -Subpatterns are numbered based on the left to right order of their +sub-pattern later in the pattern using the meta-character \I<n>. +Sub-patterns are numbered based on the left to right order of their opening parenthesis. Note that a backreference matches whatever -actually matched the subpattern in the string being examined, not the -rules for that subpattern. Therefore, C<(0|0x)\d*\s\1\d*> will -match "0x1234 0x4321",but not "0x1234 01234", since subpattern 1 +actually matched the sub-pattern in the string being examined, not the +rules for that sub-pattern. Therefore, C<(0|0x)\d*\s\1\d*> will +match "0x1234 0x4321",but not "0x1234 01234", because sub-pattern 1 actually matched "0x", even though the rule C<0|0x> could potentially match the leading 0 in the second number. @@ -512,7 +542,7 @@ Some people get too used to writing things like This is grandfathered for the RHS of a substitute to avoid shocking the B<sed> addicts, but it's a dirty habit to get into. That's because in -PerlThink, the right-hand side of a C<s///> is a double-quoted string. C<\1> in +PerlThink, the righthand side of a C<s///> is a double-quoted string. C<\1> in the usual double-quoted string means a control-A. The customary Unix meaning of C<\1> is kludged in for C<s///>. However, if you get into the habit of doing that, you get yourself into trouble if you then add an C</e> diff --git a/pod/perlref.pod b/pod/perlref.pod index a7c7f438d8..7b522eee4d 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -7,9 +7,9 @@ perlref - Perl references and nested data structures Before release 5 of Perl it was difficult to represent complex data structures, because all references had to be symbolic, and even that was difficult to do when you wanted to refer to a variable rather than a -symbol table entry. Perl 5 not only makes it easier to use symbolic +symbol table entry. Perl not only makes it easier to use symbolic references to variables, but lets you have "hard" references to any piece -of data. Any scalar may hold a hard reference. Since arrays and hashes +of data. Any scalar may hold a hard reference. Because arrays and hashes contain scalars, you can now easily build arrays of arrays, arrays of hashes, hashes of arrays, arrays of hashes of functions, and so on. @@ -25,7 +25,7 @@ references to objects that have been officially "blessed" into a class package.) A symbolic reference contains the name of a variable, just as a -symbolic link in the filesystem merely contains the name of a file. +symbolic link in the filesystem contains merely the name of a file. The C<*glob> notation is a kind of symbolic reference. Hard references are more like hard links in the file system: merely another way at getting at the same underlying object, irrespective of its name. @@ -44,7 +44,7 @@ References can be constructed several ways. By using the backslash operator on a variable, subroutine, or value. (This works much like the & (address-of) operator works in C.) Note -that this typically creates I<ANOTHER> reference to a variable, since +that this typically creates I<ANOTHER> reference to a variable, because there's already a reference to the variable in the symbol table. But the symbol table reference might go away, and you'll still have the reference that the backslash returned. Here are some examples: @@ -53,8 +53,13 @@ reference that the backslash returned. Here are some examples: $arrayref = \@ARGV; $hashref = \%ENV; $coderef = \&handler; - $globref = \*STDOUT; + $globref = \*foo; +It isn't possible to create a true reference to an IO handle (filehandle or +dirhandle) using the backslash operator. See the explanation of the +*foo{THING} syntax below. (However, you're apt to find Perl code +out there using globrefs as though they were IO handles, which is +grandfathered into continued functioning.) =item 2. @@ -164,7 +169,7 @@ newprint() I<despite> the fact that the "my $x" has seemingly gone out of scope by the time the anonymous subroutine runs. That's what closure is all about. -This only applies to lexical variables, by the way. Dynamic variables +This applies to only lexical variables, by the way. Dynamic variables continue to work as they have always worked. Closure is not something that most Perl programmers need trouble themselves about to begin with. @@ -183,27 +188,62 @@ named new(), but don't have to be: =item 6. References of the appropriate type can spring into existence if you -dereference them in a context that assumes they exist. Since we haven't +dereference them in a context that assumes they exist. Because we haven't talked about dereferencing yet, we can't show you any examples yet. =item 7. -References to filehandles can be created by taking a reference to -a typeglob. This is currently the best way to pass filehandles into or +A reference can be created by using a special syntax, lovingly known as +the *foo{THING} syntax. *foo{THING} returns a reference to the THING +slot in *foo (which is the symbol table entry which holds everything +known as foo). + + $scalarref = *foo{SCALAR}; + $arrayref = *ARGV{ARRAY}; + $hashref = *ENV{HASH}; + $coderef = *handler{CODE}; + $ioref = *STDIN{IO}; + $globref = *foo{GLOB}; + +All of these are self-explanatory except for *foo{IO}. It returns the +IO handle, used for file handles (L<perlfunc/open>), sockets +(L<perlfunc/socket> and L<perlfunc/socketpair>), and directory handles +(L<perlfunc/opendir>). For compatibility with previous versions of +Perl, *foo{FILEHANDLE} is a synonym for *foo{IO}. + +*foo{THING} returns undef if that particular THING hasn't been used yet, +except in the case of scalars. *foo{SCALAR} returns a reference to an +anonymous scalar if $foo hasn't been used yet. This might change in a +future release. + +The use of *foo{IO} is the best way to pass bareword filehandles into or out of subroutines, or to store them in larger data structures. - splutter(\*STDOUT); + splutter(*STDOUT{IO}); sub splutter { my $fh = shift; print $fh "her um well a hmmm\n"; } - $rec = get_rec(\*STDIN); + $rec = get_rec(*STDIN{IO}); sub get_rec { my $fh = shift; return scalar <$fh>; } +Beware, though, that you can't do this with a routine which is going to +open the filehandle for you, because *HANDLE{IO} will be undef if HANDLE +hasn't been used yet. Use \*HANDLE for that sort of thing instead. + +Using \*HANDLE (or *HANDLE) is another way to use and store non-bareword +filehandles (before perl version 5.002 it was the only way). The two +methods are largely interchangeable, you can do + + splutter(\*STDOUT); + $rec = get_rec(\*STDIN); + +with the above subroutine definitions. + =back That's it for creating references. By now you're probably dying to @@ -247,7 +287,7 @@ previous examples could be written like this: ${$arrayref}[0] = "January"; ${$hashref}{"KEY"} = "VALUE"; &{$coderef}(1,2,3); - $globref->print("output\n"); # iff you use FileHandle + $globref->print("output\n"); # iff IO::Handle is loaded Admittedly, it's a little silly to use the curlies in this case, but the BLOCK can contain any arbitrary expression, in particular, @@ -258,7 +298,7 @@ subscripted expressions: Because of being able to omit the curlies for the simple case of C<$$x>, people often make the mistake of viewing the dereferencing symbols as proper operators, and wonder about their precedence. If they were, -though, you could use parens instead of braces. That's not the case. +though, you could use parentheses instead of braces. That's not the case. Consider the difference below; case 0 is a short-hand version of case 1, I<NOT> case 2: @@ -324,7 +364,7 @@ reference is pointing to. See L<perlfunc>. The bless() operator may be used to associate a reference with a package functioning as an object class. See L<perlobj>. -A typeglob may be dereferenced the same way a reference can, since +A typeglob may be dereferenced the same way a reference can, because the dereference syntax always indicates the kind of reference desired. So C<${*foo}> and C<${\$foo}> both indicate the same scalar variable. @@ -391,8 +431,8 @@ variables, which are all "global" to the package. =head2 Not-so-symbolic references -A new feature contributing to readability in 5.001 is that the brackets -around a symbolic reference behave more like quotes, just as they +A new feature contributing to readability in perl version 5.001 is that the +brackets around a symbolic reference behave more like quotes, just as they always have within a string. That is, $push = "pop on "; @@ -409,7 +449,7 @@ and even print ${ push } . "over"; will have the same effect. (This would have been a syntax error in -5.000, though Perl 4 allowed it in the spaceless form.) Note that this +Perl 5.000, though Perl 4 allowed it in the spaceless form.) Note that this construct is I<not> considered to be a symbolic reference when you're using strict refs: @@ -423,7 +463,7 @@ subscripting a hash. So now, instead of writing $array{ "aaa" }{ "bbb" }{ "ccc" } -you can just write +you can write just $array{ aaa }{ bbb }{ ccc } @@ -440,7 +480,7 @@ makes it more than a bareword: $array{ shift @_ } The B<-w> switch will warn you if it interprets a reserved word as a string. -But it will no longer warn you about using lowercase words, since the +But it will no longer warn you about using lowercase words, because the string is effectively quoted. =head1 WARNING diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 5042d67bd7..083b567e19 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -33,7 +33,7 @@ Contained in the file specified by the first filename on the command line. =item 3. -Passed in implicitly via standard input. This only works if there are +Passed in implicitly via standard input. This works only if there are no filename arguments--to pass arguments to a STDIN script you must explicitly specify a "-" for the script name. @@ -46,11 +46,11 @@ scans for the first line starting with #! and containing the word embedded in a larger message. (In this case you would indicate the end of the script using the __END__ token.) -As of Perl 5, the #! line is always examined for switches as the line is -being parsed. Thus, if you're on a machine that only allows one argument -with the #! line, or worse, doesn't even recognize the #! line, you still -can get consistent switch behavior regardless of how Perl was invoked, -even if B<-x> was used to find the beginning of the script. +The #! line is always examined for switches as the line is being +parsed. Thus, if you're on a machine that allows only one argument +with the #! line, or worse, doesn't even recognize the #! line, you +still can get consistent switch behavior regardless of how Perl was +invoked, even if B<-x> was used to find the beginning of the script. Because many operating systems silently chop off kernel interpretation of the #! line after 32 characters, some switches may be passed in on the @@ -67,8 +67,8 @@ The sequences "-*" and "- " are specifically ignored so that you could, if you were so inclined, say #!/bin/sh -- # -*- perl -*- -p - eval 'exec perl $0 -S ${1+"$@"}' - if 0; + eval 'exec /usr/bin/perl $0 -S ${1+"$@"}' + if $running_under_some_shell; to let Perl see the B<-p> switch. @@ -100,7 +100,7 @@ Switches include: =item B<-0>[I<digits>] -specifies the record separator (C<$/>) as an octal number. If there are +specifies the input record separator (C<$/>) as an octal number. If there are no digits, the null character is the separator. Other switches may precede or follow the digits. For example, if you have a version of B<find> which can print filenames terminated by the null character, you @@ -109,7 +109,7 @@ can say this: find . -name '*.bak' -print0 | perl -n0e unlink The special value 00 will cause Perl to slurp files in paragraph mode. -The value 0777 will cause Perl to slurp files whole since there is no +The value 0777 will cause Perl to slurp files whole because there is no legal character with that value. =item B<-a> @@ -133,7 +133,7 @@ An alternate delimiter may be specified using B<-F>. causes Perl to check the syntax of the script and then exit without executing it. Actually, it I<will> execute C<BEGIN>, C<END>, and C<use> blocks, -since these are considered as occurring outside the execution of +because these are considered as occurring outside the execution of your program. =item B<-d> @@ -151,10 +151,10 @@ Devel::DProf profiler. See L<perldebug>. =item B<-D>I<list> sets debugging flags. To watch how it executes your script, use -B<-D14>. (This only works if debugging is compiled into your +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 +alternative specify a list of letters instead of numbers (e.g., B<-D14> is equivalent to B<-Dtls>): 1 p Tokenizing and Parsing @@ -186,7 +186,7 @@ Make sure to use semicolons where you would in a normal program. =item B<-F>I<pattern> specifies the pattern to split on if B<-a> is also in effect. The -pattern may be surrounded by C<//>, C<""> or C<''>, otherwise it will be +pattern may be surrounded by C<//>, C<"">, or C<''>, otherwise it will be put in single quotes. =item B<-h> @@ -245,9 +245,10 @@ searches /usr/include and /usr/lib/perl. =item B<-l>[I<octnum>] enables automatic line-ending processing. It has two effects: first, -it automatically chomps the line terminator when used with B<-n> or -B<-p>, and second, it assigns "C<$\>" to have the value of I<octnum> so that -any print statements will have that line terminator added back on. If +it automatically chomps "C<$/>" (the input record separator) when used +with B<-n> or B<-p>, and second, it assigns "C<$\>" +(the output record separator) to have the value of I<octnum> so that +any print statements will have that separator added back on. If I<octnum> is omitted, sets "C<$\>" to the current value of "C<$/>". For instance, to trim lines to 80 columns: @@ -329,9 +330,9 @@ the implicit loop, just as in awk. =item B<-P> causes your script to be run through the C preprocessor before -compilation by Perl. (Since both comments and cpp directives begin +compilation by Perl. (Because both comments and cpp directives begin with the # character, you should avoid starting comments with any words -recognized by the C preprocessor such as "if", "else" or "define".) +recognized by the C preprocessor such as "if", "else", or "define".) =item B<-s> @@ -352,7 +353,7 @@ this is used to emulate #! startup on machines that don't support #!, in the following manner: #!/usr/bin/perl - eval "exec /usr/bin/perl -S $0 $*" + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if $running_under_some_shell; The system ignores the first line and feeds the script to /bin/sh, @@ -364,15 +365,15 @@ script if necessary. After Perl locates the script, it parses the lines and ignores them because the variable $running_under_some_shell is never true. A better construct than C<$*> would be C<${1+"$@"}>, which handles embedded spaces and such in the filenames, but doesn't work if -the script is being interpreted by csh. In order to start up sh rather +the script is being interpreted by csh. To start up sh rather than csh, some systems may have to replace the #! line with a line containing just a colon, which will be politely ignored by Perl. Other systems can't control that, and need a totally devious construct that -will work under any of csh, sh or Perl, such as the following: +will work under any of csh, sh, or Perl, such as the following: eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' & eval 'exec /usr/bin/perl -S $0 $argv:q' - if 0; + if $running_under_some_shell; =item B<-T> @@ -418,7 +419,7 @@ Prints to STDOUT the value of the named configuration variable. prints warnings about variable names that are mentioned only once, and scalar variables that are used before being set. Also warns about redefined subroutines, and references to undefined filehandles or -filehandles opened readonly that you are attempting to write on. Also +filehandles opened read-only that you are attempting to write on. Also warns you if you use values as a number that doesn't look like numbers, using an array as though it were a scalar, if your subroutines recurse more than 100 deep, and innumerable other things. @@ -431,8 +432,8 @@ garbage will be discarded until the first line that starts with #! and contains the string "perl". Any meaningful switches on that line will be applied (but only one group of switches, as with normal #! processing). If a directory name is specified, Perl will switch to -that directory before running the script. The B<-x> switch only -controls the the disposal of leading garbage. The script must be +that directory before running the script. The B<-x> switch controls +only the disposal of leading garbage. The script must be terminated with C<__END__> if there is trailing garbage to be ignored (the script can process any or all of the trailing garbage via the DATA filehandle if desired). diff --git a/pod/perlsec.pod b/pod/perlsec.pod index facddedfbf..2324b8a373 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -1,4 +1,3 @@ - =head1 NAME perlsec - Perl security @@ -17,7 +16,7 @@ Perl automatically enables a set of special security checks, called I<taint mode>, when it detects its program running with differing real and effective user or group IDs. The setuid bit in Unix permissions is mode 04000, the setgid bit mode 02000; either or both may be set. You can also enable taint -mode explicitly by using the the B<-T> command line flag. This flag is +mode explicitly by using the B<-T> command line flag. This flag is I<strongly> suggested for server programs and any program run on behalf of someone else, such as a CGI script. @@ -31,20 +30,23 @@ program more secure than the corresponding C program. You may not use data derived from outside your program to affect something else outside your program--at least, not by accident. All command-line -arguments, environment variables, and file input are marked as "tainted". -Tainted data may not be used directly or indirectly in any command that -invokes a subshell, nor in any command that modifies files, directories, -or processes. Any variable set within an expression that has previously -referenced a tainted value itself becomes tainted, even if it is logically -impossible for the tainted value to influence the variable. Because -taintedness is associated with each scalar value, some elements of an -array can be tainted and others not. +arguments, environment variables, locale information (see L<perllocale>), +and file input are marked as "tainted". Tainted data may not be used +directly or indirectly in any command that invokes a sub-shell, nor in any +command that modifies files, directories, or processes. Any variable set +within an expression that has previously referenced a tainted value itself +becomes tainted, even if it is logically impossible for the tainted value +to influence the variable. Because taintedness is associated with each +scalar value, some elements of an array can be tainted and others not. For example: $arg = shift; # $arg is tainted $hid = $arg, 'bar'; # $hid is also tainted $line = <>; # Tainted + $line = <STDIN>; # Also tainted + open FOO, "/home/me/bar" or die $!; + $line = <FOO>; # Still tainted $path = $ENV{'PATH'}; # Tainted, but see below $data = 'abc'; # Not tainted @@ -102,16 +104,16 @@ taintedness. Instead, the slightly more efficient and conservative approach is used that if any tainted value has been accessed within the same expression, the whole expression is considered tainted. -But testing for taintedness only gets you so far. Sometimes you just have +But testing for taintedness gets you only so far. Sometimes you have just to clear your data's taintedness. The only way to bypass the tainting -mechanism is by referencing subpatterns from a regular expression match. +mechanism is by referencing sub-patterns from a regular expression match. Perl presumes that if you reference a substring using $1, $2, etc., that you knew what you were doing when you wrote the pattern. That means using a bit of thought--don't just blindly untaint anything, or you defeat the -entire mechanism. It's better to verify that the variable has only -good characters (for certain values of "good") rather than checking -whether it has any bad characters. That's because it's far too easy to -miss bad characters that you never thought of. +entire mechanism. It's better to verify that the variable has only good +characters (for certain values of "good") rather than checking whether it +has any bad characters. That's because it's far too easy to miss bad +characters that you never thought of. Here's a test to make sure that the data contains nothing but "word" characters (alphabetics, numerics, and underscores), a hyphen, an at sign, @@ -123,7 +125,7 @@ or a dot. die "Bad data in $data"; # log this somewhere } -This is fairly secure since C</\w+/> doesn't normally match shell +This is fairly secure because C</\w+/> doesn't normally match shell metacharacters, nor are dot, dash, or at going to mean something special to the shell. Use of C</.+/> would have been insecure in theory because it lets everything through, but Perl doesn't check for that. The lesson @@ -132,6 +134,14 @@ Laundering data using regular expression is the I<ONLY> mechanism for untainting dirty data, unless you use the strategy detailed below to fork a child of lesser privilege. +The example does not untaint $data if C<use locale> is in effect, +because the characters matched by C<\w> are determined by the locale. +Perl considers that locale definitions are untrustworthy because they +contain data from outside the program. If you are writing a +locale-aware program, and want to launder data with a regular expression +containing C<\w>, put C<no locale> ahead of the expression in the same +block. See L<perllocale/SECURITY> for further discussion and examples. + =head2 Cleaning Up Your Path For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to a @@ -156,7 +166,7 @@ prevent stupid mistakes, not to remove the need for thought. Perl does not call the shell to expand wild cards when you pass B<system> and B<exec> explicit parameter lists instead of strings with possible shell wildcards in them. Unfortunately, the B<open>, B<glob>, and -backtick functions provide no such alternate calling convention, so more +back-tick functions provide no such alternate calling convention, so more subterfuge will be required. Perl provides a reasonably safe way to open a file or pipe from a setuid @@ -168,11 +178,11 @@ environment variables, umasks, current working directories, back to the originals or known safe values. Then the child process, which no longer has any special permissions, does the B<open> or other system call. Finally, the child passes the data it managed to access back to the -parent. Since the file or pipe was opened in the child while running +parent. Because the file or pipe was opened in the child while running under less privilege than the parent, it's not apt to be tricked into doing something it shouldn't. -Here's a way to do backticks reasonably safely. Notice how the B<exec> is +Here's a way to do back-ticks reasonably safely. Notice how the B<exec> is not called with a string that the shell could expand. This is by far the best way to call something that might be subjected to shell escapes: just never call the shell at all. By the time we get to the B<exec>, tainting diff --git a/pod/perlstyle.pod b/pod/perlstyle.pod index 46c17ddae3..734b9ad032 100644 --- a/pod/perlstyle.pod +++ b/pod/perlstyle.pod @@ -32,7 +32,7 @@ Opening curly on same line as keyword, if possible, otherwise line up. =item * -Space before the opening curly of a multiline BLOCK. +Space before the opening curly of a multi-line BLOCK. =item * @@ -64,7 +64,7 @@ Uncuddled elses. =item * -No space between function name and its opening paren. +No space between function name and its opening parenthesis. =item * @@ -76,7 +76,7 @@ Long lines broken after an operator (except "and" and "or"). =item * -Space after last paren matching on current line. +Space after last parenthesis matching on current line. =item * @@ -117,7 +117,7 @@ is better than $verbose && print "Starting analysis\n"; -since the main point isn't whether the user typed B<-v> or not. +because the main point isn't whether the user typed B<-v> or not. Similarly, just because an operator lets you assume default arguments doesn't mean that you have to make use of the defaults. The defaults @@ -135,7 +135,7 @@ schmuck bounce on the % key in B<vi>. Even if you aren't in doubt, consider the mental welfare of the person who has to maintain the code after you, and who will probably put -parens in the wrong place. +parentheses in the wrong place. =item * @@ -189,7 +189,7 @@ Package names are sometimes an exception to this rule. Perl informally reserves lowercase module names for "pragma" modules like C<integer> and C<strict>. Other modules should begin with a capital letter and use mixed case, but probably without underscores due to limitations in primitive -filesystems' representations of module names as files that must fit into a +file systems' representations of module names as files that must fit into a few sparse bites. =item * @@ -216,9 +216,9 @@ Don't use slash as a delimiter when your regexp has slashes or backslashes. =item * Use the new "and" and "or" operators to avoid having to parenthesize -list operators so much, and to reduce the incidence of punctuational +list operators so much, and to reduce the incidence of punctuation operators like C<&&> and C<||>. Call your subroutines as if they were -functions or list operators to avoid excessive ampersands and parens. +functions or list operators to avoid excessive ampersands and parentheses. =item * diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 870b2b5af9..c83f2da336 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -22,8 +22,8 @@ To import subroutines: To call subroutines: - NAME(LIST); # & is optional with parens. - NAME LIST; # Parens optional if predeclared/imported. + NAME(LIST); # & is optional with parentheses. + NAME LIST; # Parentheses optional if pre-declared/imported. &NAME; # Passes current @_ to subroutine. =head1 DESCRIPTION @@ -105,7 +105,7 @@ Use array assignment to a local list to name your formal arguments: } This also has the effect of turning call-by-reference into call-by-value, -since the assignment copies the values. Otherwise a function is free to +because the assignment copies the values. Otherwise a function is free to do in-place modifications of @_ and change its caller's values. upcase_in($v1, $v2); # this changes $v1 and $v2 @@ -149,13 +149,14 @@ Because like its flat incoming parameter list, the return list is also flat. So all you have managed to do here is stored everything in @a and made @b an empty list. See L</"Pass by Reference"> for alternatives. -A subroutine may be called using the "&" prefix. The "&" is optional in -Perl 5, and so are the parens if the subroutine has been predeclared. -(Note, however, that the "&" is I<NOT> optional when you're just naming -the subroutine, such as when it's used as an argument to defined() or -undef(). Nor is it optional when you want to do an indirect subroutine -call with a subroutine name or reference using the C<&$subref()> or -C<&{$subref}()> constructs. See L<perlref> for more on that.) +A subroutine may be called using the "&" prefix. The "&" is optional +in modern Perls, and so are the parentheses if the subroutine has been +pre-declared. (Note, however, that the "&" is I<NOT> optional when +you're just naming the subroutine, such as when it's used as an +argument to defined() or undef(). Nor is it optional when you want to +do an indirect subroutine call with a subroutine name or reference +using the C<&$subref()> or C<&{$subref}()> constructs. See L<perlref> +for more on that.) Subroutines may be called recursively. If a subroutine is called using the "&" form, the argument list is optional, and if omitted, no @_ array is @@ -187,11 +188,12 @@ Synopsis: my @oof = @bar; # declare @oof lexical, and init it A "my" declares the listed variables to be confined (lexically) to the -enclosing block, subroutine, C<eval>, or C<do/require/use>'d file. If -more than one value is listed, the list must be placed in parens. All -listed elements must be legal lvalues. Only alphanumeric identifiers may -be lexically scoped--magical builtins like $/ must currently be localized with -"local" instead. +enclosing block, conditional (C<if/unless/elsif/else>), loop +(C<for/foreach/while/until/continue>), subroutine, C<eval>, or +C<do/require/use>'d file. If more than one value is listed, the list +must be placed in parentheses. All listed elements must be legal lvalues. +Only alphanumeric identifiers may be lexically scoped--magical +builtins like $/ must currently be localized with "local" instead. Unlike dynamic variables created by the "local" statement, lexical variables declared with "my" are totally hidden from the outside world, @@ -225,11 +227,11 @@ change whether those variables is viewed as a scalar or an array. So my ($foo) = <STDIN>; my @FOO = <STDIN>; -both supply a list context to the righthand side, while +both supply a list context to the right-hand side, while my $foo = <STDIN>; -supplies a scalar context. But the following only declares one variable: +supplies a scalar context. But the following declares only one variable: my $foo, $bar = 1; @@ -250,6 +252,49 @@ the expression is false unless the old $x happened to have the value 123. +Lexical scopes of control structures are not bounded precisely by the +braces that delimit their controlled blocks; control expressions are +part of the scope, too. Thus in the loop + + while (my $line = <>) { + $line = lc $line; + } continue { + print $line; + } + +the scope of $line extends from its declaration throughout the rest of +the loop construct (including the C<continue> clause), but not beyond +it. Similarly, in the conditional + + if ((my $answer = <STDIN>) =~ /^yes$/i) { + user_agrees(); + } elsif ($answer =~ /^no$/i) { + user_disagrees(); + } else { + chomp $answer; + die "'$answer' is neither 'yes' nor 'no'"; + } + +the scope of $answer extends from its declaration throughout the rest +of the conditional (including C<elsif> and C<else> clauses, if any), +but not beyond it. + +(None of the foregoing applies to C<if/unless> or C<while/until> +modifiers appended to simple statements. Such modifiers are not +control structures and have no effect on scoping.) + +The C<foreach> loop defaults to scoping its index variable dynamically +(in the manner of C<local>; see below). However, if the index +variable is prefixed with the keyword "my", then it is lexically +scoped instead. Thus in the loop + + for my $i (1, 2, 3) { + some_function(); + } + +the scope of $i extends to the end of the loop, but not beyond it, and +so the value of $i is unavailable in some_function(). + Some users may wish to encourage the use of lexically scoped variables. As an aid to catching implicit references to package variables, if you say @@ -284,8 +329,8 @@ lexical of the same name is also visible: That will print out 20 and 10. -You may declare "my" variables at the outer most scope of a file to -totally hide any such identifiers from the outside world. This is similar +You may declare "my" variables at the outermost scope of a file to +hide any such identifiers totally from the outside world. This is similar to C's static variables at the file level. To do this with a subroutine requires the use of a closure (anonymous function). If a block (such as an eval(), function, or C<package>) wants to create a private subroutine @@ -297,7 +342,7 @@ variable containing an anonymous sub reference: &$secret_sub(); As long as the reference is never returned by any function within the -module, no outside module can see the subroutine, since its name is not in +module, no outside module can see the subroutine, because its name is not in any package's symbol table. Remember that it's not I<REALLY> called $some_pack::secret_version or anything; it's just $secret_version, unqualified and unqualifiable. @@ -326,7 +371,7 @@ If this function is being sourced in from a separate file via C<require> or C<use>, then this is probably just fine. If it's all in the main program, you'll need to arrange for the my() to be executed early, either by putting the whole block above -your pain program, or more likely, merely placing a BEGIN +your pain program, or more likely, placing merely a BEGIN sub around it to make sure it gets executed before your program starts to run: @@ -362,15 +407,15 @@ Synopsis: local *merlyn = \$randal; # just alias $merlyn, not @merlyn etc A local() modifies its listed variables to be local to the enclosing -block, (or subroutine, C<eval{}> or C<do>) and I<any called from +block, (or subroutine, C<eval{}>, or C<do>) and I<any called from within that block>. A local() just gives temporary values to global (meaning package) variables. This is known as dynamic scoping. Lexical scoping is done with "my", which works more like C's auto declarations. If more than one variable is given to local(), they must be placed in -parens. All listed elements must be legal lvalues. This operator works +parentheses. All listed elements must be legal lvalues. This operator works by saving the current values of those variables in its argument list on a -hidden stack and restoring them upon exiting the block, subroutine or +hidden stack and restoring them upon exiting the block, subroutine, or eval. This means that called subroutines can also reference the local variable, but not the global one. The argument list may be assigned to if desired, which allows you to initialize your local variables. (If no @@ -405,7 +450,7 @@ as a scalar or an array. So local($foo) = <STDIN>; local @FOO = <STDIN>; -both supply a list context to the righthand side, while +both supply a list context to the right-hand side, while local $foo = <STDIN>; @@ -422,12 +467,12 @@ Sometimes you don't want to pass the value of an array to a subroutine but rather the name of it, so that the subroutine can modify the global copy of it rather than working with a local copy. In perl you can refer to all objects of a particular name by prefixing the name -with a star: C<*foo>. This is often known as a "type glob", since the +with a star: C<*foo>. This is often known as a "typeglob", because the star on the front can be thought of as a wildcard match for all the funny prefix characters on variables and subroutines and such. -When evaluated, the type glob produces a scalar value that represents -all the objects of that name, including any filehandle, format or +When evaluated, the typeglob produces a scalar value that represents +all the objects of that name, including any filehandle, format, or subroutine. When assigned to, it causes the name mentioned to refer to whatever "*" value was assigned to it. Example: @@ -444,20 +489,21 @@ Note that scalars are already passed by reference, so you can modify scalar arguments without using this mechanism by referring explicitly to C<$_[0]> etc. You can modify all the elements of an array by passing all the elements as scalars, but you have to use the * mechanism (or -the equivalent reference mechanism) to push, pop or change the size of +the equivalent reference mechanism) to push, pop, or change the size of an array. It will certainly be faster to pass the typeglob (or reference). Even if you don't want to modify an array, this mechanism is useful for -passing multiple arrays in a single LIST, since normally the LIST +passing multiple arrays in a single LIST, because normally the LIST mechanism will merge all the array values so that you can't extract out -the individual arrays. For more on typeglobs, see L<perldata/"Typeglobs">. +the individual arrays. For more on typeglobs, see +L<perldata/"Typeglobs and FileHandles">. =head2 Pass by Reference -If you want to pass more than one array or hash into a function--or -return them from it--and have them maintain their integrity, -then you're going to have to use an explicit pass-by-reference. -Before you do that, you need to understand references as detailed in L<perlref>. +If you want to pass more than one array or hash into a function--or +return them from it--and have them maintain their integrity, then +you're going to have to use an explicit pass-by-reference. Before you +do that, you need to understand references as detailed in L<perlref>. This section may not make much sense to you otherwise. Here are a few simple examples. First, let's pass in several @@ -489,9 +535,9 @@ list of keys occurring in all the hashes passed to it: return grep { $seen{$_} == @_ } keys %seen; } -So far, we're just using the normal list return mechanism. +So far, we're using just the normal list return mechanism. What happens if you want to pass or return a hash? Well, -if you're only using one of them, or you don't mind them +if you're using only one of them, or you don't mind them concatenating, then the normal calling convention is ok, although a little expensive. @@ -501,7 +547,7 @@ Where people get into trouble is here: or (%a, %b) = func(%c, %d); -That syntax simply won't work. It just sets @a or %a and clears the @b or +That syntax simply won't work. It sets just @a or %a and clears the @b or %b. Plus the function didn't get passed into two separate arrays or hashes: it got one long list in @_, as always. @@ -536,7 +582,7 @@ It turns out that you can actually do this also: Here we're using the typeglobs to do symbol table aliasing. It's a tad subtle, though, and also won't work if you're using my() -variables, since only globals (well, and local()s) are in the symbol table. +variables, because only globals (well, and local()s) are in the symbol table. If you're passing around filehandles, you could usually just use the bare typeglob, like *STDOUT, but typeglobs references would be better because @@ -554,6 +600,9 @@ they'll still work properly under C<use strict 'refs'>. For example: return scalar <$fh>; } +Another way to do this is using *HANDLE{IO}, see L<perlref> for usage +and caveats. + If you're planning on generating new filehandles, you could do this: sub openit { @@ -563,8 +612,8 @@ If you're planning on generating new filehandles, you could do this: } Although that will actually produce a small memory leak. See the bottom -of L<perlfunc/open()> for a somewhat cleaner way using the FileHandle -functions supplied with the POSIX package. +of L<perlfunc/open()> for a somewhat cleaner way using the IO::Handle +package. =head2 Prototypes @@ -574,7 +623,7 @@ As of the 5.002 release of perl, if you declare then mypush() takes arguments exactly like push() does. The declaration of the function to be called must be visible at compile time. The prototype -only affects the interpretation of new-style calls to the function, where +affects only the interpretation of new-style calls to the function, where new-style is defined as not using the C<&> character. In other words, if you call it like a builtin function, then it behaves like a builtin function. If you call it like an old-fashioned subroutine, then it @@ -583,10 +632,10 @@ this rule that prototypes have no influence on subroutine references like C<\&foo> or on indirect subroutine calls like C<&{$subref}>. Method calls are not influenced by prototypes either, because the -function to be called is indeterminate at compile time, since it depends +function to be called is indeterminate at compile time, because it depends on inheritance. -Since the intent is primarily to let you define subroutines that work +Because the intent is primarily to let you define subroutines that work like builtin commands, here are the prototypes for some other functions that parse almost exactly like the corresponding builtins. @@ -627,7 +676,7 @@ A semicolon separates mandatory arguments from optional arguments. Note how the last three examples above are treated specially by the parser. mygrep() is parsed as a true list operator, myrand() is parsed as a true unary operator with unary precedence the same as rand(), and -mytime() is truly argumentless, just like time(). That is, if you +mytime() is truly without arguments, just like time(). That is, if you say mytime +2; @@ -645,7 +694,7 @@ The interesting thing about & is that you can generate new syntax with it: &$catch; } } - sub catch (&) { @_ } + sub catch (&) { $_[0] } try { die "phooey"; @@ -657,7 +706,7 @@ That prints "unphooey". (Yes, there are still unresolved issues having to do with the visibility of @_. I'm ignoring that question for the moment. (But note that if we make @_ lexically scoped, those anonymous subroutines can act like closures... (Gee, -is this sounding a little Lispish? (Nevermind.)))) +is this sounding a little Lispish? (Never mind.)))) And here's a reimplementation of grep: @@ -698,23 +747,66 @@ returning a list: Then you've just supplied an automatic scalar() in front of their argument, which can be more than a bit surprising. The old @foo which used to hold one thing doesn't get passed in. Instead, -the func() now gets passed in 1, that is, the number of elments +the func() now gets passed in 1, that is, the number of elements in @foo. And the split() gets called in a scalar context and starts scribbling on your @_ parameter list. -This is all very powerful, of course, and should only be used in moderation +This is all very powerful, of course, and should be used only in moderation to make the world a better place. +=head2 Constant Functions + +Functions with a prototype of C<()> are potential candidates for +inlining. If the result after optimization and constant folding is a +constant then it will be used in place of new-style calls to the +function. Old-style calls (that is, calls made using C<&>) are not +affected. + +All of the following functions would be inlined. + + sub PI () { 3.14159 } + sub ST_DEV () { 0 } + sub ST_INO () { 1 } + + sub FLAG_FOO () { 1 << 8 } + sub FLAG_BAR () { 1 << 9 } + sub FLAG_MASK () { FLAG_FOO | FLAG_BAR } + + sub OPT_BAZ () { 1 } + sub BAZ_VAL () { + if (OPT_BAZ) { + return 23; + } + else { + return 42; + } + } + +If you redefine a subroutine which was eligible for inlining you'll get +a mandatory warning. (You can use this warning to tell whether or not a +particular subroutine is considered constant.) The warning is +considered severe enough not to be optional because previously compiled +invocations of the function will still be using the old value of the +function. If you need to be able to redefine the subroutine you need to +ensure that it isn't inlined, either by dropping the C<()> prototype +(which changes the calling semantics, so beware) or by thwarting the +inlining mechanism in some other way, such as + + my $dummy; + sub not_inlined () { + $dummy || 23 + } + =head2 Overriding Builtin Functions -Many builtin functions may be overridden, though this should only be -tried occasionally and for good reason. Typically this might be +Many builtin functions may be overridden, though this should be tried +only occasionally and for good reason. Typically this might be done by a package attempting to emulate missing builtin functionality on a non-Unix system. -Overriding may only be done by importing the name from a +Overriding may be done only by importing the name from a module--ordinary predeclaration isn't good enough. However, the -C<subs> pragma (compiler directive) lets you, in effect, predeclare subs +C<subs> pragma (compiler directive) lets you, in effect, pre-declare subs via the import syntax, and these names may then override the builtin ones: use subs 'chdir', 'chroot', 'chmod', 'chown'; @@ -722,7 +814,7 @@ via the import syntax, and these names may then override the builtin ones: sub chdir { ... } Library modules should not in general export builtin names like "open" -or "chdir" as part of their default @EXPORT list, since these may +or "chdir" as part of their default @EXPORT list, because these may sneak into someone else's namespace and change the semantics unexpectedly. Instead, if the module adds the name to the @EXPORT_OK list, then it's possible for a user to import the name explicitly, but not implicitly. @@ -767,7 +859,7 @@ should just call system() with those arguments. All you'd do is this: who('am', 'i'); ls('-l'); -In fact, if you preclare the functions you want to call that way, you don't +In fact, if you pre-declare the functions you want to call that way, you don't even need the parentheses: use subs qw(date who ls); diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 459795e7cd..91a601aebb 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -35,7 +35,7 @@ take effect at compile time. Typically all the declarations are put at the beginning or the end of the script. However, if you're using lexically-scoped private variables created with my(), you'll have to make sure your format or subroutine definition is within the same block scope -as the my if you expect to to be able to access those private variables. +as the my if you expect to be able to access those private variables. Declaring a subroutine allows a subroutine name to be used as if it were a list operator from that point forward in the program. You can declare a @@ -63,7 +63,7 @@ The only kind of simple statement is an expression evaluated for its side effects. Every simple statement must be terminated with a semicolon, unless it is the final statement in a block, in which case the semicolon is optional. (A semicolon is still encouraged there if the -block takes up more than one line, since you may eventually add another line.) +block takes up more than one line, because you may eventually add another line.) Note that there are some operators like C<eval {}> and C<do {}> that look like compound statements, but aren't (they're just TERMs in an expression), and thus need an explicit termination if used as the last item in a statement. @@ -91,7 +91,7 @@ can write loops like: } until $line eq ".\n"; See L<perlfunc/do>. Note also that the loop control -statements described later will I<NOT> work in this construct, since +statements described later will I<NOT> work in this construct, because modifiers don't take loop labels. Sorry. You can always wrap another block around it to do that sort of thing. @@ -128,7 +128,7 @@ all do the same thing: open(FOO) ? 'hi mom' : die "Can't open $FOO: $!"; # a bit exotic, that last one -The C<if> statement is straightforward. Since BLOCKs are always +The C<if> statement is straightforward. Because BLOCKs are always bounded by curly brackets, there is never any ambiguity about which C<if> an C<else> goes with. If you use C<unless> in place of C<if>, the sense of the test is reversed. @@ -220,11 +220,8 @@ If the word C<while> is replaced by the word C<until>, the sense of the test is reversed, but the conditional is still tested before the first iteration. -In either the C<if> or the C<while> statement, you may replace "(EXPR)" -with a BLOCK, and the conditional is true if the value of the last -statement in that block is true. While this "feature" continues to work in -version 5, it has been deprecated, so please change any occurrences of "if BLOCK" to -"if (do BLOCK)". +The form C<while/if BLOCK BLOCK>, available in Perl 4, is no longer +available. Replace any occurrence of C<if BLOCK> by C<if (do BLOCK)>. =head2 For Loops @@ -244,6 +241,9 @@ is the same as this: $i++; } +(There is one minor difference: The first form implies a lexical scope +for variables declared with C<my> in the initialization expression.) + Besides the normal array index looping, C<for> can lend itself to many other interesting applications. Here's one that avoids the problem you get into if you explicitly test for end-of-file on @@ -259,12 +259,14 @@ hang. =head2 Foreach Loops The C<foreach> loop iterates over a normal list value and sets the -variable VAR to be each element of the list in turn. The variable is -implicitly local to the loop and regains its former value upon exiting the -loop. If the variable was previously declared with C<my>, it uses that -variable instead of the global one, but it's still localized to the loop. -This can cause problems if you have subroutine or format declarations -within that block's scope. +variable VAR to be each element of the list in turn. If the variable +is preceded with the keyword C<my>, then it is lexically scoped, and +is therefore visible only within the loop. Otherwise, the variable is +implicitly local to the loop and regains its former value upon exiting +the loop. If the variable was previously declared with C<my>, it uses +that variable instead of the global one, but it's still localized to +the loop. (Note that a lexically scoped variable can cause problems +with you have subroutine or format declarations.) The C<foreach> keyword is actually a synonym for the C<for> keyword, so you can use C<foreach> for readability or C<for> for brevity. If VAR is @@ -278,7 +280,7 @@ Examples: for (@ary) { s/foo/bar/ } - foreach $elem (@elements) { + foreach my $elem (@elements) { $elem *= 2; } @@ -294,8 +296,8 @@ Examples: Here's how a C programmer might code up a particular algorithm in Perl: - for ($i = 0; $i < @ary1; $i++) { - for ($j = 0; $j < @ary2; $j++) { + for (my $i = 0; $i < @ary1; $i++) { + for (my $j = 0; $j < @ary2; $j++) { if ($ary1[$i] > $ary2[$j]) { last; # can't go to outer :-( } @@ -307,8 +309,8 @@ Here's how a C programmer might code up a particular algorithm in Perl: Whereas here's how a Perl programmer more comfortable with the idiom might do it: - OUTER: foreach $wid (@ary1) { - INNER: foreach $jet (@ary2) { + OUTER: foreach my $wid (@ary1) { + INNER: foreach my $jet (@ary2) { next OUTER if $wid > $jet; $wid += $jet; } @@ -317,19 +319,19 @@ do it: See how much easier this is? It's cleaner, safer, and faster. It's cleaner because it's less noisy. It's safer because if code gets added between the inner and outer loops later on, the new code won't be -accidentally executed, the C<next> explicitly iterates the other loop +accidentally executed. The C<next> explicitly iterates the other loop rather than merely terminating the inner one. And it's faster because Perl executes a C<foreach> statement more rapidly than it would the equivalent C<for> loop. =head2 Basic BLOCKs and Switch Statements -A BLOCK by itself (labeled or not) is semantically equivalent to a loop -that executes once. Thus you can use any of the loop control -statements in it to leave or restart the block. (Note that this -is I<NOT> true in C<eval{}>, C<sub{}>, or contrary to popular belief C<do{}> blocks, -which do I<NOT> count as loops.) The C<continue> block -is optional. +A BLOCK by itself (labeled or not) is semantically equivalent to a +loop that executes once. Thus you can use any of the loop control +statements in it to leave or restart the block. (Note that this is +I<NOT> true in C<eval{}>, C<sub{}>, or contrary to popular belief +C<do{}> blocks, which do I<NOT> count as loops.) The C<continue> +block is optional. The BLOCK construct is particularly nice for doing case structures. @@ -491,7 +493,7 @@ and your documentation text freely, as in ......... } -Note that pod translators should only look at paragraphs beginning +Note that pod translators should look at only paragraphs beginning with a pod directive (it makes parsing easier), whereas the compiler actually knows to look for pod escapes even in the middle of a paragraph. This means that the following secret stuff will be diff --git a/pod/perltie.pod b/pod/perltie.pod index 7c4314188a..6bfdf5988b 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -13,8 +13,8 @@ perltie - how to hide an object class in a simple variable =head1 DESCRIPTION Prior to release 5.0 of Perl, a programmer could use dbmopen() -to magically connect an on-disk database in the standard Unix dbm(3x) -format to a %HASH in their program. However, their Perl was either +to connect an on-disk database in the standard Unix dbm(3x) +format magically to a %HASH in their program. However, their Perl was either built with one particular dbm library or another, but not both, and you couldn't extend this mechanism to other packages or types of variables. @@ -33,12 +33,12 @@ In the tie() call, C<VARIABLE> is the name of the variable to be enchanted. C<CLASSNAME> is the name of a class implementing objects of the correct type. Any additional arguments in the C<LIST> are passed to the appropriate constructor method for that class--meaning TIESCALAR(), -TIEARRAY(), TIEHASH() or TIEHANDLE(). (Typically these are arguments +TIEARRAY(), TIEHASH(), or TIEHANDLE(). (Typically these are arguments such as might be passed to the dbminit() function of C.) The object returned by the "new" method is also returned by the tie() function, which would be useful if you wanted to access other methods in C<CLASSNAME>. (You don't actually have to return a reference to a right -"type" (e.g. HASH or C<CLASSNAME>) so long as it's a properly blessed +"type" (e.g., HASH or C<CLASSNAME>) so long as it's a properly blessed object.) You can also retrieve a reference to the underlying object using the tied() function. @@ -105,8 +105,8 @@ variable C<$^W> to see whether to emit a bit of noise anyway. This method will be triggered every time the tied variable is accessed (read). It takes no arguments beyond its self reference, which is the -object representing the scalar we're dealing with. Since in this case -we're just using a SCALAR ref for the tied scalar object, a simple $$self +object representing the scalar we're dealing with. Because in this case +we're using just a SCALAR ref for the tied scalar object, a simple $$self allows the method to get at the real value stored there. In our example below, that real value is the process ID to which we've tied our variable. @@ -160,7 +160,7 @@ argument--the new value the user is trying to assign. =item DESTROY this This method will be triggered when the tied variable needs to be destructed. -As with other object classes, such a method is seldom necessary, since Perl +As with other object classes, such a method is seldom necessary, because Perl deallocates its moribund object's memory for you automatically--this isn't C++, you know. We'll use a DESTROY method here for debugging purposes only. @@ -173,7 +173,7 @@ C++, you know. We'll use a DESTROY method here for debugging purposes only. =back That's about all there is to it. Actually, it's more than all there -is to it, since we've done a few nice things here for the sake +is to it, because we've done a few nice things here for the sake of completeness, robustness, and general aesthetics. Simpler TIESCALAR classes are certainly possible. @@ -253,7 +253,7 @@ As you may have noticed, the name of the FETCH method (et al.) is the same for all accesses, even though the constructors differ in names (TIESCALAR vs TIEARRAY). While in theory you could have the same class servicing several tied types, in practice this becomes cumbersome, and it's easiest -to simply keep them at one tie type per class. +to keep them at simply one tie type per class. =item STORE this, index, value @@ -303,8 +303,8 @@ value pairs. FIRSTKEY and NEXTKEY implement the keys() and each() functions to iterate over all the keys. And DESTROY is called when the tied variable is garbage collected. -If this seems like a lot, then feel free to merely inherit -from the standard Tie::Hash module for most of your methods, redefining only +If this seems like a lot, then feel free to inherit from +merely the standard Tie::Hash module for most of your methods, redefining only the interesting ones. See L<Tie::Hash> for details. Remember that Perl distinguishes between a key not existing in the hash, @@ -313,8 +313,8 @@ C<undef>. The two possibilities can be tested with the C<exists()> and C<defined()> functions. Here's an example of a somewhat interesting tied hash class: it gives you -a hash representing a particular user's dotfiles. You index into the hash -with the name of the file (minus the dot) and you get back that dotfile's +a hash representing a particular user's dot files. You index into the hash +with the name of the file (minus the dot) and you get back that dot file's contents. For example: use DotFiles; @@ -323,7 +323,7 @@ contents. For example: $dot{login} =~ /MANPATH/ || $dot{cshrc} =~ /MANPATH/ ) { - print "you seem to set your manpath\n"; + print "you seem to set your MANPATH\n"; } Or here's another sample of using our tied class: @@ -347,7 +347,7 @@ whose dot files this object represents =item HOME -where those dotfiles live +where those dot files live =item CLOBBER @@ -355,7 +355,7 @@ whether we should try to change or remove those dot files =item LIST -the hash of dotfile names and content mappings +the hash of dot file names and content mappings =back @@ -367,7 +367,7 @@ Here's the start of F<Dotfiles.pm>: my $DEBUG = 0; sub debug { $DEBUG = @_ ? shift : 1 } -For our example, we want to able to emit debugging info to help in tracing +For our example, we want to be able to emit debugging info to help in tracing during development. We keep also one convenience function around internally to help print out warnings; whowasi() returns the function name that calls it. @@ -413,7 +413,7 @@ Here's the constructor: It's probably worth mentioning that if you're going to filetest the return values out of a readdir, you'd better prepend the directory -in question. Otherwise, since we didn't chdir() there, it would +in question. Otherwise, because we didn't chdir() there, it would have been testing the wrong file. =item FETCH this, key @@ -445,7 +445,7 @@ Here's the fetch for our DotFiles example. It was easy to write by having it call the Unix cat(1) command, but it would probably be more portable to open the file manually (and somewhat -more efficient). Of course, since dot files are a Unixy concept, we're +more efficient). Of course, because dot files are a Unixy concept, we're not that concerned. =item STORE this, key, value @@ -526,14 +526,14 @@ the caller whether the file was successfully deleted. This method is triggered when the whole hash is to be cleared, usually by assigning the empty list to it. -In our example, that would remove all the user's dotfiles! It's such a +In our example, that would remove all the user's dot files! It's such a dangerous thing that they'll have to set CLOBBER to something higher than 1 to make it happen. sub CLEAR { carp &whowasi if $DEBUG; my $self = shift; - croak "@{[&whowasi]}: won't remove all dotfiles for $self->{USER}" + croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}" unless $self->{CLOBBER} > 1; my $dot; foreach $dot ( keys %{$self->{LIST}}) { @@ -574,8 +574,8 @@ second argument which is the last key that had been accessed. This is useful if you're carrying about ordering or calling the iterator from more than one sequence, or not really storing things in a hash anywhere. -For our example, we're using a real hash so we'll just do the simple -thing, but we'll have to indirect through the LIST field. +For our example, we're using a real hash so we'll do just the simple +thing, but we'll have to go through the LIST field indirectly. sub NEXTKEY { carp &whowasi if $DEBUG; @@ -628,7 +628,7 @@ In our example we're going to create a shouting handle. This is the constructor for the class. That means it is expected to return a blessed reference of some sort. The reference can be used to -hold some internal information. We won't use it in out example. +hold some internal information. sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift } @@ -680,7 +680,7 @@ You cannot easily tie a multilevel data structure (such as a hash of hashes) to a dbm file. The first problem is that all but GDBM and Berkeley DB have size limitations, but beyond that, you also have problems with how references are to be represented on disk. One experimental -module that does attempt to partially address this need is the MLDBM +module that does attempt to address this need partially is the MLDBM module. Check your nearest CPAN site as described in L<perlmod> for source code to MLDBM. diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 81b81ccb42..b8353fcdb1 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -6,220 +6,233 @@ perltoc - perl documentation table of contents =head1 DESCRIPTION This page provides a brief table of contents for the rest of the Perl -documentation set. It is meant to be be quickly scanned or grepped +documentation set. It is meant to be scanned quickly or grepped through to locate the proper section you're looking for. =head1 BASIC DOCUMENTATION - - - =head2 perl - Practical Extraction and Report Language =item SYNOPSIS - =item DESCRIPTION - Many usability enhancements, Simplified grammar, Lexical scoping, Arbitrarily nested data structures, Modularity and reusability, -Object-oriented programming, Embeddable and Extensible, POSIX -compliant, Package constructors and destructors, Multiple simultaneous -DBM implementations, Subroutine definitions may now be autoloaded, -Regular expression enhancements +Object-oriented programming, Embeddable and Extensible, POSIX compliant, +Package constructors and destructors, Multiple simultaneous DBM +implementations, Subroutine definitions may now be autoloaded, Regular +expression enhancements, Innumerable Unbundled Modules, Compilability =item ENVIRONMENT - -HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERLLIB +HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB =item AUTHOR - =item FILES - =item SEE ALSO - =item DIAGNOSTICS - =item BUGS - =item NOTES +=head2 perlnews - what's new for perl5.004 +=item DESCRIPTION +=item Supported Environments +=item Core Changes -=head2 perldata - Perl data types +=over -=item DESCRIPTION +=item Compilation Option: Binary Compatibility With 5.003 +=item New Opcode Module and Revised Safe Module -=over +=item Internal Change: FileHandle Deprecated -=item Variable names +=item Internal Change: PerlIO internal IO abstraction interface +=item New and Changed Built-in Variables -=item Context +$^E, $^H, $^M +=item New and Changed Built-in Functions -=item Scalar values +delete on slices, flock, keys as an lvalue, my() in Control Structures, +unpack() and pack(), use VERSION, use Module VERSION LIST, +prototype(FUNCTION), $_ as Default +=item C<m//g> does not trigger a pos() reset on failure -=item Scalar value constructors +=item New Built-in Methods +isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance() -=item List value constructors +=item TIEHANDLE Now Supported + +TIEHANDLE classname, LIST, PRINT this, LIST, READLINE this, DESTROY this +=back + +=item Pragmata -=item Typeglobs and FileHandles +use blib, use locale, use ops +=item Modules +=over +=item Module Information Summary + +=item IO + +=item Math::Complex + +=item Overridden Built-ins =back +=item Efficiency Enhancements +=item Documentation Changes +L<perlnews>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>, +L<perlsec> -=head2 perlsyn - Perl syntax +=item New Diagnostics -=item DESCRIPTION +"my" variable %s masks earlier declaration in same scope, Allocation too +large: %lx, Allocation too large, Attempt to free non-existent shared +string, Attempt to use reference as lvalue in substr, Unsupported function +fork, Ill-formed logical name |%s| in prime_env_iter, Integer overflow in +hex number, Integer overflow in octal number, Null picture in formline, +Offset outside string, Out of memory!, Out of memory during request for %s, +Possible attempt to put comments in qw() list, Possible attempt to separate +words with commas, untie attempted while %d inner references still exist, +Got an error from DosAllocMem:, Malformed PERLLIB_PREFIX, PERL_SH_DIR too +long, Process terminated by SIG%s +=item BUGS -=over +=item SEE ALSO -=item Declarations +=item HISTORY +=head2 perldata - Perl data types -=item Simple statements +=item DESCRIPTION +=over -=item Compound statements +=item Variable names +=item Context -=item Loop Control +=item Scalar values +=item Scalar value constructors -=item For Loops +=item List value constructors +=item Typeglobs and Filehandles -=item Foreach Loops +=back +=head2 perlsyn - Perl syntax -=item Basic BLOCKs and Switch Statements +=item DESCRIPTION +=over -=item Goto +=item Declarations +=item Simple statements -=item PODs: Embedded Documentation +=item Compound statements +=item Loop Control +=item For Loops +=item Foreach Loops -=back +=item Basic BLOCKs and Switch Statements +=item Goto +=item PODs: Embedded Documentation +=back =head2 perlop - Perl operators and precedence =item SYNOPSIS - =item DESCRIPTION - =over =item Terms and List Operators (Leftward) - =item The Arrow Operator - -=item Autoincrement and Autodecrement - +=item Auto-increment and Auto-decrement =item Exponentiation - =item Symbolic Unary Operators - =item Binding Operators - =item Multiplicative Operators - =item Additive Operators - =item Shift Operators - =item Named Unary Operators - =item Relational Operators - =item Equality Operators - =item Bitwise And - =item Bitwise Or and Exclusive Or - =item C-style Logical And - =item C-style Logical Or - =item Range Operator - =item Conditional Operator - =item Assignment Operators - =item Comma Operator - =item List Operators (Rightward) - =item Logical Not - =item Logical And - =item Logical or and Exclusive Or - =item C Operators Missing From Perl - unary &, unary *, (TYPE) -=item Quote and Quotelike Operators - - -=item Regexp Quotelike Operators +=item Quote and Quote-like Operators +=item Regexp Quote-Like Operators ?PATTERN?, m/PATTERN/gimosx, /PATTERN/gimosx, q/STRING/, C<'STRING'>, qq/STRING/, "STRING", qx/STRING/, `STRING`, qw/STRING/, @@ -228,2903 +241,3255 @@ y/SEARCHLIST/REPLACEMENTLIST/cds =item I/O Operators - =item Constant Folding - -=item Integer arithmetic - - - +=item Integer Arithmetic =back - - - =head2 perlre - Perl regular expressions =item DESCRIPTION +i, m, s, x =over =item Regular Expressions - (?#text), (?:regexp), (?=regexp), (?!regexp), (?imsx) =item Backtracking - =item Version 8 Regular Expressions - =item WARNING on \1 vs $1 - - - =back - - - =head2 perlrun - how to execute the Perl interpreter =item SYNOPSIS - =item DESCRIPTION - =over =item Switches - -B<-0>I<digits>, B<-a>, B<-c>, B<-d>, B<-d:foo>, B<-D>I<number>, -B<-D>I<list>, B<-e> I<commandline>, B<-F>I<regexp>, B<-i>I<extension>, -B<-I>I<directory>, B<-l>I<octnum>, B<-m>I<module>, B<-M>I<module>, -B<-n>, B<-p>, B<-P>, B<-s>, B<-S>, B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, -B<-V:name>, B<-w>, B<-x> I<directory> - - +B<-0>[I<digits>], B<-a>, B<-c>, B<-d>, B<-d:>I<foo>, B<-D>I<number>, +B<-D>I<list>, B<-e> I<commandline>, B<-F>I<pattern>, B<-h>, +B<-i>[I<extension>], B<-I>I<directory>, B<-l>[I<octnum>], +B<-m>[B<->]I<module>, B<-M>[B<->]I<module>, B<-M>[B<->]I<'module ...'>, +B<-[mM]>[B<->]I<module=arg[,arg]...>, B<-n>, B<-p>, B<-P>, B<-s>, B<-S>, +B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, B<-V:>I<name>, B<-w>, B<-x> I<directory> =back - - - =head2 perlfunc - Perl builtin functions =item DESCRIPTION - - + I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!> =over =item Perl Functions by Category - -Functions for SCALARs or strings, Regular expressions and pattern -matching, Numeric functions, Functions for real @ARRAYs, Functions for -list data, Functions for real %HASHes, Input and output functions, -Functions for fixed length data or records, Functions for filehandles, -files, or directories, Keywords related to the control flow of your -perl program, Keywords related to scoping, Miscellaneous functions, -Functions for processes and process groups, Keywords related to perl -modules, Keywords related to classes and object-orientedness, Low-level -socket functions, System V interprocess communication functions, -Fetching user and group info, Fetching network info, Time-related -functions +Functions for SCALARs or strings, Regular expressions and pattern matching, +Numeric functions, Functions for real @ARRAYs, Functions for list data, +Functions for real %HASHes, Input and output functions, Functions for fixed +length data or records, Functions for filehandles, files, or directories, +Keywords related to the control flow of your perl program, Keywords related +to scoping, Miscellaneous functions, Functions for processes and process +groups, Keywords related to perl modules, Keywords related to classes and +object-orientedness, Low-level socket functions, System V interprocess +communication functions, Fetching user and group info, Fetching network +info, Time-related functions, Functions new in perl5, Functions obsoleted +in perl5 =item Alphabetical Listing of Perl Functions - --I<X> FILEHANDLE, -I<X> EXPR, -I<X>, abs VALUE, accept NEWSOCKET,GENERICSOCKET, -alarm SECONDS, atan2 Y,X, bind SOCKET,NAME, binmode FILEHANDLE, bless -REF,CLASSNAME, bless REF, caller EXPR, caller, chdir EXPR, chmod LIST, -chomp VARIABLE, chomp LIST, chomp, chop VARIABLE, chop LIST, chop, -chown LIST, chr NUMBER, chroot FILENAME, close FILEHANDLE, closedir -DIRHANDLE, connect SOCKET,NAME, continue BLOCK, cos EXPR, crypt -PLAINTEXT,SALT, dbmclose ASSOC_ARRAY, dbmopen ASSOC,DBNAME,MODE, -defined EXPR, delete EXPR, die LIST, do BLOCK, do SUBROUTINE(LIST), do -EXPR, dump LABEL, each ASSOC_ARRAY, eof FILEHANDLE, eof (), eof, eval -EXPR, eval BLOCK, exec LIST, exists EXPR, exit EXPR, exp EXPR, fcntl -FILEHANDLE,FUNCTION,SCALAR, fileno FILEHANDLE, flock +-I<X> FILEHANDLE, -I<X> EXPR, -I<X>, abs VALUE, abs, accept +NEWSOCKET,GENERICSOCKET, alarm SECONDS, alarm, atan2 Y,X, bind SOCKET,NAME, +binmode FILEHANDLE, bless REF,CLASSNAME, bless REF, caller EXPR, caller, +chdir EXPR, chmod LIST, chomp VARIABLE, chomp LIST, chomp, chop VARIABLE, +chop LIST, chop, chown LIST, chr NUMBER, chr, chroot FILENAME, chroot, +close FILEHANDLE, closedir DIRHANDLE, connect SOCKET,NAME, continue BLOCK, +cos EXPR, crypt PLAINTEXT,SALT, dbmclose ASSOC_ARRAY, dbmopen +ASSOC,DBNAME,MODE, defined EXPR, defined, delete EXPR, die LIST, do BLOCK, +do SUBROUTINE(LIST), do EXPR, dump LABEL, each ASSOC_ARRAY, eof FILEHANDLE, +eof (), eof, eval EXPR, eval BLOCK, exec LIST, exists EXPR, exit EXPR, exp +EXPR, exp, fcntl FILEHANDLE,FUNCTION,SCALAR, fileno FILEHANDLE, flock FILEHANDLE,OPERATION, fork, format, formline PICTURE, LIST, getc FILEHANDLE, getc, getlogin, getpeername SOCKET, getpgrp PID, getppid, -getpriority WHICH,WHO, getpwnam NAME, getgrnam NAME, gethostbyname -NAME, getnetbyname NAME, getprotobyname NAME, getpwuid UID, getgrgid -GID, getservb - - +getpriority WHICH,WHO, getpwnam NAME, getgrnam NAME, gethostbyname NAME, +getnetbyname NAME, getprotobyname NAME, getpwuid UID, getgrgid GID, +getservbyname NAME,PROTO, gethostbyaddr ADDR,ADDRTYPE, getnetbyaddr +ADDR,ADDRTYPE, getprotobynumber NUMBER, getservbyport PORT,PROTO, getpwent, +getgrent, gethostent, getnetent, getprotoent, getservent, setpwent, +setgrent, sethostent STAYOPEN, setnetent STAYOPEN, setprotoent STAYOPEN, +setservent STAYOPEN, endpwent, endgrent, endhostent, endnetent, +endprotoent, endservent, getsockname SOCKET, getsockopt +SOCKET,LEVEL,OPTNAME, glob EXPR, gmtime EXPR, goto LABEL, goto EXPR, goto +&NAME, grep BLOCK LIST, grep EXPR,LIST, hex EXPR, hex, import, index +STR,SUBSTR,POSITION, index STR,SUBSTR, int EXPR, int, ioctl +FILEHANDLE,FUNCTION,SCALAR, join EXPR,LIST, keys ASSOC_ARRAY, kill LIST, +last LABEL, last, lc EXPR, lc, lcfirst EXPR, lcfirst, length EXPR, length, +link OLDFILE,NEWFILE, listen SOCKET,QUEUESIZE, local EXPR, localtime EXPR, +log EXPR, log, lstat FILEHANDLE, lstat EXPR, lstat, m//, map BLOCK LIST, +map EXPR,LIST, mkdir FILENAME,MODE, msgctl ID,CMD,ARG, msgget KEY,FLAGS, +msgsnd ID,MSG,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, my EXPR, next LABEL, +next, no Module LIST, oct EXPR, oct, open FILEHANDLE,EXPR, open FILEHANDLE, +opendir DIRHANDLE,EXPR, ord EXPR, ord, pack TEMPLATE,LIST, package +NAMESPACE, pipe READHANDLE,WRITEHANDLE, pop ARRAY, pop, pos SCALAR, pos, +print FILEHANDLE LIST, print LIST, print, printf FILEHANDLE FORMAT, LIST, +printf FORMAT, LIST, prototype FUNCTION, push ARRAY,LIST, q/STRING/, +qq/STRING/, qx/STRING/, qw/STRING/, quotemeta EXPR, quotemeta, rand EXPR, +rand, read FILEHANDLE,SCALAR,LENGTH,OFFSET, read FILEHANDLE,SCALAR,LENGTH, +readdir DIRHANDLE, readlink EXPR, readlink, recv SOCKET,SCALAR,LEN,FLAGS, +redo LABEL, redo, ref EXPR, ref, rename OLDNAME,NEWNAME, require EXPR, +require, reset EXPR, reset, return LIST, reverse LIST, rewinddir DIRHANDLE, +rindex STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME, rmdir, s///, +scalar EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir DIRHANDLE,POS, select +FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT, semctl +ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send +SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority +WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY, +shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE, +shmwrite ID,STRING,POS,SIZE, shutdown SOCKET,HOW, sin EXPR, sin, sleep +EXPR, sleep, socket SOCKET,DOMAIN,TYPE,PROTOCOL, socketpair +SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, sort SUBNAME LIST, sort BLOCK LIST, +sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH, +splice ARRAY,OFFSET, split /PATTERN/,EXPR,LIMIT, split /PATTERN/,EXPR, +split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, sqrt, srand EXPR, +stat EXPR, stat, study SCALAR, study, sub BLOCK, sub NAME, sub NAME BLOCK, +substr EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink OLDFILE,NEWFILE, +syscall LIST, sysopen FILEHANDLE,FILENAME,MODE, sysopen +FILEHANDLE,FILENAME,MODE,PERMS, sysread FILEHANDLE,SCALAR,LENGTH,OFFSET, +sysread FILEHANDLE,SCALAR,LENGTH, system LIST, syswrite +FILEHANDLE,SCALAR,LENGTH, tell FILEHANDLE, tell, telldir DIRHANDLE, tie +VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate +FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, +ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack +TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module LIST, use +Module, use Module VERSION LIST, use VERSION, utime LIST, values +ASSOC_ARRAY, vec EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn +LIST, write FILEHANDLE, write EXPR, write, y/// =back - - - =head2 perlvar - Perl predefined variables =item DESCRIPTION - =over =item Predefined Names - -$ARG, $_, $<I<digit>>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $', -$LAST_PAREN_MATCH, $+, $MULTILINE_MATCHING, $*, input_line_number -HANDLE EXPR, $INPUT_LINE_NUMBER, $NR, $, input_record_separator HANDLE -EXPR, $INPUT_RECORD_SEPARATOR, $RS, $/, autoflush HANDLE EXPR, -$OUTPUT_AUTOFLUSH, $|, output_field_separator HANDLE EXPR, -$OUTPUT_FIELD_SEPARATOR, $OFS, $,, output_record_separator HANDLE EXPR, -$OUTPUT_RECORD_SEPARATOR, $ORS, $\, $LIST_SEPARATOR, $", -$SUBSCRIPT_SEPARATOR, $SUBSEP, $;, $OFMT, $#, format_page_number HANDLE -EXPR, $FORMAT_PAGE_NUMBER, $%, format_lines_per_page HANDLE EXPR, -$FORMAT_LINES_PER_PAGE, $=, format_lines_left HANDLE EXPR, -$FORMAT_LINES_LEFT, $-, format_name HANDLE EXPR, $FORMAT_NAME, $~, -format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^, -format_line_break_characters HANDLE EXPR, -$FORMAT_LINE_BREAK_CHARACTERS, $:, format_formfeed HANDLE EXPR, -$FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A, $CHILD_ERROR, $?, $OS_ERROR, -$ERRNO, $!, $EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, -$UID, $<, - - +$ARG, $_, $E<lt>I<digit>E<gt>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $', +$LAST_PAREN_MATCH, $+, $MULTILINE_MATCHING, $*, input_line_number HANDLE +EXPR, $INPUT_LINE_NUMBER, $NR, $, input_record_separator HANDLE EXPR, +$INPUT_RECORD_SEPARATOR, $RS, $/, autoflush HANDLE EXPR, $OUTPUT_AUTOFLUSH, +$|, output_field_separator HANDLE EXPR, $OUTPUT_FIELD_SEPARATOR, $OFS, $,, +output_record_separator HANDLE EXPR, $OUTPUT_RECORD_SEPARATOR, $ORS, $\, +$LIST_SEPARATOR, $", $SUBSCRIPT_SEPARATOR, $SUBSEP, $;, $OFMT, $#, +format_page_number HANDLE EXPR, $FORMAT_PAGE_NUMBER, $%, +format_lines_per_page HANDLE EXPR, $FORMAT_LINES_PER_PAGE, $=, +format_lines_left HANDLE EXPR, $FORMAT_LINES_LEFT, $-, format_name HANDLE +EXPR, $FORMAT_NAME, $~, format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^, +format_line_break_characters HANDLE EXPR, $FORMAT_LINE_BREAK_CHARACTERS, +$:, format_formfeed HANDLE EXPR, $FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A, +$CHILD_ERROR, $?, $OS_ERROR, $ERRNO, $!, $EXTENDED_OS_ERROR, $^E, +$EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, $UID, $<, +$EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, $GID, $(, +$EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $PERL_VERSION, $], +$DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, $INPLACE_EDIT, $^I, $OSNAME, +$^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X, +$ARGV, @ARGV, @INC, %INC, $ENV{expr}, $SIG{expr} =back - - - =head2 perlsub - Perl subroutines =item SYNOPSIS - =item DESCRIPTION - =over =item Private Variables via my() - =item Temporary Values via local() - =item Passing Symbol Table Entries (typeglobs) - =item Pass by Reference - =item Prototypes +=item Constant Functions =item Overriding Builtin Functions - =item Autoloading - - - =back =item SEE ALSO - - - - =head2 perlmod - Perl modules (packages) =item DESCRIPTION - =over =item Packages - =item Symbol Tables - =item Package Constructors and Destructors - =item Perl Classes - =item Perl Modules - - - =back =item NOTE - =item THE PERL MODULE LIBRARY - =over =item Pragmatic Modules - -diagnostics, integer, less, overload, sigtrap, strict, subs +blib, diagnostics, integer, less, lib, locale, ops, overload, sigtrap, +strict, subs, vars =item Standard Modules - -AnyDBM_File, AutoLoader, AutoSplit, Benchmark, Carp, Config, Cwd, -DB_File, Devel::SelfStubber, DynaLoader, English, Env, Exporter, -ExtUtils::Liblist, ExtUtils::MakeMaker, ExtUtils::Manifest, -ExtUtils::Mkbootstrap, ExtUtils::Miniperl, Fcntl, File::Basename, -File::CheckTree, File::Find, FileHandle, File::Path, Getopt::Long, -Getopt::Std, I18N::Collate, IPC::Open2, IPC::Open3, Net::Ping, POSIX, -SelfLoader, Safe, Socket, Test::Harness, Text::Abbrev +AnyDBM_File, AutoLoader, AutoSplit, Benchmark, CPAN, CPAN::FirstTime, +CPAN::Nox, Carp, Class::Template, Config, Cwd, DB_File, Devel::SelfStubber, +DirHandle, DynaLoader, English, Env, Exporter, ExtUtils::Embed, +ExtUtils::Install, ExtUtils::Liblist, ExtUtils::MM_OS2, ExtUtils::MM_Unix, +ExtUtils::MM_VMS, ExtUtils::MakeMaker, ExtUtils::Manifest, +ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fatal, +Fcntl, File::Basename, File::CheckTree, File::Compare, File::Copy, +File::Find, File::Path, File::stat, FileCache, FileHandle, FindBin, +GDBM_File, Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File, +IO::Handle, IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2, +IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, NDBM_File, +Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, Opcode, +Pod::Text, POSIX, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, +Shell, Socket, Symbol, Sys::Hostname, Sys::Syslog, Term::Cap, +Term::Complete, Term::ReadLine, Test::Harness, Text::Abbrev, +Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash, +Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, +Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent =item Extension Modules +=back + +=item CPAN + +Language Extensions and Documentation Tools, Development Support, Operating +System Interfaces, Networking, Device Control (modems) and InterProcess +Communication, Data Types and Data Type Utilities, Database Interfaces, +User Interfaces, Interfaces to / Emulations of Other Programming Languages, +File Names, File Systems and File Locking (see also File Handles), String +Processing, Language Text Processing, Parsing, and Searching, Option, +Argument, Parameter, and Configuration File Processing, +Internationalization and Locale, Authentication, Security, and Encryption, +World Wide Web, HTML, HTTP, CGI, MIME, Server and Daemon Utilities, +Archiving and Compression, Images, Pixmap and Bitmap Manipulation, Drawing, +and Graphing, Mail and Usenet News, Control Flow Utilities (callbacks and +exceptions etc), File Handle and Input/Output Stream Utilities, +Miscellaneous Modules + +=item Modules: Creation, Use, and Abuse + +=over + +=item Guidelines for Module Creation + +Do similar modules already exist in some form?, Try to design the new +module to be easy to extend and reuse, Some simple style guidelines, Select +what to export, Select a name for the module, Have you got it right?, +README and other Additional Files, A description of the +module/package/extension etc, A copyright notice - see below, Prerequisites +- what else you may need to have, How to build it - possible changes to +Makefile.PL etc, How to install it, Recent changes in this release, +especially incompatibilities, Changes / enhancements you plan to make in +the future, Adding a Copyright Notice, Give the module a +version/issue/release number, How to release and distribute a module, Take +care when changing a released module + +=item Guidelines for Converting Perl 4 Library Scripts into Modules + +There is no requirement to convert anything, Consider the implications, +Make the most of the opportunity, The pl2pm utility will get you started, +Adds the standard Module prologue lines, Converts package specifiers from ' +to ::, Converts die(...) to croak(...), Several other minor changes +=item Guidelines for Reusing Application Code +Complete applications rarely belong in the Perl Module Library, Many +applications contain some perl code which could be reused, Break-out the +reusable code into one or more separate module files, Take the opportunity +to reconsider and redesign the interfaces, In some cases the 'application' +can then be reduced to a small =back -=item CPAN +=head2 perlform - Perl formats + +=item DESCRIPTION +=over -Language Extensions and Documentation Tools, Development Support, -Operating System Interfaces, Networking, Device Control (modems) and -InterProcess Communication, Data Types and Data Type Utilities, -Database Interfaces, User Interfaces, Interfaces to / Emulations of -Other Programming Languages, File Names, File Systems and File Locking -(see also File Handles), String Processing, Language Text Processing, -Parsing and Searching, Option, Argument, Parameter and Configuration -File Processing, Internationalization and Locale, Authentication, -Security and Encryption, World Wide Web, HTML, HTTP, CGI, MIME, Server -and Daemon Utilities, Archiving and Compression, Images, Pixmap and -Bitmap Manipulation, Drawing and Graphing, Mail and Usenet News, -Control Flow Utilities (callbacks and exceptions etc), File Handle and -Input/Output Stream Utilities, Miscellaneous Modules +=item Format Variables -=item Modules: Creation, Use and Abuse +=back +=item NOTES =over -=item Guidelines for Module Creation +=item Footers +=item Accessing Formatting Internals -Do similar modules already exist in some form?, Try to design the new -module to be easy to extend and reuse, Some simple style guidelines, -Select what to export, Select a name for the module, Have you got it -right?, README and other Additional Files, A description of the -module/package/extension etc, A copyright notice - see below, -Prerequisites - what else you may need to have, How to build it - -possible changes to Makefile.PL etc, How to install it, Recent changes -in this release, especially incompatibilities, Changes / enhancements -you plan to make in the future, Adding a Copyright Notice, Give the -module a version/issue/release number, How to release and distribute a -module, Take care when changing a released module +=back -=item Guidelines for Converting Perl 4 Library Scripts into Modules +=item WARNINGS +=head2 perllocale - Perl locale handling (internationalization and +localization) -There is no requirement to convert anything, Consider the implications, -Make the most of the opportunity, The pl2pm utility will get you -started, Adds the standard Module prologue lines, Converts package -specifiers from ' to ::, Converts die(...) to croak(...), Several other -minor changes +=item DESCRIPTION -=item Guidelines for Reusing Application Code +=item PREPARING TO USE LOCALES +=item USING LOCALES -Complete applications rarely belong in the Perl Module Library, Many -applications contain some perl code which could be reused, Break-out -the reusable code into one or more separate module files, Take the -opportunity to reconsider and redesign the interfaces, In some cases -the 'application' can then be reduced to a small +=over +=item The use locale pragma +=item The setlocale function + +=item The localeconv function =back +=item LOCALE CATEGORIES +=over +=item Category LC_COLLATE: Collation -=head2 perlref - Perl references and nested data structures +=item Category LC_CTYPE: Character Types -=item DESCRIPTION +=item Category LC_NUMERIC: Numeric Formatting + +=item Category LC_MONETARY: Formatting of monetary amounts + +=item LC_TIME + +=item Other categories + +=back +=item SECURITY + +B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):, +B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or <\U>), +B<Matching operator> (C<m//>):, B<Substitution operator> (C<s///>):, +B<In-memory formatting function> (sprintf()):, B<Output formatting +functions> (printf() and write()):, B<Case-mapping functions> (lc(), +lcfirst(), uc(), ucfirst()):, B<POSIX locale-dependent functions> +(localeconv(), strcoll(),strftime(), strxfrm()):, B<POSIX character class +tests> (isalnum(), isalpha(), isdigit(),isgraph(), islower(), isprint(), +ispunct(), isspace(), isupper(), +isxdigit()): + +=item ENVIRONMENT + +PERL_BADLANG, LC_ALL, LC_CTYPE, LC_COLLATE, LC_MONETARY, LC_NUMERIC, +LC_TIME, LANG + +=item NOTES =over -=item Symbolic references +=item Backward compatibility +=item I18N:Collate obsolete -=item Not-so-symbolic references +=item Sort speed and memory use impacts + +=item write() and LC_NUMERIC +=item Freely available locale definitions +=item I18n and l10n +=item An imperfect standard =back -=item WARNING +=item BUGS +=over + +=item Broken systems + +=back =item SEE ALSO +=item HISTORY + +=head2 perlref - Perl references and nested data structures + +=item DESCRIPTION + +=over + +=item Symbolic references + +=item Not-so-symbolic references +=back +=item WARNING +=item SEE ALSO =head2 perldsc - Perl Data Structures Cookbook =item DESCRIPTION - arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes, -more elaborate constructs, recursive and self-referential data -structures, objects +more elaborate constructs =item REFERENCES - =item COMMON MISTAKES - =item CAVEAT ON PRECEDENCE - =item WHY YOU SHOULD ALWAYS C<use strict> - =item DEBUGGING - =item CODE EXAMPLES - =item LISTS OF LISTS - =over =item Declaration of a LIST OF LISTS - =item Generation of a LIST OF LISTS - =item Access and Printing of a LIST OF LISTS - - - =back =item HASHES OF LISTS - =over =item Declaration of a HASH OF LISTS - =item Generation of a HASH OF LISTS - =item Access and Printing of a HASH OF LISTS - - - =back =item LISTS OF HASHES - =over =item Declaration of a LIST OF HASHES - =item Generation of a LIST OF HASHES - =item Access and Printing of a LIST OF HASHES - - - =back =item HASHES OF HASHES - =over =item Declaration of a HASH OF HASHES - =item Generation of a HASH OF HASHES - =item Access and Printing of a HASH OF HASHES - - - =back =item MORE ELABORATE RECORDS - =over =item Declaration of MORE ELABORATE RECORDS - =item Declaration of a HASH OF COMPLEX RECORDS - =item Generation of a HASH OF COMPLEX RECORDS +=back +=item Database Ties +=item SEE ALSO -=back +=item AUTHOR -=item Database Ties +=head2 perllol, perlLoL - Manipulating Lists of Lists in Perl +=item DESCRIPTION -=item SEE ALSO +=item Declaration and Access of Lists of Lists +=item Growing Your Own + +=item Access and Printing + +=item Slices + +=item SEE ALSO =item AUTHOR +=head2 perltoot - Tom's object-oriented tutorial for perl +=item DESCRIPTION +=item Creating a Class +=over -=head2 perllol, perlLoL - Manipulating Lists of Lists in Perl +=item Object Representation -=item DESCRIPTION +=item Class Interface +=item Constructors and Instance Methods -=item Declaration and Access of Lists of Lists +=item Planning for the Future: Better Constructors +=item Destructors -=item Growing Your Own +=item Other Object Methods +=back -=item Access and Printing +=item Class Data +=over -=item Slices +=item Accessing Class Data +=item Debugging Methods -=item SEE ALSO +=item Class Destructors +=item Documenting the Interface -=item AUTHOR +=back +=item Aggregation +=item Inheritance +=over +=item Overridden Methods -=head2 perlobj - Perl objects +=item Multiple Inheritance -=item DESCRIPTION +=item UNIVERSAL: The Root of All Objects +=back + +=item Alternate Object Representations =over -=item An Object is Simply a Reference +=item Arrays as Objects +=item Closures as Objects -=item A Class is Simply a Package +=back +=item AUTOLOAD: Proxy Methods -=item A Method is Simply a Subroutine +=over +=item Autoloaded Data Methods -=item Method Invocation +=item Inherited Autoloaded Data Methods +=back -=item Destructors +=item Metaclassical Tools +=over -=item WARNING +=item Class::Template +=item Data Members as Variables -=item Summary +=item NOTES +=item Object Terminology -=item Two-Phased Garbage Collection +=back +=item SEE ALSO + +=item COPYRIGHT +=over +=item Acknowledgments =back -=item SEE ALSO +=head2 perlobj - Perl objects + +=item DESCRIPTION + +=over +=item An Object is Simply a Reference + +=item A Class is Simply a Package + +=item A Method is Simply a Subroutine + +=item Method Invocation + +=item Default UNIVERSAL methods + +isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance() +=item Destructors +=item WARNING +=item Summary + +=item Two-Phased Garbage Collection + +=back + +=item SEE ALSO =head2 perltie - how to hide an object class in a simple variable =item SYNOPSIS - =item DESCRIPTION - =over =item Tying Scalars - TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this =item Tying Arrays - TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value, DESTROY this =item Tying Hashes - -USER, HOME, CLOBBER, LIST, TIEHASH classname, LIST, FETCH this, key, -STORE this, key, value, DELETE this, key, CLEAR this, EXISTS this, key, -FIRSTKEY this, NEXTKEY this, lastkey, DESTROY this +USER, HOME, CLOBBER, LIST, TIEHASH classname, LIST, FETCH this, key, STORE +this, key, value, DELETE this, key, CLEAR this, EXISTS this, key, FIRSTKEY +this, NEXTKEY this, lastkey, DESTROY this =item Tying FileHandles - - +TIEHANDLE classname, LIST, PRINT this, LIST, READLINE this, DESTROY this =back =item SEE ALSO - =item BUGS - =item AUTHOR - - - - =head2 perlbot - Bag'o Object Tricks (the BOT) =item DESCRIPTION - =item OO SCALING TIPS - =item INSTANCE VARIABLES - =item SCALAR INSTANCE VARIABLES - =item INSTANCE VARIABLE INHERITANCE - =item OBJECT RELATIONSHIPS - =item OVERRIDING SUPERCLASS METHODS - =item USING RELATIONSHIP WITH SDBM - =item THINKING OF CODE REUSE - =item CLASS CONTEXT AND THE OBJECT - =item INHERITING A CONSTRUCTOR - =item DELEGATION +=head2 perlipc - Perl interprocess communication (signals, fifos, pipes, +safe subprocesses, sockets, and semaphores) +=item DESCRIPTION +=item Signals +=item Named Pipes -=head2 perldebug - Perl debugging - -=item DESCRIPTION - +=item Using open() for IPC =over -=item Debugging - +=item Safe Pipe Opens -h, T, s, n, f, c, c line, <CR>, l min+incr, l min-max, l line, l, -, w -line, l subname, /pattern/, ?pattern?, L, S, t, b line [ condition ], b -subname [ condition ], d line, D, a line command, A, < command, > -command, V package [symbols], X [symbols], ! number, ! -number, H --number, q or ^D, command, p expr +=item Bidirectional Communication -=item Customization +=back +=item Sockets: Client/Server Communication -=item Other resources +=over +=item Internet TCP Clients and Servers +=item Unix-Domain TCP Clients and Servers +=item UDP: Message Passing =back -=item BUGS - - - - - -=head2 perldiag - various Perl diagnostics +=item SysV IPC -=item DESCRIPTION +=item WARNING +=item NOTES +=item BUGS +=item AUTHOR +=item SEE ALSO -=head2 perlform - Perl formats +=head2 perldebug - Perl debugging =item DESCRIPTION +=item The Perl Debugger =over -=item Format Variables - - +=item Debugger Commands +h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n, +E<lt>CRE<gt>, c [line|sub], l, l min+incr, l min-max, l line, l subname, -, +w [line], f filename, /pattern/, ?pattern?, L, S [[!]pattern], t, t expr, b +[line] [condition], b subname [condition], b postpone subname [condition], +b load filename, d [line], D, a [line] command, A, O [opt[=val]] [opt"val"] +[opt?].., recallCommand, ShellBang, pager, tkRunning, signalLevel, +warnLevel, dieLevel, AutoTrace, LineInfo, C<inhibit_exit>, C<PrintRet>, +C<frame>, arrayDepth, hashDepth, compactDump, veryCompact, globPrint, +DumpDBFiles, DumpPackages, quote, HighBit, undefPrint, C<TTY>, noTTY, +C<noTTY>, C<ReadLine>, C<NonStop>, E<lt> [ command ], E<lt>E<lt> command, +E<gt> command, E<gt>E<gt> command, { [ command ], {{ command, ! number, ! +-number, ! pattern, !! cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, = +[alias value], command, p expr -=back - -=item NOTES +=item Debugger Customization +=item Readline Support -=over +=item Editor Support for Debugging -=item Footers - - -=item Accessing Formatting Internals +=item The Perl Profiler +=item Debugger support in perl +=item Debugger Internals +=item Other resources =back -=item WARNING - - +=item BUGS +=head2 perldiag - various Perl diagnostics +=item DESCRIPTION -=head2 perlipc - Perl interprocess communication (signals, fifos, -pipes, safe subprocesses, sockets, and semaphores) +=head2 perlsec - Perl security =item DESCRIPTION +=over -=item Signals +=item Laundering and Detecting Tainted Data +=item Cleaning Up Your Path -=item Named Pipes +=item Security Bugs +=back -=item Using open() for IPC +=head2 perltrap - Perl traps for the unwary +=item DESCRIPTION =over -=item Safe Pipe Opens +=item Awk Traps +=item C Traps -=item Bidirectional Communication +=item Sed Traps +=item Shell Traps +=item Perl Traps +=item Perl4 to Perl5 Traps -=back +Discontinuance, Deprecation, and BugFix traps, Parsing Traps, Numerical +Traps, General data type traps, Context Traps - scalar, list contexts, +Precedence Traps, General Regular Expression Traps using s///, etc, +Subroutine, Signal, Sorting Traps, OS Traps, DBM Traps, Unclassified Traps -=item Sockets: Client/Server Communication +=item Discontinuance, Deprecation, and BugFix traps +Discontinuance, Deprecation, BugFix, Discontinuance, Discontinuance, +Discontinuance, BugFix, Discontinuance, Discontinuance, BugFix, +Discontinuance, Deprecation, Discontinuance -=over +=item Parsing Traps -=item Internet TCP Clients and Servers +Parsing, Parsing, Parsing +=item Numerical Traps -=item Unix-Domain TCP Clients and Servers +Numerical, Numerical, Numerical +=item General data type traps -=item UDP: Message Passing +(Arrays), (Arrays), (Hashes), (Globs), (Scalar String), (Constants), +(Scalars), (Variable Suicide) +=item Context Traps - scalar, list contexts +(list context), (scalar context), (scalar context), (list, builtin) +=item Precedence Traps -=back +Precedence, Precedence, Precedence, Precedence, Precedence, Precedence, +Precedence -=item SysV IPC +=item General Regular Expression Traps using s///, etc. +Regular Expression, Regular Expression, Regular Expression, Regular +Expression, Regular Expression, Regular Expression, Regular Expression, +Regular Expression -=item WARNING +=item Subroutine, Signal, Sorting Traps +(Signals), (Sort Subroutine), warn() won't let you specify a filehandle -=item NOTES +=item OS Traps +(SysV), (SysV) -=item BUGS +=item Interpolation Traps +Interpolation, Interpolation, Interpolation, Interpolation, Interpolation, +Interpolation, Interpolation, Interpolation, Interpolation -=item AUTHOR +=item DBM Traps +DBM, DBM -=item SEE ALSO +=item Unclassified Traps +Unclassified +=back +=head2 perlstyle - Perl style guide +=item DESCRIPTION -=head2 perlsec - Perl security +=head2 perlpod - plain old documentation =item DESCRIPTION +=item Embedding Pods in Perl Modules +=item Common Pod Pitfalls +=item SEE ALSO +=item AUTHOR -=head2 perltrap - Perl traps for the unwary +=head2 perlbook - Perl book information =item DESCRIPTION +=head2 perlembed - how to embed perl in your C program -=over - -=item Awk Traps +=item DESCRIPTION +=over -=item C Traps +=item PREAMBLE +B<Use C from Perl?>, B<Use a UNIX program from Perl?>, B<Use Perl from +Perl?>, B<Use C from C?>, B<Use Perl from C?> -=item Sed Traps +=item ROADMAP +=item Compiling your C program -=item Shell Traps +=item Adding a Perl interpreter to your C program +=item Calling a Perl subroutine from your C program -=item Perl Traps +=item Evaluating a Perl statement from your C program +=item Performing Perl pattern matches and substitutions from your C program -=item Perl4 Traps +=item Fiddling with the Perl stack from your C program +=item Maintaining a persistent interpreter +=item Maintaining multiple interpreter instances +=item Using Perl modules, which themselves use C libraries, from your C +program =back +=item MORAL +=item AUTHOR +=head2 perlapio - perl's IO abstraction interface. -=head2 perlstyle - Perl style guide +=item SYNOPSIS =item DESCRIPTION +B<PerlIO *>, B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>, +B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>, +B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>, +B<PerlIO_stdoutf(fmt,...)>, B<PerlIO_read(f,buf,count)>, +B<PerlIO_write(f,buf,count)>, B<PerlIO_close(f)>, B<PerlIO_puts(s,f)>, +B<PerlIO_putc(c,f)>, B<PerlIO_ungetc(c,f)>, B<PerlIO_getc(f)>, +B<PerlIO_eof(f)>, B<PerlIO_error(f)>, B<PerlIO_fileno(f)>, +B<PerlIO_clearerr(f)>, B<PerlIO_flush(f)>, B<PerlIO_tell(f)>, +B<PerlIO_seek(f,o,w)>, B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>, +B<PerlIO_rewind(f)>, B<PerlIO_tmpfile()> +=over + +=item Co-existence with stdio +B<PerlIO_importFILE(f,flags)>, B<PerlIO_exportFILE(f,flags)>, +B<PerlIO_findFILE(f)>, B<PerlIO_releaseFILE(p,f)>, B<PerlIO_setlinebuf(f)>, +B<PerlIO_has_cntptr(f)>, B<PerlIO_get_ptr(f)>, B<PerlIO_get_cnt(f)>, +B<PerlIO_canset_cnt(f)>, B<PerlIO_fast_gets(f)>, +B<PerlIO_set_ptrcnt(f,p,c)>, B<PerlIO_set_cnt(f,c)>, B<PerlIO_has_base(f)>, +B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)> +=back =head2 perlxs - XS language reference manual =item DESCRIPTION - =over =item Introduction - =item On The Road - =item The Anatomy of an XSUB - =item The Argument Stack - =item The RETVAL Variable - =item The MODULE Keyword - =item The PACKAGE Keyword - =item The PREFIX Keyword - =item The OUTPUT: Keyword - =item The CODE: Keyword - =item The INIT: Keyword - =item The NO_INIT Keyword - =item Initializing Function Parameters - =item Default Parameter Values - =item The PREINIT: Keyword +=item The SCOPE: Keyword =item The INPUT: Keyword - =item Variable-length Parameter Lists - =item The PPCODE: Keyword - =item Returning Undef And Empty Lists - =item The REQUIRE: Keyword - =item The CLEANUP: Keyword - =item The BOOT: Keyword - =item The VERSIONCHECK: Keyword - =item The PROTOTYPES: Keyword - =item The PROTOTYPE: Keyword - =item The ALIAS: Keyword - =item The INCLUDE: Keyword - =item The CASE: Keyword - =item The & Unary Operator - =item Inserting Comments and C Preprocessor Directives - =item Using XS With C++ - =item Interface Strategy - =item Perl Objects And C Structures - =item The Typemap - - - =back =item EXAMPLES - =item XS VERSION - =item AUTHOR - - - - -=head2 perlxstut, perlXStut - Tutorial for XSUB's +=head2 perlxstut, perlXStut - Tutorial for XSUBs =item DESCRIPTION - =over =item VERSION CAVEAT - =item DYNAMIC VERSUS STATIC - =item EXAMPLE 1 - =item EXAMPLE 2 - =item WHAT HAS GONE ON? +=item WRITING GOOD TEST SCRIPTS =item EXAMPLE 3 - =item WHAT'S NEW HERE? - =item INPUT AND OUTPUT PARAMETERS - =item THE XSUBPP COMPILER - =item THE TYPEMAP FILE - =item WARNING +=item EXAMPLE 4 -=item SPECIFYING ARGUMENTS TO XSUBPP +=item WHAT HAS HAPPENED HERE? +=item SPECIFYING ARGUMENTS TO XSUBPP =item THE ARGUMENT STACK - =item EXTENDING YOUR EXTENSION - =item DOCUMENTING YOUR EXTENSION - =item INSTALLING YOUR EXTENSION - =item SEE ALSO - =item Author - =item Last Changed - - - =back - - - =head2 perlguts - Perl's Internal Functions =item DESCRIPTION +=over =item Datatypes - -=over - =item What is an "IV"? - =item Working with SV's - =item What's Really Stored in an SV? - =item Working with AV's - =item Working with HV's - =item References - =item Blessed References and Class Objects - - - -=back - =item Creating New Variables +=item Reference Counts and Mortality -=item XSUB's and the Argument Stack - - -=item Mortality - - -=item Stashes - +=item Stashes and Globs =item Magic - -=over - =item Assigning Magic - =item Magic Virtual Tables - =item Finding Magic - - - -=back - =item Double-Typed SV's +=item XSUB's and the Argument Stack =item Calling Perl Routines from within C Programs - =item Memory Allocation +=item PerlIO -=item API LISTING +=item Scratchpads +=item Putting a C value on Perl stack -AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop, -av_push, av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, -CvSTASH, DBsingle, DBsub, dMARK, dORIGMARK, dSP, dXSARGS, ENTER, -EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME, G_NOARGS, -G_SCALAR, gv_stashpv, gv_stashsv, GvSV, he_free, hv_clear, hv_delete, -hv_exists, hv_fetch, hv_iterinit, hv_iterkey, hv_iternext, -hv_iternextsv, hv_iterval, hv_magic, HvNAME, hv_store, hv_undef, -isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, items, LEAVE, -MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_len, mg_magical, -mg_set, Move, na, New, Newc, Newz, newAV, newHV, newRV, newSV, newSViv, -newSVnv, newSVpv, newSVrv, newSVsv, newXS, newXSproto, Nullav, Nullch, -Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc, perl_call_argv, -perl_call_method, perl_call_pv, perl_call_sv, perl_construct, -perl_destruct, perl_eval_sv, perl_free, perl_get_av, perl_get_cv, -perl_get_hv, perl_get_sv, perl_parse, perl_require_pv, perl_run, POPi, -POPl, POPp, POPn, POPs, +=item Scratchpads -=item AUTHOR +=item Scratchpads and recursions +=item API LISTING -=item DATE - +AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop, av_push, +av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, CvSTASH, +DBsingle, DBsub, DBtrace, dMARK, dORIGMARK, dowarn, dSP, dXSARGS, dXSI32, +dXSI32, ENTER, EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME, +G_NOARGS, G_SCALAR, gv_fetchmeth, gv_fetchmethod, gv_stashpv, gv_stashsv, +he_free, he_delayfree, hv_clear, hv_delete, hv_exists, hv_fetch, +hv_iterinit, hv_iterkey, hv_iternext, hv_iternextsv, hv_iterval, hv_magic, +HvNAME, hv_store, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, +isUPPER, items, ix, LEAVE, MARK, mg_clear, mg_copy, mg_find, mg_free, +mg_get, mg_len, mg_magical, mg_set, Move, na, New, Newc, Newz, newAV, +newHV, newRV_inc, newRV_noinc, newSV, newSViv, newSVnv, newSVpv, newSVrv, +newSVsv, newXS, newXSproto, Nullav, Nullch, Nullcv, Nullhv, Nullsv, +ORIGMARK, perl_alloc, perl_call_argv, perl_call_method, perl_call_pv, +perl_call_sv, perl_construct, perl_destruct, perl_eval_sv, perl_free, +perl_get_av, perl_get_cv, perl_get_hv, perl_get_sv, perl_parse, +perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi, +PUSHn, PUSHp, PUSHs, PUTBACK, Renew, Renewc, RETVAL, safefree, safemalloc, +saferealloc, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, +strGT, strLE, strLT, strNE, strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv, +sv_catpvn, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec, +SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on, +SvIOK_only, SvIOK_only, SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN, +sv_len, sv_len, sv_magic, sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK, +SvNIOK_off, SvNIOKp, SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only, +SvNOKp, SvNV, SvNVX, SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only, +SvPOKp, SvPV, SvPVX, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, +SvROK_off, SvROK_on, SvRV, sv_setiv, sv_setnv, sv_setpv, sv_setpvn, +sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH, +SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE, +SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref, sv_usepvn, +sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS, +XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, +XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO, +XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero +=back +=item EDITOR +=item DATE =head2 perlcall - Perl calling conventions from C =item DESCRIPTION - An Error Handler, An Event Driven Program =item THE PERL_CALL FUNCTIONS - -B<perl_call_sv>, B<perl_call_pv>, B<perl_call_method>, -B<perl_call_argv> +B<perl_call_sv>, B<perl_call_pv>, B<perl_call_method>, B<perl_call_argv> =item FLAG VALUES - =over =item G_SCALAR - =item G_ARRAY - =item G_DISCARD - =item G_NOARGS - -=item G_EVAL - +=item G_EVAL =item G_KEEPERR - -=item Determining the Context - - - +=item Determining the Context =back =item KNOWN PROBLEMS - =item EXAMPLES - =over =item No Parameters, Nothing returned - =item Passing Parameters - =item Returning a Scalar - =item Returning a list of values - =item Returning a list in a scalar context - =item Returning Data from Perl via the parameter list - =item Using G_EVAL - =item Using G_KEEPERR - =item Using perl_call_sv - =item Using perl_call_argv - =item Using perl_call_method - =item Using GIMME - =item Using Perl to dispose of temporaries - =item Strategies for storing Callback Context Information - 1. Ignore the problem - Allow only 1 callback, 2. Create a sequence of callbacks - hard wired limit, 3. Use a parameter to map to the Perl callback =item Alternate Stack Manipulation - - - =back =item SEE ALSO - =item AUTHOR - =item DATE +=head1 PRAGMA DOCUMENTATION +=head2 blib - Use MakeMaker's uninstalled version of a package +=item SYNOPSIS +=item DESCRIPTION -=head2 perlembed - how to embed perl in your C program +=item BUGS -=item DESCRIPTION +=item AUTHOR +=head2 diagnostics - Perl compiler pragma to force verbose warning +diagnostics -=over +=item SYNOPSIS -=item PREAMBLE +=item DESCRIPTION +=over -B<Use C from Perl?>, B<Use a UNIX program from Perl?>, B<Use Perl from -Perl?>, B<Use C from C?>, B<Use Perl from C?> +=item The C<diagnostics> Pragma -=item ROADMAP +=item The I<splain> Program +=back -=item Compiling your C program +=item EXAMPLES +=item INTERNALS -=item Adding a Perl interpreter to your C program +=item BUGS +=item AUTHOR -=item Calling a Perl subroutine from your C program +=head2 integer - Perl pragma to compute arithmetic in integer instead of +double +=item SYNOPSIS -=item Evaluating a Perl statement from your C program +=item DESCRIPTION +=head2 less - perl pragma to request less of something from the compiler -=item Performing Perl pattern matches and substitutions from your C -program +=item SYNOPSIS +=item DESCRIPTION +=head2 lib - manipulate @INC at compile time +=item SYNOPSIS -=back +=item DESCRIPTION -=item MORAL +=over + +=item ADDING DIRECTORIES TO @INC +=item DELETING DIRECTORIES FROM @INC -=item AUTHOR +=item RESTORING ORIGINAL @INC +=back +=item SEE ALSO +=item AUTHOR +=head2 locale - Perl pragma to use and avoid POSIX locales for built-in +operations -=head2 perlpod - plain old documentation +=item SYNOPSIS =item DESCRIPTION +=head2 ops - Perl pragma to restrict unsafe operations when compiling -=item Embedding Pods in Perl Modules +=item SYNOPSIS +=item DESCRIPTION =item SEE ALSO +=head2 overload - Package for overloading perl operations -=item AUTHOR - +=item SYNOPSIS +=item CAVEAT SCRIPTOR +=item DESCRIPTION +=over -=head2 perlbook - Perl book information +=item Declaration of overloaded functions -=item DESCRIPTION +=item Calling Conventions for Binary Operations +FALSE, TRUE, C<undef> +=item Calling Conventions for Unary Operations +=item Overloadable Operations +I<Arithmetic operations>, I<Comparison operations>, I<Bit operations>, +I<Increment and decrement>, I<Transcendental functions>, I<Boolean, string +and numeric conversion>, I<Special> -=head1 PRAGMA DOCUMENTATION +=back +=item SPECIAL SYMBOLS FOR C<use overload> +=over +=item Last Resort -=head2 diagnostics - Perl compiler pragma to force verbose warning -diagnostics +=item Fallback -=item SYNOPSIS +C<undef>, TRUE, defined, but FALSE +=item Copy Constructor -=item DESCRIPTION +B<Example> +=back -=over +=item MAGIC AUTOGENERATION -=item The C<diagnostics> Pragma +I<Assignment forms of arithmetic operations>, I<Conversion operations>, +I<Increment and decrement>, C<abs($a)>, I<Unary minus>, I<Negation>, +I<Concatenation>, I<Comparison operations>, I<Copy operator> +=item WARNING -=item The I<splain> Program +=item Run-time Overloading +=item Public functions +overload::StrVal(arg), overload::Overloaded(arg), overload::Method(obj,op) +=item IMPLEMENTATION -=back +=item AUTHOR -=item EXAMPLES +=item DIAGNOSTICS +=item BUGS -=item INTERNALS +=head2 sigtrap - Perl pragma to enable simple signal handling +=item SYNOPSIS -=item BUGS +=item DESCRIPTION +=item OPTIONS -=item AUTHOR +=over +=item SIGNAL HANDLERS +B<stack-trace>, B<die>, B<handler> I<your-handler> +=item SIGNAL LISTS +B<normal-signals>, B<error-signals>, B<old-interface-signals> -=head2 integer - Perl pragma to compute arithmetic in integer instead -of double +=item OTHER -=item SYNOPSIS +B<untrapped>, B<any>, I<signal>, I<number> +=back -=item DESCRIPTION +=item EXAMPLES +=head2 strict - Perl pragma to restrict unsafe constructs +=item SYNOPSIS +=item DESCRIPTION +C<strict refs>, C<strict vars>, C<strict subs> -=head2 less - perl pragma to request less of something from the -compiler +=head2 subs - Perl pragma to predeclare sub names =item SYNOPSIS - =item DESCRIPTION +=head2 vars - Perl pragma to predeclare global variable names +=item SYNOPSIS +=item DESCRIPTION +=head1 MODULE DOCUMENTATION -=head2 lib - manipulate @INC at compile time +=head2 AnyDBM_File - provide framework for multiple DBMs =item SYNOPSIS - =item DESCRIPTION - =over -=item ADDING DIRECTORIES TO @INC +=item DBM Comparisons +[0], [1], [2], [3] -=item DELETING DIRECTORIES FROM @INC +=back +=item SEE ALSO -=item RESTORING ORIGINAL @INC +=head2 AutoLoader - load functions only on demand +=item SYNOPSIS +=item DESCRIPTION +=over -=back +=item __END__ -=item SEE ALSO +=item Loading Stubs +=item Package Lexicals -=item AUTHOR +=item AutoLoader vs. SelfLoader +=back +=item CAVEAT +=head2 AutoSplit - split a package for autoloading +=item SYNOPSIS -=head2 overload - Package for overloading perl operations +=item DESCRIPTION -=item SYNOPSIS +=item CAVEATS +=item DIAGNOSTICS -=item CAVEAT SCRIPTOR +=head2 Benchmark - benchmark running times of code +=item SYNOPSIS =item DESCRIPTION - =over -=item Declaration of overloaded functions - +=item Methods -=item Calling Conventions for Binary Operations +new, debug +=item Standard Exports -FALSE, TRUE, C<undef> +timeit(COUNT, CODE), timethis, timethese, timediff, timestr -=item Calling Conventions for Unary Operations +=item Optional Exports +=back -=item Overloadable Operations +=item NOTES +=item INHERITANCE -I<Arithmetic operations>, I<Comparison operations>, I<Bit operations>, -I<Increment and decrement>, I<Transcendental functions>, I<Boolean, -string and numeric conversion>, I<Special> +=item CAVEATS +=item AUTHORS +=item MODIFICATION HISTORY -=back +=head2 CPAN - query, download and build perl modules from CPAN sites -=item SPECIAL SYMBOLS FOR C<use overload> +=item SYNOPSIS +=item DESCRIPTION =over -=item Last Resort - - -=item Fallback +=item Interactive Mode +Searching for authors, bundles, distribution files and modules, make, test, +install, clean modules or distributions -C<undef>, TRUE, defined, but FALSE +=item CPAN::Shell -=item Copy Constructor +=item ProgrammerE<39>s interface +=item Cache Manager -B<Example> +=item Bundles +=item autobundle +=item recompile =back -=item MAGIC AUTOGENERATION - +=item CONFIGURATION -I<Assignment forms of arithmetic operations>, I<Conversion operations>, -I<Increment and decrement>, C<abs($a)>, I<Unary minus>, -I<Concatenation>, I<Comparison operations>, I<Copy operator> +o conf E<lt>scalar optionE<gt>, o conf E<lt>scalar optionE<gt> +E<lt>valueE<gt>, o conf E<lt>list optionE<gt>, o conf E<lt>list optionE<gt> +[shift|pop], o conf E<lt>list optionE<gt> [unshift|push|splice] +E<lt>listE<gt> -=item WARNING +=item SECURITY +=item EXPORT -=item Run-time Overloading +=item Debugging +=over -=item Public functions +=item Prerequisites +=back -overload::StrVal(arg), overload::Overloaded(arg), -C<overload::Method(obj,op)> +=item AUTHOR -=item IMPLEMENTATION +=item SEE ALSO +=head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization -=item AUTHOR +=item SYNOPSIS +=item DESCRIPTION -=item DIAGNOSTICS +=head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS +module +=item SYNOPSIS -=item BUGS +=item DESCRIPTION +=item SEE ALSO +=head2 Carp, carp - warn of errors (from perspective of caller) +=item SYNOPSIS +=item DESCRIPTION -=head2 sigtrap - Perl pragma to enable stack backtrace on unexpected -signals +=head2 Class::Template - struct/member template builder =item SYNOPSIS - =item DESCRIPTION +=item EXAMPLES +Example 1, Example 2 +=item NOTES - -=head2 strict - Perl pragma to restrict unsafe constructs +=head2 Config - access Perl configuration information =item SYNOPSIS - =item DESCRIPTION +myconfig(), config_sh(), config_vars(@names) -C<strict refs>, C<strict vars>, C<strict subs> - +=item EXAMPLE +=item WARNING +=item NOTE -=head2 subs - Perl pragma to predeclare sub names +=head2 Cwd, getcwd - get pathname of current working directory =item SYNOPSIS - =item DESCRIPTION +=head2 DB_File - Perl5 access to Berkeley DB +=item SYNOPSIS +=item DESCRIPTION +B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> -=head2 vars - Perl pragma to predeclare global variable names +=over -=item SYNOPSIS +=item How does DB_File interface to Berkeley DB? +=item Opening a Berkeley DB Database File -=item DESCRIPTION +=item Default Parameters +=item In Memory Databases +=back +=item DB_HASH +=over -=head1 MODULE DOCUMENTATION +=item A Simple Example. +=back +=item DB_BTREE +=over -=head2 AnyDBM_File - provide framework for multiple DBMs +=item Changing the BTREE sort order -=item SYNOPSIS +=item Handling duplicate keys +=item The get_dup method. -=item DESCRIPTION +=item Matching Partial Keys +=back + +=item DB_RECNO =over -=item DBM Comparisons +=item The bval option +=item A Simple Example -[0], [1], [2], [3] +=item Extra Methods +B<$X-E<gt>push(list) ;>, B<$value = $X-E<gt>pop ;>, B<$X-E<gt>shift>, +B<$X-E<gt>unshift(list) ;>, B<$X-E<gt>length> +=item Another Example =back -=item SEE ALSO - +=item THE API INTERFACE +B<$status = $X-E<gt>get($key, $value [, $flags]) ;>, B<$status = +$X-E<gt>put($key, $value [, $flags]) ;>, B<$status = $X-E<gt>del($key [, +$flags]) ;>, B<$status = $X-E<gt>fd ;>, B<$status = $X-E<gt>seq($key, +$value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;> +=item HINTS AND TIPS +=over -=head2 AutoLoader - load functions only on demand - -=item SYNOPSIS +=item Locking Databases +=item Sharing databases with C applications -=item DESCRIPTION +=back +=item COMMON QUESTIONS +=over +=item Why is there Perl source in my database? +=item How do I store complex data structures with DB_File? -=head2 AutoSplit - split a package for autoloading +=item What does "Invalid Argument" mean? -=item SYNOPSIS +=item What does "Bareword 'DB_File' not allowed" mean? +=back -=item DESCRIPTION +=item HISTORY +=item BUGS +=item AVAILABILITY +=item SEE ALSO +=item AUTHOR -=head2 Benchmark - benchmark running times of code +=head2 Devel::SelfStubber - generate stubs for a SelfLoading module =item SYNOPSIS - =item DESCRIPTION +=head2 DirHandle - supply object methods for directory handles -=over - -=item Methods +=item SYNOPSIS +=item DESCRIPTION -new, debug +=head2 DynaLoader - Dynamically load C libraries into Perl code -=item Standard Exports +=item SYNOPSIS +=item DESCRIPTION -C<timeit(COUNT, CODE)>, timethis, timethese, timediff, timestr +@dl_library_path, @dl_resolve_using, @dl_require_symbols, dl_error(), +$dl_debug, dl_findfile(), dl_expandspec(), dl_load_file(), +dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), bootstrap() -=item Optional Exports +=item AUTHOR +=head2 English - use nice English (or awk) names for ugly punctuation +variables +=item SYNOPSIS +=item DESCRIPTION -=back +=head2 Env - perl module that imports environment variables -=item NOTES +=item SYNOPSIS +=item DESCRIPTION -=item INHERITANCE +=item AUTHOR +=head2 Exporter - Implements default import method for modules -=item CAVEATS +=item SYNOPSIS +=item DESCRIPTION -=item AUTHORS +=over +=item Selecting What To Export -=item MODIFICATION HISTORY +=item Specialised Import Lists +=item Module Version Checking +=item Managing Unknown Symbols +=item Tag Handling Utility Functions +=back -=head2 Carp, carp - warn of errors (from perspective of caller) +=head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications =item SYNOPSIS - =item DESCRIPTION +=item @EXPORT +=item FUNCTIONS +xsinit(), Examples, ldopts(), Examples, perl_inc(), ccflags(), ccdlflags(), +ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules) +=item EXAMPLES -=head2 Cwd, getcwd - get pathname of current working directory - -=item SYNOPSIS - - -=item DESCRIPTION +=item SEE ALSO +=item AUTHOR +=head2 ExtUtils::Install - install files from here to there +=item SYNOPSIS +=item DESCRIPTION -=head2 DB_File - Perl5 access to Berkeley DB +=head2 ExtUtils::Liblist - determine libraries to use and how to use them =item SYNOPSIS - =item DESCRIPTION - -DB_HASH, DB_BTREE, DB_RECNO +For static extensions, For dynamic extensions, For dynamic extensions =over -=item How does DB_File interface to Berkeley DB? +=item EXTRALIBS +=item LDLOADLIBS and LD_RUN_PATH -=item Differences with Berkeley DB +=item BSLOADLIBS +=back -=item RECNO +=item PORTABILITY +=over -=item In Memory Databases +=item VMS implementation +=back -=item Using the Berkeley DB Interface Directly +=item SEE ALSO +=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in +ExtUtils::MakeMaker -get, put, del, fd, seq, sync +=item SYNOPSIS +=item DESCRIPTION +=head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker -=back +=item SYNOPSIS -=item EXAMPLES +=item DESCRIPTION +=item METHODS =over -=item Using HASH +=item Preloaded methods +canonpath, catdir, catfile, curdir, rootdir, updir -=item Using BTREE +=item SelfLoaded methods +c_o (o), cflags (o), clean (o), const_cccmd (o), const_config (o), +const_loadlibs (o), constants (o), depend (o), dir_target (o), dist (o), +dist_basics (o), dist_ci (o), dist_core (o), dist_dir (o), dist_test (o), +dlsyms (o), dynamic (o), dynamic_bs (o), dynamic_lib (o), exescan, +extliblist, file_name_is_absolute, find_perl -=item Using RECNO +=item Methods to actually produce chunks of text for the Makefile +force (o), guess_name, has_link_code, init_dirscan, init_main, init_others, +install (o), installbin (o), libscan (o), linkext (o), lsdir, macro (o), +makeaperl (o), makefile (o), manifypods (o), maybe_command, +maybe_command_in_dirs, needs_linking (o), nicetext, parse_version, pasthru +(o), path, perl_script, perldepend (o), pm_to_blib, post_constants (o), +post_initialize (o), postamble (o), prefixify, processPL (o), realclean +(o), replace_manpage_separator, static (o), static_lib (o), staticmake (o), +subdir_x (o), subdirs (o), test (o), test_via_harness (o), test_via_script +(o), tool_autosplit (o), tools_other (o), tool_xsubpp (o), top_targets (o), +writedoc, xs_c (o), xs_o (o) -=item Locking Databases +=back +=item SEE ALSO +=head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in +ExtUtils::MakeMaker +=item SYNOPSIS -=back +=item DESCRIPTION -=item HISTORY +=over +=item Methods always loaded -=item WARNINGS +eliminate_macros, fixpath, catdir, catfile, wraplist, curdir (override), +rootdir (override), updir (override) +=item SelfLoaded methods -=item BUGS +guess_name (override), find_perl (override), path (override), maybe_command +(override), maybe_command_in_dirs (override), perl_script (override), +file_name_is_absolute (override), replace_manpage_separator, init_others +(override), constants (override), cflags (override), const_cccmd +(override), pm_to_blib (override), tool_autosplit (override), tool_sxubpp +(override), xsubpp_version (override), tools_other (override), dist +(override), c_o (override), xs_c (override), xs_o (override), top_targets +(override), dlsyms (override), dynamic_lib (override), dynamic_bs +(override), static_lib (override), manifypods (override), processPL +(override), installbin (override), subdir_x (override), clean (override), +realclean (override), dist_basics (override), dist_core (override), +dist_dir (override), dist_test (override), install (override), perldepend +(override), makefile (override), test (override), test_via_harness +(override), test_via_script (override), makeaperl (override), nicetext +(override) +=back -=item AVAILABILITY +=head2 ExtUtils::MakeMaker - create an extension Makefile +=item SYNOPSIS -=item SEE ALSO +=item DESCRIPTION +=over -=item AUTHOR +=item How To Write A Makefile.PL +=item Default Makefile Behaviour +=item make test +=item make testdb +=item make install -=head2 Devel::SelfStubber - generate stubs for a SelfLoading module +=item PREFIX and LIB attribute -=item SYNOPSIS +=item AFS users +=item Static Linking of a new Perl Binary -=item DESCRIPTION +=item Determination of Perl Library and Installation Locations +=item Which architecture dependent directory? +=item Using Attributes and Parameters +C, CONFIG, CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS, +EXCLUDE_EXT, EXE_FILES, NO_VC, FIRST_MAKEFILE, FULLPERL, H, INC, +INCLUDE_EXT, INSTALLARCHLIB, INSTALLBIN, INSTALLDIRS, INSTALLMAN1DIR, +INSTALLMAN3DIR, INSTALLPRIVLIB, INSTALLSCRIPT, INSTALLSITELIB, +INSTALLSITEARCH, INST_ARCHLIB, INST_BIN, INST_EXE, INST_LIB, INST_MAN1DIR, +INST_MAN3DIR, INST_SCRIPT, LDFROM, LIBPERL_A, LIB, LIBS, LINKTYPE, +MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME, +NEEDS_LINKING, NOECHO, NORECURS, OBJECT, OPTIMIZE, PERL, PERLMAINCC, +PERL_ARCHLIB, PERL_LIB, PERL_SRC, PL_FILES, PM, PMLIBDIRS, PREFIX, +PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT, XSPROTOARG, +XS_VERSION +=item Additional lowercase attributes -=head2 DirHandle - supply object methods for directory handles +clean, depend, dist, dynamic_lib, installpm, linkext, macro, realclean, +tool_autosplit -=item SYNOPSIS +=item Overriding MakeMaker Methods +=item Hintsfile support -=item DESCRIPTION +=item Distribution Support + make distcheck, make skipcheck, make distclean, make manifest, + make distdir, make tardist, make dist, make uutardist, make +shdist, make zipdist, make ci +=back +=item SEE ALSO +=item AUTHORS -=head2 DynaLoader - Dynamically load C libraries into Perl code +=head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file =item SYNOPSIS - =item DESCRIPTION +=item MANIFEST.SKIP -@dl_library_path, @dl_resolve_using, @dl_require_symbols, dl_error(), -$dl_debug, dl_findfile(), dl_expandspec(), dl_load_file(), -dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), bootstrap() +=item EXPORT_OK -=item AUTHOR +=item GLOBAL VARIABLES +=item DIAGNOSTICS +C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:> I<$!>, +C<Added to MANIFEST:> I<file> +=item SEE ALSO +=item AUTHOR -=head2 English - use nice English (or awk) names for ugly punctuation -variables +=head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c =item SYNOPSIS - =item DESCRIPTION +=item SEE ALSO +=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader +=item SYNOPSIS +=item DESCRIPTION -=head2 Env - perl module that imports environment variables +=head2 ExtUtils::Mksymlists - write linker options files for dynamic +extension =item SYNOPSIS - =item DESCRIPTION +NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE =item AUTHOR +=item REVISION +=head2 ExtUtils::testlib - add blib/* directories to @INC +=item SYNOPSIS +=item DESCRIPTION -=head2 Exporter - Implements default import method for modules +=head2 Fatal - replace functions with equivalents which succeed or die =item SYNOPSIS - =item DESCRIPTION +=item AUTHOR -=over +=head2 Fcntl - load the C Fcntl.h defines -=item Selecting What To Export +=item SYNOPSIS +=item DESCRIPTION -=item Specialised Import Lists +=item NOTE +=item EXPORTED SYMBOLS -=item Module Version Checking +=head2 File::Basename, fileparse - split a pathname into pieces +=item SYNOPSIS -=item Managing Unknown Symbols +=item DESCRIPTION +fileparse_set_fstype, fileparse -=item Tag Handling Utility Functions +=item EXAMPLES +C<basename>, C<dirname> + +=head2 File::CheckTree, validate - run many filetest checks on a tree +=item SYNOPSIS +=item DESCRIPTION -=back +=head2 File::Compare - Compare files or filehandles +=item SYNOPSIS +=item DESCRIPTION +=item RETURN -=head2 ExtUtils::Install - install files from here to there +=item AUTHOR -=item SYNOPSIS +=head2 File::Copy - Copy files or filehandles +=item SYNOPSIS =item DESCRIPTION +=over +=item Special behavior if C<syscopy> is defined (VMS and OS/2) +rmscopy($from,$to[,$date_flag]) +=back -=head2 ExtUtils::Liblist - determine libraries to use and how to use -them +=item RETURN -=item SYNOPSIS +=item AUTHOR + +=head2 File::Find, find - traverse a file tree +=item SYNOPSIS =item DESCRIPTION +=head2 File::Path - create or remove a series of directories -For static extensions, For dynamic extensions, For dynamic extensions +=item SYNOPSIS -=over +=item DESCRIPTION -=item EXTRALIBS +=item AUTHORS +=item REVISION -=item LDLOADLIBS and LD_RUN_PATH +=head2 File::stat - by-name interface to Perl's built-in stat() functions +=item SYNOPSIS -=item BSLOADLIBS +=item DESCRIPTION +=item NOTE +=item AUTHOR +=head2 FileCache - keep more files open than the system permits -=back +=item SYNOPSIS -=item PORTABILITY +=item DESCRIPTION +=item BUGS -=item SEE ALSO +=head2 FileHandle - supply object methods for filehandles + +=item SYNOPSIS +=item DESCRIPTION +$fh->print, $fh->printf, $fh->getline, $fh->getlines +=item SEE ALSO +=head2 FindBin - Locate directory of original perl script -=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in -ExtUtils::MakeMaker +=item SYNOPSIS =item DESCRIPTION +=item EXPORTABLE VARIABLES +=item KNOWN BUGS +=item AUTHORS +=item COPYRIGHT -=head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker +=item REVISION -=item SYNOPSIS +=head2 GDBM_File - Perl5 access to the gdbm library. +=item SYNOPSIS =item DESCRIPTION +=item AVAILABILITY -=item METHODS - - -=over +=item BUGS -=item Preloaded methods +=item SEE ALSO +=head2 Getopt::Long, GetOptions - extended processing of command line +options -catdir, catfile, nicetext, libscan, exescan, lsdir, path, -replace_manpage_separator, file_name_is_absolute, prefixify, -maybe_command_in_dirs, maybe_command, perl_script +=item SYNOPSIS -=item SelfLoaded methods +=item DESCRIPTION +E<lt>noneE<gt>, !, =s, :s, =i, :i, =f, :f -guess_name, init_main, init_dirscan, init_others, find_perl +=over -=item Methods to actually produce chunks of text for the Makefile +=item Linkage specification +=item Aliases and abbreviations -post_initialize, const_config, constants, const_loadlibs, const_cccmd, -tool_autosplit, tool_xsubpp, tools_other, dist, macro, depend, -post_constants, pasthru, c_o, xs_c, xs_o, top_targets, linkext, dlsyms, -dynamic, dynamic_bs, dynamic_lib, static, static_lib, installpm, -installpm_x, manifypods, processPL, installbin, subdirs, subdir_x, -clean, realclean, dist_basics, dist_core, dist_dir, dist_test, dist_ci, -install, force, perldepend, makefile, staticmake, test, -test_via_harness, test_via_script, postamble, makeaperl, extliblist, -dir_target, needs_linking, has_link_code, writedoc +=item Non-option call-back routine +=item Option starters +=item Return value =back -=item SEE ALSO +=item COMPATIBILITY +=item EXAMPLES +=item CONFIGURATION VARIABLES +$Getopt::Long::autoabbrev, $Getopt::Long::getopt_compat, +$Getopt::Long::order, $Getopt::Long::bundling, $Getopt::Long::ignorecase, +$Getopt::Long::passthrough, $Getopt::Long::VERSION, $Getopt::Long::error, +$Getopt::Long::debug +=head2 Getopt::Std, getopt - Process single-character switches with switch +clustering -=head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in -ExtUtils::MakeMaker +=item SYNOPSIS =item DESCRIPTION +=head2 I18N::Collate - compare 8-bit scalar data according to the current +locale +=item SYNOPSIS +=item DESCRIPTION - -=head2 ExtUtils::MakeMaker - create an extension Makefile +=head2 IO - load various IO modules =item SYNOPSIS - =item DESCRIPTION +=head2 IO::File - supply object methods for filehandles -=over - -=item Hintsfile support - +=item SYNOPSIS -=item What's new in version 5 of MakeMaker +=item DESCRIPTION +=item CONSTRUCTOR -=item Incompatibilities between MakeMaker 5.00 and 4.23 +new ([ ARGS ] ) +=item METHODS -=item Default Makefile Behaviour +open( FILENAME [,MODE [,PERMS]] ) +=item SEE ALSO -=item make test +=item HISTORY +=head2 IO::Handle - supply object methods for I/O handles -=item make install +=item SYNOPSIS +=item DESCRIPTION -=item PREFIX attribute +=item CONSTRUCTOR +new (), new_from_fd ( FD, MODE ) -=item AFS users +=item METHODS +$fh->getline, $fh->getlines, $fh->fdopen ( FD, MODE ), $fh->write ( BUF, +LEN [, OFFSET }\] ), $fh->opened, $fh->untaint -=item Static Linking of a new Perl Binary +=item NOTE +=item SEE ALSO -=item Determination of Perl Library and Installation Locations +=item BUGS +=item HISTORY -=item Useful Default Makefile Macros +=head2 IO::Pipe, IO::pipe - supply object methods for pipes +=item SYNOPSIS -=item Using Attributes and Parameters +=item DESCRIPTION +=item CONSTRCUTOR -C, CONFIG, CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS, -EXE_FILES, FIRST_MAKEFILE, FULLPERL, H, INC, INSTALLARCHLIB, -INSTALLBIN, INSTALLDIRS, INSTALLMAN1DIR, INSTALLMAN3DIR, -INSTALLPRIVLIB, INSTALLSITELIB, INSTALLSITEARCH, INST_ARCHLIB, -INST_EXE, INST_LIB, INST_MAN1DIR, INST_MAN3DIR, LDFROM, LIBPERL_A, -LIBS, LINKTYPE, MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, -MYEXTLIB, NAME, NEEDS_LINKING, NOECHO, NORECURS, OBJECT, PERL, -PERLMAINCC, PERL_ARCHLIB, PERL_LIB, PERL_SRC, PL_FILES, PM, PMLIBDIRS, -PREFIX, PREREQ, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT, -XSPROTOARG, XS_VERSION +new ( [READER, WRITER] ) -=item Additional lowercase attributes +=item METHODS +reader ([ARGS]), writer ([ARGS]), handles () -clean, depend, dist, dynamic_lib, installpm, linkext, macro, realclean, -tool_autosplit +=item SEE ALSO -=item Overriding MakeMaker Methods +=item AUTHOR +=item COPYRIGHT -=item Distribution Support +=head2 IO::Seekable - supply seek based methods for I/O objects +=item SYNOPSIS - make distcheck, make skipcheck, make distclean, make - manifest, make distdir, make tardist, make dist, make - uutardist, make shdist, make ci +=item DESCRIPTION +=item SEE ALSO +=item HISTORY -=back +=head2 IO::Select - OO interface to the select system call -=item AUTHORS +=item SYNOPSIS +=item DESCRIPTION -=item MODIFICATION HISTORY +=item CONSTRUCTOR +new ( [ HANDLES ] ) -=item TODO +=item METHODS +add ( HANDLES ), remove ( HANDLES ), exists ( HANDLE ), handles, can_read ( +[ TIMEOUT ] ), can_write ( [ TIMEOUT ] ), has_error ( [ TIMEOUT ] ), count +(), bits(), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) +=item EXAMPLE +=item AUTHOR +=item COPYRIGHT -=head2 ExtUtils::Manifest - utilities to write and check a MANIFEST -file +=head2 IO::Socket - Object interface to socket communications =item SYNOPSIS - =item DESCRIPTION +=item CONSTRUCTOR -=item MANIFEST.SKIP - +new ( [ARGS] ) -=item EXPORT_OK +=item METHODS +accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype, +protocol -=item GLOBAL VARIABLES +=item SUB-CLASSES +=over -=item DIAGNOSTICS +=item IO::Socket::INET +=item METHODS -C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:> -I<$!>, C<Added to MANIFEST:> I<file> +sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost +() -=item SEE ALSO +=item IO::Socket::UNIX +=item METHODS -=item AUTHOR +hostpath(), peerpath() +=back +=item SEE ALSO +=item AUTHOR +=item COPYRIGHT -=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by -DynaLoader +=head2 IO::lib::IO::File, IO::File - supply object methods for filehandles =item SYNOPSIS - =item DESCRIPTION +=item CONSTRUCTOR +new ([ ARGS ] ) +=item METHODS +open( FILENAME [,MODE [,PERMS]] ) -=head2 ExtUtils::Mksymlists - write linker options files for dynamic -extension +=item SEE ALSO -=item SYNOPSIS +=item HISTORY +=head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O +handles -=item DESCRIPTION +=item SYNOPSIS +=item DESCRIPTION -NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE +=item CONSTRUCTOR -=item AUTHOR +new (), new_from_fd ( FD, MODE ) +=item METHODS -=item REVISION +$fh->getline, $fh->getlines, $fh->fdopen ( FD, MODE ), $fh->write ( BUF, +LEN [, OFFSET }\] ), $fh->opened, $fh->untaint +=item NOTE +=item SEE ALSO +=item BUGS +=item HISTORY -=head2 Fcntl - load the C Fcntl.h defines +=head2 IO::lib::IO::Pipe, IO::pipe - supply object methods for pipes =item SYNOPSIS - =item DESCRIPTION +=item CONSTRCUTOR -=item NOTE +new ( [READER, WRITER] ) +=item METHODS +reader ([ARGS]), writer ([ARGS]), handles () +=item SEE ALSO +=item AUTHOR -=head2 File::Basename, Basename - parse file specifications +=item COPYRIGHT -=item SYNOPSIS +=head2 IO::lib::IO::Seekable, IO::Seekable - supply seek based methods for +I/O objects +=item SYNOPSIS =item DESCRIPTION +=item SEE ALSO -fileparse_set_fstype, fileparse - -=item EXAMPLES - - -C<basename>, C<dirname> - +=item HISTORY +=head2 IO::lib::IO::Select, IO::Select - OO interface to the select system +call +=item SYNOPSIS -=head2 File::CheckTree, validate - run many filetest checks on a tree +=item DESCRIPTION -=item SYNOPSIS +=item CONSTRUCTOR +new ( [ HANDLES ] ) -=item DESCRIPTION +=item METHODS +add ( HANDLES ), remove ( HANDLES ), exists ( HANDLE ), handles, can_read ( +[ TIMEOUT ] ), can_write ( [ TIMEOUT ] ), has_error ( [ TIMEOUT ] ), count +(), bits(), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) +=item EXAMPLE +=item AUTHOR +=item COPYRIGHT -=head2 File::Find, find - traverse a file tree +=head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket +communications =item SYNOPSIS - =item DESCRIPTION +=item CONSTRUCTOR +new ( [ARGS] ) +=item METHODS +accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype, +protocol -=head2 File::Path - create or remove a series of directories +=item SUB-CLASSES -=item SYNOPSIS +=over +=item IO::Socket::INET -=item DESCRIPTION +=item METHODS +sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost +() -=item AUTHORS +=item IO::Socket::UNIX +=item METHODS -=item REVISION +hostpath(), peerpath() +=back +=item SEE ALSO +=item AUTHOR +=item COPYRIGHT -=head2 FileCache - keep more files open than the system permits +=head2 IPC::Open2, open2 - open a process for both reading and writing =item SYNOPSIS - =item DESCRIPTION +=item WARNING -=item BUGS +=item SEE ALSO +=head2 IPC::Open3, open3 - open a process for reading, writing, and error +handling +=item SYNOPSIS +=item DESCRIPTION +=item WARNING -=head2 FileHandle - supply object methods for filehandles +=head2 Math::BigFloat - Arbitrary length float math package =item SYNOPSIS - =item DESCRIPTION +number format, Error returns 'NaN', Division is computed to - $fh->print, $fh->printf, $fh->getline, $fh->getlines +=item BUGS -=item SEE ALSO +=item AUTHOR +=head2 Math::BigInt - Arbitrary size integer math package -=item BUGS +=item SYNOPSIS +=item DESCRIPTION +Canonical notation, Input, Output +=item EXAMPLES +=item BUGS -=head2 GDBM_File - Perl5 access to the gdbm library. +=item AUTHOR -=item SYNOPSIS +=head2 Math::Complex - complex numbers and associated mathematical +functions +=item SYNOPSIS =item DESCRIPTION +=item OPERATIONS -=item AVAILABILITY +=item CREATION +=item STRINGIFICATION -=item BUGS +=item USAGE +=item BUGS -=item SEE ALSO - +=item AUTHOR +=head2 NDBM_File - Tied access to ndbm files +=item SYNOPSIS +=item DESCRIPTION -=head2 Getopt::Long, GetOptions - extended processing of command line -options +=head2 Net::Ping - check a remote host for reachability =item SYNOPSIS - =item DESCRIPTION - -<none>, !, =s, :s, =i, :i, =f, :f - =over -=item Linkage specification +=item Functions +Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);, $p->ping($host [, +$timeout]);, $p->close();, pingecho($host [, $timeout]); -=item Aliases and abbreviations - +=back -=item Non-option call-back routine +=item WARNING +=item NOTES -=item Option starters +=head2 Net::hostent - by-name interface to Perl's built-in gethost*() +functions +=item SYNOPSIS -=item Return value +=item DESCRIPTION +=item EXAMPLES +=item NOTE +=item AUTHOR -=back +=head2 Net::netent - by-name interface to Perl's built-in getnet*() +functions -=item COMPATIBILITY +=item SYNOPSIS +=item DESCRIPTION =item EXAMPLES +=item NOTE -=item CONFIGURATION VARIABLES +=item AUTHOR +=head2 Net::protoent - by-name interface to Perl's built-in getproto*() +functions -$Getopt::Long::autoabbrev, $Getopt::Long::getopt_compat, -$Getopt::Long::order, $Getopt::Long::ignorecase, -$Getopt::Long::VERSION, $Getopt::Long::error, $Getopt::Long::debug +=item SYNOPSIS +=item DESCRIPTION +=item NOTE +=item AUTHOR -=head2 Getopt::Std, getopt - Process single-character switches with -switch clustering +=head2 Net::servent - by-name interface to Perl's built-in getserv*() +functions =item SYNOPSIS - =item DESCRIPTION +=item EXAMPLES +=item NOTE +=item AUTHOR - -=head2 I18N::Collate - compare 8-bit scalar data according to the -current locale +=head2 ODBM_File - Tied access to odbm files =item SYNOPSIS - =item DESCRIPTION - - - - -=head2 IPC::Open2, open2 - open a process for both reading and writing +=head2 Opcode - Disable named opcodes when compiling perl code =item SYNOPSIS - =item DESCRIPTION +=item NOTE =item WARNING +=item Operator Names and Operator Lists -=item SEE ALSO - - +an operator name (opname), an operator tag name (optag), a negated opname +or optag, an operator set (opset) +=item Opcode Functions +opcodes, opset (OP, ...), opset_to_ops (OPSET), opset_to_hex (OPSET), +full_opset, empty_opset, invert_opset (OPSET), verify_opset (OPSET, ...), +define_optag (OPTAG, OPSET), opmask_add (OPSET), opmask, opdesc (OP, ...), +opdump (PAT) -=head2 IPC::Open3, open3 - open a process for reading, writing, and -error handling - -=item SYNOPSIS - +=item Manipulating Opsets -=item DESCRIPTION +=item TO DO (maybe) +=item Predefined Opcode Tags +:base_core, :base_mem, :base_loop, :base_io, :base_orig, :base_math, +:default, :filesys_read, :sys_db, :browse, :filesys_open, :filesys_write, +:subprocess, :ownprocess, :others, :still_to_be_decided, :dangerous +=item SEE ALSO +=item AUTHORS -=head2 Net::Ping, pingecho - check a host for upness +=head2 Opcode::Safe, Safe - Compile and execute code in restricted +compartments =item SYNOPSIS - =item DESCRIPTION +a new namespace, an operator mask + +=item WARNING =over -=item Parameters +=item RECENT CHANGES +=item Methods in class Safe -hostname, timeout +permit (OP, ...), permit_only (OP, ...), deny (OP, ...), deny_only (OP, +...), trap (OP, ...), untrap (OP, ...), share (NAME, ...), share_from +(PACKAGE, ARRAYREF), varglob (VARNAME), reval (STRING), rdo (FILENAME), +root (NAMESPACE), mask (MASK) +=item Some Safety Issues +Memory, CPU, Snooping, Signals, State Changes -=back +=item AUTHOR -=item WARNING +=back +=head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when +compiling +=item SYNOPSIS +=item DESCRIPTION +=item SEE ALSO =head2 POSIX - Perl interface to IEEE Std 1003.1 =item SYNOPSIS - =item DESCRIPTION - =item NOTE - -=item CAVEATS - +=item CAVEATS =item FUNCTIONS - -_exit, abort, abs, access, acos, alarm, asctime, asin, assert, atan, -atan2, atexit, atof, atoi, atol, bsearch, calloc, ceil, chdir, chmod, -chown, clearerr, clock, close, closedir, cos, cosh, creat, ctermid, -ctime, cuserid, difftime, div, dup, dup2, errno, execl, execle, execlp, -execv, execve, execvp, exit, exp, fabs, fclose, fcntl, fdopen, feof, -ferror, fflush, fgetc, fgetpos, fgets, fileno, floor, fmod, fopen, -fork, fpathconf, fprintf, fputc, fputs, fread, free, freopen, frexp, -fscanf, fseek, fsetpos, fstat, ftell, fwrite, getc, getchar, getcwd, -getegid, getenv, geteuid, getgid, getgrgid, getgrnam, getgroups, -getlogin, getpgrp, getpid, getppid, getpwnam, getpwuid, gets, getuid, -gmtime, isalnum, isalpha, isatty, iscntrl, isdigit, isgraph, islower, -isprint, ispunct, isspace, isupper, isxdigit, kill, labs, ldexp, ldiv, -link, localeconv, localtime, log, log10, longjmp, lseek, malloc, mblen, -mbstowcs, mbtowc, memchr, memcmp, memcpy, memmove, memset, mkdir, -mkfifo, mktime, modf, nice, offsetof, open, opendir, pat +_exit, abort, abs, access, acos, alarm, asctime, asin, assert, atan, atan2, +atexit, atof, atoi, atol, bsearch, calloc, ceil, chdir, chmod, chown, +clearerr, clock, close, closedir, cos, cosh, creat, ctermid, ctime, +cuserid, difftime, div, dup, dup2, errno, execl, execle, execlp, execv, +execve, execvp, exit, exp, fabs, fclose, fcntl, fdopen, feof, ferror, +fflush, fgetc, fgetpos, fgets, fileno, floor, fmod, fopen, fork, fpathconf, +fprintf, fputc, fputs, fread, free, freopen, frexp, fscanf, fseek, fsetpos, +fstat, ftell, fwrite, getc, getchar, getcwd, getegid, getenv, geteuid, +getgid, getgrgid, getgrnam, getgroups, getlogin, getpgrp, getpid, getppid, +getpwnam, getpwuid, gets, getuid, gmtime, isalnum, isalpha, isatty, +iscntrl, isdigit, isgraph, islower, isprint, ispunct, isspace, isupper, +isxdigit, kill, labs, ldexp, ldiv, link, localeconv, localtime, log, log10, +longjmp, lseek, malloc, mblen, mbstowcs, mbtowc, memchr, memcmp, memcpy, +memmove, memset, mkdir, mkfifo, mktime, modf, nice, offsetof, open, +opendir, pathconf, pause, perror, pipe, pow, printf, putc, putchar, puts, +qsort, raise, rand, read, readdir, realloc, remove, rename, rewind, +rewinddir, rmdir, scanf, setgid, setjmp, setlocale, setpgid, setsid, +setuid, sigaction, siglongjmp, sigpending, sigprocmask, sigsetjmp, +sigsuspend, sin, sinh, sleep, sprintf, sqrt, srand, sscanf, stat, strcat, +strchr, strcmp, strcoll, strcpy, strcspn, strerror, strftime, strlen, +strncat, strncmp, strncpy, stroul, strpbrk, strrchr, strspn, strstr, +strtod, strtok, strtol, strtoul, strxfrm, sysconf, system, tan, tanh, +tcdrain, tcflow, tcflush, tcgetpgrp, tcsendbreak, tcsetpgrp, time, times, +tmpfile, tmpnam, tolower, toupper, ttyname, tzname, tzset, umask, uname, +ungetc, unlink, utime, vfprintf, vprintf, vsprintf, wait, waitpid, +wcstombs, wctomb, write =item CLASSES - =over =item POSIX::SigAction - new =item POSIX::SigSet - new, addset, delset, emptyset, fillset, ismember =item POSIX::Termios - new, getattr, getcc, getcflag, getiflag, getispeed, getlflag, getoflag, getospeed, setattr, setcc, setcflag, setiflag, setispeed, setlflag, setoflag, setospeed, Baud rate values, Terminal interface values, c_cc field values, c_cflag field values, c_iflag field values, c_lflag field values, c_oflag field values - - =back =item PATHNAME CONSTANTS - Constants =item POSIX CONSTANTS - Constants =item SYSTEM CONFIGURATION - Constants =item ERRNO - Constants =item FCNTL - Constants =item FLOAT - Constants =item LIMITS - Constants =item LOCALE - Constants =item MATH - Constants =item SIGNAL - Constants =item STAT - Constants, Macros =item STDLIB - Constants =item STDIO - Constants =item TIME - Constants =item UNISTD - Constants =item WAIT - Constants, Macros =item CREATION - - - - =head2 Pod::Text - convert POD data to formatted ASCII text =item SYNOPSIS - =item DESCRIPTION - =item AUTHOR - =item TODO +=head2 SDBM_File - Tied access to sdbm files +=item SYNOPSIS +=item DESCRIPTION +=head2 Safe - Compile and execute code in restricted compartments -=head2 Safe - Safe extension module for Perl +=item SYNOPSIS =item DESCRIPTION - a new namespace, an operator mask -=over +=item WARNING -=item Operator masks +=over +=item RECENT CHANGES =item Methods in class Safe +permit (OP, ...), permit_only (OP, ...), deny (OP, ...), deny_only (OP, +...), trap (OP, ...), untrap (OP, ...), share (NAME, ...), share_from +(PACKAGE, ARRAYREF), varglob (VARNAME), reval (STRING), rdo (FILENAME), +root (NAMESPACE), mask (MASK) -NAMESPACE, MASK, root (NAMESPACE), mask (MASK), trap (OP, ...), untrap -(OP, ...), share (VARNAME, ...), varglob (VARNAME), reval (STRING), rdo -(FILENAME) - -=item Subroutines in package Safe - +=item Some Safety Issues -ops_to_mask (OP, ...), mask_to_ops (MASK), opcode (OP, ...), opname -(OP, ...), fullmask, emptymask, MAXO, op_mask +Memory, CPU, Snooping, Signals, State Changes =item AUTHOR - - - =back - - - =head2 Search::Dict, look - search for key in dictionary file =item SYNOPSIS - =item DESCRIPTION - - - - =head2 SelectSaver - save and restore selected file handle =item SYNOPSIS - =item DESCRIPTION - - - - =head2 SelfLoader - load functions only on demand =item SYNOPSIS - =item DESCRIPTION - =over =item The __DATA__ token - =item SelfLoader autoloading - =item Autoloading and package lexicals - =item SelfLoader and AutoLoader - =item __DATA__, __END__, and the FOOBAR::DATA filehandle. - =item Classes and inherited methods. - - - =back =item Multiple packages and fully qualified subroutine names - - - - -=head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load -the C socket.h defines and structure manipulators +=head2 Shell - run shell commands transparently within perl =item SYNOPSIS - =item DESCRIPTION +=item AUTHOR -inet_aton HOSTNAME, inet_ntoa IP_ADDRESS, INADDR_ANY, INADDR_LOOPBACK, -INADDR_NONE, sockaddr_in PORT, ADDRESS, sockaddr_in SOCKADDR_IN, -pack_sockaddr_in PORT, IP_ADDRESS, unpack_sockaddr_in SOCKADDR_IN, -sockaddr_un PATHNAME, sockaddr_un SOCKADDR_UN, pack_sockaddr_un PATH, -unpack_sockaddr_un SOCKADDR_UN +=head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C +socket.h defines and structure manipulators +=item SYNOPSIS +=item DESCRIPTION +inet_aton HOSTNAME, inet_ntoa IP_ADDRESS, INADDR_ANY, INADDR_BROADCAST, +INADDR_LOOPBACK, INADDR_NONE, sockaddr_in PORT, ADDRESS, sockaddr_in +SOCKADDR_IN, pack_sockaddr_in PORT, IP_ADDRESS, unpack_sockaddr_in +SOCKADDR_IN, sockaddr_un PATHNAME, sockaddr_un SOCKADDR_UN, +pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =head2 Symbol - manipulate Perl symbols and their names =item SYNOPSIS - =item DESCRIPTION - - - - =head2 Sys::Hostname - Try every conceivable way to get hostname =item SYNOPSIS - =item DESCRIPTION - =item AUTHOR - - - - -=head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - -Perl interface to the UNIX syslog(3) calls +=head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl +interface to the UNIX syslog(3) calls =item SYNOPSIS - =item DESCRIPTION - -openlog $ident, $logopt, $facility, syslog $priority, $mask, $format, -@args, setlogmask $mask_priority, closelog +openlog $ident, $logopt, $facility, syslog $priority, $format, @args, +setlogmask $mask_priority, closelog =item EXAMPLES - =item DEPENDENCIES - =item SEE ALSO - =item AUTHOR - - - - =head2 Term::Cap - Perl termcap interface =item SYNOPSIS - =item DESCRIPTION - =item EXAMPLES - - - - =head2 Term::Complete - Perl word completion module =item SYNOPSIS - =item DESCRIPTION - -<tab>Attempts word completion. Cannot be changed, ^D, ^U, <del>, <bs> +E<lt>tabE<gt>Attempts word completion. +Cannot be changed, ^D, ^U, E<lt>delE<gt>, E<lt>bsE<gt> =item DIAGNOSTICS - =item BUGS - =item AUTHOR - - - - -=head2 Term::ReadLine - Perl interface to various C<readline> packages. -If no real package is found, substitutes stubs instead of basic -functions. +=head2 Term::ReadLine - Perl interface to various C<readline> packages. If +no real package is found, substitutes stubs instead of basic functions. =item SYNOPSIS - =item DESCRIPTION - =item Minimal set of supported functions - C<ReadLine>, C<new>, C<readline>, C<addhistory>, C<IN>, $C<OUT>, C<MinLine>, C<findConsole>, C<Features> =item EXPORTS - - - - =head2 Test::Harness - run perl standard test scripts with statistics =item SYNOPSIS - =item DESCRIPTION - =over =item The test script output - - - =back =item EXPORT - =item DIAGNOSTICS - C<All tests successful.\nFiles=%d, Tests=%d, %s>, C<FAILED tests -%s\n\tFailed %d/%d tests, %.2f%% okay.>, C<Test returned status %d -(wstat %d)>, C<Failed 1 test, %.2f%% okay. %s>, C<Failed %d/%d tests, -%.2f%% okay. %s> +%s\n\tFailed %d/%d tests, %.2f%% okay.>, C<Test returned status %d (wstat +%d)>, C<Failed 1 test, %.2f%% okay. %s>, C<Failed %d/%d tests, %.2f%% okay. +%s> =item SEE ALSO - =item AUTHORS - =item BUGS - - - - =head2 Text::Abbrev, abbrev - create an abbreviation table from a list =item SYNOPSIS - =item DESCRIPTION - =item EXAMPLE +=head2 Text::ParseWords - parse text into an array of tokens +=item SYNOPSIS +=item DESCRIPTION +=item AUTHORS -=head2 Text::Soundex - Implementation of the Soundex Algorithm as -Described by Knuth +=head2 Text::Soundex - Implementation of the Soundex Algorithm as Described +by Knuth =item SYNOPSIS - =item DESCRIPTION - =item EXAMPLES - =item LIMITATIONS - =item AUTHOR +=head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and +unexpand(1) +=item SYNOPSIS +=item DESCRIPTION +=item BUGS -=head2 Text::Tabs -- expand and unexpand tabs +=item AUTHOR -=item SYNOPSIS +=head2 Text::Wrap - line wrapping to form simple paragraphs +=item SYNOPSIS =item DESCRIPTION +=item EXAMPLE =item AUTHOR +=head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes + +=item SYNOPSIS + +=item DESCRIPTION +TIEHASH classname, LIST, STORE this, key, value, FETCH this, key, FIRSTKEY +this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this +=item CAVEATS +=item MORE INFORMATION -=head2 Text::Wrap -- wrap text into a paragraph +=head2 Tie::RefHash - use references as hash keys =item SYNOPSIS - =item DESCRIPTION +=item EXAMPLE =item AUTHOR +=item VERSION +=item SEE ALSO - - -=head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes +=head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied +scalars =item SYNOPSIS - =item DESCRIPTION +TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this -TIEHASH classname, LIST, STORE this, key, value, FETCH this, key, -FIRSTKEY this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, -key, CLEAR this +=item MORE INFORMATION -=item CAVEATS +=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing +=item SYNOPSIS -=item MORE INFORMATION +=item DESCRIPTION +=item CAVEATS +=head2 Time::Local - efficiently compute time from local and GMT time +=item SYNOPSIS +=item DESCRIPTION -=head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied -scalars +=head2 Time::gmtime - by-name interface to Perl's built-in gmtime() +function =item SYNOPSIS - =item DESCRIPTION +=item NOTE -TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this +=item AUTHOR -=item MORE INFORMATION +=head2 Time::localtime - by-name interface to Perl's built-in localtime() +function +=item SYNOPSIS +=item DESCRIPTION +=item NOTE +=item AUTHOR -=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing +=head2 Time::tm - internal object used by Time::gmtime and Time::localtime =item SYNOPSIS +=item DESCRIPTION + +=item AUTHOR + +=head2 UNIVERSAL - base class for ALL classes (blessed references) + +=item SYNOPSIS =item DESCRIPTION +isa ( TYPE ), can ( METHOD ), VERSION ( [ REQUIRE ] ), isa ( REF, TYPE ) -=item CAVEATS +=head2 User::grent - by-name interface to Perl's built-in getgr*() +functions +=item SYNOPSIS +=item DESCRIPTION +=item NOTE +=item AUTHOR -=head2 Time::Local - efficiently compute tome from local and GMT time +=head2 User::pwent - by-name interface to Perl's built-in getpw*() +functions =item SYNOPSIS - =item DESCRIPTION +=item NOTE - +=item AUTHOR =head1 AUXILIARY DOCUMENTATION -Here should be listed all the extra program's docs, but they don't all -have man pages yet: +Here should be listed all the extra programs' documentation, but they +don't all have manual pages yet: =item a2p @@ -3144,10 +3509,8 @@ have man pages yet: =item wrapsuid - =head1 AUTHOR -Larry Wall E<lt><F<larry@wall.org>E<gt>, with the help of oodles of -other folks. - +Larry Wall E<lt>F<larry@wall.org>E<gt>, with the help of oodles +of other folks. diff --git a/pod/perltoot.pod b/pod/perltoot.pod new file mode 100644 index 0000000000..aae3b7393d --- /dev/null +++ b/pod/perltoot.pod @@ -0,0 +1,1779 @@ +=head1 NAME + +perltoot - Tom's object-oriented tutorial for perl + +=head1 DESCRIPTION + +Object-oriented programming is a big seller these days. Some managers +would rather have objects than sliced bread. Why is that? What's so +special about an object? Just what I<is> an object anyway? + +An object is nothing but a way of tucking away complex behaviours into +a neat little easy-to-use bundle. (This is what professors call +abstraction.) Smart people who have nothing to do but sit around for +weeks on end figuring out really hard problems make these nifty +objects that even regular people can use. (This is what professors call +software reuse.) Users (well, programmers) can play with this little +bundle all they want, but they aren't to open it up and mess with the +insides. Just like an expensive piece of hardware, the contract says +that you void the warranty if you muck with the cover. So don't do that. + +The heart of objects is the class, a protected little private namespace +full of data and functions. A class is a set of related routines that +addresses some problem area. You can think of it as a user-defined type. +The Perl package mechanism, also used for more traditional modules, +is used for class modules as well. Objects "live" in a class, meaning +that they belong to some package. + +More often than not, the class provides the user with little bundles. +These bundles are objects. They know whose class they belong to, +and how to behave. Users ask the class to do something, like "give +me an object." Or they can ask one of these objects to do something. +Asking a class to do something for you is calling a I<class method>. +Asking an object to do something for you is calling an I<object method>. +Asking either a class (usually) or an object (sometimes) to give you +back an object is calling a I<constructor>, which is just a +kind of method. + +That's all well and good, but how is an object different from any other +Perl data type? Just what is an object I<really>; that is, what's its +fundamental type? The answer to the first question is easy. An object +is different from any other data type in Perl in one and only one way: +you may dereference it using not merely string or numeric subscripts +as with simple arrays and hashes, but with named subroutine calls. +In a word, with I<methods>. + +The answer to the second question is that it's a reference, and not just +any reference, mind you, but one whose referent has been I<bless>()ed +into a particular class (read: package). What kind of reference? Well, +the answer to that one is a bit less concrete. That's because in Perl +the designer of the class can employ any sort of reference they'd like +as the underlying intrinsic data type. It could be a scalar, an array, +or a hash reference. It could even be a code reference. But because +of its inherent flexibility, an object is usually a hash reference. + +=head1 Creating a Class + +Before you create a class, you need to decide what to name it. That's +because the class (package) name governs the name of the file used to +house it, just as with regular modules. Then, that class (package) +should provide one or more ways to generate objects. Finally, it should +provide mechanisms to allow users of its objects to indirectly manipulate +these objects from a distance. + +For example, let's make a simple Person class module. It gets stored in +the file Person.pm. If it were called a Happy::Person class, it would +be stored in the file Happy/Person.pm, and its package would become +Happy::Person instead of just Person. (On a personal computer not +running Unix or Plan 9, but something like MacOS or VMS, the directory +separator may be different, but the principle is the same.) Do not assume +any formal relationship between modules based on their directory names. +This is merely a grouping convenience, and has no effect on inheritance, +variable accessibility, or anything else. + +For this module we aren't going to use Exporter, because we're +a well-behaved class module that doesn't export anything at all. +In order to manufacture objects, a class needs to have a I<constructor +method>. A constructor gives you back not just a regular data type, +but a brand-new object in that class. This magic is taken care of by +the bless() function, whose sole purpose is to enable its referent to +be used as an object. Remember: being an object really means nothing +more than that methods may now be called against it. + +While a constructor may be named anything you'd like, most Perl +programmers seem to like to call theirs new(). However, new() is not +a reserved word, and a class is under no obligation to supply such. +Some programmers have also been known to use a function with +the same name as the class as the constructor. + +=head2 Object Representation + +By far the most common mechanism used in Perl to represent a Pascal +record, a C struct, or a C++ class an anonymous hash. That's because a +hash has an arbitrary number of data fields, each conveniently accessed by +an arbitrary name of your own devising. + +If you were just doing a simple +struct-like emulation, you would likely go about it something like this: + + $rec = { + name => "Jason", + age => 23, + peers => [ "Norbert", "Rhys", "Phineas"], + }; + +If you felt like it, you could add a bit of visual distinction +by up-casing the hash keys: + + $rec = { + NAME => "Jason", + AGE => 23, + PEERS => [ "Norbert", "Rhys", "Phineas"], + }; + +And so you could get at C<$rec-E<gt>{NAME}> to find "Jason", or +C<@{ $rec-E<gt>{PEERS} }> to get at "Norbert", "Rhys", and "Phineas". +(Have you ever noticed how many 23-year-old programmers seem to +be named "Jason" these days? :-) + +This same model is often used for classes, although it is not considered +the pinnacle of programming propriety for folks from outside the +class to come waltzing into an object, brazenly accessing its data +members directly. Generally speaking, an object should be considered +an opaque cookie that you use I<object methods> to access. Visually, +methods look like you're dereffing a reference using a function name +instead of brackets or braces. + +=head2 Class Interface + +Some languages provide a formal syntactic interface to a class's methods, +but Perl does not. It relies on you to read the documentation of each +class. If you try to call an undefined method on an object, Perl won't +complain, but the program will trigger an exception while it's running. +Likewise, if you call a method expecting a prime number as its argument +with an even one instead, you can't expect the compiler to catch this. +(Well, you can expect it all you like, but it's not going to happen.) + +Let's suppose you have a well-educated user of your Person class, +someone who has read the docs that explain the prescribed +interface. Here's how they might use the Person class: + + use Person; + + $him = Person->new(); + $him->name("Jason"); + $him->age(23); + $him->peers( "Norbert", "Rhys", "Phineas" ); + + push @All_Recs, $him; # save object in array for later + + printf "%s is %d years old.\n", $him->name, $him->age; + print "His peers are: ", join(", ", $him->peers), "\n"; + + printf "Last rec's name is %s\n", $All_Recs[-1]->name; + +As you can see, the user of the class doesn't know (or at least, has no +business paying attention to the fact) that the object has one particular +implementation or another. The interface to the class and its objects +is exclusively via methods, and that's all the user of the class should +ever play with. + +=head2 Constructors and Instance Methods + +Still, I<someone> has to know what's in the object. And that someone is +the class. It implements methods that the programmer uses to access +the object. Here's how to implement the Person class using the standard +hash-ref-as-an-object idiom. We'll make a class method called new() to +act as the constructor, and three object methods called name(), age(), and +peers() to get at per-object data hidden away in our anonymous hash. + + package Person; + use strict; + + ################################################## + ## the object constructor (simplistic version) ## + ################################################## + sub new { + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless($self); # but see below + return $self; + } + + ############################################## + ## methods to access per-object data ## + ## ## + ## With args, they set the value. Without ## + ## any, they only retrieve it/them. ## + ############################################## + + sub name { + my $self = shift; + if (@_) { $self->{NAME} = shift } + return $self->{NAME}; + } + + sub age { + my $self = shift; + if (@_) { $self->{AGE} = shift } + return $self->{AGE}; + } + + sub peers { + my $self = shift; + if (@_) { @{ $self->{PEERS} } = @_ } + return @{ $self->{PEERS} }; + } + + 1; # so the require or use succeeds + +We've created three methods to access an object's data, name(), age(), +and peers(). These are all substantially similar. If called with an +argument, they set the appropriate field; otherwise they return the +value held by that field, meaning the value of that hash key. + +=head2 Planning for the Future: Better Constructors + +Even though at this point you may not even know what it means, someday +you're going to worry about inheritance. (You can safely ignore this +for now and worry about it later if you'd like.) To ensure that this +all works out smoothly, you must use the double-argument form of bless(). +The second argument is the class into which the referent will be blessed. +By not assuming our own class as the default second argument and instead +using the class passed into us, we make our constructor inheritable. + +While we're at it, let's make our constructor a bit more flexible. +Rather than being uniquely a class method, we'll set it up so that +it can be called as either a class method I<or> an object +method. That way you can say: + + $me = Person->new(); + $him = $me->new(); + +To do this, all we have to do is check whether what was passed in +was a reference or not. If so, we were invoked as an object method, +and we need to extract the package (class) using the ref() function. +If not, we just use the string passed in as the package name +for blessing our referent. + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless ($self, $class); + return $self; + } + +That's about all there is for constructors. These methods bring objects +to life, returning neat little opaque bundles to the user to be used in +subsequent method calls. + +=head2 Destructors + +Every story has a beginning and an end. The beginning of the object's +story is its constructor, explicitly called when the object comes into +existence. But the ending of its story is the I<destructor>, a method +implicitly called when an object leaves this life. Any per-object +clean-up code is placed in the destructor, which must (in Perl) be called +DESTROY. + +If constructors can have arbitrary names, then why not destructors? +Because while a constructor is explicitly called, a destructor is not. +Destruction happens automatically via Perl's garbage collection (GC) +system, which is a quick but somewhat lazy reference-based GC system. +To know what to call, Perl insists that the destructor be named DESTROY. + +Why is DESTROY in all caps? Perl on occasion uses purely upper-case +function names as a convention to indicate that the function will +be automatically called by Perl in some way. Others that are called +implicitly include BEGIN, END, AUTOLOAD, plus all methods used by +tied objects, described in L<perltie>. + +In really good object-oriented programming languages, the user doesn't +care when the destructor is called. It just happens when it's supposed +to. In low-level languages without any GC at all, there's no way to +depend on this happening at the right time, so the programmer must +explicitly call the destructor to clean up memory and state, crossing +their fingers that it's the right time to do so. Unlike C++, an +object destructor is nearly never needed in Perl, and even when it is, +explicit invocation is uncalled for. In the case of our Person class, +we don't need a destructor because Perl takes care of simple matters +like memory deallocation. + +The only situation where Perl's reference-based GC won't work is +when there's a circularity in the data structure, such as: + + $this->{WHATEVER} = $this; + +In that case, you must delete the self-reference manually if you expect +your program not to leak memory. While admittedly error-prone, this is +the best we can do right now. Nonetheless, rest assured that when your +program is finished, its objects' destructors are all duly called. +So you are guaranteed that an object I<eventually> gets properly +destroyed, except in the unique case of a program that never exits. +(If you're running Perl embedded in another application, this full GC +pass happens a bit more frequently--whenever a thread shuts down.) + +=head2 Other Object Methods + +The methods we've talked about so far have either been constructors or +else simple "data methods", interfaces to data stored in the object. +These are a bit like an object's data members in the C++ world, except +that strangers don't access them as data. Instead, they should only +access the object's data indirectly via its methods. This is an +important rule: in Perl, access to an object's data should I<only> +be made through methods. + +Perl doesn't impose restrictions on who gets to use which methods. +The public-versus-private distinction is by convention, not syntax. +(Well, unless you use the Alias module described below in L</"Data Members +as Variables">.) Occasionally you'll see method names beginning or ending +with an underscore or two. This marking is a convention indicating +that the methods are private to that class alone and sometimes to its +closest acquaintances, its immediate subclasses. But this distinction +is not enforced by Perl itself. It's up to the programmer to behave. + +There's no reason to limit methods to those that simply access data. +Methods can do anything at all. The key point is that they're invoked +against an object or a class. Let's say we'd like object methods that +do more than fetch or set one particular field. + + sub exclaim { + my $self = shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $self->{NAME}, $self->{AGE}, join(", ", $self->{PEERS}); + } + +Or maybe even one like this: + + sub happy_birthday { + my $self = shift; + return ++$self->{AGE}; + } + +Some might argue that one should go at these this way: + + sub exclaim { + my $self = shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $self->name, $self->age, join(", ", $self->peers); + } + + sub happy_birthday { + my $self = shift; + return $self->age( $self->age() + 1 ); + } + +But since these methods are all executing in the class itself, this +may not be critical. There are trade-offs to be made. Using direct +hash access is faster (about an order of magnitude faster, in fact), and +it's more convenient when you want to interpolate in strings. But using +methods (the external interface) internally shields not just the users of +your class but even you yourself from changes in your data representation. + +=head1 Class Data + +What about "class data", data items common to each object in a class? +What would you want that for? Well, in your Person class, you might +like to keep track of the total people alive. How do you implement that? + +You I<could> make it a global variable called $Person::Census. But about +only reason you'd do that would be if you I<wanted> people to be able to +get at your class data directly. They could just say $Person::Census +and play around with it. Maybe this is ok in your design scheme. +You might even conceivably want to make it an exported variable. To be +exportable, a variable must be a (package) global. If this were a +traditional module rather than an object-oriented one, you might do that. + +While this approach is expected in most traditional modules, it's +generally considered rather poor form in most object modules. In an +object module, you should set up a protective veil to separate interface +from implementation. So provide a class method to access class data +just as you provide object methods to access object data. + +So, you I<could> still keep $Census as a package global and rely upon +others to honor the contract of the module and therefore not play around +with its implementation. You could even be supertricky and make $Census a +tied object as described in L<perltie>, thereby intercepting all accesses. + +But more often than not, you just want to make your class data a +file-scoped lexical. To do so, simply put this at the top of the file: + + my $Census = 0; + +Even though the scope of a my() normally expires when the block in which +it was declared is done (in this case the whole file being required or +used), Perl's deep binding of lexical variables guarantees that the +variable will not be deallocated, remaining accessible to functions +declared within that scope. This doesn't work with global variables +given temporary values via local(), though. + +Irrespective of whether you leave $Census a package global or make +it instead a file-scoped lexical, you should make these +changes to your Person::new() constructor: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $Census++; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless ($self, $class); + return $self; + } + + sub population { + return $Census; + } + +Now that we've done this, we certainly do need a destructor so that +when Person is destroyed, the $Census goes down. Here's how +this could be done: + + sub DESTROY { --$Census } + +Notice how there's no memory to deallocate in the destructor? That's +something that Perl takes care of for you all by itself. + +=head2 Accessing Class Data + +It turns out that this is not really a good way to go about handling +class data. A good scalable rule is that I<you must never reference class +data directly from an object method>. Otherwise you aren't building a +scalable, inheritable class. The object must be the rendezvous point +for all operations, especially from an object method. The globals +(class data) would in some sense be in the "wrong" package in your +derived classes. In Perl, methods execute in the context of the class +they were defined in, I<not> that of the object that triggered them. +Therefore, namespace visibility of package globals in methods is unrelated +to inheritance. + +Got that? Maybe not. Ok, let's say that some other class "borrowed" +(well, inherited) the DESTROY method as it was defined above. When those +objects are destructed, the original $Census variable will be altered, +not the one in the new class's package namespace. Perhaps this is what +you want, but probably it isn't. + +Here's how to fix this. We'll store a reference to the data in the +value accessed by the hash key "_CENSUS". Why the underscore? Well, +mostly because an initial underscore already conveys strong feelings +of magicalness to a C programmer. It's really just a mnemonic device +to remind ourselves that this field is special and not to be used as +a public data member in the same way that NAME, AGE, and PEERS are. +(Because we've been developing this code under the strict pragma, prior +to perl version 5.004 we'll have to quote the field name.) + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + # "private" data + $self->{"_CENSUS"} = \$Census; + bless ($self, $class); + ++ ${ $self->{"_CENSUS"} }; + return $self; + } + + sub population { + my $self = shift; + if (ref $self) { + return ${ $self->{"_CENSUS"} }; + } else { + return $Census; + } + } + + sub DESTROY { + my $self = shift; + -- ${ $self->{"_CENSUS"} }; + } + +=head2 Debugging Methods + +It's common for a class to have a debugging mechanism. For example, +you might want to see when objects are created or destroyed. To do that, +add a debugging variable as a file-scoped lexical. For this, we'll pull +in the standard Carp module to emit our warnings and fatal messages. +That way messages will come out with the caller's filename and +line number instead of our own; if we wanted them to be from our own +perspective, we'd just use die() and warn() directly instead of croak() +and carp() respectively. + + use Carp; + my $Debugging = 0; + +Now add a new class method to access the variable. + + sub debug { + my $class = shift; + if (ref $class) { confess "Class method called as object method" } + unless (@_ == 1) { confess "usage: CLASSNAME->debug(level)" } + $Debugging = shift; + } + +Now fix up DESTROY to murmur a bit as the moribund object expires: + + sub DESTROY { + my $self = shift; + if ($Debugging) { carp "Destroying $self " . $self->name } + -- ${ $self->{"_CENSUS"} }; + } + +One could conceivably make a per-object debug state. That +way you could call both of these: + + Person->debug(1); # entire class + $him->debug(1); # just this object + +To do so, we need our debugging method to be a "bimodal" one, one that +works on both classes I<and> objects. Therefore, adjust the debug() +and DESTROY methods as follows: + + sub debug { + my $self = shift; + confess "usage: thing->debug(level)" unless @_ == 1; + my $level = shift; + if (ref($self)) { + $self->{"_DEBUG"} = $level; # just myself + } else { + $Debugging = $level; # whole class + } + } + + sub DESTROY { + my $self = shift; + if ($Debugging || $self->{"_DEBUG"}) { + carp "Destroying $self " . $self->name; + } + -- ${ $self->{"_CENSUS"} }; + } + +What happens if a derived class (which we'll all C<Employee>) inherits +methods from this person one? Then C<Employee->debug()> when called +as a class method manipulates $Person::Debugging not $Employee::Debugging. + +=head2 Class Destructors + +The object destructor handles the death of each distinct object. But sometimes +you want a bit of cleanup when the entire class is shut down, which +currently only happens when the program exits. To make such a +I<class destructor>, create a function in that class's package named +END. This works just like the END function in traditional modules, +meaning that it gets called whenever your program exits unless it execs +or dies of an uncaught signal. For example, + + sub END { + if ($Debugging) { + print "All persons are going away now.\n"; + } + } + +When the program exits, all the class destructors (END functions) are +be called in the opposite order that they were loaded in (LIFO order). + +=head2 Documenting the Interface + +And there you have it: we've just shown you the I<implementation> of this +Person class. Its I<interface> would be its documentation. Usually this +means putting it in pod ("plain old documentation") format right there +in the same file. In our Person example, we would place the following +docs anywhere in the Person.pm file. Even though it looks mostly like +code, it's not. It's embedded documentation such as would be used by +the pod2man, pod2html, or pod2text programs. The Perl compiler ignores +pods entirely, just as the translators ignore code. Here's an example of +some pods describing the informal interface: + + =head1 NAME + + Person - class to implement people + + =head1 SYNOPSIS + + use Person; + + ################# + # class methods # + ################# + $ob = Person->new; + $count = Person->population; + + ####################### + # object data methods # + ####################### + + ### get versions ### + $who = $ob->name; + $years = $ob->age; + @pals = $ob->peers; + + ### set versions ### + $ob->name("Jason"); + $ob->age(23); + $ob->peers( "Norbert", "Rhys", "Phineas" ); + + ######################## + # other object methods # + ######################## + + $phrase = $ob->exclaim; + $ob->happy_birthday; + + =head1 DESCRIPTION + + The Person class implements dah dee dah dee dah.... + +That's all there is to the matter of interface versus implementation. +A programmer who opens up the module and plays around with all the private +little shiny bits that were safely locked up behind the interface contract +has voided the warranty, and you shouldn't worry about their fate. + +=head1 Aggregation + +Suppose you later want to change the class to implement better names. +Perhaps you'd like to support both given names (called Christian names, +irrespective of one's religion) and family names (called surnames), plus +nicknames and titles. If users of your Person class have been properly +accessing it through its documented interface, then you can easily change +the underlying implementation. If they haven't, then they lose and +it's their fault for breaking the contract and voiding their warranty. + +To do this, we'll make another class, this one called Fullname. What's +the Fullname class look like? To answer that question, you have to +first figure out how you want to use it. How about we use it this way: + + $him = Person->new(); + $him->fullname->title("St"); + $him->fullname->christian("Thomas"); + $him->fullname->surname("Aquinas"); + $him->fullname->nickname("Tommy"); + printf "His normal name is %s\n", $him->name; + printf "But his real name is %s\n", $him->fullname->as_string; + +Ok. To do this, we'll change Person::new() so that it supports +a full name field this way: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{FULLNAME} = Fullname->new(); + $self->{AGE} = undef; + $self->{PEERS} = []; + $self->{"_CENSUS"} = \$Census; + bless ($self, $class); + ++ ${ $self->{"_CENSUS"} }; + return $self; + } + + sub fullname { + my $self = shift; + return $self->{FULLNAME}; + } + +Then to support old code, define Person::name() this way: + + sub name { + my $self = shift; + return $self->{FULLNAME}->nickname(@_) + || $self->{FULLNAME}->christian(@_); + } + +Here's the Fullname class. We'll use the same technique +of using a hash reference to hold data fields, and methods +by the appropriate name to access them: + + package Fullname; + use strict; + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { + TITLE => undef, + CHRISTIAN => undef, + SURNAME => undef, + NICK => undef, + }; + bless ($self, $class); + return $self; + } + + sub christian { + my $self = shift; + if (@_) { $self->{CHRISTIAN} = shift } + return $self->{CHRISTIAN}; + } + + sub surname { + my $self = shift; + if (@_) { $self->{SURNAME} = shift } + return $self->{SURNAME}; + } + + sub nickname { + my $self = shift; + if (@_) { $self->{NICK} = shift } + return $self->{NICK}; + } + + sub title { + my $self = shift; + if (@_) { $self->{TITLE} = shift } + return $self->{TITLE}; + } + + sub as_string { + my $self = shift; + my $name = join(" ", @$self{'CHRISTIAN', 'SURNAME'}); + if ($self->{TITLE}) { + $name = $self->{TITLE} . " " . $name; + } + return $name; + } + + 1; + +Finally, here's the test program: + + #!/usr/bin/perl -w + use strict; + use Person; + sub END { show_census() } + + sub show_census () { + printf "Current population: %d\n", Person->population; + } + + Person->debug(1); + + show_census(); + + my $him = Person->new(); + + $him->fullname->christian("Thomas"); + $him->fullname->surname("Aquinas"); + $him->fullname->nickname("Tommy"); + $him->fullname->title("St"); + $him->age(1); + + printf "%s is really %s.\n", $him->name, $him->fullname; + printf "%s's age: %d.\n", $him->name, $him->age; + $him->happy_birthday; + printf "%s's age: %d.\n", $him->name, $him->age; + + show_census(); + +=head1 Inheritance + +Object-oriented programming systems all support some notion of +inheritance. Inheritance means allowing one class to piggy-back on +top of another one so you don't have to write the same code again and +again. It's about software reuse, and therefore related to Laziness, +the principal virtue of a programmer. (The import/export mechanisms in +traditional modules are also a form of code reuse, but a simpler one than +the true inheritance that you find in object modules.) + +Sometimes the syntax of inheritance is built into the core of the +language, and sometimes it's not. Perl has no special syntax for +specifying the class (or classes) to inherit from. Instead, it's all +strictly in the semantics. Each package can have a variable called @ISA, +which governs (method) inheritance. If you try to call a method on an +object or class, and that method is not found in that object's package, +Perl then looks to @ISA for other packages to go looking through in +search of the missing method. + +Like the special per-package variables recognized by Exporter (such as +@EXPORT, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, and $VERSION), the @ISA +array I<must> be a package-scoped global and not a file-scoped lexical +created via my(). Most classes have just one item in their @ISA array. +In this case, we have what's called "single inheritance", or SI for short. + +Consider this class: + + package Employee; + use Person; + @ISA = ("Person"); + 1; + +Not a lot to it, eh? All it's doing so far is loading in another +class and stating that this one will inherit methods from that +other class if need be. We have given it none of its own methods. +We rely upon an Employee to behave just like a Person. + +Setting up an empty class like this is called the "empty subclass test"; +that is, making a derived class that does nothing but inherit from a +base class. If the original base class has been designed properly, +then the new derived class can be used as a drop-in replacement for the +old one. This means you should be able to write a program like this: + + use Employee + my $empl = Employee->new(); + $empl->name("Jason"); + $empl->age(23); + printf "%s is age %d.\n", $empl->name, $empl->age; + +By proper design, we mean always using the two-argument form of bless(), +avoiding direct access of global data, and not exporting anything. If you +look back at the Person::new() function we defined above, we were careful +to do that. There's a bit of package data used in the constructor, +but the reference to this is stored on the object itself and all other +methods access package data via that reference, so we should be ok. + +What do we mean by the Person::new() function -- isn't that actually +a method? Well, in principle, yes. A method is just a function that +expects as its first argument a class name (package) or object +(blessed reference). Person::new() is the function that both the +C<Person-E<gt>new()> method and the C<Employee-E<gt>new()> method end +up calling. Understand that while a method call looks a lot like a +function call, they aren't really quite the same, and if you treat them +as the same, you'll very soon be left with nothing but broken programs. +First, the actual underlying calling conventions are different: method +calls get an extra argument. Second, function calls don't do inheritance, +but methods do. + + Method Call Resulting Function Call + ----------- ------------------------ + Person->new() Person::new("Person") + Employee->new() Person::new("Employee") + +So don't use function calls when you mean to call a method. + +If an employee is just a Person, that's not all too very interesting. +So let's add some other methods. We'll give our employee +data fields to access their salary, their employee ID, and their +start date. + +If you're getting a little tired of creating all these nearly identical +methods just to get at the object's data, do not despair. Later, +we'll describe several different convenience mechanisms for shortening +this up. Meanwhile, here's the straight-forward way: + + sub salary { + my $self = shift; + if (@_) { $self->{SALARY} = shift } + return $self->{SALARY}; + } + + sub id_number { + my $self = shift; + if (@_) { $self->{ID} = shift } + return $self->{ID}; + } + + sub start_date { + my $self = shift; + if (@_) { $self->{START_DATE} = shift } + return $self->{START_DATE}; + } + +=head2 Overridden Methods + +What happens when both a derived class and its base class have the same +method defined? Well, then you get the derived class's version of that +method. For example, let's say that we want the peers() method called on +an employee to act a bit differently. Instead of just returning the list +of peer names, let's return slightly different strings. So doing this: + + $empl->peers("Peter", "Paul", "Mary"); + printf "His peers are: %s\n", join(", ", $empl->peers); + +will produce: + + His peers are: PEON=PETER, PEON=PAUL, PEON=MARY + +To do this, merely add this definition into the Employee.pm file: + + sub peers { + my $self = shift; + if (@_) { @{ $self->{PEERS} } = @_ } + return map { "PEON=\U$_" } @{ $self->{PEERS} }; + } + +There, we've just demonstrated the high-falutin' concept known in certain +circles as I<polymorphism>. We've taken on the form and behaviour of +an existing object, and then we've altered it to suit our own purposes. +This is a form of Laziness. (Getting polymorphed is also what happens +when the wizard decides you'd look better as a frog.) + +Every now and then you'll want to have a method call trigger both its +derived class (also know as "subclass") version as well as its base class +(also known as "superclass") version. In practice, constructors and +destructors are likely to want to do this, and it probably also makes +sense in the debug() method we showed previously. + +To do this, add this to Employee.pm: + + use Carp; + my $Debugging = 0; + + sub debug { + my $self = shift; + confess "usage: thing->debug(level)" unless @_ == 1; + my $level = shift; + if (ref($self)) { + $self->{"_DEBUG"} = $level; + } else { + $Debugging = $level; # whole class + } + Person::debug($self, $Debugging); # don't really do this + } + +As you see, we turn around and call the Person package's debug() function. +But this is far too fragile for good design. What if Person doesn't +have a debug() function, but is inheriting I<its> debug() method +from elsewhere? It would have been slightly better to say + + Person->debug($Debugging); + +But even that's got too much hard-coded. It's somewhat better to say + + $self->Person::debug($Debugging); + +Which is a funny way to say to start looking for a debug() method up +in Person. This strategy is more often seen on overridden object methods +than on overridden class methods. + +There is still something a bit off here. We've hard-coded our +superclass's name. This in particular is bad if you change which classes +you inherit from, or add others. Fortunately, the pseudoclass SUPER +comes to the rescue here. + + $self->SUPER::debug($Debugging); + +This way it starts looking in my class's @ISA. This only makes sense +from I<within> a method call, though. Don't try to access anything +in SUPER:: from anywhere else, because it doesn't exist outside +an overridden method call. + +Things are getting a bit complicated here. Have we done anything +we shouldn't? As before, one way to test whether we're designing +a decent class is via the empty subclass test. Since we already have +an Employee class that we're trying to check, we'd better get a new +empty subclass that can derive from Employee. Here's one: + + package Boss; + use Employee; # :-) + @ISA = qw(Employee); + +And here's the test program: + + #!/usr/bin/perl -w + use strict; + use Boss; + Boss->debug(1); + + my $boss = Boss->new(); + + $boss->fullname->title("Don"); + $boss->fullname->surname("Pichon Alvarez"); + $boss->fullname->christian("Federico Jesus"); + $boss->fullname->nickname("Fred"); + + $boss->age(47); + $boss->peers("Frank", "Felipe", "Faust"); + + printf "%s is age %d.\n", $boss->fullname, $boss->age; + printf "His peers are: %s\n", join(", ", $boss->peers); + +Running it, we see that we're still ok. If you'd like to dump out your +object in a nice format, somewhat like the way the 'x' command works in +the debugger, you could use the Data::Dumper module from CPAN this way: + + use Data::Dumper; + print "Here's the boss:\n"; + print Dumper($boss); + +Which shows us something like this: + + Here's the boss: + $VAR1 = bless( { + _CENSUS => \1, + FULLNAME => bless( { + TITLE => 'Don', + SURNAME => 'Pichon Alvarez', + NICK => 'Fred', + CHRISTIAN => 'Federico Jesus' + }, 'Fullname' ), + AGE => 47, + PEERS => [ + 'Frank', + 'Felipe', + 'Faust' + ] + }, 'Boss' ); + +Hm.... something's missing there. What about the salary, start date, +and ID fields? Well, we never set them to anything, even undef, so they +don't show up in the hash's keys. The Employee class has no new() method +of its own, and the new() method in Person doesn't know about Employees. +(Nor should it: proper OO design dictates that a subclass be allowed to +know about its immediate superclass, but never vice-versa.) So let's +fix up Employee::new() this way: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(); + $self->{SALARY} = undef; + $self->{ID} = undef; + $self->{START_DATE} = undef; + bless ($self, $class); # reconsecrate + return $self; + } + +Now if you dump out an Employee or Boss object, you'll find +that new fields show up there now. + +=head2 Multiple Inheritance + +Ok, at the risk of confusing beginners and annoying OO gurus, it's +time to confess that Perl's object system includes that controversial +notion known as multiple inheritance, or MI for short. All this means +is that rather than having just one parent class who in turn might +itself have a parent class, etc., that you can directly inherit from +two or more parents. It's true that some uses of MI can get you into +trouble, although hopefully not quite so much trouble with Perl as with +dubiously-OO languages like C++. + +The way it works is actually pretty simple: just put more than one package +name in your @ISA array. When it comes time for Perl to go finding +methods for your object, it looks at each of these packages in order. +Well, kinda. It's actually a fully recursive, depth-first order. +Consider a bunch of @ISA arrays like this: + + @First::ISA = qw( Alpha ); + @Second::ISA = qw( Beta ); + @Third::ISA = qw( First Second ); + +If you have an object of class Third: + + my $ob = Third->new(); + $ob->spin(); + +How do we find a spin() method (or a new() method for that matter)? +Because the search is depth-first, classes will be looked up +in the following order: Third, First, Alpha, Second, and Beta. + +In practice, few class modules have been seen that actually +make use of MI. One nearly always chooses simple containership of +one class within another over MI. That's why our Person +object I<contained> a Fullname object. That doesn't mean +it I<was> one. + +However, there is one particular area where MI in Perl is rampant: +borrowing another class's class methods. This is rather common, +especially with some bundled "objectless" classes, +like Exporter, DynaLoader, AutoLoader, and SelfLoader. These classes +do not provide constructors; they exist only so you may inherit their +class methods. (It's not entirely clear why inheritance was done +here rather than traditional module importation.) + +For example, here is the POSIX module's @ISA: + + package POSIX; + @ISA = qw(Exporter DynaLoader); + +The POSIX module isn't really an object module, but then, +neither are Exporter or DynaLoader. They're just lending their +classes' behaviours to POSIX. + +Why don't people use MI for object methods much? One reason is that +it can have complicated side-effects. For one thing, your inheritance +graph (no longer a tree) might converge back to the same base class. +Although Perl guards against recursive inheritance, merely having parents +who are related to each other via a common ancestor, incestuous though +it sounds, is not forbidden. What if in our Third class shown above we +wanted its new() method to also call both overridden constructors in its +two parent classes? The SUPER notation would only find the first one. +Also, what about if the Alpha and Beta classes both had a common ancestor, +like Nought? If you kept climbing up the inheritance tree calling +overridden methods, you'd end up calling Nought::new() twice, +which might well be a bad idea. + +=head2 UNIVERSAL: The Root of All Objects + +Wouldn't it be convenient if all objects were rooted at some ultimate +base class? That way you could give every object common methods without +having to go and add it to each and every @ISA. Well, it turns out that +you can. You don't see it, but Perl tacitly and irrevocably assumes +that there's an extra element at the end of @ISA: the class UNIVERSAL. +In version 5.003, there were no predefined methods there, but you could put +whatever you felt like into it. + +However, as of version 5.004 (or some subversive releases, like 5.003_08), +UNIVERSAL has some methods in it already. These are built-in to your Perl +binary, so they don't take any extra time to load. Predefined methods +include isa(), can(), and VERSION(). isa() tells you whether an object or +class "is" another one without having to traverse the hierarchy yourself: + + $has_io = $fd->isa("IO::Handle"); + $itza_handle = IO::Socket->isa("IO::Handle"); + +The can() method, called against that object or class, reports back +whether its string argument is a callable method name in that class. +In fact, it gives you back a function reference to that method: + + $his_print_method = $obj->can('as_string'); + +Finally, the VERSION method checks whether the class (or the object's +class) has a package global called $VERSION that's high enough, as in: + + Some_Module->VERSION(3.0); + $his_vers = $ob->VERSION(); + +However, we don't usually call VERSION ourselves. (Remember that an all +upper-case function name is a Perl convention that indicates that the +function will be automatically used by Perl in some way.) In this case, +it happens when you say + + use Some_Module 3.0; + +If you wanted to add versioning to your Person class explained +above, just add this to Person.pm: + + use vars qw($VERSION); + $VERSION = '1.1'; + +and then in Employee.pm could you can say + + use Employee 1.1; + +And it would make sure that you have at least that version number or +higher available. This is not the same as loading in that exact version +number. No mechanism currently exists for concurrent installation of +multiple versions of a module. Lamentably. + +=head1 Alternate Object Representations + +Nothing requires objects to be implemented as hash references. An object +can be any sort of reference so long as its referent has been suitably +blessed. That means scalar, array, and code references are also fair +game. + +A scalar would work if the object has only one datum to hold. An array +would work for most cases, but makes inheritance a bit dodgy because +you have to invent new indices for the derived classes. + +=head2 Arrays as Objects + +If the user of your class honors the contract and sticks to the advertised +interface, then you can change its underlying interface if you feel +like it. Here's another implementation that conforms to the same +interface specification. This time we'll use an array reference +instead of a hash reference to represent the object. + + package Person; + use strict; + + my($NAME, $AGE, $PEERS) = ( 0 .. 2 ); + + ############################################ + ## the object constructor (array version) ## + ############################################ + sub new { + my $self = []; + $self->[$NAME] = undef; # this is unnecessary + $self->[$AGE] = undef; # as it this + $self->[$PEERS] = []; # but this isn't, really + bless($self); + return $self; + } + + sub name { + my $self = shift; + if (@_) { $self->[$NAME] = shift } + return $self->[$NAME]; + } + + sub age { + my $self = shift; + if (@_) { $self->[$AGE] = shift } + return $self->[$AGE]; + } + + sub peers { + my $self = shift; + if (@_) { @{ $self->[$PEERS] } = @_ } + return @{ $self->[$PEERS] }; + } + + 1; # so the require or use succeeds + +You might guess that the array access will be a lot faster than the +hash access, but they're actually comparable. The array is a little +bit faster, but not more than ten or fifteen percent, even when you +replace the variables above like $AGE with literal numbers, like 1. +A bigger difference between the two approaches can be found in memory use. +A hash representation takes up more memory than an array representation +because you have to allocation memory for the keys as well as the values. +However, it really isn't that bad, especially since as of version 5.004, +memory is only allocated once for a given hash key, no matter how many +hashes have that key. It's expected that sometime in the future, even +these differences will fade into obscurity as more efficient underlying +representations are devised. + +Still, the tiny edge in speed (and somewhat larger one in memory) +is enough to make some programmers choose an array representation +for simple classes. There's still a little problem with +scalability, though, because later in life when you feel +like creating subclasses, you'll find that hashes just work +out better. + +=head2 Closures as Objects + +Using a code reference to represent an object offers some fascinating +possibilities. We can create a new anonymous function (closure) who +alone in all the world can see the object's data. This is because we +put the data into an anonymous hash that's lexically visible only to +the closure we create, bless, and return as the object. This object's +methods turn around and call the closure as a regular subroutine call, +passing it the field we want to affect. (Yes, +the double-function call is slow, but if you wanted fast, you wouldn't +be using objects at all, eh? :-) + +Use would be similar to before: + + use Person; + $him = Person->new(); + $him->name("Jason"); + $him->age(23); + $him->peers( [ "Norbert", "Rhys", "Phineas" ] ); + printf "%s is %d years old.\n", $him->name, $him->age; + print "His peers are: ", join(", ", @{$him->peers}), "\n"; + +but the implementation would be radically, perhaps even sublimely +different: + + package Person; + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + NAME => undef, + AGE => undef, + PEERS => [], + }; + my $closure = sub { + my $field = shift; + if (@_) { $self->{$field} = shift } + return $self->{$field}; + }; + bless($closure, $class); + return $closure; + } + + sub name { &{ $_[0] }("NAME", @_[ 1 .. $#_ ] ) } + sub age { &{ $_[0] }("AGE", @_[ 1 .. $#_ ] ) } + sub peers { &{ $_[0] }("PEERS", @_[ 1 .. $#_ ] ) } + + 1; + +Because this object is hidden behind a code reference, it's probably a bit +mysterious to those whose background is more firmly rooted in standard +procedural or object-based programming languages than in functional +programming languages whence closures derive. The object +created and returned by the new() method is itself not a data reference +as we've seen before. It's an anonymous code reference that has within +it access to a specific version (lexical binding and instantiation) +of the object's data, which are stored in the private variable $self. +Although this is the same function each time, it contains a different +version of $self. + +When a method like C<$him-E<gt>name("Jason")> is called, its implicit +zeroth argument is the invoking object just as it is with all method +calls. But in this case, it's our code reference (something like a +function pointer in C++, but with deep binding of lexical variables). +There's not a lot to be done with a code reference beyond calling it, so +that's just what we do when we say C<&{$_[0]}>. This is just a regular +function call, not a method call. The initial argument is the string +"NAME", and any remaining arguments are whatever had been passed to the +method itself. + +Once we're executing inside the closure that had been created in new(), +the $self hash reference suddenly becomes visible. The closure grabs +its first argument ("NAME" in this case because that's what the name() +method passed it), and uses that string to subscript into the private +hash hidden in its unique version of $self. + +Nothing under the sun will allow anyone outside the executing method to +be able to get at this hidden data. Well, nearly nothing. You I<could> +single step through the program using the debugger and find out the +pieces while you're in the method, but everyone else is out of luck. + +There, if that doesn't excite the Scheme folks, then I just don't know +what will. Translation of this technique into C++, Java, or any other +braindead-static language is left as a futile exercise for aficionados +of those camps. + +You could even add a bit of nosiness via the caller() function and +make the closure refuse to operate unless called via its own package. +This would no doubt satisfy certain fastidious concerns of programming +police and related puritans. + +If you were wondering when Hubris, the third principle virtue of a +programmer, would come into play, here you have it. (More seriously, +Hubris is just the pride in craftsmanship that comes from having written +a sound bit of well-designed code.) + +=head1 AUTOLOAD: Proxy Methods + +Autoloading is a way to intercept calls to undefined methods. An autoload +routine may choose to create a new function on the fly, either loaded +from disk or perhaps just eval()ed right there. This define-on-the-fly +strategy is why it's called autoloading. + +But that's only one possible approach. Another one is to just +have the autoloaded method itself directly provide the +requested service. When used in this way, you may think +of autoloaded methods as "proxy" methods. + +When Perl tries to call an undefined function in a particular package +and that function is not defined, it looks for a function in +that same package called AUTOLOAD. If one exists, it's called +with the same arguments as the original function would have had. +The fully-qualified name of the function is stored in that package's +global variable $AUTOLOAD. Once called, the function can do anything +it would like, including defining a new function by the right name, and +then doing a really fancy kind of C<goto> right to it, erasing itself +from the call stack. + +What does this have to do with objects? After all, we keep talking about +functions, not methods. Well, since a method is just a function with +an extra argument and some fancier semantics about where it's found, +we can use autoloading for methods, too. Perl doesn't start looking +for an AUTOLOAD method until it has exhausted the recursive hunt up +through @ISA, though. Some programmers have even been known to define +a UNIVERSAL::AUTOLOAD method to trap unresolved method calls to any +kind of object. + +=head2 Autoloaded Data Methods + +You probably began to get a little suspicious about the duplicated +code way back earlier when we first showed you the Person class, and +then later the Employee class. Each method used to access the +hash fields looked virtually identical. This should have tickled +that great programming virtue, Impatience, but for the time, +we let Laziness win out, and so did nothing. Proxy methods can cure +this. + +Instead of writing a new function every time we want a new data field, +we'll use the autoload mechanism to generate (actually, mimic) methods on +the fly. To verify that we're accessing a valid member, we will check +against an C<_permitted> (pronounced "under-permitted") field, which +is a reference to a file-scoped lexical (like a C file static) hash of permitted fields in this record +called %fields. Why the underscore? For the same reason as the _CENSUS +field we once used: as a marker that means "for internal use only". + +Here's what the module initialization code and class +constructor will look like when taking this approach: + + package Person; + use Carp; + use vars qw($AUTOLOAD); # it's a package global + + my %fields = ( + name => undef, + age => undef, + peers => undef, + ); + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + _permitted => \%fields, + %fields, + }; + bless $self, $class; + return $self; + } + +If we wanted our record to have default values, we could fill those in +where current we have C<undef> in the %fields hash. + +Notice how we saved a reference to our class data on the object itself? +Remember that it's important to access class data through the object +itself instead of having any method reference %fields directly, or else +you won't have a decent inheritance. + +The real magic, though, is going to reside in our proxy method, which +will handle all calls to undefined methods for objects of class Person +(or subclasses of Person). It has to be called AUTOLOAD. Again, it's +all caps because it's called for us implicitly by Perl itself, not by +a user directly. + + sub AUTOLOAD { + my $self = shift; + my $type = ref($self) + or croak "$self is not an object"; + + my $name = $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + unless (exists $self->{_permitted}->{$name} ) { + croak "Can't access `$name' field in class $type"; + } + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + +Pretty nifty, eh? All we have to do to add new data fields +is modify %fields. No new functions need be written. + +I could have avoided the C<_permitted> field entirely, but I +wanted to demonstrate how to store a reference to class data on the +object so you wouldn't have to access that class data +directly from an object method. + +=head2 Inherited Autoloaded Data Methods + +But what about inheritance? Can we define our Employee +class similarly? Yes, so long as we're careful enough. + +Here's how to be careful: + + package Employee; + use Person; + use strict; + use vars qw(@ISA); + @ISA = qw(Person); + + my %fields = ( + id => undef, + salary => undef, + ); + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = bless $that->SUPER::new(), $class; + my($element); + foreach $element (keys %fields) { + $self->{_permitted}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + return $self; + } + +Once we've done this, we don't even need to have an +AUTOLOAD function in the Employee package, because +we'll grab Person's version of that via inheritance, +and it will all work out just fine. + +=head1 Metaclassical Tools + +Even though proxy methods can provide a more convenient approach to making +more struct-like classes than tediously coding up data methods as +functions, it still leaves a bit to be desired. For one thing, it means +you have to handle bogus calls that you don't mean to trap via your proxy. +It also means you have to be quite careful when dealing with inheritance, +as detailed above. + +Perl programmers have responded to this by creating several different +class construction classes. These metaclasses are classes +that create other classes. A couple worth looking at are +Class::Template and Alias. These and other related metaclasses can be +found in the modules directory on CPAN. + +=head2 Class::Template + +One of the older ones is Class::Template. In fact, its syntax and +interface were sketched out long before perl5 even solidified into a +real thing. What it does is provide you a way to "declare" +a class as having objects whose fields are of a specific type. +The function that does this is called, not surprisingly +enough, struct(). + +Here's a simple example of using it: + + use Class::Template qw(struct); + use Jobbie; # user-defined; see below + + struct 'Fred' => { + one => '$', + many => '@', + profession => Jobbie, # calls Jobbie->new() + }; + + $ob = Fred->new; + $ob->one("hmmmm"); + + $ob->many(0, "here"); + $ob->many(1, "you"); + $ob->many(2, "go"); + print "Just set: ", $ob->many(2), "\n"; + + $ob->profession->salary(10_000); + +You can declare types in the struct to be basic Perl types, or +user-defined types (classes). User types will be initialized by calling +that class's new() method. + +Here's a real-world example of using struct generation. Let's say you +wanted to override Perl's idea of gethostbyname() and gethostbyaddr() so +that they would return objects that acted like C structures. We don't +care about high-falutin' OO gunk. All we want is for these objects to +act like structs in the C sense. + + use Socket; + use Net::hostent; + $h = gethostbyname("perl.com"); # object return + printf "perl.com's real name is %s, address %s\n", + $h->name, inet_ntoa($h->addr); + +Here's how to do this using the Class::Template module. +The crux is going to be this call: + + struct 'Net::hostent' => [ # note bracket + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + ]; + +Which creates object methods of those names and types. +It even creates a new() method for us. + +We could also have implemented our object this way: + + struct 'Net::hostent' => { # note brace + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + }; + +and then Class::Template would have used an anonymous hash as the object +type, instead of an anonymous array. The array is faster and smaller, +but the hash works out better if you eventually want to do inheritance. +Since for this struct-like object we aren't planning on inheritance, +this time we'll opt for better speed and size over better flexibility. + +Here's the whole implementation: + + package Net::hostent; + use strict; + + BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(gethostbyname gethostbyaddr gethost); + @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + } + use vars @EXPORT_OK; + + use Class::Template qw(struct); + struct 'Net::hostent' => [ + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + ]; + + sub addr { shift->addr_list->[0] } + + sub populate (@) { + return unless @_; + my $hob = new(); # Class::Template made this! + $h_name = $hob->[0] = $_[0]; + @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; + $h_addrtype = $hob->[2] = $_[2]; + $h_length = $hob->[3] = $_[3]; + $h_addr = $_[4]; + @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; + return $hob; + } + + sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } + + sub gethostbyaddr ($;$) { + my ($addr, $addrtype); + $addr = shift; + require Socket unless @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::gethostbyaddr($addr, $addrtype)) + } + + sub gethost($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &gethostbyaddr(Socket::inet_aton(shift)); + } else { + &gethostbyname; + } + } + + 1; + +We've snuck in quite a fair bit of other concepts besides just dynamic +class creation, like overriding core functions, import/export bits, +function prototyping, and short-cut function call via C<&whatever>. +These all mostly make sense from the perspective of a traditional module, +but as you can see, we can also use them in an object module. + +You can look at other object-based, struct-like overrides of core +functions in the 5.004 release of Perl in File::stat, Net::hostent, +Net::netent, Net::protoent, Net::servent, Time::gmtime, Time::localtime, +User::grent, and User::pwent. These modules have a final component +that's all lower-case, by convention reserved for compiler pragmas, +because they affect the compilation and change a built-in function. +They also have the type names that a C programmer would most expect. + +=head2 Data Members as Variables + +If you're used to C++ objects, then you're accustomed to being able to +get at an object's data members as simple variables from within a method. +The Alias module provides for this, as well as a good bit more, such +as the possibility of private methods that the object can call but folks +outside the class cannot. + +Here's an example of creating a Person using the Alias module. +When you update these magical instance variables, you automatically +update value fields in the hash. Convenient, eh? + + package Person; + + # this is the same as before... + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + NAME => undef, + AGE => undef, + PEERS => [], + }; + bless($self, $class); + return $self; + } + + use Alias qw(attr); + use vars qw($NAME $AGE $PEERS); + + sub name { + my $self = attr shift; + if (@_) { $NAME = shift; } + return $NAME; + } + + sub age { + my $self = attr shift; + if (@_) { $AGE = shift; } + return $AGE; + } + + sub peers { + my $self = attr shift; + if (@_) { @PEERS = @_; } + return @PEERS; + } + + sub exclaim { + my $self = attr shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $NAME, $AGE, join(", ", @PEERS); + } + + sub happy_birthday { + my $self = attr shift; + return ++$AGE; + } + +The need for the C<use vars> declaration is because what Alias does +is play with package globals with the same name as the fields. To use +globals while C<use strict> is in effect, you have to pre-declare them. +These package variables are localized to the block enclosing the attr() +call just as if you'd used a local() on them. However, that means that +they're still considered global variables with temporary values, just +as with any other local(). + +It would be nice to combine Alias with +something like Class::Template or Class::MethodMaker. + +=head2 NOTES + +=head2 Object Terminology + +In the various OO literature, it seems that a lot of different words +are used to describe only a few different concepts. If you're not +already an object programmer, then you don't need to worry about all +these fancy words. But if you are, then you might like to know how to +get at the same concepts in Perl. + +For example, it's common to call an object an I<instance> of a class +and to call those objects' methods I<instance methods>. Data fields +peculiar to each object are often called I<instance data> or I<object +attributes>, and data fields common to all members of that class are +I<class data>, I<class attributes>, or I<static data members>. + +Also, I<base class>, I<generic class>, and I<superclass> all describe +the same notion, whereas I<derived class>, I<specific class>, and +I<subclass> describe the other related one. + +C++ programmers have I<static methods> and I<virtual methods>, +but Perl only has I<class methods> and I<object methods>. +Actually, Perl only has methods. Whether a method gets used +as a class or object method is by usage only. You could accidentally +call a class method (one expecting a string argument) on an +object (one expecting a reference), or vice versa. + +>From the C++ perspective, all methods in Perl are virtual. +This, by the way, is why they are never checked for function +prototypes in the argument list as regular built-in and user-defined +functions can be. + +Because a class is itself something of an object, Perl's classes can be +taken as describing both a "class as meta-object" (also called I<object +factory>) philosophy and the "class as type definition" (I<declaring> +behaviour, not I<defining> mechanism) idea. C++ supports the latter +notion, but not the former. + +=head1 SEE ALSO + +The following man pages will doubtless provide more +background for this one: +L<perlmod>, +L<perlref>, +L<perlobj>, +L<perlbot>, +L<perltie>, +and +L<overload>. + +=head1 COPYRIGHT + +I I<really> hate to have to say this, but recent unpleasant +experiences have mandated its inclusion: + + Copyright 1996 Tom Christiansen. All Rights Reserved. + +This work derives in part from the second edition of I<Programming Perl>. +Although destined for release as a man page with the standard Perl +distribution, it is not public domain (nor is any of Perl and its docset: +publishers beware). It's expected to someday make its way into a revision +of the Camel Book. While it is copyright by me with all rights reserved, +permission is granted to freely distribute verbatim copies of this +document provided that no modifications outside of formatting be made, +and that this notice remain intact. You are permitted and encouraged to +use its code and derivatives thereof in your own source code for fun or +for profit as you see fit. But so help me, if in six months I find some +book out there with a hacked-up version of this material in it claiming to +be written by someone else, I'll tell all the world that you're a jerk. +Furthermore, your lawyer will meet my lawyer (or O'Reilly's) over lunch +to arrange for you to receive your just deserts. Count on it. + +=head2 Acknowledgments + +Thanks to +Larry Wall, +Roderick Schertler, +Gurusamy Sarathy, +Dean Roehrich, +Raphael Manfredi, +Brent Halsey, +Greg Bacon, +Brad Appleton, +and many others for their helpful comments. diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 3d31173584..4b56dd23d8 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -101,8 +101,8 @@ basically incompatible with C.) =item * The concatenation operator is ".", not the null string. (Using the -null string would render C</pat/ /pat/> unparsable, since the third slash -would be interpreted as a division operator--the tokener is in fact +null string would render C</pat/ /pat/> unparsable, because the third slash +would be interpreted as a division operator--the tokenizer is in fact slightly context sensitive for operators like "/", "?", and "E<gt>". And in fact, "." itself can be the beginning of a number.) @@ -183,7 +183,7 @@ Comments begin with "#", not "/*". =item * You can't take the address of anything, although a similar operator -in Perl 5 is the backslash, which creates a reference. +in Perl is the backslash, which creates a reference. =item * @@ -231,18 +231,18 @@ Sharp shell programmers should take note of the following: =item * -The backtick operator does variable interpolation without regard to +The back-tick operator does variable interpolation without regard to the presence of single quotes in the command. =item * -The backtick operator does no translation of the return value, unlike B<csh>. +The back-tick operator does no translation of the return value, unlike B<csh>. =item * Shells (especially B<csh>) do several levels of substitution on each -command line. Perl does substitution only in certain constructs -such as double quotes, backticks, angle brackets, and search patterns. +command line. Perl does substitution in only certain constructs +such as double quotes, back-ticks, angle brackets, and search patterns. =item * @@ -275,16 +275,16 @@ context than they do in a scalar one. See L<perldata> for details. =item * Avoid barewords if you can, especially all lower-case ones. -You can't tell just by looking at it whether a bareword is +You can't tell by just looking at it whether a bareword is a function or a string. By using quotes on strings and -parens on function calls, you won't ever get them confused. +parentheses on function calls, you won't ever get them confused. =item * You cannot discern from mere inspection which built-ins are unary operators (like chop() and chdir()) and which are list operators (like print() and unlink()). -(User-defined subroutines can B<only> be list operators, never +(User-defined subroutines can be B<only> list operators, never unary ones.) See L<perlop>. =item * @@ -296,7 +296,7 @@ you might expect to do not. =item * The E<lt>FHE<gt> construct is not the name of the filehandle, it is a readline -operation on that handle. The data read is only assigned to $_ if the +operation on that handle. The data read is assigned to $_ only if the file read is the sole condition in a while loop: while (<FH>) { } @@ -332,7 +332,7 @@ external name is still an alias for the original. =back -=head2 Perl4 to Perl5 Traps +=head2 Perl4 to Perl5 Traps Practicing Perl4 Programmers should take note of the following Perl4-to-Perl5 specific traps. @@ -419,7 +419,7 @@ for C<$_> itself (and C<@_>, etc.). =item * Deprecation Double-colon is now a valid package separator in a variable name. Thus these -behave differently in perl4 vs. perl5, since the packages don't exist. +behave differently in perl4 vs. perl5, because the packages don't exist. $a=1;$b=2;$c=3;$var=4; print "$a::$b::$c "; @@ -549,6 +549,36 @@ behave like C<split /\s+/> (which does). # perl4 prints: :hi:mom # perl5 prints: hi:mom +=item * BugFix + +Perl 4 would ignore any text which was attached to an C<-e> switch, +always taking the code snippet from the following arg. Additionally, it +would silently accept an C<-e> switch without a following arg. Both of +these behaviors have been fixed. + + perl -e'print "attached to -e"' 'print "separate arg"' + + # perl4 prints: separate arg + # perl5 prints: attached to -e + + perl -e + + # perl4 prints: + # perl5 dies: No code specified for -e. + +=item * Discontinuance + +In Perl 4 the return value of C<push> was undocumented, but it was +actually the last value being pushed onto the target list. In Perl 5 +the return value of C<push> is documented, but has changed, it is the +number of elements in the resulting list. + + @x = ('existing'); + print push(@x, 'first new', 'second new'); + + # perl4 prints: second new + # perl5 prints: 3 + =item * Deprecation Some error messages will be different. @@ -622,9 +652,10 @@ Formatted output and significant digits =item * Numerical -This specific item has been deleted. It demonstrated how the autoincrement +This specific item has been deleted. It demonstrated how the auto-increment operator would not catch when a number went over the signed int limit. Fixed -in 5.003_04. But always be wary when using large ints. If in doubt: +in version 5.003_04. But always be wary when using large integers. +If in doubt: use Math::BigInt; @@ -633,15 +664,15 @@ in 5.003_04. But always be wary when using large ints. If in doubt: Assignment of return values from numeric equality tests does not work in perl5 when the test evaluates to false (0). Logical tests now return an null, instead of 0 - + $p = ($test == 1); print $p,"\n"; - + # perl4 prints: 0 # perl5 prints: -Also see the L<General Regular Expression Traps> tests for another example -of this new feature... +Also see the L<General Regular Expression Traps using s///, etc.> +tests for another example of this new feature... =back @@ -765,7 +796,7 @@ The behavior is slightly different for: Variable suicide behavior is more consistent under Perl 5. Perl5 exhibits the same behavior for associative arrays and scalars, -that perl4 exhibits only for scalars. +that perl4 exhibits for only scalars. $aGlobal{ "aKey" } = "global value"; print "MAIN:", $aGlobal{"aKey"}, "\n"; @@ -904,7 +935,7 @@ of assignment. Perl 4 mistakenly gave them the precedence of the associated operator. So you now must parenthesize them in expressions like /foo/ ? ($a += 2) : ($a -= 2); - + Otherwise /foo/ ? $a += 2 : $a -= 2 @@ -923,8 +954,8 @@ now works as a C programmer would expect. open FOO || die; -is now incorrect. You need parens around the filehandle. -Otherwise, perl5 leaves the statement as it's default precedence: +is now incorrect. You need parentheses around the filehandle. +Otherwise, perl5 leaves the statement as its default precedence: open(FOO || die); @@ -1025,8 +1056,8 @@ Also see L<Numerical Traps> for another example of this new feature. =item * Regular Expression -C<s`lhs`rhs`> (using backticks) is now a normal substitution, with no -backtick expansion +C<s`lhs`rhs`> (using back-ticks) is now a normal substitution, with no +back-tick expansion $string = ""; $string =~ s`^`hostname`; @@ -1077,6 +1108,26 @@ repeatedly, like C</x/> or C<m!x!>. # perl5 prints: perl5 +=item * Regular Expression + +Under perl4 and upto version 5.003, a failed C<m//g> match used to +reset the internal iterator, so that subsequent C<m//g> match attempts +began from the beginning of the string. In perl version 5.004 and later, +failed C<m//g> matches do not reset the iterator position (which can be +found using the C<pos()> function--see L<perlfunc/pos>). + + $test = "foop"; + for (1..3) { + print $1 while ($test =~ /(o)/g); + # pos $test = 0; # to get old behavior + } + + # perl4 prints: oooooo + # perl5.004 prints: oo + +You may always reset the iterator yourself as shown in the commented line +to get the old behavior. + =back =head2 Subroutine, Signal, Sorting Traps @@ -1134,7 +1185,7 @@ within the signal handler function, each time a signal was handled with perl4. With perl5, the reset is now done correctly. Any code relying on the handler _not_ being reset will have to be reworked. -5.002 and beyond uses sigaction() under SysV +Since version 5.002, Perl uses sigaction() under SysV. sub gotit { print "Got @_... "; @@ -1157,7 +1208,7 @@ on the handler _not_ being reset will have to be reworked. =item * (SysV) Under SysV OS's, C<seek()> on a file opened to append C<E<gt>E<gt>> now does -the right thing w.r.t. the fopen() man page. e.g. - When a file is opened +the right thing w.r.t. the fopen() man page. e.g., - When a file is opened for append, it is impossible to overwrite information already in the file. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index b0e2cf319f..de9bd22348 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -7,7 +7,7 @@ perlvar - Perl predefined variables =head2 Predefined Names The following names have special meaning to Perl. Most of the -punctuational names have reasonable mnemonics, or analogues in one of +punctuation names have reasonable mnemonics, or analogues in one of the shells. Nevertheless, if you wish to use the long variable names, you just need to say @@ -51,7 +51,7 @@ a reference, you'll raise a run-time exception. The default input and pattern-searching space. The following pairs are equivalent: - while (<>) {...} # only equivalent in while! + while (<>) {...} # equivalent in only while! while ($_ = <>) {...} /^Subject:/ @@ -108,7 +108,7 @@ test. Note that outside of a C<while> test, this will not happen. =item $E<lt>I<digit>E<gt> -Contains the subpattern from the corresponding set of parentheses in +Contains the sub-pattern from the corresponding set of parentheses in the last pattern matched, not counting patterns matched in nested blocks that have been exited already. (Mnemonic: like \digit.) These variables are all read-only. @@ -162,15 +162,15 @@ This variable is read-only. =item $* -Set to 1 to do multiline matching within a string, 0 to tell Perl +Set to 1 to do multi-line matching within a string, 0 to tell Perl that it can assume that strings contain a single line, for the purpose of optimizing pattern matches. Pattern matches on strings containing multiple newlines can produce confusing results when "C<$*>" is 0. Default is 0. (Mnemonic: * matches multiple things.) Note that this variable -only influences the interpretation of "C<^>" and "C<$>". A literal newline can +influences the interpretation of only "C<^>" and "C<$>". A literal newline can be searched for even when C<$* == 0>. -Use of "C<$*>" is deprecated in Perl 5. +Use of "C<$*>" is deprecated in modern perls. =item input_line_number HANDLE EXPR @@ -182,7 +182,7 @@ Use of "C<$*>" is deprecated in Perl 5. The current input line number for the last file handle from which you read (or performed a C<seek> or C<tell> on). An -explicit close on a filehandle resets the line number. Since +explicit close on a filehandle resets the line number. Because "C<E<lt>E<gt>>" never does an explicit close, line numbers increase across ARGV files (but see examples under eof()). Localizing C<$.> has the effect of also localizing Perl's notion of "the last read @@ -221,8 +221,8 @@ delimit line boundaries when quoting poetry.) If set to nonzero, forces a flush after every write or print on the currently selected output channel. Default is 0 (regardless of whether -the channel is actually buffered by the system or not; C<$|> only tells -you whether you've asked Perl to explicitly flush after each write). +the channel is actually buffered by the system or not; C<$|> tells you +only whether you've asked Perl explicitly to flush after each write). Note that STDOUT will typically be line buffered if output is to the terminal and block buffered otherwise. Setting this variable is useful primarily when you are outputting to a pipe, such as when you are running @@ -239,8 +239,8 @@ has no effect on input buffering. =item $, The output field separator for the print operator. Ordinarily the -print operator simply prints out the comma separated fields you -specify. In order to get behavior more like B<awk>, set this variable +print operator simply prints out the comma-separated fields you +specify. To get behavior more like B<awk>, set this variable as you would set B<awk>'s OFS variable to specify what is printed between fields. (Mnemonic: what is printed when there is a , in your print statement.) @@ -254,9 +254,9 @@ print statement.) =item $\ The output record separator for the print operator. Ordinarily the -print operator simply prints out the comma separated fields you -specify, with no trailing newline or record separator assumed. In -order to get behavior more like B<awk>, set this variable as you would +print operator simply prints out the comma-separated fields you +specify, with no trailing newline or record separator assumed. +To get behavior more like B<awk>, set this variable as you would set B<awk>'s ORS variable to specify what is printed at the end of the print. (Mnemonic: you set "C<$\>" instead of adding \n at the end of the print. Also, it's just like C<$/>, but it's what you get "back" from @@ -299,7 +299,7 @@ keys contain binary data there might not be any safe value for "C<$;>". semi-semicolon. Yeah, I know, it's pretty lame, but "C<$,>" is already taken for something more important.) -Consider using "real" multi-dimensional arrays in Perl 5. +Consider using "real" multi-dimensional arrays. =item $OFMT @@ -313,7 +313,7 @@ of the macro DBL_DIG from your system's F<float.h>. This is different from B<awk>'s default OFMT setting of %.6g, so you need to set "C<$#>" explicitly to get B<awk>'s value. (Mnemonic: # is the number sign.) -Use of "C<$#>" is deprecated in Perl 5. +Use of "C<$#>" is deprecated. =item format_page_number HANDLE EXPR @@ -379,7 +379,7 @@ poetry is a part of a line.) =item $^L -What formats output to perform a formfeed. Default is \f. +What formats output to perform a form feed. Default is \f. =item $ACCUMULATOR @@ -396,7 +396,7 @@ L<perlfunc/formline()>. =item $? -The status returned by the last pipe close, backtick (C<``>) command, +The status returned by the last pipe close, back-tick (C<``>) command, or system() operator. Note that this is the status word returned by the wait() system call, so the exit value of the subprocess is actually (C<$? E<gt>E<gt> 8>). Thus on many systems, C<$? & 255> gives which signal, @@ -418,7 +418,7 @@ all the usual caveats. (This means that you shouldn't depend on the value of "C<$!>" to be anything in particular unless you've gotten a specific error return indicating a system error.) If used in a string context, yields the corresponding system error string. You can assign -to "C<$!>" in order to set I<errno> if, for instance, you want "C<$!>" to return the +to "C<$!>" to set I<errno> if, for instance, you want "C<$!>" to return the string for error I<n>, or you want to set the exit value for the die() operator. (Mnemonic: What just went bang?) @@ -429,7 +429,7 @@ operator. (Mnemonic: What just went bang?) More specific information about the last system error than that provided by C<$!>, if available. (If not, it's just C<$!> again, except under OS/2.) -At the moment, this differs from C<$!> only under VMS and OS/2, where it +At the moment, this differs from C<$!> under only VMS and OS/2, where it provides the VMS status value from the last system error, and OS/2 error code of the last call to OS/2 API which was not directed via CRT. The caveats mentioned in the description of C<$!> apply here, too. @@ -481,7 +481,7 @@ The effective uid of this process. Example: ($<,$>) = ($>,$<); # swap real and effective uid (Mnemonic: it's the uid you went I<TO>, if you're running setuid.) Note: -"C<$E<lt>>" and "C<$E<gt>>" can only be swapped on machines supporting setreuid(). +"C<$E<lt>>" and "C<$E<gt>>" can be swapped on only machines supporting setreuid(). =item $REAL_GROUP_ID @@ -510,10 +510,11 @@ which may be the same as the first number. (Mnemonic: parentheses are used to I<GROUP> things. The effective gid is the group that's I<RIGHT> for you, if you're running setgid.) -Note: "C<$E<lt>>", "C<$E<gt>>", "C<$(>" and "C<$)>" can only be set on machines -that support the corresponding I<set[re][ug]id()> routine. "C<$(>" and "C<$)>" -can only be swapped on machines supporting setregid(). Because Perl doesn't -currently use initgroups(), you can't set your group vector to multiple groups. +Note: "C<$E<lt>>", "C<$E<gt>>", "C<$(>" and "C<$)>" can be set only on +machines that support the corresponding I<set[re][ug]id()> routine. "C<$(>" +and "C<$)>" can be swapped on only machines supporting setregid(). Because +Perl doesn't currently use initgroups(), you can't set your group vector to +multiple groups. =item $PROGRAM_NAME @@ -612,7 +613,7 @@ it. =item $^T The time at which the script began running, in seconds since the -epoch (beginning of 1970). The values returned by the B<-M>, B<-A> +epoch (beginning of 1970). The values returned by the B<-M>, B<-A>, and B<-C> filetests are based on this value. @@ -637,7 +638,7 @@ contains the name of the current file when reading from E<lt>E<gt>. The array @ARGV contains the command line arguments intended for the script. Note that C<$#ARGV> is the generally number of arguments minus -one, since C<$ARGV[0]> is the first argument, I<NOT> the command name. See +one, because C<$ARGV[0]> is the first argument, I<NOT> the command name. See "C<$0>" for the command name. =item @INC @@ -647,8 +648,8 @@ be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It initially consists of the arguments to any B<-I> command line switches, followed by the default Perl library, probably F</usr/local/lib/perl>, followed by ".", to represent the current directory. If you need to -modify this at runtime, you should use the C<use lib> pragma in order -to also get the machine-dependent library properly loaded: +modify this at runtime, you should use the C<use lib> pragma +to get the machine-dependent library properly loaded also: use lib '/mypath/libdir/'; use SomeMod; @@ -684,7 +685,7 @@ signals. Example: $SIG{'INT'} = 'DEFAULT'; # restore default action $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT -The %SIG array only contains values for the signals actually set within +The %SIG array contains values for only the signals actually set within the Perl script. Here are some other examples: $SIG{PIPE} = Plumber; # SCARY!! @@ -697,6 +698,22 @@ sometimes it's a string representing the function, and sometimes it's going to call the subroutine call right then and there! Best to be sure and quote it or take a reference to it. *Plumber works too. See L<perlsub>. +If your system has the sigaction() function then signal handlers are +installed using it. This means you get reliable signal handling. If +your system has the SA_RESTART flag it is used when signals handlers are +installed. This means that system calls for which it is supported +continue rather than returning when a signal arrives. If you want your +system calls to be interrupted by signal delivery then do something like +this: + + use POSIX ':signal_h'; + + my $alarm = 0; + sigaction SIGALRM, new POSIX::SigAction sub { $alarm = 1 } + or die "Error setting SIGALRM handler: $!\n"; + +See L<POSIX>. + Certain internal hooks can be also set using the %SIG hash. The routine indicated by C<$SIG{__WARN__}> is called when a warning message is about to be printed. The warning message is passed as the first diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 6a898a5331..26418b51a9 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -560,7 +560,7 @@ the following statement. =head2 Returning Undef And Empty Lists -Occasionally the programmer will want to simply return +Occasionally the programmer will want to return simply C<undef> or an empty list if a function fails rather than a separate status value. The rpcb_gettime() function offers just this situation. If the function succeeds we would like @@ -631,7 +631,7 @@ other C<XSRETURN> macros. The REQUIRE: keyword is used to indicate the minimum version of the B<xsubpp> compiler needed to compile the XS module. An XS module which -contains the following statement will only compile with B<xsubpp> version +contains the following statement will compile with only B<xsubpp> version 1.922 or greater: REQUIRE: 1.922 @@ -664,7 +664,7 @@ terminate the code block. =head2 The VERSIONCHECK: Keyword The VERSIONCHECK: keyword corresponds to B<xsubpp>'s C<-versioncheck> and -C<-noversioncheck> options. This keyword overrides the commandline +C<-noversioncheck> options. This keyword overrides the command line options. Version checking is enabled by default. When version checking is enabled the XS module will attempt to verify that its version matches the version of the PM module. @@ -680,7 +680,7 @@ To disable version checking: =head2 The PROTOTYPES: Keyword The PROTOTYPES: keyword corresponds to B<xsubpp>'s C<-prototypes> and -C<-noprototypes> options. This keyword overrides the commandline options. +C<-noprototypes> options. This keyword overrides the command-line options. Prototypes are enabled by default. When prototypes are enabled XSUBs will be given Perl prototypes. This keyword may be used multiple times in an XS module to enable and disable prototypes for different parts of the module. @@ -844,7 +844,7 @@ C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>. =head2 Inserting Comments and C Preprocessor Directives C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, -CODE:, PPCODE: and CLEANUP: blocks, as well as outside the functions. +CODE:, PPCODE:, and CLEANUP: blocks, as well as outside the functions. Comments are allowed anywhere after the MODULE keyword. The compiler will pass the preprocessor directives through untouched and will remove the commented lines. @@ -953,7 +953,7 @@ example. # char* having the name of the package for the blessing. O_OBJECT sv_setref_pv( $arg, CLASS, (void*)$var ); - + INPUT O_OBJECT if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) ) diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index 0c6cf3fb22..0ad1b1038d 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -10,8 +10,8 @@ L<perlxs>. This tutorial starts with very simple examples and becomes more complex, with each new example adding new features. Certain concepts may not be -completely explained until later in the tutorial in order to slowly ease -the reader into building extensions. +completely explained until later in the tutorial to ease the +reader slowly into building extensions. =head2 VERSION CAVEAT @@ -25,21 +25,21 @@ features were added to Perl 5. =item * -In versions of 5.002 prior to the gamma version, the test script in Example -1 will not function properly. You need to change the "use lib" line to -read: +In versions of Perl 5.002 prior to the gamma version, the test script +in Example 1 will not function properly. You need to change the "use +lib" line to read: use lib './blib'; =item * -In versions of 5.002 prior to version beta 3, the line in the .xs file +In versions of Perl 5.002 prior to version beta 3, the line in the .xs file about "PROTOTYPES: DISABLE" will cause a compiler error. Simply remove that line from the file. =item * -In versions of 5.002 prior to version 5.002b1h, the test.pl file was not +In versions of Perl 5.002 prior to version 5.002b1h, the test.pl file was not automatically created by h2xs. This means that you cannot say "make test" to run the test script. You will need to add the following line before the "use extension" statement: @@ -63,7 +63,7 @@ Some systems may have installed Perl version 5 as "perl5". =head2 DYNAMIC VERSUS STATIC It is commonly thought that if a system does not have the capability to -dynamically load a library, you cannot build XSUBs. This is incorrect. +load a library dynamically, you cannot build XSUBs. This is incorrect. You I<can> build them, but you must link the XSUB's subroutines with the rest of Perl, creating a new executable. This situation is similar to Perl 4. @@ -227,7 +227,7 @@ Now re-run make to rebuild our new shared library. Now perform the same steps as before, generating a Makefile from the Makefile.PL file, and running make. -In order to test that our extension works, we now need to look at the +To test that our extension works, we now need to look at the file test.pl. This file is set up to imitate the same kind of testing structure that Perl itself has. Within the test script, you perform a number of tests to confirm the behavior of the extension, printing "ok" @@ -446,7 +446,7 @@ section on the argument stack. =head2 WARNING In general, it's not a good idea to write extensions that modify their input -parameters, as in Example 3. However, in order to better accommodate calling +parameters, as in Example 3. However, to accommodate better calling pre-existing C routines, which often do modify their input parameters, this behavior is tolerated. The next example will show how to do this. @@ -490,12 +490,13 @@ And finally create a file Makefile.PL that looks like this: use ExtUtils::MakeMaker; $Verbose = 1; WriteMakefile( - 'NAME' => 'Mytest2::mylib', - 'clean' => {'FILES' => 'libmylib.a'}, + NAME => 'Mytest2::mylib', + SKIP => [qw(all static static_lib dynamic dynamic_lib)], + clean => {'FILES' => 'libmylib$(LIB_EXT)'}, ); - sub MY::postamble { + sub MY::top_targets { ' all :: static @@ -533,7 +534,8 @@ and a new replacement subroutine too: } (Note: Most makes will require that there be a tab character that indents -the line "cd mylib && $(MAKE)".) +the line "cd mylib && $(MAKE)", similarly for the Makefile in the +subdirectory.) Let's also fix the MANIFEST file so that it accurately reflects the contents of our extension. The single line that says "mylib" should be replaced by @@ -577,7 +579,7 @@ and add the following lines to the end of the script: print &Mytest2::foo(1, 2, "0.0") == 7 ? "ok 3\n" : "not ok 3\n"; print abs(&Mytest2::foo(0, 0, "-3.4") - 0.6) <= 0.01 ? "ok 4\n" : "not ok 4\n"; -(When dealing with floating-point comparisons, it is often useful to not check +(When dealing with floating-point comparisons, it is often useful not to check for equality, but rather the difference being below a certain epsilon factor, 0.01 in this case) @@ -607,7 +609,7 @@ C<constant> routine. The .pm file has exported the name TESTVAL in the @EXPORT array. This could lead to name clashes. A good rule of thumb is that if the #define -is only going to be used by the C routines themselves, and not by the user, +is going to be used by only the C routines themselves, and not by the user, they should be removed from the @EXPORT array. Alternately, if you don't mind using the "fully qualified name" of a variable, you could remove most or all of the items in the @EXPORT array. @@ -620,12 +622,12 @@ processed at all by h2xs. There is no good solution to this right now. =back We've also told Perl about the library that we built in the mylib -subdirectory. That required only the addition of the MYEXTLIB variable +subdirectory. That required the addition of only the MYEXTLIB variable to the WriteMakefile call and the replacement of the postamble subroutine to cd into the subdirectory and run make. The Makefile.PL for the library is a bit more complicated, but not excessively so. Again we replaced the postamble subroutine to insert our own code. This code -simply specified that the library to be created here was a static +specified simply that the library to be created here was a static archive (as opposed to a dynamically loadable library) and provided the commands to build it. @@ -696,7 +698,7 @@ Sometimes you might want to provide some extra methods or subroutines to assist in making the interface between Perl and your extension simpler or easier to understand. These routines should live in the .pm file. Whether they are automatically loaded when the extension itself is loaded -or only loaded when called depends on where in the .pm file the subroutine +or loaded only when called depends on where in the .pm file the subroutine definition is placed. =head2 DOCUMENTING YOUR EXTENSION diff --git a/pod/pod2html.PL b/pod/pod2html.PL index ced84783e5..816fb6ba4c 100644 --- a/pod/pod2html.PL +++ b/pod/pod2html.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,14 +23,15 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -eval 'exec perl -S $0 ${1+"$@"}' - if $running_under_some_shell; + # # pod2html - convert pod format to html # Version 1.15 @@ -118,8 +117,9 @@ for $count (0,1) { open(HTML,">$html") || die "can't create $html: $ERRNO"; print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n"; print HTML "<CENTER>" unless $NO_NS; - print HTML "<TITLE>$pod</TITLE>\n</HEAD>\n<BODY>"; + print HTML "<TITLE>$pod</TITLE>"; print HTML "</CENTER>" unless $NO_NS; + print HTML "\n</HEAD>\n<BODY>"; } for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ; @@ -322,6 +322,7 @@ sub scan_thing{ # scan a chunk for later references my($cmd,$title,$pod) = @_; $_ = $title; s/\n$//; + s/E<(\d+)>/&#$1;/g; s/E<(.*?)>/&$1;/g; # remove any formatting information for the headers s/[SFCBI]<(.*?)>/$1/g; @@ -378,7 +379,7 @@ sub picrefs { } } if (length($key)) { - ($pod2,$num) = split(/_/,$value,2); + ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/; if ($htype eq "NAME") { return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n" } @@ -506,6 +507,7 @@ sub pre_escapes { # twiddle these, and stay up late :-) s/&/noremap("&")/ge; s/<</noremap("<<")/eg; s/([^ESIBLCF])</$1\<\;/g; + s/E<(\d+)>/\&#$1\;/g; # embedded numeric special s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special } } diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL index 602364e2ec..9702614ffa 100644 --- a/pod/pod2latex.PL +++ b/pod/pod2latex.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -124,11 +122,21 @@ open(LATEX,">$pod.tex"); &do_hdr(); $cutting = 1; +$begun = ""; while (<POD>) { if ($cutting) { next unless /^=/; $cutting = 0; } + if ($begun) { + if (/^=end\s+$begun/) { + $begun = ""; + } + elsif ($begun =~ /^(tex|latex)$/) { + print LATEX $_; + } + next; + } chop; length || (print LATEX "\n") && next; @@ -146,6 +154,22 @@ while (<POD>) { next; } + if (/^=for\s+(\S+)\s*/s) { + if ($1 eq "tex" or $1 eq "latex") { + print LATEX $',"\n"; + } else { + # ignore unknown for + } + next; + } + elsif (/^=begin\s+(\S+)\s*/s) { + $begun = $1; + if ($1 eq "tex" or $1 eq "latex") { + print LATEX $'."\n"; + } + next; + } + # preserve '=item' line with pod quotes as they are. if (/^=item/) { ($bareitem = $_) =~ s/^=item\s*//; diff --git a/pod/pod2man.PL b/pod/pod2man.PL index a4a3c25eeb..5d1e193a34 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,14 +23,14 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -eval 'exec perl -S $0 "$@"' - if 0; =head1 NAME @@ -388,8 +386,11 @@ $wanna_see{SYNOPSIS}++ if $section =~ /^3/; $name = @ARGV ? $ARGV[0] : "<STDIN>"; $Filename = $name; -$name = uc($name) if $section =~ /^1/; -$name =~ s/\.[^.]*$//; +if ($section =~ /^1/) { + require File::Basename; + $name = uc File::Basename::basename($name); +} +$name =~ s/\.(pod|p[lm])$//i; $name =~ s(/)(::)g; # translate Getopt/Long to Getopt::Long, etc. if ($name ne 'something') { @@ -605,11 +606,22 @@ END $indent = 0; +$begun = ""; + while (<>) { if ($cutting) { next unless /^=/; $cutting = 0; } + if ($begun) { + if (/^=end\s+$begun/) { + $begun = ""; + } + elsif ($begun =~ /^(roff|man)$/) { + print STDOUT $_; + } + next; + } chomp; # Translate verbatim paragraph @@ -634,6 +646,22 @@ while (<>) { $verbatim = 0; + if (/^=for\s+(\S+)\s*/s) { + if ($1 eq "man" or $1 eq "roff") { + print STDOUT $',"\n\n"; + } else { + # ignore unknown for + } + next; + } + elsif (/^=begin\s+(\S+)\s*/s) { + $begun = $1; + if ($1 eq "man" or $1 eq "roff") { + print STDOUT $'."\n\n"; + } + next; + } + # check for things that'll hosed our noremap scheme; affects $_ init_noremap(); diff --git a/pod/pod2text.PL b/pod/pod2text.PL index 49198078c0..586da04e0f 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. diff --git a/pod/roffitall b/pod/roffitall index 024279a69e..6bf47afad4 100644..100755 --- a/pod/roffitall +++ b/pod/roffitall @@ -1,84 +1,171 @@ #!/bin/sh -#psroff -t -man -rC1 -rD1 -rF1 > /tmp/PerlDoc.ps 2>/tmp/PerlTOC.raw \ -nroff -man -rC1 -rD1 -rF1 > /tmp/PerlDoc.txt 2>/tmp/PerlTOC.nr.raw \ - /usr/local/man/man1/perl.1 \ - /usr/local/man/man1/perldata.1 \ - /usr/local/man/man1/perlsyn.1 \ - /usr/local/man/man1/perlop.1 \ - /usr/local/man/man1/perlre.1 \ - /usr/local/man/man1/perlrun.1 \ - /usr/local/man/man1/perlfunc.1 \ - /usr/local/man/man1/perlvar.1 \ - /usr/local/man/man1/perlsub.1 \ - /usr/local/man/man1/perlmod.1 \ - /usr/local/man/man1/perlref.1 \ - /usr/local/man/man1/perldsc.1 \ - /usr/local/man/man1/perllol.1 \ - /usr/local/man/man1/perlobj.1 \ - /usr/local/man/man1/perltie.1 \ - /usr/local/man/man1/perlbot.1 \ - /usr/local/man/man1/perldebug.1 \ - /usr/local/man/man1/perldiag.1 \ - /usr/local/man/man1/perlform.1 \ - /usr/local/man/man1/perlipc.1 \ - /usr/local/man/man1/perlsec.1 \ - /usr/local/man/man1/perltrap.1 \ - /usr/local/man/man1/perlstyle.1 \ - /usr/local/man/man1/perlxs.1 \ - /usr/local/man/man1/perlxstut.1 \ - /usr/local/man/man1/perlguts.1 \ - /usr/local/man/man1/perlcall.1 \ - /usr/local/man/man1/perlembed.1 \ - /usr/local/man/man1/perlpod.1 \ - /usr/local/man/man1/perlbook.1 \ +# +# Usage: roffitall [-nroff|-psroff|-groff] +# +# Authors: Tom Christiansen, Raphael Manfredi + +me=roffitall +tmp=. + +#manroot=/usr/local +#libroot=/usr/local + +manroot=$HOME/usr +libroot=$HOME/usr/lib/perl5 + +case "$1" in +-nroff) cmd="nroff -man"; ext='txt';; +-psroff) cmd="psroff -t"; ext='ps';; +-groff) cmd="groff -man"; ext='ps';; +*) + echo "Usage: roffitall [-nroff|-psroff|-groff]" >&2 + exit 1 + ;; +esac + +toroff=` + echo \ + $manroot/man/man1/perl.1 \ + $manroot/man/man1/perlnews.1 \ + $manroot/man/man1/perldata.1 \ + $manroot/man/man1/perlsyn.1 \ + $manroot/man/man1/perlop.1 \ + $manroot/man/man1/perlre.1 \ + $manroot/man/man1/perlrun.1 \ + $manroot/man/man1/perllocale.1 \ + $manroot/man/man1/perlfunc.1 \ + $manroot/man/man1/perlvar.1 \ + $manroot/man/man1/perlsub.1 \ + $manroot/man/man1/perlmod.1 \ + $manroot/man/man1/perlref.1 \ + $manroot/man/man1/perldsc.1 \ + $manroot/man/man1/perllol.1 \ + $manroot/man/man1/perlobj.1 \ + $manroot/man/man1/perltie.1 \ + $manroot/man/man1/perlbot.1 \ + $manroot/man/man1/perldebug.1 \ + $manroot/man/man1/perldiag.1 \ + $manroot/man/man1/perlform.1 \ + $manroot/man/man1/perlipc.1 \ + $manroot/man/man1/perlsec.1 \ + $manroot/man/man1/perltrap.1 \ + $manroot/man/man1/perlstyle.1 \ + $manroot/man/man1/perlapio.1 \ + $manroot/man/man1/perlxs.1 \ + $manroot/man/man1/perlxstut.1 \ + $manroot/man/man1/perlguts.1 \ + $manroot/man/man1/perlcall.1 \ + $manroot/man/man1/perlembed.1 \ + $manroot/man/man1/perlpod.1 \ + $manroot/man/man1/perlbook.1 \ \ - /usr/local/man/man3/diagnostics.3 \ - /usr/local/man/man3/integer.3 \ - /usr/local/man/man3/less.3 \ - /usr/local/man/man3/lib.3 \ - /usr/local/man/man3/overload.3 \ - /usr/local/man/man3/sigtrap.3 \ - /usr/local/man/man3/strict.3 \ - /usr/local/man/man3/subs.3 \ + $libroot/man/man3/blib.3 \ + $libroot/man/man3/diagnostics.3 \ + $libroot/man/man3/integer.3 \ + $libroot/man/man3/less.3 \ + $libroot/man/man3/lib.3 \ + $libroot/man/man3/localle.3 \ + $libroot/man/man3/overload.3 \ + $libroot/man/man3/sigtrap.3 \ + $libroot/man/man3/strict.3 \ + $libroot/man/man3/subs.3 \ + $libroot/man/man3/vars.3 \ \ - /usr/local/man/man3/AnyDBM_File.3 \ - /usr/local/man/man3/AutoLoader.3 \ - /usr/local/man/man3/AutoSplit.3 \ - /usr/local/man/man3/Benchmark.3 \ - /usr/local/man/man3/Carp.3 \ - /usr/local/man/man3/Config.3 \ - /usr/local/man/man3/Cwd.3 \ - /usr/local/man/man3/DB_File.3 \ - /usr/local/man/man3/Devel::SelfStubber.3 \ - /usr/local/man/man3/DynaLoader.3 \ - /usr/local/man/man3/English.3 \ - /usr/local/man/man3/Env.3 \ - /usr/local/man/man3/Exporter.3 \ - /usr/local/man/man3/ExtUtils::Liblist.3 \ - /usr/local/man/man3/ExtUtils::MakeMaker.3 \ - /usr/local/man/man3/ExtUtils::Manifest.3 \ - /usr/local/man/man3/ExtUtils::Mkbootstrap.3 \ - /usr/local/man/man3/Fcntl.3 \ - /usr/local/man/man3/File::Basename.3 \ - /usr/local/man/man3/File::CheckTree.3 \ - /usr/local/man/man3/File::Find.3 \ - /usr/local/man/man3/FileHandle.3 \ - /usr/local/man/man3/File::Path.3 \ - /usr/local/man/man3/Getopt::Long.3 \ - /usr/local/man/man3/Getopt::Std.3 \ - /usr/local/man/man3/I18N::Collate.3 \ - /usr/local/man/man3/IPC::Open2.3 \ - /usr/local/man/man3/IPC::Open3.3 \ - /usr/local/man/man3/Net::Ping.3 \ - /usr/local/man/man3/POSIX.3 \ - /usr/local/man/man3/Safe.3 \ - /usr/local/man/man3/SelfLoader.3 \ - /usr/local/man/man3/Socket.3 \ - /usr/local/man/man3/Sys::Hostname.3 \ - /usr/local/man/man3/Term::Cap.3 \ - /usr/local/man/man3/Term::Complete.3 \ - /usr/local/man/man3/Test::Harness.3 \ - /usr/local/man/man3/Text::Abbrev.3 \ - /usr/local/man/man3/Text::Soundex.3 \ - /usr/local/man/man3/TieHash.3 \ - /usr/local/man/man3/Time::Local.3 + $libroot/man/man3/AnyDBM_File.3 \ + $libroot/man/man3/AutoLoader.3 \ + $libroot/man/man3/AutoSplit.3 \ + $libroot/man/man3/Benchmark.3 \ + $libroot/man/man3/Carp.3 \ + $libroot/man/man3/Config.3 \ + $libroot/man/man3/Cwd.3 \ + $libroot/man/man3/DB_File.3 \ + $libroot/man/man3/Devel::SelfStubber.3 \ + $libroot/man/man3/DynaLoader.3 \ + $libroot/man/man3/English.3 \ + $libroot/man/man3/Env.3 \ + $libroot/man/man3/Exporter.3 \ + $libroot/man/man3/ExtUtils::Embed.3 \ + $libroot/man/man3/ExtUtils::Install.3 \ + $libroot/man/man3/ExtUtils::Liblist.3 \ + $libroot/man/man3/ExtUtils::MakeMaker.3 \ + $libroot/man/man3/ExtUtils::Manifest.3 \ + $libroot/man/man3/ExtUtils::Mkbootstrap.3 \ + $libroot/man/man3/ExtUtils::Mksymlists.3 \ + $libroot/man/man3/Fatal.3 \ + $libroot/man/man3/Fcntl.3 \ + $libroot/man/man3/File::Basename.3 \ + $libroot/man/man3/File::CheckTree.3 \ + $libroot/man/man3/File::Copy.3 \ + $libroot/man/man3/File::Compare.3 \ + $libroot/man/man3/File::Find.3 \ + $libroot/man/man3/File::Path.3 \ + $libroot/man/man3/File::stat.3 \ + $libroot/man/man3/FileCache.3 \ + $libroot/man/man3/FileHandle.3 \ + $libroot/man/man3/FindBin.3 \ + $libroot/man/man3/Getopt::Long.3 \ + $libroot/man/man3/Getopt::Std.3 \ + $libroot/man/man3/I18N::Collate.3 \ + $libroot/man/man3/IO.3 \ + $libroot/man/man3/IO::File.3 \ + $libroot/man/man3/IO::Handle.3 \ + $libroot/man/man3/IO::Pipe.3 \ + $libroot/man/man3/IO::Seekable.3 \ + $libroot/man/man3/IO::Select.3 \ + $libroot/man/man3/IO::Socket.3 \ + $libroot/man/man3/IPC::Open2.3 \ + $libroot/man/man3/IPC::Open3.3 \ + $libroot/man/man3/Math::BigFloat.3 \ + $libroot/man/man3/Math::BigInt.3 \ + $libroot/man/man3/Math::Complex.3 \ + $libroot/man/man3/Net::Ping.3 \ + $libroot/man/man3/Net::hostent.3 \ + $libroot/man/man3/Net::netent.3 \ + $libroot/man/man3/Net::protoent.3 \ + $libroot/man/man3/Net::servent.3 \ + $libroot/man/man3/Opcode.3 \ + $libroot/man/man3/POSIX.3 \ + $libroot/man/man3/Pod::Text.3 \ + $libroot/man/man3/Safe.3 \ + $libroot/man/man3/Search::Dict.3 \ + $libroot/man/man3/SelectSaver.3 \ + $libroot/man/man3/SelfLoader.3 \ + $libroot/man/man3/Shell.3 \ + $libroot/man/man3/Socket.3 \ + $libroot/man/man3/Symbol.3 \ + $libroot/man/man3/Sys::Hostname.3 \ + $libroot/man/man3/Sys::Syslog.3 \ + $libroot/man/man3/Term::Cap.3 \ + $libroot/man/man3/Term::Complete.3 \ + $libroot/man/man3/Test::Harness.3 \ + $libroot/man/man3/Text::Abbrev.3 \ + $libroot/man/man3/Text::ParseWords.3 \ + $libroot/man/man3/Text::Soundex.3 \ + $libroot/man/man3/Text::Tabs.3 \ + $libroot/man/man3/Tie::Hash.3 \ + $libroot/man/man3/Tie::RefHash.3 \ + $libroot/man/man3/Tie::Scalar.3 \ + $libroot/man/man3/Tie::SubstrHash.3 \ + $libroot/man/man3/Time::Local.3 \ + $libroot/man/man3/Time::gmtime.3 \ + $libroot/man/man3/Time::localtime.3 \ + $libroot/man/man3/Time::tm.3 \ + $libroot/man/man3/UNIVERSAL.3 \ + $libroot/man/man3/User::grent.3 \ + $libroot/man/man3/User::pwent.3 | \ +perl -ne 'map { -r && print "$_ " } split'` + +#psroff -t -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.ps 2>$tmp/PerlTOC.raw +#nroff -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.txt 2>$tmp/PerlTOC.nr.raw + +run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw" +echo "$me: running $run" +eval $run $toroff +echo "$me: parsing TOC" +./rofftoc $tmp/PerlTOC.$ext.raw > $tmp/PerlTOC.tmp.man +run="$cmd $tmp/PerlTOC.tmp.man >$tmp/PerlTOC.$ext" +echo "$me: running $run" +eval $run +rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw +echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext" + diff --git a/pod/rofftoc b/pod/rofftoc new file mode 100755 index 0000000000..a2d0e7ba20 --- /dev/null +++ b/pod/rofftoc @@ -0,0 +1,66 @@ +# feed this into perl + eval 'exec perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +# Usage: rofftoc PerlTOC.xxx.raw +# +# Post-processes roffitall output. Called from roffitall to produce +# a formatted table of contents. +# +# Author: Tom Christiansen + +print <<'EOF'; +.de NP +'.sp 0.8i +.tl ''- % -'' +'bp +'sp 0.5i +.tl ''\fB\s+2Perl Table of Contents\s0\fR'' +'sp 0.3i +.. +.wh -1i NP +.af % i +.sp 0.5i +.tl ''\fB\s+5Perl Table of Contents\s0\fR'' +.sp 0.5i +.nf +.na +EOF +while (<>) { + #chomp; + s/Index://; + ($type, $page, $desc) = split ' ', $_, 3; + $desc =~ s/^"(.*)"$/$1/; + if ($type eq 'Title') { + ($name = $desc) =~ s/ .*//; + next; + } elsif ($type eq 'Name') { + #print STDERR $page, "\t", $desc; + print ".ne 5\n"; + print ".in 0\n"; + print ".sp\n"; + print ".ft B\n"; + print "$desc\n"; + print ".ft P\n"; + print ".in 5n\n"; + } elsif ($type eq 'Header') { + print ".br\n", $page, "\t", $desc; + } elsif ($type eq 'Subsection') { + print ".br\n", $page, "\t\t", $desc; + } elsif ($type eq 'Item') { + next if $desc =~ /\\bu/; + next unless $name =~ /POSIX|func/i; + print ".br\n", $page, "\t\t\t", $desc; + } +} +__END__ +Index:Title 1 "PERL 1" +Index:Name 1 "perl - Practical Extraction and Report Language" +Index:Header 1 "NAME" +Index:Header 1 "SYNOPSIS" +Index:Header 2 "DESCRIPTION" +Index:Item 2 "\(bu Many usability enhancements" +Index:Item 2 "\(bu Simplified grammar" +Index:Item 2 "\(bu Lexical scoping" +Index:Item 2 "\(bu Arbitrarily nested data structures" +Index:Item 2 "\(bu Modularity and reusability" @@ -15,7 +15,22 @@ #include "EXTERN.h" #include "perl.h" -static void doencodes _((SV *sv, char *s, I32 len)); +/* + * Types used in bitwise operations. + * + * Normally we'd just use IV and UV. However, some hardware and + * software combinations (e.g. Alpha and current OSF/1) don't have a + * floating-point type to use for NV that has adequate bits to fully + * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).) + * + * It just so happens that "int" is the right size everywhere, at + * least today. + */ +typedef int IBW; +typedef unsigned UBW; + +static SV* refto _((SV* sv)); +static void doencodes _((SV* sv, char* s, I32 len)); /* variations on pp_null */ @@ -128,28 +143,8 @@ PP(pp_rv2gv) sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } - if (op->op_private & OPpLVAL_INTRO) { - GP *ogp = GvGP(sv); - - SSCHECK(3); - SSPUSHPTR(SvREFCNT_inc(sv)); - SSPUSHPTR(ogp); - SSPUSHINT(SAVEt_GP); - - if (op->op_flags & OPf_SPECIAL) { - GvGP(sv)->gp_refcnt++; /* will soon be assigned */ - GvINTRO_on(sv); - } - else { - GP *gp; - Newz(602,gp, 1, GP); - GvGP(sv) = gp; - GvREFCNT(sv) = 1; - GvSV(sv) = NEWSV(72,0); - GvLINE(sv) = curcop->cop_line; - GvEGV(sv) = (GV*)sv; - } - } + if (op->op_private & OPpLVAL_INTRO) + save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } @@ -194,7 +189,7 @@ PP(pp_rv2sv) if (op->op_flags & OPf_MOD) { if (op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) + else if (op->op_private & OPpDEREF) provide_ref(op, sv); } SETs(sv); @@ -220,7 +215,12 @@ PP(pp_pos) dSP; dTARGET; dPOPss; if (op->op_flags & OPf_MOD) { - LvTYPE(TARG) = '<'; + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, '.', Nullch, 0); + } + + LvTYPE(TARG) = '.'; LvTARG(TARG) = sv; PUSHs(TARG); /* no SvSETMAGIC */ RETURN; @@ -248,8 +248,11 @@ PP(pp_rv2cv) /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL)); - - if (!cv) + if (cv) { + if (CvCLONE(cv)) + cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); + } + else cv = (CV*)&sv_undef; SETs((SV*)cv); RETURN; @@ -265,10 +268,8 @@ PP(pp_prototype) ret = &sv_undef; cv = sv_2cv(TOPs, &stash, &gv, FALSE); - if (cv && SvPOK(cv)) { - char *p = SvPVX(cv); - ret = sv_2mortal(newSVpv(p ? p : "", SvLEN(cv))); - } + if (cv && SvPOK(cv)) + ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv))); SETs(ret); RETURN; } @@ -276,60 +277,59 @@ PP(pp_prototype) PP(pp_anoncode) { dSP; - CV* cv = (CV*)cSVOP->op_sv; - EXTEND(SP,1); - + CV* cv = (CV*)curpad[op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - + EXTEND(SP,1); PUSHs((SV*)cv); RETURN; } PP(pp_srefgen) { - dSP; dTOPss; - SV* rv; - rv = sv_newmortal(); - sv_upgrade(rv, SVt_RV); - if (SvPADTMP(sv)) - sv = newSVsv(sv); - else { - SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); - } - SvRV(rv) = sv; - SvROK_on(rv); - SETs(rv); + dSP; + *SP = refto(*SP); RETURN; } PP(pp_refgen) { dSP; dMARK; - SV* sv; - SV* rv; if (GIMME != G_ARRAY) { MARK[1] = *SP; SP = MARK + 1; } - while (MARK < SP) { - sv = *++MARK; - rv = sv_newmortal(); - sv_upgrade(rv, SVt_RV); - if (SvPADTMP(sv)) - sv = newSVsv(sv); - else { - SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); - } - SvRV(rv) = sv; - SvROK_on(rv); - *MARK = rv; - } + EXTEND_MORTAL(SP - MARK); + while (++MARK <= SP) + *MARK = refto(*MARK); RETURN; } +static SV* +refto(sv) +SV* sv; +{ + SV* rv; + + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { + if (LvTARGLEN(sv)) + vivify_itervar(sv); + if (LvTARG(sv)) + sv = LvTARG(sv); + } + else if (SvPADTMP(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } + rv = sv_newmortal(); + sv_upgrade(rv, SVt_RV); + SvRV(rv) = sv; + SvROK_on(rv); + return rv; +} + PP(pp_ref) { dSP; dTARGET; @@ -421,13 +421,6 @@ PP(pp_study) else snext[pos] = -pos; sfirst[ch] = pos; - - /* If there were any case insensitive searches, we must assume they - * all are. This speeds up insensitive searches much more than - * it slows down sensitive ones. - */ - if (sawi) - sfirst[fold[ch]] = pos; } SvSCREAM_on(sv); @@ -551,13 +544,11 @@ PP(pp_undef) break; case SVt_PVCV: cv_undef((CV*)sv); - sub_generation++; break; case SVt_PVGV: - if (SvFAKE(sv)) { - sv_setsv(sv, &sv_undef); - break; - } + if (SvFAKE(sv)) + sv_setsv(sv, &sv_undef); + break; default: if (SvPOK(sv) && SvLEN(sv)) { (void)SvOOK_off(sv); @@ -576,15 +567,12 @@ PP(pp_predec) { dSP; if (SvREADONLY(TOPs)) - croak(no_modify); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + croak(no_modify); + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -596,16 +584,13 @@ PP(pp_postinc) { dSP; dTARGET; if (SvREADONLY(TOPs)) - croak(no_modify); + croak(no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MAX) { - sv_setnv(TOPs, (double)SvIVX(TOPs) + 1.0); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -620,16 +605,13 @@ PP(pp_postdec) { dSP; dTARGET; if(SvREADONLY(TOPs)) - croak(no_modify); + croak(no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -664,25 +646,24 @@ PP(pp_divide) { dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { - dPOPnv; - if (value == 0.0) + dPOPPOPnnrl; + double value; + if (right == 0.0) DIE("Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { - double x; - I32 k; - x = POPn; - if ((double)I_32(x) == x && - (double)I_32(value) == value && - (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) { + IV k; + if ((double)I_V(left) == left && + (double)I_V(right) == right && + (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; } else { - value = x/value; + value = left / right; } } #else - value = POPn / value; + value = left / right; #endif PUSHn( value ); RETURN; @@ -693,19 +674,26 @@ PP(pp_modulo) { dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); { - register IV value; - register UV uval; + register UV right; - uval = POPn; - if (!uval) + right = POPu; + if (!right) DIE("Illegal modulus zero"); - value = TOPn; - if (value >= 0) - value = (UV)value % uval; + + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + register IV left = SvIVX(TOPs); + if (left < 0) + SETu( (right - ((UV)(-left) - 1) % right) - 1 ); + else + SETi( left % right ); + } else { - value = (uval - ((UV)(-value - 1) % uval)) - 1; + register double left = TOPn; + if (left < 0.0) + SETu( (right - (U_V(-left) - 1) % right) - 1 ); + else + SETu( U_V(left) % right ); } - SETi(value); RETURN; } } @@ -749,16 +737,17 @@ PP(pp_repeat) } SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); - if (count >= 1) { - SvGROW(TARG, (count * len) + 1); - if (count > 1) + if (count != 1) { + if (count < 1) + SvCUR_set(TARG, 0); + else { + SvGROW(TARG, (count * len) + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); - SvCUR(TARG) *= count; + SvCUR(TARG) *= count; + } *SvEND(TARG) = '\0'; - (void)SvPOK_only(TARG); } - else - sv_setsv(TARG, &sv_no); + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -769,7 +758,7 @@ PP(pp_subtract) { dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPnnrl; + dPOPTOPnnrl_ul; SETn( left - right ); RETURN; } @@ -779,9 +768,16 @@ PP(pp_left_shift) { dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - dPOPTOPiirl; - SETi( left << right ); - RETURN; + IBW shift = POPi; + if (op->op_private & HINT_INTEGER) { + IBW i = TOPi; + SETi( i << shift ); + } + else { + UBW u = TOPu; + SETu( u << shift ); + } + RETURN; } } @@ -789,8 +785,15 @@ PP(pp_right_shift) { dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - dPOPTOPiirl; - SETi( left >> right ); + IBW shift = POPi; + if (op->op_private & HINT_INTEGER) { + IBW i = TOPi; + SETi( i >> shift ); + } + else { + UBW u = TOPu; + SETu( u >> shift ); + } RETURN; } } @@ -852,12 +855,16 @@ PP(pp_ncmp) dPOPTOPnnrl; I32 value; - if (left > right) - value = 1; - else if (left < right) + if (left < right) value = -1; - else + else if (left == right) value = 0; + else if (left > right) + value = 1; + else { + SETs(&sv_undef); + RETURN; + } SETi(value); RETURN; } @@ -868,7 +875,10 @@ PP(pp_slt) dSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs( cmp < 0 ? &sv_yes : &sv_no ); RETURN; } } @@ -878,7 +888,10 @@ PP(pp_sgt) dSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs( cmp > 0 ? &sv_yes : &sv_no ); RETURN; } } @@ -888,7 +901,10 @@ PP(pp_sle) dSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs( cmp <= 0 ? &sv_yes : &sv_no ); RETURN; } } @@ -898,7 +914,20 @@ PP(pp_sge) dSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs( cmp >= 0 ? &sv_yes : &sv_no ); + RETURN; + } +} + +PP(pp_seq) +{ + dSP; tryAMAGICbinSET(seq,0); + { + dPOPTOPssrl; + SETs( sv_eq(left, right) ? &sv_yes : &sv_no ); RETURN; } } @@ -918,22 +947,28 @@ PP(pp_scmp) dSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; - SETi( sv_cmp(left, right) ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETi( cmp ); RETURN; } } -PP(pp_bit_and) { +PP(pp_bit_and) +{ dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value & U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = SvIV(left) & SvIV(right); + SETi( value ); + } + else { + UBW value = SvUV(left) & SvUV(right); + SETu( value ); + } } else { do_vop(op->op_type, TARG, left, right); @@ -949,12 +984,14 @@ PP(pp_bit_xor) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value ^ U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi( value ); + } + else { + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu( value ); + } } else { do_vop(op->op_type, TARG, left, right); @@ -970,12 +1007,14 @@ PP(pp_bit_or) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value | U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi( value ); + } + else { + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu( value ); + } } else { do_vop(op->op_type, TARG, left, right); @@ -992,12 +1031,14 @@ PP(pp_negate) dTOPss; if (SvGMAGICAL(sv)) mg_get(sv); - if (SvNIOKp(sv)) + if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN) + SETi(-SvIVX(sv)); + else if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; char *s = SvPV(sv, len); - if (isALPHA(*s) || *s == '_') { + if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } @@ -1029,18 +1070,20 @@ PP(pp_complement) dSP; dTARGET; tryAMAGICun(compl); { dTOPss; - register I32 anum; - if (SvNIOKp(sv)) { - UV value = ~SvIV(sv); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = ~SvIV(sv); + SETi( value ); + } + else { + UBW value = ~SvUV(sv); + SETu( value ); + } } else { register char *tmps; register long *tmpl; + register I32 anum; STRLEN len; SvSetSV(TARG, sv); @@ -1278,7 +1321,7 @@ PP(pp_srand) _ckvmssts(sys$gettim(when)); anum = when[0] ^ when[1]; #else -# if defined(I_SYS_TIME) && !defined(PLAN9) +# ifdef HAS_GETTIMEOFDAY struct timeval when; gettimeofday(&when,(struct timezone *) 0); anum = when.tv_sec ^ when.tv_usec; @@ -1321,8 +1364,10 @@ PP(pp_log) { double value; value = POPn; - if (value <= 0.0) + if (value <= 0.0) { + SET_NUMERIC_STANDARD(); DIE("Can't take log of %g", value); + } value = log(value); XPUSHn(value); RETURN; @@ -1335,8 +1380,10 @@ PP(pp_sqrt) { double value; value = POPn; - if (value < 0.0) + if (value < 0.0) { + SET_NUMERIC_STANDARD(); DIE("Can't take sqrt of %g", value); + } value = sqrt(value); XPUSHn(value); RETURN; @@ -1377,22 +1424,17 @@ PP(pp_hex) { dSP; dTARGET; char *tmps; - unsigned long value; I32 argtype; tmps = POPp; - value = scan_hex(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { dSP; dTARGET; - unsigned long value; + UV value; I32 argtype; char *tmps; @@ -1405,10 +1447,7 @@ PP(pp_oct) value = scan_hex(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(value); RETURN; } @@ -1470,12 +1509,13 @@ PP(pp_substr) else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } + if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'x', Nullch, 0); } - LvTYPE(TARG) = 's'; + LvTYPE(TARG) = 'x'; LvTARG(TARG) = sv; LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; @@ -1631,7 +1671,14 @@ PP(pp_rindex) PP(pp_sprintf) { dSP; dMARK; dORIGMARK; dTARGET; +#ifdef USE_LOCALE_NUMERIC + if (op->op_private & OPpLOCALE) + SET_NUMERIC_LOCAL(); + else + SET_NUMERIC_STANDARD(); +#endif do_sprintf(TARG, SP-MARK, MARK+1); + TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; PUSHTARG; RETURN; @@ -1703,8 +1750,15 @@ PP(pp_ucfirst) SETs(sv); } s = SvPV_force(sv, na); - if (isLOWER(*s)) - *s = toUPPER(*s); + if (*s) { + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toUPPER_LC(*s); + } + else + *s = toUPPER(*s); + } RETURN; } @@ -1722,8 +1776,15 @@ PP(pp_lcfirst) SETs(sv); } s = SvPV_force(sv, na); - if (isUPPER(*s)) - *s = toLOWER(*s); + if (*s) { + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toLOWER_LC(*s); + } + else + *s = toLOWER(*s); + } SETs(sv); RETURN; @@ -1734,7 +1795,6 @@ PP(pp_uc) dSP; SV *sv = TOPs; register char *s; - register char *send; STRLEN len; if (!SvPADTMP(sv)) { @@ -1743,12 +1803,21 @@ PP(pp_uc) sv = TARG; SETs(sv); } + s = SvPV_force(sv, len); - send = s + len; - while (s < send) { - if (isLOWER(*s)) - *s = toUPPER(*s); - s++; + if (len) { + register char *send = s + len; + + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toUPPER_LC(*s); + } + else { + for (; s < send; s++) + *s = toUPPER(*s); + } } RETURN; } @@ -1758,7 +1827,6 @@ PP(pp_lc) dSP; SV *sv = TOPs; register char *s; - register char *send; STRLEN len; if (!SvPADTMP(sv)) { @@ -1767,12 +1835,21 @@ PP(pp_lc) sv = TARG; SETs(sv); } + s = SvPV_force(sv, len); - send = s + len; - while (s < send) { - if (isUPPER(*s)) - *s = toLOWER(*s); - s++; + if (len) { + register char *send = s + len; + + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toLOWER_LC(*s); + } + else { + for (; s < send; s++) + *s = toLOWER(*s); + } } RETURN; } @@ -1891,17 +1968,35 @@ PP(pp_delete) { dSP; SV *sv; - SV *tmpsv = POPs; - HV *hv = (HV*)POPs; - STRLEN len; - if (SvTYPE(hv) != SVt_PVHV) { - DIE("Not a HASH reference"); + HV *hv; + + if (op->op_private & OPpSLICE) { + dMARK; dORIGMARK; + hv = (HV*)POPs; + if (SvTYPE(hv) != SVt_PVHV) + DIE("Not a HASH reference"); + while (++MARK <= SP) { + sv = hv_delete_ent(hv, *MARK, + (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); + *MARK = sv ? sv : &sv_undef; + } + if (GIMME != G_ARRAY) { + MARK = ORIGMARK; + *++MARK = *SP; + SP = MARK; + } + } + else { + SV *keysv = POPs; + hv = (HV*)POPs; + if (SvTYPE(hv) != SVt_PVHV) + DIE("Not a HASH reference"); + sv = hv_delete_ent(hv, keysv, + (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); + if (!sv) + sv = &sv_undef; + PUSHs(sv); } - sv = hv_delete_ent(hv, tmpsv, - (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); - if (!sv) - RETPUSHUNDEF; - PUSHs(sv); RETURN; } @@ -2023,17 +2118,17 @@ PP(pp_lslice) PP(pp_anonlist) { - dSP; dMARK; + dSP; dMARK; dORIGMARK; I32 items = SP - MARK; - SP = MARK; - XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1))); + SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); + SP = ORIGMARK; /* av_make() might realloc stack_sp */ + XPUSHs(av); RETURN; } PP(pp_anonhash) { dSP; dMARK; dORIGMARK; - STRLEN len; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { @@ -2116,15 +2211,20 @@ PP(pp_splice) MEXTEND(MARK, length); Copy(AvARRAY(ary)+offset, MARK, length, SV*); if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ + EXTEND_MORTAL(length); + for (i = length, dst = MARK; i; i--) { + if (!SvIMMORTAL(*dst)) + sv_2mortal(*dst); /* free them eventualy */ + dst++; + } } MARK += length - 1; } else { *MARK = AvARRAY(ary)[offset+length-1]; if (AvREAL(ary)) { - sv_2mortal(*MARK); + if (!SvIMMORTAL(*MARK)) + sv_2mortal(*MARK); for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } @@ -2210,8 +2310,12 @@ PP(pp_splice) if (length) { Copy(tmparyval, MARK, length, SV*); if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ + EXTEND_MORTAL(length); + for (i = length, dst = MARK; i; i--) { + if (!SvIMMORTAL(*dst)) + sv_2mortal(*dst); /* free them eventualy */ + dst++; + } } Safefree(tmparyval); } @@ -2220,7 +2324,8 @@ PP(pp_splice) else if (length--) { *MARK = tmparyval[length]; if (AvREAL(ary)) { - sv_2mortal(*MARK); + if (!SvIMMORTAL(*MARK)) + sv_2mortal(*MARK); while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } @@ -2255,7 +2360,7 @@ PP(pp_pop) dSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); - if (sv != &sv_undef && AvREAL(av)) + if (!SvIMMORTAL(sv) && AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2269,7 +2374,7 @@ PP(pp_shift) EXTEND(SP, 1); if (!sv) RETPUSHUNDEF; - if (sv != &sv_undef && AvREAL(av)) + if (!SvIMMORTAL(sv) && AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2336,12 +2441,42 @@ PP(pp_reverse) RETURN; } +static SV * +mul128(sv, m) + SV *sv; + U8 m; +{ + STRLEN len; + char *s = SvPV(sv, len); + char *t; + U32 i = 0; + + if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ + SV *new = newSVpv("0000000000", 10); + + sv_catsv(new, sv); + SvREFCNT_dec(sv); /* free old sv */ + sv = new; + s = SvPV(sv, len); + } + t = s + len - 1; + while (!*t) /* trailing '\0'? */ + t--; + while (t > s) { + i = ((*t - '0') << 7) + m; + *(t--) = '0' + (i % 10); + m = i / 10; + } + return (sv); +} + /* Explosives and implosives. */ PP(pp_unpack) { dSP; dPOPPOPssrl; + SV **oldsp = sp; SV *sv; STRLEN llen; STRLEN rlen; @@ -2563,6 +2698,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ @@ -2585,6 +2721,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { auint = *s++ & 255; sv = NEWSV(37, 0); @@ -2606,6 +2743,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &ashort, 1, I16); s += sizeof(I16); @@ -2638,6 +2776,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aushort, 1, U16); s += sizeof(U16); @@ -2671,6 +2810,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); @@ -2696,6 +2836,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); @@ -2724,6 +2865,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &along, 1, I32); s += sizeof(I32); @@ -2759,6 +2901,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aulong, 1, U32); s += sizeof(U32); @@ -2781,6 +2924,7 @@ PP(pp_unpack) if (len > along) len = along; EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (sizeof(char*) > strend - s) break; @@ -2795,49 +2939,47 @@ PP(pp_unpack) } break; case 'w': - along = (strend - s) / sizeof(char); - if (len > along) - len = along; EXTEND(SP, len); - { - I8 bytes = 0; - - auint = 0; - while (len > 0) { - if (s >= strend) { - if (auint) { - DIE("Unterminated compressed integer"); - } else { - break; - } - } - auint = (auint << 7) | (*s & 0x7f); - if (!(*s & 0x80)) { - sv = NEWSV(40, 0); - sv_setiv(sv, (I32) auint); - PUSHs(sv_2mortal(sv)); - len--; - auint = 0; - bytes = 0; - } else if (++bytes >= sizeof(auint)) { /* promote to double */ - adouble = auint; - - while (*s & 0x80) { - adouble = (adouble * 128) + (*(++s) & 0x7f); - if (s >= strend) { - DIE("Unterminated compressed integer"); - } - } - sv = NEWSV(40, 0); - sv_setnv(sv, adouble); - PUSHs(sv_2mortal(sv)); - len--; - auint = 0; - bytes = 0; - } - s++; - } - } + EXTEND_MORTAL(len); + { + UV auv = 0; + U32 bytes = 0; + + while ((len > 0) && (s < strend)) { + auv = (auv << 7) | (*s & 0x7f); + if (!(*s++ & 0x80)) { + bytes = 0; + sv = NEWSV(40, 0); + sv_setuv(sv, auv); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + else if (++bytes >= sizeof(UV)) { /* promote to string */ + char decn[sizeof(UV) * 3 + 1]; + char *t; + + (void) sprintf(decn, "%0*ld", sizeof(decn) - 1, auv); + sv = newSVpv(decn, 0); + while (s < strend) { + sv = mul128(sv, *s & 0x7f); + if (!(*s++ & 0x80)) { + bytes = 0; + break; + } + } + t = SvPV(sv, na); + while (*t == '0') + t++; + sv_chop(sv, t); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + } + if ((s >= strend) && bytes) + croak("Unterminated compressed integer"); + } break; case 'P': EXTEND(SP, 1); @@ -2855,6 +2997,7 @@ PP(pp_unpack) #ifdef HAS_QUAD case 'q': EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Quad_t) > strend) aquad = 0; @@ -2869,6 +3012,7 @@ PP(pp_unpack) break; case 'Q': EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(unsigned Quad_t) > strend) auquad = 0; @@ -2897,6 +3041,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); @@ -2920,6 +3065,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); @@ -3005,6 +3151,8 @@ PP(pp_unpack) checksum = 0; } } + if (sp == oldsp && GIMME != G_ARRAY) + PUSHs(&sv_undef); RETURN; } @@ -3035,6 +3183,85 @@ register I32 len; sv_catpvn(sv, "\n", 1); } +static SV * +is_an_int(s, l) + char *s; + STRLEN l; +{ + SV *result = newSVpv("", l); + char *result_c = SvPV(result, na); /* convenience */ + char *out = result_c; + bool skip = 1; + bool ignore = 0; + + while (*s) { + switch (*s) { + case ' ': + break; + case '+': + if (!skip) { + SvREFCNT_dec(result); + return (NULL); + } + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + skip = 0; + if (!ignore) { + *(out++) = *s; + } + break; + case '.': + ignore = 1; + break; + default: + SvREFCNT_dec(result); + return (NULL); + } + s++; + } + *(out++) = '\0'; + SvCUR_set(result, out - result_c); + return (result); +} + +static int +div128(pnum, done) + SV *pnum; /* must be '\0' terminated */ + bool *done; +{ + STRLEN len; + char *s = SvPV(pnum, len); + int m = 0; + int r = 0; + char *t = s; + + *done = 1; + while (*t) { + int i; + + i = m * 10 + (*t - '0'); + m = i & 0x7F; + r = (i >> 7); /* r < 10 */ + if (r) { + *done = 0; + } + *(t++) = '0' + r; + } + *(t++) = '\0'; + SvCUR_set(pnum, (STRLEN) (t - s)); + return (m); +} + + PP(pp_pack) { dSP; dMARK; dORIGMARK; dTARGET; @@ -3316,39 +3543,62 @@ PP(pp_pack) break; case 'w': while (len-- > 0) { - fromstr = NEXTFROM; - adouble = floor((double)SvNV(fromstr)); - - if (adouble < 268435456) { /* we can use integers */ - unsigned char buf[4]; /* buffer for compressed int */ - unsigned char *in = buf + 3; - auint = U_I(adouble); - do { - *(in--) = (unsigned char) ((auint & 0x7f) | 0x80); - auint >>= 7; - } while (auint); - buf[3] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, (char*) in+1, buf+3-in); - } else { - unsigned char buf[sizeof(double)*2]; /* buffer for compressed int */ - I8 msize = sizeof(double)*2; /* 8/7 would be enough */ - unsigned char *in = buf + msize -1; - if (adouble<0) { - croak("Cannot compress negative numbers"); + fromstr = NEXTFROM; + adouble = floor(SvNV(fromstr)); + + if (adouble < 0) + croak("Cannot compress negative numbers"); + + if (adouble <= UV_MAX) { + char buf[1 + sizeof(UV)]; + char *in = buf + sizeof(buf); + UV auv = U_V(adouble);; + + do { + *--in = (auv & 0x7f) | 0x80; + auv >>= 7; + } while (auv); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ + char *from, *result, *in; + SV *norm; + STRLEN len; + bool done; + + /* Copy string and check for compliance */ + from = SvPV(fromstr, len); + if ((norm = is_an_int(from, len)) == NULL) + croak("can compress only unsigned integer"); + + New('w', result, len, char); + in = result + len; + done = FALSE; + while (!done) + *--in = div128(norm, &done) | 0x80; + result[len - 1] &= 0x7F; /* clear continue bit */ + sv_catpvn(cat, in, (result + len) - in); + Safefree(result); + SvREFCNT_dec(norm); /* free norm */ } - do { - double next = adouble/128; - *in = (unsigned char) (adouble - floor(next)*128); - *in |= 0x80; /* set continue bit */ - if (--in < buf) { /* this cannot happen ;-) */ - croak ("Cannot compress integer"); - } - adouble = next; - } while (floor(adouble)>0); /* floor() not necessary? */ - buf[msize-1] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, (char*) in+1, buf+msize-in-1); - } - } + else if (SvNOKp(fromstr)) { + char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ + char *in = buf + sizeof(buf); + + do { + double next = floor(adouble / 128); + *--in = (unsigned char)(adouble - (next * 128)) | 0x80; + if (--in < buf) /* this cannot happen ;-) */ + croak ("Cannot compress integer"); + adouble = next; + } while (adouble > 0); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else + croak("Cannot compress non integer"); + } break; case 'i': while (len-- > 0) { @@ -3455,7 +3705,8 @@ PP(pp_split) STRLEN len; register char *s = SvPV(sv, len); char *strend = s + len; - register PMOP *pm = (PMOP*)POPs; + register PMOP *pm; + register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; @@ -3466,12 +3717,21 @@ PP(pp_split) I32 realarray = 0; I32 base; AV *oldstack = curstack; - register REGEXP *rx = pm->op_pmregexp; I32 gimme = GIMME; I32 oldsave = savestack_ix; +#ifdef DEBUGGING + Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); +#else + pm = (PMOP*)POPs; +#endif if (!pm || !s) DIE("panic: do_split"); + rx = pm->op_pmregexp; + + TAINT_IF((pm->op_pmflags & PMf_LOCALE) && + (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); + if (pm->op_pmreplroot) ary = GvAVn((GV*)pm->op_pmreplroot); else if (gimme != G_ARRAY) @@ -3493,8 +3753,14 @@ PP(pp_split) base = SP - stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { - while (isSPACE(*s)) - s++; + if (pm->op_pmflags & PMf_LOCALE) { + while (isSPACE_LC(*s)) + s++; + } + else { + while (isSPACE(*s)) + s++; + } } if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); @@ -3505,17 +3771,25 @@ PP(pp_split) limit = maxiters + 2; if (pm->op_pmflags & PMf_WHITE) { while (--limit) { - /*SUPPRESS 530*/ - for (m = s; m < strend && !isSPACE(*m); m++) ; + m = s; + while (m < strend && + !((pm->op_pmflags & PMf_LOCALE) + ? isSPACE_LC(*m) : isSPACE(*m))) + ++m; if (m >= strend) break; + dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (!realarray) sv_2mortal(dstr); XPUSHs(dstr); - /*SUPPRESS 530*/ - for (s = m + 1; s < strend && isSPACE(*s); s++) ; + + s = m + 1; + while (s < strend && + ((pm->op_pmflags & PMf_LOCALE) + ? isSPACE_LC(*s) : isSPACE(*s))) + ++s; } } else if (strEQ("^", rx->precomp)) { @@ -3533,23 +3807,13 @@ PP(pp_split) s = m; } } - else if (pm->op_pmshort) { + else if (pm->op_pmshort && !rx->nparens) { i = SvCUR(pm->op_pmshort); if (i == 1) { - I32 fold = (pm->op_pmflags & PMf_FOLD); i = *SvPVX(pm->op_pmshort); - if (fold && isUPPER(i)) - i = toLOWER(i); while (--limit) { - if (fold) { - for ( m = s; - m < strend && *m != i && - (!isUPPER(*m) || toLOWER(*m) != i); - m++) /*SUPPRESS 530*/ - ; - } - else /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + /*SUPPRESS 530*/ + for (m = s; m < strend && *m != i; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); @@ -3579,7 +3843,9 @@ PP(pp_split) else { maxiters += (strend - s) * rx->nparens; while (s < strend && --limit && - pregexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) { + pregexec(rx, s, strend, orig, 1, Nullsv, TRUE)) + { + TAINT_IF(rx->exec_tainted); if (rx->subbase && rx->subbase != orig) { m = s; @@ -55,24 +55,26 @@ #define POPp (SvPVx(POPs, na)) #define POPn (SvNVx(POPs)) #define POPi ((IV)SvIVx(POPs)) +#define POPu ((UV)SvUVx(POPs)) #define POPl ((long)SvIVx(POPs)) #define TOPs (*sp) #define TOPp (SvPV(TOPs, na)) #define TOPn (SvNV(TOPs)) #define TOPi ((IV)SvIV(TOPs)) +#define TOPu ((UV)SvUV(TOPs)) #define TOPl ((long)SvIV(TOPs)) /* Go to some pains in the rare event that we must extend the stack. */ -#define EXTEND(p,n) STMT_START { if (stack_max - p < (n)) { \ - sp = stack_grow(sp,p, (int) (n)); \ +#define EXTEND(p,n) STMT_START { if (stack_max - p < (n)) { \ + sp = stack_grow(sp,p, (int) (n)); \ } } STMT_END /* Same thing, but update mark register too. */ -#define MEXTEND(p,n) STMT_START {if (stack_max - p < (n)) { \ - int markoff = mark - stack_base; \ - sp = stack_grow(sp,p,(int) (n)); \ - mark = stack_base + markoff; \ +#define MEXTEND(p,n) STMT_START {if (stack_max - p < (n)) { \ + int markoff = mark - stack_base; \ + sp = stack_grow(sp,p,(int) (n)); \ + mark = stack_base + markoff; \ } } STMT_END #define PUSHs(s) (*++sp = (s)) @@ -80,18 +82,21 @@ #define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END #define PUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); PUSHTARG; } STMT_END #define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END +#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #define XPUSHs(s) STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END #define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END #define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END #define XPUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); XPUSHTARG; } STMT_END #define XPUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END +#define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #define SETs(s) (*sp = s) #define SETTARG STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END #define SETp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END #define SETn(n) STMT_START { sv_setnv(TARG, (double)(n)); SETTARG; } STMT_END #define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END +#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END #define dTOPss SV *sv = TOPs #define dPOPss SV *sv = POPs @@ -99,14 +104,35 @@ #define dPOPnv double value = POPn #define dTOPiv IV value = TOPi #define dPOPiv IV value = POPi - -#define dPOPPOPssrl SV *right = POPs; SV *left = POPs -#define dPOPPOPnnrl double right = POPn; double left = POPn -#define dPOPPOPiirl IV right = POPi; IV left = POPi - -#define dPOPTOPssrl SV *right = POPs; SV *left = TOPs -#define dPOPTOPnnrl double right = POPn; double left = TOPn -#define dPOPTOPiirl IV right = POPi; IV left = TOPi +#define dTOPuv UV value = TOPu +#define dPOPuv UV value = POPu + +#define dPOPXssrl(X) SV *right = POPs; SV *left = CAT2(X,s) +#define dPOPXnnrl(X) double right = POPn; double left = CAT2(X,n) +#define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i) + +#define USE_LEFT(sv) \ + (SvOK(sv) || SvGMAGICAL(sv) || !(op->op_flags & OPf_STACKED)) +#define dPOPXnnrl_ul(X) \ + double right = POPn; \ + SV *leftsv = CAT2(X,s); \ + double left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0 +#define dPOPXiirl_ul(X) \ + IV right = POPi; \ + SV *leftsv = CAT2(X,s); \ + IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0 + +#define dPOPPOPssrl dPOPXssrl(POP) +#define dPOPPOPnnrl dPOPXnnrl(POP) +#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP) +#define dPOPPOPiirl dPOPXiirl(POP) +#define dPOPPOPiirl_ul dPOPXiirl_ul(POP) + +#define dPOPTOPssrl dPOPXssrl(TOP) +#define dPOPTOPnnrl dPOPXnnrl(TOP) +#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP) +#define dPOPTOPiirl dPOPXiirl(TOP) +#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP) #define RETPUSHYES RETURNX(PUSHs(&sv_yes)) #define RETPUSHNO RETURNX(PUSHs(&sv_no)) @@ -125,6 +151,12 @@ sp = stack_sp = stack_base + AvFILL(t); \ curstack = t; +#define EXTEND_MORTAL(n) \ + STMT_START { \ + if (tmps_ix + (n) >= tmps_max) \ + Renew(tmps_stack, tmps_max = tmps_ix + (n) + 1, SV*); \ + } STMT_END + #ifdef OVERLOAD #define AMGf_noright 1 @@ -31,8 +31,9 @@ static I32 dopoptolabel _((char *label)); static I32 dopoptoloop _((I32 startingblock)); static I32 dopoptosub _((I32 startingblock)); static void save_lines _((AV *array, SV *sv)); -static int sortcmp _((const void *, const void *)); static int sortcv _((const void *, const void *)); +static int sortcmp _((const void *, const void *)); +static int sortcmp_locale _((const void *, const void *)); static I32 sortcxix; @@ -108,6 +109,8 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); + if (!cx->sb_rxtainted) + cx->sb_rxtainted = SvTAINTED(TOPs); sv_catsv(dstr, POPs); if (rx->subbase) Safefree(rx->subbase); @@ -130,6 +133,8 @@ PP(pp_substcont) (void)SvPOK_only(targ); SvSETMAGIC(targ); + if (cx->sb_rxtainted) + SvTAINTED_on(targ); PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); @@ -147,6 +152,7 @@ PP(pp_substcont) sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0]; cx->sb_subbase = rx->subbase; + cx->sb_rxtainted |= rx->exec_tainted; rx->subbase = Nullch; /* so recursion works */ RETURNOP(pm->op_pmreplstart); @@ -174,7 +180,7 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvCOMPILED(form)) { + if (!SvMAGICAL(form) || !SvCOMPILED(form)) { SvREADONLY_off(form); doparseform(form); } @@ -376,6 +382,8 @@ PP(pp_formline) } gotsome = TRUE; value = SvNV(sv); + /* Formats aren't yet marked for locales, so assume "yes". */ + SET_NUMERIC_LOCAL(); if (arg & 256) { sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value); } else { @@ -649,7 +657,8 @@ PP(pp_sort) else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp); + qsort((char*)(ORIGMARK+1), max, sizeof(SV*), + (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp); } } stack_sp = ORIGMARK + max; @@ -707,14 +716,16 @@ PP(pp_flop) I32 max; if (SvNIOKp(left) || !SvPOKp(left) || - (looks_like_number(left) && *SvPVX(left) != '0') ) { + (looks_like_number(left) && *SvPVX(left) != '0') ) + { i = SvIV(left); max = SvIV(right); - if (max > i) + if (max >= i) { + EXTEND_MORTAL(max - i + 1); EXTEND(SP, max - i + 1); + } while (i <= max) { - sv = sv_mortalcopy(&sv_no); - sv_setiv(sv,i++); + sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } @@ -853,7 +864,7 @@ I32 startingblock; switch (cx->cx_type) { case CXt_SUBST: if (dowarn) - warn("Exiting substitition via %s", op_name[op->op_type]); + warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: if (dowarn) @@ -900,54 +911,6 @@ I32 cxix; } } -#ifdef I_STDARG -OP * -die(char* pat, ...) -#else -/*VARARGS0*/ -OP * -die(pat, va_alist) - char *pat; - va_dcl -#endif -{ - va_list args; - char *message; - int oldrunlevel = runlevel; - int was_in_eval = in_eval; - HV *stash; - GV *gv; - CV *cv; - - /* We have to switch back to mainstack or die_where may try to pop - * the eval block from the wrong stack if die is being called from a - * signal handler. - dkindred@cs.cmu.edu */ - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } -#ifdef I_STDARG - va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); - va_end(args); - if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - } - restartop = die_where(message); - if ((!restartop && was_in_eval) || oldrunlevel > 1) - Siglongjmp(top_env, 3); - return restartop; -} - OP * die_where(message) char *message; @@ -1189,63 +1152,15 @@ sortcmp(a, b) const void *a; const void *b; { - register SV *str1 = *(SV **) a; - register SV *str2 = *(SV **) b; - I32 retval; - - if (!SvPOKp(str1)) { - if (!SvPOKp(str2)) - return 0; - else - return -1; - } - if (!SvPOKp(str2)) - return 1; - - if (lc_collate_active) { /* NOTE: this is the LC_COLLATE branch */ - register char * pv1, * pv2, * pvx; - STRLEN cur1, cur2, curx; - - pv1 = SvPV(str1, cur1); - pvx = mem_collxfrm(pv1, cur1, &curx); - pv1 = pvx; - cur1 = curx; - - pv2 = SvPV(str2, cur2); - pvx = mem_collxfrm(pv2, cur2, &curx); - pv2 = pvx; - cur2 = curx; - - retval = memcmp((void *)pv1, (void *)pv2, cur1 < cur2 ? cur1 : cur2); - - Safefree(pv1); - Safefree(pv2); - - if (retval) - return retval < 0 ? -1 : 1; - - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; - } - - /* NOTE: this is the non-LC_COLLATE area */ + return sv_cmp(*(SV **)a, *(SV **)b); +} - if (SvCUR(str1) < SvCUR(str2)) { - /*SUPPRESS 560*/ - if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) - return retval; - else - return -1; - } - /*SUPPRESS 560*/ - else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2))) - return retval; - else if (SvCUR(str1) == SvCUR(str2)) - return 0; - else - return 1; +static int +sortcmp_locale(a, b) +const void *a; +const void *b; +{ + return sv_cmp_locale(*(SV **)a, *(SV **)b); } PP(pp_reset) @@ -1295,7 +1210,7 @@ PP(pp_dbstate) SAVETMPS; SAVEI32(debug); - SAVESPTR(stack_sp); + SAVESTACK_POS(); debug = 0; hasargs = 0; sp = stack_sp; @@ -1339,11 +1254,8 @@ PP(pp_enteriter) PUSHBLOCK(cx, CXt_LOOP, SP); PUSHLOOP(cx, svp, MARK); - if (op->op_flags & OPf_STACKED) { - AV* av = (AV*)POPs; - cx->blk_loop.iterary = av; - cx->blk_loop.iterix = -1; - } + if (op->op_flags & OPf_STACKED) + cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); else { cx->blk_loop.iterary = curstack; AvFILL(curstack) = sp - stack_base; @@ -1675,6 +1587,7 @@ PP(pp_goto) EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); stack_sp += items; + SvREFCNT_dec(GvAV(defgv)); GvAV(defgv) = cx->blk_sub.savearray; AvREAL_off(av); av_clear(av); @@ -1716,8 +1629,7 @@ PP(pp_goto) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"", - GvENAME(CvGV(cv))); + sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); @@ -1726,8 +1638,10 @@ PP(pp_goto) for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { - /* outer lexical? */ + if ((SvFLAGS(svp[ix]) & SVf_FAKE) + || *name == '&') + { + /* outer lexical or anon code */ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]) ); } @@ -1765,7 +1679,7 @@ PP(pp_goto) cx->blk_sub.savearray = GvAV(defgv); cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; + GvAV(defgv) = (AV*)SvREFCNT_inc(av); ++mark; if (items >= AvMAX(av) + 1) { @@ -1791,12 +1705,13 @@ PP(pp_goto) } } if (perldb && curstash != debstash) { - /* &xsub is not copying @_ */ + /* + * We do not care about using sv to call CV; + * it's for informational purposes only. + */ SV *sv = GvSV(DBsub); save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); - /* We do not care about using sv to call CV, - * just for info. */ } RETURNOP(CvSTART(cv)); } @@ -1988,6 +1903,7 @@ int gimme; dSP; OP *saveop = op; HV *newstash; + CV *caller; AV* comppadlist; in_eval = 1; @@ -1996,17 +1912,19 @@ int gimme; /* set up a scratch pad */ - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_fill); + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); + caller = compcv; SAVESPTR(compcv); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); + CvUNIQUE_on(compcv); comppad = newAV(); comppad_name = newAV(); @@ -2021,6 +1939,10 @@ int gimme; av_store(comppadlist, 0, (SV*)comppad_name); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(compcv) = comppadlist; + + if (saveop->op_type != OP_REQUIRE) + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller); + SAVEFREESV(compcv); /* make sure we compile in the right package */ @@ -2080,6 +2002,20 @@ int gimme; DEBUG_x(dump_eval()); + /* Register with debugger: */ + + if (perldb && saveop->op_type == OP_REQUIRE) { + CV *cv = perl_get_cv("DB::postponed", FALSE); + + if (cv) { + dSP; + PUSHMARK(sp); + XPUSHs((SV*)compiling.cop_filegv); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } + /* compiled okay, so do it */ SP = stack_base + POPMARK; /* pop original mark */ @@ -2099,6 +2035,7 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { + SET_NUMERIC_STANDARD(); if (atof(patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", SvPV(sv,na),patchlevel); @@ -2124,8 +2061,8 @@ PP(pp_require) || (tmpname[0] && tmpname[1] == ':') #endif #ifdef VMS - || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && - (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>'))) + || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && + (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1])))) #endif ) { @@ -2134,13 +2071,15 @@ PP(pp_require) else { AV *ar = GvAVn(incgv); I32 i; - - for (i = 0; i <= AvFILL(ar); i++) { #ifdef VMS + char unixified[256]; + if (tounixspec_ts(tmpname,unixified) != NULL) + for (i = 0; i <= AvFILL(ar); i++) { if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL) continue; - strcat(buf,name); + strcat(buf,unixified); #else + for (i = 0; i <= AvFILL(ar); i++) { (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); #endif @@ -2213,9 +2152,10 @@ PP(pp_entereval) dSP; register CONTEXT *cx; dPOPss; - I32 gimme = GIMME; - char tmpbuf[32]; + I32 gimme = GIMME, was = sub_generation; + char tmpbuf[32], *safestr; STRLEN len; + OP *ret; if (!SvPV(sv,len) || !len) RETPUSHUNDEF; @@ -2231,7 +2171,13 @@ PP(pp_entereval) sprintf(tmpbuf, "_<(eval %d)", ++evalseq); compiling.cop_filegv = gv_fetchfile(tmpbuf+2); compiling.cop_line = 1; - SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + safestr = savepv(tmpbuf); + SAVEDELETE(defstash, safestr, strlen(safestr)); SAVEI32(hints); hints = op->op_targ; @@ -2244,7 +2190,11 @@ PP(pp_entereval) if (perldb && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; - return doeval(gimme); + ret = doeval(gimme); + if (perldb && was != sub_generation) { /* Some subs defined here. */ + strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ + } + return ret; } PP(pp_leaveeval) @@ -2388,7 +2338,10 @@ SV *sv; register I32 arg; bool ischop; - New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */ + if (len == 0) + croak("Null picture in formline"); + + New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; if (s < send) { @@ -2421,13 +2374,12 @@ SV *sv; skipspaces++; arg -= skipspaces; if (arg) { - if (postspace) { + if (postspace) *fpc++ = FF_SPACE; - postspace = FALSE; - } *fpc++ = FF_LITERAL; *fpc++ = arg; } + postspace = FALSE; if (s <= send) skipspaces--; if (skipspaces) { @@ -2543,5 +2495,6 @@ SV *sv; } Copy(fops, s, arg, U16); Safefree(fops); + sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } @@ -97,10 +97,10 @@ PP(pp_gelem) break; case 'C': if (strEQ(elem, "CODE")) - ref = (SV*)GvCV(gv); + ref = (SV*)GvCVu(gv); break; case 'F': - if (strEQ(elem, "FILEHANDLE")) + if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ ref = (SV*)GvIOp(gv); break; case 'G': @@ -111,6 +111,10 @@ PP(pp_gelem) if (strEQ(elem, "HASH")) ref = (SV*)GvHV(gv); break; + case 'I': + if (strEQ(elem, "IO")) + ref = (SV*)GvIOp(gv); + break; case 'N': if (strEQ(elem, "NAME")) sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); @@ -154,11 +158,8 @@ PP(pp_sassign) SV *temp; temp = left; left = right; right = temp; } - if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || - !((mg = mg_find(left, 't')) && mg->mg_len & 1))) - { + if (tainting && tainted && !SvTAINTED(left)) TAINT_NOT; - } SvSetSV(right, left); SvSETMAGIC(right); SETs(right); @@ -185,16 +186,6 @@ PP(pp_unstack) return NORMAL; } -PP(pp_seq) -{ - dSP; tryAMAGICbinSET(seq,0); - { - dPOPTOPssrl; - SETs( sv_eq(left, right) ? &sv_yes : &sv_no ); - RETURN; - } -} - PP(pp_concat) { dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); @@ -208,9 +199,9 @@ PP(pp_concat) } else if (SvGMAGICAL(TARG)) mg_get(TARG); - else if (!SvOK(TARG)) { - s = SvPV_force(TARG, len); + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ + s = SvPV_force(TARG, len); } s = SvPV(right,len); sv_catpvn(TARG,s,len); @@ -226,7 +217,7 @@ PP(pp_padsv) if (op->op_flags & OPf_MOD) { if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) + else if (op->op_private & OPpDEREF) provide_ref(op, curpad[op->op_targ]); } RETURN; @@ -252,15 +243,12 @@ PP(pp_preinc) { dSP; if (SvREADONLY(TOPs)) - croak(no_modify); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MAX) { - sv_setnv(TOPs, (double)(SvIVX(TOPs)) + 1.0 ); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + croak(no_modify); + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -283,7 +271,7 @@ PP(pp_add) { dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPnnrl; + dPOPTOPnnrl_ul; SETn( left + right ); RETURN; } @@ -311,7 +299,19 @@ PP(pp_join) PP(pp_pushre) { dSP; +#ifdef DEBUGGING + /* + * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs + * will be enough to hold an OP*. + */ + SV* sv = sv_newmortal(); + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = '/'; + Copy(&op, &LvTARGOFF(sv), 1, OP*); + XPUSHs(sv); +#else XPUSHs((SV*)op); +#endif RETURN; } @@ -604,7 +604,7 @@ PP(pp_aassign) ary = Null(AV*); hash = Null(HV*); while (lelem <= lastlelem) { - tainted = 0; /* Each item stands on its own, taintwise. */ + TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; switch (SvTYPE(sv)) { case SVt_PVAV: @@ -621,7 +621,7 @@ PP(pp_aassign) (void)av_store(ary,i++,sv); if (magic) mg_set(sv); - tainted = 0; + TAINT_NOT; } break; case SVt_PVHV: { @@ -644,7 +644,7 @@ PP(pp_aassign) (void)hv_store_ent(hash,sv,tmpstr,0); if (magic) mg_set(tmpstr); - tainted = 0; + TAINT_NOT; } if (relem == lastrelem) warn("Odd number of elements in hash list"); @@ -739,6 +739,9 @@ PP(pp_aassign) SP = lastrelem; else SP = firstrelem + (lastlelem - firstlelem); + lelem = firstlelem + (relem - firstrelem); + while (relem <= SP) + *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef; RETURN; } else { @@ -800,7 +803,7 @@ PP(pp_match) } if (!rx->nparens && !global) gimme = G_SCALAR; /* accidental array context? */ - safebase = (gimme == G_ARRAY) || global; + safebase = (((gimme == G_ARRAY) || global) && !sawampersand); if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; @@ -809,7 +812,7 @@ PP(pp_match) play_it_again: if (global && rx->startp[0]) { t = s = rx->endp[0]; - if (s > strend) + if (s >= strend) goto nope; minmatch = (s == rx->startp[0]); } @@ -838,15 +841,10 @@ play_it_again: s = t; } else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - memcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; - } + if (*SvPVX(pm->op_pmshort) != *s + || (pm->op_pmslen > 1 + && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen))) + goto nope; } if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { SvREFCNT_dec(pm->op_pmshort); @@ -854,8 +852,8 @@ play_it_again: } } if (pregexec(rx, s, strend, truebase, minmatch, - SvSCREAM(TARG) ? TARG : Nullsv, - safebase)) { + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) + { curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmflags |= PMf_USED; @@ -869,12 +867,14 @@ play_it_again: if (gimme == G_ARRAY) { I32 iters, i, len; + TAINT_IF(rx->exec_tainted); iters = rx->nparens; if (global && !iters) i = 1; else i = 0; EXTEND(SP, iters + i); + EXTEND_MORTAL(iters + i); for (i = !i; i <= iters; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ @@ -885,6 +885,7 @@ play_it_again: } if (global) { truebase = rx->subbeg; + strend = rx->subend; if (rx->startp[0] && rx->startp[0] == rx->endp[0]) ++rx->endp[0]; goto play_it_again; @@ -902,14 +903,12 @@ play_it_again: mg = mg_find(TARG, 'g'); } if (rx->startp[0]) { - mg->mg_len = rx->endp[0] - truebase; + mg->mg_len = rx->endp[0] - rx->subbeg; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } - else - mg->mg_len = -1; } LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -920,6 +919,8 @@ yup: curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmflags |= PMf_USED; + Safefree(rx->subbase); + rx->subbase = Nullch; if (global) { rx->subbeg = truebase; rx->subend = strend; @@ -930,8 +931,6 @@ yup: if (sawampersand) { char *tmps; - if (rx->subbase) - Safefree(rx->subbase); tmps = rx->subbase = savepvn(t, strend-t); rx->subbeg = tmps; rx->subend = tmps + (strend-t); @@ -946,13 +945,6 @@ nope: ++BmUSEFUL(pm->op_pmshort); ret_no: - if (global) { - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); - if (mg) - mg->mg_len = -1; - } - } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) RETURN; @@ -979,7 +971,8 @@ do_readline() perl_call_method("READLINE", GIMME); LEAVE; SPAGAIN; - if (GIMME == G_SCALAR) sv_setsv(TARG, TOPs); + if (GIMME == G_SCALAR) + SvSetSV_nosteal(TARG, TOPs); RETURN; } fp = Nullfp; @@ -1165,14 +1158,14 @@ do_readline() } RETURN; } + /* This should not be marked tainted if the fp is marked clean */ + if (!(IoFLAGS(io) & IOf_UNTAINT)) { + TAINT; + SvTAINTED_on(sv); + } IoLINES(io)++; + SvSETMAGIC(sv); XPUSHs(sv); - if (tainting) { - /* This should not be marked tainted if the fp is marked clean */ - if (!(IoFLAGS(io) & IOf_UNTAINT)) - tainted = TRUE; - SvTAINT(sv); /* Anything from the outside world...*/ - } if (type == OP_GLOB) { char *tmps; @@ -1252,9 +1245,13 @@ PP(pp_helem) if (lval) { if (!he || HeVAL(he) == &sv_undef) DIE(no_helem, SvPV(keysv, na)); - if (op->op_private & OPpLVAL_INTRO) - save_svref(&HeVAL(he)); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) + if (op->op_private & OPpLVAL_INTRO) { + if (HvNAME(hv) && isGV(HeVAL(he))) + save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL)); + else + save_svref(&HeVAL(he)); + } + else if (op->op_private & OPpDEREF) provide_ref(op, HeVAL(he)); } PUSHs(he ? HeVAL(he) : &sv_undef); @@ -1318,27 +1315,45 @@ PP(pp_iter) { dSP; register CONTEXT *cx; - SV *sv; + SV* sv; AV* av; EXTEND(sp, 1); cx = &cxstack[cxstack_ix]; if (cx->cx_type != CXt_LOOP) DIE("panic: pp_iter"); + av = cx->blk_loop.iterary; - if (av == curstack && cx->blk_loop.iterix >= cx->blk_oldsp) + if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - if (cx->blk_loop.iterix >= AvFILL(av)) - RETPUSHNO; + SvREFCNT_dec(*cx->blk_loop.itervar); - if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) { + if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); - *cx->blk_loop.itervar = sv; - } else - *cx->blk_loop.itervar = &sv_undef; + sv = &sv_undef; + if (av != curstack && SvIMMORTAL(sv)) { + SV *lv = cx->blk_loop.iterlval; + if (lv && SvREFCNT(lv) > 1) { + SvREFCNT_dec(lv); + lv = Nullsv; + } + if (lv) + SvREFCNT_dec(LvTARG(lv)); + else { + lv = cx->blk_loop.iterlval = newSVsv(sv); + sv_upgrade(lv, SVt_PVLV); + sv_magic(lv, Nullsv, 'y', Nullch, 0); + LvTYPE(lv) = 'y'; + } + LvTARG(lv) = SvREFCNT_inc(av); + LvTARGOFF(lv) = cx->blk_loop.iterix; + LvTARGLEN(lv) = 1; + sv = (SV*)lv; + } + *cx->blk_loop.itervar = SvREFCNT_inc(sv); RETPUSHYES; } @@ -1358,6 +1373,7 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; + bool rxtainted; char *orig; I32 safebase; register REGEXP *rx = pm->op_pmregexp; @@ -1388,7 +1404,7 @@ PP(pp_subst) pm = curpm; rx = pm->op_pmregexp; } - safebase = ((!rx || !rx->nparens) && !sawampersand); + safebase = (!rx->nparens && !sawampersand); if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; @@ -1415,139 +1431,124 @@ PP(pp_subst) s = m; } else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - memcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; - } + if (*SvPVX(pm->op_pmshort) != *s + || (pm->op_pmslen > 1 + && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen))) + goto nope; } if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { SvREFCNT_dec(pm->op_pmshort); pm->op_pmshort = Nullsv; /* opt is being useless */ } } + + /* only replace once? */ once = !(rpm->op_pmflags & PMf_GLOBAL); - if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */ - c = SvPV(dstr, clen); - if (clen <= rx->minlen) { - /* can do inplace substitution */ - if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - if (force_on_match) { - force_on_match = 0; - s = SvPV_force(TARG, len); - goto force_it; + + /* known replacement string? */ + c = (rpm->op_pmflags & PMf_CONST) ? SvPV(dstr, clen) : Nullch; + + /* can do inplace substitution? */ + if (c && clen <= rx->minlen) { + if (! pregexec(rx, s, strend, orig, 0, + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + PUSHs(&sv_no); + LEAVE_SCOPE(oldsave); + RETURN; + } + if (force_on_match) { + force_on_match = 0; + s = SvPV_force(TARG, len); + goto force_it; + } + if (rx->subbase) /* oops, no we can't */ + goto long_way; + d = s; + curpm = pm; + SvSCREAM_off(TARG); /* disable possible screamer */ + if (once) { + rxtainted = rx->exec_tainted; + m = rx->startp[0]; + d = rx->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; } - if (rx->subbase) /* oops, no we can't */ - goto long_way; - d = s; - curpm = pm; - SvSCREAM_off(TARG); /* disable possible screamer */ - if (once) { - m = rx->startp[0]; - d = rx->endp[0]; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ - d -= clen; - m = d; - sv_chop(TARG, d-i); - s += i; - while (i--) - *--d = *--s; - if (clen) - Copy(c, m, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else if (clen) { - d -= clen; - sv_chop(TARG, d); - Copy(c, d, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else { - sv_chop(TARG, d); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /* NOTREACHED */ + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; } - do { - if (iters++ > maxiters) - DIE("Substitution loop"); - m = rx->startp[0]; - /*SUPPRESS 560*/ - if (i = m - s) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = rx->endp[0]; - } while (pregexec(rx, s, strend, orig, s == m, - Nullsv, TRUE)); /* (don't match same null twice) */ - if (s != d) { - i = strend - s; - SvCUR_set(TARG, d - SvPVX(TARG) + i); - Move(s, d, i+1, char); /* include the Null */ + *m = '\0'; + SvCUR_set(TARG, m - s); + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + sv_chop(TARG, d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); + } + else if (clen) { + d -= clen; + sv_chop(TARG, d); + Copy(c, d, clen, char); + } + else { + sv_chop(TARG, d); + } + PUSHs(&sv_yes); + } + else { + rxtainted = 0; + do { + if (iters++ > maxiters) + DIE("Substitution loop"); + rxtainted |= rx->exec_tainted; + m = rx->startp[0]; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s, d, i, char); + d += i; } - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); - LEAVE_SCOPE(oldsave); - RETURN; + if (clen) { + Copy(c, d, clen, char); + d += clen; + } + s = rx->endp[0]; + } while (pregexec(rx, s, strend, orig, s == m, + Nullsv, TRUE)); /* don't match same null twice */ + if (s != d) { + i = strend - s; + SvCUR_set(TARG, d - SvPVX(TARG) + i); + Move(s, d, i+1, char); /* include the NUL */ } - PUSHs(&sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + PUSHs(sv_2mortal(newSViv((I32)iters))); } + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + if (rxtainted) + SvTAINTED_on(TARG); + LEAVE_SCOPE(oldsave); + RETURN; } - else - c = Nullch; + if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { long_way: if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); goto force_it; } + rxtainted = rx->exec_tainted; dstr = NEWSV(25, sv_len(TARG)); sv_setpvn(dstr, m, s-m); curpm = pm; @@ -1559,6 +1560,7 @@ PP(pp_subst) do { if (iters++ > maxiters) DIE("Substitution loop"); + rxtainted |= rx->exec_tainted; if (rx->subbase && rx->subbase != orig) { m = s; s = orig; @@ -1573,8 +1575,7 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (pregexec(rx, s, strend, orig, s == m, Nullsv, - safebase)); + } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -1587,6 +1588,8 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); + if (rxtainted) + SvTAINTED_on(TARG); PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; @@ -1695,7 +1698,7 @@ PP(pp_entersub) register CV *cv; register CONTEXT *cx; I32 gimme; - I32 hasargs = (op->op_flags & OPf_STACKED) != 0; + bool hasargs = (op->op_flags & OPf_STACKED) != 0; if (!sv) DIE("Not a CODE reference"); @@ -1725,7 +1728,7 @@ PP(pp_entersub) cv = (CV*)sv; break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) + if (!(cv = GvCVu((GV*)sv))) cv = sv_2cv(sv, &stash, &gv, TRUE); break; } @@ -1738,41 +1741,40 @@ PP(pp_entersub) DIE("Not a CODE reference"); if (!CvROOT(cv) && !CvXSUB(cv)) { - if (gv = CvGV(cv)) { - SV *tmpstr; - GV *ngv; - if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */ - cv = GvCV(gv); - if (SvTYPE(sv) == SVt_PVGV) { - SvREFCNT_dec(GvCV((GV*)sv)); - GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv); - } - goto retry; - } - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, Nullch); - ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); - if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ - gv = ngv; - sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */ - if (tainting) - sv_unmagic(GvSV(CvGV(cv)), 't'); - goto retry; - } - else - DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); + GV* autogv; + SV* subname; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvANON(cv) || !(gv = CvGV(cv))) + DIE("Undefined subroutine called"); + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + goto retry; + } + /* should call AUTOLOAD now? */ + if ((autogv = gv_autoload(GvESTASH(gv), GvNAME(gv), GvNAMELEN(gv)))) { + cv = GvCV(autogv); + goto retry; } - DIE("Undefined subroutine called"); + /* sorry */ + subname = sv_newmortal(); + gv_efullname3(subname, gv, Nullch); + DIE("Undefined subroutine &%s called", SvPVX(subname)); } gimme = GIMME; - if ((op->op_private & OPpENTERSUB_DB)) { + if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) { + SV *oldsv = sv; sv = GvSV(DBsub); save_item(sv); gv = CvGV(cv); - if ( CvFLAGS(cv) & (CVf_ANON | CVf_CLONED) - || strEQ(GvNAME(gv), "END") ) { - /* GV is potentially non-unique */ + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) + && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ sv_setsv(sv, newRV((SV*)cv)); } else { @@ -1855,8 +1857,9 @@ PP(pp_entersub) if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv))); + if (CvDEPTH(cv) == 100 && dowarn + && !(perldb && cv == GvCV(DBsub))) + sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *av; AV *newpad = newAV(); @@ -1866,9 +1869,10 @@ PP(pp_entersub) for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */ - av_store(newpad, ix, - SvREFCNT_inc(oldpad[ix]) ); + if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ + || *name == '&') /* anonymous code? */ + { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); } else { /* our own lexical */ if (*name == '@') @@ -1906,7 +1910,7 @@ PP(pp_entersub) } cx->blk_sub.savearray = GvAV(defgv); cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; + GvAV(defgv) = (AV*)SvREFCNT_inc(av); ++MARK; if (items > AvMAX(av) + 1) { @@ -1935,6 +1939,19 @@ PP(pp_entersub) } } +void +sub_crush_depth(cv) +CV* cv; +{ + if (CvANON(cv)) + warn("Deep recursion on anonymous subroutine"); + else { + SV* tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), Nullch); + warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); + } +} + PP(pp_aelem) { dSP; @@ -1953,7 +1970,7 @@ PP(pp_aelem) DIE(no_aelem, elem); if (op->op_private & OPpLVAL_INTRO) save_svref(svp); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) + else if (op->op_private & OPpDEREF) provide_ref(op, *svp); } PUSHs(svp ? *svp : &sv_undef); @@ -1970,9 +1987,25 @@ SV* sv; if (!SvOK(sv)) { if (SvREADONLY(sv)) croak(no_modify); - (void)SvUPGRADE(sv, SVt_RV); - SvRV(sv) = (op->op_private & OPpDEREF_HV ? - (SV*)newHV() : (SV*)newAV()); + if (SvTYPE(sv) < SVt_RV) + sv_upgrade(sv, SVt_RV); + else if (SvTYPE(sv) >= SVt_PV) { + (void)SvOOK_off(sv); + Safefree(SvPVX(sv)); + SvLEN(sv) = SvCUR(sv) = 0; + } + switch (op->op_private & OPpDEREF) + { + case OPpDEREF_SV: + SvRV(sv) = newSV(0); + break; + case OPpDEREF_AV: + SvRV(sv) = (SV*)newAV(); + break; + case OPpDEREF_HV: + SvRV(sv) = (SV*)newHV(); + break; + } SvROK_on(sv); SvSETMAGIC(sv); } @@ -2019,7 +2052,7 @@ DIE("Can't call method \"%s\" without a package or object reference", name); if (!gv) DIE("Can't locate object method \"%s\" via package \"%s\"", name, packname); - SETs((SV*)gv); + SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); @@ -2038,7 +2071,7 @@ DIE("Can't call method \"%s\" without a package or object reference", name); name, HvNAME(SvSTASH(ob))); } - SETs((SV*)gv); + SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } @@ -98,6 +98,52 @@ static int dooneliner _((char *cmd, char *filename)); # define my_chsize chsize #endif +#ifdef HAS_FLOCK +# define FLOCK flock +#else /* no flock() */ + + /* fcntl.h might not have been included, even if it exists, because + the current Configure only sets I_FCNTL if it's needed to pick up + the *_OK constants. Make sure it has been included before testing + the fcntl() locking constants. */ +# if defined(HAS_FCNTL) && !defined(I_FCNTL) +# include <fcntl.h> +# endif + +# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW) +# define FLOCK fcntl_emulate_flock +# define FCNTL_EMULATE_FLOCK +# else /* no flock() or fcntl(F_SETLK,...) */ +# ifdef HAS_LOCKF +# define FLOCK lockf_emulate_flock +# define LOCKF_EMULATE_FLOCK +# endif /* lockf */ +# endif /* no flock() or fcntl(F_SETLK,...) */ + +# ifdef FLOCK + static int FLOCK _((int, int)); + + /* + * These are the flock() constants. Since this sytems doesn't have + * flock(), the values of the constants are probably not available. + */ +# ifndef LOCK_SH +# define LOCK_SH 1 +# endif +# ifndef LOCK_EX +# define LOCK_EX 2 +# endif +# ifndef LOCK_NB +# define LOCK_NB 4 +# endif +# ifndef LOCK_UN +# define LOCK_UN 8 +# endif +# endif /* emulating flock() */ + +#endif /* no flock() */ + + /* Pushy I/O. */ PP(pp_backtick) @@ -156,7 +202,7 @@ PP(pp_glob) #ifndef CSH *SvPVX(rs) = '\n'; #endif /* !CSH */ -#endif /* !MSDOS */ +#endif /* !DOSISH */ result = do_readline(); LEAVE; @@ -238,18 +284,18 @@ PP(pp_open) if (MAXARG > 1) sv = POPs; - else if (SvTYPE(TOPs) == SVt_PVGV) - sv = GvSV(TOPs); - else + if (!isGV(TOPs)) DIE(no_usym, "filehandle"); + if (MAXARG <= 1) + sv = GvSV(TOPs); gv = (GV*)POPs; - if (IoFLAGS(GvIOn(gv)) & IOf_UNTAINT) /* This GV has UNTAINT previously set */ - IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; /* Clear it. We don't carry that over */ + if (!isGV(gv)) + DIE(no_usym, "filehandle"); + if (GvIOp(gv)) + IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; tmps = SvPV(sv, len); - if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp)) { - IoLINES(GvIOp(gv)) = 0; + if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp)) PUSHi( (I32)forkprocess ); - } else if (forkprocess == 0) /* we are a new child */ PUSHi(0); else @@ -372,7 +418,7 @@ PP(pp_binmode) EXTEND(SP, 1); if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) - RETSETUNDEF; + RETPUSHUNDEF; #ifdef DOSISH #ifdef atarist @@ -422,7 +468,7 @@ PP(pp_tie) methname = "TIESCALAR"; stash = gv_stashsv(mark[1], FALSE); - if (!stash || !(gv = gv_fetchmethod(stash, methname)) || !GvCV(gv)) + if (!stash || !(gv = gv_fetchmethod(stash, methname))) DIE("Can't locate object method \"%s\" via package \"%s\"", methname, SvPV(mark[1],na)); @@ -437,7 +483,7 @@ PP(pp_tie) if (perldb && curstash != debstash) op->op_private |= OPpENTERSUB_DB; - XPUSHs((SV*)gv); + XPUSHs((SV*)GvCV(gv)); PUTBACK; if (op = pp_entersub()) @@ -467,8 +513,8 @@ PP(pp_untie) SV * sv ; sv = POPs; - if (hints & HINT_STRICT_UNTIE) - { + + if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -477,7 +523,7 @@ PP(pp_untie) mg = mg_find(sv, 'q') ; if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) - croak("Can't untie: %d inner references still exist", + warn("untie attempted while %d inner references still exist", SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } @@ -486,7 +532,7 @@ PP(pp_untie) sv_unmagic(sv, 'P'); else sv_unmagic(sv, 'q'); - RETSETYES; + RETPUSHYES; } PP(pp_tied) @@ -526,11 +572,11 @@ PP(pp_dbmopen) sv = sv_mortalcopy(&sv_no); sv_setpv(sv, "AnyDBM_File"); stash = gv_stashsv(sv, FALSE); - if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) { + if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { PUTBACK; perl_require_pv("AnyDBM_File.pm"); SPAGAIN; - if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) + if (!(gv = gv_fetchmethod(stash, "TIEHASH"))) DIE("No dbm on this machine"); } @@ -555,7 +601,7 @@ PP(pp_dbmopen) else PUSHs(sv_2mortal(newSViv(O_RDWR))); PUSHs(right); - PUSHs((SV*)gv); + PUSHs((SV*)GvCV(gv)); PUTBACK; if (op = pp_entersub()) @@ -572,7 +618,7 @@ PP(pp_dbmopen) PUSHs(left); PUSHs(sv_2mortal(newSViv(O_RDONLY))); PUSHs(right); - PUSHs((SV*)gv); + PUSHs((SV*)GvCV(gv)); PUTBACK; if (op = pp_entersub()) @@ -629,7 +675,7 @@ PP(pp_sselect) } #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -#ifdef __linux__ +#if defined(__linux__) || defined(OS2) growsize = sizeof(fd_set); #else growsize = maxlen; /* little endians can use vecs directly */ @@ -781,7 +827,7 @@ PP(pp_getc) gv = argvgv; if (!gv || do_eof(gv)) /* make sure we have fp with something */ RETPUSHUNDEF; - TAINT_IF(1); + TAINT; sv_setpv(TARG, " "); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ PUSHTARG; @@ -843,7 +889,6 @@ PP(pp_enterwrite) fgv = gv; cv = GvFORM(fgv); - if (!cv) { if (fgv) { SV *tmpsv = sv_newmortal(); @@ -852,8 +897,10 @@ PP(pp_enterwrite) } DIE("Not a format reference"); } - IoFLAGS(io) &= ~IOf_DIDTOP; + if (CvCLONE(cv)) + cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); + IoFLAGS(io) &= ~IOf_DIDTOP; return doform(cv,gv,op->op_next); } @@ -929,6 +976,8 @@ PP(pp_leavewrite) gv_efullname3(tmpsv, fgv, Nullch); DIE("Undefined top format \"%s\" called",SvPVX(tmpsv)); } + if (CvCLONE(cv)) + cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); return doform(cv,gv,op); } @@ -1001,6 +1050,12 @@ PP(pp_prtf) goto just_say_no; } else { +#ifdef USE_LOCALE_NUMERIC + if (op->op_private & OPpLOCALE) + SET_NUMERIC_LOCAL(); + else + SET_NUMERIC_STANDARD(); +#endif do_sprintf(sv, SP - MARK, MARK + 1); if (!do_print(sv, fp)) goto just_say_no; @@ -1065,6 +1120,8 @@ PP(pp_sysread) if (!gv) goto say_undef; bufsv = *++MARK; + if (! SvOK(bufsv)) + sv_setpvn(bufsv, "", 0); buffer = SvPV_force(bufsv, blen); length = SvIVx(*++MARK); if (length < 0) @@ -1081,6 +1138,7 @@ PP(pp_sysread) if (op->op_type == OP_RECV) { bufsize = sizeof buf; buffer = SvGROW(bufsv, length+1); + /* 'offset' means 'flags' here */ length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)buf, &bufsize); if (length < 0) @@ -1090,8 +1148,8 @@ PP(pp_sysread) (void)SvPOK_only(bufsv); SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ - if (tainting && !(IoFLAGS(io) & IOf_UNTAINT)) - sv_magic(bufsv, Nullsv, 't', Nullch, 0); + if (!(IoFLAGS(io) & IOf_UNTAINT)) + SvTAINTED_on(bufsv); SP = ORIGMARK; sv_setpvn(TARG, buf, bufsize); PUSHs(TARG); @@ -1101,6 +1159,11 @@ PP(pp_sysread) if (op->op_type == OP_RECV) DIE(no_sock_func, "recv"); #endif + if (offset < 0) { + if (-offset > blen) + DIE("Offset outside string"); + offset += blen; + } bufsize = SvCUR(bufsv); buffer = SvGROW(bufsv, length+offset+1); if (offset > bufsize) { /* Zero any newly allocated space */ @@ -1126,8 +1189,8 @@ PP(pp_sysread) (void)SvPOK_only(bufsv); SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ - if (tainting && !(IoFLAGS(io) & IOf_UNTAINT)) - sv_magic(bufsv, Nullsv, 't', Nullch, 0); + if (!(IoFLAGS(io) & IOf_UNTAINT)) + SvTAINTED_on(bufsv); SP = ORIGMARK; PUSHi(length); RETURN; @@ -1173,9 +1236,15 @@ PP(pp_send) } } else if (op->op_type == OP_SYSWRITE) { - if (MARK < SP) + if (MARK < SP) { offset = SvIVx(*++MARK); - else + if (offset < 0) { + if (-offset > blen) + DIE("Offset outside string"); + offset += blen; + } else if (offset >= blen) + DIE("Offset outside string"); + } else offset = 0; if (length > blen - offset) length = blen - offset; @@ -1287,7 +1356,7 @@ PP(pp_truncate) int tmpfd; if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0) - result = 0; + result = 0; else { if (my_chsize(tmpfd, len) < 0) result = 0; @@ -1357,18 +1426,14 @@ PP(pp_ioctl) DIE("ioctl is not implemented"); #endif else -#if defined(DOSISH) && !defined(OS2) - DIE("fcntl is not implemented"); -#else -# ifdef HAS_FCNTL -# if defined(OS2) && defined(__EMX__) +#ifdef HAS_FCNTL +#if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); -# else +#else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); -# endif -# else +#endif +#else DIE("fcntl is not implemented"); -# endif #endif if (SvPOK(argsv)) { @@ -1398,11 +1463,7 @@ PP(pp_flock) GV *gv; PerlIO *fp; -#if !defined(HAS_FLOCK) && defined(HAS_LOCKF) -# define flock lockf_emulate_flock -#endif - -#if defined(HAS_FLOCK) || defined(flock) +#ifdef FLOCK argtype = POPi; if (MAXARG <= 0) gv = last_in_gv; @@ -1413,7 +1474,7 @@ PP(pp_flock) else fp = Nullfp; if (fp) { - value = (I32)(flock(PerlIO_fileno(fp), argtype) >= 0); + value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0); } else value = 0; @@ -1802,6 +1863,12 @@ PP(pp_getpeername) goto nuts2; break; } +#ifdef BOGUS_GETNAME_RETURN + /* Interactive Unix, getpeername() and getsockname() + does not return valid namelen */ + if (aint == BOGUS_GETNAME_RETURN) + aint = sizeof(struct sockaddr); +#endif SvCUR_set(sv,aint); *SvEND(sv) ='\0'; PUSHs(sv); @@ -1839,13 +1906,10 @@ PP(pp_stat) laststype = OP_STAT; statgv = tmpgv; sv_setpv(statname, ""); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || - Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { - max = 0; - laststatval = -1; - } + laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv)) + ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1); } - else if (laststatval < 0) + if (laststatval < 0) max = 0; } else { @@ -1874,14 +1938,17 @@ PP(pp_stat) } } - EXTEND(SP, 13); if (GIMME != G_ARRAY) { + EXTEND(SP, 1); if (max) RETPUSHYES; else RETPUSHUNDEF; } if (max) { + EXTEND(SP, max); + EXTEND_MORTAL(max); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino))); PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode))); @@ -2215,11 +2282,21 @@ PP(pp_fttext) STDCHAR tbuf[512]; register STDCHAR *s; register IO *io; - SV *sv; + register SV *sv; + GV *gv; - if (op->op_flags & OPf_REF) { + if (op->op_flags & OPf_REF) + gv = cGVOP->op_gv; + else if (isGV(TOPs)) + gv = (GV*)POPs; + else if (SvROK(TOPs) && isGV(SvRV(TOPs))) + gv = (GV*)SvRV(POPs); + else + gv = Nullgv; + + if (gv) { EXTEND(SP, 1); - if (cGVOP->op_gv == defgv) { + if (gv == defgv) { if (statgv) io = GvIO(statgv); else { @@ -2228,13 +2305,17 @@ PP(pp_fttext) } } else { - statgv = cGVOP->op_gv; + statgv = gv; + laststatval = -1; sv_setpv(statname, ""); io = GvIO(statgv); } if (io && IoIFP(io)) { - if (PerlIO_has_base(IoIFP(io))) { - Fstat(PerlIO_fileno(IoIFP(io)), &statcache); + if (! PerlIO_has_base(IoIFP(io))) + DIE("-T and -B not implemented on filehandles"); + laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache); + if (laststatval < 0) + RETPUSHUNDEF; if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */ if (op->op_type == OP_FTTEXT) RETPUSHNO; @@ -2252,10 +2333,6 @@ PP(pp_fttext) /* sfio can have large buffers - limit to 512 */ if (len > 512) len = 512; - } - else { - DIE("-T and -B not implemented on filehandles"); - } } else { if (dowarn) @@ -2267,9 +2344,10 @@ PP(pp_fttext) } else { sv = POPs; + really_filename: statgv = Nullgv; + laststatval = -1; sv_setpv(statname, SvPV(sv, na)); - really_filename: #ifdef HAS_OPEN3 i = open(SvPV(sv, na), O_RDONLY, 0); #else @@ -2280,7 +2358,9 @@ PP(pp_fttext) warn(warn_nl, "open"); RETPUSHUNDEF; } - Fstat(i, &statcache); + laststatval = Fstat(i, &statcache); + if (laststatval < 0) + RETPUSHUNDEF; len = read(i, tbuf, 512); (void)close(i); if (len <= 0) { @@ -2419,13 +2499,15 @@ PP(pp_rename) #ifdef HAS_RENAME anum = rename(tmps, tmps2); #else - if (same_dirent(tmps2, tmps)) /* can always rename to same name */ - anum = 1; - else { - if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) - (void)UNLINK(tmps2); - if (!(anum = link(tmps, tmps2))) - anum = UNLINK(tmps); + if (!(anum = Stat(tmps, &statbuf))) { + if (same_dirent(tmps2, tmps)) /* can always rename to same name */ + anum = 1; + else { + if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) + (void)UNLINK(tmps2); + if (!(anum = link(tmps, tmps2))) + anum = UNLINK(tmps); + } } #endif SETi( anum >= 0 ); @@ -2768,12 +2850,12 @@ nope: PP(pp_fork) { +#ifdef HAS_FORK dSP; dTARGET; int childpid; GV *tmpgv; EXTEND(SP, 1); -#ifdef HAS_FORK childpid = fork(); if (childpid < 0) RETSETUNDEF; @@ -2792,19 +2874,14 @@ PP(pp_fork) PP(pp_wait) { +#if !defined(DOSISH) || defined(OS2) dSP; dTARGET; int childpid; int argflags; - I32 value; - EXTEND(SP, 1); -#ifdef HAS_WAIT - childpid = wait(&argflags); - if (childpid > 0) - pidgone(childpid, argflags); - value = (I32)childpid; - statusvalue = FIXSTATUS(argflags); - PUSHi(value); + childpid = wait4pid(-1, &argflags, 0); + statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1; + XPUSHi(childpid); RETURN; #else DIE(no_func, "Unsupported function wait"); @@ -2813,19 +2890,17 @@ PP(pp_wait) PP(pp_waitpid) { +#if !defined(DOSISH) || defined(OS2) dSP; dTARGET; int childpid; int optype; int argflags; - I32 value; -#ifdef HAS_WAIT optype = POPi; childpid = TOPi; childpid = wait4pid(childpid, &argflags, optype); - value = (I32)childpid; - statusvalue = FIXSTATUS(argflags); - SETi(value); + statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1; + SETi(childpid); RETURN; #else DIE(no_func, "Unsupported function wait"); @@ -2839,10 +2914,9 @@ PP(pp_system) int childpid; int result; int status; - Signal_t (*ihand)(); /* place to save signal during system() */ - Signal_t (*qhand)(); /* place to save signal during system() */ + Sigsave_t ihand,qhand; /* place to save signals during system() */ -#if defined(HAS_FORK) && !defined(VMS) && !defined(OS2) +#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) if (SP - MARK == 1) { if (tainting) { char *junk = SvPV(TOPs, na); @@ -2860,13 +2934,13 @@ PP(pp_system) sleep(5); } if (childpid > 0) { - ihand = signal(SIGINT, SIG_IGN); - qhand = signal(SIGQUIT, SIG_IGN); + rsignal_save(SIGINT, SIG_IGN, &ihand); + rsignal_save(SIGQUIT, SIG_IGN, &qhand); do { result = wait4pid(childpid, &status, 0); } while (result == -1 && errno == EINTR); - (void)signal(SIGINT, ihand); - (void)signal(SIGQUIT, qhand); + (void)rsignal_restore(SIGINT, &ihand); + (void)rsignal_restore(SIGQUIT, &qhand); statusvalue = FIXSTATUS(status); if (result < 0) value = -1; @@ -3084,7 +3158,7 @@ PP(pp_tms) { dSP; -#if defined(MSDOS) || !defined(HAS_TIMES) +#ifndef HAS_TIMES DIE("times not implemented"); #else EXTEND(SP, 4); @@ -3104,7 +3178,7 @@ PP(pp_tms) PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ))); } RETURN; -#endif /* MSDOS */ +#endif /* HAS_TIMES */ } PP(pp_localtime) @@ -3136,6 +3210,7 @@ PP(pp_gmtime) tmbuf = gmtime(&when); EXTEND(SP, 9); + EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { dTARGET; char mybuf[30]; @@ -3604,8 +3679,11 @@ PP(pp_gservent) } else if (which == OP_GSBYPORT) { char *proto = POPp; - int port = POPi; + unsigned short port = POPu; +#ifdef HAS_HTONS + port = htons(port); +#endif sent = getservbyport(port, proto); } else @@ -3976,9 +4054,10 @@ PP(pp_syscall) if (tainting) { while (++MARK <= SP) { - if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) && - (mg = mg_find(*MARK, 't')) && mg->mg_len & 1) - tainted = TRUE; + if (SvTAINTED(*MARK)) { + TAINT; + break; + } } MARK = ORIGMARK; TAINT_PROPER("syscall"); @@ -4060,7 +4139,42 @@ PP(pp_syscall) #endif } -#if !defined(HAS_FLOCK) && defined(HAS_LOCKF) +#ifdef FCNTL_EMULATE_FLOCK + +/* XXX Emulate flock() with fcntl(). + What's really needed is a good file locking module. +*/ + +static int +fcntl_emulate_flock(fd, operation) +int fd; +int operation; +{ + struct flock flock; + + switch (operation & ~LOCK_NB) { + case LOCK_SH: + flock.l_type = F_RDLCK; + break; + case LOCK_EX: + flock.l_type = F_WRLCK; + break; + case LOCK_UN: + flock.l_type = F_UNLCK; + break; + default: + errno = EINVAL; + return -1; + } + flock.l_whence = SEEK_SET; + flock.l_start = flock.l_len = 0L; + + return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); +} + +#endif /* FCNTL_EMULATE_FLOCK */ + +#ifdef LOCKF_EMULATE_FLOCK /* XXX Emulate flock() with lockf(). This is just to increase portability of scripts. The calls are not completely @@ -4090,23 +4204,7 @@ PP(pp_syscall) # define F_TEST 3 /* Test a region for other processes locks */ # endif -/* These are the flock() constants. Since this sytems doesn't have - flock(), the values of the constants are probably not available. -*/ -# ifndef LOCK_SH -# define LOCK_SH 1 -# endif -# ifndef LOCK_EX -# define LOCK_EX 2 -# endif -# ifndef LOCK_NB -# define LOCK_NB 4 -# endif -# ifndef LOCK_UN -# define LOCK_UN 8 -# endif - -int +static int lockf_emulate_flock (fd, operation) int fd; int operation; @@ -4131,8 +4229,9 @@ int operation; errno = EWOULDBLOCK; break; - /* LOCK_UN - unlock */ + /* LOCK_UN - unlock (non-blocking is a no-op) */ case LOCK_UN: + case LOCK_UN|LOCK_NB: i = lockf (fd, F_ULOCK, 0); break; @@ -4144,4 +4243,5 @@ int operation; } return (i); } -#endif + +#endif /* LOCKF_EMULATE_FLOCK */ @@ -8,7 +8,7 @@ #endif #ifdef OVERLOAD SV* amagic_call _((SV* left,SV* right,int method,int dir)); -bool Gv_AMupdate _((HV* stash)); +bool Gv_AMupdate _((HV* stash)); #endif /* OVERLOAD */ OP* append_elem _((I32 optype, OP* head, OP* tail)); OP* append_list _((I32 optype, LISTOP* first, LISTOP* last)); @@ -28,8 +28,8 @@ SV** av_store _((AV* ar, I32 key, SV* val)); void av_undef _((AV* ar)); void av_unshift _((AV* ar, I32 num)); OP* bind_match _((I32 type, OP* left, OP* pat)); -OP* block_end _((int line, int floor, OP* seq)); -int block_start _((void)); +OP* block_end _((I32 floor, OP* seq)); +int block_start _((int full)); void boot_core_UNIVERSAL _((void)); void calllist _((AV* list)); I32 cando _((I32 bit, I32 effective, struct stat* statbufp)); @@ -43,7 +43,8 @@ OP * ck_gvconst _((OP * o)); OP * ck_retarget _((OP *op)); OP* convert _((I32 optype, I32 flags, OP* op)); char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen)); -void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn)); +void croak _((const char* pat,...)) + __attribute__((format(printf,1,2),noreturn)); CV* cv_clone _((CV* proto)); void cv_undef _((CV* cv)); SV* cv_const_sv _((CV* cv)); @@ -54,7 +55,7 @@ SV * filter_add _((filter_t funcp, SV *datasv)); void filter_del _((filter_t funcp)); I32 filter_read _((int idx, SV *buffer, int maxlen)); I32 cxinc _((void)); -void deb _((char* pat,...)) __attribute__((format(printf,1,2))); +void deb _((const char* pat,...)) __attribute__((format(printf,1,2))); void deb_growlevel _((void)); I32 debop _((OP* op)); I32 debstackptrs _((void)); @@ -63,7 +64,7 @@ void debprofdump _((void)); #endif I32 debstack _((void)); void deprecate _((char* s)); -OP* die _((char* pat,...)) __attribute__((format(printf,1,2))); +OP* die _((const char* pat,...)) __attribute__((format(printf,1,2))); OP* die_where _((char* message)); void dounwind _((I32 cxix)); bool do_aexec _((SV* really, SV** mark, SV** sp)); @@ -113,7 +114,7 @@ void dump_op _((OP* arg)); void dump_pm _((PMOP* pm)); void dump_packsubs _((HV* stash)); void dump_sub _((GV* gv)); -void fbm_compile _((SV* sv, I32 iflag)); +void fbm_compile _((SV* sv)); char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); OP* force_list _((OP* arg)); OP* fold_constants _((OP * arg)); @@ -124,6 +125,7 @@ GP* gp_ref _((GP* gp)); GV* gv_AVadd _((GV* gv)); GV* gv_HVadd _((GV* gv)); GV* gv_IOadd _((GV* gv)); +GV* gv_autoload _((HV* stash, char* name, STRLEN len)); void gv_check _((HV* stash)); void gv_efullname _((SV* sv, GV* gv)); void gv_efullname3 _((SV* sv, GV* gv, char* prefix)); @@ -137,8 +139,8 @@ void gv_init _((GV *gv, HV *stash, char *name, STRLEN len, int multi)); HV* gv_stashpv _((char* name, I32 create)); HV* gv_stashpvn _((char* name, U32 namelen, I32 create)); HV* gv_stashsv _((SV* sv, I32 create)); -void he_delayfree _((HE* hent, I32 shared)); -void he_free _((HE* hent, I32 shared)); +void he_delayfree _((HV* hv, HE* hent)); +void he_free _((HV* hv, HE* hent)); void hoistmust _((PMOP* pm)); void hv_clear _((HV* tb)); SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags)); @@ -158,8 +160,10 @@ void hv_magic _((HV* hv, GV* gv, int how)); SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash)); HE* hv_store_ent _((HV* tb, SV* key, SV* val, U32 hash)); void hv_undef _((HV* tb)); -I32 ibcmp _((U8* a, U8* b, I32 len)); +I32 ibcmp _((char* a, char* b, I32 len)); +I32 ibcmp_locale _((char* a, char* b, I32 len)); I32 ingroup _((I32 testgid, I32 effective)); +U32 intro_my _((void)); char* instr _((char* big, char* little)); bool io_close _((IO* io)); OP* invert _((OP* cmd)); @@ -176,11 +180,13 @@ I32 looks_like_number _((SV* sv)); int magic_clearenv _((SV* sv, MAGIC* mg)); int magic_clearpack _((SV* sv, MAGIC* mg)); int magic_clearsig _((SV* sv, MAGIC* mg)); -int magic_existspack _((SV* sv, MAGIC* mg)); +int magic_existspack _((SV* sv, MAGIC* mg)); +int magic_freeitervar _((SV* sv, MAGIC* mg)); int magic_get _((SV* sv, MAGIC* mg)); int magic_getarylen _((SV* sv, MAGIC* mg)); int magic_getpack _((SV* sv, MAGIC* mg)); int magic_getglob _((SV* sv, MAGIC* mg)); +int magic_getitervar _((SV* sv, MAGIC* mg)); int magic_getpos _((SV* sv, MAGIC* mg)); int magic_getsig _((SV* sv, MAGIC* mg)); int magic_gettaint _((SV* sv, MAGIC* mg)); @@ -194,8 +200,13 @@ int magic_setamagic _((SV* sv, MAGIC* mg)); int magic_setarylen _((SV* sv, MAGIC* mg)); int magic_setbm _((SV* sv, MAGIC* mg)); int magic_setdbline _((SV* sv, MAGIC* mg)); +#ifdef USE_LOCALE_COLLATE +int magic_setcollxfrm _((SV* sv, MAGIC* mg)); +#endif int magic_setenv _((SV* sv, MAGIC* mg)); +int magic_setfm _((SV* sv, MAGIC* mg)); int magic_setisa _((SV* sv, MAGIC* mg)); +int magic_setitervar _((SV* sv, MAGIC* mg)); int magic_setglob _((SV* sv, MAGIC* mg)); int magic_setmglob _((SV* sv, MAGIC* mg)); int magic_setnkeys _((SV* sv, MAGIC* mg)); @@ -209,18 +220,11 @@ int magic_setvec _((SV* sv, MAGIC* mg)); int magic_wipepack _((SV* sv, MAGIC* mg)); void magicname _((char* sym, char* name, I32 namlen)); int main _((int argc, char** argv, char** env)); -#if !defined(STANDARD_C) -Malloc_t malloc _((MEM_SIZE nbytes)); -#endif -#if defined(MYMALLOC) && defined(HIDEMYMALLOC) -extern Malloc_t malloc _((MEM_SIZE nbytes)); -extern Malloc_t realloc _((Malloc_t, MEM_SIZE)); -extern Free_t free _((Malloc_t)); -extern Malloc_t calloc _((MEM_SIZE, MEM_SIZE)); -#endif void markstack_grow _((void)); -char* mem_collxfrm _((const char *m, const Size_t n, Size_t * nx)); -char* mess _((char* pat, va_list* args)); +#ifdef USE_LOCALE_COLLATE +char* mem_collxfrm _((const char *s, STRLEN len, STRLEN *xlen)); +#endif +char* mess _((const char* pat, va_list* args)); int mg_clear _((SV* sv)); int mg_copy _((SV *, SV *, char *, I32)); MAGIC* mg_find _((SV* sv, int type)); @@ -232,14 +236,16 @@ int mg_set _((SV* sv)); OP* mod _((OP* op, I32 type)); char* moreswitches _((char* s)); OP * my _(( OP *)); +#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char* my_bcopy _((char* from, char* to, I32 len)); +#endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char* my_bzero _((char* loc, I32 len)); #endif void my_exit _((U32 status)) __attribute__((noreturn)); I32 my_lstat _((void)); -#ifndef HAS_MEMCMP -I32 my_memcmp _((unsigned char* s1, unsigned char* s2, I32 len)); +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) +I32 my_memcmp _((char* s1, char* s2, I32 len)); #endif I32 my_pclose _((PerlIO* ptr)); PerlIO* my_popen _((char* cmd, char* mode)); @@ -329,8 +335,13 @@ SV* perl_get_sv _((char* name, I32 create)); AV* perl_get_av _((char* name, I32 create)); HV* perl_get_hv _((char* name, I32 create)); CV* perl_get_cv _((char* name, I32 create)); -int perl_init_fold _(()); int perl_init_i18nl10n _((int printwarn)); +int perl_init_i18nl14n _((int printwarn)); +void perl_new_collate _((char *newcoll)); +void perl_new_ctype _((char *newctype)); +void perl_new_numeric _((char *newcoll)); +void perl_set_numeric_local _((void)); +void perl_set_numeric_standard _((void)); int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env)); void perl_require_pv _((char* pv)); #define perl_requirepv perl_require_pv @@ -355,30 +366,16 @@ char* regnext _((char* p)); char* regprop _((char* op)); void repeatcpy _((char* to, char* from, I32 len, I32 count)); char* rninstr _((char* big, char* bigend, char* little, char* lend)); +Sighandler_t rsignal _((int, Sighandler_t)); +int rsignal_restore _((int, Sigsave_t*)); +int rsignal_save _((int, Sighandler_t, Sigsave_t*)); +Sighandler_t rsignal_state _((int)); int runops _((void)); -#ifndef safemalloc -void safefree _((Malloc_t where)); -Malloc_t safemalloc _((MEM_SIZE size)); -#ifndef MSDOS -Malloc_t saferealloc _((Malloc_t where, MEM_SIZE size)); -#else -Malloc_t saferealloc _((Malloc_t where, unsigned long size)); -#endif -Malloc_t safecalloc _((MEM_SIZE cnt, MEM_SIZE size)); -#endif -#ifdef LEAKTEST -void safexfree _((Malloc_t where)); -Malloc_t safexmalloc _((I32 x, MEM_SIZE size)); -Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size)); -Malloc_t safexcalloc _((I32 x, MEM_SIZE size, MEM_SIZE size)); -#endif #ifndef HAS_RENAME I32 same_dirent _((char* a, char* b)); #endif char* savepv _((char* sv)); char* savepvn _((char* sv, I32 len)); -char* sharepvn _((char* sv, I32 len, U32 hash)); -void unsharepvn _((char* sv, I32 len, U32 hash)); void savestack_grow _((void)); void save_aptr _((AV** aptr)); AV* save_ary _((GV* gv)); @@ -390,11 +387,14 @@ void save_destructor _((void (*f)(void*), void* p)); void save_freesv _((SV* sv)); void save_freeop _((OP* op)); void save_freepv _((char* pv)); +void save_gp _((GV* gv, I32 empty)); HV* save_hash _((GV* gv)); void save_hptr _((HV** hptr)); +void save_I16 _((I16* intp)); void save_I32 _((I32* intp)); void save_int _((int* intp)); void save_item _((SV* item)); +void save_iv _((IV* iv)); void save_list _((SV** sarg, I32 maxsarg)); void save_long _((long *longp)); void save_nogv _((GV* gv)); @@ -407,18 +407,21 @@ OP* scalar _((OP* o)); OP* scalarkids _((OP* op)); OP* scalarseq _((OP* o)); OP* scalarvoid _((OP* op)); -unsigned long scan_hex _((char* start, I32 len, I32* retlen)); +UV scan_hex _((char* start, I32 len, I32* retlen)); char* scan_num _((char* s)); -unsigned long scan_oct _((char* start, I32 len, I32* retlen)); +UV scan_oct _((char* start, I32 len, I32* retlen)); OP* scope _((OP* o)); char* screaminstr _((SV* bigsv, SV* littlesv)); #ifndef VMS I32 setenv_getix _((char* nam)); #endif void setdefout _((GV *gv)); +char* sharepvn _((char* sv, I32 len, U32 hash)); +HEK* share_hek _((char* sv, I32 len, U32 hash)); Signal_t sighandler _((int sig)); SV** stack_grow _((SV** sp, SV**p, int n)); int start_subparse _((void)); +void sub_crush_depth _((CV* cv)); bool sv_2bool _((SV* sv)); CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref)); IO* sv_2io _((SV* sv)); @@ -426,6 +429,7 @@ IV sv_2iv _((SV* sv)); SV* sv_2mortal _((SV* sv)); double sv_2nv _((SV* sv)); char* sv_2pv _((SV* sv, STRLEN* lp)); +UV sv_2uv _((SV* sv)); void sv_add_arena _((char* ptr, U32 size, U32 flags)); int sv_backoff _((SV* sv)); SV* sv_bless _((SV* sv, HV* stash)); @@ -437,8 +441,13 @@ void sv_clean_all _((void)); void sv_clean_objs _((void)); void sv_clear _((SV* sv)); I32 sv_cmp _((SV* sv1, SV* sv2)); +I32 sv_cmp_locale _((SV* sv1, SV* sv2)); +#ifdef USE_LOCALE_COLLATE +char* sv_collxfrm _((SV* sv, STRLEN* nxp)); +#endif void sv_dec _((SV* sv)); void sv_dump _((SV* sv)); +bool sv_derived_from _((SV* sv, char* name)); I32 sv_eq _((SV* sv1, SV* sv2)); void sv_free _((SV* sv)); void sv_free_arenas _((void)); @@ -464,30 +473,57 @@ void sv_replace _((SV* sv, SV* nsv)); void sv_report_used _((void)); void sv_reset _((char* s, HV* stash)); void sv_setiv _((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)); SV* sv_setref_nv _((SV *rv, char *classname, double nv)); SV* sv_setref_pv _((SV *rv, char *classname, void* pv)); SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n)); -void sv_setpv _((SV* sv, char* ptr)); -void sv_setpvn _((SV* sv, char* ptr, STRLEN len)); +void sv_setpv _((SV* sv, const char* ptr)); +void sv_setpvn _((SV* sv, const char* ptr, STRLEN len)); void sv_setsv _((SV* dsv, SV* ssv)); +void sv_taint _((SV* sv)); +bool sv_tainted _((SV* sv)); int sv_unmagic _((SV* sv, int type)); void sv_unref _((SV* sv)); +void sv_untaint _((SV* sv)); bool sv_upgrade _((SV* sv, U32 mt)); void sv_usepvn _((SV* sv, char* ptr, STRLEN len)); void taint_env _((void)); -void taint_not _((char *s)); -void taint_proper _((char* f, char* s)); +void taint_proper _((const char* f, char* s)); #ifdef UNLINK_ALL_VERSIONS I32 unlnk _((char* f)); #endif +void unsharepvn _((char* sv, I32 len, U32 hash)); +void unshare_hek _((HEK* hek)); void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg)); +void vivify_itervar _((SV* sv)); I32 wait4pid _((int pid, int* statusp, int flags)); -void warn _((char* pat,...)) __attribute__((format(printf,1,2))); +void warn _((const char* pat,...)) __attribute__((format(printf,1,2))); void watch _((char **addr)); I32 whichsig _((char* sig)); int yyerror _((char* s)); int yylex _((void)); int yyparse _((void)); int yywarn _((char* s)); + +#if defined(MYMALLOC) || !defined(STANDARD_C) +Malloc_t malloc _((MEM_SIZE nbytes)); +Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes)); +Free_t free _((Malloc_t where)); +#endif + +#ifndef MYMALLOC +Malloc_t safemalloc _((MEM_SIZE nbytes)); +Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes)); +Free_t safefree _((Malloc_t where)); +#endif + +#ifdef LEAKTEST +Malloc_t safexmalloc _((I32 x, MEM_SIZE size)); +Malloc_t safexcalloc _((I32 x, MEM_SIZE elements, MEM_SIZE size)); +Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size)); +void safexfree _((Malloc_t where)); +#endif diff --git a/qnx/ar b/qnx/ar new file mode 100755 index 0000000000..b46549abd1 --- /dev/null +++ b/qnx/ar @@ -0,0 +1,33 @@ +#! /bin/sh +#__USAGE +#%C key library name ... +# Crude cover for wlib to be compatible with ar +# Supports the following key letters: +# qcru +# ru replace existing modules. u indicates only replace +# those which are newer +# c create the library (kinda moot) +# q quickly append to the end. +# +#This is a crude cover, but it has proved sufficient for many +#ports. Rather than attempt to implement subtleties of the +#ar syntax, I simply create a new library under all +#circumstances. A much more thorough cover is available from +#http://www.fdma.com/pub/qnx/porting/ar +# +#Note that Watcom 10.6 supports ar directly, so this +#cover is not necessary. +# +#Increased the record size to 32 to accomodate a large library +#in the perl 5.003 distribution +# +#Submitted by Norton T. Allen (allen@huarp.harvard.edu) + +if [ $# -lt 3 ]; then + use $0 + exit 1 +fi +shift +library=$1 +shift +wlib -p=32 -n $library `for i in $*; do echo "+$i \\c"; done` diff --git a/qnx/cpp b/qnx/cpp new file mode 100755 index 0000000000..6459af249f --- /dev/null +++ b/qnx/cpp @@ -0,0 +1,24 @@ +#! /bin/sh +#__USAGE +#%C [-P] [-C] other options +# cpp is a wrapper for wcc to make it work like other cpp's +# -P omit #line directives from the output +# -C pass comments through to the output +# +#Submitted by Norton T. Allen (allen@huarp.harvard.edu) + +typeset lines=l comments="" redir="" +while :; do + case $1 in + -P) lines=""; shift; continue;; + -C) comments=c; shift; continue;; + esac + break +done +if [ ! -t 0 ]; then + cat >.$$.c + redir=.$$.c +fi +cc -c -Wc,-p$lines$comments -Wc,-pw=0 $* $redir | + awk 'NR>1||NF>0 {sub("^ ","");print}' +[ -n "$redir" ] && rm -f $redir @@ -107,7 +107,7 @@ static char *regnode _((char)); static char *regpiece _((I32 *)); static void reginsert _((char, char *)); static void regoptail _((char *, char *)); -static void regset _((char *, I32, I32)); +static void regset _((char *, I32)); static void regtail _((char *, char *)); static char* nextchar _((void)); @@ -132,7 +132,6 @@ char* exp; char* xend; PMOP* pm; { - I32 fold = pm->op_pmflags & PMf_FOLD; register regexp *r; register char *scan; register SV *longish; @@ -150,13 +149,14 @@ PMOP* pm; if (exp == NULL) croak("NULL regexp argument"); - /* First pass: determine size, legality. */ + regprecomp = savepvn(exp, xend - exp); regflags = pm->op_pmflags; + regsawback = 0; + + /* First pass: determine size, legality. */ regparse = exp; regxend = xend; - regprecomp = savepvn(exp,xend-exp); regnaughty = 0; - regsawback = 0; regnpar = 1; regsize = 0L; regcode = ®dummy; @@ -171,17 +171,18 @@ PMOP* pm; if (regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); - /* Allocate space. */ + /* Allocate space and initialize. */ Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp); if (r == NULL) FAIL("regexp out of space"); - - /* Second pass: emit code. */ - r->prelen = xend-exp; + r->prelen = xend - exp; r->precomp = regprecomp; r->subbeg = r->subbase = NULL; - regnaughty = 0; + + /* Second pass: emit code. */ regparse = exp; + regxend = xend; + regnaughty = 0; regnpar = 1; regcode = r->program; regc((char)MAGIC); @@ -190,7 +191,6 @@ PMOP* pm; /* Dig out information for optimizations. */ pm->op_pmflags = regflags; - fold = pm->op_pmflags & PMf_FOLD; r->regstart = Nullsv; /* Worst-case defaults. */ r->reganch = 0; r->regmust = Nullsv; @@ -216,16 +216,16 @@ PMOP* pm; /* Starting-point info. */ again: - if (OP(first) == EXACTLY) { + if (OP(first) == EXACT) { r->regstart = newSVpv(OPERAND(first)+1,*OPERAND(first)); - if (SvCUR(r->regstart) > !(sawstudy|fold)) - fbm_compile(r->regstart,fold); - else - sv_upgrade(r->regstart, SVt_PVBM); + if (SvCUR(r->regstart) > !sawstudy) + fbm_compile(r->regstart); + (void)SvUPGRADE(r->regstart, SVt_PVBM); } else if (strchr(simple+2,OP(first))) r->regstclass = first; - else if (OP(first) == BOUND || OP(first) == NBOUND) + else if (regkind[(U8)OP(first)] == BOUND || + regkind[(U8)OP(first)] == NBOUND) r->regstclass = first; else if (regkind[(U8)OP(first)] == BOL) { r->reganch = ROPT_ANCH; @@ -280,7 +280,7 @@ PMOP* pm; scan = regnext(scan); continue; } - if (OP(scan) == EXACTLY) { + if (OP(scan) == EXACT) { char *t; first = scan; @@ -333,8 +333,8 @@ PMOP* pm; /* Prefer earlier on tie, unless we can tail match latter */ - if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL) > - SvCUR(longest)) + if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL) + > SvCUR(longest)) { sv_setsv(longest,longish); backest = backish; @@ -342,23 +342,18 @@ PMOP* pm; else sv_setpvn(longish,"",0); if (SvCUR(longest) - && - (!r->regstart - || - !fbm_instr((unsigned char*) SvPVX(r->regstart), - (unsigned char *) SvPVX(r->regstart) - + SvCUR(r->regstart), - longest) - ) - ) + && (!r->regstart + || !fbm_instr((unsigned char*) SvPVX(r->regstart), + (unsigned char *) (SvPVX(r->regstart) + + SvCUR(r->regstart)), + longest))) { r->regmust = longest; if (backest < 0) backest = -1; r->regback = backest; - if (SvCUR(longest) > !(sawstudy || fold || - regkind[(U8)OP(first)]==EOL)) - fbm_compile(r->regmust,fold); + if (SvCUR(longest) > !(sawstudy || regkind[(U8)OP(first)] == EOL)) + fbm_compile(r->regmust); (void)SvUPGRADE(r->regmust, SVt_PVBM); BmUSEFUL(r->regmust) = 100; if (regkind[(U8)OP(first)] == EOL && SvCUR(longish)) @@ -371,7 +366,6 @@ PMOP* pm; SvREFCNT_dec(longish); } - r->do_folding = fold; r->nparens = regnpar - 1; r->minlen = minlen; Newz(1002, r->startp, regnpar, char*); @@ -773,7 +767,8 @@ tryagain: case '?': case '+': case '*': - FAIL("?+* follows nothing in regexp"); + case '{': + FAIL("?+*{} follows nothing in regexp"); break; case '\\': switch (*++regparse) { @@ -793,32 +788,32 @@ tryagain: nextchar(); break; case 'w': - ret = regnode(ALNUM); + ret = regnode((regflags & PMf_LOCALE) ? ALNUML : ALNUM); *flagp |= HASWIDTH|SIMPLE; nextchar(); break; case 'W': - ret = regnode(NALNUM); + ret = regnode((regflags & PMf_LOCALE) ? NALNUML : NALNUM); *flagp |= HASWIDTH|SIMPLE; nextchar(); break; case 'b': - ret = regnode(BOUND); + ret = regnode((regflags & PMf_LOCALE) ? BOUNDL : BOUND); *flagp |= SIMPLE; nextchar(); break; case 'B': - ret = regnode(NBOUND); + ret = regnode((regflags & PMf_LOCALE) ? NBOUNDL : NBOUND); *flagp |= SIMPLE; nextchar(); break; case 's': - ret = regnode(SPACE); + ret = regnode((regflags & PMf_LOCALE) ? SPACEL : SPACE); *flagp |= HASWIDTH|SIMPLE; nextchar(); break; case 'S': - ret = regnode(NSPACE); + ret = regnode((regflags & PMf_LOCALE) ? NSPACEL : NSPACE); *flagp |= HASWIDTH|SIMPLE; nextchar(); break; @@ -887,7 +882,9 @@ tryagain: regparse++; defchar: - ret = regnode(EXACTLY); + ret = regnode((regflags & PMf_FOLD) + ? ((regflags & PMf_LOCALE) ? EXACTFL : EXACTF) + : EXACT); regc(0); /* save spot for len */ for (len = 0, p = regparse - 1; len < 127 && p < regxend; @@ -948,10 +945,8 @@ tryagain: break; case 'c': p++; - ender = *p++; - if (isLOWER(ender)) - ender = toUPPER(ender); - ender ^= 64; + ender = UCHARAT(p++); + ender = toCTRL(ender); break; case '0': case '1': case '2': case '3':case '4': case '5': case '6': case '7': case '8':case '9': @@ -990,8 +985,6 @@ tryagain: ender = *p++; break; } - if (regflags & PMf_FOLD && isUPPER(ender)) - ender = toLOWER(ender); if (ISMULT2(p)) { /* Back off on ?+*. */ if (len) p = oldp; @@ -1023,24 +1016,20 @@ tryagain: } static void -regset(bits,def,c) -char *bits; -I32 def; +regset(opnd, c) +char *opnd; register I32 c; { - if (regcode == ®dummy) - return; - c &= 255; - if (def) - bits[c >> 3] &= ~(1 << (c & 7)); - else - bits[c >> 3] |= (1 << (c & 7)); + if (opnd == ®dummy) + return; + c &= 0xFF; + opnd[1 + (c >> 3)] |= (1 << (c & 7)); } static char * regclass() { - register char *bits; + register char *opnd; register I32 class; register I32 lastclass = 1234; register I32 range = 0; @@ -1049,16 +1038,21 @@ regclass() I32 numlen; ret = regnode(ANYOF); + opnd = regcode; + for (class = 0; class < 33; class++) + regc(0); if (*regparse == '^') { /* Complement of range. */ regnaughty++; regparse++; - def = 0; - } else { - def = 255; + if (opnd != ®dummy) + *opnd |= ANYOF_INVERT; + } + if (opnd != ®dummy) { + if (regflags & PMf_FOLD) + *opnd |= ANYOF_FOLD; + if (regflags & PMf_LOCALE) + *opnd |= ANYOF_LOCALE; } - bits = regcode; - for (class = 0; class < 32; class++) - regc(def); if (*regparse == ']' || *regparse == '-') goto skipcond; /* allow 1st char to be ] or - */ while (regparse < regxend && *regparse != ']') { @@ -1068,39 +1062,63 @@ regclass() class = UCHARAT(regparse++); switch (class) { case 'w': - for (class = 0; class < 256; class++) - if (isALNUM(class)) - regset(bits,def,class); + if (regflags & PMf_LOCALE) { + if (opnd != ®dummy) + *opnd |= ANYOF_ALNUML; + } + else { + for (class = 0; class < 256; class++) + if (isALNUM(class)) + regset(opnd, class); + } lastclass = 1234; continue; case 'W': - for (class = 0; class < 256; class++) - if (!isALNUM(class)) - regset(bits,def,class); + if (regflags & PMf_LOCALE) { + if (opnd != ®dummy) + *opnd |= ANYOF_NALNUML; + } + else { + for (class = 0; class < 256; class++) + if (!isALNUM(class)) + regset(opnd, class); + } lastclass = 1234; continue; case 's': - for (class = 0; class < 256; class++) - if (isSPACE(class)) - regset(bits,def,class); + if (regflags & PMf_LOCALE) { + if (opnd != ®dummy) + *opnd |= ANYOF_SPACEL; + } + else { + for (class = 0; class < 256; class++) + if (isSPACE(class)) + regset(opnd, class); + } lastclass = 1234; continue; case 'S': - for (class = 0; class < 256; class++) - if (!isSPACE(class)) - regset(bits,def,class); + if (regflags & PMf_LOCALE) { + if (opnd != ®dummy) + *opnd |= ANYOF_NSPACEL; + } + else { + for (class = 0; class < 256; class++) + if (!isSPACE(class)) + regset(opnd, class); + } lastclass = 1234; continue; case 'd': for (class = '0'; class <= '9'; class++) - regset(bits,def,class); + regset(opnd, class); lastclass = 1234; continue; case 'D': for (class = 0; class < '0'; class++) - regset(bits,def,class); + regset(opnd, class); for (class = '9' + 1; class < 256; class++) - regset(bits,def,class); + regset(opnd, class); lastclass = 1234; continue; case 'n': @@ -1129,10 +1147,8 @@ regclass() regparse += numlen; break; case 'c': - class = *regparse++; - if (isLOWER(class)) - class = toUPPER(class); - class ^= 64; + class = UCHARAT(regparse++); + class = toCTRL(class); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': @@ -1155,11 +1171,8 @@ regclass() continue; /* do it next time */ } } - for ( ; lastclass <= class; lastclass++) { - regset(bits,def,lastclass); - if (regflags & PMf_FOLD && isUPPER(lastclass)) - regset(bits,def,toLOWER(lastclass)); - } + for ( ; lastclass <= class; lastclass++) + regset(opnd, lastclass); lastclass = class; } if (*regparse != ']') @@ -1439,7 +1452,7 @@ regdump(r) regexp *r; { register char *s; - register char op = EXACTLY; /* Arbitrary non-END op. */ + register char op = EXACT; /* Arbitrary non-END op. */ register char *next; @@ -1459,9 +1472,9 @@ regexp *r; PerlIO_printf(Perl_debug_log, "(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF) { - s += 32; + s += 33; } - if (op == EXACTLY) { + if (regkind[(U8)op] == EXACT) { /* Literal string, where present. */ s++; (void)PerlIO_putc(Perl_debug_log, ' '); @@ -1536,8 +1549,14 @@ char *op; case BRANCH: p = "BRANCH"; break; - case EXACTLY: - p = "EXACTLY"; + case EXACT: + p = "EXACT"; + break; + case EXACTF: + p = "EXACTF"; + break; + case EXACTFL: + p = "EXACTFL"; break; case NOTHING: p = "NOTHING"; @@ -1548,29 +1567,17 @@ char *op; case END: p = "END"; break; - case ALNUM: - p = "ALNUM"; - break; - case NALNUM: - p = "NALNUM"; - break; case BOUND: p = "BOUND"; break; + case BOUNDL: + p = "BOUNDL"; + break; case NBOUND: p = "NBOUND"; break; - case SPACE: - p = "SPACE"; - break; - case NSPACE: - p = "NSPACE"; - break; - case DIGIT: - p = "DIGIT"; - break; - case NDIGIT: - p = "NDIGIT"; + case NBOUNDL: + p = "NBOUNDL"; break; case CURLY: (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", ARG1(op),ARG2(op)); @@ -1616,6 +1623,36 @@ char *op; case WHILEM: p = "WHILEM"; break; + case DIGIT: + p = "DIGIT"; + break; + case NDIGIT: + p = "NDIGIT"; + break; + case ALNUM: + p = "ALNUM"; + break; + case NALNUM: + p = "NALNUM"; + break; + case SPACE: + p = "SPACE"; + break; + case NSPACE: + p = "NSPACE"; + break; + case ALNUML: + p = "ALNUML"; + break; + case NALNUML: + p = "NALNUML"; + break; + case SPACEL: + p = "SPACEL"; + break; + case NSPACEL: + p = "NSPACEL"; + break; default: FAIL("corrupted regexp opcode"); } @@ -48,41 +48,49 @@ */ /* definition number opnd? meaning */ -#define END 0 /* no End of program. */ -#define BOL 1 /* no Match "" at beginning of line. */ -#define MBOL 2 /* no Same, assuming multiline. */ -#define SBOL 3 /* no Same, assuming singleline. */ -#define EOL 4 /* no Match "" at end of line. */ -#define MEOL 5 /* no Same, assuming multiline. */ -#define SEOL 6 /* no Same, assuming singleline. */ -#define ANY 7 /* no Match any one character (except newline). */ -#define SANY 8 /* no Match any one character. */ -#define ANYOF 9 /* sv Match character in (or not in) this class. */ +#define END 0 /* no End of program. */ +#define BOL 1 /* no Match "" at beginning of line. */ +#define MBOL 2 /* no Same, assuming multiline. */ +#define SBOL 3 /* no Same, assuming singleline. */ +#define EOL 4 /* no Match "" at end of line. */ +#define MEOL 5 /* no Same, assuming multiline. */ +#define SEOL 6 /* no Same, assuming singleline. */ +#define ANY 7 /* no Match any one character (except newline). */ +#define SANY 8 /* no Match any one character. */ +#define ANYOF 9 /* sv Match character in (or not in) this class. */ #define CURLY 10 /* sv Match this simple thing {n,m} times. */ #define CURLYX 11 /* sv Match this complex thing {n,m} times. */ #define BRANCH 12 /* node Match this alternative, or the next... */ #define BACK 13 /* no Match "", "next" ptr points backward. */ -#define EXACTLY 14 /* sv Match this string (preceded by length). */ -#define NOTHING 15 /* no Match empty string. */ -#define STAR 16 /* node Match this (simple) thing 0 or more times. */ -#define PLUS 17 /* node Match this (simple) thing 1 or more times. */ -#define ALNUM 18 /* no Match any alphanumeric character */ -#define NALNUM 19 /* no Match any non-alphanumeric character */ +#define EXACT 14 /* sv Match this string (preceded by length). */ +#define EXACTF 15 /* sv Match this string, folded (prec. by length). */ +#define EXACTFL 16 /* sv Match this string, folded in locale (w/len). */ +#define NOTHING 17 /* no Match empty string. */ +#define STAR 18 /* node Match this (simple) thing 0 or more times. */ +#define PLUS 19 /* node Match this (simple) thing 1 or more times. */ #define BOUND 20 /* no Match "" at any word boundary */ -#define NBOUND 21 /* no Match "" at any word non-boundary */ -#define SPACE 22 /* no Match any whitespace character */ -#define NSPACE 23 /* no Match any non-whitespace character */ -#define DIGIT 24 /* no Match any numeric character */ -#define NDIGIT 25 /* no Match any non-numeric character */ -#define REF 26 /* num Match some already matched string */ -#define OPEN 27 /* num Mark this point in input as start of #n. */ -#define CLOSE 28 /* num Analogous to OPEN. */ -#define MINMOD 29 /* no Next operator is not greedy. */ -#define GBOL 30 /* no Matches where last m//g left off. */ -#define IFMATCH 31 /* no Succeeds if the following matches. */ -#define UNLESSM 32 /* no Fails if the following matches. */ -#define SUCCEED 33 /* no Return from a subroutine, basically. */ -#define WHILEM 34 /* no Do curly processing and see if rest matches. */ +#define BOUNDL 21 /* no Match "" at any word boundary */ +#define NBOUND 22 /* no Match "" at any word non-boundary */ +#define NBOUNDL 23 /* no Match "" at any word non-boundary */ +#define REF 24 /* num Match some already matched string */ +#define OPEN 25 /* num Mark this point in input as start of #n. */ +#define CLOSE 26 /* num Analogous to OPEN. */ +#define MINMOD 27 /* no Next operator is not greedy. */ +#define GBOL 28 /* no Matches where last m//g left off. */ +#define IFMATCH 29 /* no Succeeds if the following matches. */ +#define UNLESSM 30 /* no Fails if the following matches. */ +#define SUCCEED 31 /* no Return from a subroutine, basically. */ +#define WHILEM 32 /* no Do curly processing and see if rest matches. */ +#define ALNUM 33 /* no Match any alphanumeric character */ +#define ALNUML 34 /* no Match any alphanumeric char in locale */ +#define NALNUM 35 /* no Match any non-alphanumeric character */ +#define NALNUML 36 /* no Match any non-alphanumeric char in locale */ +#define SPACE 37 /* no Match any whitespace character */ +#define SPACEL 38 /* no Match any whitespace char in locale */ +#define NSPACE 39 /* no Match any non-whitespace character */ +#define NSPACEL 40 /* no Match any non-whitespace char in locale */ +#define DIGIT 41 /* no Match any numeric character */ +#define NDIGIT 42 /* no Match any non-numeric character */ /* * Opcode notes: @@ -109,7 +117,13 @@ #ifndef DOINIT EXT char regarglen[]; #else -EXT char regarglen[] = {0,0,0,0,0,0,0,0,0,0,4,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2,0,0,0,0,0}; +EXT char regarglen[] = { + 0,0,0,0,0,0,0,0,0,0, + /*CURLY*/ 4, /*CURLYX*/ 4, + 0,0,0,0,0,0,0,0,0,0,0,0, + /*REF*/ 2, /*OPEN*/ 2, /*CLOSE*/ 2, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +}; #endif #ifndef DOINIT @@ -130,18 +144,16 @@ EXT char regkind[] = { CURLY, BRANCH, BACK, - EXACTLY, + EXACT, + EXACT, + EXACT, NOTHING, STAR, PLUS, - ALNUM, - NALNUM, + BOUND, BOUND, NBOUND, - SPACE, - NSPACE, - DIGIT, - NDIGIT, + NBOUND, REF, OPEN, CLOSE, @@ -150,7 +162,17 @@ EXT char regkind[] = { BRANCH, BRANCH, END, - WHILEM + WHILEM, + ALNUM, + ALNUM, + NALNUM, + NALNUM, + SPACE, + SPACE, + NSPACE, + NSPACE, + DIGIT, + NDIGIT, }; #endif @@ -158,14 +180,21 @@ EXT char regkind[] = { #ifndef DOINIT EXT char varies[]; #else -EXT char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,CURLYX,REF,WHILEM,0}; +EXT char varies[] = { + BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, WHILEM, 0 +}; #endif /* The following always have a length of 1. */ #ifndef DOINIT EXT char simple[]; #else -EXT char simple[] = {ANY,SANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0}; +EXT char simple[] = { + ANY, SANY, ANYOF, + ALNUM, ALNUML, NALNUM, NALNUML, + SPACE, SPACEL, NSPACE, NSPACEL, + DIGIT, NDIGIT, 0 +}; #endif EXT char regdummy; @@ -222,6 +251,16 @@ EXT char regdummy; #define MAGIC 0234 +/* Flags for first parameter byte of ANYOF */ +#define ANYOF_INVERT 0x40 +#define ANYOF_FOLD 0x20 +#define ANYOF_LOCALE 0x10 +#define ANYOF_ISA 0x0F +#define ANYOF_ALNUML 0x08 +#define ANYOF_NALNUML 0x04 +#define ANYOF_SPACEL 0x02 +#define ANYOF_NSPACEL 0x01 + /* * Utility definitions. */ @@ -82,10 +82,10 @@ static CURCUR* regcc; typedef I32 CHECKPOINT; -CHECKPOINT regcppush _((I32 parenfloor)); -char * regcppop _((void)); +static CHECKPOINT regcppush _((I32 parenfloor)); +static char * regcppop _((void)); -CHECKPOINT +static CHECKPOINT regcppush(parenfloor) I32 parenfloor; { @@ -107,7 +107,7 @@ I32 parenfloor; return retval; } -char* +static char * regcppop() { I32 i = SSPOPINT; @@ -147,6 +147,9 @@ regcppop() static I32 regmatch _((char *prog)); static I32 regrepeat _((char *p, I32 max)); static I32 regtry _((regexp *prog, char *startpos)); +static bool reginclass _((char *p, I32 c)); + +static bool regtainted; /* tainted information used? */ /* - pregexec - match a regexp against a string @@ -162,7 +165,6 @@ SV *screamer; I32 safebase; /* no need to remember string in subbase */ { register char *s; - register I32 i; register char *c; register char *startpos = stringarg; register I32 tmp; @@ -192,23 +194,15 @@ I32 safebase; /* no need to remember string in subbase */ if (!multiline && regprev == '\n') regprev = '\0'; /* force ^ to NOT match */ } + regprecomp = prog->precomp; - regnpar = prog->nparens; /* Check validity of program. */ if (UCHARAT(prog->program) != MAGIC) { FAIL("corrupted regexp program"); } - if (prog->do_folding) { - i = strend - startpos; - New(1101,c,i+1,char); - Copy(startpos, c, i+1, char); - startpos = c; - strend = startpos + i; - for (s = startpos; s < strend; s++) - if (isUPPER(*s)) - *s = toLOWER(*s); - } + regnpar = prog->nparens; + regtainted = FALSE; /* If there is a "must appear" string, look for it. */ s = startpos; @@ -281,13 +275,13 @@ I32 safebase; /* no need to remember string in subbase */ if (prog->regstart) { if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */ /* it must be a one character string */ - i = SvPVX(prog->regstart)[0]; + char ch = SvPVX(prog->regstart)[0]; while (s < strend) { - if (*s == i) { + if (*s == ch) { if (regtry(prog, s)) goto got_it; s++; - while (s < strend && *s == i) + while (s < strend && *s == ch) s++; } s++; @@ -327,8 +321,7 @@ I32 safebase; /* no need to remember string in subbase */ case ANYOF: c = OPERAND(c); while (s < strend) { - i = UCHARAT(s); - if (!(c[i >> 3] & (1 << (i&7)))) { + if (reginclass(c, *s)) { if (tmp && regtry(prog, s)) goto got_it; else @@ -339,18 +332,16 @@ I32 safebase; /* no need to remember string in subbase */ s++; } break; + case BOUNDL: + regtainted = TRUE; + /* FALL THROUGH */ case BOUND: if (minlen) dontbother++,strend--; - if (s != startpos) { - i = s[-1]; - tmp = isALNUM(i); - } - else - tmp = isALNUM(regprev); /* assume not alphanumeric */ + tmp = (s != startpos) ? UCHARAT(s - 1) : regprev; + tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); while (s < strend) { - i = *s; - if (tmp != isALNUM(i)) { + if (tmp == !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) { tmp = !tmp; if (regtry(prog, s)) goto got_it; @@ -360,18 +351,16 @@ I32 safebase; /* no need to remember string in subbase */ if ((minlen || tmp) && regtry(prog,s)) goto got_it; break; + case NBOUNDL: + regtainted = TRUE; + /* FALL THROUGH */ case NBOUND: if (minlen) dontbother++,strend--; - if (s != startpos) { - i = s[-1]; - tmp = isALNUM(i); - } - else - tmp = isALNUM(regprev); /* assume not alphanumeric */ + tmp = (s != startpos) ? UCHARAT(s - 1) : regprev; + tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); while (s < strend) { - i = *s; - if (tmp != isALNUM(i)) + if (tmp == !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s))) tmp = !tmp; else if (regtry(prog, s)) goto got_it; @@ -382,8 +371,21 @@ I32 safebase; /* no need to remember string in subbase */ break; case ALNUM: while (s < strend) { - i = *s; - if (isALNUM(i)) { + if (isALNUM(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case ALNUML: + regtainted = TRUE; + while (s < strend) { + if (isALNUM_LC(*s)) { if (tmp && regtry(prog, s)) goto got_it; else @@ -396,8 +398,21 @@ I32 safebase; /* no need to remember string in subbase */ break; case NALNUM: while (s < strend) { - i = *s; - if (!isALNUM(i)) { + if (!isALNUM(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case NALNUML: + regtainted = TRUE; + while (s < strend) { + if (!isALNUM_LC(*s)) { if (tmp && regtry(prog, s)) goto got_it; else @@ -421,6 +436,20 @@ I32 safebase; /* no need to remember string in subbase */ s++; } break; + case SPACEL: + regtainted = TRUE; + while (s < strend) { + if (isSPACE_LC(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; case NSPACE: while (s < strend) { if (!isSPACE(*s)) { @@ -434,6 +463,20 @@ I32 safebase; /* no need to remember string in subbase */ s++; } break; + case NSPACEL: + regtainted = TRUE; + while (s < strend) { + if (!isSPACE_LC(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; case DIGIT: while (s < strend) { if (isDIGIT(*s)) { @@ -480,38 +523,27 @@ got_it: strend += dontbother; /* uncheat */ prog->subbeg = strbeg; prog->subend = strend; - if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding) { - i = strend - startpos + (stringarg - strbeg); - if (safebase) { /* no need for $digit later */ - s = strbeg; - prog->subend = s+i; - } - else if (strbeg != prog->subbase) { - s = savepvn(strbeg,i); /* so $digit will work later */ - if (prog->subbase) - Safefree(prog->subbase); - prog->subbeg = prog->subbase = s; - prog->subend = s+i; - } - else { - prog->subbeg = s = prog->subbase; - prog->subend = s+i; - } - s += (stringarg - strbeg); + prog->exec_tainted = regtainted; + + /* make sure $`, $&, $', and $digit will work later */ + if (!safebase && (strbeg != prog->subbase)) { + I32 i = strend - startpos + (stringarg - strbeg); + s = savepvn(strbeg, i); + Safefree(prog->subbase); + prog->subbase = s; + prog->subbeg = prog->subbase; + prog->subend = prog->subbase + i; + s = prog->subbase + (stringarg - strbeg); for (i = 0; i <= prog->nparens; i++) { if (prog->endp[i]) { prog->startp[i] = s + (prog->startp[i] - startpos); prog->endp[i] = s + (prog->endp[i] - startpos); } } - if (prog->do_folding) - Safefree(startpos); } return 1; phooey: - if (prog->do_folding) - Safefree(startpos); return 0; } @@ -576,13 +608,14 @@ char *prog; register I32 ln; /* len or last */ register char *s; /* operand or save */ register char *locinput = reginput; + register I32 c1, c2; /* case fold search */ int minmod = 0; #ifdef DEBUGGING static int regindent = 0; regindent++; #endif - nextchar = *locinput; + nextchar = UCHARAT(locinput); scan = prog; while (scan != NULL) { #ifdef DEBUGGING @@ -653,85 +686,130 @@ char *prog; case SANY: if (!nextchar && locinput >= regeol) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; case ANY: if (!nextchar && locinput >= regeol || nextchar == '\n') sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); + break; + case EXACT: + s = OPERAND(scan); + ln = *s++; + /* Inline the first character, for speed. */ + if (UCHARAT(s) != nextchar) + sayNO; + if (regeol - locinput < ln) + sayNO; + if (ln > 1 && memNE(s, locinput, ln)) + sayNO; + locinput += ln; + nextchar = UCHARAT(locinput); break; - case EXACTLY: + case EXACTFL: + regtainted = TRUE; + /* FALL THROUGH */ + case EXACTF: s = OPERAND(scan); ln = *s++; /* Inline the first character, for speed. */ - if (*s != nextchar) + if (UCHARAT(s) != nextchar && + UCHARAT(s) != ((OP(scan) == EXACTF) + ? fold : fold_locale)[nextchar]) sayNO; if (regeol - locinput < ln) sayNO; - if (ln > 1 && memcmp(s, locinput, ln) != 0) + if (ln > 1 && (OP(scan) == EXACTF + ? ibcmp(s, locinput, ln) + : ibcmp_locale(s, locinput, ln))) sayNO; locinput += ln; - nextchar = *locinput; + nextchar = UCHARAT(locinput); break; case ANYOF: s = OPERAND(scan); if (nextchar < 0) nextchar = UCHARAT(locinput); - if (s[nextchar >> 3] & (1 << (nextchar&7))) + if (!reginclass(s, nextchar)) sayNO; if (!nextchar && locinput >= regeol) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; + case ALNUML: + regtainted = TRUE; + /* FALL THROUGH */ case ALNUM: if (!nextchar) sayNO; - if (!isALNUM(nextchar)) + if (!(OP(scan) == ALNUM + ? isALNUM(nextchar) : isALNUM_LC(nextchar))) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; + case NALNUML: + regtainted = TRUE; + /* FALL THROUGH */ case NALNUM: if (!nextchar && locinput >= regeol) sayNO; - if (isALNUM(nextchar)) + if (OP(scan) == NALNUM + ? isALNUM(nextchar) : isALNUM_LC(nextchar)) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; - case NBOUND: + case BOUNDL: + case NBOUNDL: + regtainted = TRUE; + /* FALL THROUGH */ case BOUND: - if (locinput == regbol) /* was last char in word? */ - ln = isALNUM(regprev); - else - ln = isALNUM(locinput[-1]); - n = isALNUM(nextchar); /* is next char in word? */ - if ((ln == n) == (OP(scan) == BOUND)) + case NBOUND: + /* was last char in word? */ + ln = (locinput != regbol) ? UCHARAT(locinput - 1) : regprev; + if (OP(scan) == BOUND || OP(scan) == NBOUND) { + ln = isALNUM(ln); + n = isALNUM(nextchar); + } + else { + ln = isALNUM_LC(ln); + n = isALNUM_LC(nextchar); + } + if (((!ln) == (!n)) == (OP(scan) == BOUND || OP(scan) == BOUNDL)) sayNO; break; + case SPACEL: + regtainted = TRUE; + /* FALL THROUGH */ case SPACE: if (!nextchar && locinput >= regeol) sayNO; - if (!isSPACE(nextchar)) + if (!(OP(scan) == SPACE + ? isSPACE(nextchar) : isSPACE_LC(nextchar))) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; + case NSPACEL: + regtainted = TRUE; + /* FALL THROUGH */ case NSPACE: if (!nextchar) sayNO; - if (isSPACE(nextchar)) + if (OP(scan) == SPACE + ? isSPACE(nextchar) : isSPACE_LC(nextchar)) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; case DIGIT: if (!isDIGIT(nextchar)) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; case NDIGIT: if (!nextchar && locinput >= regeol) sayNO; if (isDIGIT(nextchar)) sayNO; - nextchar = *++locinput; + nextchar = UCHARAT(++locinput); break; case REF: n = ARG1(scan); /* which paren pair */ @@ -743,15 +821,15 @@ char *prog; if (s == regendp[n]) break; /* Inline the first character, for speed. */ - if (*s != nextchar) + if (UCHARAT(s) != nextchar) sayNO; ln = regendp[n] - s; if (locinput + ln > regeol) sayNO; - if (ln > 1 && memcmp(s, locinput, ln) != 0) + if (ln > 1 && memNE(s, locinput, ln)) sayNO; locinput += ln; - nextchar = *locinput; + nextchar = UCHARAT(locinput); break; case NOTHING: @@ -800,6 +878,7 @@ char *prog; * that we can try again after backing off. */ + CHECKPOINT cp; CURCUR* cc = regcc; n = cc->cur + 1; /* how many we know we matched */ reginput = locinput; @@ -812,7 +891,7 @@ char *prog; /* If degenerate scan matches "", assume scan done. */ - if (locinput == cc->lastloc) { + if (locinput == cc->lastloc && n >= cc->min) { regcc = cc->oldcc; ln = regcc->cur; if (regmatch(cc->next)) @@ -838,8 +917,12 @@ char *prog; if (cc->minmod) { regcc = cc->oldcc; ln = regcc->cur; - if (regmatch(cc->next)) + cp = regcppush(cc->parenfloor); + if (regmatch(cc->next)) { + regcpblow(cp); sayYES; /* All done. */ + } + regcppop(); regcc->cur = ln; regcc = cc; @@ -850,8 +933,12 @@ char *prog; reginput = locinput; cc->cur = n; cc->lastloc = locinput; - if (regmatch(cc->scan)) + cp = regcppush(cc->parenfloor); + if (regmatch(cc->scan)) { + regcpblow(cp); sayYES; + } + regcppop(); cc->cur = n - 1; sayNO; } @@ -859,11 +946,13 @@ char *prog; /* Prefer scan over next for maximal matching. */ if (n < cc->max) { /* More greed allowed? */ - regcppush(cc->parenfloor); + cp = regcppush(cc->parenfloor); cc->cur = n; cc->lastloc = locinput; - if (regmatch(cc->scan)) + if (regmatch(cc->scan)) { + regcpblow(cp); sayYES; + } regcppop(); /* Restore some previous $<digit>s? */ reginput = locinput; } @@ -929,10 +1018,17 @@ char *prog; n = 32767; scan = NEXTOPER(scan); repeat: - if (OP(next) == EXACTLY) - nextchar = *(OPERAND(next)+1); + if (regkind[(U8)OP(next)] == EXACT) { + c1 = UCHARAT(OPERAND(next) + 1); + if (OP(next) == EXACTF) + c2 = fold[c1]; + else if (OP(next) == EXACTFL) + c2 = fold_locale[c1]; + else + c2 = c1; + } else - nextchar = -1000; + c1 = c2 = -1000; reginput = locinput; if (minmod) { minmod = 0; @@ -940,9 +1036,13 @@ char *prog; sayNO; while (n >= ln || (n == 32767 && ln > 0)) { /* ln overflow ? */ /* If it could work, try it. */ - if (nextchar == -1000 || *reginput == nextchar) + if (c1 == -1000 || + UCHARAT(reginput) == c1 || + UCHARAT(reginput) == c2) + { if (regmatch(next)) sayYES; + } /* Couldn't or didn't -- back up. */ reginput = locinput + ln; if (regrepeat(scan, 1)) { @@ -960,9 +1060,13 @@ char *prog; ln = n; /* why back off? */ while (n >= ln) { /* If it could work, try it. */ - if (nextchar == -1000 || *reginput == nextchar) + if (c1 == -1000 || + UCHARAT(reginput) == c1 || + UCHARAT(reginput) == c2) + { if (regmatch(next)) sayYES; + } /* Couldn't or didn't -- back up. */ n--; reginput = locinput + n; @@ -1043,34 +1147,64 @@ I32 max; case SANY: scan = loceol; break; - case EXACTLY: /* length of string is 1 */ - opnd++; - while (scan < loceol && *opnd == *scan) + case EXACT: /* length of string is 1 */ + c = UCHARAT(++opnd); + while (scan < loceol && UCHARAT(scan) == c) + scan++; + break; + case EXACTF: /* length of string is 1 */ + c = UCHARAT(++opnd); + while (scan < loceol && + (UCHARAT(scan) == c || UCHARAT(scan) == fold[c])) + scan++; + break; + case EXACTFL: /* length of string is 1 */ + regtainted = TRUE; + c = UCHARAT(++opnd); + while (scan < loceol && + (UCHARAT(scan) == c || UCHARAT(scan) == fold_locale[c])) scan++; break; case ANYOF: - c = UCHARAT(scan); - while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) { + while (scan < loceol && reginclass(opnd, *scan)) scan++; - c = UCHARAT(scan); - } break; case ALNUM: while (scan < loceol && isALNUM(*scan)) scan++; break; + case ALNUML: + regtainted = TRUE; + while (scan < loceol && isALNUM_LC(*scan)) + scan++; + break; case NALNUM: while (scan < loceol && !isALNUM(*scan)) scan++; break; + case NALNUML: + regtainted = TRUE; + while (scan < loceol && !isALNUM_LC(*scan)) + scan++; + break; case SPACE: while (scan < loceol && isSPACE(*scan)) scan++; break; + case SPACEL: + regtainted = TRUE; + while (scan < loceol && isSPACE_LC(*scan)) + scan++; + break; case NSPACE: while (scan < loceol && !isSPACE(*scan)) scan++; break; + case NSPACEL: + regtainted = TRUE; + while (scan < loceol && !isSPACE_LC(*scan)) + scan++; + break; case DIGIT: while (scan < loceol && isDIGIT(*scan)) scan++; @@ -1090,6 +1224,48 @@ I32 max; } /* + - regclass - determine if a character falls into a character class + */ + +static bool +reginclass(p, c) +register char *p; +register I32 c; +{ + char flags = *p; + bool match = FALSE; + + c &= 0xFF; + if (p[1 + (c >> 3)] & (1 << (c & 7))) + match = TRUE; + else if (flags & ANYOF_FOLD) { + I32 cf; + if (flags & ANYOF_LOCALE) { + regtainted = TRUE; + cf = fold_locale[c]; + } + else + cf = fold[c]; + if (p[1 + (cf >> 3)] & (1 << (cf & 7))) + match = TRUE; + } + + if (!match && (flags & ANYOF_ISA)) { + regtainted = TRUE; + + if (((flags & ANYOF_ALNUML) && isALNUM_LC(c)) || + ((flags & ANYOF_NALNUML) && !isALNUM_LC(c)) || + ((flags & ANYOF_SPACEL) && isSPACE_LC(c)) || + ((flags & ANYOF_NSPACEL) && !isSPACE_LC(c))) + { + match = TRUE; + } + } + + return match ^ ((flags & ANYOF_INVERT) != 0); +} + +/* - regnext - dig the "next" pointer out of a node * * [Note, when REGALIGN is defined there are two places in regmatch() @@ -26,7 +26,7 @@ typedef struct regexp { char *subend; /* end of subbase */ U16 naughty; /* how exponential is this pattern? */ char reganch; /* Internal use only. */ - char do_folding; /* do case-insensitive match? */ + char exec_tainted; /* Tainted information used by regexec? */ char program[1]; /* Unwarranted chumminess with compiler. */ } regexp; @@ -107,19 +107,14 @@ free_tmps() } } -SV * -save_scalar(gv) -GV *gv; +static SV * +save_scalar_at(sptr) +SV **sptr; { register SV *sv; - SV *osv = GvSV(gv); - - SSCHECK(3); - SSPUSHPTR(gv); - SSPUSHPTR(osv); - SSPUSHINT(SAVEt_SV); + SV *osv = *sptr; - sv = GvSV(gv) = NEWSV(0,0); + sv = *sptr = NEWSV(0,0); if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { sv_upgrade(sv, SvTYPE(osv)); if (SvGMAGICAL(osv)) { @@ -143,62 +138,50 @@ GV *gv; return sv; } -#ifdef INLINED_ELSEWHERE -void -save_gp(gv) +SV * +save_scalar(gv) GV *gv; { - register GP *gp; - GP *ogp = GvGP(gv); - SSCHECK(3); - SSPUSHPTR(SvREFCNT_inc(gv)); - SSPUSHPTR(ogp); - SSPUSHINT(SAVEt_GP); - - Newz(602,gp, 1, GP); - GvGP(gv) = gp; - GvREFCNT(gv) = 1; - GvSV(gv) = NEWSV(72,0); - GvLINE(gv) = curcop->cop_line; - GvEGV(gv) = gv; + SSPUSHPTR(gv); + SSPUSHPTR(GvSV(gv)); + SSPUSHINT(SAVEt_SV); + return save_scalar_at(&GvSV(gv)); } -#endif SV* save_svref(sptr) SV **sptr; { - register SV *sv; - SV *osv = *sptr; - SSCHECK(3); - SSPUSHPTR(*sptr); SSPUSHPTR(sptr); + SSPUSHPTR(*sptr); SSPUSHINT(SAVEt_SVREF); + return save_scalar_at(sptr); +} - sv = *sptr = NEWSV(0,0); - if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { - sv_upgrade(sv, SvTYPE(osv)); - if (SvGMAGICAL(osv)) { - MAGIC* mg; - bool oldtainted = tainted; - mg_get(osv); - if (tainting && tainted && (mg = mg_find(osv, 't'))) { - SAVESPTR(mg->mg_obj); - mg->mg_obj = osv; - } - SvFLAGS(osv) |= (SvFLAGS(osv) & - (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - tainted = oldtainted; - } - SvMAGIC(sv) = SvMAGIC(osv); - SvFLAGS(sv) |= SvMAGICAL(osv); - localizing = 1; - SvSETMAGIC(sv); - localizing = 0; +void +save_gp(gv, empty) +GV *gv; +I32 empty; +{ + SSCHECK(3); + SSPUSHPTR(SvREFCNT_inc(gv)); + SSPUSHPTR(GvGP(gv)); + SSPUSHINT(SAVEt_GP); + + if (empty) { + register GP *gp; + Newz(602, gp, 1, GP); + GvGP(gv) = gp_ref(gp); + GvSV(gv) = NEWSV(72,0); + GvLINE(gv) = curcop->cop_line; + GvEGV(gv) = gv; + } + else { + gp_ref(GvGP(gv)); + GvINTRO_on(gv); } - return sv; } AV * @@ -272,6 +255,16 @@ I32 *intp; } void +save_I16(intp) +I16 *intp; +{ + SSCHECK(3); + SSPUSHINT(*intp); + SSPUSHPTR(intp); + SSPUSHINT(SAVEt_I16); +} + +void save_iv(ivp) IV *ivp; { @@ -437,26 +430,13 @@ I32 base; case SAVEt_SV: /* scalar reference */ value = (SV*)SSPOPPTR; gv = (GV*)SSPOPPTR; - sv = GvSV(gv); - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) && - SvTYPE(sv) != SVt_PVGV) - { - (void)SvUPGRADE(value, SvTYPE(sv)); - SvMAGIC(value) = SvMAGIC(sv); - SvFLAGS(value) |= SvMAGICAL(sv); - SvMAGICAL_off(sv); - SvMAGIC(sv) = 0; - } - SvREFCNT_dec(sv); - GvSV(gv) = value; - localizing = 2; - SvSETMAGIC(value); - localizing = 0; - break; + ptr = &GvSV(gv); + goto restore_sv; case SAVEt_SVREF: /* scalar reference */ + value = (SV*)SSPOPPTR; ptr = SSPOPPTR; + restore_sv: sv = *(SV**)ptr; - value = (SV*)SSPOPPTR; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) && SvTYPE(sv) != SVt_PVGV) { @@ -466,6 +446,14 @@ I32 base; SvMAGICAL_off(sv); SvMAGIC(sv) = 0; } + else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) && + SvTYPE(value) != SVt_PVGV) + { + SvFLAGS(value) |= (SvFLAGS(value) & + (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + SvMAGICAL_off(value); + SvMAGIC(value) = 0; + } SvREFCNT_dec(sv); *(SV**)ptr = value; localizing = 2; @@ -496,6 +484,10 @@ I32 base; ptr = SSPOPPTR; *(I32*)ptr = (I32)SSPOPINT; break; + case SAVEt_I16: /* I16 reference */ + ptr = SSPOPPTR; + *(I16*)ptr = (I16)SSPOPINT; + break; case SAVEt_IV: /* IV reference */ ptr = SSPOPPTR; *(IV*)ptr = (IV)SSPOPIV; @@ -563,13 +555,15 @@ I32 base; hv_clear((HV*)sv); break; case SVt_PVCV: - sub_generation++; - cv_undef((CV*)sv); + croak("panic: leave_scope pad code"); + case SVt_RV: + case SVt_IV: + case SVt_NV: + (void)SvOK_off(sv); break; default: - if (SvPOK(sv) && SvLEN(sv)) - (void)SvOOK_off(sv); (void)SvOK_off(sv); + (void)SvOOK_off(sv); break; } } @@ -601,6 +595,12 @@ I32 base; savestack_ix -= delta; /* regexp must have croaked */ } break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + { + I32 delta = SSPOPINT; + stack_sp = stack_base + delta; + } + break; default: croak("panic: leave_scope inconsistency"); } @@ -671,6 +671,8 @@ CONTEXT* cx; if (cx->blk_loop.itervar) PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n", (long)cx->blk_loop.itersave); + PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n", + (long)cx->blk_loop.iterlval); break; case CXt_SUBST: @@ -20,6 +20,8 @@ #define SAVEt_DELETE 19 #define SAVEt_DESTRUCTOR 20 #define SAVEt_REGCONTEXT 21 +#define SAVEt_STACK_POS 22 +#define SAVEt_I16 23 #define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow() #define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i)) @@ -43,16 +45,28 @@ #define LEAVE pop_scope() #define LEAVE_SCOPE(old) if (savestack_ix > old) leave_scope(old) -#define SAVEINT(i) save_int((int*)(&i)); -#define SAVEIV(i) save_iv((IV*)(&i)); -#define SAVEI32(i) save_I32((I32*)(&i)); -#define SAVELONG(l) save_long((long*)(&l)); -#define SAVESPTR(s) save_sptr((SV**)(&s)) -#define SAVEPPTR(s) save_pptr((char**)(&s)) -#define SAVEFREESV(s) save_freesv((SV*)(s)) -#define SAVEFREEOP(o) save_freeop((OP*)(o)) -#define SAVEFREEPV(p) save_freepv((char*)(p)) -#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv)) -#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l) -#define SAVEDESTRUCTOR(f,p) save_destructor((void(*)_((void*)))f,(void*)p) +/* + * Not using SOFT_CAST on SAVEFREESV and SAVEFREESV + * because these are used for several kinds of pointer values + */ +#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)); +#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i)); +#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i)); +#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i)); +#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l)); +#define SAVESPTR(s) save_sptr((SV**)&(s)) +#define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s)) +#define SAVEFREESV(s) save_freesv((SV*)(s)) +#define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) +#define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) +#define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv)) +#define SAVEDELETE(h,k,l) \ + save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l)) +#define SAVEDESTRUCTOR(f,p) \ + save_destructor(SOFT_CAST(void(*)_((void*)))(f),SOFT_CAST(void*)(p)) +#define SAVESTACK_POS() STMT_START { \ + SSCHECK(2); \ + SSPUSHINT(stack_sp - stack_base); \ + SSPUSHINT(SAVEt_STACK_POS); \ + } STMT_END @@ -40,6 +40,8 @@ # define FAST_SV_GETS #endif +static IV asIV _((SV* sv)); +static UV asUV _((SV* sv)); static SV *more_sv _((void)); static XPVIV *more_xiv _((void)); static XPVNV *more_xnv _((void)); @@ -328,13 +330,17 @@ SV* sv; } #endif +static bool in_clean_objs = FALSE; + void sv_clean_objs() { + in_clean_objs = TRUE; #ifndef DISABLE_DESTRUCTOR_KLUDGE visit(do_clean_named_objs); #endif visit(do_clean_objs); + in_clean_objs = FALSE; } static void @@ -346,14 +352,14 @@ SV* sv; SvREFCNT_dec(sv); } -static int in_clean_all = 0; +static bool in_clean_all = FALSE; void sv_clean_all() { - in_clean_all = 1; + in_clean_all = TRUE; visit(do_clean_all); - in_clean_all = 0; + in_clean_all = FALSE; } void @@ -373,6 +379,9 @@ sv_free_arenas() if (!SvFAKE(sva)) Safefree((void *)sva); } + + sv_arenaroot = 0; + sv_root = 0; } static XPVIV* @@ -1000,8 +1009,10 @@ register SV *sv; else sprintf(t,"(\"%.127s\")",SvPVX(sv)); } - else if (SvNOKp(sv)) + else if (SvNOKp(sv)) { + SET_NUMERIC_STANDARD(); sprintf(t,"(%g)",SvNVX(sv)); + } else if (SvIOKp(sv)) sprintf(t,"(%ld)",(long)SvIVX(sv)); else @@ -1045,12 +1056,12 @@ unsigned long newlen; { register char *s; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ if (SvROK(sv)) sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { @@ -1119,6 +1130,17 @@ IV i; } void +sv_setuv(sv,u) +register SV *sv; +UV u; +{ + if (u <= IV_MAX) + sv_setiv(sv, u); + else + sv_setnv(sv, (double)u); +} + +void sv_setnv(sv,num) register SV *sv; double num; @@ -1176,17 +1198,33 @@ SV *sv; int i; for (s = SvPVX(sv), i = 50; *s && i; s++,i--) { - int ch = *s; - if (ch & 128 && !isprint(ch)) { + int ch = *s & 0xFF; + if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; *d++ = '-'; ch &= 127; } - if (isprint(ch)) + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (isPRINT_LC(ch)) *d++ = ch; else { *d++ = '^'; - *d++ = ch ^ 64; + *d++ = toCTRL(ch); } } if (*s) { @@ -1219,14 +1257,10 @@ register SV *sv; else return (IV) U_V(SvNVX(sv)); } - if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !looks_like_number(sv)) - not_a_number(sv); - return (IV)atol(SvPVX(sv)); - } - if (!SvROK(sv)) { - return 0; - } + if (SvPOKp(sv) && SvLEN(sv)) + return asIV(sv); + if (!SvROK(sv)) + return 0; } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { @@ -1244,11 +1278,8 @@ register SV *sv; else return (IV) U_V(SvNVX(sv)); } - if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !looks_like_number(sv)) - not_a_number(sv); - return (IV)atol(SvPVX(sv)); - } + if (SvPOKp(sv) && SvLEN(sv)) + return asIV(sv); if (dowarn) warn(warn_uninit); return 0; @@ -1257,7 +1288,7 @@ register SV *sv; switch (SvTYPE(sv)) { case SVt_NULL: sv_upgrade(sv, SVt_IV); - return SvIVX(sv); + break; case SVt_PV: sv_upgrade(sv, SVt_PVIV); break; @@ -1270,25 +1301,88 @@ register SV *sv; if (SvNVX(sv) < 0.0) SvIVX(sv) = I_V(SvNVX(sv)); else - SvIVX(sv) = (IV) U_V(SvNVX(sv)); + SvUVX(sv) = U_V(SvNVX(sv)); } else if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !looks_like_number(sv)) - not_a_number(sv); (void)SvIOK_on(sv); - SvIVX(sv) = (IV)atol(SvPVX(sv)); + SvIVX(sv) = asIV(sv); } else { if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; } - (void)SvIOK_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } +UV +sv_2uv(sv) +register SV *sv; +{ + if (!sv) + return 0; + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvIOKp(sv)) + return SvUVX(sv); + if (SvNOKp(sv)) + return U_V(SvNVX(sv)); + if (SvPOKp(sv) && SvLEN(sv)) + return asUV(sv); + if (!SvROK(sv)) + return 0; + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { +#ifdef OVERLOAD + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + return SvUV(tmpstr); +#endif /* OVERLOAD */ + return (UV)SvRV(sv); + } + if (SvREADONLY(sv)) { + if (SvNOKp(sv)) { + return U_V(SvNVX(sv)); + } + if (SvPOKp(sv) && SvLEN(sv)) + return asUV(sv); + if (dowarn) + warn(warn_uninit); + return 0; + } + } + switch (SvTYPE(sv)) { + case SVt_NULL: + sv_upgrade(sv, SVt_IV); + break; + case SVt_PV: + sv_upgrade(sv, SVt_PVIV); + break; + case SVt_NV: + sv_upgrade(sv, SVt_PVNV); + break; + } + if (SvNOKp(sv)) { + (void)SvIOK_on(sv); + SvUVX(sv) = U_V(SvNVX(sv)); + } + else if (SvPOKp(sv) && SvLEN(sv)) { + (void)SvIOK_on(sv); + SvUVX(sv) = asUV(sv); + } + else { + if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warn(warn_uninit); + return 0; + } + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", + (unsigned long)sv,SvUVX(sv))); + return SvUVX(sv); +} + double sv_2nv(sv) register SV *sv; @@ -1302,6 +1396,7 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); + SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) @@ -1323,6 +1418,7 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); + SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) @@ -1337,7 +1433,9 @@ register SV *sv; sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(SET_NUMERIC_STANDARD()); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -1349,6 +1447,7 @@ register SV *sv; else if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); + SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { @@ -1357,10 +1456,103 @@ register SV *sv; return 0.0; } SvNOK_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(SET_NUMERIC_STANDARD()); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } +static IV +asIV(sv) +SV *sv; +{ + I32 numtype = looks_like_number(sv); + double d; + + if (numtype == 1) + return atol(SvPVX(sv)); + if (!numtype && dowarn) + not_a_number(sv); + SET_NUMERIC_STANDARD(); + d = atof(SvPVX(sv)); + if (d < 0.0) + return I_V(d); + else + return (IV) U_V(d); +} + +static UV +asUV(sv) +SV *sv; +{ + I32 numtype = looks_like_number(sv); + + if (numtype == 1) + return atol(SvPVX(sv)); + if (!numtype && dowarn) + not_a_number(sv); + SET_NUMERIC_STANDARD(); + return U_V(atof(SvPVX(sv))); +} + +I32 +looks_like_number(sv) +SV *sv; +{ + register char *s; + register char *send; + register char *sbegin; + I32 numtype = 1; + STRLEN len; + + if (SvPOK(sv)) { + sbegin = SvPVX(sv); + len = SvCUR(sv); + } + else if (SvPOKp(sv)) + sbegin = SvPV(sv, len); + else + return 1; + send = sbegin + len; + + s = sbegin; + while (isSPACE(*s)) + s++; + if (s >= send) + return 0; + if (*s == '+' || *s == '-') + s++; + while (isDIGIT(*s)) + s++; + if (s == send) + return numtype; + if (*s == '.') { + numtype = 1; + s++; + } + else if (s == SvPVX(sv)) + return 0; + while (isDIGIT(*s)) + s++; + if (s == send) + return numtype; + if (*s == 'e' || *s == 'E') { + numtype = 2; + s++; + if (*s == '+' || *s == '-') + s++; + while (isDIGIT(*s)) + s++; + } + while (isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(sbegin, "0 but true", 10)) + return 1; + return 0; +} + char * sv_2pv(sv, lp) register SV *sv; @@ -1384,6 +1576,7 @@ STRLEN *lp; goto tokensave; } if (SvNOKp(sv)) { + SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); goto tokensave; } @@ -1419,7 +1612,7 @@ STRLEN *lp; case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; case SVt_PVFM: s = "FORMATLINE"; break; - case SVt_PVIO: s = "FILEHANDLE"; break; + case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } if (SvOBJECT(sv)) @@ -1434,6 +1627,7 @@ STRLEN *lp; } if (SvREADONLY(sv)) { if (SvNOKp(sv)) { + SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); goto tokensave; } @@ -1460,7 +1654,10 @@ STRLEN *lp; (void)strcpy(s,"0"); else #endif /*apollo*/ + { + SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, s); + } errno = olderrno; #ifdef FIXNEGATIVEZERO if (*s == '-' && s[1] == '0' && !s[2]) @@ -1608,22 +1805,20 @@ register SV *sstr; (void)SvOK_off(dstr); return; case SVt_IV: - if (dtype <= SVt_PV) { + if (dtype != SVt_IV && dtype < SVt_PVIV) { if (dtype < SVt_IV) sv_upgrade(dstr, SVt_IV); else if (dtype == SVt_NV) sv_upgrade(dstr, SVt_PVNV); - else if (dtype <= SVt_PV) + else sv_upgrade(dstr, SVt_PVIV); } break; case SVt_NV: - if (dtype <= SVt_PVIV) { + if (dtype != SVt_NV && dtype < SVt_PVNV) { if (dtype < SVt_NV) sv_upgrade(dstr, SVt_NV); - else if (dtype == SVt_PVIV) - sv_upgrade(dstr, SVt_PVNV); - else if (dtype <= SVt_PV) + else sv_upgrade(dstr, SVt_PVNV); } break; @@ -1716,8 +1911,7 @@ register SV *sstr; GvGP(dstr)->gp_refcnt--; GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); - GvGP(dstr) = gp; - GvREFCNT(dstr) = 1; + GvGP(dstr) = gp_ref(gp); GvSV(dstr) = NEWSV(72,0); GvLINE(dstr) = curcop->cop_line; GvEGV(dstr) = (GV*)dstr; @@ -1743,8 +1937,14 @@ register SV *sstr; GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: - if (intro) + if (intro) { + if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { + SvREFCNT_dec(GvCV(dstr)); + GvCV(dstr) = Nullcv; + GvCVGEN(dstr) = 0; + } SAVESPTR(GvCV(dstr)); + } else { CV* cv = GvCV(dstr); if (cv) { @@ -1754,12 +1954,13 @@ register SV *sstr; (CvROOT(cv) || CvXSUB(cv)) ) warn("Subroutine %s redefined", GvENAME((GV*)dstr)); - SvFAKE_on(cv); } } if (GvCV(dstr) != (CV*)sref) { GvCV(dstr) = (CV*)sref; + GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); + sub_generation++; } if (curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_CV_on(dstr); @@ -1882,7 +2083,7 @@ register SV *sstr; void sv_setpvn(sv,ptr,len) register SV *sv; -register char *ptr; +register const char *ptr; register STRLEN len; { assert(len >= 0); /* STRLEN is probably unsigned, so this may @@ -1914,7 +2115,7 @@ register STRLEN len; void sv_setpv(sv,ptr) register SV *sv; -register char *ptr; +register const char *ptr; { register STRLEN len; @@ -2090,7 +2291,7 @@ I32 namlen; { MAGIC* mg; - if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) + if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how)) croak(no_modify); if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2142,6 +2343,9 @@ I32 namlen; case 'E': mg->mg_virtual = &vtbl_env; break; + case 'f': + mg->mg_virtual = &vtbl_fm; + break; case 'e': mg->mg_virtual = &vtbl_envelem; break; @@ -2164,6 +2368,11 @@ I32 namlen; case 'l': mg->mg_virtual = &vtbl_dbline; break; +#ifdef USE_LOCALE_COLLATE + case 'o': + mg->mg_virtual = &vtbl_collxfrm; + break; +#endif /* USE_LOCALE_COLLATE */ case 'P': mg->mg_virtual = &vtbl_pack; break; @@ -2190,6 +2399,9 @@ I32 namlen; case 'x': mg->mg_virtual = &vtbl_substr; break; + case 'y': + mg->mg_virtual = &vtbl_itervar; + break; case '*': mg->mg_virtual = &vtbl_glob; break; @@ -2358,6 +2570,7 @@ register SV *nsv; } SvREFCNT(sv) = 0; sv_clear(sv); + assert(!SvREFCNT(sv)); StructCopy(nsv,sv,SV); SvREFCNT(sv) = refcnt; SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ @@ -2372,15 +2585,15 @@ register SV *sv; assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { - dSP; - GV* destructor; - if (defstash) { /* Still have a symbol table? */ - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + dSP; + GV* destructor; ENTER; SAVEFREESV(SvSTASH(sv)); - if (destructor && GvCV(destructor)) { + + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { SV ref; Zero(&ref, 1, SV); @@ -2392,10 +2605,12 @@ register SV *sv; PUSHMARK(SP); PUSHs(&ref); PUTBACK; - perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); + perl_call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); del_XRV(SvANY(&ref)); SvREFCNT(sv)--; } + LEAVE; } else @@ -2406,7 +2621,7 @@ register SV *sv; --sv_objcount; /* XXX Might want something more general */ } if (SvREFCNT(sv)) { - SV *ret; + SV *ret; if ( perldb && (ret = perl_get_sv("DB::ret", FALSE)) && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) { @@ -2414,8 +2629,12 @@ register SV *sv; SvRV(ret) = 0; SvROK_off(ret); SvREFCNT(sv) = 0; - } else { - croak("panic: dangling references in DESTROY"); + } + else { + if (in_clean_objs) + croak("DESTROY created new reference to dead object"); + /* DESTROY gave object new lease on life */ + return; } } } @@ -2423,7 +2642,10 @@ register SV *sv; mg_free(sv); switch (SvTYPE(sv)) { case SVt_PVIO: - io_close((IO*)sv); + if (IoIFP(sv) != PerlIO_stdin() && + IoIFP(sv) != PerlIO_stdout() && + IoIFP(sv) != PerlIO_stderr()) + io_close((IO*)sv); Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2555,7 +2777,8 @@ SV *sv; } #endif sv_clear(sv); - del_SV(sv); + if (! SvREFCNT(sv)) + del_SV(sv); } STRLEN @@ -2600,107 +2823,135 @@ register SV *str2; if (cur1 != cur2) return 0; - return !memcmp(pv1, pv2, cur1); + return memEQ(pv1, pv2, cur1); } I32 -sv_cmp(str1,str2) +sv_cmp(str1, str2) register SV *str1; register SV *str2; { + STRLEN cur1 = 0; + char *pv1 = str1 ? SvPV(str1, cur1) : NULL; + STRLEN cur2 = 0; + char *pv2 = str2 ? SvPV(str2, cur2) : NULL; I32 retval; - char *pv1; - STRLEN cur1; - char *pv2; - STRLEN cur2; - - if (lc_collate_active) { /* NOTE: this is the LC_COLLATE branch */ - - if (!str1) { - pv1 = ""; - cur1 = 0; - } else { - pv1 = SvPV(str1, cur1); - - { - STRLEN cur1x; - char * pv1x = mem_collxfrm(pv1, cur1, &cur1x); - - pv1 = pv1x; - cur1 = cur1x; - } - } - - if (!str2) { - pv2 = ""; - cur2 = 0; - } else { - pv2 = SvPV(str2, cur2); - { - STRLEN cur2x; - char * pv2x = mem_collxfrm(pv2, cur2, &cur2x); - - pv2 = pv2x; - cur2 = cur2x; - } - } - - if (!cur1) { - Safefree(pv2); + if (!cur1) return cur2 ? -1 : 0; - } - if (!cur2) { - Safefree(pv1); + if (!cur2) return 1; - } - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); - Safefree(pv1); - Safefree(pv2); - - if (retval) + if (retval) return retval < 0 ? -1 : 1; - if (cur1 == cur2) + if (cur1 == cur2) return 0; else return cur1 < cur2 ? -1 : 1; +} - } else { /* NOTE: this is the non-LC_COLLATE branch */ +I32 +sv_cmp_locale(sv1, sv2) +register SV *sv1; +register SV *sv2; +{ +#ifdef USE_LOCALE_COLLATE - if (!str1) { - pv1 = ""; - cur1 = 0; - } else - pv1 = SvPV(str1, cur1); + char *pv1, *pv2; + STRLEN len1, len2; + I32 retval; - if (!str2) { - pv2 = ""; - cur2 = 0; - } else - pv2 = SvPV(str2, cur2); + if (collation_standard) + goto raw_compare; - if (!cur1) - return cur2 ? -1 : 0; + len1 = 0; + pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL; + len2 = 0; + pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL; - if (!cur2) - return 1; + if (!pv1 || !len1) { + if (pv2 && len2) + return -1; + else + goto raw_compare; + } + else { + if (!pv2 || !len2) + return 1; + } - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); - if (retval) + if (retval) return retval < 0 ? -1 : 1; - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; + /* + * When the result of collation is equality, that doesn't mean + * that there are no differences -- some locales exclude some + * characters from consideration. So to avoid false equalities, + * we use the raw string as a tiebreaker. + */ + + raw_compare: + /* FALL THROUGH */ + +#endif /* USE_LOCALE_COLLATE */ + + return sv_cmp(sv1, sv2); +} + +#ifdef USE_LOCALE_COLLATE +/* + * Any scalar variable may carry an 'o' magic that contains the + * scalar data of the variable transformed to such a format that + * a normal memory comparison can be used to compare the data + * according to the locale settings. + */ +char * +sv_collxfrm(sv, nxp) + SV *sv; + STRLEN *nxp; +{ + MAGIC *mg; + + mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL; + if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { + char *s, *xf; + STRLEN len, xlen; + + if (mg) + Safefree(mg->mg_ptr); + s = SvPV(sv, len); + if ((xf = mem_collxfrm(s, len, &xlen))) { + if (! mg) { + sv_magic(sv, 0, 'o', 0, 0); + mg = mg_find(sv, 'o'); + assert(mg); + } + mg->mg_ptr = xf; + mg->mg_len = xlen; + } + else { + mg->mg_ptr = NULL; + mg->mg_len = -1; + } + } + if (mg && mg->mg_ptr) { + *nxp = mg->mg_len; + return mg->mg_ptr + sizeof(collation_ix); + } + else { + *nxp = 0; + return NULL; } } +#endif /* USE_LOCALE_COLLATE */ + char * sv_gets(sv,fp,append) register SV *sv; @@ -2722,6 +2973,7 @@ I32 append; } if (!SvUPGRADE(sv, SVt_PV)) return 0; + SvSCREAM_off(sv); if (RsSNARF(rs)) { rsptr = NULL; @@ -2788,7 +3040,8 @@ I32 append; } else { shortbuffered = 0; - SvGROW(sv, append+cnt+2);/* (remembering cnt can be -1) */ + /* remember that cnt can be negative */ + SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1))); } } else @@ -2799,7 +3052,8 @@ I32 append; "Screamer: entering, ptr=%d, cnt=%d\n",ptr,cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering: FILE * thinks ptr=%d, cnt=%d, base=%d\n", - PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), + PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)); for (;;) { screamer: if (cnt > 0) { @@ -2811,7 +3065,7 @@ I32 append; } } else { - memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */ + Copy(ptr, bp, cnt, char); /* this | eat */ bp += cnt; /* screams | dust */ ptr += cnt; /* louder | sed :-) */ cnt = 0; @@ -2833,7 +3087,8 @@ I32 append; PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%d, cnt=%d, base=%d\n", - PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), + PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)); /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid another abstraction. This may also avoid issues with different named @@ -2843,7 +3098,8 @@ I32 append; i = PerlIO_getc(fp); /* get more characters */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n", - PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), + PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)); cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -2865,7 +3121,7 @@ I32 append; thats_all_folks: if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || - memcmp((char*)bp - rslen, rsptr, rslen)) + memNE((char*)bp - rslen, rsptr, rslen)) goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) @@ -2875,7 +3131,8 @@ thats_really_all_folks: PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: end: FILE * thinks ptr=%d, cnt=%d, base=%d\n", - PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), + PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -2911,7 +3168,7 @@ screamer2: if (i != EOF && /* joy */ (!rslen || SvCUR(sv) < rslen || - memcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; goto screamer2; @@ -2954,14 +3211,18 @@ register SV *sv; if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); - if (flags & SVp_IOK) { - (void)SvIOK_only(sv); - ++SvIVX(sv); - return; - } if (flags & SVp_NOK) { - SvNVX(sv) += 1.0; (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + if (flags & SVp_IOK) { + if (SvIVX(sv) == IV_MAX) + sv_setnv(sv, (double)IV_MAX + 1.0); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { @@ -2975,7 +3236,8 @@ register SV *sv; while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (*d) { - sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */ + SET_NUMERIC_STANDARD(); + sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */ return; } d--; @@ -3024,16 +3286,20 @@ register SV *sv; if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); - if (flags & SVp_IOK) { - (void)SvIOK_only(sv); - --SvIVX(sv); - return; - } if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; (void)SvNOK_only(sv); return; } + if (flags & SVp_IOK) { + if (SvIVX(sv) == IV_MIN) + sv_setnv(sv, (double)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } + return; + } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVNV) sv_upgrade(sv, SVt_NV); @@ -3041,7 +3307,8 @@ register SV *sv; (void)SvNOK_only(sv); return; } - sv_setnv(sv,atof(SvPVX(sv)) - 1.0); + SET_NUMERIC_STANDARD(); + sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */ } /* Make a string that will exist for the duration of the expression @@ -3052,7 +3319,7 @@ register SV *sv; static void sv_mortalgrow() { - tmps_max += 128; + tmps_max += (tmps_max < 512) ? 128 : 512; Renew(tmps_stack, tmps_max, SV*); } @@ -3168,6 +3435,19 @@ SV *ref; return sv; } +#ifdef CRIPPLED_CC +SV * +newRV_noinc(ref) +SV *ref; +{ + register SV *sv; + + sv = newRV(ref); + SvREFCNT_dec(ref); + return sv; +} +#endif /* CRIPPLED_CC */ + /* make an exact duplicate of old */ SV * @@ -3242,16 +3522,14 @@ HV *stash; (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); - SvTAINT(sv); if (SvPVX(sv) != Nullch) *SvPVX(sv) = '\0'; + SvTAINT(sv); } if (GvAV(gv)) { av_clear(GvAV(gv)); } - if (GvHV(gv)) { - if (HvNAME(GvHV(gv))) - continue; + if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef VMS /* VMS has no environ array */ if (gv == envgv) @@ -3310,7 +3588,7 @@ I32 lref; return Nullcv; *st = GvESTASH(gv); fix_gv: - if (lref && !GvCV(gv)) { + if (lref && !GvCVu(gv)) { SV *tmpsv; ENTER; tmpsv = NEWSV(704,0); @@ -3320,10 +3598,10 @@ I32 lref; Nullop, Nullop); LEAVE; - if (!GvCV(gv)) + if (!GvCVu(gv)) croak("Unable to create sub named \"%s\"", SvPV(sv,na)); } - return GvCV(gv); + return GvCVu(gv); } } @@ -3357,30 +3635,40 @@ register SV *sv; } } } -#endif /* SvTRUE */ +#endif /* !SvTRUE */ #ifndef SvIV -IV SvIV(Sv) -register SV *Sv; +IV +SvIV(sv) +register SV *sv; { - if (SvIOK(Sv)) - return SvIVX(Sv); - return sv_2iv(Sv); + if (SvIOK(sv)) + return SvIVX(sv); + return sv_2iv(sv); } -#endif /* SvIV */ +#endif /* !SvIV */ +#ifndef SvUV +UV +SvUV(sv) +register SV *sv; +{ + if (SvIOK(sv)) + return SvUVX(sv); + return sv_2uv(sv); +} +#endif /* !SvUV */ #ifndef SvNV -double SvNV(Sv) -register SV *Sv; +double +SvNV(sv) +register SV *sv; { - if (SvNOK(Sv)) - return SvNVX(Sv); - if (SvIOK(Sv)) - return (double)SvIVX(Sv); - return sv_2nv(Sv); + if (SvNOK(sv)) + return SvNVX(sv); + return sv_2nv(sv); } -#endif /* SvNV */ +#endif /* !SvNV */ #ifdef CRIPPLED_CC char * @@ -3627,6 +3915,70 @@ SV* sv; sv_2mortal(rv); /* Schedule for freeing later */ } +IO* +sv_2io(sv) +SV *sv; +{ + IO* io; + GV* gv; + + switch (SvTYPE(sv)) { + case SVt_PVIO: + io = (IO*)sv; + break; + case SVt_PVGV: + gv = (GV*)sv; + io = GvIO(gv); + if (!io) + croak("Bad filehandle: %s", GvNAME(gv)); + break; + default: + if (!SvOK(sv)) + croak(no_usym, "filehandle"); + if (SvROK(sv)) + return sv_2io(SvRV(sv)); + gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); + if (gv) + io = GvIO(gv); + else + io = 0; + if (!io) + croak("Bad filehandle: %s", SvPV(sv,na)); + break; + } + return io; +} + +void +sv_taint(sv) +SV *sv; +{ + sv_magic((sv), Nullsv, 't', Nullch, 0); +} + +void +sv_untaint(sv) +SV *sv; +{ + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + MAGIC *mg = mg_find(sv, 't'); + if (mg) + mg->mg_len &= ~1; + } +} + +bool +sv_tainted(sv) +SV *sv; +{ + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + MAGIC *mg = mg_find(sv, 't'); + if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) + return TRUE; + } + return FALSE; +} + #ifdef DEBUGGING void sv_dump(sv) @@ -3681,11 +4033,27 @@ SV* sv; if (CvCLONE(sv)) strcat(d, "CLONE,"); if (CvCLONED(sv)) strcat(d, "CLONED,"); break; + case SVt_PVHV: + if (HvSHAREKEYS(sv)) strcat(d, "SHAREKEYS,"); + if (HvLAZYDEL(sv)) strcat(d, "LAZYDEL,"); + break; case SVt_PVGV: - if (GvMULTI(sv)) strcat(d, "MULTI,"); -#ifdef OVERLOAD - if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,"); -#endif /* OVERLOAD */ + if (GvINTRO(sv)) strcat(d, "INTRO,"); + if (GvMULTI(sv)) strcat(d, "MULTI,"); + if (GvASSUMECV(sv)) strcat(d, "ASSUMECV,"); + if (GvIMPORTED(sv)) { + strcat(d, "IMPORT"); + if (GvIMPORTED(sv) == GVf_IMPORTED) + strcat(d, "ALL,"); + else { + strcat(d, "("); + if (GvIMPORTED_SV(sv)) strcat(d, " SV"); + if (GvIMPORTED_AV(sv)) strcat(d, " AV"); + if (GvIMPORTED_HV(sv)) strcat(d, " HV"); + if (GvIMPORTED_CV(sv)) strcat(d, " CV"); + strcat(d, " ),"); + } + } } d += strlen(d); @@ -3750,8 +4118,10 @@ SV* sv; } if (type >= SVt_PVIV || type == SVt_IV) PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); - if (type >= SVt_PVNV || type == SVt_NV) + if (type >= SVt_PVNV || type == SVt_NV) { + SET_NUMERIC_STANDARD(); PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); + } if (SvROK(sv)) { PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); @@ -3846,8 +4216,7 @@ SV* sv; PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv)); PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); break; case SVt_PVIO: @@ -3877,38 +4246,3 @@ SV* sv; { } #endif - -IO* -sv_2io(sv) -SV *sv; -{ - IO* io; - GV* gv; - - switch (SvTYPE(sv)) { - case SVt_PVIO: - io = (IO*)sv; - break; - case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - croak("Bad filehandle: %s", GvNAME(gv)); - break; - default: - if (!SvOK(sv)) - croak(no_usym, "filehandle"); - if (SvROK(sv)) - return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); - if (gv) - io = GvIO(gv); - else - io = 0; - if (!io) - croak("Bad filehandle: %s", SvPV(sv,na)); - break; - } - return io; -} - @@ -126,17 +126,11 @@ struct io { #define SVpfm_COMPILED 0x80000000 #define SVpbm_VALID 0x80000000 -#define SVpbm_CASEFOLD 0x40000000 -#define SVpbm_TAIL 0x20000000 +#define SVpbm_TAIL 0x40000000 #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */ -#ifdef OVERLOAD -#define SVpgv_AM 0x40000000 -/* #define SVpgv_badAM 0x20000000 */ -#endif /* OVERLOAD */ - struct xrv { SV * xrv_rv; /* pointer to another SV */ }; @@ -154,6 +148,13 @@ struct xpviv { IV xiv_iv; /* integer value or pv offset */ }; +struct xpvuv { + char * xpv_pv; /* pointer to malloced string */ + STRLEN xpv_cur; /* length of xpv_pv as a C string */ + STRLEN xpv_len; /* allocated size */ + UV xuv_uv; /* unsigned value or pv offset */ +}; + struct xpvnv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ @@ -217,6 +218,8 @@ struct xpvbm { U8 xbm_rare; /* rarest character in string */ }; +/* This structure much match XPVCV */ + struct xpvfm { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ @@ -236,6 +239,8 @@ struct xpvfm { long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; + U8 xcv_flags; + I32 xfm_lines; }; @@ -402,10 +407,6 @@ struct xpvio { #define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL) #define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL) -#define SvCASEFOLD(sv) (SvFLAGS(sv) & SVpbm_CASEFOLD) -#define SvCASEFOLD_on(sv) (SvFLAGS(sv) |= SVpbm_CASEFOLD) -#define SvCASEFOLD_off(sv) (SvFLAGS(sv) &= ~SVpbm_CASEFOLD) - #define SvVALID(sv) (SvFLAGS(sv) & SVpbm_VALID) #define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID) #define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID) @@ -415,6 +416,8 @@ struct xpvio { #define SvIVX(sv) ((XPVIV*) SvANY(sv))->xiv_iv #define SvIVXx(sv) SvIVX(sv) +#define SvUVX(sv) ((XPVUV*) SvANY(sv))->xuv_uv +#define SvUVXx(sv) SvUVX(sv) #define SvNVX(sv) ((XPVNV*)SvANY(sv))->xnv_nv #define SvNVXx(sv) SvNVX(sv) #define SvPVX(sv) ((XPV*) SvANY(sv))->xpv_pv @@ -474,11 +477,16 @@ struct xpvio { #define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type #define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags -#define SvTAINT(sv) if (tainting && tainted) sv_magic(sv, Nullsv, 't', Nullch, 0) +#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv)) +#define SvTAINTED_on(sv) STMT_START{ if(tainting){sv_taint(sv);} }STMT_END +#define SvTAINTED_off(sv) STMT_START{ if(tainting){sv_untaint(sv);} }STMT_END + +#define SvTAINT(sv) STMT_START{ if(tainted){SvTAINTED_on(sv);} }STMT_END #ifdef CRIPPLED_CC IV SvIV _((SV* sv)); +UV SvUV _((SV* sv)); double SvNV _((SV* sv)); #define SvPV_force(sv, lp) sv_pvn_force(sv, &lp) #define SvPV(sv, lp) sv_pvn(sv, &lp) @@ -486,6 +494,7 @@ char *sv_pvn _((SV *, STRLEN *)); I32 SvTRUE _((SV *)); #define SvIVx(sv) SvIV(sv) +#define SvUVx(sv) SvUV(sv) #define SvNVx(sv) SvNV(sv) #define SvPVx(sv, lp) sv_pvn(sv, &lp) #define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp) @@ -493,14 +502,25 @@ I32 SvTRUE _((SV *)); #else /* !CRIPPLED_CC */ +#undef SvIV #define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) +#undef SvUV +#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) + +#undef SvNV #define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)) -#define SvPV(sv, lp) (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) +#undef SvPV +#define SvPV(sv, lp) \ + (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) -#define SvPV_force(sv, lp) ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp)) +#undef SvPV_force +#define SvPV_force(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp)) +#undef SvTRUE #define SvTRUE(sv) ( \ !sv \ ? 0 \ @@ -519,20 +539,38 @@ I32 SvTRUE _((SV *)); : sv_2bool(sv) ) #define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) +#define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) #define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) #define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) #define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv)) #endif /* CRIPPLED_CC */ +#define newRV_inc(sv) newRV(sv) +#ifdef CRIPPLED_CC +SV *newRV_noinc _((SV *)); +#else +#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) +#endif + /* the following macro updates any magic values this sv is associated with */ #define SvSETMAGIC(x) if (SvSMAGICAL(x)) mg_set(x) -#define SvSetSV(dst,src) if (dst != src) sv_setsv(dst,src) +#define SvSetSV(dst,src) if ((dst) != (src)) sv_setsv(dst,src) + +#define SvSetSV_nosteal(dst,src) \ + if ((dst) != (src)) { \ + U32 tMpF = SvFLAGS(src) & SVs_TEMP; \ + SvTEMP_off(src); \ + sv_setsv(dst, src); \ + SvFLAGS(src) |= tMpF; \ + } #define SvPEEK(sv) sv_peek(sv) +#define SvIMMORTAL(sv) ((sv)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no) + #define isGV(sv) (SvTYPE(sv) == SVt_PVGV) #ifndef DOSISH @@ -8,4 +8,4 @@ If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. -If you come up with new tests, send them to lwall@sems.com. +If you come up with new tests, send them to larry@wall.org. @@ -1,6 +1,6 @@ #!./perl -# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ +# Last change: Fri Jan 10 09:57:03 WET 1997 # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. @@ -21,17 +21,23 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($ARGV[0] eq '') { @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); + `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); } -open(CONFIG,"../config.sh"); -while (<CONFIG>) { - if (/sharpbang='(.*)'/) { - $sharpbang = ($1 eq '#!'); - last; +if ($^O eq 'os2' || $^O eq 'qnx') { + $sharpbang = 0; +} +else { + open(CONFIG, "../config.sh"); + while (<CONFIG>) { + if (/sharpbang='(.*)'/) { + $sharpbang = ($1 eq '#!'); + last; + } } + close(CONFIG); } -$sharpbang = 0 if $ENV{OS2_SHELL}; # OS/2 + $bad = 0; $good = 0; $total = @ARGV; @@ -41,7 +47,7 @@ while ($test = shift) { } $te = $test; chop($te); - print "$te" . '.' x (15 - length($te)); + print "$te" . '.' x (18 - length($te)); if ($sharpbang) { open(results,"./$test |") || (print "can't run.\n"); } else { @@ -50,6 +56,10 @@ while ($test = shift) { close(script); if (/#!..perl(.*)/) { $switch = $1; + if ($^O eq 'VMS') { + # Must protect uppercase switches with "" on command line + $switch =~ s/-([A-Z]\S*)/"-$1"/g; + } } else { $switch = ''; } @@ -107,11 +117,17 @@ if ($bad == 0) { } else { $pct = sprintf("%.2f", $good / $total * 100); if ($bad == 1) { - warn "Failed 1 test, $pct% okay.\n"; + warn "Failed 1 test script out of $total, $pct% okay.\n"; } else { - die "Failed $bad/$total tests, $pct% okay.\n"; + warn "Failed $bad test scripts out of $total, $pct% okay.\n"; } + warn <<'SHRDLU'; + ### Since not all tests were successful, you may want to run some + ### of them individually and examine any diagnostic messages they + ### produce. See the INSTALL document's section on "make test". +SHRDLU } ($user,$sys,$cuser,$csys) = times; -print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", +print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); +exit $bad != 0; diff --git a/t/base/term.t b/t/base/term.t index 7bbb80ee90..782ad397d3 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -2,7 +2,7 @@ # $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $ -print "1..6\n"; +print "1..7\n"; # check "" interpretation @@ -27,16 +27,19 @@ if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} $x = 1; if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} +$x = '1E2'; +if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";} + # check <> pseudoliteral open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null."); if (<try> eq '') { - print "ok 5\n"; + print "ok 6\n"; } else { - print "not ok 5\n"; + print "not ok 6\n"; die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; } open(try, "../Configure") || (die "Can't open ../Configure."); -if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";} +if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/t/comp/colon.t b/t/comp/colon.t new file mode 100755 index 0000000000..2a37367d75 --- /dev/null +++ b/t/comp/colon.t @@ -0,0 +1,138 @@ +#!./perl + +# +# Ensure that syntax using colons (:) is parsed correctly. +# The tests are done on the following tokens (by default): +# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$_ = ''; # to avoid undef warning on m// etc. + +sub ok { + my($test,$ok) = @_; + print "not " unless $ok; + print "ok $test\n"; +} + +$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings + +print "1..25\n"; + +ok 1, (eval "package ABC; sub zyx {1}; 1;" and + eval "ABC::zyx" and + not eval "ABC:: eq ABC||" and + not eval "ABC::: >= 0"); + +ok 2, (eval "package LABEL; sub zyx {1}; 1;" and + eval "LABEL::zyx" and + not eval "LABEL:: eq LABEL||" and + not eval "LABEL::: >= 0"); + +ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and + eval "XYZZY::zyx" and + not eval "XYZZY:: eq XYZZY||" and + not eval "XYZZY::: >= 0"); + +ok 4, (eval "package m; sub zyx {1}; 1;" and + not eval "m::zyx" and + eval "m:: eq m||" and + not eval "m::: >= 0"); + +ok 5, (eval "package q; sub zyx {1}; 1;" and + not eval "q::zyx" and + eval "q:: eq q||" and + not eval "q::: >= 0"); + +ok 6, (eval "package qq; sub zyx {1}; 1;" and + not eval "qq::zyx" and + eval "qq:: eq qq||" and + not eval "qq::: >= 0"); + +ok 7, (eval "package qw; sub zyx {1}; 1;" and + not eval "qw::zyx" and + eval "qw:: eq qw||" and + not eval "qw::: >= 0"); + +ok 8, (eval "package qx; sub zyx {1}; 1;" and + not eval "qx::zyx" and + eval "qx:: eq qx||" and + not eval "qx::: >= 0"); + +ok 9, (eval "package s; sub zyx {1}; 1;" and + not eval "s::zyx" and + not eval "s:: eq s||" and + eval "s::: >= 0"); + +ok 10, (eval "package tr; sub zyx {1}; 1;" and + not eval "tr::zyx" and + not eval "tr:: eq tr||" and + eval "tr::: >= 0"); + +ok 11, (eval "package y; sub zyx {1}; 1;" and + not eval "y::zyx" and + not eval "y:: eq y||" and + eval "y::: >= 0"); + +ok 12, (eval "ABC:1" and + not eval "ABC:echo: eq ABC|echo|" and + not eval "ABC:echo:ohce: >= 0"); + +ok 13, (eval "LABEL:1" and + not eval "LABEL:echo: eq LABEL|echo|" and + not eval "LABEL:echo:ohce: >= 0"); + +ok 14, (eval "XYZZY:1" and + not eval "XYZZY:echo: eq XYZZY|echo|" and + not eval "XYZZY:echo:ohce: >= 0"); + +ok 15, (not eval "m:1" and + eval "m:echo: eq m|echo|" and + not eval "m:echo:ohce: >= 0"); + +ok 16, (not eval "q:1" and + eval "q:echo: eq q|echo|" and + not eval "q:echo:ohce: >= 0"); + +ok 17, (not eval "qq:1" and + eval "qq:echo: eq qq|echo|" and + not eval "qq:echo:ohce: >= 0"); + +ok 18, (not eval "qw:1" and + eval "qw:echo: eq qw|echo|" and + not eval "qw:echo:ohce: >= 0"); + +ok 19, (not eval "qx:1" and + eval "qx:echo: eq qx|echo|" and + not eval "qx:echo:ohce: >= 0"); + +ok 20, (not eval "s:1" and + not eval "s:echo: eq s|echo|" and + eval "s:echo:ohce: >= 0"); + +ok 21, (not eval "tr:1" and + not eval "tr:echo: eq tr|echo|" and + eval "tr:echo:ohce: >= 0"); + +ok 22, (not eval "y:1" and + not eval "y:echo: eq y|echo|" and + eval "y:echo:ohce: >= 0"); + +ok 23, (eval "AUTOLOAD:1" and + not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and + not eval "AUTOLOAD:echo:ohce: >= 0"); + +ok 24, (eval "and:1" and + not eval "and:echo: eq and|echo|" and + not eval "and:echo:ohce: >= 0"); + +ok 25, (eval "alarm:1" and + not eval "alarm:echo: eq alarm|echo|" and + not eval "alarm:echo:ohce: >= 0"); diff --git a/t/comp/proto.t b/t/comp/proto.t new file mode 100755 index 0000000000..197ea78272 --- /dev/null +++ b/t/comp/proto.t @@ -0,0 +1,377 @@ +#!./perl +# +# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> +# +# So far there are tests for the following prototypes. +# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) +# +# It is impossible to test every prototype that can be specified, but +# we should test as many as we can. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +print "1..74\n"; + +my $i = 1; + +sub testing (&$) { + my $p = prototype(shift); + my $c = shift; + my $what = defined $c ? '(' . $p . ')' : 'no prototype'; + print '#' x 25,"\n"; + print '# Testing ',$what,"\n"; + print '#' x 25,"\n"; + print "not " + if((defined($p) && defined($c) && $p ne $c) + || (defined($p) != defined($c))); + printf "ok %d\n",$i++; +} + +@_ = qw(a b c d); +my @array; +my %hash; + +## +## +## + +testing \&no_proto, undef; + +sub no_proto { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 0 == no_proto(); +printf "ok %d\n",$i++; + +print "not " unless 1 == no_proto(5); +printf "ok %d\n",$i++; + +print "not " unless 4 == &no_proto; +printf "ok %d\n",$i++; + +print "not " unless 1 == no_proto +6; +printf "ok %d\n",$i++; + +print "not " unless 4 == no_proto(@_); +printf "ok %d\n",$i++; + +## +## +## + + +testing \&no_args, ''; + +sub no_args () { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 0 == no_args(); +printf "ok %d\n",$i++; + +print "not " unless 0 == no_args; +printf "ok %d\n",$i++; + +print "not " unless 5 == no_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &no_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &no_args(1,2); +printf "ok %d\n",$i++; + +eval "no_args(1)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + +testing \&one_args, '$'; + +sub one_args ($) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == one_args(1); +printf "ok %d\n",$i++; + +print "not " unless 1 == one_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &one_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &one_args(1,2); +printf "ok %d\n",$i++; + +eval "one_args(1,2)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +eval "one_args()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub one_a_args ($) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ == 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +one_a_args(@_); + +## +## +## + +testing \&over_one_args, '$@'; + +sub over_one_args ($@) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == over_one_args(1); +printf "ok %d\n",$i++; + +print "not " unless 2 == over_one_args(1,2); +printf "ok %d\n",$i++; + +print "not " unless 1 == over_one_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &over_one_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &over_one_args(1,2); +printf "ok %d\n",$i++; + +print "not " unless 5 == &over_one_args(1,@_); +printf "ok %d\n",$i++; + +eval "over_one_args()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub over_one_a_args ($@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +over_one_a_args(@_); +over_one_a_args(@_,1); +over_one_a_args(@_,1,2); +over_one_a_args(@_,@_); + +## +## +## + +testing \&scalar_and_hash, '$%'; + +sub scalar_and_hash ($%) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == scalar_and_hash(1); +printf "ok %d\n",$i++; + +print "not " unless 3 == scalar_and_hash(1,2,3); +printf "ok %d\n",$i++; + +print "not " unless 1 == scalar_and_hash +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &scalar_and_hash; +printf "ok %d\n",$i++; + +print "not " unless 2 == &scalar_and_hash(1,2); +printf "ok %d\n",$i++; + +print "not " unless 5 == &scalar_and_hash(1,@_); +printf "ok %d\n",$i++; + +eval "scalar_and_hash()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub scalar_and_hash_a ($@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +scalar_and_hash_a(@_); +scalar_and_hash_a(@_,1); +scalar_and_hash_a(@_,1,2); +scalar_and_hash_a(@_,@_); + +## +## +## + +testing \&one_or_two, '$;$'; + +sub one_or_two ($;$) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == one_or_two(1); +printf "ok %d\n",$i++; + +print "not " unless 2 == one_or_two(1,3); +printf "ok %d\n",$i++; + +print "not " unless 1 == one_or_two +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &one_or_two; +printf "ok %d\n",$i++; + +print "not " unless 3 == &one_or_two(1,2,3); +printf "ok %d\n",$i++; + +print "not " unless 5 == &one_or_two(1,@_); +printf "ok %d\n",$i++; + +eval "one_or_two()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +eval "one_or_two(1,2,3)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub one_or_two_a ($;$) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +one_or_two_a(@_); +one_or_two_a(@_,1); +one_or_two_a(@_,@_); + +## +## +## + +testing \&a_sub, '&'; + +sub a_sub (&) { + print "# \@_ = (",join(",",@_),")\n"; + &{$_[0]}; +} + +sub tmp_sub_1 { printf "ok %d\n",$i++ } + +a_sub { printf "ok %d\n",$i++ }; +a_sub \&tmp_sub_1; + +@array = ( \&tmp_sub_1 ); +eval 'a_sub @array'; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + +testing \&sub_aref, '&\@'; + +sub sub_aref (&\@) { + print "# \@_ = (",join(",",@_),")\n"; + my($sub,$array) = @_; + print "not " unless @_ == 2 && @{$array} == 4; + print map { &{$sub}($_) } @{$array} +} + +@array = (qw(O K)," ", $i++); +sub_aref { lc shift } @array; +print "\n"; + +## +## +## + +testing \&sub_array, '&@'; + +sub sub_array (&@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ == 5; + my $sub = shift; + print map { &{$sub}($_) } @_ +} + +@array = (qw(O K)," ", $i++); +sub_array { lc shift } @array; +print "\n"; + +## +## +## + +testing \&a_hash, '%'; + +sub a_hash (%) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_); +} + +print "not " unless 1 == a_hash 'a'; +printf "ok %d\n",$i++; + +print "not " unless 2 == a_hash 'a','b'; +printf "ok %d\n",$i++; + +## +## +## + +testing \&a_hash_ref, '\%'; + +sub a_hash_ref (\%) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless ref($_[0]) && $_[0]->{'a'}; + printf "ok %d\n",$i++; + $_[0]->{'b'} = 2; +} + +%hash = ( a => 1); +a_hash_ref %hash; +print "not " unless $hash{'b'} == 2; +printf "ok %d\n",$i++; + +## +## +## + +testing \&an_array_ref, '\@'; + +sub an_array_ref (\@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless ref($_[0]) && 1 == @{$_[0]}; + printf "ok %d\n",$i++; + @{$_[0]} = (qw(ok)," ",$i++,"\n"); +} + +@array = ('a'); +an_array_ref @array; +print "not " unless @array == 4; +print @array; diff --git a/t/comp/redef.t b/t/comp/redef.t index 6a73ae1c2e..ad28bfd5e2 100755 --- a/t/comp/redef.t +++ b/t/comp/redef.t @@ -1,9 +1,8 @@ -#!./perl +#!./perl -w # # Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> BEGIN { - $^W = 1; $warn = ""; $SIG{__WARN__} = sub { $warn .= join("",@_) } } diff --git a/t/comp/use.t b/t/comp/use.t new file mode 100755 index 0000000000..a6ce2a4d56 --- /dev/null +++ b/t/comp/use.t @@ -0,0 +1,101 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..14\n"; + +my $i = 1; + +eval "use 5.000;"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf "use %.5f;", $]; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + + +eval sprintf "use %.5f;", $] - 0.000001; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf("use %.5f;", $] + 1); +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf "use %.5f;", $] + 0.00001; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + + + +use lib; # I know that this module will be there. + + +local $lib::VERSION = 1.0; + +eval "use lib 0.9"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval "use lib 1.0"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval "use lib 1.01"; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + + +eval "use lib 0.9 qw(fred)"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " unless $INC[0] eq "fred"; +print "ok ",$i++,"\n"; + +eval "use lib 1.0 qw(joe)"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " unless $INC[0] eq "joe"; +print "ok ",$i++,"\n"; + +eval "use lib 1.01 qw(freda)"; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " if $INC[0] eq "freda"; +print "ok ",$i++,"\n"; diff --git a/t/harness b/t/harness index c98d91e360..5b460f3de4 100644..100755 --- a/t/harness +++ b/t/harness @@ -9,6 +9,7 @@ use lib '../lib'; use Test::Harness; $Test::Harness::switches = ""; # Too much noise otherwise +$Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; @tests = @ARGV; @tests = <*/*.t> unless @tests; @@ -73,12 +73,14 @@ if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} unlink 'c'; chdir $wd || die "Can't cd back to $wd"; +rmdir 'tmp'; unlink 'c'; if (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";} $foo = `grep perl c`; if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} + unlink 'c'; } else { print "ok 21\nok 22\n"; diff --git a/t/io/read.t b/t/io/read.t index 16d32b189c..b27fde17c7 100755 --- a/t/io/read.t +++ b/t/io/read.t @@ -15,8 +15,12 @@ read(A,$b,1,4); close(A); +unlink("a"); + if ($b eq "\000\000\000\000_") { print "ok 1\n"; } else { # Probably "\000bcd_" print "not ok 1\n"; } + +unlink 'a'; diff --git a/t/lib/basename.t b/t/lib/basename.t index 56b1f7f211..0f8a117e4c 100755 --- a/t/lib/basename.t +++ b/t/lib/basename.t @@ -7,7 +7,7 @@ BEGIN { use File::Basename qw(fileparse basename dirname); -print "1..30\n"; +print "1..34\n"; # import correctly? print +(defined(&basename) && !defined(&fileparse_set_fstype) ? @@ -105,3 +105,16 @@ print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? '' : 'not '),"ok 30\n"; +# extra tests for a few specific bugs + +File::Basename::fileparse_set_fstype 'MSDOS'; +# perl5.003_18 gives C:/perl/.\ +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +# perl5.003_18 gives C:\perl\ +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; + +File::Basename::fileparse_set_fstype 'UNIX'; +# perl5.003_18 gives '.' +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +# perl5.003_18 gives '/perl/lib' +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t index b229d7c67b..ebaecac21a 100755 --- a/t/lib/bigintpm.t +++ b/t/lib/bigintpm.t @@ -1,8 +1,11 @@ #!./perl -BEGIN { unshift @INC, './lib', '../lib'; - require Config; import Config; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; } + +use Config; use Math::BigInt; $test = 0; diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index 81d32c415b..0e2a7c34eb 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -23,6 +23,21 @@ sub ok print "ok $no\n" ; } +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + $Dfile = "dbbtree.tmp"; unlink $Dfile; @@ -31,16 +46,17 @@ umask(0); # Check the interface to BTREEINFO my $dbh = new DB_File::BTREEINFO ; -$^W = 0 ; -ok(1, $dbh->{flags} == undef) ; -ok(2, $dbh->{cachesize} == undef) ; -ok(3, $dbh->{psize} == undef) ; -ok(4, $dbh->{lorder} == undef) ; -ok(5, $dbh->{minkeypage} == undef) ; -ok(6, $dbh->{maxkeypage} == undef) ; -ok(7, $dbh->{compare} == undef) ; -ok(8, $dbh->{prefix} == undef) ; -$^W = 1 ; +ok(1, $dbh->{flags} == 0) ; +ok(2, $dbh->{cachesize} == 0) ; +ok(3, $dbh->{psize} == 0) ; +ok(4, $dbh->{lorder} == 0) ; +ok(5, $dbh->{minkeypage} == 0) ; +ok(6, $dbh->{maxkeypage} == 0) ; +{ + local $^W = 0 ; + ok(7, $dbh->{compare} == undef) ; + ok(8, $dbh->{prefix} == undef) ; +} $dbh->{flags} = 3000 ; ok(9, $dbh->{flags} == 3000) ; @@ -170,13 +186,9 @@ ok(28, $i == 30) ; ok(29, $#keys == 31) ; #Check that the keys can be retrieved in order -$ok = 1 ; -foreach (keys %h) -{ - ($ok = 0), last if defined $previous && $previous gt $_ ; - $previous = $_ ; -} -ok(30, $ok ) ; +my @b = keys %h ; +my @c = sort lexical @b ; +ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; ok(31, $h{'foo'} eq '' ) ; @@ -229,10 +241,8 @@ $status = $X->del('') ; ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -$^W = 0 ; -ok(43, $h{'q'} eq undef) ; -ok(44, $h{''} eq undef) ; -$^W = 1 ; +ok(43, ! defined $h{'q'}) ; +ok(44, ! defined $h{''}) ; undef $X ; untie %h ; @@ -418,13 +428,14 @@ $Dfile1 = "btree1" ; $Dfile2 = "btree2" ; $Dfile3 = "btree3" ; -$dbh1 = TIEHASH DB_File::BTREEINFO ; -$dbh1->{compare} = sub { $_[0] <=> $_[1] } ; +$dbh1 = new DB_File::BTREEINFO ; +{ local $^W = 0 ; + $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } -$dbh2 = TIEHASH DB_File::BTREEINFO ; +$dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = TIEHASH DB_File::BTREEINFO ; +$dbh3 = new DB_File::BTREEINFO ; $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; @@ -433,14 +444,14 @@ tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; @Keys = qw( 0123 12 -1234 9 987654321 def ) ; -$^W = 0 ; -@srt_1 = sort { $a <=> $b } @Keys ; -$^W = 1 ; +{ local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; } @srt_2 = sort { $a cmp $b } @Keys ; @srt_3 = sort { length $a <=> length $b } @Keys ; foreach (@Keys) { - $^W = 0 ; $h{$_} = 1 ; $^W = 1 ; + { local $^W = 0 ; + $h{$_} = 1 ; } $g{$_} = 1 ; $k{$_} = 1 ; } diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 527dfc9f7a..09c0ee2151 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -1,9 +1,7 @@ -#!./perl -#!./perl -w +#!./perl -w BEGIN { - #@INC = '../lib' if -d '../lib' ; - @INC = '../lib' ; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -14,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..48\n"; +print "1..51\n"; sub ok { @@ -34,14 +32,14 @@ umask(0); my $dbh = new DB_File::HASHINFO ; +ok(1, $dbh->{bsize} == 0) ; +ok(2, $dbh->{ffactor} == 0) ; +ok(3, $dbh->{nelem} == 0) ; +ok(4, $dbh->{cachesize} == 0) ; $^W = 0 ; -ok(1, $dbh->{bsize} == undef) ; -ok(2, $dbh->{ffactor} == undef) ; -ok(3, $dbh->{nelem} == undef) ; -ok(4, $dbh->{cachesize} == undef) ; ok(5, $dbh->{hash} == undef) ; -ok(6, $dbh->{lorder} == undef) ; $^W = 1 ; +ok(6, $dbh->{lorder} == 0) ; $dbh->{bsize} = 3000 ; ok(7, $dbh->{bsize} == 3000 ); @@ -64,9 +62,10 @@ ok(12, $dbh->{lorder} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); -eval '$q = $dbh->{fred}' ; +eval 'my $q = $dbh->{fred}' ; ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + # Now check the interface to HASH ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); @@ -295,7 +294,22 @@ ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $status = $X->fd ; ok(48, $status == -1 ); -untie %h ; undef $X ; +untie %h ; + +{ + # check ability to override the default hashing + my %x ; + my $filename = "xyz" ; + my $hi = new DB_File::HASHINFO ; + $::count = 0 ; + $hi->{hash} = sub { ++$::count ; length $_[0] } ; + ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; + $h{"abc"} = 123 ; + ok(50, $h{"abc"} == 123) ; + untie %x ; + unlink $filename ; + ok(51, $::count >0) ; +} exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 999ca6021a..da3edbf45f 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -21,9 +21,27 @@ sub ok print "not " unless $result ; print "ok $no\n" ; + + return $result ; +} + +sub bad_one +{ + print <<EOM unless $bad_ones++ ; +# +# Some older versions of Berkeley DB will fail tests 51, 53 and 55. +# +# You can safely ignore the errors if you're never going to use the +# broken functionality (recno databases with a modified bval). +# Otherwise you'll have to upgrade your DB library. +# +# If you want to upgrade Berkeley DB, the most recent version is 1.85. +# Check out http://www.bostic.com/db for more details. +# +EOM } -print "1..47\n"; +print "1..55\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -33,15 +51,13 @@ umask(0); # Check the interface to RECNOINFO my $dbh = new DB_File::RECNOINFO ; -$^W = 0 ; -ok(1, $dbh->{bval} == undef ) ; -ok(2, $dbh->{cachesize} == undef) ; -ok(3, $dbh->{psize} == undef) ; -ok(4, $dbh->{flags} == undef) ; -ok(5, $dbh->{lorder} == undef); -ok(6, $dbh->{reclen} == undef); -ok(7, $dbh->{bfname} eq undef); -$^W = 0 ; +ok(1, $dbh->{bval} == 0 ) ; +ok(2, $dbh->{cachesize} == 0) ; +ok(3, $dbh->{psize} == 0) ; +ok(4, $dbh->{flags} == 0) ; +ok(5, $dbh->{lorder} == 0); +ok(6, $dbh->{reclen} == 0); +ok(7, $dbh->{bfname} eq ""); $dbh->{bval} = 3000 ; ok(8, $dbh->{bval} == 3000 ); @@ -181,4 +197,76 @@ untie(@h); unlink $Dfile; +{ + # Check bval defaults to \n + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = `cat $Dfile` ; + unlink $Dfile; + ok(49, $x eq "abc\ndef\n\nghi\n") ; +} + +{ + # Change bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{bval} = "-" ; + ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = `cat $Dfile` ; + unlink $Dfile; + my $ok = ($x eq "abc-def--ghi-") ; + bad_one() unless $ok ; + ok(51, $ok) ; +} + +{ + # Check R_FIXEDLEN with default bval (space) + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{reclen} = 5 ; + ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = `cat $Dfile` ; + unlink $Dfile; + my $ok = ($x eq "abc def ghi ") ; + bad_one() unless $ok ; + ok(53, $ok) ; +} + +{ + # Check R_FIXEDLEN with user-defined bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{bval} = "-" ; + $dbh->{reclen} = 5 ; + ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = `cat $Dfile` ; + unlink $Dfile; + my $ok = ($x eq "abc--def-------ghi--") ; + bad_one() unless $ok ; + ok(55, $ok) ; +} + exit ; diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 4a5d1d756a..b718215a1e 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..3\n"; +print "1..11\n"; $| = 1; @@ -29,6 +29,60 @@ print "not " unless $foo eq "ok 3\n"; print "ok 2\n"; copy "copy-$$", \*STDOUT; +unlink "copy-$$" or die "unlink: $!"; + +open(F,"file-$$"); +copy(*F, "copy-$$"); +open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 4\n"; +unlink "copy-$$" or die "unlink: $!"; +open(F,"file-$$"); +copy(\*F, "copy-$$"); +close(F) or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; +print "not " unless $foo eq "ok 3\n"; +print "ok 5\n"; +unlink "copy-$$" or die "unlink: $!"; + +require IO::File; +$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 6\n"; +unlink "copy-$$" or die "unlink: $!"; +require FileHandle; +my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 7\n"; +unlink "file-$$" or die "unlink: $!"; + +print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); +print "# target disappeared.\nnot " if not -e "copy-$$"; +print "ok 8\n"; + +move "copy-$$", "file-$$" or print "# move did not succeed.\n"; +print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; +open(R, "file-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 9\n"; + +copy "file-$$", "lib"; +open(R, "lib/file-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 10\n"; +unlink "lib/file-$$" or die "unlink: $!"; + +move "file-$$", "lib"; +open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; +print "ok 11\n"; +unlink "lib/file-$$" or die "unlink: $!"; -unlink "file-$$"; -unlink "copy-$$"; diff --git a/t/lib/filehand.t b/t/lib/filehand.t index 0199a52ace..11836f1c52 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bFileHandle\b/ && $^O ne 'VMS') { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; exit 0; } @@ -13,17 +13,70 @@ BEGIN { use FileHandle; use strict subs; +autoflush STDOUT 1; + $mystdout = new_from_fd FileHandle 1,"w"; $| = 1; autoflush $mystdout; -print "1..4\n"; +print "1..11\n"; print $mystdout "ok ",fileno($mystdout),"\n"; $fh = new FileHandle "TEST", O_RDONLY and print "ok 2\n"; + + $buffer = <$fh>; print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; + ungetc $fh 65; CORE::read($fh, $buf,1); print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; + +close $fh; + +$fh = new FileHandle; + +print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer); +print "ok 5\n"; + +$fh->seek(0,0); +print "not " unless (<$fh> eq $buffer); +print "ok 6\n"; + +$fh->seek(0,2); +$line = <$fh>; +print "not " if (defined($line) || !$fh->eof); +print "ok 7\n"; + +print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close); +print "ok 8\n"; + +autoflush STDOUT 0; + +print "not " if ($|); +print "ok 9\n"; + +autoflush STDOUT 1; + +print "not " unless ($|); +print "ok 10\n"; + +($rd,$wr) = FileHandle::pipe; + +if ($^O eq 'VMS' || $^O eq 'os2') { + $wr->autoflush; + $wr->printf("ok %d\n",11); + print $rd->getline; +} +else { + if (fork) { + $wr->close; + print $rd->getline; + } + else { + $rd->close; + $wr->printf("ok %d\n",11); + exit(0); + } +} diff --git a/t/lib/findbin.t b/t/lib/findbin.t index 8d5347cdb7..3e742f9a4f 100755 --- a/t/lib/findbin.t +++ b/t/lib/findbin.t @@ -9,5 +9,5 @@ print "1..1\n"; use FindBin qw($Bin); -print "not " unless $Bin =~ m,t/lib$,; +print "not " unless $Bin =~ m,t[/.]lib\]?$,; print "ok 1\n"; diff --git a/t/lib/getopt.t b/t/lib/getopt.t index ec2ea49059..fb70f10aae 100755 --- a/t/lib/getopt.t +++ b/t/lib/getopt.t @@ -41,7 +41,6 @@ print "ok 7\n"; # Try illegal options, but avoid printing of the error message open(STDERR, ">stderr") || die; -unlink "stderr"; @ARGV = qw(-h help); @@ -69,3 +68,6 @@ print "ok 10\n"; print "not " unless "@ARGV" eq "file"; print "ok 11\n"; + +close STDERR; +unlink "stderr"; diff --git a/t/lib/io_dup.t b/t/lib/io_dup.t index ac1768383a..f5d4544490 100755 --- a/t/lib/io_dup.t +++ b/t/lib/io_dup.t @@ -1,11 +1,20 @@ #!./perl BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } } } diff --git a/t/lib/io_pipe.t b/t/lib/io_pipe.t index 6f9d30c82f..1d050ff4bd 100755 --- a/t/lib/io_pipe.t +++ b/t/lib/io_pipe.t @@ -1,11 +1,21 @@ #!./perl + BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } } } @@ -35,7 +45,7 @@ elsif(defined $pid) } else { - die "# error = $!"; + die; } $pipe = new IO::Pipe; diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t new file mode 100755 index 0000000000..44d9757093 --- /dev/null +++ b/t/lib/io_sel.t @@ -0,0 +1,108 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..21\n"; + +use IO::Select 1.09; + +my $sel = new IO::Select(\*STDIN); +$sel->add(4, 5) == 2 or print "not "; +print "ok 1\n"; + +$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; +print "ok 2\n"; + +@handles = $sel->handles; +print "not " unless $sel->count == 4 && @handles == 4; +print "ok 3\n"; +#print $sel->as_string, "\n"; + +$sel->remove(\*STDIN) == 1 or print "not "; +print "ok 4\n", +; +$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present + or print "not "; +print "ok 5\n"; + +print "not " unless $sel->count == 2; +print "ok 6\n"; +#print $sel->as_string, "\n"; + +$sel->remove(1, 4); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 7\n"; + +$sel = new IO::Select; +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 8\n"; + +$sel->remove([\*STDOUT, 5]); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 9\n"; + +@a = $sel->can_read(); # should return imediately +print "not " unless @a == 0; +print "ok 10\n"; + +# we assume that we can write to STDOUT :-) +$sel->add([\*STDOUT, "ok 12\n"]); + +@a = $sel->can_write; +print "not " unless @a == 1; +print "ok 11\n"; + +my($fd, $msg) = @{shift @a}; +print $fd $msg; + +$sel->add(\*STDOUT); # update + +@a = IO::Select::select(undef, $sel, undef, 1); +print "not " unless @a == 3; +print "ok 13\n"; + +($r, $w, $e) = @a; + +print "not " unless @$r == 0 && @$w == 1 && @$e == 0; +print "ok 14\n"; + +$fd = $w->[0]; +print $fd "ok 15\n"; + +# Test new exists() method +$sel->exists(\*STDIN) and print "not "; +print "ok 16\n"; + +($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; +print "ok 17\n"; + +$fd = $sel->exists(\*STDOUT); +if ($fd) { + print $fd "ok 18\n"; +} else { + print "not ok 18\n"; +} + +$fd = $sel->exists([1, 'foo']); +if ($fd) { + print $fd "ok 19\n"; +} else { + print "not ok 19\n"; +} + +# Try self clearing +$sel->add(5,6,7,8,9,10); +print "not " unless $sel->count == 7; +print "ok 20\n"; + +$sel->remove($sel->handles); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 21\n"; diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 53690b117c..c3701c5655 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -1,14 +1,22 @@ #!./perl BEGIN { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - require Config; import Config; - if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/) && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; - exit 0; + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } } } @@ -17,22 +25,15 @@ print "1..5\n"; use IO::Socket; -$port = 4002 + int(rand(time) & 0xff); -$SIG{ALRM} = sub {}; - -$pid = fork(); - -if($pid) { +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + ) or die "$!"; - $listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - LocalPort => $port - ) or die "$!"; +print "ok 1\n"; - print "ok 1\n"; +$port = $listen->sockport; - # Wake out child - kill(ALRM => $pid); +if($pid = fork()) { $sock = $listen->accept(); print "ok 2\n"; @@ -47,12 +48,8 @@ if($pid) { waitpid($pid,0); print "ok 5\n"; -} elsif(defined $pid) { - - # Wait for a small pause, so that we can ensure the listen socket is setup - # the parent will awake us with a SIGALRM - sleep(10); +} elsif(defined $pid) { $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', @@ -60,9 +57,13 @@ if($pid) { ) or die "$!"; $sock->autoflush(1); + print $sock "ok 3\n"; + print $sock->getline(); + $sock->close; + exit; } else { die; diff --git a/t/lib/io_tell.t b/t/lib/io_tell.t index 5a706fb876..f45d21e095 100755 --- a/t/lib/io_tell.t +++ b/t/lib/io_tell.t @@ -1,14 +1,24 @@ #!./perl -# $RCSfile: tell.t,v $$Revision: 1.1 $$Date: 1996/05/01 10:52:47 $ +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + $tell_file = "TEST"; + } + else { + $tell_file = "Makefile"; + } +} + +use Config; BEGIN { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) { - print "1..0\n"; - exit 0; + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } } } @@ -16,7 +26,7 @@ print "1..13\n"; use IO::File; -$tst = IO::File->new("TEST","r") || die("Can't open TEST"); +$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index e85583fdb3..d8377f6446 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -1,15 +1,23 @@ #!./perl BEGIN { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - require Config; import Config; - if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/ || - $^O eq 'os2') && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; - exit 0; + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } } } @@ -25,7 +33,7 @@ $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); print "ok 1\n"; $udpa->send("ok 2\n",0,$udpb->sockname); -$rem = $udpb->recv($buf="",5); +$udpb->recv($buf="",5); print $buf; $udpb->send("ok 3\n"); $udpa->recv($buf="",5); diff --git a/t/lib/io_xs.t b/t/lib/io_xs.t index bff3d69c4c..3426ebe896 100755 --- a/t/lib/io_xs.t +++ b/t/lib/io_xs.t @@ -1,13 +1,20 @@ #!./perl -$| = 1; BEGIN { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) { - print "1..0\n"; - exit 0; + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } } } diff --git a/t/lib/open2.t b/t/lib/open2.t new file mode 100755 index 0000000000..1cf325a875 --- /dev/null +++ b/t/lib/open2.t @@ -0,0 +1,39 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open2; +#require 'open2.pl'; use subs 'open2'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $^X, '-e', 'print scalar <STDIN>'; +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t new file mode 100755 index 0000000000..a5d7f2e8ee --- /dev/null +++ b/t/lib/open3.t @@ -0,0 +1,114 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open3; +#require 'open3.pl'; use subs 'open3'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..21\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $^X, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, <ERROR> eq "hi error\n"; +ok 5, close(WRITE), $!; +ok 6, close(READ), $!; +ok 7, close(ERROR), $!; +$reaped_pid = waitpid $pid, 0; +ok 8, $reaped_pid == $pid, $reaped_pid; +ok 9, $? == 0, $?; + +# read and error together, both named +$pid = open3 'WRITE', 'READ', 'READ', $^X, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 10\n"; +print scalar <READ>; +print WRITE "ok 11\n"; +print scalar <READ>; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $^X, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 12\n"; +print scalar <READ>; +print WRITE "ok 13\n"; +print scalar <READ>; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $^X, '-e', 'print scalar <STDIN>'; +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar <READ>; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $^X, '-e', 'print scalar <STDIN>'; +print WRITE "ok 16\n"; +waitpid $pid, 0; + +# dup error: This particular case, duping stderr onto the existing +# stdout but putting stdout somewhere else, is a good case because it +# used not to work. +$pid = open3 'WRITE', 'READ', '>&STDOUT', + $^X, '-e', 'print STDERR scalar <STDIN>'; +print WRITE "ok 17\n"; +waitpid $pid, 0; + +# dup reader and error together, both named +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $^X, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 18\n"; +print WRITE "ok 19\n"; +waitpid $pid, 0; + +# dup reader and error together, error empty +$pid = open3 'WRITE', '>&STDOUT', '', $^X, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0; diff --git a/t/lib/posix.t b/t/lib/posix.t index 23007ff059..6ae88c0dd2 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write); use strict subs; $| = 1; -print "1..14\n"; +print "1..17\n"; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -58,8 +58,27 @@ print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; +# Check string conversion functions. + +if ($Config{d_strtod}) { + $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; + ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); + print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n"); + &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; +} else { print "# strtod not present\n", "ok 14\n"; } + +if ($Config{d_strtol}) { + ($n, $x) = &POSIX::strtol('21_PENGUINS'); + print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n"); +} else { print "# strtol not present\n", "ok 15\n"; } + +if ($Config{d_strtoul}) { + ($n, $x) = &POSIX::strtoul('88_TEARS'); + print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n"); +} else { print "# strtoul not present\n", "ok 16\n"; } + # Pick up whether we're really able to dynamically load everything. -print &POSIX::acos(1.0) == 0.0 ? "ok 14\n" : "not ok 14\n"; +print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; $| = 0; print '@#!*$@(!@#$'; diff --git a/t/lib/safe2.t b/t/lib/safe2.t index 61c6c8ffec..586eace6a8 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -119,7 +119,8 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); -print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ? +print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || + $! =~ /A file or directory in the path name does not exist/ ? "ok $t\n" : "not ok $t # $!\n"); $t++; print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; diff --git a/t/lib/searchdict.t b/t/lib/searchdict.t index 69329d65c1..447c425b27 100755 --- a/t/lib/searchdict.t +++ b/t/lib/searchdict.t @@ -41,7 +41,7 @@ EOT use Search::Dict; open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; -unlink "dict-$$"; +binmode DICT; # To make length expected one. print DICT $DICT; my $pos = look *DICT, "abash"; @@ -60,3 +60,6 @@ chomp($word = <DICT>); print "not " if $pos < 0 || $word ne "Aarhus"; print "ok 3\n"; + +close DICT or die "cannot close"; +unlink "dict-$$"; diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t new file mode 100755 index 0000000000..57e89c45e0 --- /dev/null +++ b/t/op/assignwarn.t @@ -0,0 +1,61 @@ +#!./perl + +# +# Verify which OP= operators warn if their targets are undefined. +# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$^W = 1; +my $warn = ""; +$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; + +sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } + +sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } + +print "1..23\n"; + +{ my $x; $x ++; ok 1, ! uninitialized; } +{ my $x; $x --; ok 2, ! uninitialized; } +{ my $x; ++ $x; ok 3, ! uninitialized; } +{ my $x; -- $x; ok 4, ! uninitialized; } + +{ my $x; $x **= 1; ok 5, uninitialized; } + +{ my $x; $x += 1; ok 6, ! uninitialized; } +{ my $x; $x -= 1; ok 7, ! uninitialized; } + +{ my $x; $x .= 1; ok 8, ! uninitialized; } + +{ my $x; $x *= 1; ok 9, uninitialized; } +{ my $x; $x /= 1; ok 10, uninitialized; } +{ my $x; $x %= 1; ok 11, uninitialized; } + +{ my $x; $x x= 1; ok 12, uninitialized; } + +{ my $x; $x &= 1; ok 13, uninitialized; } +{ my $x; $x |= 1; ok 14, ! uninitialized; } +{ my $x; $x ^= 1; ok 15, ! uninitialized; } + +{ my $x; $x &&= 1; ok 16, ! uninitialized; } +{ my $x; $x ||= 1; ok 17, ! uninitialized; } + +{ my $x; $x <<= 1; ok 18, uninitialized; } +{ my $x; $x >>= 1; ok 19, uninitialized; } + +{ my $x; $x &= "x"; ok 20, uninitialized; } +{ my $x; $x |= "x"; ok 21, ! uninitialized; } +{ my $x; $x ^= "x"; ok 22, ! uninitialized; } + +ok 23, $warn eq ''; + +# If we got any errors that we were not expecting, then print them +print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/t/op/bop.t b/t/op/bop.t index 8ebf8d3eeb..0c55029b93 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -1,24 +1,55 @@ #!./perl # -# test the bit operators '&', '|' and '^' +# test the bit operators '&', '|', '^', '~', '<<', and '>>' # -print "1..9\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); +print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); + +# shifts +print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); +print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); + +# signed vs. unsigned +print ((~0 > 0 && do { use integer; ~0 } == -1) + ? "ok 7\n" : "not ok 7\n"); + +my $bits = 0; +for (my $i = ~0; $i; $i >>= 1) { ++$bits; } +my $cusp = 1 << ($bits - 1); + +print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0) + ? "ok 8\n" : "not ok 8\n"); +print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0) + ? "ok 9\n" : "not ok 9\n"); +print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0) + ? "ok 10\n" : "not ok 10\n"); +print (((1 << ($bits - 1)) == $cusp && + do { use integer; 1 << ($bits - 1) } == -$cusp) + ? "ok 11\n" : "not ok 11\n"); +print ((($cusp >> 1) == ($cusp / 2) && + do { use integer; $cusp >> 1 } == -($cusp / 2)) + ? "ok 12\n" : "not ok 12\n"); # short strings -print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 4\n" : "not ok 4\n"); -print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 5\n" : "not ok 5\n"); -print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 6\n" : "not ok 6\n"); +print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n"); # long strings $foo = "A" x 150; $bar = "z" x 75; -print (($foo & $bar) eq ('@'x75 ) ? "ok 7\n" : "not ok 7\n"); -print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 8\n" : "not ok 8\n"); -print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 9\n" : "not ok 9\n"); +print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n"); +print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n"); +print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n"); diff --git a/t/op/cmp.t b/t/op/cmp.t new file mode 100755 index 0000000000..aba7c2e9dc --- /dev/null +++ b/t/op/cmp.t @@ -0,0 +1,35 @@ +#!./perl + +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); + +$expect = ($#FOO+2) * ($#FOO+1); +print "1..$expect\n"; + +my $ok = 0; +for my $i (0..$#FOO) { + for my $j ($i..$#FOO) { + $ok++; + my $cmp = $FOO[$i] <=> $FOO[$j]; + if (!defined($cmp) || + $cmp == -1 && $FOO[$i] < $FOO[$j] || + $cmp == 0 && $FOO[$i] == $FOO[$j] || + $cmp == 1 && $FOO[$i] > $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] <=> $FOO[$j])\n"; + } + $ok++; + $cmp = $FOO[$i] cmp $FOO[$j]; + if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || + $cmp == 0 && $FOO[$i] eq $FOO[$j] || + $cmp == 1 && $FOO[$i] gt $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] cmp $FOO[$j])\n"; + } + } +} diff --git a/t/op/delete.t b/t/op/delete.t index 010cbf1003..4e00566cd7 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -2,11 +2,13 @@ # $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ -print "1..7\n"; +print "1..16\n"; $foo{1} = 'a'; $foo{2} = 'b'; $foo{3} = 'c'; +$foo{4} = 'd'; +$foo{5} = 'e'; $foo = delete $foo{2}; @@ -14,9 +16,21 @@ if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} +if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} +if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} + +@foo = delete @foo{4, 5}; + +if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} +if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} +if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} +if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} +if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} $foo = join('',values(foo)); -if ($foo eq 'ac' || $foo eq 'ca') {print "ok 5\n";} else {print "not ok 5\n";} +if ($foo eq 'ac' || $foo eq 'ca') {print "ok 14\n";} else {print "not ok 14\n";} foreach $key (keys foo) { delete $foo{$key}; @@ -26,7 +40,7 @@ $foo{'foo'} = 'x'; $foo{'bar'} = 'y'; $foo = join('',values(foo)); -if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";} +print +($foo eq 'xy' || $foo eq 'yx') ? "ok 15\n" : "not ok 15\n"; $refhash{"top"}->{"foo"} = "FOO"; $refhash{"top"}->{"bar"} = "BAR"; @@ -34,4 +48,4 @@ $refhash{"top"}->{"bar"} = "BAR"; delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; -print "@list" eq "foo" ? "ok 7\n" : "not ok 7 @list\n"; +print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; diff --git a/t/op/each.t b/t/op/each.t index 4106e54c50..b92dd1770c 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -2,7 +2,7 @@ # $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $ -print "1..7\n"; +print "1..14\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -68,3 +68,42 @@ undef %h; %h = (1,1); $size = ((split('/',scalar %h))[1]); if ($size == 8) {print "ok 7\n";} else {print "not ok 7\n";} + +# test scalar each +%hash = 1..20; +$total = 0; +$total += $key while $key = each %hash; +print "# Scalar each is bad.\nnot " unless $total == 100; +print "ok 8\n"; + +for (1..3) { @foo = each %hash } +keys %hash; +$total = 0; +$total += $key while $key = each %hash; +print "# Scalar keys isn't resetting the iterator.\nnot " if $total != 100; +print "ok 9\n"; + +for (1..3) { @foo = each %hash } +$total = 0; +$total += $key while $key = each %hash; +print "# Iterator of each isn't being maintained.\nnot " if $total == 100; +print "ok 10\n"; + +for (1..3) { @foo = each %hash } +values %hash; +$total = 0; +$total += $key while $key = each %hash; +print "# Scalar values isn't resetting the iterator.\nnot " if $total != 100; +print "ok 11\n"; + +$size = (split('/', scalar %hash))[1]; +keys(%hash) = $size / 2; +print "not " if $size != (split('/', scalar %hash))[1]; +print "ok 12\n"; +keys(%hash) = $size + 100; +print "not " if $size == (split('/', scalar %hash))[1]; +print "ok 13\n"; + +print "not " if keys(%hash) != 10; +print "ok 14\n"; + diff --git a/t/op/magic.t b/t/op/magic.t index b46dade75d..a050510f38 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -2,17 +2,35 @@ # $RCSfile: magic.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:05 $ -$| = 1; # command buffering +BEGIN { + $^W = 1; + $| = 1; + chdir 't' if -d 't'; + @INC = '../lib'; + $SIG{__WARN__} = sub { die @_ }; +} -print "1..6\n"; +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +print "1..28\n"; eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval -if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} +ok 1, `echo \$foo` eq "hi there\n"; unlink 'ajslkdfpqjsjfk'; $! = 0; -open(foo,'ajslkdfpqjsjfk'); -if ($!) {print "ok 2\n";} else {print "not ok 2\n";} +open(FOO,'ajslkdfpqjsjfk'); +ok 2, $!, $!; +close FOO; # just mention it, squelch used-only-once # the next tests are embedded inside system simply because sh spits out # a newline onto stderr when a child process kills itself with SIGINT. @@ -38,8 +56,63 @@ END @val1 = @ENV{keys(%ENV)}; # can we slice ENV? @val2 = values(%ENV); +ok 5, join(':',@val1) eq join(':',@val2); +ok 6, @val1 > 1; + +# regex vars +'foobarbaz' =~ /b(a)r/; +ok 7, $` eq 'foo', $`; +ok 8, $& eq 'bar', $&; +ok 9, $' eq 'baz', $'; +ok 10, $+ eq 'a', $+; + +# $" +@a = qw(foo bar baz); +ok 11, "@a" eq "foo bar baz", "@a"; +{ + local $" = ','; + ok 12, "@a" eq "foo,bar,baz", "@a"; +} -print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n"; +# $; +%h = (); +$h{'foo', 'bar'} = 1; +ok 13, (keys %h)[0] eq "foo\034bar", (keys %h)[0]; +{ + local $; = 'x'; + %h = (); + $h{'foo', 'bar'} = 1; + ok 14, (keys %h)[0] eq 'fooxbar', (keys %h)[0]; +} -print @val1 > 1 ? "ok 6\n" : "not ok 6\n"; +# $?, $@, $$ +system 'true'; +ok 15, $? == 0, $?; +system 'false'; +ok 16, $? != 0, $?; + +eval { die "foo\n" }; +ok 17, $@ eq "foo\n", $@; + +ok 18, $$ > 0, $$; + +# $^X and $0 +$script = './show-shebang'; +ok 19, open(SCRIPT, ">$script"), $!; +ok 20, print(SCRIPT <<'EOF'), $!; +#!./perl +print "\$^X is $^X, \$0 is $0\n"; +EOF +ok 21, close(SCRIPT), $!; +ok 22, chmod(0755, $script), $!; +$s = "\$^X is ./perl, \$0 is $script\n"; +$_ = `$script`; +ok 23, $_ eq $s, ":$_:"; +$_ = `./perl $script`; +ok 24, $_ eq $s, ":$_:"; +ok 25, unlink($script), $!; +# $], $^O, $^T +ok 26, $] >= 5.00319, $]; +ok 27, $^O; +ok 28, $^T > 850000000, $^T; diff --git a/t/op/method.t b/t/op/method.t new file mode 100755 index 0000000000..bdbc8a9673 --- /dev/null +++ b/t/op/method.t @@ -0,0 +1,108 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..20\n"; + +@A::ISA = 'B'; +@B::ISA = 'C'; + +sub C::d {"C::d"} +sub D::d {"D::d"} + +my $cnt = 0; +sub test { + print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; + # print "not " unless shift eq shift; + print "ok ", ++$cnt, "\n" +} + +test( A->d, "C::d"); # Update hash table; + +*B::d = \&D::d; # Import now. +test (A->d, "D::d"); # Update hash table; + +{ + local *B::d; + eval 'sub B::d {"B::d1"}'; # Import now. + test (A->d, "B::d1"); # Update hash table; + undef &B::d; + test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); +} + +test (A->d, "D::d"); # Back to previous state + +eval 'sub B::d {"B::d2"}'; # Import now. +test (A->d, "B::d2"); # Update hash table; + +# What follows is hardly guarantied to work, since the names in scripts +# are already linked to "pruned" globs. Say, `undef &B::d' if it were +# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. + +undef &B::d; +delete $B::{d}; +test (A->d, "C::d"); # Update hash table; + +eval 'sub B::d {"B::d3"}'; # Import now. +test (A->d, "B::d3"); # Update hash table; + +delete $B::{d}; +*dummy::dummy = sub {}; # Mark as updated +test (A->d, "C::d"); + +eval 'sub B::d {"B::d4"}'; # Import now. +test (A->d, "B::d4"); # Update hash table; + +delete $B::{d}; # Should work without any help too +test (A->d, "C::d"); + +*A::x = *A::d; # See if cache incorrectly follows synonyms +A->d; +test (eval { A->x } || "nope", "nope"); + +eval <<'EOF'; +sub C::e; +sub Y::f; +$counter = 0; + +@X::ISA = 'Y'; +@Y::ISA = 'B'; + +sub B::AUTOLOAD { + my $c = ++$counter; + my $method = $B::AUTOLOAD; + *$B::AUTOLOAD = sub { "B: In $method, $c" }; + goto &$B::AUTOLOAD; +} +sub C::AUTOLOAD { + my $c = ++$counter; + my $method = $C::AUTOLOAD; + *$C::AUTOLOAD = sub { "C: In $method, $c" }; + goto &$C::AUTOLOAD; +} +EOF + +test(A->e(), "C: In C::e, 1"); # We get a correct autoload +test(A->e(), "C: In C::e, 1"); # Which sticks + +test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top +test(A->ee(), "B: In A::ee, 2"); # Which sticks + +test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method +test(Y->f(), "B: In Y::f, 3"); # Which sticks + +# This test is not intended to be reasonable. It is here just to let you +# know that you broke some old construction. Feel free to rewrite the test +# if your patch breaks it. + +*B::AUTOLOAD = sub { + my $c = ++$counter; + my $method = $AUTOLOAD; + *$AUTOLOAD = sub { "new B: In $method, $c" }; + goto &$AUTOLOAD; +}; + +test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload +test(A->eee(), "new B: In A::eee, 4"); # Which sticks diff --git a/t/op/misc.t b/t/op/misc.t index e3bf57638d..4f47f0f7af 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -37,6 +37,18 @@ for (@prgs){ } __END__ +()=() +######## +$a = ":="; split /($a)/o, "a:=b:=c"; print "@_" +EXPECT +a := b := c +######## +$cusp = ~0 ^ (~0 >> 1); +$, = " "; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +EXPECT +7 0 0 1 ! +######## $foo=undef; $foo->go; EXPECT Can't call method "go" without a package or object reference at - line 1. @@ -196,3 +208,64 @@ EXPECT This is a reversed sentence. -- Out of inspiration -- and destroyed as well +######## +my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" +EXPECT +2 2 2 +######## +@a = ($a, $b, $c, $d) = (5, 6); +print "ok\n" + if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); +EXPECT +ok +######## +print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); +EXPECT +ok +######## +print "ok\n" if ("\0" lt "\xFF"); +EXPECT +ok +######## +open(H,'op/misc.t'); # must be in the 't' directory +stat(H); +print "ok\n" if (-e _ and -f _ and -r _); +EXPECT +ok +######## +sub thing { 0 || return qw(now is the time) } +print thing(), "\n"; +EXPECT +nowisthetime +######## +$ren = 'joy'; +$stimpy = 'happy'; +{ local $main::{ren} = *stimpy; print $ren, ' ' } +print $ren, "\n"; +EXPECT +happy joy +######## +$stimpy = 'happy'; +{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' } +print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; +EXPECT +happy joy +######## +package p; +sub func { print 'really ' unless wantarray; 'p' } +sub groovy { 'groovy' } +package main; +print p::func()->groovy(), "\n" +EXPECT +really groovy +######## +($k, $s) = qw(x 0); +@{$h{$k}} = qw(1 2 4); +for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } +print "bogus\n" unless $s == 7; +######## +my $a = 'outer'; +eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; +eval { my $x = 'peace'; eval q[ print "$x\n" ] } +EXPECT +inner peace @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ +# $RCSfile: my.t,v $ -print "1..20\n"; +print "1..28\n"; sub foo { my($a, $b) = @_; @@ -44,3 +44,42 @@ $d{''} = "ok 18\n"; print &foo2("ok 11\n","ok 12\n"); print $a,@b,@c,%d,$x,$y; + +my $i = "outer"; + +if (my $i = "inner") { + print "not " if $i ne "inner"; +} +print "ok 21\n"; + +if ((my $i = 1) == 0) { + print "not "; +} +else { + print "not" if $i != 1; +} +print "ok 22\n"; + +my $j = 5; +while (my $i = --$j) { + print("not "), last unless $i > 0; +} +continue { + print("not "), last unless $i > 0; +} +print "ok 23\n"; + +$j = 5; +for (my $i = 0; (my $k = $i) < $j; ++$i) { + print("not "), last unless $i >= 0 && $i < $j && $i == $k; +} +print "ok 24\n"; +print "not " if defined $k; +print "ok 25\n"; + +foreach my $i (26, 27) { + print "ok $i\n"; +} + +print "not " if $i ne "outer"; +print "ok 28\n"; diff --git a/t/op/oct.t b/t/op/oct.t index 7890643aef..24b5c4309d 100755 --- a/t/op/oct.t +++ b/t/op/oct.t @@ -2,7 +2,7 @@ # $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ -print "1..6\n"; +print "1..8\n"; print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; @@ -10,3 +10,5 @@ print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; +print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; +print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; diff --git a/t/op/pack.t b/t/op/pack.t index f15a7033ab..b11fe234e7 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..16\n"; +print "1..25\n"; $format = "c2x5CCxsdila6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -47,25 +47,26 @@ print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF # check 'w' my $test=10; -my @x = (5,130,256,560,32000,3097152,268435455,2**30+20, 2**56+4711); +my @x = (5,130,256,560,32000,3097152,268435455,1073741844, + '4503599627365785','23728385234614992549757750638446'); my $x = pack('w*', @x); -my $y = pack 'C*', 5,129,2,130,0,132,48,129,250,0,129,189,132,64,255,255,255, - 127,132,128,128,128,20,129,128,128,128,128,128,128,164,96; +my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++; @y = unpack('w*', $y); -my $a = join ':', @x; -my $b = join ':', @y; - -print $a eq $b ? "ok $test\n" : "not ok $test\n"; $test++; +my $a; +while ($a = pop @x) { + my $b = pop @y; + print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; +} @y = unpack('w2', $x); print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++; -# test exections +# test exeptions eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; diff --git a/t/op/pat.t b/t/op/pat.t index d93e6d66e2..d9941fa816 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..60\n"; +print "1..61\n"; $x = "abc\ndef\n"; @@ -134,17 +134,19 @@ print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" : "not ok 45\n"; @words = (); +pos = 0; while (/to/g) { push(@words, $&); } print join(':',@words) eq "to:to" ? "ok 46\n" - : "not ok 46 @words\n"; + : "not ok 46 `@words'\n"; +pos $_ = 0; @words = /to/g; print join(':',@words) eq "to:to" ? "ok 47\n" - : "not ok 47 @words\n"; + : "not ok 47 `@words'\n"; $_ = "abcdefghi"; @@ -191,12 +193,14 @@ $x=/abc/g; print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; $x=/abc/g; print $x == 0 ? "ok 54\n" : "not ok 54\n"; +pos = 0; $x=/ABC/gi; print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; $x=/ABC/gi; print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; $x=/ABC/gi; print $x == 0 ? "ok 57\n" : "not ok 57\n"; +pos = 0; $x=/abc/g; print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; $x=/abc/g; @@ -204,3 +208,9 @@ print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; $_ .= ''; @x=/abc/g; print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; + +$_ = "abdc"; +pos $_ = 2; +/\Gc/g; +print "not " if (pos $_) != 2; +print "ok 61\n"; diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t index 09794571b1..20dd312b31 100755 --- a/t/op/quotemeta.t +++ b/t/op/quotemeta.t @@ -1,15 +1,15 @@ #!./perl print "1..15\n"; -$_=join "", grep $_=chr($_), 32..127; +$_=join "", map chr($_), 32..127; -#95 characters - 52 letters - 10 digits = 33 backslashes -#95 characters + 33 backslashes = 128 characters +# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes +# 96 characters + 33 backslashes = 129 characters $_=quotemeta $_; -if ( length == 128 ){print "ok 1\n"} else {print "not ok 1\n"} -if (tr/\\//cd == 94){print "ok 2\n"} else {print "not ok 2\n"} +if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} +# 95 non-backslash characters +if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} -#perl5a11 bus errors on this: if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n"; diff --git a/t/op/rand.t b/t/op/rand.t index 5c0eccf15f..6031f421b1 100755 --- a/t/op/rand.t +++ b/t/op/rand.t @@ -2,28 +2,34 @@ # From: kgb@ast.cam.ac.uk (Karl Glazebrook) -print "1..4\n"; +print "1..6\n"; srand; -$m=0; +$m=$max=0; for(1..1000){ $n = rand(1); - if ($n<0 || $n>=1) { + if ($n<0) { print "not ok 1\n# The value of randbits is likely too low in config.sh\n"; exit } $m += $n; - + $max = $n if $n > $max; } $m=$m/1000; print "ok 1\n"; +$off = log($max)/log(2); +if ($off > 0) { $off = int(.5+$off) } + else { $off = - int(.5-$off) } +print "# Consider adding $off to randbits\n" if $off > 0; +print "# Consider subtracting ", -$off, " from randbits\n" if $off < 0; + if ($m<0.4) { print "not ok 2\n# The value of randbits is likely too high in config.sh\n"; } elsif ($m>0.6) { - print "not ok 2\n# Something's really weird about rand()'s distribution.\n"; + print "not ok 2\n# The value of randbits is likely too low in config.sh\n"; }else{ print "ok 2\n"; } @@ -49,4 +55,12 @@ if ($m<40 || $m>60) { print "ok 4\n"; } +srand(3.14159); +$r = rand; +srand(3.14159); +print "# srand is not consistent.\nnot " if rand != $r; +print "ok 5\n"; + +print "# rand is unchanging!\nnot " if rand == $r; +print "ok 6\n"; diff --git a/t/op/re_tests b/t/op/re_tests index f8c4c6eafb..c20fb89e80 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -53,6 +53,42 @@ a[^-b]c adc y $& adc a[^-b]c a-c n - - a[^]b]c a]c n - - a[^]b]c adc y $& adc +\ba\b a- y - - +\ba\b -a y - - +\ba\b -a- y - - +\by\b xy n - - +\by\b yz n - - +\by\b xyz n - - +\Ba\B a- n - - +\Ba\B -a n - - +\Ba\B -a- n - - +\By\b xy y - - +\by\B yz y - - +\By\B xyz y - - +\w a y - - +\w - n - - +\W a n - - +\W - y - - +a\sb a b y - - +a\sb a-b n - - +a\Sb a b n - - +a\Sb a-b y - - +\d 1 y - - +\d - n - - +\D 1 n - - +\D - y - - +[\w] a y - - +[\w] - n - - +[\W] a n - - +[\W] - y - - +a[\s]b a b y - - +a[\s]b a-b n - - +a[\S]b a b n - - +a[\S]b a-b y - - +[\d] 1 y - - +[\d] - n - - +[\D] 1 n - - +[\D] - y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- diff --git a/t/op/recurse.t b/t/op/recurse.t new file mode 100755 index 0000000000..6b21c66106 --- /dev/null +++ b/t/op/recurse.t @@ -0,0 +1,90 @@ +#!./perl + +# +# test recursive functions. +# + +print "1..23\n"; + +sub gcd ($$) { + return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); + return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); + $_[0]; +} + +sub factorial ($) { + $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); +} + +sub fibonacci ($) { + $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); +} + +# Highly recursive, highly aggressive. +# Kids, don't try this at home. +# For example ackermann(4,0) will take quite a long time. +# +# In fact, the current Perl, 5.004, will complain loudly: +# "Deep recursion on subroutine." (see perldiag) when +# computing the ackermann(4,0) because the recursion will +# become so deep (>100 levels) that Perl suspects the script +# has been lost in an infinite recursion. + +sub ackermann ($$) { + return $_[1] + 1 if ($_[0] == 0); + return ackermann($_[0] - 1, 1) if ($_[1] == 0); + ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); +} + +# Highly recursive, highly boring. + +sub takeuchi ($$$) { + $_[1] < $_[0] ? + takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), + takeuchi($_[1] - 1, $_[2], $_[0]), + takeuchi($_[2] - 1, $_[0], $_[1])) + : $_[2]; +} + +print 'not ' unless (($d = gcd(1147, 1271)) == 31); +print "ok 1\n"; +print "# gcd(1147, 1271) = $d\n"; + +print 'not ' unless (($d = gcd(1908, 2016)) == 36); +print "ok 2\n"; +print "# gcd(1908, 2016) = $d\n"; + +print 'not ' unless (($f = factorial(10)) == 3628800); +print "ok 3\n"; +print "# factorial(10) = $f\n"; + +print 'not ' unless (($f = factorial(factorial(3))) == 720); +print "ok 4\n"; +print "# factorial(factorial(3)) = $f\n"; + +print 'not ' unless (($f = fibonacci(10)) == 89); +print "ok 5\n"; +print "# fibonacci(10) = $f\n"; + +print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711); +print "ok 6\n"; +print "# fibonacci(fibonacci(7)) = $f\n"; + +$i = 7; + +@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); + +for $x (0..3) { + for $y (0..3) { + $a = ackermann($x, $y); + print 'not ' unless ($a == shift(@ack)); + print "ok ", $i++, "\n"; + print "# ackermann($x, $y) = $a\n"; + } +} + +($x, $y, $z) = (18, 12, 6); + +print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); +print "ok ", $i++, "\n"; +print "# takeuchi($x, $y, $z) = $t\n"; diff --git a/t/op/stat.t b/t/op/stat.t index 0ec31689cd..b018b6cb2c 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -116,8 +116,9 @@ if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} $cnt = $uid = 0; die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -print ("not ok 35\n"), goto tty_test unless -d '/usr/bin'; -chdir '/usr/bin' || die "Can't cd to /usr/bin"; +($bin) = grep {-d} qw(/bin /usr/bin) + or print ("not ok 35\n"), goto tty_test; +chdir $bin || die "Can't cd to $bin: $!"; while (defined($_ = <*>)) { $cnt++; $uid++ if -u; diff --git a/t/op/sysio.t b/t/op/sysio.t new file mode 100755 index 0000000000..0f546b270f --- /dev/null +++ b/t/op/sysio.t @@ -0,0 +1,175 @@ +#!./perl + +print "1..30\n"; + +chdir('op') || die "sysio.t: cannot look for myself: $!"; + +open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; + +$reopen = ($^O eq 'VMS' || $^O eq 'os2'); + +$x = 'abc'; + +# should not be able to do negative lengths +eval { sysread(I, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 1\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 2\n"; + +# should not be able to read before the buffer +eval { sysread(I, $x, 1, -4) }; +print 'not ' unless ($x eq 'abc'); +print "ok 3\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 4\n"; + +$a ='0123456789'; + +# default offset 0 +print 'not ' unless(sysread(I, $a, 3) == 3); +print "ok 5\n"; + +# $a should be as follows +print 'not ' unless ($a eq '#!.'); +print "ok 6\n"; + +# reading past the buffer should zero pad +print 'not ' unless(sysread(I, $a, 2, 5) == 2); +print "ok 7\n"; + +# the zero pad should be seen now +print 'not ' unless ($a eq "#!.\0\0/p"); +print "ok 8\n"; + +# try changing the last two characters of $a +print 'not ' unless(sysread(I, $a, 3, -2) == 3); +print "ok 9\n"; + +# the last two characters of $a should have changed (into three) +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 10\n"; + +$outfile = 'sysio.out'; + +open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; + +select(O); $|=1; select(STDOUT); + +# cannot write negative lengths +eval { syswrite(O, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 11\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 12\n"; + +# $outfile still intact +print 'not ' if (-s $outfile); +print "ok 13\n"; + +# should not be able to write from after the buffer +eval { syswrite(O, $x, 1, 3) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 14\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 15\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 16\n"; + +# should not be able to write from before the buffer + +eval { syswrite(O, $x, 1, -4) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 17\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 18\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 19\n"; + +# default offset 0 +print 'not ' unless (syswrite(O, $a, 2) == 2); +print "ok 20\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 21\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 2); +print "ok 22\n"; + +# with offset +print 'not ' unless (syswrite(O, $a, 2, 5) == 2); +print "ok 23\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 24\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 4); +print "ok 25\n"; + +# with negative offset and a bit too much length +print 'not ' unless (syswrite(O, $a, 5, -3) == 3); +print "ok 26\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 27\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 7); +print "ok 28\n"; + +close(O); + +open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; + +$b = 'xyz'; + +# reading too much only return as much as available +print 'not ' unless (sysread(I, $b, 100) == 7); +print "ok 29\n"; +# this we should have +print 'not ' unless ($b eq '#!ererl'); +print "ok 30\n"; + +close(I); + +unlink $outfile; + +chdir('..'); + +1; + +# eof diff --git a/t/op/tie.t b/t/op/tie.t index cf116519e6..77e74db4e2 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -3,7 +3,7 @@ # This test harness will (eventually) test the "tie" functionality # without the need for a *DBM* implementation. -# Currently it only tests use strict "untie". +# Currently it only tests the untie warning chdir 't' if -d 't'; @INC = "../lib"; @@ -11,6 +11,9 @@ $ENV{PERL5LIB} = "../lib"; $|=1; +# catch warnings into fatal errors +$SIG{__WARN__} = sub { die "WARNING: @_" } ; + undef $/; @prgs = split "\n########\n", <DATA>; print "1..", scalar @prgs, "\n"; @@ -22,7 +25,7 @@ for (@prgs){ $results = $@ ; $results =~ s/\n+$//; $expected =~ s/\n+$//; - if ( $status or $results !~ /^$expected/){ + if ( $status or $results and $results !~ /^WARNING: $expected/){ print STDERR "STATUS: $status\n"; print STDERR "PROG: $prog\n"; print STDERR "EXPECTED:\n$expected\n"; @@ -74,7 +77,8 @@ EXPECT ######## # strict behaviour, without any extra references -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -82,26 +86,29 @@ EXPECT ######## # strict behaviour, with 1 extra references generating an error -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT -Can't untie: 1 inner references still exist at +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references via tied generating an error -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT -Can't untie: 1 inner references still exist at +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references which are destroyed -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -110,7 +117,8 @@ EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -120,22 +128,25 @@ EXPECT ######## # strict error behaviour, with 2 extra references -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; untie %h; EXPECT -Can't untie: 2 inner references still exist at +untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. -no strict 'untie'; +#no warning 'untie'; +local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { - use strict 'untie'; + #use warning 'untie'; + local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; diff --git a/t/op/universal.t b/t/op/universal.t new file mode 100755 index 0000000000..3e075cff43 --- /dev/null +++ b/t/op/universal.t @@ -0,0 +1,38 @@ +#!./perl +# +# check UNIVERSAL +# + +print "1..4\n"; + +# explicit bless + +$a = {}; +bless $a, "Bob"; +if ($a->class eq "Bob") {print "ok 1\n";} else {print "not ok 1\n";} + +# bless through a package + +package Fred; + +$b = {}; +bless $b; +if ($b->class eq "Fred") {print "ok 2\n";} else {print "not ok 2\n";} + +package main; + +# same as test 1 and 2, but with other object syntax + +# explicit bless + +$a = {}; +bless $a, "Bob"; +if (class $a eq "Bob") {print "ok 3\n";} else {print "not ok 3\n";} + +# bless through a package + +package Fred; + +$b = {}; +bless $b; +if (class $b eq "Fred") {print "ok 4\n";} else {print "not ok 4\n";} diff --git a/t/op/write.t b/t/op/write.t index d14cef3cd6..46ec8130b9 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -2,7 +2,7 @@ # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ -print "1..3\n"; +print "1..5\n"; format OUT = the quick brown @<< @@ -133,3 +133,35 @@ if (`cat Op_write.tmp` eq $right) else { print "not ok 3\n"; } +# formline tests + +$mustbe = <<EOT; +@ a +@> ab +@>> abc +@>>> abc +@>>>> abc +@>>>>> abc +@>>>>>> abc +@>>>>>>> abc +@>>>>>>>> abc +@>>>>>>>>> abc +@>>>>>>>>>> abc +EOT + +$was1 = $was2 = ''; +for (0..10) { + # lexical picture + $^A = ''; + my $format1 = '@' . '>' x $_; + formline $format1, 'abc'; + $was1 .= "$format1 $^A\n"; + # global + $^A = ''; + local $format2 = '@' . '>' x $_; + formline $format2, 'abc'; + $was2 .= "$format2 $^A\n"; +} +print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; +print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; + diff --git a/t/pragma/locale.t b/t/pragma/locale.t new file mode 100755 index 0000000000..0f71da434b --- /dev/null +++ b/t/pragma/locale.t @@ -0,0 +1,449 @@ +#!./perl -wT + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +my $have_setlocale = 0; +eval { + require POSIX; + import POSIX ':locale_h'; + $have_setlocale++; +}; + +print "1..", ($have_setlocale ? 104 : 98), "\n"; + +use vars qw($a + $English $German $French $Spanish + @C @English @German @French @Spanish + $Locale @Locale %iLocale %UPPER %lower @Neoalpha); + +$a = 'abc %'; + +sub ok { + my ($n, $result) = @_; + + print 'not ' unless ($result); + print "ok $n\n"; +} + +# First we'll do a lot of taint checking for locales. +# This is the easiest to test, actually, as any locale, +# even the default locale will taint under 'use locale'. + +sub is_tainted { # hello, camel two. + my $dummy; + not eval { $dummy = join("", @_), kill 0; 1 } +} + +sub check_taint ($$) { + ok $_[0], is_tainted($_[1]); +} + +sub check_taint_not ($$) { + ok $_[0], not is_tainted($_[1]); +} + +use locale; # engage locale and therefore locale taint. + +check_taint_not 1, $a; + +check_taint 2, uc($a); +check_taint 3, "\U$a"; +check_taint 4, ucfirst($a); +check_taint 5, "\u$a"; +check_taint 6, lc($a); +check_taint 7, "\L$a"; +check_taint 8, lcfirst($a); +check_taint 9, "\l$a"; + +check_taint 10, sprintf('%e', 123.456); +check_taint 11, sprintf('%f', 123.456); +check_taint 12, sprintf('%g', 123.456); +check_taint_not 13, sprintf('%d', 123.456); +check_taint_not 14, sprintf('%x', 123.456); + +$_ = $a; # untaint $_ + +$_ = uc($a); # taint $_ + +check_taint 15, $_; + +/(\w)/; # taint $&, $`, $', $+, $1. +check_taint 16, $&; +check_taint 17, $`; +check_taint 18, $'; +check_taint 19, $+; +check_taint 20, $1; +check_taint_not 21, $2; + +/(.)/; # untaint $&, $`, $', $+, $1. +check_taint_not 22, $&; +check_taint_not 23, $`; +check_taint_not 24, $'; +check_taint_not 25, $+; +check_taint_not 26, $1; +check_taint_not 27, $2; + +/(\W)/; # taint $&, $`, $', $+, $1. +check_taint 28, $&; +check_taint 29, $`; +check_taint 30, $'; +check_taint 31, $+; +check_taint 32, $1; +check_taint_not 33, $2; + +/(\s)/; # taint $&, $`, $', $+, $1. +check_taint 34, $&; +check_taint 35, $`; +check_taint 36, $'; +check_taint 37, $+; +check_taint 38, $1; +check_taint_not 39, $2; + +/(\S)/; # taint $&, $`, $', $+, $1. +check_taint 40, $&; +check_taint 41, $`; +check_taint 42, $'; +check_taint 43, $+; +check_taint 44, $1; +check_taint_not 45, $2; + +$_ = $a; # untaint $_ + +check_taint_not 46, $_; + +/(b)/; # this must not taint +check_taint_not 47, $&; +check_taint_not 48, $`; +check_taint_not 49, $'; +check_taint_not 50, $+; +check_taint_not 51, $1; +check_taint_not 52, $2; + +$_ = $a; # untaint $_ + +check_taint_not 53, $_; + +$b = uc($a); # taint $b +s/(.+)/$b/; # this must taint only the $_ + +check_taint 54, $_; +check_taint_not 55, $&; +check_taint_not 56, $`; +check_taint_not 57, $'; +check_taint_not 58, $+; +check_taint_not 59, $1; +check_taint_not 60, $2; + +$_ = $a; # untaint $_ + +s/(.+)/b/; # this must not taint +check_taint_not 61, $_; +check_taint_not 62, $&; +check_taint_not 63, $`; +check_taint_not 64, $'; +check_taint_not 65, $+; +check_taint_not 66, $1; +check_taint_not 67, $2; + +$b = $a; # untaint $b + +($b = $a) =~ s/\w/$&/; +check_taint 68, $b; # $b should be tainted. +check_taint_not 69, $a; # $a should be not. + +$_ = $a; # untaint $_ + +s/(\w)/\l$1/; # this must taint +check_taint 70, $_; +check_taint 71, $&; +check_taint 72, $`; +check_taint 73, $'; +check_taint 74, $+; +check_taint 75, $1; +check_taint_not 76, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\L$1/; # this must taint +check_taint 77, $_; +check_taint 78, $&; +check_taint 79, $`; +check_taint 80, $'; +check_taint 81, $+; +check_taint 82, $1; +check_taint_not 83, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\u$1/; # this must taint +check_taint 84, $_; +check_taint 85, $&; +check_taint 86, $`; +check_taint 87, $'; +check_taint 88, $+; +check_taint 89, $1; +check_taint_not 90, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\U$1/; # this must taint +check_taint 91, $_; +check_taint 92, $&; +check_taint 93, $`; +check_taint 94, $'; +check_taint 95, $+; +check_taint 96, $1; +check_taint_not 97, $2; + +# After all this tainting $a should be cool. + +check_taint_not 98, $a; + +# I think we've seen quite enough of taint. +# Let us do some *real* locale work now, +# unless setlocale() is missing (i.e. minitest). + +exit unless $have_setlocale; + +sub getalnum { + sort grep /\w/, map { chr } 0..255 +} + +sub locatelocale ($$@) { + my ($lcall, $alnum, @try) = @_; + + undef $$lcall; + + for (@try) { + local $^W = 0; # suppress "Subroutine LC_ALL redefined" + if (setlocale(&LC_ALL, $_)) { + $$lcall = $_; + @$alnum = &getalnum; + last; + } + } + + @$alnum = () unless (defined $$lcall); +} + +# Find some default locale + +locatelocale(\$Locale, \@Locale, qw(C POSIX)); + +# Find some English locale + +locatelocale(\$English, \@English, + qw(en_US.ISO8859-1 en_GB.ISO8859-1 + en en_US en_UK en_IE en_CA en_AU en_NZ + english english.iso88591 + american american.iso88591 + british british.iso88591 + )); + +# Find some German locale + +locatelocale(\$German, \@German, + qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 + de de_DE de_AT de_CH + german german.iso88591)); + +# Find some French locale + +locatelocale(\$French, \@French, + qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 + fr fr_FR fr_BE fr_CA fr_CH + french french.iso88591)); + +# Find some Spanish locale + +locatelocale(\$Spanish, \@Spanish, + qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 + es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 + es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 + es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 + es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 + es es_AR es_BO es_CL + es_CO es_CR es_EC + es_ES es_GT es_MX + es_NI es_PA es_PE + es_PY es_SV es_UY es_VE + spanish spanish.iso88591)); + +# Select the largest of the alpha(num)bets. + +($Locale, @Locale) = ($English, @English) + if (length(@English) > length(@Locale)); +($Locale, @Locale) = ($German, @German) + if (length(@German) > length(@Locale)); +($Locale, @Locale) = ($French, @French) + if (length(@French) > length(@Locale)); +($Locale, @Locale) = ($Spanish, @Spanish) + if (length(@Spanish) > length(@Locale)); + +print "# Locale = $Locale\n"; +print "# Alnum_ = @Locale\n"; + +{ + local $^W = 0; + setlocale(&LC_ALL, $Locale); +} + +{ + my $i = 0; + + for (@Locale) { + $iLocale{$_} = $i++; + } +} + +# Sieve the uppercase and the lowercase. + +for (@Locale) { + if (/[^\d_]/) { # skip digits and the _ + if (lc eq $_) { + $UPPER{$_} = uc; + } else { + $lower{$_} = lc; + } + } +} + +# Cross-check the upper and the lower. +# Yes, this is broken when the upper<->lower changes the number of +# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature, +# or the Dutch IJ or the Spanish LL or ...) +# But so far all the implementations do this wrong so we can do it wrong too. + +for (keys %UPPER) { + if (defined $lower{$UPPER{$_}}) { + if ($_ ne $lower{$UPPER{$_}}) { + print 'not '; + last; + } + } +} +print "ok 99\n"; + +for (keys %lower) { + if (defined $UPPER{$lower{$_}}) { + if ($_ ne $UPPER{$lower{$_}}) { + print 'not '; + last; + } + } +} +print "ok 100\n"; + +# Find the alphabets that are not alphabets in the default locale. + +{ + no locale; + + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + } +} + +@Neoalpha = sort @Neoalpha; + +# Test \w. + +{ + my $word = join('', @Neoalpha); + + $word =~ /^(\w*)$/; + + print 'not ' if ($1 ne $word); +} +print "ok 101\n"; + +# Find places where the collation order differs from the default locale. + +{ + my (@k, $i, $j, @d); + + { + no locale; + + @k = sort (keys %UPPER, keys %lower); + } + + for ($i = 0; $i < @k; $i++) { + for ($j = $i + 1; $j < @k; $j++) { + if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { + push(@d, [$k[$j], $k[$i]]); + } + } + } + + # Cross-check those places. + + for (@d) { + ($i, $j) = @$_; + if ($i gt $j) { + print "# i = $i, j = $j, i ", + $i le $j ? 'le' : 'gt', " j\n"; + print 'not '; + last; + } + } +} +print "ok 102\n"; + +# Cross-check whole character set. + +for (map { chr } 0..255) { + if (/\w/ and /\W/) { print 'not '; last } + if (/\d/ and /\D/) { print 'not '; last } + if (/\s/ and /\S/) { print 'not '; last } + if (/\w/ and /\D/ and not /_/ and + not (exists $UPPER{$_} or exists $lower{$_})) { + print 'not '; + last; + } +} +print "ok 103\n"; + +# The @Locale should be internally consistent. + +{ + my ($from, $to, , $lesser, $greater); + + for (0..9) { + # Select a slice. + $from = int(($_*@Locale)/10); + $to = $from + int(@Locale/10); + $to = $#Locale if ($to > $#Locale); + $lesser = join('', @Locale[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Locale if ($to > $#Locale); + $greater = join('', @Locale[$from..$to]); + if (not ($lesser lt $greater) or + not ($lesser le $greater) or + not ($lesser ne $greater) or + ($lesser eq $greater) or + ($lesser ge $greater) or + ($lesser gt $greater) or + ($greater lt $lesser ) or + ($greater le $lesser ) or + not ($greater ne $lesser ) or + ($greater eq $lesser ) or + not ($greater ge $lesser ) or + not ($greater gt $lesser ) or + # Well, these two are sort of redundant because @Locale + # was derived using cmp. + not (($lesser cmp $greater) == -1) or + not (($greater cmp $lesser ) == 1) + ) { + print 'not '; + last; + } + } +} +print "ok 104\n"; diff --git a/t/op/overload.t b/t/pragma/overload.t index 183cb273f7..42d045741d 100755 --- a/t/op/overload.t +++ b/t/pragma/overload.t @@ -1,9 +1,12 @@ #!./perl -BEGIN { unshift @INC, './lib', '../lib'; - require Config; import Config; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; } +use Config; + package Oscalar; use overload ( # Anonymous subroutines: @@ -30,7 +33,7 @@ qw( sub new { my $foo = $_[1]; - bless \$foo; + bless \$foo, $_[0]; } sub stringify { "${$_[0]}" } @@ -52,7 +55,9 @@ $a = new Oscalar "087"; $b= "$a"; # All test numbers in comments are off by 1. -# So much for hard-wiring them in :-) +# So much for hard-wiring them in :-) To fix this: +test(1); # 1 + test ($b eq $a); # 2 test ($b eq "087"); # 3 test (ref $a eq "Oscalar"); # 4 @@ -252,16 +257,107 @@ $a=new Oscalar "xx"; test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 +# Check inheritance of overloading; +{ + package OscalarI; + @ISA = 'Oscalar'; +} + +$aI = new OscalarI "$a"; +test (ref $aI eq "OscalarI"); # 89 +test ("$aI" eq "xx"); # 90 +test ($aI eq "xx"); # 91 +test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 + # Here we test blessing to a package updates hash eval "package Oscalar; no overload '.'"; -test ("b${a}" eq "_.b.__.xx._"); # 89 +test ("b${a}" eq "_.b.__.xx._"); # 93 $x="1"; bless \$x, Oscalar; -test ("b${a}c" eq "bxxc"); # 90 +test ("b${a}c" eq "bxxc"); # 94 new Oscalar 1; -test ("b${a}c" eq "bxxc"); # 91 +test ("b${a}c" eq "bxxc"); # 95 + +# Negative overloading: + +$na = eval { ~$a }; +test($@ =~ /no method found/); # 96 + +# Check AUTOLOADING: + +*Oscalar::AUTOLOAD = + sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; + goto &{"Oscalar::$AUTOLOAD"}}; + +eval "package Oscalar; sub comple; use overload '~' => 'comple'"; + +$na = eval { ~$a }; # Hash was not updated +test($@ =~ /no method found/); # 97 + +bless \$x, Oscalar; + +$na = eval { ~$a }; # Hash updated +warn "`$na', $@" if $@; +test !$@; # 98 +test($na eq '_!_xx_!_'); # 99 + +$na = 0; + +$na = eval { ~$aI }; # Hash was not updated +test($@ =~ /no method found/); # 100 + +bless \$x, OscalarI; + +$na = eval { ~$aI }; +print $@; + +test !$@; # 101 +test($na eq '_!_xx_!_'); # 102 + +eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; + +$na = eval { $aI >> 1 }; # Hash was not updated +test($@ =~ /no method found/); # 103 + +bless \$x, OscalarI; + +$na = 0; + +$na = eval { $aI >> 1 }; +print $@; + +test !$@; # 104 +test($na eq '_!_xx_!_'); # 105 + +# warn overload::Method($a, '0+'), "\n"; +test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 +test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 +test (overload::Overloaded($aI)); # 108 +test (!overload::Overloaded('overload')); # 109 + +test (! defined overload::Method($aI, '<<')); # 110 +test (! defined overload::Method($a, '<')); # 111 + +test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 +test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 + +# Check overloading by methods (specified deep in the ISA tree). +{ + package OscalarII; + @ISA = 'OscalarI'; + sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} + eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; +} + +$aaII = "087"; +$aII = \$aaII; +bless $aII, 'OscalarII'; +bless \$fake, 'OscalarI'; # update the hash +test(($aI | 3) eq '_<<_xx_<<_'); # 114 +# warn $aII << 3; +test(($aII << 3) eq '_<<_087_<<_'); # 115 -# Last test is number 90. -sub last {90} +# Last test is: +sub last {115} diff --git a/t/pragma/strict-refs b/t/pragma/strict-refs new file mode 100644 index 0000000000..7bf1556e10 --- /dev/null +++ b/t/pragma/strict-refs @@ -0,0 +1,295 @@ +Check strict refs functionality + +__END__ + +# no strict, should build & run ok. +my $fred ; +$b = "fred" ; +$a = $$b ; +$c = ${"def"} ; +$c = @{"def"} ; +$c = %{"def"} ; +$c = *{"def"} ; +$c = \&{"def"} ; +$c = def->[0]; +$c = def->{xyz}; +EXPECT + +######## + +# strict refs - error +use strict ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = $$b ; +EXPECT +Can't use an undefined value as a SCALAR reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = @$b ; +EXPECT +Can't use an undefined value as an ARRAY reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = %$b ; +EXPECT +Can't use an undefined value as a HASH reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = *$b ; +EXPECT +Can't use an undefined value as a symbol reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->[0] ; +EXPECT +Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->{barney} ; +EXPECT +Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. +######## + +# strict refs - no error +use strict ; +no strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict qw(subs vars) ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict 'refs' ; +my $fred ; +my $b = \$fred ; +my $a = $$b ; +EXPECT + +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + + +--FILE-- abc +my $a = ${"Fred"} ; +1; +--FILE-- +use strict 'refs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +1; +--FILE-- +require "./abc"; +my $a = ${"Fred"} ; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +${"Fred"} ; +require "./abc"; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +######## + +--FILE-- abc.pm +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +my $a = ${"Fred"} ; +use abc; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'refs' ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + no strict ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'refs' ; + my $a = ${"Fred"} ; +]; print STDERR $@; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + no strict ; + my $a = ${"Fred"} ; +'; print STDERR $@; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/t/pragma/strict-subs b/t/pragma/strict-subs new file mode 100644 index 0000000000..6864a3a979 --- /dev/null +++ b/t/pragma/strict-subs @@ -0,0 +1,279 @@ +Check strict subs functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(refs vars); +Fred ; +EXPECT + +######## + +use strict ; +no strict 'subs' ; +Fred ; +EXPECT + +######## + +# strict subs - error +use strict 'subs' ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - no error +use strict 'subs' ; +sub Fred {} +Fred ; +EXPECT + +######## + +# Check compile time scope of strict subs pragma +use strict 'subs' ; +{ + no strict ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict subs pragma +no strict; +{ + use strict 'subs' ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +use strict 'subs' ; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 3. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +my $a = Fred ; +1; +--FILE-- +use strict 'subs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +1; +--FILE-- +require "./abc"; +my $a = Fred ; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +require "./abc"; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. + at - line 2. +######## + +--FILE-- abc.pm +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +use abc; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. + at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'subs' ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 5. +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + no strict ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + Fred ; +'; print STDERR $@ ; +Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'subs' ; + Fred ; +]; print STDERR $@; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + Fred ; +'; print STDERR $@ ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + no strict ; + my $a = Fred ; +'; print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars new file mode 100644 index 0000000000..727eb2d4f2 --- /dev/null +++ b/t/pragma/strict-vars @@ -0,0 +1,225 @@ +Check strict vars functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(subs refs) ; +$fred ; +EXPECT + +######## + +use strict ; +no strict 'vars' ; +$fred ; +EXPECT + +######## + +# strict vars - no error +use strict 'vars' ; +use vars qw( $freddy) ; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars - error +use strict ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +local $fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +$joe = 1 ; +1; +--FILE-- +use strict 'vars' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +1; +--FILE-- +require "./abc"; +$joe = 1 ; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +require "./abc"; +EXPECT +Variable "$joe" is not imported at ./abc line 2. +Global symbol "joe" requires explicit package name at ./abc line 2. + at - line 2. +######## + +--FILE-- abc.pm +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +use abc; +EXPECT +Variable "$joe" is not imported at abc.pm line 2. +Global symbol "joe" requires explicit package name at abc.pm line 2. + at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'vars' ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 5. +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + no strict ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 9. +Global symbol "joe" requires explicit package name at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'vars' ; + $joe = 1 ; +]; print STDERR $@; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + no strict ; + $joe = 1 ; +'; print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. diff --git a/t/pragma/strict.t b/t/pragma/strict.t new file mode 100755 index 0000000000..0ff849e2be --- /dev/null +++ b/t/pragma/strict.t @@ -0,0 +1,88 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +my @prgs = () ; + +foreach (sort glob("pragma/strict-*")) { + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --git a/t/pragma/subs.t b/t/pragma/subs.t new file mode 100755 index 0000000000..33180066e0 --- /dev/null +++ b/t/pragma/subs.t @@ -0,0 +1,129 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; +undef $/; +my @prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +my $Is_VMS = $^O eq 'VMS'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} + +__END__ + +# Error - not predeclaring a sub +Fred 1,2 ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +Execution of - aborted due to compilation errors. +######## + +# Error - not predeclaring a sub in time +Fred 1,2 ; +use subs qw( Fred ) ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +Execution of - aborted due to compilation errors. +######## + +# AOK +use subs qw( Fred) ; +Fred 1,2 ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function +use subs qw( open ) ; +open 1,2 ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +--FILE-- abc +Fred 1,2 ; +1; +--FILE-- +use subs qw( Fred ) ; +require "./abc" ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# check that it isn't affected by block scope +{ + use subs qw( Fred ) ; +} +Fred 1, 2; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 diff --git a/t/pragma/warn-1global b/t/pragma/warn-1global new file mode 100644 index 0000000000..33252731b0 --- /dev/null +++ b/t/pragma/warn-1global @@ -0,0 +1,146 @@ +Check existing $^W functionality + +__END__ + +# warnable code, warnings disabled +$a =+ 3 ; +EXPECT + +######## +-w +# warnable code, warnings enabled via command line switch +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator at - line 4. +######## + +# compile-time warnable code, warnings enabled via runtime $^W +# so no warning printed. +$^W = 1 ; +$a =+ 3 ; +EXPECT + +######## + +# warnable code, warnings enabled via runtime $^W +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 4. +######## + +# warnings enabled at compile time, disabled at run time +BEGIN { $^W = 1 } +$^W = 0 ; +my $b ; chop $b ; +EXPECT + +######## + +# warnings disabled at compile time, enabled at run time +BEGIN { $^W = 0 } +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +$^W = 0; +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT + +######## + +--FILE-- abcd +$^W = 1; +1 ; +--FILE-- +$^W =0 ; +require "./abcd"; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +$^W = 1; +eval "my $b ; chop $b ;" ; +EXPECT +Use of uninitialized value at - line 3. +Use of uninitialized value at - line 3. +######## + +eval "$^W = 1;" ; +my $b ; chop $b ; +EXPECT + +######## + +eval {$^W = 1;} ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +{ + local ($^W) = 1; +} +my $b ; chop $b ; +EXPECT + +######## + +my $a ; chop $a ; +{ + local ($^W) = 1; + my $b ; chop $b ; +} +my $c ; chop $c ; +EXPECT +Use of uninitialized value at - line 5. diff --git a/t/pragma/warning.t b/t/pragma/warning.t new file mode 100755 index 0000000000..3cb5c73569 --- /dev/null +++ b/t/pragma/warning.t @@ -0,0 +1,89 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; + +foreach (sort glob("pragma/warn-*")) { + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --git a/t/re_tests b/t/re_tests deleted file mode 100644 index 2ac666ab38..0000000000 --- a/t/re_tests +++ /dev/null @@ -1,3 +0,0 @@ -a.+?c abcabc y $& abc -(a+|b)* ab y $&-$1 ab-b -(a+|b){0,} ab y $&-$1 ab-b @@ -8,37 +8,25 @@ #include "perl.h" void -taint_not(s) -char *s; -{ - if (euid != uid) - croak("No %s allowed while running setuid", s); - if (egid != gid) - croak("No %s allowed while running setgid", s); -} - -void taint_proper(f, s) -char *f; +const char *f; char *s; { - if (tainting) { - DEBUG_u(PerlIO_printf(PerlIO_stderr(), "%s %d %d %d\n",s,tainted,uid, euid)); - if (tainted) { - char *ug = 0; - if (euid != uid) - ug = " while running setuid"; - else if (egid != gid) - ug = " while running setgid"; - else if (tainting) - ug = " while running with -T switch"; - if (ug) { - if (!unsafe) - croak(f, s, ug); - else if (dowarn) - warn(f, s, ug); - } - } + char *ug; + + if (tainted) { + DEBUG_u(PerlIO_printf(PerlIO_stderr(), + "%s %d %d %d\n", s, tainted, uid, euid)); + if (euid != uid) + ug = " while running setuid"; + else if (egid != gid) + ug = " while running setgid"; + else + ug = " while running with -T switch"; + if (!unsafe) + croak(f, s, ug); + else if (dowarn) + warn(f, s, ug); } } @@ -46,26 +34,24 @@ void taint_env() { SV** svp; + MAGIC *mg = 0; - if (tainting) { - MAGIC *mg = 0; - svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE); - if (!svp || *svp == &sv_undef || - ((mg = mg_find(*svp, 't')) && mg->mg_len & 1)) - { - tainted = TRUE; - if (mg && MgTAINTEDDIR(mg)) - taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); - else - taint_proper("Insecure %s%s", "$ENV{PATH}"); - } - svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE); - if (svp && *svp != &sv_undef && - (mg = mg_find(*svp, 't')) && mg->mg_len & 1) - { - tainted = TRUE; - taint_proper("Insecure %s%s", "$ENV{IFS}"); - } + svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE); + if (!svp || *svp == &sv_undef || + ((mg = mg_find(*svp, 't')) && mg->mg_len & 1)) + { + TAINT; + if (mg && MgTAINTEDDIR(mg)) + taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); + else + taint_proper("Insecure %s%s", "$ENV{PATH}"); } -} + svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE); + if (svp && *svp != &sv_undef && + (mg = mg_find(*svp, 't')) && mg->mg_len & 1) + { + TAINT; + taint_proper("Insecure %s%s", "$ENV{IFS}"); + } +} @@ -40,6 +40,7 @@ static void missingterm _((char *s)); static void no_op _((char *what, char *s)); static void set_csh _((void)); static I32 sublex_done _((void)); +static I32 sublex_push _((void)); static I32 sublex_start _((void)); #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); @@ -49,20 +50,29 @@ static void restore_rsfp _((void *f)); static char *linestart; /* beg. of most recently read line */ +static char pending_ident; /* pending identifier lookup */ + +static struct { + I32 super_state; /* lexer state to save */ + I32 sub_inwhat; /* "lex_inwhat" to use */ + OP *sub_op; /* "lex_op" to use */ +} sublex_info; + /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). */ -#define LEX_NORMAL 9 -#define LEX_INTERPNORMAL 8 -#define LEX_INTERPCASEMOD 7 -#define LEX_INTERPSTART 6 -#define LEX_INTERPEND 5 -#define LEX_INTERPENDMAYBE 4 -#define LEX_INTERPCONCAT 3 -#define LEX_INTERPCONST 2 -#define LEX_FORMLINE 1 -#define LEX_KNOWNEXT 0 +#define LEX_NORMAL 10 +#define LEX_INTERPNORMAL 9 +#define LEX_INTERPCASEMOD 8 +#define LEX_INTERPPUSH 7 +#define LEX_INTERPSTART 6 +#define LEX_INTERPEND 5 +#define LEX_INTERPENDMAYBE 4 +#define LEX_INTERPCONCAT 3 +#define LEX_INTERPCONST 2 +#define LEX_FORMLINE 1 +#define LEX_KNOWNEXT 0 #ifdef I_FCNTL #include <fcntl.h> @@ -181,7 +191,7 @@ char *s; } else if (multi_close < 32 || multi_close == 127) { *tmpbuf = '^'; - tmpbuf[1] = multi_close ^ 64; + tmpbuf[1] = toCTRL(multi_close); s = "\\n"; tmpbuf[2] = '\0'; s = tmpbuf; @@ -216,15 +226,15 @@ SV *line; char *s; STRLEN len; - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); SAVEPPTR(bufend); SAVEPPTR(oldbufptr); @@ -276,6 +286,7 @@ SV *line; void lex_end() { + doextract = FALSE; } static void @@ -517,7 +528,10 @@ int kind; force_next(WORD); if (kind) { op->op_private = OPpCONST_ENTERED; - gv_fetchpv(s, TRUE, + /* XXX see note in pp_entereval() for why we forgo typo + warnings if the symbol must be introduced in an eval. + GSAR 96-10-12 */ + gv_fetchpv(s, in_eval ? GV_ADDMULTI : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -540,7 +554,7 @@ char *s; if(isDIGIT(*s)) { char *d; int c; - for( d=s, c = 1; isDIGIT(*d) || (*d == '.' && c--); d++); + for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++); if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { s = scan_num(s); /* real VERSION number -- GBARR */ @@ -605,16 +619,36 @@ sublex_start() return THING; } + sublex_info.super_state = lex_state; + sublex_info.sub_inwhat = op_type; + sublex_info.sub_op = lex_op; + lex_state = LEX_INTERPPUSH; + + expect = XTERM; + if (lex_op) { + yylval.opval = lex_op; + lex_op = Nullop; + return PMFUNC; + } + else + return FUNC; +} + +static I32 +sublex_push() +{ push_scope(); - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + + lex_state = sublex_info.super_state; + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); SAVEPPTR(oldbufptr); SAVEPPTR(oldoldbufptr); @@ -643,21 +677,13 @@ sublex_start() lex_state = LEX_INTERPCONCAT; curcop->cop_line = multi_start; - lex_inwhat = op_type; - if (op_type == OP_MATCH || op_type == OP_SUBST) - lex_inpat = lex_op; + lex_inwhat = sublex_info.sub_inwhat; + if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST) + lex_inpat = sublex_info.sub_op; else - lex_inpat = 0; + lex_inpat = Nullop; - expect = XTERM; - force_next('('); - if (lex_op) { - yylval.opval = lex_op; - lex_op = Nullop; - return PMFUNC; - } - else - return FUNC; + return '('; } static I32 @@ -799,10 +825,8 @@ char *start; continue; case 'c': s++; - *d = *s++; - if (isLOWER(*d)) - *d = toUPPER(*d); - *d++ ^= 64; + len = *s++; + *d++ = toCTRL(len); continue; case 'b': *d++ = '\b'; @@ -989,7 +1013,7 @@ GV *gv; if (gv) { if (GvIO(gv)) return 0; - if (!GvCV(gv)) + if (!GvCVu(gv)) gv = 0; } s = scan_word(s, tmpbuf, TRUE, &len); @@ -1003,11 +1027,13 @@ GV *gv; } if (!keyword(tmpbuf, len)) { indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV); - if (indirgv && GvCV(indirgv)) + if (indirgv && GvCVu(indirgv)) return 0; /* filehandle or package name makes it a method */ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { s = skipspace(s); + if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>') + return 0; /* no assumptions -- "=>" quotes bearword */ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tmpbuf,0)); @@ -1165,7 +1191,8 @@ STRLEN append; { if (rsfp_filters) { - SvCUR_set(sv, 0); /* start with empty line */ + if (!append) + SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else @@ -1182,7 +1209,7 @@ STRLEN append; { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" }; #endif -extern int yychar; /* last token */ +EXT int yychar; /* last token */ int yylex() @@ -1192,6 +1219,59 @@ yylex() register I32 tmp; STRLEN len; + if (pending_ident) { + char pit = pending_ident; + pending_ident = 0; + + if (in_my) { + if (strchr(tokenbuf,':')) + croak(no_myglob,tokenbuf); + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = pad_allocmy(tokenbuf); + return PRIVATEREF; + } + + if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) { + if (last_lop_op == OP_SORT && + tokenbuf[0] == '$' && + (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') + && !tokenbuf[2]) + { + for (d = in_eval ? oldoldbufptr : linestart; + d < bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + croak("Can't use \"my %s\" in sort comparison", + tokenbuf); + } + } + } + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } + + /* Force them to make up their mind on "@foo". */ + if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) { + GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV); + if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) { + char tmpbuf[1024]; + sprintf(tmpbuf, "Literal %s now requires backslash", tokenbuf); + yyerror(tmpbuf); + } + } + + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0)); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE, + ((tokenbuf[0] == '$') ? SVt_PV + : (tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; + } + switch (lex_state) { #ifdef COMMENTARY case LEX_NORMAL: /* Some compilers will produce faster */ @@ -1275,6 +1355,9 @@ yylex() return yylex(); } + case LEX_INTERPPUSH: + return sublex_push(); + case LEX_INTERPSTART: if (bufptr == bufend) return sublex_done(); @@ -1375,6 +1458,8 @@ yylex() goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: if (!rsfp) { + last_uni = 0; + last_lop = 0; if (lex_brackets) yyerror("Missing right bracket"); TOKEN(0); @@ -1481,11 +1566,78 @@ yylex() s++; if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ s++; - if (!in_eval && *s == '#' && s[1] == '!') { + d = Nullch; + if (!in_eval) { + if (*s == '#' && *(s+1) == '!') + d = s + 2; +#ifdef ALTERNATE_SHEBANG + else { + static char as[] = ALTERNATE_SHEBANG; + if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) + d = s + (sizeof(as) - 1); + } +#endif /* ALTERNATE_SHEBANG */ + } + if (d) { + /* + * HP-UX (at least) sets argv[0] to the script name, + * which makes $^X incorrect. And Digital UNIX and Linux, + * at least, set argv[0] to the basename of the Perl + * interpreter. So, having found "#!", we'll set it right. + */ + SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); + char *ipath; + char *ibase; + + while (*d == ' ' || *d == '\t') + d++; + ipath = d; + ibase = Nullch; + while (*d && !isSPACE(*d)) { + if (*d++ == '/') + ibase = d; + } + assert(SvPOK(x) || SvGMAGICAL(x)); + if (sv_eq(x, GvSV(curcop->cop_filegv)) + || (ibase + && SvCUR(x) == (d - ibase) + && strnEQ(SvPVX(x), ibase, d - ibase))) + sv_setpvn(x, ipath, d - ipath); + /* + * $^X is always tainted, but taintedness must be off + * when parsing code, so forget we ever saw it. + */ + TAINT_NOT; + + /* + * Look for options. + */ d = instr(s,"perl -"); if (!d) d = instr(s,"perl"); +#ifdef ALTERNATE_SHEBANG + /* + * If the ALTERNATE_SHEBANG on this system starts with a + * character that can be part of a Perl expression, then if + * we see it but not "perl", we're probably looking at the + * start of Perl code, not a request to hand off to some + * other interpreter. Similarly, if "perl" is there, but + * not in the first 'word' of the line, we assume the line + * contains the start of the Perl program. + * This isn't foolproof, but it's generally a good guess. + */ + if (d && *s != '#') { + char *c = s; + while (*c && !strchr("; \t\r\n\f\v#", *c)) + c++; + if (c < d) + d = Nullch; /* "perl" not in first word; ignore */ + else + *s = '#'; /* Don't try to parse shebang line */ + } +#endif if (!d && + *s == '#' && !minus_c && !instr(s,"indir") && instr(origargv[0],"perl")) @@ -1685,35 +1837,19 @@ yylex() Mop(OP_MULTIPLY); case '%': - if (expect != XOPERATOR) { - s = scan_ident(s, bufend, tokenbuf + 1, TRUE); - if (tokenbuf[1]) { - expect = XOPERATOR; - tokenbuf[0] = '%'; - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - TERM('%'); - } - if (!strchr(tokenbuf,':')) { - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - force_next(PRIVATEREF); - TERM('%'); - } - } - force_ident(tokenbuf + 1, *tokenbuf); - } - else - PREREF('%'); - TERM('%'); + if (expect == XOPERATOR) { + ++s; + Mop(OP_MODULO); + } + tokenbuf[0] = '%'; + s = scan_ident(s, bufend, tokenbuf+1, TRUE); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final % should be \\% or %name"); + PREREF('%'); } - ++s; - Mop(OP_MODULO); + pending_ident = '%'; + TERM('%'); case '^': s++; @@ -1788,17 +1924,29 @@ yylex() case XOPERATOR: while (s < bufend && (*s == ' ' || *s == '\t')) s++; - if (s < bufend && (isALPHA(*s) || *s == '_')) { - d = scan_word(s, tokenbuf, FALSE, &len); + d = s; + tokenbuf[0] = '\0'; + if (d < bufend && *d == '-') { + tokenbuf[0] = '-'; + d++; + while (d < bufend && (*d == ' ' || *d == '\t')) + d++; + } + if (d < bufend && isIDFIRST(*d)) { + d = scan_word(d, tokenbuf + 1, FALSE, &len); while (d < bufend && (*d == ' ' || *d == '\t')) d++; if (*d == '}') { + char minus = (tokenbuf[0] == '-'); if (dowarn && - (keyword(tokenbuf, len) || - perl_get_cv(tokenbuf, FALSE) )) + (keyword(tokenbuf + 1, len) || + (minus && len == 1 && isALPHA(tokenbuf[1])) || + perl_get_cv(tokenbuf + 1, FALSE) )) warn("Ambiguous use of {%s} resolved to {\"%s\"}", - tokenbuf, tokenbuf); - s = force_word(s,WORD,FALSE,TRUE,FALSE); + tokenbuf + !minus, tokenbuf + !minus); + s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); + if (minus) + force_next('-'); } } /* FALL THROUGH */ @@ -1996,67 +2144,72 @@ yylex() Rop(OP_GT); case '$': - if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) { - s = scan_ident(s+1, bufend, tokenbuf+1, FALSE); - if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) { - expect = XTERM; - depcom(); - return ','; /* grandfather non-comma-format format */ - } - else - no_op("Array length",s); + CLINE; + + if (expect == XOPERATOR) { + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ } - else if (!tokenbuf[1]) + } + + if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) { + if (expect == XOPERATOR) + no_op("Array length", bufptr); + tokenbuf[0] = '@'; + s = scan_ident(s+1, bufend, tokenbuf+1, FALSE); + if (!tokenbuf[1]) PREREF(DOLSHARP); - if (!strchr(tokenbuf+1,':')) { - tokenbuf[0] = '@'; - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - expect = XOPERATOR; - force_next(PRIVATEREF); - TOKEN(DOLSHARP); - } - } expect = XOPERATOR; - force_ident(tokenbuf+1, *tokenbuf); + pending_ident = '#'; TOKEN(DOLSHARP); } + + if (expect == XOPERATOR) + no_op("Scalar", bufptr); + tokenbuf[0] = '$'; s = scan_ident(s, bufend, tokenbuf+1, FALSE); - if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) { - expect = XTERM; - depcom(); - return ','; /* grandfather non-comma-format format */ - } - else - no_op("Scalar",s); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final $ should be \\$ or $name"); + PREREF('$'); } - if (tokenbuf[1]) { - expectation oldexpect = expect; - /* This kludge not intended to be bulletproof. */ - if (tokenbuf[1] == '[' && !tokenbuf[2]) { - yylval.opval = newSVOP(OP_CONST, 0, - newSViv((IV)compiling.cop_arybase)); - yylval.opval->op_private = OPpCONST_ARYBASE; - TERM(THING); - } - tokenbuf[0] = '$'; - if (dowarn) { - char *t; - if (*s == '[' && oldexpect != XREF) { - for (t = s+1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; + /* This kludge not intended to be bulletproof. */ + if (tokenbuf[1] == '[' && !tokenbuf[2]) { + yylval.opval = newSVOP(OP_CONST, 0, + newSViv((IV)compiling.cop_arybase)); + yylval.opval->op_private = OPpCONST_ARYBASE; + TERM(THING); + } + + d = s; + if (lex_state == LEX_NORMAL) + s = skipspace(s); + + if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) { + char *t; + if (*s == '[') { + tokenbuf[0] = '@'; + if (dowarn) { + for(t = s + 1; + isSPACE(*t) || isALNUM(*t) || *t == '$'; + t++) ; if (*t++ == ',') { bufptr = skipspace(bufptr); - while (t < bufend && *t != ']') t++; + while (t < bufend && *t != ']') + t++; warn("Multidimensional syntax %.*s not supported", - t-bufptr+1, bufptr); + (t - bufptr) + 1, bufptr); } } - if (*s == '{' && strEQ(tokenbuf, "$SIG") && - (t = strchr(s,'}')) && (t = strchr(t,'='))) { + } + else if (*s == '{') { + tokenbuf[0] = '%'; + if (dowarn && strEQ(tokenbuf+1, "SIG") && + (t = strchr(s, '}')) && (t = strchr(t, '='))) + { char tmpbuf[1024]; STRLEN len; for (t++; isSPACE(*t); t++) ; @@ -2067,114 +2220,44 @@ yylex() } } } - expect = XOPERATOR; - if (lex_state == LEX_NORMAL && isSPACE(*s)) { - bool islop = (last_lop == oldoldbufptr); - s = skipspace(s); - if (!islop || last_lop_op == OP_GREPSTART) - expect = XOPERATOR; - else if (strchr("$@\"'`q", *s)) - expect = XTERM; /* e.g. print $fh "foo" */ - else if (strchr("&*<%", *s) && isIDFIRST(s[1])) - expect = XTERM; /* e.g. print $fh &sub */ - else if (isDIGIT(*s)) - expect = XTERM; /* e.g. print $fh 3 */ - else if (*s == '.' && isDIGIT(s[1])) - expect = XTERM; /* e.g. print $fh .3 */ - else if (strchr("/?-+", *s) && !isSPACE(s[1])) - expect = XTERM; /* e.g. print $fh -1 */ - else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])) - expect = XTERM; /* print $fh <<"EOF" */ - } - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - } - else if (!strchr(tokenbuf,':')) { - if (oldexpect != XREF || oldoldbufptr == last_lop) { - if (intuit_more(s)) { - if (*s == '[') - tokenbuf[0] = '@'; - else if (*s == '{') - tokenbuf[0] = '%'; - } - } - if (tmp = pad_findmy(tokenbuf)) { - if (last_lop_op == OP_SORT && - !tokenbuf[2] && *tokenbuf =='$' && - tokenbuf[1] <= 'b' && tokenbuf[1] >= 'a') - { - for (d = in_eval ? oldoldbufptr : linestart; - d < bufend && *d != '\n'; - d++) - { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - croak("Can't use \"my %s\" in sort comparison", - tokenbuf); - } - } - } - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - force_next(PRIVATEREF); - } - else - force_ident(tokenbuf+1, *tokenbuf); - } - else - force_ident(tokenbuf+1, *tokenbuf); - } - else { - if (s == bufend) - yyerror("Final $ should be \\$ or $name"); - PREREF('$'); } + + expect = XOPERATOR; + if (lex_state == LEX_NORMAL && isSPACE(*d)) { + bool islop = (last_lop == oldoldbufptr); + if (!islop || last_lop_op == OP_GREPSTART) + expect = XOPERATOR; + else if (strchr("$@\"'`q", *s)) + expect = XTERM; /* e.g. print $fh "foo" */ + else if (strchr("&*<%", *s) && isIDFIRST(s[1])) + expect = XTERM; /* e.g. print $fh &sub */ + else if (isDIGIT(*s)) + expect = XTERM; /* e.g. print $fh 3 */ + else if (*s == '.' && isDIGIT(s[1])) + expect = XTERM; /* e.g. print $fh .3 */ + else if (strchr("/?-+", *s) && !isSPACE(s[1])) + expect = XTERM; /* e.g. print $fh -1 */ + else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])) + expect = XTERM; /* print $fh <<"EOF" */ + } + pending_ident = '$'; TOKEN('$'); case '@': - s = scan_ident(s, bufend, tokenbuf+1, FALSE); if (expect == XOPERATOR) - no_op("Array",s); - if (tokenbuf[1]) { - GV* gv; - - tokenbuf[0] = '@'; - expect = XOPERATOR; - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - TERM('@'); - } - else if (!strchr(tokenbuf,':')) { - if (intuit_more(s)) { - if (*s == '{') - tokenbuf[0] = '%'; - } - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - force_next(PRIVATEREF); - TERM('@'); - } - } - - /* Force them to make up their mind on "@foo". */ - if (lex_state != LEX_NORMAL && !lex_brackets && - ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) || - (*tokenbuf == '@' - ? !GvAV(gv) - : !GvHV(gv) ))) - { - char tmpbuf[1024]; - sprintf(tmpbuf, "Literal @%s now requires backslash",tokenbuf+1); - yyerror(tmpbuf); - } + no_op("Array", s); + tokenbuf[0] = '@'; + s = scan_ident(s, bufend, tokenbuf+1, FALSE); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final @ should be \\@ or @name"); + PREREF('@'); + } + if (lex_state == LEX_NORMAL) + s = skipspace(s); + if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) { + if (*s == '{') + tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ if (dowarn) { @@ -2190,13 +2273,8 @@ yylex() } } } - force_ident(tokenbuf+1, *tokenbuf); - } - else { - if (s == bufend) - yyerror("Final @ should be \\@ or @name"); - PREREF('@'); } + pending_ident = '@'; TERM('@'); case '/': /* may either be division or pattern */ @@ -2336,16 +2414,34 @@ yylex() keylookup: bufptr = s; s = scan_word(s, tokenbuf, FALSE, &len); - - if (*s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE")) + + /* Some keywords can be followed by any delimiter, including ':' */ + tmp = (len == 1 && strchr("msyq", tokenbuf[0]) || + len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') || + (tokenbuf[0] == 'q' && + strchr("qwx", tokenbuf[1])))); + + /* x::* is just a word, unless x is "CORE" */ + if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE")) goto just_a_word; + d = s; + while (d < bufend && isSPACE(*d)) + d++; /* no comments skipped here, or s### is misparsed */ + + /* Is this a label? */ + if (!tmp && expect == XSTATE + && d < bufend && *d == ':' && *(d + 1) != ':') { + s = d + 1; + yylval.pval = savepv(tokenbuf); + CLINE; + TOKEN(LABEL); + } + + /* Check for keywords */ tmp = keyword(tokenbuf, len); /* Is this a word before a => operator? */ - d = s; - while (d < bufend && (*d == ' ' || *d == '\t')) - d++; /* no comments skipped here, or s### is misparsed */ if (strnEQ(d,"=>",2)) { CLINE; if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE))) @@ -2385,18 +2481,7 @@ yylex() croak("Bad name after %s::", tokenbuf); } - /* Do special processing at start of statement. */ - - if (expect == XSTATE) { - while (isSPACE(*s)) s++; - if (*s == ':') { /* It's a label. */ - yylval.pval = savepv(tokenbuf); - s++; - CLINE; - TOKEN(LABEL); - } - } - else if (expect == XOPERATOR) { + if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; warn(warn_nosemi); @@ -2439,7 +2524,7 @@ yylex() /* (But it's an indir obj regardless for sort.) */ if ((last_lop_op == OP_SORT || - (!immediate_paren && (!gv || !GvCV(gv))) ) && + (!immediate_paren && (!gv || !GvCVu(gv))) ) && (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){ expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; @@ -2461,7 +2546,7 @@ yylex() /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !GvCV(gv))) { + if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { last_lop = oldbufptr; last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -2474,7 +2559,7 @@ yylex() /* Not a method, so call it a subroutine (if defined) */ - if (gv && GvCV(gv)) { + if (gv && GvCVu(gv)) { CV* cv = GvCV(gv); if (*s == '(') { nextval[nexttoke].opval = yylval.opval; @@ -2781,10 +2866,16 @@ yylex() case KEY_for: case KEY_foreach: yylval.ival = curcop->cop_line; - while (s < bufend && isSPACE(*s)) - s++; - if (isIDFIRST(*s)) - croak("Missing $ on loop variable"); + s = skipspace(s); + if (isIDFIRST(*s)) { + char *p = s; + if ((bufend - p) >= 3 && + strnEQ(p, "my", 2) && isSPACE(*(p + 2))) + p += 2; + p = skipspace(p); + if (isIDFIRST(*p)) + croak("Missing $ on loop variable"); + } OPERATOR(FOR); case KEY_formline: @@ -2843,10 +2934,10 @@ yylex() FUN0(OP_GPWENT); case KEY_getpwnam: - FUN1(OP_GPWNAM); + UNI(OP_GPWNAM); case KEY_getpwuid: - FUN1(OP_GPWUID); + UNI(OP_GPWUID); case KEY_getpeername: UNI(OP_GETPEERNAME); @@ -2888,10 +2979,10 @@ yylex() FUN0(OP_GGRENT); case KEY_getgrnam: - FUN1(OP_GGRNAM); + UNI(OP_GGRNAM); case KEY_getgrgid: - FUN1(OP_GGRGID); + UNI(OP_GGRGID); case KEY_getlogin: FUN0(OP_GETLOGIN); @@ -2936,7 +3027,6 @@ yylex() UNI(OP_LCFIRST); case KEY_local: - yylval.ival = 0; OPERATOR(LOCAL); case KEY_length: @@ -2987,8 +3077,7 @@ yylex() case KEY_my: in_my = TRUE; - yylval.ival = 1; - OPERATOR(LOCAL); + OPERATOR(MY); case KEY_next: s = force_word(s,WORD,TRUE,FALSE,FALSE); @@ -3077,6 +3166,19 @@ yylex() s = scan_str(s); if (!s) missingterm((char*)0); + if (dowarn && SvLEN(lex_stuff)) { + d = SvPV_force(lex_stuff, len); + for (; len; --len, ++d) { + if (*d == ',') { + warn("Possible attempt to separate words with commas"); + break; + } + if (*d == '#') { + warn("Possible attempt to put comments in qw() list"); + break; + } + } + } force_next(')'); nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff)); lex_stuff = Nullsv; @@ -3208,16 +3310,16 @@ yylex() LOP(OP_SETPRIORITY,XTERM); case KEY_sethostent: - FUN1(OP_SHOSTENT); + UNI(OP_SHOSTENT); case KEY_setnetent: - FUN1(OP_SNETENT); + UNI(OP_SNETENT); case KEY_setservent: - FUN1(OP_SSERVENT); + UNI(OP_SSERVENT); case KEY_setprotoent: - FUN1(OP_SPROTOENT); + UNI(OP_SPROTOENT); case KEY_setpwent: FUN0(OP_SPWENT); @@ -4243,20 +4345,21 @@ I32 ck_uni; *d = *s++; d[1] = '\0'; if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) { - *d = *s++ ^ 64; + *d = toCTRL(*s); + s++; } if (bracket) { if (isSPACE(s[-1])) { while (s < send && (*s == ' ' || *s == '\t')) s++; *d = *s; } - if (isALPHA(*d) || *d == '_') { + if (isIDFIRST(*d)) { d++; while (isALNUM(*s) || *s == ':') *d++ = *s++; *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; - if ((*s == '[' || *s == '{')) { + if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { if (dowarn && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; warn("Ambiguous use of %c{%s%s} resolved to %c%s%s", @@ -4293,10 +4396,8 @@ void pmflag(pmfl,ch) U16* pmfl; int ch; { - if (ch == 'i') { - sawi = TRUE; + if (ch == 'i') *pmfl |= PMf_FOLD; - } else if (ch == 'g') *pmfl |= PMf_GLOBAL; else if (ch == 'o') @@ -4323,14 +4424,14 @@ char *start; lex_stuff = Nullsv; croak("Search pattern not terminated"); } + pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogmsx", *s)) pmflag(&pm->op_pmflags,*s++); - pm->op_pmpermflags = pm->op_pmflags; + lex_op = (OP*)pm; yylval.ival = OP_MATCH; return s; @@ -4408,8 +4509,6 @@ register PMOP *pm; ) { if (!(pm->op_pmregexp->reganch & ROPT_ANCH)) pm->op_pmflags |= PMf_SCANFIRST; - else if (pm->op_pmflags & PMf_FOLD) - return; pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart); pm->op_pmslen = SvCUR(pm->op_pmshort); } @@ -4556,7 +4655,7 @@ register char *s; if (!rsfp) { d = s; while (s < bufend && - (*s != term || memcmp(s,tokenbuf,len) != 0) ) { + (*s != term || memNE(s,tokenbuf,len)) ) { if (*s++ == '\n') curcop->cop_line++; } @@ -4589,7 +4688,7 @@ register char *s; (I32)curcop->cop_line,sv); } bufend = SvPVX(linestr) + SvCUR(linestr); - if (*s == term && memcmp(s,tokenbuf,len) == 0) { + if (*s == term && memEQ(s,tokenbuf,len)) { s = bufend - 1; *s = ' '; sv_catsv(linestr,herewas); @@ -4780,8 +4879,9 @@ char *start; croak("panic: scan_num"); case '0': { - U32 i; + UV u; I32 shift; + bool overflowed = FALSE; if (s[1] == 'x') { shift = 4; @@ -4791,8 +4891,10 @@ char *start; goto decimal; else shift = 3; - i = 0; + u = 0; for (;;) { + UV n, b; + switch (*s) { default: goto out; @@ -4805,25 +4907,27 @@ char *start; /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - i <<= shift; - i += *s++ & 15; - break; + b = *s++ & 15; + goto digit; case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': if (shift != 4) goto out; - i <<= 4; - i += (*s++ & 7) + 9; + b = (*s++ & 7) + 9; + digit: + n = u << shift; + if (!overflowed && (n >> shift) != u) { + warn("Integer overflow in %s number", + (shift == 4) ? "hex" : "octal"); + overflowed = TRUE; + } + u = n | b; break; } } out: sv = NEWSV(92,0); - tryi32 = i; - if (tryi32 == i && tryi32 >= 0) - sv_setiv(sv,tryi32); - else - sv_setnv(sv,(double)i); + sv_setuv(sv, u); } break; case '1': case '2': case '3': case '4': case '5': @@ -4863,6 +4967,7 @@ char *start; } *d = '\0'; sv = NEWSV(92,0); + SET_NUMERIC_STANDARD(); value = atof(tokenbuf); tryi32 = I_32(value); if (!floatit && (double)tryi32 == value) @@ -4963,22 +5068,20 @@ start_subparse() CV* outsidecv = compcv; AV* comppadlist; -#ifndef __QNX__ if (compcv) { assert(SvTYPE(compcv) == SVt_PVCV); } -#endif save_I32(&subline); save_item(subname); - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); SAVESPTR(compcv); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - SAVEINT(pad_reset_pending); + SAVEI32(comppad_name_fill); + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); + SAVEI32(pad_reset_pending); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); @@ -5047,7 +5150,7 @@ char *s; (void)strcpy(tname,"within string"); } else if (yychar < 32) - (void)sprintf(tname,"next char ^%c",yychar+64); + (void)sprintf(tname,"next char ^%c",toCTRL(yychar)); else (void)sprintf(tname,"next char %c",yychar); (void)sprintf(buf, "%s at %s line %d, %s\n", diff --git a/universal.c b/universal.c index 72087e62a8..74d182d953 100644 --- a/universal.c +++ b/universal.c @@ -74,36 +74,53 @@ int level; return &sv_no; } +bool +sv_derived_from(sv, name) +SV * sv ; +char * name ; +{ + SV *rv; + char *type; + HV *stash; + + stash = Nullhv; + type = Nullch; + + if (SvGMAGICAL(sv)) + mg_get(sv) ; + + if (SvROK(sv)) { + sv = SvRV(sv); + type = sv_reftype(sv,0); + if(SvOBJECT(sv)) + stash = SvSTASH(sv); + } + else { + stash = gv_stashsv(sv, FALSE); + } + + return (type && strEQ(type,name)) || + (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) + ? TRUE + : FALSE ; + +} + + static XS(XS_UNIVERSAL_isa) { dXSARGS; - SV *sv, *rv; - char *name, *type; - HV *stash; + SV *sv; + char *name; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); - stash = Nullhv; - type = Nullch; sv = ST(0); name = (char *)SvPV(ST(1),na); - if (SvROK(sv)) { - sv = SvRV(sv); - type = sv_reftype(sv,0); - if(SvOBJECT(sv)) - stash = SvSTASH(sv); - } - else { - stash = gv_stashsv(sv, FALSE); - } - - ST(0) = (type && strEQ(type,name)) || - (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) - ? &sv_yes - : &sv_no; + ST(0) = (sv_derived_from(sv, name) ? &sv_yes : &sv_no) ; XSRETURN(1); } @@ -117,6 +134,7 @@ XS(XS_UNIVERSAL_can) SV *rv; GV *gv; CV *cvp; + HV *pkg = NULL; if (items != 2) croak("Usage: UNIVERSAL::can(object-ref, method)"); @@ -125,8 +143,17 @@ XS(XS_UNIVERSAL_can) name = (char *)SvPV(ST(1),na); rv = &sv_undef; - if(SvROK(sv) && (sv = (SV*)SvRV(sv)) && SvOBJECT(sv)) { - gv = gv_fetchmethod(SvSTASH(sv), name); + if(SvROK(sv)) { + sv = (SV*)SvRV(sv); + if(SvOBJECT(sv)) + pkg = SvSTASH(sv); + } + else { + pkg = gv_stashsv(sv, FALSE); + } + + if (pkg) { + gv = gv_fetchmethod(pkg, name); if(gv && GvCV(gv)) { /* If the sub is only a stub then we may have a gv to AUTOLOAD */ @@ -171,6 +198,7 @@ XS(XS_UNIVERSAL_VERSION) GV *gv; SV *sv; char *undef; + double req; if(SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); @@ -195,9 +223,9 @@ XS(XS_UNIVERSAL_VERSION) undef = "(undef)"; } - if(items > 1 && (undef || SvNV(ST(1)) > SvNV(sv))) + if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) croak("%s version %s required--this is only version %s", - HvNAME(pkg),SvPV(ST(1),na),undef ? undef : SvPV(sv,na)); + HvNAME(pkg), SvPV(ST(1),na), undef ? undef : SvPV(sv,na)); ST(0) = sv; @@ -69,6 +69,18 @@ */ /* #define VMS / **/ +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) # include <signal.h> #endif @@ -19,6 +19,10 @@ #include <signal.h> #endif +#ifndef SIG_ERR +# define SIG_ERR ((Sighandler_t) -1) +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include <unistd.h> @@ -42,13 +46,17 @@ # include <sys/file.h> #endif +#ifdef I_SYS_WAIT +# include <sys/wait.h> +#endif + #define FLUSH #ifdef LEAKTEST static void xstat _((void)); #endif -#ifndef safemalloc +#ifndef MYMALLOC /* paranoid version of malloc */ @@ -60,19 +68,15 @@ static void xstat _((void)); Malloc_t safemalloc(size) -#ifdef MSDOS -unsigned long size; -#else MEM_SIZE size; -#endif /* MSDOS */ { Malloc_t ptr; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0) croak("panic: malloc"); @@ -99,23 +103,20 @@ MEM_SIZE size; Malloc_t saferealloc(where,size) Malloc_t where; -#ifndef MSDOS MEM_SIZE size; -#else -unsigned long size; -#endif /* MSDOS */ { Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) Malloc_t realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef MSDOS - if (size > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; - my_exit(1); - } -#endif /* MSDOS */ +#ifdef HAS_64K_LIMIT + if (size > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Reallocation too large: %lx\n", size) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ if (!where) croak("Null realloc"); #ifdef DEBUGGING @@ -173,12 +174,13 @@ MEM_SIZE size; { Malloc_t ptr; -#ifdef MSDOS - if (size * count > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; - my_exit(1); - } -#endif /* MSDOS */ +#ifdef HAS_64K_LIMIT + if (size * count > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Allocation too large: %lx\n", size * count) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0 || (long)count < 0) croak("panic: calloc"); @@ -203,7 +205,7 @@ MEM_SIZE size; /*NOTREACHED*/ } -#endif /* !safemalloc */ +#endif /* !MYMALLOC */ #ifdef LEAKTEST @@ -404,20 +406,135 @@ char *lend; return Nullch; } -/* Initialize the fold[] array. */ -int -perl_init_fold() +/* + * Set up for a new ctype locale. + */ +void +perl_new_ctype(newctype) + char *newctype; { - int i; +#ifdef USE_LOCALE_CTYPE + + int i; + + for (i = 0; i < 256; i++) { + if (isUPPER_LC(i)) + fold_locale[i] = toLOWER_LC(i); + else if (isLOWER_LC(i)) + fold_locale[i] = toUPPER_LC(i); + else + fold_locale[i] = i; + } - for (i = 0; i < 256; i++) { - if (isUPPER(i)) fold[i] = toLOWER(i); - else if (isLOWER(i)) fold[i] = toUPPER(i); - else fold[i] = i; - } +#endif /* USE_LOCALE_CTYPE */ } -/* Initialize locale (and the fold[] array).*/ +/* + * Set up for a new collation locale. + */ +void +perl_new_collate(newcoll) + char *newcoll; +{ +#ifdef USE_LOCALE_COLLATE + + if (! newcoll) { + if (collation_name) { + ++collation_ix; + Safefree(collation_name); + collation_name = NULL; + collation_standard = TRUE; + collxfrm_base = 0; + collxfrm_mult = 2; + } + return; + } + + if (! collation_name || strNE(collation_name, newcoll)) { + ++collation_ix; + Safefree(collation_name); + collation_name = savepv(newcoll); + collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); + + { + /* 2: at most so many chars ('a', 'b'). */ + /* 50: surely no system expands a char more. */ +#define XFRMBUFSIZE (2 * 50) + char xbuf[XFRMBUFSIZE]; + Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); + Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); + SSize_t mult = fb - fa; + if (mult < 1) + croak("strxfrm() gets absurd"); + collxfrm_base = (fa > mult) ? (fa - mult) : 0; + collxfrm_mult = mult; + } + } + +#endif /* USE_LOCALE_COLLATE */ +} + +/* + * Set up for a new numeric locale. + */ +void +perl_new_numeric(newnum) + char *newnum; +{ +#ifdef USE_LOCALE_NUMERIC + + if (! newnum) { + if (numeric_name) { + Safefree(numeric_name); + numeric_name = NULL; + numeric_standard = TRUE; + numeric_local = TRUE; + } + return; + } + + if (! numeric_name || strNE(numeric_name, newnum)) { + Safefree(numeric_name); + numeric_name = savepv(newnum); + numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); + numeric_local = TRUE; + } + +#endif /* USE_LOCALE_NUMERIC */ +} + +void +perl_set_numeric_standard() +{ +#ifdef USE_LOCALE_NUMERIC + + if (! numeric_standard) { + setlocale(LC_NUMERIC, "C"); + numeric_standard = TRUE; + numeric_local = FALSE; + } + +#endif /* USE_LOCALE_NUMERIC */ +} + +void +perl_set_numeric_local() +{ +#ifdef USE_LOCALE_NUMERIC + + if (! numeric_local) { + setlocale(LC_NUMERIC, numeric_name); + numeric_standard = FALSE; + numeric_local = TRUE; + } + +#endif /* USE_LOCALE_NUMERIC */ +} + + +/* + * Initialize locale awareness. + */ int perl_init_i18nl10n(printwarn) int printwarn; @@ -428,175 +545,298 @@ perl_init_i18nl10n(printwarn) * 0 = fallback to C locale, * -1 = fallback to C locale failed */ -#if defined(HAS_SETLOCALE) - char * lc_all = getenv("LC_ALL"); - char * lc_ctype = getenv("LC_CTYPE"); - char * lc_collate = getenv("LC_COLLATE"); - char * lang = getenv("LANG"); - int setlocale_failure = 0; - -#define SETLOCALE_LC_CTYPE 0x01 -#define SETLOCALE_LC_COLLATE 0x02 - -#ifdef LC_CTYPE - if (setlocale(LC_CTYPE, "") == 0) - setlocale_failure |= SETLOCALE_LC_CTYPE; -#endif - -#ifdef LC_COLLATE - if (setlocale(LC_COLLATE, "") == 0) - setlocale_failure |= SETLOCALE_LC_COLLATE; - else - lc_collate_active = 1; -#endif - - if (setlocale_failure && (lc_all || lang)) { - char *perl_badlang; - - if (printwarn > 1 || - printwarn && - (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) { - - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Setting locale failed for the categories:\n\t"); -#ifdef LC_CTYPE - if (setlocale_failure & SETLOCALE_LC_CTYPE) + +#ifdef USE_LOCALE + +#ifdef USE_LOCALE_CTYPE + char *curctype = NULL; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + char *curcoll = NULL; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + char *curnum = NULL; +#endif /* USE_LOCALE_NUMERIC */ + char *lc_all = getenv("LC_ALL"); + char *lang = getenv("LANG"); + bool setlocale_failure = FALSE; + +#ifdef LOCALE_ENVIRON_REQUIRED + + /* + * Ultrix setlocale(..., "") fails if there are no environment + * variables from which to get a locale name. + */ + + bool done = FALSE; + +#ifdef LC_ALL + if (lang) { + if (setlocale(LC_ALL, "")) + done = TRUE; + else + setlocale_failure = TRUE; + } + if (!setlocale_failure) +#endif /* LC_ALL */ + { +#ifdef USE_LOCALE_CTYPE + if (! (curctype = setlocale(LC_CTYPE, + (!done && (lang || getenv("LC_CTYPE"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! (curcoll = setlocale(LC_COLLATE, + (!done && (lang || getenv("LC_COLLATE"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! (curnum = setlocale(LC_NUMERIC, + (!done && (lang || getenv("LC_NUMERIC"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_NUMERIC */ + } + +#else /* !LOCALE_ENVIRON_REQUIRED */ + +#ifdef LC_ALL + + if (! setlocale(LC_ALL, "")) + setlocale_failure = TRUE; + else { +#ifdef USE_LOCALE_CTYPE + curctype = setlocale(LC_CTYPE, Nullch); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + curcoll = setlocale(LC_COLLATE, Nullch); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + curnum = setlocale(LC_NUMERIC, Nullch); +#endif /* USE_LOCALE_NUMERIC */ + } + +#else /* !LC_ALL */ + +#ifdef USE_LOCALE_CTYPE + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_NUMERIC */ + +#endif /* LC_ALL */ + +#endif /* !LOCALE_ENVIRON_REQUIRED */ + + if (setlocale_failure) { + char *p; + bool locwarn = (printwarn > 1 || + printwarn && + (!(p = getenv("PERL_BADLANG")) || atoi(p))); + + if (locwarn) { +#ifdef LC_ALL + PerlIO_printf(PerlIO_stderr(), - "LC_CTYPE "); -#endif -#ifdef LC_COLLATE - if (setlocale_failure & SETLOCALE_LC_COLLATE) + "perl: warning: Setting locale failed.\n"); + +#else /* !LC_ALL */ + PerlIO_printf(PerlIO_stderr(), - "LC_COLLATE "); -#endif - PerlIO_printf(PerlIO_stderr(), - "\n"); + "perl: warning: Setting locale failed for the categories:\n\t"); +#ifdef USE_LOCALE_CTYPE + if (! curctype) + PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! curcoll) + PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! curnum) + PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); +#endif /* USE_LOCALE_NUMERIC */ + PerlIO_printf(PerlIO_stderr(), "\n"); + +#endif /* LC_ALL */ + + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Please check that your locale settings:\n"); PerlIO_printf(PerlIO_stderr(), - "perl: warning: Please check that your locale settings:\n"); - - PerlIO_printf(PerlIO_stderr(), - "\tLC_ALL = %c%s%c,\n", - lc_all ? '"' : '(', - lc_all ? lc_all : "unset", - lc_all ? '"' : ')' - ); -#ifdef LC_CTYPE - if (setlocale_failure & SETLOCALE_LC_CTYPE) + "\tLC_ALL = %c%s%c,\n", + lc_all ? '"' : '(', + lc_all ? lc_all : "unset", + lc_all ? '"' : ')'); + + { + char **e; + for (e = environ; *e; e++) { + if (strnEQ(*e, "LC_", 3) + && strnNE(*e, "LC_ALL=", 7) + && (p = strchr(*e, '='))) + PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", + (p - *e), *e, p + 1); + } + } + PerlIO_printf(PerlIO_stderr(), - "\tLC_CTYPE = %c%s%c,\n", - lc_ctype ? '"' : '(', - lc_ctype ? lc_ctype : "unset", - lc_ctype ? '"' : ')' - ); -#endif -#ifdef LC_COLLATE - if (setlocale_failure & SETLOCALE_LC_COLLATE) + "\tLANG = %c%s%c\n", + lang ? '"' : '(', + lang ? lang : "unset", + lang ? '"' : ')'); + PerlIO_printf(PerlIO_stderr(), - "\tLC_COLLATE = %c%s%c,\n", - lc_collate ? '"' : '(', - lc_collate ? lc_collate : "unset", - lc_collate ? '"' : ')' - ); -#endif - PerlIO_printf(PerlIO_stderr(), - "\tLANG = %c%s%c\n", - lang ? '"' : ')', - lang ? lang : "unset", - lang ? '"' : ')' - ); - - PerlIO_printf(PerlIO_stderr(), - " are supported and installed on your system.\n"); - - ok = 0; - + " are supported and installed on your system.\n"); } + #ifdef LC_ALL - if (setlocale_failure) { - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Falling back to the \"C\" locale.\n"); - if (setlocale(LC_ALL, "C") == NULL) { + + if (setlocale(LC_ALL, "C")) { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Falling back to the standard locale (\"C\").\n"); + ok = 0; + } + else { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); ok = -1; - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Failed to fall back to the \"C\" locale.\n"); - } - } -#else - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Cannot fall back to the \"C\" locale.\n"); -#endif + } + +#else /* ! LC_ALL */ + + if (0 +#ifdef USE_LOCALE_CTYPE + || !(curctype || setlocale(LC_CTYPE, "C")) +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + || !(curcoll || setlocale(LC_COLLATE, "C")) +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + || !(curnum || setlocale(LC_NUMERIC, "C")) +#endif /* USE_LOCALE_NUMERIC */ + ) + { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); + ok = -1; + } + +#endif /* ! LC_ALL */ + +#ifdef USE_LOCALE_CTYPE + curctype = setlocale(LC_CTYPE, Nullch); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + curcoll = setlocale(LC_COLLATE, Nullch); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + curnum = setlocale(LC_NUMERIC, Nullch); +#endif /* USE_LOCALE_NUMERIC */ } - if (setlocale_failure & SETLOCALE_LC_CTYPE == 0) - perl_init_fold(); +#ifdef USE_LOCALE_CTYPE + perl_new_ctype(curctype); +#endif /* USE_LOCALE_CTYPE */ -#endif /* #if defined(HAS_SETLOCALE) */ +#ifdef USE_LOCALE_COLLATE + perl_new_collate(curcoll); +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + perl_new_numeric(curnum); +#endif /* USE_LOCALE_NUMERIC */ + +#endif /* USE_LOCALE */ return ok; } +/* Backwards compatibility. */ +int +perl_init_i18nl14n(printwarn) + int printwarn; +{ + return perl_init_i18nl10n(printwarn); +} + +#ifdef USE_LOCALE_COLLATE + +/* + * mem_collxfrm() is a bit like strxfrm() but with two important + * differences. First, it handles embedded NULs. Second, it allocates + * a bit more memory than needed for the transformed data itself. + * The real transformed data begins at offset sizeof(collationix). + * Please see sv_collxfrm() to see how this is used. + */ char * -mem_collxfrm(m, n, nx) /* mem_collxfrm() does strxfrm() for (data,size) */ - const char *m; /* "strings", that is, transforms normal eight-bit */ - const Size_t n; /* data into a format that can be memcmp()ed to get */ - Size_t * nx; /* 'the right' result for each locale. */ -{ /* Uses strxfrm() but handles embedded NULs. */ - char * mx = 0; - -#ifdef HAS_STRXFRM - Size_t ma; - - /* the expansion factor of 16 has been seen with strxfrm() */ - ma = (lc_collate_active ? 16 : 1) * n + 1; - -#define RENEW_mx() \ - do { \ - ma = 2 * ma + 1; \ - Renew(mx, ma, char); \ - if (mx == 0) \ - goto out; \ - } while (0) - - New(171, mx, ma, char); - - if (mx) { - Size_t xc, dx; - int xok; - - for (*nx = 0, xc = 0; xc < n; ) { - if (m[xc] == 0) - do { - if (*nx == ma) - RENEW_mx(); - mx[*nx++] = m[xc++]; - } while (xc < n && m[xc] == 0); - else { - do { - dx = strxfrm(mx + *nx, m + xc, ma - *nx); - if (dx + *nx > ma) { - RENEW_mx(); - xok = 0; - } else - xok = 1; - } while (!xok); - xc += strlen(mx + *nx); - *nx += dx; - } - } - } - -out: - -#endif /* HAS_STRXFRM */ - - return mx; +mem_collxfrm(s, len, xlen) + const char *s; + STRLEN len; + STRLEN *xlen; +{ + char *xbuf; + STRLEN xalloc, xin, xout; + + /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ + /* the +1 is for the terminating NUL. */ + + xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1; + New(171, xbuf, xalloc, char); + if (! xbuf) + goto bad; + + *(U32*)xbuf = collation_ix; + xout = sizeof(collation_ix); + for (xin = 0; xin < len; ) { + SSize_t xused; + + for (;;) { + xused = strxfrm(xbuf + xout, s + xin, xalloc - xout); + if (xused == -1) + goto bad; + if (xused < xalloc - xout) + break; + xalloc = (2 * xalloc) + 1; + Renew(xbuf, xalloc, char); + if (! xbuf) + goto bad; + } + + xin += strlen(s + xin) + 1; + xout += xused; + + /* Embedded NULs are understood but silently skipped + * because they make no sense in locale collation. */ + } + + xbuf[xout] = '\0'; + *xlen = xout - sizeof(collation_ix); + return xbuf; + + bad: + Safefree(xbuf); + *xlen = 0; + return NULL; } +#endif /* USE_LOCALE_COLLATE */ + void -fbm_compile(sv, iflag) +fbm_compile(sv) SV *sv; -I32 iflag; { register unsigned char *s; register unsigned char *table; @@ -616,47 +856,19 @@ I32 iflag; i = 0; while (s >= (unsigned char*)(SvPVX(sv))) { - if (table[*s] == len) { -#ifndef pdp11 - if (iflag) - table[*s] = table[fold[*s]] = i; -#else - if (iflag) { - I32 j; - j = fold[*s]; - table[j] = i; - table[*s] = i; - } -#endif /* pdp11 */ - else - table[*s] = i; - } + if (table[*s] == len) + table[*s] = i; s--,i++; } sv_upgrade(sv, SVt_PVBM); - sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ - if (iflag) { - register U32 tmp, foldtmp; - SvCASEFOLD_on(sv); - for (i = 0; i < len; i++) { - tmp=freq[s[i]]; - foldtmp=freq[fold[s[i]]]; - if (tmp < frequency && foldtmp < frequency) { - rarest = i; - /* choose most frequent among the two */ - frequency = (tmp > foldtmp) ? tmp : foldtmp; - } - } - } - else { - for (i = 0; i < len; i++) { - if (freq[s[i]] < frequency) { - rarest = i; - frequency = freq[s[i]]; - } + for (i = 0; i < len; i++) { + if (freq[s[i]] < frequency) { + rarest = i; + frequency = freq[s[i]]; } } BmRARE(sv) = s[rarest]; @@ -691,91 +903,50 @@ SV *littlestr; if (littlelen > bigend - big) return Nullch; little = (unsigned char*)SvPVX(littlestr); - if (SvCASEFOLD(littlestr)) { /* oops, fake it */ - big = bigend - littlelen; /* just start near end */ - if (bigend[-1] == '\n' && little[littlelen-1] != '\n') - big--; - } - else { - s = bigend - littlelen; - if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) - return (char*)s; /* how sweet it is */ - else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' - && s > big) { - s--; - if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) - return (char*)s; - } - return Nullch; + s = bigend - littlelen; + if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) + return (char*)s; /* how sweet it is */ + else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' + && s > big) { + s--; + if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) + return (char*)s; } + return Nullch; } table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); if (--littlelen >= bigend - big) return Nullch; s = big + littlelen; oldlittle = little = table - 2; - if (SvCASEFOLD(littlestr)) { /* case insensitive? */ - if (s < bigend) { - top1: - /*SUPPRESS 560*/ - if (tmp = table[*s]) { + if (s < bigend) { + top2: + /*SUPPRESS 560*/ + if (tmp = table[*s]) { #ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top1; - } + if (bigend - s > tmp) { + s += tmp; + goto top2; + } #else - if ((s += tmp) < bigend) - goto top1; + if ((s += tmp) < bigend) + goto top2; #endif - return Nullch; - } - else { - tmp = littlelen; /* less expensive than calling strncmp() */ - olds = s; - while (tmp--) { - if (*--s == *--little || fold[*s] == *little) - continue; - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ - goto top1; - return Nullch; - } - return (char *)s; - } + return Nullch; } - } - else { - if (s < bigend) { - top2: - /*SUPPRESS 560*/ - if (tmp = table[*s]) { -#ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top2; - } -#else - if ((s += tmp) < bigend) + else { + tmp = littlelen; /* less expensive than calling strncmp() */ + olds = s; + while (tmp--) { + if (*--s == *--little) + continue; + s = olds + 1; /* here we pay the price for failure */ + little = oldlittle; + if (s < bigend) /* fake up continue to outer loop */ goto top2; -#endif return Nullch; } - else { - tmp = littlelen; /* less expensive than calling strncmp() */ - olds = s; - while (tmp--) { - if (*--s == *--little) - continue; - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ - goto top2; - return Nullch; - } - return (char *)s; - } + return (char *)s; } } return Nullch; @@ -808,96 +979,66 @@ SV *littlestr; return Nullch; } #ifdef POINTERRIGOR - if (SvCASEFOLD(littlestr)) { /* case insignificant? */ - do { - if (big[pos-previous] != first && big[pos-previous] != fold[first]) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { - s--; - break; - } - } - if (s == littleend) - return (char *)(big+pos-previous); - } while ( - pos += screamnext[pos] /* does this goof up anywhere? */ - ); - } - else { - do { - if (big[pos-previous] != first) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++) { - s--; - break; - } + do { + if (big[pos-previous] != first) + continue; + for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++) { + s--; + break; } - if (s == littleend) - return (char *)(big+pos-previous); - } while ( pos += screamnext[pos] ); - } + } + if (s == littleend) + return (char *)(big+pos-previous); + } while ( pos += screamnext[pos] ); #else /* !POINTERRIGOR */ big -= previous; - if (SvCASEFOLD(littlestr)) { /* case insignificant? */ - do { - if (big[pos] != first && big[pos] != fold[first]) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { - s--; - break; - } - } - if (s == littleend) - return (char *)(big+pos); - } while ( - pos += screamnext[pos] /* does this goof up anywhere? */ - ); - } - else { - do { - if (big[pos] != first) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++) { - s--; - break; - } + do { + if (big[pos] != first) + continue; + for (x=big+pos+1,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++) { + s--; + break; } - if (s == littleend) - return (char *)(big+pos); - } while ( - pos += screamnext[pos] - ); - } + } + if (s == littleend) + return (char *)(big+pos); + } while ( pos += screamnext[pos] ); #endif /* POINTERRIGOR */ return Nullch; } I32 -ibcmp(a,b,len) -register U8 *a; -register U8 *b; +ibcmp(s1, s2, len) +char *s1, *s2; register I32 len; { + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; while (len--) { - if (*a == *b) { - a++,b++; - continue; - } - if (fold[*a++] == *b++) - continue; - return 1; + if (*a != *b && *a != fold[*b]) + return 1; + a++,b++; + } + return 0; +} + +I32 +ibcmp_locale(s1, s2, len) +char *s1, *s2; +register I32 len; +{ + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; + while (len--) { + if (*a != *b && *a != fold_locale[*b]) + return 1; + a++,b++; } return 0; } @@ -930,167 +1071,14 @@ register I32 len; return newaddr; } -#if !defined(I_STDARG) && !defined(I_VARARGS) - -/* - * Fallback on the old hackers way of doing varargs - */ - -/*VARARGS1*/ -char * -mess(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; -{ - char *s; - char *s_start; - I32 usermess = strEQ(pat,"%s"); - SV *tmpstr; - - s = s_start = buf; - if (usermess) { - tmpstr = sv_newmortal(); - sv_setpv(tmpstr, (char*)a1); - *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; - } - else { - (void)sprintf(s,pat,a1,a2,a3,a4); - s += strlen(s); - } - - if (s[-1] != '\n') { - if (dirty) - strcpy(s, " during global destruction.\n"); - else { - if (curcop->cop_line) { - (void)sprintf(s," at %s line %ld", - SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); - s += strlen(s); - } - if (GvIO(last_in_gv) && - IoLINES(GvIOp(last_in_gv)) ) { - (void)sprintf(s,", <%s> %s %ld", - last_in_gv == argvgv ? "" : GvENAME(last_in_gv), - strEQ(rs,"\n") ? "line" : "chunk", - (long)IoLINES(GvIOp(last_in_gv))); - s += strlen(s); - } - (void)strcpy(s,".\n"); - s += 2; - } - if (usermess) - sv_catpv(tmpstr,buf+1); - } - - if (s - s_start >= sizeof(buf)) { /* Ooops! */ - if (usermess) - PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); - else - PerlIO_puts(PerlIO_stderr(), buf); - PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n"); - my_exit(1); - } - if (usermess) - return SvPVX(tmpstr); - else - return buf; -} - -/*VARARGS1*/ -void croak(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; -{ - char *tmps; - char *message; - HV *stash; - GV *gv; - CV *cv; - - message = mess(pat,a1,a2,a3,a4); - if (diehook) { - SV *olddiehook = diehook; - diehook = Nullsv; /* sv_2cv might call croak() */ - cv = sv_2cv(olddiehook, &stash, &gv, 0); - diehook = olddiehook; - if (cv && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - } - } - if (in_eval) { - restartop = die_where(message); - Siglongjmp(top_env, 3); - } - PerlIO_puts(PerlIO_stderr(),message); - (void)PerlIO_flush(PerlIO_stderr()); - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - } - statusvalue = SHIFTSTATUS(statusvalue); -#ifdef VMS - my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT); -#else - my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); -#endif -} - -/*VARARGS1*/ -void warn(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; -{ - char *message; - SV *sv; - HV *stash; - GV *gv; - CV *cv; - - message = mess(pat,a1,a2,a3,a4); - if (warnhook) { - SV *oldwarnhook = warnhook; - warnhook = Nullsv; /* sv_2cv might end up calling warn() */ - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - warnhook = oldwarnhook; - if (cv && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - return; - } - } - PerlIO_puts(PerlIO_stderr(),message); -#ifdef LEAKTEST - DEBUG_L(xstat()); -#endif - (void)PerlIO_flush(PerlIO_stderr()); -} - -#else /* !defined(I_STDARG) && !defined(I_VARARGS) */ - #ifdef I_STDARG char * -mess(char *pat, va_list *args) +mess(const char *pat, va_list *args) #else /*VARARGS0*/ char * mess(pat, args) - char *pat; + const char *pat; va_list *args; #endif { @@ -1111,7 +1099,7 @@ mess(pat, args) if (usermess) { tmpstr = sv_newmortal(); sv_setpv(tmpstr, va_arg(*args, char *)); - *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; + *s++ = SvCUR(tmpstr) ? SvPVX(tmpstr)[SvCUR(tmpstr)-1] : ' '; } else { (void) vsprintf(s,pat,*args); @@ -1119,7 +1107,7 @@ mess(pat, args) } va_end(*args); - if (s[-1] != '\n') { + if (!(s > s_start && s[-1] == '\n')) { if (dirty) strcpy(s, " during global destruction.\n"); else { @@ -1159,8 +1147,71 @@ mess(pat, args) } #ifdef I_STDARG +OP * +die(const char* pat, ...) +#else +/*VARARGS0*/ +OP * +die(pat, va_alist) + const char *pat; + va_dcl +#endif +{ + va_list args; + char *message; + int oldrunlevel = runlevel; + int was_in_eval = in_eval; + HV *stash; + GV *gv; + CV *cv; + + /* We have to switch back to mainstack or die_where may try to pop + * the eval block from the wrong stack if die is being called from a + * signal handler. - dkindred@cs.cmu.edu */ + if (curstack != mainstack) { + dSP; + SWITCHSTACK(curstack, mainstack); + } + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + message = mess(pat, &args); + va_end(args); + + if (diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = diehook; + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg = sv_2mortal(newSVpv(message, 0)); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + /* It's okay for the __DIE__ hook to modify the message. */ + message = SvPV(msg, na); + } + } + + restartop = die_where(message); + if ((!restartop && was_in_eval) || oldrunlevel > 1) + Siglongjmp(top_env, 3); + return restartop; +} + +#ifdef I_STDARG void -croak(char* pat, ...) +croak(const char* pat, ...) #else /*VARARGS0*/ void @@ -1183,18 +1234,24 @@ croak(pat, va_alist) message = mess(pat, &args); va_end(args); if (diehook) { + /* sv_2cv might call croak() */ SV *olddiehook = diehook; - diehook = Nullsv; /* sv_2cv might call croak() */ + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; cv = sv_2cv(olddiehook, &stash, &gv, 0); - diehook = olddiehook; - if (cv && !CvDEPTH(cv)) { + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; + SV *msg = sv_2mortal(newSVpv(message, 0)); PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); + + /* It's okay for the __DIE__ hook to modify the message. */ + message = SvPV(msg, na); } } if (in_eval) { @@ -1222,11 +1279,11 @@ croak(pat, va_alist) void #ifdef I_STDARG -warn(char* pat,...) +warn(const char* pat,...) #else /*VARARGS0*/ warn(pat,va_alist) - char *pat; + const char *pat; va_dcl #endif { @@ -1245,16 +1302,17 @@ warn(pat,va_alist) va_end(args); if (warnhook) { + /* sv_2cv might call warn() */ SV *oldwarnhook = warnhook; - warnhook = Nullsv; /* sv_2cv might end up calling warn() */ + ENTER; + SAVESPTR(warnhook); + warnhook = Nullsv; cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - warnhook = oldwarnhook; - if (cv && !CvDEPTH(cv)) { + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(sv_2mortal(newSVpv(message,0))); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); return; @@ -1266,7 +1324,6 @@ warn(pat,va_alist) #endif (void)PerlIO_flush(PerlIO_stderr()); } -#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ #ifndef VMS /* VMS' my_setenv() is in VMS.c */ void @@ -1378,22 +1435,24 @@ register I32 len; } #endif -#ifndef HAS_MEMCMP +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 my_memcmp(s1,s2,len) -register unsigned char *s1; -register unsigned char *s2; +char *s1; +char *s2; register I32 len; { + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; register I32 tmp; while (len--) { - if (tmp = *s1++ - *s2++) + if (tmp = *a++ - *b++) return tmp; } return 0; } -#endif /* HAS_MEMCMP */ +#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #if defined(I_STDARG) || defined(I_VARARGS) #ifndef HAS_VPRINTF @@ -1404,7 +1463,9 @@ char * int #endif vsprintf(dest, pat, args) -char *dest, *pat, *args; +char *dest; +const char *pat; +char *args; { FILE fakebuf; @@ -1576,8 +1637,8 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in - VMS.c, same with OS/2. */ + /* VMS' my_popen() is in VMS.c, same with OS/2. */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) PerlIO * my_popen(cmd,mode) char *cmd; @@ -1598,11 +1659,9 @@ char *mode; return Nullfp; this = (*mode == 'w'); that = !this; - if (tainting) { - if (doexec) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); - } + if (doexec && tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { @@ -1659,7 +1718,7 @@ char *mode; return PerlIO_fdopen(p[this], mode); } #else -#if defined(atarist) +#if defined(atarist) || defined(DJGPP) FILE *popen(); PerlIO * my_popen(cmd,mode) @@ -1667,7 +1726,8 @@ char *cmd; char *mode; { /* Needs work for PerlIO ! */ - return popen(PerlIO_exportFILE(cmd), mode); + /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + return popen(PerlIO_exportFILE(cmd, 0), mode); } #endif @@ -1717,12 +1777,126 @@ int newfd; } #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ + +#ifdef HAS_SIGACTION + +Sighandler_t +rsignal(signo, handler) +int signo; +Sighandler_t handler; +{ + struct sigaction act, oact; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + if (sigaction(signo, &act, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +Sighandler_t +rsignal_state(signo) +int signo; +{ + struct sigaction oact; + + if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +int +rsignal_save(signo, handler, save) +int signo; +Sighandler_t handler; +Sigsave_t *save; +{ + struct sigaction act; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + return sigaction(signo, &act, save); +} + +int +rsignal_restore(signo, save) +int signo; +Sigsave_t *save; +{ + return sigaction(signo, save, (struct sigaction *)NULL); +} + +#else /* !HAS_SIGACTION */ + +Sighandler_t +rsignal(signo, handler) +int signo; +Sighandler_t handler; +{ + return signal(signo, handler); +} + +static int sig_trapped; + +static +Signal_t +sig_trap(signo) +int signo; +{ + sig_trapped++; +} + +Sighandler_t +rsignal_state(signo) +int signo; +{ + Sighandler_t oldsig; + + sig_trapped = 0; + oldsig = signal(signo, sig_trap); + signal(signo, oldsig); + if (sig_trapped) + kill(getpid(), signo); + return oldsig; +} + +int +rsignal_save(signo, handler, save) +int signo; +Sighandler_t handler; +Sigsave_t *save; +{ + *save = signal(signo, handler); + return (*save == SIG_ERR) ? -1 : 0; +} + +int +rsignal_restore(signo, save) +int signo; +Sigsave_t *save; +{ + return (signal(signo, *save) == SIG_ERR) ? -1 : 0; +} + +#endif /* !HAS_SIGACTION */ + + /* VMS' my_pclose() is in VMS.c; same with OS/2 */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) I32 my_pclose(ptr) PerlIO *ptr; { - Signal_t (*hstat)(), (*istat)(), (*qstat)(); + Sigsave_t hstat, istat, qstat; int status; SV **svp; int pid; @@ -1740,15 +1914,15 @@ PerlIO *ptr; #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif - hstat = signal(SIGHUP, SIG_IGN); - istat = signal(SIGINT, SIG_IGN); - qstat = signal(SIGQUIT, SIG_IGN); + rsignal_save(SIGHUP, SIG_IGN, &hstat); + rsignal_save(SIGINT, SIG_IGN, &istat); + rsignal_save(SIGQUIT, SIG_IGN, &qstat); do { pid = wait4pid(pid, &status, 0); } while (pid == -1 && errno == EINTR); - signal(SIGHUP, hstat); - signal(SIGINT, istat); - signal(SIGQUIT, qstat); + rsignal_restore(SIGHUP, &hstat); + rsignal_restore(SIGINT, &istat); + rsignal_restore(SIGQUIT, &qstat); return(pid < 0 ? pid : status); } #endif /* !DOSISH */ @@ -1827,7 +2001,7 @@ int status; return; } -#if defined(atarist) || defined(OS2) +#if defined(atarist) || defined(OS2) || defined(DJGPP) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -1988,18 +2162,23 @@ char *b; } #endif /* !HAS_RENAME */ -unsigned long +UV scan_oct(start, len, retlen) char *start; I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; while (len && *s >= '0' && *s <= '7') { - retval <<= 3; - retval |= *s++ - '0'; + register UV n = retval << 3; + if (!overflowed && (n >> 3) != retval) { + warn("Integer overflow in octal number"); + overflowed = TRUE; + } + retval = n | (*s++ - '0'); len--; } if (dowarn && len && (*s == '8' || *s == '9')) @@ -2008,19 +2187,24 @@ I32 *retlen; return retval; } -unsigned long +UV scan_hex(start, len, retlen) char *start; I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; char *tmp; while (len-- && *s && (tmp = strchr(hexdigit, *s))) { - retval <<= 4; - retval |= (tmp - hexdigit) & 15; + register UV n = retval << 4; + if (!overflowed && (n >> 4) != retval) { + warn("Integer overflow in hex number"); + overflowed = TRUE; + } + retval = n | (tmp - hexdigit) & 15; s++; } *retlen = s - start; diff --git a/utils/Makefile b/utils/Makefile index 33947c87f1..958dc038d7 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -4,16 +4,16 @@ PERL = ../miniperl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL - -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain all: $(plextract) $(plextract): $(PERL) -I../lib $@.PL +splain: ../lib/diagnostics.pm + clean: realclean: diff --git a/utils/c2ph.PL b/utils/c2ph.PL index 97d17af655..9f80bc04a6 100644 --- a/utils/c2ph.PL +++ b/utils/c2ph.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 22161b9791..bfd606d399 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -13,10 +13,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -26,10 +24,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; - +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -55,6 +52,10 @@ $inif = 0; @ARGV = ('-') unless @ARGV; foreach $file (@ARGV) { + # Recover from header files with unbalanced cpp directives + $t = ''; + $tab = 0; + if ($file eq '-') { open(IN, "-"); open(OUT, ">-"); @@ -103,7 +104,7 @@ foreach $file (@ARGV) { $args = "local($args) = \@_;\n$t "; } s/^\s+//; - do expr(); + expr(); $new =~ s/(["\\])/\\$1/g; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; @@ -117,7 +118,7 @@ foreach $file (@ARGV) { } else { s/^\s+//; - do expr(); + expr(); $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; @@ -145,7 +146,7 @@ foreach $file (@ARGV) { elsif (s/^if\s+//) { $new = ''; $inif = 1; - do expr(); + expr(); $inif = 0; print OUT $t,"if ($new) {\n"; $tab += 4; @@ -154,7 +155,7 @@ foreach $file (@ARGV) { elsif (s/^elif\s+//) { $new = ''; $inif = 1; - do expr(); + expr(); $inif = 0; $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); @@ -194,10 +195,31 @@ sub expr { } next; }; - s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { - $new .= '$sizeof'; - next; - }; + # replace "sizeof(foo)" with "{foo}" + # also, remove * (C dereference operator) to avoid perl syntax + # problems. Where the %sizeof array comes from is anyone's + # guess (c2ph?), but this at least avoids fatal syntax errors. + # Behavior is undefined if sizeof() delimiters are unbalanced. + # This code was modified to able to handle constructs like this: + # sizeof(*(p)), which appear in the HP-UX 10.01 header files. + s/^sizeof\s*\(// && do { + $new .= '$sizeof'; + my $lvl = 1; # already saw one open paren + # tack { on the front, and skip it in the loop + $_ = "{" . "$_"; + my $index = 1; + # find balanced closing paren + while ($index <= length($_) && $lvl > 0) { + $lvl++ if substr($_, $index, 1) eq "("; + $lvl-- if substr($_, $index, 1) eq ")"; + $index++; + } + # tack } on the end, replacing ) + substr($_, $index - 1, 1) = "}"; + # remove pesky * operators within the sizeof argument + substr($_, 0, $index - 1) =~ s/\*//g; + next; + }; s/^([_a-zA-Z]\w*)// && do { $id = $1; if ($id eq 'struct') { diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 96f6421a28..466fdab9b8 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -873,6 +871,16 @@ if (!@files) { unless ($@) { @files = readdir(D); closedir(D); } } if (!@files) { @files = map {chomp && $_} `ls`; } +if ($^O eq 'VMS') { + foreach (@files) { + # Clip trailing '.' for portability -- non-VMS OSs don't expect it + s%\.$%%; + # Fix up for case-sensitive file systems + s/$modfname/$modfname/i && next; + $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; + $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; + } +} print MANI join("\n",@files); close MANI; !NO!SUBS! diff --git a/utils/perlbug.PL b/utils/perlbug.PL index f1363722d9..ceda89d4d8 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 07540c546b..28bb464f85 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,16 +23,17 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; + +\@pagers = (); +push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; - eval 'exec perl -S $0 "$@"' - if 0; # # Perldoc revision #1 -- look up a piece of documentation in .pod format that @@ -46,7 +45,7 @@ print OUT <<'!NO!SUBS!'; if(@ARGV<1) { die <<EOF; -Usage: $0 [-h] [-v] [-t] [-u] [-m] PageName|ModuleName|ProgramName +Usage: $0 [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName We suggest you use "perldoc perldoc" to get aquainted with the system. @@ -58,12 +57,16 @@ $Is_VMS = $^O eq 'VMS'; sub usage{ warn "@_\n" if @_; + # Make sure exit status is success under VMS, so shell doesn't + # display error messages left over from startup. + ($! = 0, $^E = 1) if $^O eq 'VMS'; die <<EOF; perldoc [-h] [-v] [-u] PageName|ModuleName|ProgramName... -h Display this help message. -t Display pod using pod2text instead of pod2man and nroff. -u Display unformatted pod text -m Display modules file in its entirety + -l Display the modules file name -v Verbosely describe what's going on. PageName|ModuleName... is the name of a piece of documentation that you want to look at. You @@ -83,11 +86,11 @@ use Text::ParseWords; unshift(@ARGV,shellwords($ENV{"PERLDOC"})); -getopts("mhtuv") || usage; +getopts("mhtluv") || usage; usage if $opt_h || $opt_h; # avoid -w warning -usage("only one of -t, -u, or -m") if $opt_t + $opt_u + $opt_m > 1; +usage("only one of -t, -u, -m or -l") if $opt_t + $opt_u + $opt_m + $opt_l > 1; if ($opt_t) { require Pod::Text; import Pod::Text; } @@ -146,6 +149,7 @@ sub containspod { my($recurse,$s,@dirs) = @_; $s =~ s!::!/!g; $s = VMS::Filespec::unixify($s) if $Is_VMS; + return $s if -f $s && containspod($s); printf STDERR "looking for $s in @dirs\n" if $opt_v; my $ret; my $i; @@ -214,20 +218,22 @@ if(!@found) { exit ($Is_VMS ? 98962 : 1); } +if ($opt_l) { + print join("\n", @found), "\n"; + exit; +} + if( ! -t STDOUT ) { $opt_f = 1 } unless($Is_VMS) { $tmp = "/tmp/perldoc1.$$"; - $goodresult = 0; - @pagers = qw( more less pg view cat ); - unshift(@pagers,$ENV{PAGER}) if $ENV{PAGER}; + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } else { - require Config; $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - @pagers = ($Config::Config{'pager'},qw( most more less type/page )); - unshift(@pagers,$ENV{PERLDOC_PAGER}) if $ENV{PERLDOC_PAGER}; - $goodresult = 1; + push @pagers, qw( most more less type/page ); } +unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; if ($opt_m) { foreach $pager (@pagers) { @@ -294,7 +300,7 @@ perldoc - Look up Perl documentation in pod format. =head1 SYNOPSIS -B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] PageName|ModuleName|ProgramName +B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName =head1 DESCRIPTION @@ -335,6 +341,10 @@ This may be useful if the docs don't explain a function in the detail you need, and you'd like to inspect the code directly; perldoc will find the file for you and simply hand it off for display. +=item B<-l> file name only + +Display the file name of the module found. + =item B<PageName|ModuleName|ProgramName> The item you want to look up. Nested modules (such as C<File::Basename>) @@ -361,10 +371,6 @@ Kenneth Albanowski <kjahds@kjahds.com> Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> -=head1 SEE ALSO - -=head1 DIAGNOSTICS - =cut # diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL index e8277bb673..7c187ade35 100644 --- a/utils/pl2pm.PL +++ b/utils/pl2pm.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +23,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -56,7 +54,7 @@ It's just a first step, but it's usually a good first step. =head1 AUTHOR -Larry Wall <lwall@sems.com> +Larry Wall <larry@wall.org> =cut diff --git a/utils/splain.PL b/utils/splain.PL new file mode 100644 index 0000000000..ef7c457dda --- /dev/null +++ b/utils/splain.PL @@ -0,0 +1,45 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries: +# $startperl +# $perlpath +# $eunicefix + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir dirname($0); +$file = basename($0, '.PL'); + +# Open input file before creating output file. +$IN = '../lib/diagnostics.pm'; +open IN or die "Can't open $IN: $!\n"; + +# Create output file. +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +while (<IN>) { + print OUT unless /^package diagnostics/; +} + +close IN; + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/vms/Makefile b/vms/Makefile index 98c0747735..bf6a428d8b 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -1,4 +1,4 @@ -#> This file produced from Descrip.MMS by mms2make.pl +#> This file produced from descrip.mms by mms2make.pl #> Lines beginning with "#>" were commented out during the #> conversion process. For more information, see mms2make.pl #> @@ -32,7 +32,7 @@ ARCH = VMS_VAX OBJVAL = $@ # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00304# +PERL_VERSION = 5_00321# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -61,6 +61,7 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion) XTRACCFLAGS = /Include=[]/Object=$(O) XTRADEF = LIBS2 = sys$$Share:VAXCRTL/Shareable +POSIX = DBGCCFLAGS = /NoList @@ -163,7 +164,7 @@ all : base extras libmods utils podxform archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl perl @ $(NOOP) -extras : Fcntl FileHandle IO Opcode libmods utils podxform +extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) @@ -172,11 +173,11 @@ utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [ podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man @ $(NOOP) -pod1 = [.lib.pod]perl.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod +pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod -pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod -pod5 = [.lib.pod]perlop.pod [.lib.pod]perlovl.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod +pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod +pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod @@ -282,43 +283,43 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) [.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" -FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E) +Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) @ $(NOOP) -[.lib]FileHandle.pm : [.ext.FileHandle]Makefile +[.lib]Fcntl.pm : [.ext.Fcntl]Makefile @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] - @ Set Default [.ext.FileHandle] + @ Set Default [.ext.Fcntl] $(MMS) @ Set Default [--] -[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Makefile - @ Set Default [.ext.FileHandle] +[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Makefile + @ Set Default [.ext.Fcntl] $(MMS) @ Set Default [--] # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.FileHandle]Makefile : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" -Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) +POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) @ $(NOOP) -[.lib]Fcntl.pm : [.ext.Fcntl]Makefile +[.lib]POSIX.pm : [.ext.POSIX]Makefile @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] - @ Set Default [.ext.Fcntl] + @ Set Default [.ext.POSIX] $(MMS) @ Set Default [--] -[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Makefile - @ Set Default [.ext.Fcntl] +[.lib.auto.POSIX]POSIX$(E) : [.ext.POSIX]Makefile + @ Set Default [.ext.POSIX] $(MMS) @ Set Default [--] # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E) @ $(NOOP) @@ -397,6 +398,10 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]pl2pm.PL +[.lib]splain : [.utils]splain.PL $(ARCHDIR)Config.pm + $(MINIPERL) [.utils]splain.PL + Rename/Log [.utils]splain $@ + [.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2html.PL @@ -426,6 +431,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perl.pod $@ +[.lib.pod]perlapio.pod : [.pod]perlapio.pod + @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + @ Copy/Log [.pod]perlapio.pod $@ + [.lib.pod]perlbook.pod : [.pod]perlbook.pod @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perlbook.pod $@ @@ -470,6 +479,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perlguts.pod $@ +[.lib.pod]perllocale.pod : [.pod]perllocale.pod + @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + @ Copy/Log [.pod]perllocale.pod $@ + [.lib.pod]perlipc.pod : [.pod]perlipc.pod @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perlipc.pod $@ @@ -490,10 +503,6 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perlop.pod $@ -[.lib.pod]perlovl.pod : [.pod]perlovl.pod - @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] - @ Copy/Log [.pod]perlovl.pod $@ - [.lib.pod]perlpod.pod : [.pod]perlpod.pod @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log [.pod]perlpod.pod $@ @@ -1389,9 +1398,9 @@ cleanlis : - If f$$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;* tidy : cleanlis - - If f$$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt - - If f$$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O) - - If f$$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) + - If f$$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log [...]*.Opt + - If f$$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [...]*$(O) + - If f$$Search("[...]*$(E);-1").nes."" Then Purge/NoConfirm/Log [...]*$(E) - If f$$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H - If f$$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH - If f$$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c @@ -1415,7 +1424,8 @@ tidy : cleanlis - If f$$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.* - If f$$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If f$$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* - - If f$$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*. + - If f$$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile. + - If f$$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug. - If f$$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*. clean : tidy @@ -1473,7 +1483,7 @@ realclean : clean - If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;* - If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* - - If f$$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;* + - If f$$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. - If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If f$$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* - If f$$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;* diff --git a/vms/config.vms b/vms/config.vms index b9e51c7c25..a7460e5cf5 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -8,10 +8,10 @@ * GenConfig.pl when producing Config.pm. * * config.h for VMS - * Version: 5.002_01 + * Version: 5.003_08 */ -/* Configuration time: 22-Mar-1996 14:45 +/* Configuration time: 19-Nov-1996 23:34 * Configured by: Charles Bailey bailey@genetics.upenn.edu * Target system: VMS */ @@ -76,9 +76,15 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00305" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00321" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +#undef BINCOMPAT3 + /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard @@ -206,6 +212,17 @@ */ #define HAS_FSETPOS /**/ +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <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 /**/ +#ifdef HAS_GETTIMEOFDAY +# define Timeval struct timeval /*config-skip*/ +#endif + /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -255,13 +272,21 @@ * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ -#undef HAS_MBSTOWCS /**/ +#ifdef __DECC +# define HAS_MBSTOWCS /*config-skip*/ +#else +# undef HAS_MBSTOWCS /*config-skip*/ +#endif /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ -#undef HAS_MBTOWC /**/ +#ifdef __DECC +# define HAS_MBTOWC /*config-skip*/ +#else +# undef HAS_MBTOWC /*config-skip*/ +#endif /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available @@ -371,11 +396,6 @@ */ #undef HAS_SETEUID /**/ -/* HAS_SETLOCALE: - * This symbol, if defined, indicates that the setlocale routine is - * available to handle locale-specific ctype implementations. - */ -#undef HAS_SETLOCALE /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is @@ -645,7 +665,11 @@ * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ -#undef HAS_WCSTOMBS /**/ +#ifdef __DECC +# define HAS_WCSTOMBS /*config-skip*/ +#else +# undef HAS_WCSTOMBS /*config-skip*/ +#endif /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should @@ -1060,13 +1084,21 @@ * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ -#undef HAS_MBLEN /**/ +#ifdef __DECC +# define HAS_MBLEN /*config-skip*/ +#else +# undef HAS_MBLEN /*config-skip*/ +#endif /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ -#undef HAS_MKTIME /**/ +#ifdef __DECC +# define HAS_MKTIME /*config-skip*/ +#else +# undef HAS_MKTIME /*config-skip*/ +#endif /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is @@ -1115,13 +1147,39 @@ * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ -#undef HAS_STRCOLL /**/ +#ifdef __DECC +# define HAS_STRCOLL /*config-skip*/ +#else +# undef HAS_STRCOLL /*config-skip*/ +#endif + +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to compare strings using collating information. */ -#undef HAS_STRXFRM /**/ +#ifdef __DECC +# define HAS_STRXFRM /*config-skip*/ +#else +# undef HAS_STRXFRM /*config-skip*/ +#endif /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is @@ -1158,7 +1216,11 @@ * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ -#undef HAS_WCTOMB /**/ +#ifdef __DECC +# define HAS_WCTOMB /*config-skip*/ +#else +# undef HAS_WCTOMB /*config-skip*/ +#endif /* Fpos_t: * This symbol holds the type used to declare file positions in libc. @@ -1199,12 +1261,6 @@ */ #define I_MATH /**/ -/* I_LOCALE: - * This symbol, if defined, indicates to the C program that it should - * include <locale.h>. - */ -#undef I_LOCALE /**/ - /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor * can make decisions based on it. @@ -1467,17 +1523,42 @@ #undef SETUID_SCRIPTS_ARE_SECURE_NOW /**/ #undef DOSUID /**/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + * VMS: SocketShr doesn't support this, so we let the Socket extension + * roll its own. + */ +#undef HAS_INET_ATON /**/ + /* HAS_ISASCII: * This manifest constant lets the C program know that the * isascii is available. */ #define HAS_ISASCII /**/ +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include <locale.h>. + */ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ -#undef HAS_LOCALECONV /**/ +#ifdef __DECC +# define I_LOCALE /*config-skip*/ +# define HAS_SETLOCALE /*config-skip*/ +# define HAS_LOCALECONV /*config-skip*/ +#else +# undef I_LOCALE /*config-skip*/ +# undef HAS_SETLOCALE /*config-skip*/ +# undef HAS_LOCALECONV /*config-skip*/ +#endif /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is @@ -1514,6 +1595,13 @@ */ #define HAS_SAFE_MEMCPY /**/ +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. diff --git a/vms/descrip.mms b/vms/descrip.mms index b628c2c265..32200a3dfa 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00305# +PERL_VERSION = 5_00321# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -94,6 +94,7 @@ XTRADEF = ,GNUC_ATTRIBUTE_CHECK XTRAOBJS = LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library LIBS2 = Sys$Share:VAXCRTL/Shareable +POSIX = .else XTRAOBJS = LIBS1 = $(XTRAOBJS) @@ -117,6 +118,7 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion) LIBS2 = XTRACCFLAGS = /Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=$(OBJVAL) XTRADEF = +POSIX = POSIX .else # VAXC .first @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms" @@ -126,6 +128,7 @@ XTRADEF = XTRACCFLAGS = /Include=[]/Object=$(O) XTRADEF = LIBS2 = Sys$Share:VAXCRTL/Shareable +POSIX = .endif .endif @@ -267,7 +270,7 @@ all : base extras libmods utils podxform archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl perl @ $(NOOP) -extras : Fcntl FileHandle IO Opcode libmods utils podxform +extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) @@ -276,11 +279,11 @@ utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [ podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man @ $(NOOP) -pod1 = [.lib.pod]perl.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod +pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod -pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod -pod5 = [.lib.pod]perlop.pod [.lib.pod]perlovl.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod +pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod +pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod @@ -401,43 +404,43 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) [.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" -FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E) +Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) @ $(NOOP) -[.lib]FileHandle.pm : [.ext.FileHandle]Descrip.MMS +[.lib]Fcntl.pm : [.ext.Fcntl]Descrip.MMS @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] - @ Set Default [.ext.FileHandle] + @ Set Default [.ext.Fcntl] $(MMS) @ Set Default [--] -[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Descrip.MMS - @ Set Default [.ext.FileHandle] +[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Descrip.MMS + @ Set Default [.ext.Fcntl] $(MMS) @ Set Default [--] # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.FileHandle]Descrip.MMS : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" -Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) +POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) @ $(NOOP) -[.lib]Fcntl.pm : [.ext.Fcntl]Descrip.MMS +[.lib]POSIX.pm : [.ext.POSIX]Descrip.MMS @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] - @ Set Default [.ext.Fcntl] + @ Set Default [.ext.POSIX] $(MMS) @ Set Default [--] -[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Descrip.MMS - @ Set Default [.ext.Fcntl] +[.lib.auto.POSIX]POSIX$(E) : [.ext.POSIX]Descrip.MMS + @ Set Default [.ext.POSIX] $(MMS) @ Set Default [--] # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E) @ $(NOOP) @@ -516,6 +519,10 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) +[.lib]splain : [.utils]splain.PL $(ARCHDIR)Config.pm + $(MINIPERL) $(MMS$SOURCE) + Rename/Log [.utils]splain $(MMS$TARGET) + [.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) @@ -545,6 +552,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +[.lib.pod]perlapio.pod : [.pod]perlapio.pod + @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) + [.lib.pod]perlbook.pod : [.pod]perlbook.pod @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -589,6 +600,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +[.lib.pod]perllocale.pod : [.pod]perllocale.pod + @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) + [.lib.pod]perlipc.pod : [.pod]perlipc.pod @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -609,10 +624,6 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS] @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) -[.lib.pod]perlovl.pod : [.pod]perlovl.pod - @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] - @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) - [.lib.pod]perlpod.pod : [.pod]perlpod.pod @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -1543,9 +1554,9 @@ cleanlis : - If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;* tidy : cleanlis - - If F$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt - - If F$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O) - - If F$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) + - If F$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log [...]*.Opt + - If F$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [...]*$(O) + - If F$Search("[...]*$(E);-1").nes."" Then Purge/NoConfirm/Log [...]*$(E) - If F$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H - If F$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH - If F$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c @@ -1569,7 +1580,8 @@ tidy : cleanlis - If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.* - If F$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* - - If F$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*. + - If F$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile. + - If F$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug. - If F$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*. clean : tidy @@ -1585,6 +1597,11 @@ clean : tidy Set Default [.ext.Opcode] - $(MMS) clean Set Default [--] +.ifdef DECC + Set Default [.ext.POSIX] + - $(MMS) clean + Set Default [--] +.endif - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* @@ -1618,6 +1635,11 @@ realclean : clean Set Default [.ext.Opcode] - $(MMS) realclean Set Default [--] +.ifdef DECC + Set Default [.ext.POSIX] + - $(MMS) realclean + Set Default [--] +.endif - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);* - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);" @@ -1627,7 +1649,7 @@ realclean : clean - If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;* - If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* - - If F$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;* + - If F$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. - If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If F$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* - If F$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;* diff --git a/vms/ext/DCLsym/0README.txt b/vms/ext/DCLsym/0README.txt new file mode 100644 index 0000000000..9dc721d36b --- /dev/null +++ b/vms/ext/DCLsym/0README.txt @@ -0,0 +1,21 @@ +VMS::DCLsym is an extension to Perl 5 which allows it to manipulate DCL symbols +via an object-oriented or tied-hash interface. + +In order to build the extension, just say + +$ Perl Makefile.PL +$ MMK + +in the directory containing the source files. Once it's built, you can run the +test script by saying + +$ Perl "-Iblib" test.pl + +Finally, if you want to make it part of your regular Perl library, you can say +$ MMK install + +If you have any problems or suggestions, please feel free to let me know. + +Regards, +Charles Bailey bailey@genetics.upenn.edu +17-Aug-1995 diff --git a/vms/ext/DCLsym/DCLsym.pm b/vms/ext/DCLsym/DCLsym.pm new file mode 100644 index 0000000000..057951dd99 --- /dev/null +++ b/vms/ext/DCLsym/DCLsym.pm @@ -0,0 +1,268 @@ +package VMS::DCLsym; + +use Carp; +use DynaLoader; +use vars qw( @ISA $VERSION ); +use strict; + +# Package globals +@ISA = ( 'DynaLoader' ); +$VERSION = '1.01'; +my(%Locsyms) = ( ':ID' => 'LOCAL' ); +my(%Gblsyms) = ( ':ID' => 'GLOBAL'); +my $DoCache = 1; +my $Cache_set = 0; + + +#====> OO methods + +sub new { + my($pkg,$type) = @_; + bless { TYPE => $type }, $pkg; +} + +sub DESTROY { } + +sub getsym { + my($self,$name) = @_; + my($val,$table); + + if (($val,$table) = _getsym($name)) { + if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + } + wantarray ? ($val,$table) : $val; +} + +sub setsym { + my($self,$name,$val,$table) = @_; + + $table = $self->{TYPE} unless $table; + if (_setsym($name,$val,$table)) { + if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + 1; + } + else { 0; } +} + +sub delsym { + my($self,$name,$table) = @_; + + $table = $self->{TYPE} unless $table; + if (_delsym($name,$table)) { + if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; } + else { delete $Locsyms{$name}; } + 1; + } + else { 0; } +} + +sub clearcache { + my($self,$perm) = @_; + my($old); + + $Cache_set = 0; + %Locsyms = ( ':ID' => 'LOCAL'); + %Gblsyms = ( ':ID' => 'GLOBAL'); + $old = $DoCache; + $DoCache = $perm if defined($perm); + $old; +} + +#====> TIEHASH methods + +sub TIEHASH { + $_[0]->new(@_); +} + +sub FETCH { + my($self,$name) = @_; + if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; } + elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; } + else { scalar($self->getsym($name)); } +} + +sub STORE { + my($self,$name,$val) = @_; + if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; } + elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; } + else { $self->setsym($name,$val); } +} + +sub DELETE { + my($self,$name) = @_; + + $self->delsym($name); +} + +sub FIRSTKEY { + my($self) = @_; + my($name,$eqs,$val); + + if (!$DoCache || !$Cache_set) { + # We should eventually replace this with a C routine which walks the + # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . . + open(P,'Show Symbol * |'); + while (<P>) { + ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/ + or carp "VMS::CLISym: unparseable line $_"; + $name =~ s#\*##; + $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/; + if ($eqs eq '==') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + } + close P; + $Cache_set = 1; + } + $self ->{IDX} = 0; + $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms; + while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { + if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } + $self->{CACHE} = \%Gblsyms; + } + $name; +} + +sub NEXTKEY { + my($self) = @_; + my($name,$val); + + while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { + if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } + $self->{CACHE} = \%Gblsyms; + } + $name; +} + + +sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 } + +sub CLEAR { } + + +bootstrap VMS::DCLsym; + +1; + +__END__ + +=head1 NAME + +VMS::DCLsym - Perl extension to manipulate DCL symbols + +=head1 SYNOPSIS + + tie %allsyms, VMS::DCLsym; + tie %cgisyms, VMS::DCLsym, 'GLOBAL'; + + + $handle = new VMS::DCLsyms; + $value = $handle->getsym($name); + $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n"; + $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n"; + $handle->clearcache(); + +=head1 DESCRIPTION + +The VMS::DCLsym extension provides access to DCL symbols using a +tied hash interface. This allows Perl scripts to manipulate symbols in +a manner similar to the way in which logical names are manipulated via +the built-in C<%ENV> hash. Alternatively, one can call methods in this +package directly to read, create, and delete symbols. + +=head2 Tied hash interface + +This interface lets you treat the DCL symbol table as a Perl associative array, +in which the key of each element is the symbol name, and the value of the +element is that symbol's value. Case is not significant in the key string, as +DCL converts symbol names to uppercase, but it is significant in the value +string. All of the usual operations on associative arrays are supported. +Reading an element retrieves the current value of the symbol, assigning to it +defines a new symbol (or overwrites the old value of an existing symbol), and +deleting an element deletes the corresponding symbol. Setting an element to +C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null +string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out +whether a default symbol table has been specified for this hash (see C<table> +below), or set either or these keys to specify a default symbol table. + +When you call the C<tie> function to bind an associative array to this package, +you may specify as an optional argument the symbol table in which you wish to +create and delete symbols. If the argument is the string 'GLOBAL', then the +global symbol table is used; any other string causes the local symbol table to +be used. Note that this argument does not affect attempts to read symbols; if +a symbol with the specified name exists in the local symbol table, it is always +returned in preference to a symbol by the same name in the global symbol table. + +=head2 Object interface + +Although it's less convenient in some ways than the tied hash interface, you +can also call methods directly to manipulate individual symbols. In some +cases, this allows you finer control than using a tied hash aggregate. The +following methods are supported: + +=item new + +This creates a C<VMS::DCLsym> object which can be used as a handle for later +method calls. The single optional argument specifies the symbol table used +by default in future method calls, in the same way as the optional argument to +C<tie> described above. + +=item getsym + +If called in a scalar context, C<getsym> returns the value of the symbol whose +name is given as the argument to the call, or C<undef> if no such symbol +exists. Symbols in the local symbol table are always used in preference to +symbols in the global symbol table. If called in an array context, C<getsym> +returns a two-element list, whose first element is the value of the symbol, and +whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table +from which the symbol's value was read. + +=item setsym + +The first two arguments taken by this method are the name of the symbol and the +value which should be assigned to it. The optional third argument is a string +specifying the symbol table to be used; 'GLOBAL' specifies the global symbol +table, and any other string specifies the local symbol table. If this argument +is omitted, the default symbol table for the object is used. C<setsym> returns +TRUE if successful, and FALSE otherwise. + +=item delsym + +This method deletes the symbol whose name is given as the first argument. The +optional second argument specifies the symbol table, as described above under +C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE +if it was not. + +=item clearcache + +Because of the overhead associated with obtaining the list of defined symbols +for the tied hash iterator, it is only done once, and the list is reused for +subsequent iterations. Changes to symbols made through this package are +recorded, but in the rare event that someone changes the process' symbol table +from outside (as is possible using some software from the net), the iterator +will be out of sync with the symbol table. If you expect this to happen, you +can reset the cache by calling this method. In addition, if you pass a FALSE +value as the first argument, caching will be disabled. It can be reenabled +later by calling C<clearcache> again with a TRUE value as the first argument. +It returns TRUE or FALSE to indicate whether caching was previously enabled or +disabled, respectively. + +This method is a stopgap until we can incorporate code into this extension to +traverse the process' symbol table directly, so it may disappear in a future +version of this package. + +=head1 AUTHOR + +Charles Bailey bailey@genetics.upenn.edu + +=head1 VERSION + +1.01 08-Dec-1996 + +=head1 BUGS + +The list of symbols for the iterator is assembled by spawning off a +subprocess, which can be slow. Ideally, we should just traverse the +process' symbol table directly from C. + diff --git a/vms/ext/DCLsym/DCLsym.xs b/vms/ext/DCLsym/DCLsym.xs new file mode 100644 index 0000000000..3918eb11e5 --- /dev/null +++ b/vms/ext/DCLsym/DCLsym.xs @@ -0,0 +1,151 @@ +/* VMS::DCLsym - manipulate DCL symbols + * + * Version: 1.0 + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 17-Aug-1995 + * + * + * Revision History: + * + * 1.0 17-Aug-1995 Charles Bailey bailey@genetics.upenn.edu + * original production version + */ + +#include <descrip.h> +#include <lib$routines.h> +#include <libclidef.h> +#include <libdef.h> +#include <ssdef.h> +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym + +void +_getsym(name) + SV * name + PPCODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; + STRLEN namlen; + int tbltype; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name) { + PUSHs(sv_newmortal()); + SETERRNO(EINVAL,LIB$_INVARG); + return; + } + namdsc.dsc$a_pointer = SvPV(name,namlen); + namdsc.dsc$w_length = (unsigned short int) namlen; + retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype); + if (retsts & 1) { + PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ? + valdsc.dsc$a_pointer : "",valdsc.dsc$w_length))); + if (GIMME) { + EXTEND(sp,2); /* just in case we're at the end of the stack */ + if (tbltype == LIB$K_CLI_LOCAL_SYM) + PUSHs(sv_2mortal(newSVpv("LOCAL",5))); + else + PUSHs(sv_2mortal(newSVpv("GLOBAL",6))); + } + _ckvmssts(lib$sfree1_dd(&valdsc)); + } + else { + ST(0) = &sv_undef; /* error - we're returning undef, if anything */ + switch (retsts) { + case LIB$_NOSUCHSYM: + break; /* nobody home */; + case LIB$_INVSYMNAM: /* user errors; set errno return undef */ + case LIB$_INSCLIMEM: + case LIB$_NOCLI: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + break; + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + + +void +_setsym(name,val,typestr="LOCAL") + SV * name + SV * val + char * typestr + CODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + STRLEN slen; + int type; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name || !val) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; + } + namdsc.dsc$a_pointer = SvPV(name,slen); + namdsc.dsc$w_length = (unsigned short int) slen; + valdsc.dsc$a_pointer = SvPV(val,slen); + valdsc.dsc$w_length = (unsigned short int) slen; + type = strNE(typestr,"GLOBAL") ? + LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM; + retsts = lib$set_symbol(&namdsc,&valdsc,&type); + if (retsts & 1) { XSRETURN_YES; } + else { + switch (retsts) { + case LIB$_AMBSYMDEF: /* user errors; set errno and return */ + case LIB$_INSCLIMEM: + case LIB$_INVSYMNAM: + case LIB$_NOCLI: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + XSRETURN_NO; + break; /* NOTREACHED */ + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + + +void +_delsym(name,typestr="LOCAL") + SV * name + char * typestr + CODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + STRLEN slen; + int type; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name || !typestr) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; + } + namdsc.dsc$a_pointer = SvPV(name,slen); + namdsc.dsc$w_length = (unsigned short int) slen; + type = strNE(typestr,"GLOBAL") ? + LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM; + retsts = lib$delete_symbol(&namdsc,&type); + if (retsts & 1) { XSRETURN_YES; } + else { + switch (retsts) { + case LIB$_INVSYMNAM: /* user errors; set errno and return */ + case LIB$_NOCLI: + case LIB$_NOSUCHSYM: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + XSRETURN_NO; + break; /* NOTREACHED */ + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + diff --git a/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL new file mode 100644 index 0000000000..8e6f5bce40 --- /dev/null +++ b/vms/ext/DCLsym/Makefile.PL @@ -0,0 +1,3 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' ); diff --git a/vms/ext/DCLsym/test.pl b/vms/ext/DCLsym/test.pl new file mode 100644 index 0000000000..57f2afbd20 --- /dev/null +++ b/vms/ext/DCLsym/test.pl @@ -0,0 +1,41 @@ +print "1..15\n"; + +require VMS::DCLsym or die "failed 1\n"; +print "ok 1\n"; + +tie %syms, VMS::DCLsym or die "failed 2\n"; +print "ok 2\n"; + +$name = 'FOO_'.time(); +$syms{$name} = 'Perl_test'; +print +($! ? "(\$! = $!) not " : ''),"ok 3\n"; + +print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n"; + +($val) = `Show Symbol $name` =~ /(\w+)"$/; +print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n"; + +while (($sym,$val) = each %syms) { + last if $sym eq $name && $val eq 'Perl_test'; +} +print +($sym ? '' : 'not '),"ok 6\n"; + +delete $syms{$name}; +print +($! ? "(\$! = $!) not " : ''),"ok 7\n"; + +print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n"; +undef %syms; + +$obj = new VMS::DCLsym 'GLOBAL'; +print +($obj ? '' : 'not '),"ok 9\n"; + +print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n"; +print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n"; + +print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n"; + +($val,$tab) = $obj->getsym($name); +print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n"; + +print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n"; +print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n"; diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index 275081329c..ad16af366f 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -1,8 +1,8 @@ # VMS::Stdio - VMS extensions to Perl's stdio calls # # Author: Charles Bailey bailey@genetics.upenn.edu -# Version: 2.0 -# Revised: 28-Feb-1996 +# Version: 2.01 +# Revised: 10-Dec-1996 package VMS::Stdio; @@ -12,7 +12,7 @@ use Carp '&croak'; use DynaLoader (); use Exporter (); -$VERSION = '2.0'; +$VERSION = '2.01'; @ISA = qw( Exporter DynaLoader IO::File ); @EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ); @@ -32,12 +32,13 @@ sub AUTOLOAD { if ($constname =~ /^O_/) { my($val) = constant($constname); defined $val or croak("Unknown VMS::Stdio constant $constname"); - *$AUTOLOAD = sub { $val }; + *$AUTOLOAD = sub { val; } } else { # We don't know about it; hand off to IO::File require IO::File; - my($obj) = shift(@_); - $obj->IO::File::$constname(@_); + + *$AUTOLOAD = eval "sub { shift->IO::File::$constname(\@_) }"; + croak "Error autoloading IO::File::$constname: $@" if $@; } goto &$AUTOLOAD; } @@ -187,9 +188,9 @@ reason, it is unable to generate a name, it returns C<undef>. =item vmsopen The C<vmsopen> function enables you to specify optional RMS arguments -to the VMS CRTL when opening a file. It is similar to the built-in +to the VMS CRTL when opening a file. Its operation is similar to the built-in Perl C<open> function (see L<perlfunc> for a complete description), -but will only open normal files; it cannot open pipes or duplicate +but it will only open normal files; it cannot open pipes or duplicate existing I/O handles. Up to 8 optional arguments may follow the file name. These arguments should be strings which specify optional file characteristics as allowed by the CRTL. (See the @@ -197,7 +198,7 @@ CRTL reference manual description of creat() and fopen() for details.) If successful, C<vmsopen> returns a VMS::Stdio file handle; if an error occurs, it returns C<undef>. -You can use the file handle returned by C<vmsfopen> just as you +You can use the file handle returned by C<vmsopen> just as you would any other Perl file handle. The class VMS::Stdio ISA IO::File, so you can call IO::File methods using the handle returned by C<vmsopen>. However, C<use>ing VMS::Stdio does not @@ -230,6 +231,6 @@ task by calling the CRTL routine fwait(). =head1 REVISION -This document was last revised on 28-Jan-1996, for Perl 5.002. +This document was last revised on 10-Dec-1996, for Perl 5.004. =cut diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 79eb95335e..200268c7f1 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -79,8 +79,8 @@ IV *pval; static SV * newFH(FILE *fp, char type) { - SV *rv, *gv = NEWSV(0,0); - GV **stashp; + SV *rv; + GV **stashp, *gv = (GV *)NEWSV(0,0); HV *stash; IO *io; @@ -100,9 +100,9 @@ newFH(FILE *fp, char type) { gv_init(gv,stash,"__FH__",6,0); io = GvIOp(gv) = newIO(); IoIFP(io) = fp; - if (type != '>') IoOFP(io) = fp; + if (type != '<') IoOFP(io) = fp; IoTYPE(io) = type; - rv = newRV(gv); + rv = newRV((SV *)gv); SvREFCNT_dec(gv); return sv_bless(rv,stash); } @@ -225,7 +225,7 @@ vmsopen(spec,...) break; } if (fp != Nullfp) { - SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>'))); + SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>')))); ST(0) = (fh ? sv_2mortal(fh) : &sv_undef); } else { ST(0) = &sv_undef; } diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl index 12e508aa1f..0b50d63e3a 100644 --- a/vms/ext/Stdio/test.pl +++ b/vms/ext/Stdio/test.pl @@ -1,8 +1,8 @@ -# Tests for VMS::Stdio v2.0 +# Tests for VMS::Stdio v2.01 use VMS::Stdio; import VMS::Stdio qw(&flush &getname &rewind &sync); -print "1..13\n"; +print "1..14\n"; print +(defined(&getname) ? '' : 'not '), "ok 1\n"; $name = "test$$"; @@ -16,26 +16,29 @@ print +(sync($fh) ? '' : 'not '),"ok 4\n"; $time = (stat("$name.tmp"))[9]; print +($time ? '' : 'not '), "ok 5\n"; -print 'not ' unless print $fh scalar(localtime($time)),"\n"; +$fh->autoflush; # Can we autoload autoflush from IO::File? Do or die. print "ok 6\n"; -print +(rewind($fh) ? '' : 'not '),"ok 7\n"; +print 'not ' unless print $fh scalar(localtime($time)),"\n"; +print "ok 7\n"; + +print +(rewind($fh) ? '' : 'not '),"ok 8\n"; chop($line = <$fh>); -print +($line eq localtime($time) ? '' : 'not '), "ok 8\n"; +print +($line eq localtime($time) ? '' : 'not '), "ok 9\n"; ($gotname) = (getname($fh) =~/\](.*);/); -print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 9\n"; +print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 10\n"; $sfh = VMS::Stdio::vmssysopen($name, O_RDONLY, 0, 'ctx=rec', 'shr=put', 'dna=.tmp'); -print +($sfh ? '' : 'not ($!) '), "ok 10\n"; +print +($sfh ? '' : 'not ($!) '), "ok 11\n"; close($fh); sysread($sfh,$line,24); -print +($line eq localtime($time) ? '' : 'not '), "ok 11\n"; +print +($line eq localtime($time) ? '' : 'not '), "ok 12\n"; undef $sfh; -print +(stat("$name.tmp") ? 'not ' : ''),"ok 12\n"; +print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n"; -print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 13\n"; +print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n"; diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 8753893b8d..48092ba360 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -34,12 +34,13 @@ # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 20-Feb-1996 require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; +print "gen_shrfls.pl Rev. 14-Dec-1996\n" if $debug; + if ($ARGV[0] eq '-f') { open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; print "Input taken from file $ARGV[1]\n" if $debug; @@ -78,7 +79,9 @@ if ($docc) { $isvaxc = 0; $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ or 0; # make debug output nice - $isvaxc = (!$isgcc && $isvax && `$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/) + $isvaxc = (!$isgcc && $isvax && + # Check exit status too, in case message is shut off + (`$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/ || $? == 0x38240)) or 0; # again, make debug output nice print "\$isgcc: $isgcc\n" if $debug; print "\$isvaxc: $isvaxc\n" if $debug; @@ -139,6 +142,7 @@ sub scan_enum { sub scan_var { my($line) = @_; + my($const) = $line =~ /^EXTCONST/; print "\tchecking for global variable\n" if $debug > 1; $line =~ s/INIT\(.*\)//; @@ -147,8 +151,21 @@ sub scan_var { $line =~ s/\W*;?\s*$//; print "\tfiltered to \\$line\\\n" if $debug > 1; if ($line =~ /(\w+)$/) { - print "\tvar name is \\$1\\\n" if $debug > 1; - $vars{$1}++; + print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1; + if ($const) { $cvars{$1}++; } + else { $vars{$1}++; } + } + if ($isvaxc) { + my($type) = $line =~ /^EXT\w*\s+(\w+)/; + print "\tchecking for use of enum (type is \"$type\")\n" if $debug > 2; + if ($type eq 'expectation') { + $used_expectation_enum++; + print "\tsaw global use of enum \"expectation\"\n" if $debug > 1; + } + if ($type eq 'opcode') { + $used_opcode_enum++; + print "\tsaw global use of enum \"opcode\"\n" if $debug > 1; + } } } @@ -203,20 +220,8 @@ LINE: while (<CPP>) { else { &scan_func($_); } last LINE unless $_ = <CPP>; } - print $_ if $debug > 3; - if (($type) = /^EXT\s+(\w+)/) { - if ($isvaxc) { - if ($type eq 'expectation') { - $used_expectation_enum++; - print "\tsaw global use of enum \"expectation\"\n" if $debug > 1; - } - if ($type eq 'opcode') { - $used_opcode_enum++; - print "\tsaw global use of enum \"opcode\"\n" if $debug > 1; - } - } - &scan_var($_); - } + print $_ if $debug > 3 && ($debug > 5 || length($_)); + if (/^EXT/) { &scan_var($_); } } close CPP; @@ -277,7 +282,11 @@ if ($isvax) { or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } -foreach $var (sort keys %vars) { +unless ($isgcc) { + print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; + print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; +} +foreach $var (sort (keys %vars,keys %cvars)) { if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } # This hack brought to you by the lack of a globaldef in gcc. @@ -312,9 +321,19 @@ if ($isvax) { open(OPTATTR,">${dir}perlshr_attr.opt") or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; -print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; -foreach $var (sort keys %vars) { - print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; +if ($isvaxc) { + print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; +} +elsif ($isgcc) { + foreach $var (sort keys %cvars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; + } + foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + } +} +else { + print OPTATTR "! No additional linker directives are needed when using DECC\n"; } close OPTATTR; @@ -330,7 +349,7 @@ if ($isvax) { print DRVR "\$ Set Verify\n"; print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n"; do { - $incstr .= ",perlshr_gbl$marord"; + push(@symfiles,"perlshr_gbl$marord"); print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n"; } while (--$marord); @@ -345,6 +364,17 @@ if ($isvax) { close DRVR; } +# Initial hack to permit building of compatible shareable images for a +# given version of Perl. +if ($ENV{PERLSHR_USE_GSMATCH}) { + my $major = int($] * 1000) & 0xFF; # range 0..255 + my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 + print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; + foreach (@symfiles) { + print OPTBLD "CLUSTER=\$\$TRANSFER_VECTOR,,,$_.$objsuffix\n"; + } +} +elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); } # Include object modules and RTLs in options file # Linker wants /Include and /Library on different lines print OPTBLD "$libperl/Include=($incstr)\n"; diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 17ff2041fa..97679d5e48 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -6,7 +6,7 @@ # that went into your perl binary. In addition, values which change from run # to run may be supplied on the command line as key=val pairs. # -# Rev. 2-Oct-1996 Charles Bailey bailey@genetics.upenn.edu +# Rev. 3-Dec-1996 Charles Bailey bailey@genetics.upenn.edu # #==== Locations of installed Perl components @@ -102,6 +102,10 @@ installprivlib='$installprivlib' installarchlib='$installarchlib' installsitelib='$installsitelib' installsitearch='$installsitearch' +startperl='\$ perl 'f\$env("procedure")' - ! q# + 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' +$ exit !# +' EndOfIntro foreach (@ARGV) { @@ -126,7 +130,9 @@ foreach (@ARGV) { print OUT "gccversion='$1'\n"; } elsif ($archsufx eq 'VAX' && - `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/) { + # Check exit status too, in case message is turned off + ( `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/ || + $? == 0x38240 )) { $cctype = 'vaxc'; $d_attr = 'undef'; } @@ -154,17 +160,12 @@ foreach (@ARGV) { print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n"; - if ($cctype eq 'decc') { - print OUT "d_stdstdio='define'\n"; - print OUT "d_stdio_ptr_lval='define'\n"; - print OUT "d_stdio_cnt_lval='define'\n"; - print OUT "d_stdiobase='define'\n"; - } - else { - print OUT "d_stdstdio='undef'\n"; - print OUT "d_stdio_ptr_lval='undef'\n"; - print OUT "d_stdio_cnt_lval='undef'\n"; - print OUT "d_stdiobase='undef'\n"; + if ($cctype eq 'decc') { $rtlhas = 'define'; } + else { $rtlhas = 'undef'; } + foreach (qw[ d_stdstdio d_stdio_ptr_lval d_stdio_cnt_lval d_stdiobase + d_locconv d_setlocale i_locale d_mbstowcs d_mbtowc + d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) { + print OUT "$_='$rtlhas'\n"; } next; } @@ -266,7 +267,7 @@ while (<IN>) { elsif (not length $val and not $had_val) { # Wups -- should have been shell var for C preprocessor directive warn "Constant $token not found in config_h.SH\n"; - $token =~ tr/A-Z/a-z/; + $token = lc $token; $token = "d_$token" unless $token =~ /^i_/; print OUT "$token='$state'\n"; } @@ -282,7 +283,7 @@ while (<IN>) { } elsif (!$pp_vars{$token}) { # Haven't seen it previously, either warn "Constant $token not found in config_h.SH (val=|$val|)\n"; - $token =~ tr/A-Z/a-z/; + $token = lc $token; print OUT "$token='$val'\n"; if ($token =~ s/exp$//) {print OUT "$token='$val'\n";} } @@ -324,7 +325,7 @@ if (open(PL,"${outdir}patchlevel.h")) { else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; } # simple pager support for perldoc -if (`most` =~ /IVVERB/) { +if (`most not..file` =~ /IVVERB/) { $pager = 'more'; if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; } } diff --git a/vms/genopt.com b/vms/genopt.com index 70013aec42..3d3e5fe5df 100644 --- a/vms/genopt.com +++ b/vms/genopt.com @@ -9,6 +9,24 @@ $loop: $ x=f$element(element,p2,p3) $ if x .eqs. p2 then goto out $ y=f$edit(x,"COLLAPSE") ! lose spaces +$! Expand potential name-only args so we find shareable images +$! either via a logical name or in the default location +$ if y .nes. "" .and. - + f$locate("/SHARE",f$edit(y,"UPCASE")) .ne. f$length(y) +$ then +$ name = f$element(0,"/",y) +$ tail = f$extract(f$length(name),1024,y) +$ if f$trnlnm(name) .eqs. "" ! If it's a logical name, assume it's OK as is +$ then +$ name = f$parse(name,"sys$share:.exe;") ! Look where image activator will +$ name = f$search(name) ! Does it really exist? +$ if name .nes. "" +$ then +$ name = name - f$parse(name,,,"version") ! Insist on current version +$ y = name + tail +$ endif +$ endif +$ endif $ if y .nes. "" then write file y $ element=element+1 $ goto loop diff --git a/vms/perlvms.pod b/vms/perlvms.pod index f15bd77cfe..e065b08baa 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -140,13 +140,16 @@ be added to the linker options file F<PGPLOT.Opt> produced during the build process for the Perl extension. By default, the shareable image for an extension is placed -in the F<[.Lib.Auto.>I<Arch>.I<Extname>F<]> directory of the +F<[.lib.site_perl.auto>I<Arch>.I<Extname>F<]> directory of the installed Perl directory tree (where I<Arch> is F<VMS_VAX> or -F<VMS_AXP>, followed by the Perl version number, and I<Extname> -is the name of the extension, with each C<::> translated to C<.>). +F<VMS_AXP>, and I<Extname> is the name of the extension, with +each C<::> translated to C<.>). (See the MakeMaker documentation +for more details on installation options for extensions.) However, it can be manually placed in any of several locations: - - the F<[.Lib.Auto.>I<Extname>F<]> subdirectory of one of - the directories in C<@INC>, or + - the F<[.Lib.Auto.>I<Arch>I<$PVers>I<Extname>F<]> subdirectory + of one of the directories in C<@INC> (where I<PVers> + is the version of Perl you're using, as supplied in C<$]>, + with '.' converted to '_'), or - one of the directories in C<@INC>, or - a directory which the extensions Perl library module passes to the DynaLoader when asking it to map @@ -238,6 +241,7 @@ directory specifications may use either VMS or Unix syntax. Perl for VMS supports redirection of input and output on the command line, using a subset of Bourne shell syntax: + <F<file> reads stdin from F<file>, >F<file> writes stdout to F<file>, >>F<file> appends stdout to F<file>, @@ -261,6 +265,8 @@ to pass uppercase switches to Perl, you need to enclose them in double-quotes on the command line, since the CRTL downcases all unquoted strings. +=over 4 + =item -i If the C<-i> switch is present but no extension for a backup @@ -286,6 +292,8 @@ The C<-u> switch causes the VMS debugger to be invoked after the Perl program is compiled, but before it has run. It does not create a core dump file. +=back + =head1 Perl functions As of the time this document was last revised, the following @@ -337,6 +345,7 @@ your copy of Perl: getsockopt, listen, recv, select(system call)*, send, setsockopt, shutdown, socket +=over 4 =item File tests @@ -605,8 +614,17 @@ and you invoked Perl with the C<-w> switch, a warning will be issued.) The FLAGS argument is ignored in all cases. +=back + =head1 Perl variables +The following VMS-specific information applies to the indicated +"special" Perl variables, in addition to the general information +in L<perlvar>. Where there is a conflict, this infrmation +takes precedence. + +=over 4 + =item %ENV Reading the elements of the %ENV array returns the @@ -699,6 +717,8 @@ all the way to disk on each write (I<i.e.> not just to the underlying RMS buffers for a file). In other words, it's equivalent to calling fflush() and fsync() from C. +=back + =head1 Revision date This document was last updated on 28-Feb-1996, for Perl 5, diff --git a/vms/perly_c.vms b/vms/perly_c.vms index b1cb69cdfc..947d77311d 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1,4 +1,4 @@ -/* Postprocessed by vms_yfix.pl 1.1 to add VMS declarations of globals */ +/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */ #ifndef lint static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; #endif @@ -13,1088 +13,1001 @@ dep() deprecate("\"do\" to call subroutines"); } +#line 16 "perly.c" #define YYERRCODE 256 dEXT short yylhs[] = { -1, - 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, - 7, 21, 21, 21, 21, 21, 21, 11, 11, 11, - 9, 9, 9, 9, 30, 30, 8, 8, 8, 8, - 8, 8, 8, 8, 10, 10, 25, 25, 29, 29, - 1, 1, 1, 1, 2, 2, 32, 32, 28, 28, - 4, 33, 33, 34, 13, 13, 13, 12, 12, 12, - 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 22, 22, 23, 23, 23, 20, - 15, 16, 17, 18, 19, 24, 24, 24, 24, + 45, 0, 9, 7, 10, 8, 11, 11, 11, 12, + 12, 12, 12, 24, 24, 24, 24, 24, 24, 15, + 15, 15, 14, 14, 42, 42, 13, 13, 13, 13, + 13, 13, 13, 26, 26, 27, 27, 28, 29, 30, + 31, 32, 44, 44, 1, 1, 1, 1, 3, 38, + 38, 46, 4, 5, 6, 39, 40, 40, 41, 41, + 47, 47, 49, 48, 16, 16, 16, 25, 25, 25, + 36, 36, 36, 36, 36, 36, 36, 50, 36, 37, + 37, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 33, 33, 34, 34, 34, + 2, 2, 43, 23, 18, 19, 20, 21, 22, 35, + 35, 35, 35, }; dEXT short yylen[] = { 2, - 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, - 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, - 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, - 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, - 1, 1, 1, 1, 4, 3, 5, 5, 0, 1, - 0, 3, 2, 6, 3, 3, 1, 2, 3, 1, - 3, 5, 6, 3, 5, 2, 4, 4, 1, 1, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 5, 3, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 3, 2, 3, 2, 4, 3, - 4, 1, 5, 1, 4, 5, 4, 1, 1, 1, - 5, 6, 5, 6, 5, 4, 5, 1, 1, 3, - 4, 3, 2, 2, 4, 5, 4, 5, 1, 2, - 2, 1, 2, 2, 2, 1, 3, 1, 3, 4, - 4, 6, 1, 1, 0, 1, 0, 1, 2, 2, - 2, 2, 2, 2, 2, 1, 1, 1, 1, + 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, + 1, 2, 3, 1, 1, 3, 3, 3, 3, 0, + 2, 6, 7, 7, 0, 2, 8, 8, 10, 9, + 8, 11, 3, 0, 1, 0, 1, 1, 1, 1, + 1, 1, 0, 1, 1, 1, 1, 1, 4, 1, + 0, 5, 0, 0, 0, 1, 0, 1, 1, 1, + 3, 2, 0, 7, 3, 3, 1, 2, 3, 1, + 3, 5, 6, 3, 5, 2, 4, 0, 5, 1, + 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 5, 3, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 3, 2, 3, 2, 4, + 3, 4, 1, 5, 1, 4, 5, 4, 1, 1, + 1, 5, 6, 5, 6, 5, 4, 5, 1, 1, + 3, 4, 3, 2, 2, 4, 5, 4, 5, 1, + 2, 2, 1, 2, 2, 2, 1, 3, 1, 3, + 4, 4, 6, 1, 1, 0, 1, 0, 1, 2, + 1, 1, 1, 2, 2, 2, 2, 2, 2, 1, + 1, 1, 1, }; dEXT short yydefred[] = { 1, - 0, 5, 0, 40, 51, 51, 0, 51, 6, 41, - 7, 9, 0, 42, 43, 44, 0, 0, 0, 53, - 0, 12, 4, 143, 0, 0, 118, 0, 138, 0, - 51, 51, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 7, 0, 44, 55, 53, 0, 53, 8, 45, + 9, 11, 0, 46, 47, 48, 0, 0, 0, 62, + 63, 14, 4, 154, 0, 0, 129, 0, 149, 0, + 54, 54, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 161, 162, 0, + 0, 0, 0, 0, 0, 0, 0, 12, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 10, 0, 0, + 0, 0, 119, 121, 0, 0, 0, 0, 155, 50, + 0, 56, 0, 61, 0, 7, 170, 173, 172, 171, + 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, + 4, 4, 0, 0, 0, 0, 0, 144, 0, 0, + 0, 0, 76, 0, 168, 0, 135, 0, 0, 0, + 0, 0, 164, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 109, 0, 165, 166, 167, 169, 0, + 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 10, 0, 0, 0, - 0, 0, 0, 0, 0, 8, 0, 0, 0, 0, - 0, 108, 110, 0, 0, 0, 144, 0, 46, 0, - 52, 0, 5, 156, 159, 158, 157, 0, 0, 0, + 0, 0, 0, 101, 102, 0, 0, 0, 0, 0, + 0, 0, 0, 13, 0, 49, 58, 0, 0, 0, + 74, 0, 0, 78, 0, 0, 0, 0, 0, 0, + 0, 4, 148, 150, 0, 0, 0, 0, 0, 0, + 0, 111, 0, 133, 0, 0, 108, 26, 0, 0, + 19, 0, 0, 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 154, 0, 124, - 0, 0, 0, 0, 0, 0, 150, 0, 0, 0, - 0, 66, 0, 133, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 98, 0, 151, 152, 153, 155, - 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 90, 91, 0, 0, 0, 0, - 0, 0, 0, 0, 11, 45, 50, 0, 0, 0, - 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 36, 0, 137, 139, - 0, 0, 0, 0, 0, 0, 100, 0, 122, 0, - 0, 0, 97, 26, 0, 0, 0, 0, 0, 0, - 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 69, 0, 70, - 0, 0, 0, 0, 0, 0, 0, 120, 0, 48, - 47, 0, 3, 0, 141, 0, 68, 101, 0, 29, - 0, 30, 0, 0, 0, 23, 0, 24, 0, 0, - 0, 140, 149, 67, 0, 125, 0, 127, 0, 99, - 0, 0, 0, 0, 0, 0, 0, 107, 0, 105, - 0, 116, 0, 121, 54, 65, 0, 0, 0, 0, - 19, 0, 0, 0, 0, 0, 62, 126, 128, 115, - 0, 113, 0, 0, 106, 0, 111, 117, 103, 142, - 27, 28, 21, 0, 22, 0, 32, 0, 114, 112, - 63, 0, 0, 31, 0, 0, 20, 33, + 0, 80, 0, 81, 0, 0, 0, 0, 0, 0, + 0, 131, 0, 0, 60, 59, 52, 0, 3, 0, + 152, 0, 0, 112, 0, 41, 0, 42, 0, 0, + 0, 0, 163, 0, 0, 35, 40, 0, 0, 0, + 151, 160, 77, 0, 136, 0, 138, 0, 110, 0, + 0, 0, 0, 0, 0, 0, 118, 0, 116, 0, + 127, 0, 132, 0, 75, 0, 79, 0, 0, 0, + 0, 0, 0, 0, 0, 72, 137, 139, 126, 0, + 124, 0, 0, 117, 0, 122, 128, 114, 64, 153, + 6, 0, 0, 0, 0, 0, 0, 0, 0, 125, + 123, 73, 7, 27, 28, 0, 0, 23, 24, 0, + 31, 0, 0, 0, 21, 0, 0, 0, 30, 5, + 0, 29, 0, 0, 32, 0, 22, }; dEXT short yydgoto[] = { 1, - 9, 10, 83, 17, 86, 3, 11, 12, 66, 195, - 266, 67, 202, 69, 70, 71, 72, 73, 74, 75, - 197, 122, 203, 88, 187, 77, 241, 178, 13, 142, - 2, 14, 15, 16, + 9, 66, 10, 18, 95, 17, 86, 333, 89, 322, + 3, 11, 12, 68, 338, 260, 70, 71, 72, 73, + 74, 75, 76, 266, 78, 267, 256, 258, 261, 269, + 257, 259, 113, 197, 91, 79, 235, 81, 83, 178, + 247, 142, 264, 13, 2, 14, 15, 16, 85, 253, }; dEXT short yysindex[] = { 0, - 0, 0, 303, 0, 0, 0, -53, 0, 0, 0, - 0, 0, 607, 0, 0, 0, -111, -242, -32, 0, - -216, 0, 0, 0, 149, 149, 0, 8, 0, 2109, - 0, 0, -15, -8, 4, 6, 32, 2109, 13, 20, - 57, 149, 994, 2109, 1057, -206, 149, 2109, 938, 1291, - 2109, 2109, 2109, 2109, 2109, 1347, 0, 2109, 2109, 1403, - 149, 149, 149, 149, -203, 0, 68, 664, 491, -67, - -52, 0, 0, -21, 73, 65, 0, 7, 0, -135, - 0, -126, 0, 0, 0, 0, 0, 2109, 92, 2109, - 491, 7, -135, 2109, 7, 2109, 7, 2109, 7, 2109, - 7, 1466, 101, 491, 112, 1700, 938, 0, 102, 0, - 1228, -22, 1228, 39, -58, 2109, 0, 68, 0, 68, - -67, 0, 2109, 0, 1228, 472, 472, 472, -88, -88, - 78, -10, 472, 472, 0, -85, 0, 0, 0, 0, - 7, 0, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 0, 0, -29, 2109, 2109, 2109, - 2109, 2109, 2109, 1756, 0, 0, 0, -46, 2109, 391, - 0, 2109, -25, 2109, 7, -214, 129, -203, -5, -203, - 1, -167, 9, -167, 117, 52, 0, 2109, 0, 0, - 23, 60, 132, 2109, 1812, 1875, 0, 53, 0, 68, - 2109, 86, 0, 0, 491, -214, -214, -214, -214, -147, - 0, -54, 382, 1228, 1090, 771, 115, 491, 2942, 1523, - 314, 1554, 392, 677, 472, 472, 2109, 0, 2109, 0, - 141, 89, -42, 99, 46, 114, 64, 0, 26, 0, - 0, 124, 0, 143, 0, 2109, 0, 0, 7, 0, - 7, 0, 7, 7, 146, 0, 7, 0, 2109, 7, - 35, 0, 0, 0, 37, 0, 49, 0, 55, 0, - 130, 2109, 63, 2109, 67, 166, 2109, 0, 66, 0, - 71, 0, 74, 0, 0, 0, 1170, -203, -203, -167, - 0, 2109, -167, 131, -203, 7, 0, 0, 0, 0, - 185, 0, 1119, 76, 0, 161, 0, 0, 0, 0, - 0, 0, 0, 58, 0, 1466, 0, -203, 0, 0, - 0, 7, 162, 0, -167, 7, 0, 0, + 0, 0, -126, 0, 0, 0, -58, 0, 0, 0, + 0, 0, 827, 0, 0, 0, -242, -235, -21, 0, + 0, 0, 0, 0, -33, -33, 0, 11, 0, 1816, + 0, 0, 13, 15, 30, 45, -29, 1816, 67, 68, + 70, 1002, 939, -33, 1236, 1292, -227, 0, 0, -33, + 1816, 1816, 1816, 1816, 1816, 1816, 1173, 0, 1816, 1816, + 1348, -33, -33, -33, -33, 1816, -220, 0, -169, 3558, + -78, -59, 0, 0, -62, 73, 42, 65, 0, 0, + -5, 0, -149, 0, -134, 0, 0, 0, 0, 0, + 1816, 97, 1816, 1847, -5, -149, 0, 0, 0, 0, + 0, 0, 99, 3558, 105, 1407, 939, 0, 1847, 0, + -78, 65, 0, 1816, 0, 107, 0, 1847, -23, 36, + -51, 1816, 0, 65, -82, -82, -82, -54, -54, 57, + -27, -82, -82, 0, -87, 0, 0, 0, 0, 1847, + -5, 0, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, + 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, 1816, + 1816, 1816, 1816, 0, 0, -32, 1816, 1816, 1816, 1816, + 1816, 1816, 1582, 0, 1816, 0, 0, -36, -108, 665, + 0, 1816, 209, 0, -5, 1816, 1816, 1816, 1816, 114, + 1641, 0, 0, 0, -16, 6, 111, 1816, 65, 1697, + 1753, 0, 38, 0, 1816, 74, 0, 0, -251, -251, + 0, -251, -251, -131, 0, 18, 3516, 1847, 1089, 382, + 92, 3558, 3594, 3689, 369, 1060, 482, 285, -82, -82, + 1816, 0, 1816, 0, 128, 33, 23, 58, 25, 69, + 27, 0, -14, 3558, 0, 0, 0, 1816, 0, 131, + 0, 1816, 1816, 0, -251, 0, 134, 0, 136, -251, + 139, 141, 0, 144, -169, 0, 0, 156, 135, 1816, + 0, 0, 0, -12, 0, -10, 0, 1, 0, 71, + 1816, 75, 1816, 29, 86, 1816, 0, 76, 0, 78, + 0, 81, 0, 148, 0, 339, 0, 85, 85, 85, + 85, 1816, 85, 1816, 168, 0, 0, 0, 0, 88, + 0, 3653, 89, 0, 172, 0, 0, 0, 0, 0, + 0, -220, -220, -178, -178, 175, -220, 160, 85, 0, + 0, 0, 0, 0, 0, 85, 203, 0, 0, 85, + 0, 1641, -220, 688, 0, 1816, -220, 180, 0, 0, + 196, 0, 85, 85, 0, -178, 0, }; dEXT short yyrindex[] = { 0, 0, 0, 269, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 122, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2076, 1906, 0, + 0, 2716, 2784, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 79, 0, -7, 181, + 2827, 2871, 0, 0, 2142, 1965, 0, 21, 0, 0, + 0, 0, -31, 0, 0, 0, 0, 0, 0, 0, + 2201, 0, 0, 3299, 0, 129, 0, 0, 0, 0, + 0, 0, 0, 197, 0, 0, 213, 0, 3343, 444, + 545, 2312, 0, 0, 0, 2028, 0, 3386, 2827, 0, + 0, 2201, 0, 2437, 2914, 2952, 2990, 606, 723, 2480, + 0, 3063, 3107, 0, 0, 0, 0, 0, 0, 3424, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 2241, 1964, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 2857, 2901, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 107, 0, 360, -1, 62, 3027, - 3078, 0, 0, 2286, 2020, 0, 0, 0, 0, -12, - 0, 0, 0, 0, 0, 0, 0, 2415, 0, 0, - 1251, 0, 82, 173, 0, 0, 0, 0, 0, 0, - 0, 157, 0, 1661, 0, 0, 178, 0, 2150, 0, - 3927, 3027, 3958, 0, 0, 2415, 0, 2537, 454, 2581, - 548, 0, 0, 0, 3989, 3384, 3425, 3461, 3122, 3163, - 2636, 0, 3497, 3533, 0, 0, 0, 0, 0, 0, - 0, 0, 2680, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 2548, 0, 0, 0, 0, 883, + 0, 213, 0, 0, 0, 234, 0, 0, 0, 0, + 218, 0, 0, 0, 0, 239, 0, 0, 2591, 0, + 0, 0, 0, 0, 0, 2635, 0, 0, -2, 8, + 0, 22, 24, 525, 0, 0, 3579, 1448, 1504, 3226, + -39, 338, 0, 2490, 3535, 3498, 3462, 3262, 3150, 3188, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 163, 882, - 0, 178, 0, 2415, 0, 2, 0, 107, 0, 107, - 0, 175, 0, 175, 0, 165, 0, 0, 0, 0, - 0, 180, 0, 0, 0, 0, 0, 0, 0, 2723, - 0, 2985, 0, 0, 2785, 11, 14, 33, 59, 833, - 0, 0, -30, 4020, 4036, 3817, 3850, 3275, 0, 1611, - 4179, 4114, 4098, 3894, 3569, 3646, 0, 0, 0, 0, + 0, 0, 0, 1870, 0, 0, 0, 230, 0, 0, + 0, 0, 2201, 0, 37, 0, 0, 0, 0, 251, + 0, 0, 0, 0, 61, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 213, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 168, 0, + 0, 0, 0, 238, 0, 0, 0, 0, 0, 0, + 0, 718, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 79, 79, 153, 153, 0, 79, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 178, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 107, 107, 175, - 0, 0, 175, 0, 107, 0, 0, 0, 0, 0, - 0, 0, 2462, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 190, 0, 107, 0, 0, - 0, 0, 0, 0, 175, 0, 0, 0, + 0, 260, 79, 883, 0, 0, 79, 0, 0, 0, + 0, 0, 0, 0, 0, 153, 0, }; dEXT short yygindex[] = { 0, - 0, 0, 0, 148, -13, 106, 0, 0, 0, -91, - -184, 452, -11, 4373, 886, 0, 0, 0, 0, 0, - 234, -62, -173, 460, -20, 0, 0, 174, 0, -131, - 0, 0, 0, 0, + 0, 0, 0, 300, 278, 0, -26, 0, 892, 1004, + -76, 0, 0, 0, -313, -13, 3871, 3724, 0, 0, + 0, 0, 0, 304, -25, 0, 0, 169, -175, -8, + 53, 152, 384, -161, 901, 0, 0, 0, 0, 281, + 0, -287, 0, 0, 0, 0, 0, 0, 0, 0, }; -#define YYTABLESIZE 4657 -dEXT short yytable[] = { 65, - 208, 68, 168, 79, 283, 20, 61, 213, 254, 268, - 80, 23, 250, 80, 80, 255, 289, 206, 256, 95, - 97, 99, 101, 170, 94, 181, 81, 80, 80, 110, - 212, 96, 80, 115, 150, 261, 124, 157, 172, 13, - 82, 263, 38, 98, 132, 100, 49, 90, 136, 267, - 116, 16, 105, 209, 17, 169, 260, 13, 262, 106, - 38, 239, 80, 272, 176, 168, 294, 61, 170, 16, - 171, 102, 17, 14, 141, 306, 23, 307, 184, 148, - 149, 188, 186, 190, 189, 192, 191, 194, 193, 308, - 196, 14, 270, 237, 201, 309, 107, 150, 332, 15, - 169, 173, 60, 273, 291, 60, 25, 23, 264, 265, - 49, 143, 174, 316, 23, 323, 252, 15, 325, 60, - 60, 257, 293, 175, 177, 314, 23, 214, 23, 23, - 179, 182, 216, 217, 218, 219, 220, 221, 222, 25, - 198, 205, 25, 25, 25, 78, 25, 149, 25, 25, - 337, 25, 199, 18, 60, 21, 242, 243, 244, 245, - 246, 247, 249, 207, 251, 25, 321, 322, 211, 259, - 25, 258, 274, 327, 18, 269, 282, 280, 92, 93, - 287, 288, 295, 296, 61, 302, 271, 312, 180, 326, - 317, 290, 275, 277, 279, 318, 334, 25, 319, 281, - 330, 331, 336, 19, 49, 168, 292, 18, 148, 149, - 18, 18, 18, 37, 18, 35, 18, 18, 147, 18, - 148, 145, 310, 13, 167, 285, 37, 286, 238, 25, - 35, 25, 25, 18, 333, 148, 149, 150, 18, 148, - 149, 80, 80, 80, 80, 298, 76, 299, 304, 300, - 301, 148, 149, 303, 0, 151, 305, 186, 315, 152, - 153, 154, 155, 80, 80, 18, 185, 80, 2, 0, - 311, 23, 156, 158, 159, 160, 161, 329, 162, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 148, 149, - 324, 0, 328, 0, 148, 149, 0, 18, 0, 18, - 18, 39, 148, 149, 39, 39, 39, 0, 39, 0, - 39, 39, 0, 39, 68, 0, 148, 149, 335, 148, - 149, 0, 338, 144, 145, 146, 147, 39, 148, 149, - 148, 149, 39, 60, 60, 60, 60, 0, 0, 148, - 149, 0, 148, 149, 0, 148, 149, 0, 148, 149, - 0, 148, 149, 148, 149, 60, 60, 148, 149, 39, - 148, 149, 25, 25, 25, 25, 25, 25, 0, 25, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 148, 149, 0, 25, 25, 0, 25, 25, - 25, 39, 148, 149, 39, 25, 25, 25, 25, 25, - 57, 154, 25, 25, 168, 84, 0, 148, 149, 25, - 85, 0, 0, 25, 0, 25, 25, 0, 57, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 0, 0, - 18, 18, 18, 18, 18, 18, 150, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 0, 0, 57, 18, 18, 0, 18, 18, 18, 148, - 149, 0, 0, 18, 18, 18, 18, 18, 0, 0, - 18, 18, 168, 0, 0, 0, 0, 18, 148, 149, - 0, 18, 168, 18, 18, 89, 156, 0, 0, 156, - 156, 156, 0, 156, 143, 156, 156, 143, 156, 118, - 120, 108, 0, 0, 150, 0, 117, 0, 123, 0, - 0, 143, 143, 0, 150, 253, 143, 156, 0, 0, - 137, 138, 139, 140, 39, 39, 39, 39, 39, 39, - 0, 39, 39, 39, 0, 0, 0, 39, 0, 120, - 39, 39, 39, 39, 143, 0, 143, 39, 39, 0, - 39, 39, 39, 157, 0, 0, 0, 39, 39, 39, - 39, 39, 168, 0, 39, 39, 204, 120, 4, 5, - 6, 39, 7, 8, 210, 39, 143, 39, 39, 156, - 157, 168, 0, 157, 157, 157, 0, 157, 102, 157, - 157, 102, 157, 0, 150, 0, 0, 0, 152, 153, - 154, 155, 0, 0, 0, 102, 102, 0, 0, 0, - 102, 157, 0, 150, 160, 161, 0, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 120, 57, 57, 57, 57, 120, 0, 0, 0, 51, - 102, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 57, 57, 0, 4, 5, 6, 0, - 7, 8, 0, 0, 0, 57, 152, 153, 154, 155, - 62, 0, 0, 157, 0, 0, 152, 153, 154, 155, - 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, - 0, 0, 165, 166, 167, 162, 163, 60, 0, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 0, 0, - 156, 156, 156, 156, 156, 0, 156, 156, 156, 0, - 0, 0, 156, 0, 0, 143, 143, 143, 143, 23, - 0, 0, 52, 156, 143, 156, 156, 156, 143, 143, - 143, 143, 156, 156, 156, 156, 156, 143, 143, 156, - 156, 143, 143, 143, 143, 143, 156, 143, 143, 0, - 156, 143, 156, 156, 143, 143, 143, 168, 0, 0, - 0, 151, 0, 0, 0, 152, 153, 154, 155, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 156, 158, - 159, 160, 161, 0, 162, 163, 0, 0, 164, 150, - 0, 165, 166, 167, 157, 157, 157, 157, 157, 0, - 157, 157, 157, 0, 0, 0, 157, 0, 0, 102, - 102, 102, 102, 0, 0, 0, 0, 157, 102, 157, - 157, 157, 102, 102, 102, 102, 157, 157, 157, 157, - 157, 102, 102, 157, 157, 102, 102, 102, 102, 102, - 157, 102, 102, 0, 157, 102, 157, 157, 102, 102, - 102, 168, 22, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 56, 0, 32, 56, 0, 33, 34, - 35, 36, 0, 0, 0, 37, 38, 0, 39, 40, - 41, 56, 0, 150, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 0, 0, 0, 0, 0, 50, - 87, 87, 0, 53, 39, 54, 55, 39, 39, 39, - 0, 39, 103, 39, 39, 56, 39, 87, 112, 0, - 0, 0, 87, 0, 121, 144, 145, 146, 147, 0, - 39, 0, 0, 0, 0, 39, 87, 87, 87, 87, - 0, 0, 0, 0, 0, 0, 0, 148, 149, 0, - 0, 0, 0, 154, 155, 0, 0, 0, 0, 0, - 51, 0, 39, 61, 63, 47, 0, 56, 0, 64, - 59, 163, 58, 0, 164, 0, 0, 165, 166, 167, - 0, 0, 121, 0, 0, 0, 0, 0, 0, 0, - 0, 62, 0, 0, 39, 0, 0, 39, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 51, 0, 60, 61, - 63, 47, 0, 56, 0, 64, 59, 0, 58, 0, +#define YYTABLESIZE 4154 +dEXT short yytable[] = { 69, + 20, 85, 62, 62, 85, 207, 62, 203, 167, 180, + 102, 339, 169, 206, 80, 268, 201, 112, 85, 85, + 250, 82, 245, 85, 271, 124, 293, 57, 306, 122, + 307, 171, 121, 15, 334, 335, 167, 84, 18, 341, + 149, 308, 357, 131, 168, 147, 148, 135, 38, 272, + 93, 15, 97, 85, 98, 349, 18, 141, 233, 352, + 172, 67, 16, 170, 17, 112, 38, 169, 149, 99, + 186, 187, 188, 189, 190, 191, 282, 37, 25, 67, + 16, 288, 17, 290, 100, 292, 23, 313, 199, 23, + 231, 57, 195, 196, 305, 37, 112, 336, 337, 168, + 174, 39, 143, 144, 145, 146, 105, 106, 175, 107, + 177, 25, 173, 67, 25, 25, 25, 23, 25, 15, + 25, 25, 179, 25, 315, 287, 326, 147, 148, 209, + 210, 212, 213, 214, 215, 216, 182, 25, 192, 4, + 5, 6, 25, 7, 8, 193, 200, 205, 248, 62, + 289, 273, 20, 236, 237, 238, 239, 240, 241, 243, + 202, 291, 279, 309, 281, 270, 148, 286, 196, 25, + 351, 295, 255, 210, 298, 210, 299, 265, 314, 300, + 330, 301, 167, 302, 274, 20, 276, 278, 20, 20, + 20, 280, 20, 304, 20, 20, 303, 20, 19, 311, + 316, 25, 317, 25, 25, 318, 319, 321, 329, 147, + 148, 20, 332, 331, 149, 340, 20, 284, 342, 285, + 353, 70, 112, 87, 70, 232, 163, 112, 88, 164, + 165, 166, 85, 85, 85, 85, 354, 141, 70, 70, + 141, 85, 346, 20, 51, 147, 148, 85, 85, 251, + 85, 57, 252, 158, 141, 141, 344, 85, 85, 166, + 85, 85, 85, 85, 85, 85, 101, 310, 2, 147, + 148, 156, 196, 70, 36, 20, 34, 20, 20, 159, + 147, 148, 147, 148, 147, 148, 147, 148, 156, 141, + 255, 39, 67, 67, 67, 67, 36, 147, 148, 167, + 34, 43, 147, 148, 43, 43, 43, 21, 43, 96, + 43, 43, 211, 43, 147, 148, 77, 67, 67, 147, + 148, 147, 148, 147, 148, 147, 148, 43, 69, 147, + 148, 149, 43, 348, 25, 25, 25, 25, 25, 25, + 262, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 147, 148, 328, 25, 25, 43, + 25, 25, 25, 25, 25, 147, 148, 147, 148, 25, + 25, 25, 25, 25, 25, 167, 185, 25, 82, 320, + 153, 82, 147, 148, 147, 148, 25, 0, 25, 25, + 0, 43, 0, 0, 43, 82, 82, 162, 0, 0, + 163, 156, 0, 164, 165, 166, 0, 149, 20, 20, + 20, 20, 20, 20, 0, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 0, 167, + 82, 20, 20, 0, 20, 20, 20, 20, 20, 0, + 0, 0, 0, 20, 20, 20, 20, 20, 20, 0, + 0, 20, 70, 70, 70, 70, 0, 0, 0, 167, + 20, 149, 20, 20, 0, 0, 0, 0, 141, 141, + 141, 141, 167, 0, 181, 0, 170, 70, 70, 170, + 170, 170, 0, 170, 154, 170, 170, 154, 170, 150, + 0, 149, 0, 141, 141, 151, 152, 153, 154, 0, + 0, 154, 154, 0, 149, 204, 154, 170, 155, 157, + 158, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 43, 43, 43, 43, 43, 43, + 0, 43, 43, 43, 154, 0, 154, 43, 0, 0, + 43, 43, 43, 43, 0, 0, 0, 43, 43, 0, + 43, 43, 43, 43, 43, 0, 0, 0, 0, 43, + 43, 43, 43, 43, 43, 66, 154, 43, 66, 170, + 0, 0, 167, 153, 154, 0, 43, 171, 43, 43, + 171, 171, 171, 66, 171, 113, 171, 171, 113, 171, + 162, 0, 0, 163, 0, 0, 164, 165, 166, 0, + 0, 0, 113, 113, 149, 0, 0, 113, 171, 82, + 82, 82, 82, 0, 0, 0, 0, 66, 0, 150, + 0, 0, 0, 0, 0, 151, 152, 153, 154, 0, + 0, 294, 0, 0, 82, 82, 297, 113, 155, 157, + 158, 159, 160, 161, 162, 0, 103, 163, 0, 103, + 164, 165, 166, 0, 0, 151, 152, 153, 154, 0, + 0, 0, 0, 103, 103, 0, 0, 0, 103, 0, + 171, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 162, 0, 0, + 163, 0, 0, 164, 165, 166, 0, 0, 103, 0, + 170, 170, 170, 170, 170, 0, 170, 170, 170, 0, + 0, 0, 170, 0, 0, 154, 154, 154, 154, 0, + 0, 0, 0, 170, 154, 170, 170, 170, 170, 170, + 154, 154, 154, 154, 170, 170, 170, 170, 170, 170, + 154, 154, 170, 154, 154, 154, 154, 154, 154, 154, + 0, 170, 154, 170, 170, 154, 154, 154, 94, 0, + 0, 94, 0, 104, 0, 0, 104, 0, 151, 152, + 153, 154, 0, 0, 0, 94, 94, 0, 0, 0, + 104, 104, 0, 0, 0, 104, 161, 162, 0, 249, + 163, 0, 0, 164, 165, 166, 66, 66, 66, 66, + 0, 171, 171, 171, 171, 171, 0, 171, 171, 171, + 94, 0, 350, 171, 0, 104, 113, 113, 113, 113, + 0, 66, 0, 0, 171, 113, 171, 171, 171, 171, + 171, 113, 113, 113, 113, 171, 171, 171, 171, 171, + 171, 113, 113, 171, 113, 113, 113, 113, 113, 113, + 113, 0, 171, 113, 171, 171, 113, 113, 113, 52, + 0, 0, 62, 64, 50, 0, 57, 0, 65, 60, + 0, 59, 0, 0, 0, 0, 0, 103, 103, 103, + 103, 0, 0, 0, 0, 58, 103, 0, 0, 0, + 63, 0, 103, 103, 103, 103, 0, 0, 0, 0, + 0, 0, 103, 103, 67, 103, 103, 103, 103, 103, + 103, 103, 0, 0, 103, 43, 0, 61, 43, 43, + 43, 0, 43, 0, 43, 43, 92, 43, 0, 0, + 4, 5, 6, 108, 7, 8, 117, 0, 0, 0, + 0, 43, 0, 114, 115, 0, 43, 0, 0, 23, + 123, 0, 53, 4, 5, 6, 0, 7, 8, 0, + 0, 0, 136, 137, 138, 139, 0, 0, 0, 0, + 0, 52, 176, 43, 62, 64, 50, 0, 57, 0, + 65, 60, 0, 59, 0, 0, 184, 0, 0, 94, + 94, 94, 94, 0, 104, 104, 104, 104, 0, 0, + 0, 0, 63, 104, 0, 43, 0, 198, 43, 104, + 104, 104, 104, 0, 94, 94, 0, 94, 0, 104, + 104, 0, 104, 104, 104, 104, 104, 104, 104, 61, + 0, 104, 208, 0, 52, 0, 0, 62, 64, 50, + 0, 57, 0, 65, 60, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 240, 0, 0, 0, 0, 62, 0, 0, - 23, 0, 0, 52, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 163, 0, 0, 164, 0, - 0, 165, 166, 167, 60, 0, 0, 0, 0, 51, - 0, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 0, 56, 56, 56, 56, 0, 0, - 0, 0, 0, 0, 0, 114, 23, 0, 0, 52, - 62, 0, 0, 0, 0, 0, 56, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, - 39, 39, 39, 0, 39, 39, 39, 60, 0, 0, - 39, 0, 0, 39, 39, 39, 39, 0, 0, 0, - 39, 39, 0, 39, 39, 39, 0, 0, 0, 0, - 39, 39, 39, 39, 39, 0, 0, 39, 39, 0, - 168, 157, 52, 0, 39, 0, 0, 0, 39, 0, - 39, 39, 0, 0, 119, 25, 26, 27, 28, 85, - 29, 30, 31, 0, 0, 0, 32, 0, 0, 168, - 320, 0, 150, 0, 0, 0, 0, 38, 0, 39, - 40, 41, 0, 0, 0, 0, 42, 43, 44, 45, - 46, 0, 157, 48, 49, 0, 0, 0, 0, 0, - 50, 150, 0, 0, 53, 0, 54, 55, 0, 0, - 109, 25, 26, 27, 28, 0, 29, 30, 31, 0, - 168, 0, 32, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 38, 0, 39, 40, 41, 0, 0, - 0, 0, 42, 43, 44, 45, 46, 0, 0, 48, - 49, 135, 150, 0, 135, 0, 50, 0, 0, 0, - 53, 0, 54, 55, 0, 0, 0, 0, 135, 135, - 0, 0, 0, 24, 25, 26, 27, 28, 168, 29, - 30, 31, 0, 51, 0, 32, 61, 63, 47, 0, - 56, 0, 64, 59, 0, 58, 38, 0, 39, 40, - 41, 0, 0, 135, 0, 42, 43, 44, 45, 46, - 150, 0, 48, 49, 62, 0, 0, 0, 0, 50, - 0, 0, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 0, 0, 152, 0, 154, 155, 0, 51, - 0, 60, 61, 63, 47, 0, 56, 131, 64, 59, - 0, 58, 0, 162, 163, 0, 0, 164, 0, 151, - 165, 166, 167, 152, 153, 154, 155, 0, 0, 0, - 62, 0, 0, 23, 0, 0, 52, 158, 159, 160, - 161, 0, 162, 163, 0, 0, 164, 0, 0, 165, - 166, 167, 0, 0, 0, 51, 0, 60, 61, 63, - 47, 0, 56, 0, 64, 59, 0, 58, 0, 0, - 151, 0, 0, 0, 152, 153, 154, 155, 0, 0, - 0, 0, 0, 0, 0, 0, 62, 156, 158, 159, - 160, 161, 52, 162, 163, 0, 0, 164, 0, 0, - 165, 166, 167, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 60, 0, 135, 0, 0, 51, 0, - 0, 61, 63, 47, 0, 56, 0, 64, 59, 0, - 58, 0, 0, 0, 154, 155, 0, 0, 0, 0, - 0, 0, 135, 135, 135, 135, 0, 0, 52, 62, - 0, 162, 163, 0, 0, 164, 0, 0, 165, 166, - 167, 0, 0, 0, 135, 135, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 60, 0, 0, 32, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, - 43, 44, 45, 46, 0, 0, 48, 49, 0, 0, - 0, 52, 0, 50, 0, 0, 0, 53, 0, 54, - 55, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 168, 0, 32, 0, 0, 0, 0, + 0, 23, 0, 0, 53, 63, 0, 0, 0, 246, + 0, 0, 0, 0, 0, 0, 254, 0, 0, 0, + 0, 0, 22, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 61, 0, 0, 32, 0, 0, 33, 34, + 35, 36, 0, 0, 0, 37, 38, 0, 39, 40, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 23, 51, 0, 53, 0, 0, + 0, 0, 0, 0, 54, 0, 55, 56, 43, 43, + 43, 43, 43, 43, 0, 43, 43, 43, 0, 0, + 167, 43, 0, 0, 43, 43, 43, 43, 0, 0, + 0, 43, 43, 0, 43, 43, 43, 43, 43, 0, + 0, 0, 0, 43, 43, 43, 43, 43, 43, 167, + 0, 43, 149, 0, 0, 0, 0, 0, 0, 0, + 43, 0, 43, 43, 0, 110, 25, 26, 27, 28, + 88, 29, 30, 31, 0, 52, 0, 32, 62, 64, + 50, 149, 57, 130, 65, 60, 0, 59, 38, 0, + 39, 40, 41, 42, 43, 0, 0, 0, 0, 44, + 45, 46, 47, 48, 49, 0, 63, 51, 0, 0, + 0, 0, 0, 0, 0, 0, 54, 0, 55, 56, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 25, + 26, 27, 28, 61, 29, 30, 31, 0, 52, 0, + 32, 62, 64, 50, 0, 57, 0, 65, 60, 0, + 59, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 53, 63, + 51, 0, 323, 324, 325, 0, 327, 0, 0, 54, + 0, 55, 56, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 52, 0, 61, 62, 64, 50, + 0, 57, 343, 65, 60, 0, 59, 0, 0, 345, + 0, 0, 0, 347, 0, 0, 151, 152, 153, 154, + 120, 0, 0, 0, 0, 63, 355, 356, 23, 0, + 0, 53, 0, 160, 161, 162, 0, 0, 163, 0, + 0, 164, 165, 166, 0, 151, 0, 153, 154, 0, + 52, 0, 61, 62, 64, 50, 0, 57, 0, 65, + 60, 0, 59, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 0, 0, 0, + 0, 63, 0, 0, 0, 0, 0, 53, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 24, + 25, 26, 27, 28, 0, 29, 30, 31, 61, 52, + 134, 32, 62, 64, 50, 0, 57, 194, 65, 60, + 0, 59, 38, 0, 39, 40, 41, 42, 43, 0, + 0, 0, 0, 44, 45, 46, 47, 48, 49, 0, + 63, 51, 0, 53, 0, 0, 0, 0, 0, 0, + 54, 0, 55, 56, 0, 0, 0, 0, 87, 0, + 0, 87, 116, 25, 26, 27, 28, 61, 29, 30, + 31, 0, 0, 0, 32, 87, 87, 0, 0, 0, + 87, 0, 0, 0, 0, 38, 0, 39, 40, 41, + 42, 43, 0, 0, 0, 0, 44, 45, 46, 47, + 48, 49, 53, 0, 51, 0, 0, 0, 0, 0, + 87, 0, 0, 54, 88, 55, 56, 88, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 0, 0, 0, + 32, 88, 88, 0, 0, 0, 88, 0, 0, 0, + 0, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 0, 0, + 51, 0, 0, 0, 0, 0, 88, 0, 0, 54, + 0, 55, 56, 0, 24, 25, 26, 27, 28, 0, + 29, 30, 31, 0, 52, 0, 32, 62, 64, 50, + 0, 57, 242, 65, 60, 0, 59, 38, 0, 39, + 40, 41, 42, 43, 0, 0, 0, 0, 44, 45, + 46, 47, 48, 49, 0, 63, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 54, 0, 55, 56, 0, + 0, 0, 0, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 61, 52, 0, 32, 62, 64, 50, 0, + 57, 0, 65, 60, 0, 59, 38, 0, 39, 40, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 63, 51, 0, 53, 0, 0, + 0, 0, 0, 0, 54, 0, 55, 56, 0, 87, + 87, 87, 87, 0, 0, 0, 0, 0, 87, 52, + 0, 61, 62, 64, 50, 87, 57, 275, 65, 60, + 0, 59, 0, 0, 87, 87, 0, 87, 87, 87, + 87, 87, 0, 0, 0, 0, 0, 0, 0, 0, + 63, 0, 0, 0, 0, 0, 53, 0, 0, 0, + 0, 0, 0, 0, 0, 88, 88, 88, 88, 0, + 0, 0, 0, 0, 88, 52, 0, 61, 62, 64, + 50, 0, 57, 277, 65, 60, 0, 59, 0, 0, + 88, 88, 0, 88, 88, 88, 88, 88, 0, 0, + 0, 0, 0, 0, 0, 0, 63, 0, 0, 0, + 0, 0, 53, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 25, + 26, 27, 28, 61, 29, 30, 31, 0, 52, 0, + 32, 62, 64, 50, 0, 57, 0, 65, 60, 0, + 59, 38, 0, 39, 40, 41, 42, 43, 0, 0, + 0, 0, 44, 45, 46, 47, 48, 49, 53, 63, + 51, 0, 0, 0, 0, 0, 0, 0, 0, 54, + 0, 55, 56, 0, 0, 0, 22, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 61, 0, 0, 32, + 69, 0, 0, 69, 0, 0, 0, 0, 0, 0, + 38, 0, 39, 40, 41, 42, 43, 69, 69, 0, + 0, 44, 45, 46, 47, 48, 49, 167, 0, 51, + 0, 53, 0, 0, 0, 0, 147, 0, 54, 147, + 55, 56, 0, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 69, 147, 147, 32, 0, 0, 147, 149, 0, 0, 0, 0, 0, 0, 38, 0, 39, 40, - 41, 0, 0, 0, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 168, 150, 0, 0, 0, 50, - 0, 82, 0, 53, 82, 54, 55, 0, 0, 24, - 25, 26, 27, 28, 0, 29, 30, 31, 82, 82, - 0, 32, 0, 82, 0, 0, 150, 0, 0, 0, - 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, - 0, 42, 43, 44, 45, 46, 0, 0, 48, 49, - 0, 130, 0, 82, 130, 50, 0, 0, 0, 53, - 0, 54, 55, 0, 0, 0, 0, 0, 130, 130, - 0, 22, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 0, 51, 0, 32, 61, 63, 47, 0, 56, - 200, 64, 59, 0, 58, 38, 0, 39, 40, 41, - 0, 0, 0, 130, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 62, 0, 0, 0, 0, 50, 0, - 0, 0, 53, 0, 54, 55, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 51, 0, - 60, 61, 63, 47, 0, 56, 248, 64, 59, 0, - 58, 0, 0, 0, 0, 0, 0, 152, 153, 154, - 155, 0, 0, 0, 0, 0, 0, 0, 0, 62, - 0, 0, 159, 160, 161, 52, 162, 163, 0, 0, - 164, 0, 0, 165, 166, 167, 0, 0, 152, 153, - 154, 155, 0, 0, 51, 0, 60, 61, 63, 47, - 0, 56, 276, 64, 59, 161, 58, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 0, 0, 0, 0, 0, 62, 0, 0, 0, 0, - 0, 52, 82, 82, 82, 82, 0, 0, 0, 0, - 0, 82, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 60, 0, 82, 82, 0, 51, 82, 82, - 61, 63, 47, 0, 56, 278, 64, 59, 0, 58, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 130, 130, 130, 130, 0, 52, 62, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 130, 130, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 60, 0, 0, 32, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, - 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, - 44, 45, 46, 0, 0, 48, 49, 0, 0, 0, - 52, 0, 50, 0, 136, 0, 53, 136, 54, 55, - 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 136, 136, 0, 32, 0, 136, 0, 0, 0, - 0, 0, 0, 0, 0, 38, 0, 39, 40, 41, - 0, 0, 0, 0, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 0, 136, 0, 136, 0, 50, 0, - 119, 0, 53, 119, 54, 55, 0, 0, 24, 25, - 26, 27, 28, 0, 29, 30, 31, 119, 119, 0, - 32, 0, 119, 0, 0, 0, 136, 0, 0, 0, - 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, - 42, 43, 44, 45, 46, 0, 0, 48, 49, 0, - 119, 0, 119, 0, 50, 0, 0, 0, 53, 0, - 54, 55, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, - 0, 51, 119, 32, 61, 63, 47, 0, 56, 0, - 64, 59, 0, 58, 38, 0, 39, 40, 41, 0, - 0, 0, 0, 42, 43, 44, 45, 46, 0, 0, - 48, 49, 62, 0, 0, 0, 0, 50, 0, 0, - 0, 53, 0, 54, 55, 0, 0, 0, 0, 0, - 143, 0, 0, 143, 0, 0, 0, 0, 0, 60, - 0, 0, 0, 0, 0, 0, 0, 143, 143, 0, - 0, 0, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 52, 136, 136, 136, 136, 0, - 143, 0, 143, 0, 136, 0, 0, 0, 136, 136, - 136, 136, 0, 0, 0, 0, 0, 136, 136, 0, - 0, 136, 136, 136, 136, 136, 0, 136, 136, 0, - 0, 136, 143, 0, 136, 136, 136, 0, 0, 0, - 0, 129, 0, 0, 129, 0, 0, 0, 0, 0, - 0, 119, 119, 119, 119, 0, 0, 0, 129, 129, - 119, 0, 0, 129, 119, 119, 119, 119, 0, 0, - 0, 0, 0, 119, 119, 0, 0, 119, 119, 119, - 119, 119, 0, 119, 119, 0, 104, 119, 0, 104, - 119, 119, 119, 129, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 104, 104, 0, 0, 0, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 129, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 0, 0, 104, 32, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, - 39, 40, 41, 0, 0, 0, 0, 42, 43, 44, - 45, 46, 0, 0, 48, 49, 0, 0, 0, 0, - 0, 50, 0, 0, 0, 53, 0, 54, 55, 0, - 0, 143, 143, 143, 143, 0, 0, 0, 0, 0, - 143, 0, 0, 0, 143, 143, 143, 143, 0, 0, - 0, 0, 0, 143, 143, 0, 0, 143, 143, 143, - 143, 143, 0, 143, 143, 145, 0, 143, 145, 0, - 143, 143, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 145, 145, 0, 0, 0, 145, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 83, 0, 0, 83, 0, 145, 0, 0, - 0, 0, 129, 129, 129, 129, 0, 0, 0, 83, - 83, 129, 0, 0, 0, 129, 129, 129, 129, 0, - 0, 0, 0, 0, 129, 129, 0, 145, 129, 129, - 129, 129, 129, 0, 129, 129, 0, 0, 129, 0, - 0, 129, 129, 129, 83, 0, 0, 104, 104, 104, - 104, 0, 0, 0, 0, 0, 104, 0, 0, 0, - 104, 104, 104, 104, 0, 0, 0, 131, 0, 104, - 104, 0, 0, 104, 104, 104, 104, 104, 0, 104, - 104, 0, 0, 104, 131, 131, 104, 104, 104, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 0, 0, 131, 0, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 146, 146, - 0, 0, 0, 146, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 131, + 41, 42, 43, 0, 0, 0, 0, 44, 45, 46, + 47, 48, 49, 0, 0, 51, 147, 0, 147, 0, + 0, 0, 0, 0, 54, 130, 55, 56, 130, 24, + 25, 26, 27, 28, 0, 29, 30, 31, 0, 0, + 0, 32, 130, 130, 0, 0, 0, 130, 147, 0, + 0, 0, 38, 0, 39, 40, 41, 42, 43, 0, + 0, 0, 0, 44, 45, 46, 47, 48, 49, 0, + 0, 51, 0, 0, 0, 130, 0, 130, 0, 0, + 54, 0, 55, 56, 0, 0, 0, 0, 154, 0, + 0, 154, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 0, 0, 0, 32, 154, 154, 130, 0, 0, + 154, 0, 0, 0, 0, 38, 0, 39, 40, 41, + 42, 43, 0, 0, 0, 0, 44, 45, 46, 47, + 48, 49, 0, 0, 51, 0, 140, 0, 154, 140, + 154, 0, 0, 54, 0, 55, 56, 0, 0, 0, + 0, 0, 0, 140, 140, 153, 154, 0, 140, 0, + 0, 69, 69, 69, 69, 0, 0, 0, 0, 0, + 154, 161, 162, 0, 0, 163, 0, 0, 164, 165, + 166, 0, 0, 0, 0, 0, 69, 69, 140, 0, + 0, 0, 0, 0, 0, 0, 0, 147, 147, 147, + 147, 0, 115, 0, 0, 115, 147, 0, 0, 0, + 0, 0, 147, 147, 147, 147, 0, 0, 140, 115, + 115, 0, 147, 147, 115, 147, 147, 147, 147, 147, + 147, 147, 0, 0, 147, 0, 0, 147, 147, 147, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 146, 0, 0, 96, 0, 0, 96, - 0, 0, 0, 0, 0, 0, 145, 145, 145, 145, - 0, 0, 0, 96, 96, 145, 0, 0, 96, 145, - 145, 145, 145, 146, 0, 0, 0, 0, 145, 145, - 0, 0, 145, 145, 145, 145, 145, 0, 145, 145, - 58, 0, 145, 58, 0, 145, 145, 145, 96, 0, - 0, 0, 0, 83, 83, 83, 83, 58, 58, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 83, 83, 0, 96, 83, - 0, 0, 0, 61, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 61, 61, 0, 0, 0, 61, 0, 0, 0, 0, + 0, 0, 115, 0, 115, 0, 130, 130, 130, 130, + 0, 156, 0, 0, 156, 130, 0, 0, 0, 0, + 0, 130, 130, 130, 130, 0, 0, 0, 156, 156, + 0, 130, 130, 156, 130, 130, 130, 130, 130, 130, + 130, 0, 0, 130, 0, 0, 130, 130, 130, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 131, 131, - 131, 131, 0, 61, 0, 61, 0, 131, 0, 0, - 0, 131, 131, 131, 131, 59, 0, 0, 59, 0, - 131, 131, 0, 0, 131, 131, 131, 131, 131, 0, - 131, 131, 59, 59, 131, 61, 0, 131, 131, 131, - 0, 0, 146, 146, 146, 146, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 146, 146, 146, 146, 0, - 0, 0, 0, 0, 146, 146, 0, 59, 146, 146, - 146, 146, 146, 0, 146, 146, 0, 0, 146, 0, - 0, 146, 146, 146, 0, 0, 0, 145, 0, 0, - 145, 0, 0, 0, 0, 0, 0, 96, 96, 96, - 96, 0, 0, 0, 145, 145, 96, 0, 0, 145, - 96, 96, 96, 96, 0, 0, 0, 0, 0, 96, - 96, 0, 0, 96, 96, 96, 96, 96, 0, 96, - 96, 132, 0, 96, 132, 0, 96, 96, 96, 145, - 0, 58, 58, 58, 58, 0, 0, 0, 132, 132, - 58, 0, 0, 132, 58, 58, 58, 58, 0, 0, - 0, 0, 0, 58, 58, 0, 0, 58, 58, 58, - 58, 58, 0, 58, 58, 0, 0, 58, 0, 0, - 58, 58, 58, 132, 61, 61, 61, 61, 0, 284, - 0, 0, 0, 61, 157, 0, 0, 61, 61, 61, - 61, 0, 0, 0, 0, 0, 61, 61, 0, 0, - 61, 61, 61, 61, 61, 95, 61, 61, 95, 0, - 61, 0, 168, 61, 61, 61, 0, 0, 0, 0, - 0, 0, 95, 95, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, - 0, 0, 0, 0, 150, 0, 0, 102, 0, 0, - 102, 0, 0, 0, 0, 0, 0, 95, 59, 59, - 0, 0, 0, 0, 102, 102, 0, 0, 0, 102, + 0, 0, 0, 156, 0, 0, 0, 0, 0, 154, + 154, 154, 154, 0, 0, 0, 0, 0, 154, 0, + 0, 0, 0, 0, 154, 154, 154, 154, 0, 0, + 0, 0, 0, 156, 154, 154, 0, 154, 154, 154, + 154, 154, 154, 154, 0, 0, 154, 0, 0, 154, + 154, 154, 0, 0, 0, 0, 0, 140, 140, 140, + 140, 0, 157, 0, 0, 0, 140, 0, 0, 0, + 0, 0, 140, 140, 140, 140, 0, 0, 0, 157, + 157, 0, 140, 140, 157, 140, 140, 140, 140, 140, + 140, 140, 0, 0, 140, 0, 0, 140, 140, 140, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 109, 102, - 0, 109, 0, 0, 0, 0, 0, 0, 145, 145, - 145, 145, 0, 0, 0, 109, 109, 145, 0, 0, - 109, 145, 145, 145, 145, 0, 0, 0, 0, 0, - 145, 145, 0, 0, 145, 145, 145, 145, 145, 0, - 145, 145, 92, 0, 145, 92, 0, 145, 145, 145, - 109, 0, 132, 132, 132, 132, 0, 0, 0, 92, - 92, 132, 0, 0, 92, 132, 132, 132, 132, 0, - 0, 0, 0, 0, 132, 132, 0, 0, 132, 132, - 132, 132, 132, 93, 132, 132, 93, 0, 132, 0, - 0, 132, 132, 132, 92, 0, 0, 0, 0, 0, - 93, 93, 151, 0, 0, 93, 152, 153, 154, 155, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 156, - 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, - 0, 0, 165, 166, 167, 93, 95, 95, 95, 95, - 0, 0, 0, 0, 0, 95, 0, 0, 0, 95, - 95, 95, 95, 0, 0, 0, 0, 0, 95, 95, - 0, 0, 95, 95, 95, 95, 95, 0, 95, 95, - 0, 0, 95, 0, 0, 95, 95, 95, 102, 102, - 102, 102, 0, 0, 0, 0, 0, 102, 0, 0, - 0, 102, 102, 102, 102, 71, 0, 0, 71, 0, - 102, 102, 0, 0, 102, 102, 102, 102, 102, 0, - 102, 102, 71, 71, 102, 0, 0, 102, 102, 102, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 109, - 109, 109, 109, 0, 0, 0, 0, 0, 109, 0, - 0, 0, 109, 109, 109, 109, 0, 71, 0, 0, - 0, 109, 109, 0, 0, 109, 109, 109, 109, 109, - 0, 109, 109, 0, 0, 109, 0, 0, 109, 109, - 109, 0, 0, 92, 92, 92, 92, 0, 0, 0, - 0, 0, 92, 0, 0, 0, 92, 92, 92, 92, - 0, 0, 0, 0, 0, 92, 92, 0, 0, 92, - 92, 92, 92, 92, 87, 92, 92, 87, 0, 92, - 0, 0, 0, 0, 93, 93, 93, 93, 0, 0, - 0, 87, 87, 93, 0, 0, 87, 93, 93, 93, - 93, 0, 0, 0, 0, 0, 93, 93, 0, 0, - 93, 93, 93, 93, 93, 88, 93, 93, 88, 0, - 93, 0, 0, 0, 0, 0, 87, 0, 0, 0, - 0, 0, 88, 88, 0, 0, 0, 88, 0, 0, + 0, 0, 157, 0, 157, 0, 0, 0, 0, 0, + 0, 0, 0, 115, 115, 115, 115, 0, 0, 0, + 0, 0, 115, 0, 0, 0, 0, 0, 115, 115, + 115, 115, 0, 0, 157, 0, 0, 0, 115, 115, + 0, 115, 115, 115, 115, 115, 115, 115, 0, 0, + 115, 0, 0, 115, 115, 115, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 89, 0, 0, 89, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 88, 89, 89, - 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 85, 0, 0, - 85, 0, 0, 0, 0, 0, 71, 71, 71, 71, - 0, 0, 0, 89, 85, 85, 0, 0, 0, 85, - 0, 0, 0, 0, 0, 0, 0, 0, 71, 71, - 0, 0, 0, 86, 0, 0, 86, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, - 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, - 0, 0, 84, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 86, 84, 84, 0, 0, - 0, 84, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 156, 156, 156, 156, 0, 142, 0, 0, + 0, 156, 0, 0, 0, 0, 0, 156, 156, 156, + 156, 0, 0, 0, 142, 142, 0, 156, 156, 142, + 156, 156, 156, 156, 156, 156, 156, 0, 0, 156, + 0, 0, 156, 156, 156, 0, 0, 0, 0, 0, + 107, 0, 0, 107, 0, 0, 0, 142, 0, 142, + 93, 0, 0, 93, 0, 0, 0, 107, 107, 0, + 0, 0, 107, 0, 0, 0, 0, 93, 93, 0, + 0, 0, 93, 0, 0, 0, 0, 0, 0, 142, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 87, 87, 87, 87, 0, - 0, 84, 0, 0, 87, 0, 0, 0, 87, 87, - 87, 87, 0, 0, 0, 0, 0, 87, 87, 0, - 0, 87, 87, 87, 87, 87, 72, 87, 87, 72, - 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, - 0, 0, 0, 72, 72, 88, 0, 0, 72, 88, - 88, 88, 88, 0, 0, 0, 0, 0, 88, 88, - 0, 0, 88, 88, 88, 88, 88, 0, 88, 88, - 0, 0, 89, 89, 89, 89, 0, 0, 72, 0, - 0, 89, 0, 0, 0, 89, 89, 89, 89, 0, - 0, 0, 0, 0, 89, 89, 0, 0, 89, 89, - 89, 89, 89, 0, 89, 89, 0, 0, 85, 85, - 85, 85, 0, 0, 0, 0, 0, 85, 0, 0, - 0, 85, 85, 85, 85, 0, 0, 0, 0, 0, - 85, 85, 0, 0, 85, 85, 85, 85, 85, 0, - 85, 85, 0, 0, 86, 86, 86, 86, 0, 0, - 0, 0, 0, 86, 0, 0, 0, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 86, 86, 0, 0, - 86, 86, 86, 86, 86, 0, 86, 86, 0, 0, - 84, 84, 84, 84, 0, 0, 0, 0, 0, 84, - 0, 0, 0, 84, 84, 84, 84, 73, 0, 0, - 73, 0, 84, 84, 0, 0, 84, 84, 84, 84, - 84, 0, 84, 84, 73, 73, 0, 0, 0, 73, + 0, 0, 107, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 93, 157, 157, 157, 157, 0, 68, 0, + 0, 68, 157, 0, 0, 0, 0, 0, 157, 157, + 157, 157, 107, 0, 0, 68, 68, 0, 157, 157, + 68, 157, 157, 157, 157, 157, 157, 157, 0, 0, + 157, 0, 0, 157, 157, 157, 0, 0, 0, 0, + 0, 71, 0, 0, 0, 0, 0, 0, 0, 0, + 68, 0, 0, 0, 0, 0, 0, 0, 71, 71, + 0, 0, 0, 71, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 74, 0, 0, 74, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 74, 74, 73, - 0, 0, 74, 0, 0, 0, 0, 72, 72, 72, - 72, 0, 0, 0, 0, 0, 72, 0, 0, 0, - 72, 72, 72, 72, 75, 0, 0, 75, 0, 72, - 72, 0, 74, 72, 72, 72, 72, 72, 0, 72, - 72, 75, 75, 0, 0, 0, 75, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, - 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 123, 123, 75, 0, 0, 123, - 0, 0, 0, 0, 0, 0, 0, 0, 94, 0, - 0, 94, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 94, 94, 0, 0, 123, - 94, 0, 0, 0, 0, 0, 0, 0, 0, 134, - 0, 0, 134, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 134, 134, 0, 0, - 94, 134, 0, 0, 0, 0, 0, 0, 0, 0, - 76, 0, 0, 76, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 77, 76, 76, 77, - 0, 134, 76, 0, 0, 0, 0, 0, 73, 73, - 73, 73, 0, 77, 77, 0, 0, 73, 77, 0, - 0, 73, 73, 73, 73, 0, 0, 0, 0, 0, - 73, 73, 76, 0, 73, 73, 73, 73, 73, 0, - 73, 74, 74, 74, 74, 0, 0, 0, 77, 0, - 74, 0, 0, 0, 74, 74, 0, 74, 78, 0, - 0, 78, 0, 74, 74, 0, 0, 74, 74, 74, - 74, 74, 0, 74, 79, 78, 78, 79, 0, 0, - 78, 0, 0, 0, 0, 75, 75, 75, 75, 0, - 0, 79, 79, 0, 75, 0, 79, 0, 75, 75, - 0, 0, 0, 0, 0, 0, 0, 75, 75, 0, - 78, 75, 75, 75, 75, 75, 0, 75, 123, 123, - 123, 123, 0, 0, 0, 0, 79, 123, 0, 0, - 0, 123, 123, 0, 0, 0, 0, 0, 0, 81, - 123, 123, 81, 0, 123, 123, 123, 123, 123, 94, - 94, 94, 94, 0, 0, 0, 81, 81, 94, 0, - 0, 81, 94, 94, 0, 0, 0, 0, 0, 0, - 0, 94, 94, 0, 0, 94, 94, 94, 94, 94, - 134, 134, 134, 134, 0, 0, 0, 0, 0, 134, - 0, 81, 0, 134, 134, 0, 0, 0, 0, 0, - 0, 0, 134, 134, 0, 0, 134, 134, 134, 134, - 134, 76, 76, 76, 76, 0, 0, 0, 0, 0, - 76, 0, 0, 0, 0, 76, 0, 77, 77, 77, - 77, 0, 0, 76, 76, 0, 77, 76, 76, 76, - 76, 76, 0, 0, 0, 0, 0, 0, 0, 77, - 77, 0, 0, 77, 77, 77, 77, 77, 0, 0, + 68, 0, 0, 0, 0, 106, 0, 0, 106, 0, + 0, 71, 0, 71, 0, 0, 0, 0, 0, 0, + 0, 0, 106, 106, 0, 0, 0, 106, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 142, 142, + 142, 142, 0, 71, 0, 0, 0, 142, 0, 0, + 0, 0, 0, 142, 142, 142, 142, 106, 0, 0, + 0, 0, 0, 142, 142, 0, 142, 142, 142, 142, + 142, 142, 142, 0, 0, 142, 0, 0, 142, 142, + 142, 107, 107, 107, 107, 0, 143, 106, 0, 143, + 107, 93, 93, 93, 93, 0, 107, 107, 107, 107, + 93, 0, 0, 143, 143, 0, 107, 107, 143, 107, + 107, 107, 107, 107, 107, 107, 93, 93, 107, 93, + 93, 107, 107, 107, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 143, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 68, + 68, 68, 68, 0, 156, 0, 0, 156, 68, 0, + 0, 0, 0, 0, 68, 68, 68, 68, 0, 0, + 0, 156, 156, 0, 68, 68, 156, 68, 68, 68, + 68, 68, 68, 68, 0, 0, 68, 0, 0, 68, + 68, 68, 71, 71, 71, 71, 0, 113, 0, 0, + 113, 71, 0, 0, 0, 0, 156, 71, 71, 71, + 71, 0, 0, 0, 113, 113, 0, 71, 71, 113, + 71, 71, 71, 71, 71, 71, 71, 0, 0, 71, + 0, 0, 71, 71, 71, 0, 106, 106, 106, 106, + 0, 120, 0, 0, 120, 106, 0, 0, 0, 113, + 0, 106, 106, 106, 106, 0, 0, 0, 120, 120, + 0, 106, 106, 120, 106, 106, 106, 106, 106, 106, + 106, 0, 0, 106, 0, 0, 106, 106, 106, 0, + 0, 0, 0, 0, 98, 0, 0, 98, 0, 0, + 0, 0, 0, 120, 0, 0, 0, 0, 0, 0, + 0, 98, 98, 0, 0, 0, 98, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 143, 143, 143, + 143, 0, 99, 0, 0, 99, 143, 0, 0, 0, + 0, 0, 143, 143, 143, 143, 98, 0, 0, 99, + 99, 0, 143, 143, 99, 143, 143, 143, 143, 143, + 143, 143, 0, 0, 143, 0, 0, 143, 143, 143, + 100, 0, 0, 100, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 99, 0, 0, 100, 100, 0, + 0, 0, 100, 0, 0, 156, 156, 156, 156, 0, + 0, 0, 0, 0, 156, 0, 0, 0, 0, 0, + 156, 156, 156, 156, 0, 0, 0, 0, 0, 0, + 156, 156, 100, 156, 156, 156, 156, 156, 156, 156, + 0, 0, 156, 0, 0, 156, 156, 156, 113, 113, + 113, 113, 0, 96, 0, 0, 96, 113, 0, 0, + 0, 0, 0, 113, 113, 113, 113, 0, 0, 0, + 96, 96, 0, 113, 113, 96, 113, 113, 113, 113, + 113, 113, 113, 0, 0, 113, 0, 0, 113, 113, + 113, 0, 120, 120, 120, 120, 0, 97, 0, 0, + 97, 120, 0, 0, 0, 96, 0, 120, 120, 120, + 120, 0, 0, 0, 97, 97, 0, 120, 120, 97, + 120, 120, 120, 120, 120, 120, 120, 0, 0, 120, + 0, 0, 120, 120, 120, 98, 98, 98, 98, 0, + 95, 0, 0, 95, 98, 0, 0, 0, 0, 97, + 98, 98, 98, 98, 0, 0, 0, 95, 95, 0, + 98, 98, 95, 98, 98, 98, 98, 98, 98, 98, + 0, 0, 0, 99, 99, 99, 99, 0, 83, 0, + 0, 83, 99, 0, 0, 0, 0, 0, 99, 99, + 99, 99, 95, 0, 0, 83, 83, 0, 99, 99, + 83, 99, 99, 99, 99, 99, 99, 99, 0, 0, + 0, 100, 100, 100, 100, 0, 84, 0, 0, 84, + 100, 0, 0, 0, 0, 0, 100, 100, 100, 100, + 83, 0, 0, 84, 84, 0, 100, 100, 84, 100, + 100, 100, 100, 100, 100, 100, 0, 0, 0, 0, + 0, 0, 86, 0, 0, 86, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 84, 86, + 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 96, 96, 96, 96, 0, 146, + 0, 0, 146, 96, 0, 0, 0, 0, 0, 96, + 96, 96, 96, 0, 86, 0, 146, 146, 0, 96, + 96, 146, 96, 96, 96, 96, 96, 96, 96, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 97, 97, + 97, 97, 0, 145, 0, 0, 145, 97, 0, 0, + 0, 146, 0, 97, 97, 97, 97, 0, 0, 0, + 145, 145, 0, 97, 97, 145, 97, 97, 97, 97, + 97, 97, 97, 0, 0, 0, 0, 0, 0, 0, + 0, 95, 95, 95, 95, 0, 134, 0, 0, 134, + 95, 0, 0, 0, 0, 145, 95, 95, 95, 95, + 0, 0, 0, 134, 134, 0, 95, 95, 134, 95, + 95, 95, 95, 95, 95, 95, 0, 0, 0, 83, + 83, 83, 83, 0, 105, 0, 0, 105, 83, 0, + 0, 0, 0, 0, 83, 83, 83, 83, 134, 0, + 0, 105, 105, 0, 83, 83, 105, 83, 83, 83, + 83, 83, 83, 83, 0, 0, 0, 84, 84, 84, + 84, 0, 89, 0, 0, 89, 84, 0, 0, 0, + 0, 0, 84, 84, 84, 84, 105, 0, 0, 89, + 89, 0, 84, 84, 89, 84, 84, 84, 84, 84, + 84, 0, 0, 86, 86, 86, 86, 0, 90, 0, + 0, 90, 86, 0, 0, 0, 0, 0, 86, 86, + 0, 0, 0, 0, 89, 90, 90, 0, 86, 86, + 90, 86, 86, 86, 86, 86, 86, 0, 0, 0, + 146, 146, 146, 146, 0, 92, 0, 0, 92, 146, + 0, 0, 0, 0, 0, 146, 146, 0, 0, 0, + 90, 0, 92, 92, 0, 146, 146, 92, 146, 146, + 146, 146, 146, 0, 0, 0, 167, 0, 0, 0, + 0, 0, 0, 0, 145, 145, 145, 145, 0, 91, + 156, 0, 91, 145, 0, 0, 0, 92, 0, 145, + 145, 0, 0, 0, 0, 0, 91, 91, 149, 145, + 145, 91, 145, 145, 145, 145, 145, 0, 167, 0, + 0, 283, 0, 0, 0, 0, 156, 134, 134, 134, + 134, 0, 0, 0, 0, 0, 134, 0, 0, 0, + 0, 91, 134, 134, 0, 0, 0, 0, 0, 0, + 149, 0, 134, 134, 167, 134, 134, 134, 134, 134, + 0, 0, 0, 0, 0, 105, 105, 105, 105, 0, + 0, 0, 0, 0, 105, 0, 0, 0, 0, 0, + 105, 105, 0, 0, 0, 156, 149, 0, 0, 0, + 105, 105, 0, 105, 105, 105, 105, 105, 0, 0, + 0, 0, 0, 89, 89, 89, 89, 0, 0, 0, + 0, 0, 89, 167, 0, 0, 0, 0, 90, 90, + 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, + 103, 89, 89, 89, 89, 89, 111, 90, 119, 90, + 90, 90, 90, 90, 0, 149, 0, 0, 90, 167, + 0, 0, 0, 0, 0, 90, 90, 90, 90, 0, + 0, 0, 0, 0, 90, 90, 0, 90, 90, 90, + 90, 0, 151, 152, 153, 154, 92, 92, 92, 92, + 0, 149, 0, 0, 0, 92, 157, 158, 159, 160, + 161, 162, 0, 0, 163, 0, 0, 164, 165, 166, + 111, 92, 92, 0, 92, 92, 92, 0, 150, 0, + 0, 0, 0, 0, 151, 152, 153, 154, 0, 0, + 91, 91, 91, 91, 0, 0, 0, 155, 157, 158, + 159, 160, 161, 162, 0, 0, 163, 0, 0, 164, + 165, 166, 0, 0, 150, 91, 91, 0, 91, 0, + 151, 152, 153, 154, 0, 0, 0, 0, 0, 234, + 0, 0, 0, 155, 157, 158, 159, 160, 161, 162, + 94, 0, 163, 0, 0, 164, 165, 166, 104, 0, + 0, 0, 109, 263, 0, 118, 0, 0, 0, 0, + 0, 0, 125, 126, 127, 128, 129, 0, 0, 132, + 133, 0, 0, 150, 0, 0, 140, 0, 0, 151, + 152, 153, 154, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 157, 158, 159, 160, 161, 162, 0, + 0, 163, 0, 183, 164, 165, 166, 0, 0, 0, + 0, 0, 0, 0, 0, 151, 152, 153, 154, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 158, 159, 160, 161, 162, 0, 0, 163, 0, 0, + 164, 165, 166, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 78, - 78, 78, 78, 0, 0, 0, 0, 0, 78, 0, - 0, 0, 0, 0, 0, 79, 79, 79, 79, 0, - 0, 78, 78, 0, 79, 78, 78, 78, 78, 78, - 0, 0, 91, 0, 0, 0, 0, 79, 79, 0, - 104, 79, 79, 79, 79, 111, 113, 0, 0, 0, - 0, 0, 125, 126, 127, 128, 129, 130, 0, 0, - 133, 134, 0, 0, 0, 0, 0, 0, 0, 0, + 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, + 227, 228, 229, 230, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 244, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 81, 81, 81, 81, 0, 0, 0, 0, 0, 81, - 0, 0, 183, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 81, 81, 0, 0, 81, 81, 81, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 215, 0, 0, 0, 0, - 0, 0, 0, 223, 224, 225, 226, 227, 228, 229, - 230, 231, 232, 233, 234, 235, 236, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 296, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 297, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 313, + 0, 0, 0, 312, }; dEXT short yycheck[] = { 13, - 59, 13, 91, 17, 59, 59, 36, 93, 182, 194, - 41, 123, 59, 44, 257, 41, 59, 40, 44, 33, - 34, 35, 36, 91, 40, 88, 59, 58, 59, 43, - 41, 40, 63, 45, 123, 41, 50, 63, 91, 41, - 257, 41, 41, 40, 56, 40, 59, 40, 60, 41, - 257, 41, 40, 116, 41, 123, 188, 59, 190, 40, - 59, 91, 93, 41, 78, 91, 41, 36, 91, 59, - 123, 40, 59, 41, 278, 41, 123, 41, 92, 294, - 295, 95, 94, 97, 96, 99, 98, 101, 100, 41, - 102, 59, 41, 123, 106, 41, 40, 123, 41, 41, - 123, 123, 41, 44, 59, 44, 0, 123, 276, 277, - 123, 44, 40, 287, 123, 300, 179, 59, 303, 58, - 59, 184, 59, 59, 260, 59, 123, 141, 123, 123, - 257, 40, 144, 145, 146, 147, 148, 149, 150, 33, - 40, 40, 36, 37, 38, 257, 40, 295, 42, 43, - 335, 45, 41, 6, 93, 8, 168, 169, 170, 171, - 172, 173, 174, 125, 178, 59, 298, 299, 91, 41, - 64, 185, 41, 305, 0, 59, 91, 125, 31, 32, - 40, 93, 59, 41, 36, 40, 198, 125, 83, 59, - 125, 93, 204, 205, 206, 125, 328, 91, 125, 211, - 125, 41, 41, 257, 123, 91, 93, 33, 294, 295, - 36, 37, 38, 41, 40, 59, 42, 43, 41, 45, - 41, 59, 93, 59, 313, 237, 59, 239, 258, 123, - 41, 125, 126, 59, 326, 294, 295, 123, 64, 294, - 295, 272, 273, 274, 275, 259, 13, 261, 269, 263, - 264, 294, 295, 267, -1, 281, 270, 269, 93, 285, - 286, 287, 288, 294, 295, 91, 93, 298, 0, -1, - 282, 123, 298, 299, 300, 301, 302, 93, 304, 305, - -1, -1, 308, 294, 295, 311, 312, 313, 294, 295, - 302, -1, 306, -1, 294, 295, -1, 123, -1, 125, - 126, 33, 294, 295, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 326, -1, 294, 295, 332, 294, - 295, -1, 336, 272, 273, 274, 275, 59, 294, 295, - 294, 295, 64, 272, 273, 274, 275, -1, -1, 294, - 295, -1, 294, 295, -1, 294, 295, -1, 294, 295, - -1, 294, 295, 294, 295, 294, 295, 294, 295, 91, - 294, 295, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, - 274, 275, 294, 295, -1, 279, 280, -1, 282, 283, - 284, 123, 294, 295, 126, 289, 290, 291, 292, 293, - 41, 287, 296, 297, 91, 257, -1, 294, 295, 303, - 262, -1, -1, 307, -1, 309, 310, -1, 59, 305, - -1, -1, 308, 294, 295, 311, 312, 313, -1, -1, - 256, 257, 258, 259, 260, 261, 123, 263, 264, 265, - 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, - -1, -1, 93, 279, 280, -1, 282, 283, 284, 294, - 295, -1, -1, 289, 290, 291, 292, 293, -1, -1, - 296, 297, 91, -1, -1, -1, -1, 303, 294, 295, - -1, 307, 91, 309, 310, 26, 33, -1, -1, 36, - 37, 38, -1, 40, 41, 42, 43, 44, 45, 48, - 49, 42, -1, -1, 123, -1, 47, -1, 49, -1, - -1, 58, 59, -1, 123, 125, 63, 64, -1, -1, - 61, 62, 63, 64, 256, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, -1, 269, -1, 88, - 272, 273, 274, 275, 91, -1, 93, 279, 280, -1, - 282, 283, 284, 63, -1, -1, -1, 289, 290, 291, - 292, 293, 91, -1, 296, 297, 107, 116, 266, 267, - 268, 303, 270, 271, 123, 307, 123, 309, 310, 126, - 33, 91, -1, 36, 37, 38, -1, 40, 41, 42, - 43, 44, 45, -1, 123, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, 58, 59, -1, -1, -1, - 63, 64, -1, 123, 301, 302, -1, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - 179, 272, 273, 274, 275, 184, -1, -1, -1, 33, - 93, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, 294, 295, -1, 266, 267, 268, -1, - 270, 271, -1, -1, -1, 59, 285, 286, 287, 288, - 64, -1, -1, 126, -1, -1, 285, 286, 287, 288, - 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, - -1, -1, 311, 312, 313, 304, 305, 91, -1, 308, - -1, -1, 311, 312, 313, -1, -1, -1, -1, -1, + 59, 41, 36, 36, 44, 93, 36, 59, 91, 86, + 40, 325, 91, 41, 257, 191, 40, 43, 58, 59, + 182, 257, 59, 63, 41, 51, 41, 59, 41, 257, + 41, 91, 46, 41, 322, 323, 91, 59, 41, 327, + 123, 41, 356, 57, 123, 297, 298, 61, 41, 44, + 40, 59, 40, 93, 40, 343, 59, 278, 91, 347, + 123, 41, 41, 123, 41, 91, 59, 91, 123, 40, + 97, 98, 99, 100, 101, 102, 59, 41, 0, 59, + 59, 59, 59, 59, 40, 59, 123, 59, 114, 123, + 123, 123, 106, 107, 270, 59, 122, 276, 277, 123, + 59, 41, 272, 273, 274, 275, 40, 40, 44, 40, + 260, 33, 40, 93, 36, 37, 38, 123, 40, 59, + 42, 43, 257, 45, 286, 93, 302, 297, 298, 143, + 144, 145, 146, 147, 148, 149, 40, 59, 40, 266, + 267, 268, 64, 270, 271, 41, 40, 91, 257, 36, + 93, 41, 0, 167, 168, 169, 170, 171, 172, 173, + 125, 93, 125, 93, 91, 192, 298, 40, 182, 91, + 346, 41, 186, 187, 41, 189, 41, 191, 93, 41, + 93, 41, 91, 40, 198, 33, 200, 201, 36, 37, + 38, 205, 40, 59, 42, 43, 41, 45, 257, 125, + 125, 123, 125, 125, 126, 125, 59, 123, 41, 297, + 298, 59, 41, 125, 123, 41, 64, 231, 59, 233, + 41, 41, 248, 257, 44, 258, 309, 253, 262, 312, + 313, 314, 272, 273, 274, 275, 41, 41, 58, 59, + 44, 281, 40, 91, 123, 297, 298, 287, 288, 41, + 290, 123, 44, 41, 58, 59, 333, 297, 298, 314, + 300, 301, 302, 303, 304, 305, 296, 281, 0, 297, + 298, 63, 286, 93, 41, 123, 59, 125, 126, 41, + 297, 298, 297, 298, 297, 298, 297, 298, 59, 93, + 304, 41, 272, 273, 274, 275, 59, 297, 298, 91, + 41, 33, 297, 298, 36, 37, 38, 8, 40, 32, + 42, 43, 144, 45, 297, 298, 13, 297, 298, 297, + 298, 297, 298, 297, 298, 297, 298, 59, 342, 297, + 298, 123, 64, 342, 256, 257, 258, 259, 260, 261, + 189, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 272, 273, 274, 275, 297, 298, 304, 279, 280, 91, + 282, 283, 284, 285, 286, 297, 298, 297, 298, 291, + 292, 293, 294, 295, 296, 91, 96, 299, 41, 41, + 289, 44, 297, 298, 297, 298, 308, -1, 310, 311, + -1, 123, -1, -1, 126, 58, 59, 306, -1, -1, + 309, 63, -1, 312, 313, 314, -1, 123, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 272, 273, 274, 275, -1, 91, + 93, 279, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + -1, 299, 272, 273, 274, 275, -1, -1, -1, 91, + 308, 123, 310, 311, -1, -1, -1, -1, 272, 273, + 274, 275, 91, -1, 91, -1, 33, 297, 298, 36, + 37, 38, -1, 40, 41, 42, 43, 44, 45, 281, + -1, 123, -1, 297, 298, 287, 288, 289, 290, -1, + -1, 58, 59, -1, 123, 122, 63, 64, 300, 301, + 302, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, 256, 257, 258, 259, 260, 261, + -1, 263, 264, 265, 91, -1, 93, 269, -1, -1, + 272, 273, 274, 275, -1, -1, -1, 279, 280, -1, + 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, + 292, 293, 294, 295, 296, 41, 123, 299, 44, 126, + -1, -1, 91, 289, 290, -1, 308, 33, 310, 311, + 36, 37, 38, 59, 40, 41, 42, 43, 44, 45, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, + -1, -1, 58, 59, 123, -1, -1, 63, 64, 272, + 273, 274, 275, -1, -1, -1, -1, 93, -1, 281, + -1, -1, -1, -1, -1, 287, 288, 289, 290, -1, + -1, 248, -1, -1, 297, 298, 253, 93, 300, 301, + 302, 303, 304, 305, 306, -1, 41, 309, -1, 44, + 312, 313, 314, -1, -1, 287, 288, 289, 290, -1, + -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, + 126, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, 93, -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - -1, -1, 269, -1, -1, 272, 273, 274, 275, 123, - -1, -1, 126, 280, 281, 282, 283, 284, 285, 286, + -1, -1, 269, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, - 297, 298, 299, 300, 301, 302, 303, 304, 305, -1, - 307, 308, 309, 310, 311, 312, 313, 91, -1, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, 308, - -1, -1, 311, 312, 313, -1, -1, -1, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, 123, - -1, 311, 312, 313, 257, 258, 259, 260, 261, -1, - 263, 264, 265, -1, -1, -1, 269, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, 280, 281, 282, - 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, - 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, - 303, 304, 305, -1, 307, 308, 309, 310, 311, 312, - 313, 91, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, -1, 41, -1, 269, 44, -1, 272, 273, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + -1, 308, 309, 310, 311, 312, 313, 314, 41, -1, + -1, 44, -1, 41, -1, -1, 44, -1, 287, 288, + 289, 290, -1, -1, -1, 58, 59, -1, -1, -1, + 58, 59, -1, -1, -1, 63, 305, 306, -1, 125, + 309, -1, -1, 312, 313, 314, 272, 273, 274, 275, + -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, + 93, -1, 125, 269, -1, 93, 272, 273, 274, 275, + -1, 297, -1, -1, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 33, + -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, -1, -1, -1, 59, 281, -1, -1, -1, + 64, -1, 287, 288, 289, 290, -1, -1, -1, -1, + -1, -1, 297, 298, 13, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, 33, -1, 91, 36, 37, + 38, -1, 40, -1, 42, 43, 26, 45, -1, -1, + 266, 267, 268, 42, 270, 271, 45, -1, -1, -1, + -1, 59, -1, 43, 44, -1, 64, -1, -1, 123, + 50, -1, 126, 266, 267, 268, -1, 270, 271, -1, + -1, -1, 62, 63, 64, 65, -1, -1, -1, -1, + -1, 33, 81, 91, 36, 37, 38, -1, 40, -1, + 42, 43, -1, 45, -1, -1, 95, -1, -1, 272, + 273, 274, 275, -1, 272, 273, 274, 275, -1, -1, + -1, -1, 64, 281, -1, 123, -1, 107, 126, 287, + 288, 289, 290, -1, 297, 298, -1, 300, -1, 297, + 298, -1, 300, 301, 302, 303, 304, 305, 306, 91, + -1, 309, 141, -1, 33, -1, -1, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 123, -1, -1, 126, 64, -1, -1, -1, 178, + -1, -1, -1, -1, -1, -1, 185, -1, -1, -1, + -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, -1, -1, 269, -1, -1, 272, 273, 274, 275, -1, -1, -1, 279, 280, -1, 282, 283, - 284, 59, -1, 123, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, -1, -1, -1, -1, -1, 303, - 25, 26, -1, 307, 33, 309, 310, 36, 37, 38, - -1, 40, 37, 42, 43, 93, 45, 42, 43, -1, - -1, -1, 47, -1, 49, 272, 273, 274, 275, -1, - 59, -1, -1, -1, -1, 64, 61, 62, 63, 64, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - -1, -1, -1, 287, 288, -1, -1, -1, -1, -1, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, 123, 299, -1, 126, -1, -1, + -1, -1, -1, -1, 308, -1, 310, 311, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, -1, + 91, 269, -1, -1, 272, 273, 274, 275, -1, -1, + -1, 279, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, 91, + -1, 299, 123, -1, -1, -1, -1, -1, -1, -1, + 308, -1, 310, 311, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, -1, 33, -1, 269, 36, 37, + 38, 123, 40, 41, 42, 43, -1, 45, 280, -1, + 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, + 292, 293, 294, 295, 296, -1, 64, 299, -1, -1, + -1, -1, -1, -1, -1, -1, 308, -1, 310, 311, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 91, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, 126, 64, + 299, -1, 299, 300, 301, -1, 303, -1, -1, 308, + -1, 310, 311, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 33, -1, 91, 36, 37, 38, + -1, 40, 329, 42, 43, -1, 45, -1, -1, 336, + -1, -1, -1, 340, -1, -1, 287, 288, 289, 290, + 59, -1, -1, -1, -1, 64, 353, 354, 123, -1, + -1, 126, -1, 304, 305, 306, -1, -1, 309, -1, + -1, 312, 313, 314, -1, 287, -1, 289, 290, -1, 33, -1, 91, 36, 37, 38, -1, 40, -1, 42, - 43, 305, 45, -1, 308, -1, -1, 311, 312, 313, - -1, -1, 107, -1, -1, -1, -1, -1, -1, -1, - -1, 64, -1, -1, 123, -1, -1, 126, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 33, -1, 91, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 167, -1, -1, -1, -1, 64, -1, -1, - 123, -1, -1, 126, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 91, -1, -1, -1, -1, 33, - -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, 272, 273, 274, 275, -1, -1, - -1, -1, -1, -1, -1, 59, 123, -1, -1, 126, - 64, -1, -1, -1, -1, -1, 294, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 256, 257, 258, - 259, 260, 261, -1, 263, 264, 265, 91, -1, -1, - 269, -1, -1, 272, 273, 274, 275, -1, -1, -1, - 279, 280, -1, 282, 283, 284, -1, -1, -1, -1, - 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, - 91, 63, 126, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, 257, 258, 259, 260, 261, 262, - 263, 264, 265, -1, -1, -1, 269, -1, -1, 91, - 41, -1, 123, -1, -1, -1, -1, 280, -1, 282, - 283, 284, -1, -1, -1, -1, 289, 290, 291, 292, - 293, -1, 63, 296, 297, -1, -1, -1, -1, -1, - 303, 123, -1, -1, 307, -1, 309, 310, -1, -1, - 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - 91, -1, 269, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 280, -1, 282, 283, 284, -1, -1, - -1, -1, 289, 290, 291, 292, 293, -1, -1, 296, - 297, 41, 123, -1, 44, -1, 303, -1, -1, -1, - 307, -1, 309, 310, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 257, 258, 259, 260, 261, 91, 263, - 264, 265, -1, 33, -1, 269, 36, 37, 38, -1, + 43, -1, 45, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, + -1, 64, -1, -1, -1, -1, -1, 126, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 91, 33, + 93, 269, 36, 37, 38, -1, 40, 41, 42, 43, + -1, 45, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + 64, 299, -1, 126, -1, -1, -1, -1, -1, -1, + 308, -1, 310, 311, -1, -1, -1, -1, 41, -1, + -1, 44, 257, 258, 259, 260, 261, 91, 263, 264, + 265, -1, -1, -1, 269, 58, 59, -1, -1, -1, + 63, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, + 295, 296, 126, -1, 299, -1, -1, -1, -1, -1, + 93, -1, -1, 308, 41, 310, 311, 44, 257, 258, + 259, 260, 261, -1, 263, 264, 265, -1, -1, -1, + 269, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, -1, -1, + 299, -1, -1, -1, -1, -1, 93, -1, -1, 308, + -1, 310, 311, -1, 257, 258, 259, 260, 261, -1, + 263, 264, 265, -1, 33, -1, 269, 36, 37, 38, + -1, 40, 41, 42, 43, -1, 45, 280, -1, 282, + 283, 284, 285, 286, -1, -1, -1, -1, 291, 292, + 293, 294, 295, 296, -1, 64, 299, -1, -1, -1, + -1, -1, -1, -1, -1, 308, -1, 310, 311, -1, + -1, -1, -1, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, 33, -1, 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, 280, -1, 282, 283, - 284, -1, -1, 93, -1, 289, 290, 291, 292, 293, - 123, -1, 296, 297, 64, -1, -1, -1, -1, 303, - -1, -1, -1, 307, -1, 309, 310, -1, -1, -1, - -1, -1, -1, -1, 285, -1, 287, 288, -1, 33, - -1, 91, 36, 37, 38, -1, 40, 41, 42, 43, - -1, 45, -1, 304, 305, -1, -1, 308, -1, 281, - 311, 312, 313, 285, 286, 287, 288, -1, -1, -1, - 64, -1, -1, 123, -1, -1, 126, 299, 300, 301, - 302, -1, 304, 305, -1, -1, 308, -1, -1, 311, - 312, 313, -1, -1, -1, 33, -1, 91, 36, 37, - 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, - 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, - -1, -1, -1, -1, -1, -1, 64, 298, 299, 300, - 301, 302, 126, 304, 305, -1, -1, 308, -1, -1, - 311, 312, 313, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 91, -1, 93, -1, -1, 33, -1, - -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, 287, 288, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, 126, 64, - -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, - 313, -1, -1, -1, 294, 295, -1, 257, 258, 259, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, 64, 299, -1, 126, -1, -1, + -1, -1, -1, -1, 308, -1, 310, 311, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, 33, + -1, 91, 36, 37, 38, 288, 40, 41, 42, 43, + -1, 45, -1, -1, 297, 298, -1, 300, 301, 302, + 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, + 64, -1, -1, -1, -1, -1, 126, -1, -1, -1, + -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, 33, -1, 91, 36, 37, + 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, + 297, 298, -1, 300, 301, 302, 303, 304, -1, -1, + -1, -1, -1, -1, -1, -1, 64, -1, -1, -1, + -1, -1, 126, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 91, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 280, -1, 282, 283, 284, 285, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 295, 296, 126, 64, + 299, -1, -1, -1, -1, -1, -1, -1, -1, 308, + -1, 310, 311, -1, -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, 265, 91, -1, -1, 269, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, - 290, 291, 292, 293, -1, -1, 296, 297, -1, -1, - -1, 126, -1, 303, -1, -1, -1, 307, -1, 309, - 310, -1, -1, 257, 258, 259, 260, 261, -1, 263, - 264, 265, -1, 91, -1, 269, -1, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, + 280, -1, 282, 283, 284, 285, 286, 58, 59, -1, + -1, 291, 292, 293, 294, 295, 296, 91, -1, 299, + -1, 126, -1, -1, -1, -1, 41, -1, 308, 44, + 310, 311, -1, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 93, 58, 59, 269, -1, -1, 63, 123, -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, - 284, -1, -1, -1, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, 91, 123, -1, -1, -1, 303, - -1, 41, -1, 307, 44, 309, 310, -1, -1, 257, - 258, 259, 260, 261, -1, 263, 264, 265, 58, 59, - -1, 269, -1, 63, -1, -1, 123, -1, -1, -1, - -1, -1, 280, -1, 282, 283, 284, -1, -1, -1, - -1, 289, 290, 291, 292, 293, -1, -1, 296, 297, - -1, 41, -1, 93, 44, 303, -1, -1, -1, 307, - -1, 309, 310, -1, -1, -1, -1, -1, 58, 59, - -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, - 265, -1, 33, -1, 269, 36, 37, 38, -1, 40, - 41, 42, 43, -1, 45, 280, -1, 282, 283, 284, - -1, -1, -1, 93, 289, 290, 291, 292, 293, -1, - -1, 296, 297, 64, -1, -1, -1, -1, 303, -1, - -1, -1, 307, -1, 309, 310, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, - 91, 36, 37, 38, -1, 40, 41, 42, 43, -1, - 45, -1, -1, -1, -1, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, -1, -1, -1, 64, - -1, -1, 300, 301, 302, 126, 304, 305, -1, -1, - 308, -1, -1, 311, 312, 313, -1, -1, 285, 286, - 287, 288, -1, -1, 33, -1, 91, 36, 37, 38, - -1, 40, 41, 42, 43, 302, 45, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, - -1, 126, 272, 273, 274, 275, -1, -1, -1, -1, - -1, 281, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 91, -1, 294, 295, -1, 33, 298, 299, - 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, 126, 64, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 294, 295, 257, 258, 259, 260, - 261, -1, 263, 264, 265, 91, -1, -1, 269, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, - -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, - 291, 292, 293, -1, -1, 296, 297, -1, -1, -1, - 126, -1, 303, -1, 41, -1, 307, 44, 309, 310, - -1, -1, 257, 258, 259, 260, 261, -1, 263, 264, - 265, 58, 59, -1, 269, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - -1, -1, -1, -1, 289, 290, 291, 292, 293, -1, - -1, 296, 297, -1, 91, -1, 93, -1, 303, -1, - 41, -1, 307, 44, 309, 310, -1, -1, 257, 258, - 259, 260, 261, -1, 263, 264, 265, 58, 59, -1, - 269, -1, 63, -1, -1, -1, 123, -1, -1, -1, - -1, 280, -1, 282, 283, 284, -1, -1, -1, -1, - 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, - 91, -1, 93, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, - -1, 33, 123, 269, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 280, -1, 282, 283, 284, -1, - -1, -1, -1, 289, 290, 291, 292, 293, -1, -1, - 296, 297, 64, -1, -1, -1, -1, 303, -1, -1, - -1, 307, -1, 309, 310, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, 91, - -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 126, 272, 273, 274, 275, -1, - 91, -1, 93, -1, 281, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, -1, -1, 294, 295, -1, - -1, 298, 299, 300, 301, 302, -1, 304, 305, -1, - -1, 308, 123, -1, 311, 312, 313, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, 272, 273, 274, 275, -1, -1, -1, 58, 59, - 281, -1, -1, 63, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, -1, 41, 308, -1, 44, - 311, 312, 313, 93, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 123, -1, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, 91, 269, 93, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, - 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, - 292, 293, -1, -1, 296, 297, -1, -1, -1, -1, - -1, 303, -1, -1, -1, 307, -1, 309, 310, -1, + 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, -1, 299, 91, -1, 93, -1, + -1, -1, -1, -1, 308, 41, 310, 311, 44, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, -1, + -1, 269, 58, 59, -1, -1, -1, 63, 123, -1, + -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + -1, 299, -1, -1, -1, 91, -1, 93, -1, -1, + 308, -1, 310, 311, -1, -1, -1, -1, 41, -1, + -1, 44, 257, 258, 259, 260, 261, -1, 263, 264, + 265, -1, -1, -1, 269, 58, 59, 123, -1, -1, + 63, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, + 295, 296, -1, -1, 299, -1, 41, -1, 91, 44, + 93, -1, -1, 308, -1, 310, 311, -1, -1, -1, + -1, -1, -1, 58, 59, 289, 290, -1, 63, -1, -1, 272, 273, 274, 275, -1, -1, -1, -1, -1, - 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, 41, -1, 308, 44, -1, - 311, 312, 313, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, + 123, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, -1, -1, -1, -1, 297, 298, 93, -1, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, -1, -1, 123, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 91, -1, 93, -1, 272, 273, 274, 275, + -1, 41, -1, -1, 44, 281, -1, -1, -1, -1, + -1, 287, 288, 289, 290, -1, -1, -1, 58, 59, + -1, 297, 298, 63, 300, 301, 302, 303, 304, 305, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, 93, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, -1, 58, - 59, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, 123, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 93, -1, -1, 272, 273, 274, - 275, -1, -1, -1, -1, -1, 281, -1, -1, -1, - 285, 286, 287, 288, -1, -1, -1, 41, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, - 305, -1, -1, 308, 58, 59, 311, 312, 313, 63, + -1, -1, -1, 93, -1, -1, -1, -1, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + -1, -1, -1, 123, 297, 298, -1, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, -1, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, -1, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 91, -1, 93, -1, -1, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, -1, -1, 123, -1, -1, -1, 297, 298, + -1, 300, 301, 302, 303, 304, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, -1, -1, -1, 91, -1, 93, - -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, + -1, -1, 272, 273, 274, 275, -1, 41, -1, -1, + -1, 281, -1, -1, -1, -1, -1, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, 91, -1, 93, + 41, -1, -1, 44, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 91, -1, 93, -1, -1, 41, -1, -1, 44, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 58, 59, 281, -1, -1, 63, 285, - 286, 287, 288, 123, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - 41, -1, 308, 44, -1, 311, 312, 313, 93, -1, - -1, -1, -1, 272, 273, 274, 275, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 294, 295, -1, 123, 298, - -1, -1, -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, + -1, -1, 93, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, 123, -1, -1, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, + -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, + 93, -1, -1, -1, -1, -1, -1, -1, 58, 59, + -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, 91, -1, 93, -1, 281, -1, -1, - -1, 285, 286, 287, 288, 41, -1, -1, 44, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 58, 59, 308, 123, -1, 311, 312, 313, - -1, -1, 272, 273, 274, 275, -1, -1, -1, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, 93, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, -1, - -1, 311, 312, 313, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 272, 273, 274, - 275, -1, -1, -1, 58, 59, 281, -1, -1, 63, - 285, 286, 287, 288, -1, -1, -1, -1, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, - 305, 41, -1, 308, 44, -1, 311, 312, 313, 93, - -1, 272, 273, 274, 275, -1, -1, -1, 58, 59, - 281, -1, -1, 63, 285, 286, 287, 288, -1, -1, - -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 305, -1, -1, 308, -1, -1, - 311, 312, 313, 93, 272, 273, 274, 275, -1, 58, - -1, -1, -1, 281, 63, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, - 308, -1, 91, 311, 312, 313, -1, -1, -1, -1, + 123, -1, -1, -1, -1, 41, -1, -1, 44, -1, + -1, 91, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, -1, 123, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 93, 294, 295, - -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 123, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 41, 93, - -1, 44, -1, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, -1, -1, 58, 59, 281, -1, -1, - 63, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 41, -1, 308, 44, -1, 311, 312, 313, - 93, -1, 272, 273, 274, 275, -1, -1, -1, 58, - 59, 281, -1, -1, 63, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, -1, 298, 299, - 300, 301, 302, 41, 304, 305, 44, -1, 308, -1, - -1, 311, 312, 313, 93, -1, -1, -1, -1, -1, - 58, 59, 281, -1, -1, 63, 285, 286, 287, 288, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 298, - 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, - -1, -1, 311, 312, 313, 93, 272, 273, 274, 275, - -1, -1, -1, -1, -1, 281, -1, -1, -1, 285, - 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - -1, -1, 308, -1, -1, 311, 312, 313, 272, 273, - 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, - -1, 285, 286, 287, 288, 41, -1, -1, 44, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, 58, 59, 308, -1, -1, 311, 312, 313, + -1, -1, -1, -1, -1, -1, -1, -1, 272, 273, + 274, 275, -1, 123, -1, -1, -1, 281, -1, -1, + -1, -1, -1, 287, 288, 289, 290, 93, -1, -1, + -1, -1, -1, 297, 298, -1, 300, 301, 302, 303, + 304, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, 272, 273, 274, 275, -1, 41, 123, -1, 44, + 281, 272, 273, 274, 275, -1, 287, 288, 289, 290, + 281, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, 297, 298, 309, 300, + 301, 312, 313, 314, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, - -1, -1, 285, 286, 287, 288, -1, 93, -1, -1, - -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, - -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, - 313, -1, -1, 272, 273, 274, 275, -1, -1, -1, - -1, -1, 281, -1, -1, -1, 285, 286, 287, 288, - -1, -1, -1, -1, -1, 294, 295, -1, -1, 298, - 299, 300, 301, 302, 41, 304, 305, 44, -1, 308, - -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, - -1, 58, 59, 281, -1, -1, 63, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, - 308, -1, -1, -1, -1, -1, 93, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 93, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 93, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 294, 295, - -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 93, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 93, -1, -1, 281, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, -1, -1, 294, 295, -1, - -1, 298, 299, 300, 301, 302, 41, 304, 305, 44, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 58, 59, 281, -1, -1, 63, 285, - 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - -1, -1, 272, 273, 274, 275, -1, -1, 93, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, -1, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 272, 273, - 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, - -1, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, - 304, 305, -1, -1, 272, 273, 274, 275, -1, -1, - -1, -1, -1, 281, -1, -1, -1, 285, 286, 287, - 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, -1, 304, 305, -1, -1, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, -1, -1, 285, 286, 287, 288, 41, -1, -1, - 44, -1, 294, 295, -1, -1, 298, 299, 300, 301, - 302, -1, 304, 305, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 273, 274, 275, -1, 41, -1, -1, 44, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + -1, 58, 59, -1, 297, 298, 63, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, 272, 273, 274, 275, -1, 41, -1, -1, + 44, 281, -1, -1, -1, -1, 93, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, -1, 272, 273, 274, 275, + -1, 41, -1, -1, 44, 281, -1, -1, -1, 93, + -1, 287, 288, 289, 290, -1, -1, -1, 58, 59, + -1, 297, 298, 63, 300, 301, 302, 303, 304, 305, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, + -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, 93, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 58, 59, 93, - -1, -1, 63, -1, -1, -1, -1, 272, 273, 274, + -1, -1, -1, -1, 93, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, + 287, 288, 289, 290, -1, -1, -1, -1, -1, -1, + 297, 298, 93, 300, 301, 302, 303, 304, 305, 306, + -1, -1, 309, -1, -1, 312, 313, 314, 272, 273, + 274, 275, -1, 41, -1, -1, 44, 281, -1, -1, + -1, -1, -1, 287, 288, 289, 290, -1, -1, -1, + 58, 59, -1, 297, 298, 63, 300, 301, 302, 303, + 304, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, 272, 273, 274, 275, -1, 41, -1, -1, + 44, 281, -1, -1, -1, 93, -1, 287, 288, 289, + 290, -1, -1, -1, 58, 59, -1, 297, 298, 63, + 300, 301, 302, 303, 304, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, 272, 273, 274, 275, -1, + 41, -1, -1, 44, 281, -1, -1, -1, -1, 93, + 287, 288, 289, 290, -1, -1, -1, 58, 59, -1, + 297, 298, 63, 300, 301, 302, 303, 304, 305, 306, + -1, -1, -1, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + 289, 290, 93, -1, -1, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, 306, -1, -1, + -1, 272, 273, 274, 275, -1, 41, -1, -1, 44, + 281, -1, -1, -1, -1, -1, 287, 288, 289, 290, + 93, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, -1, -1, -1, -1, + -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, 58, + 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, 41, + -1, -1, 44, 281, -1, -1, -1, -1, -1, 287, + 288, 289, 290, -1, 93, -1, 58, 59, -1, 297, + 298, 63, 300, 301, 302, 303, 304, 305, 306, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 272, 273, + 274, 275, -1, 41, -1, -1, 44, 281, -1, -1, + -1, 93, -1, 287, 288, 289, 290, -1, -1, -1, + 58, 59, -1, 297, 298, 63, 300, 301, 302, 303, + 304, 305, 306, -1, -1, -1, -1, -1, -1, -1, + -1, 272, 273, 274, 275, -1, 41, -1, -1, 44, + 281, -1, -1, -1, -1, 93, 287, 288, 289, 290, + -1, -1, -1, 58, 59, -1, 297, 298, 63, 300, + 301, 302, 303, 304, 305, 306, -1, -1, -1, 272, + 273, 274, 275, -1, 41, -1, -1, 44, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, 93, -1, + -1, 58, 59, -1, 297, 298, 63, 300, 301, 302, + 303, 304, 305, 306, -1, -1, -1, 272, 273, 274, + 275, -1, 41, -1, -1, 44, 281, -1, -1, -1, + -1, -1, 287, 288, 289, 290, 93, -1, -1, 58, + 59, -1, 297, 298, 63, 300, 301, 302, 303, 304, + 305, -1, -1, 272, 273, 274, 275, -1, 41, -1, + -1, 44, 281, -1, -1, -1, -1, -1, 287, 288, + -1, -1, -1, -1, 93, 58, 59, -1, 297, 298, + 63, 300, 301, 302, 303, 304, 305, -1, -1, -1, + 272, 273, 274, 275, -1, 41, -1, -1, 44, 281, + -1, -1, -1, -1, -1, 287, 288, -1, -1, -1, + 93, -1, 58, 59, -1, 297, 298, 63, 300, 301, + 302, 303, 304, -1, -1, -1, 91, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, 41, + 63, -1, 44, 281, -1, -1, -1, 93, -1, 287, + 288, -1, -1, -1, -1, -1, 58, 59, 123, 297, + 298, 63, 300, 301, 302, 303, 304, -1, 91, -1, + -1, 58, -1, -1, -1, -1, 63, 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, -1, - 285, 286, 287, 288, 41, -1, -1, 44, -1, 294, - 295, -1, 93, 298, 299, 300, 301, 302, -1, 304, - 305, 58, 59, -1, -1, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 58, 59, 93, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, - -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 58, 59, -1, -1, 93, - 63, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - 93, 63, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 41, 58, 59, 44, - -1, 93, 63, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, 58, 59, -1, -1, 281, 63, -1, - -1, 285, 286, 287, 288, -1, -1, -1, -1, -1, - 294, 295, 93, -1, 298, 299, 300, 301, 302, -1, - 304, 272, 273, 274, 275, -1, -1, -1, 93, -1, - 281, -1, -1, -1, 285, 286, -1, 288, 41, -1, - -1, 44, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 41, 58, 59, 44, -1, -1, - 63, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 58, 59, -1, 281, -1, 63, -1, 285, 286, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - 93, 298, 299, 300, 301, 302, -1, 304, 272, 273, - 274, 275, -1, -1, -1, -1, 93, 281, -1, -1, - -1, 285, 286, -1, -1, -1, -1, -1, -1, 41, - 294, 295, 44, -1, 298, 299, 300, 301, 302, 272, - 273, 274, 275, -1, -1, -1, 58, 59, 281, -1, - -1, 63, 285, 286, -1, -1, -1, -1, -1, -1, - -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, 93, -1, 285, 286, -1, -1, -1, -1, -1, - -1, -1, 294, 295, -1, -1, 298, 299, 300, 301, - 302, 272, 273, 274, 275, -1, -1, -1, -1, -1, - 281, -1, -1, -1, -1, 286, -1, 272, 273, 274, - 275, -1, -1, 294, 295, -1, 281, 298, 299, 300, - 301, 302, -1, -1, -1, -1, -1, -1, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, - 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, 93, 287, 288, -1, -1, -1, -1, -1, -1, + 123, -1, 297, 298, 91, 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 294, 295, -1, 281, 298, 299, 300, 301, 302, - -1, -1, 30, -1, -1, -1, -1, 294, 295, -1, - 38, 298, 299, 300, 301, 43, 44, -1, -1, -1, - -1, -1, 50, 51, 52, 53, 54, 55, -1, -1, - 58, 59, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, -1, 90, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 294, 295, -1, -1, 298, 299, 300, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, + 287, 288, -1, -1, -1, 63, 123, -1, -1, -1, + 297, 298, -1, 300, 301, 302, 303, 304, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, 91, -1, -1, -1, -1, 25, 26, + -1, -1, -1, -1, -1, -1, -1, -1, 297, 298, + 37, 300, 301, 302, 303, 304, 43, 44, 45, 272, + 273, 274, 275, 50, -1, 123, -1, -1, 281, 91, + -1, -1, -1, -1, -1, 62, 63, 64, 65, -1, + -1, -1, -1, -1, 297, 298, -1, 300, 301, 302, + 303, -1, 287, 288, 289, 290, 272, 273, 274, 275, + -1, 123, -1, -1, -1, 281, 301, 302, 303, 304, + 305, 306, -1, -1, 309, -1, -1, 312, 313, 314, + 107, 297, 298, -1, 300, 301, 302, -1, 281, -1, + -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, + 272, 273, 274, 275, -1, -1, -1, 300, 301, 302, + 303, 304, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, -1, -1, 281, 297, 298, -1, 300, -1, + 287, 288, 289, 290, -1, -1, -1, -1, -1, 166, + -1, -1, -1, 300, 301, 302, 303, 304, 305, 306, + 30, -1, 309, -1, -1, 312, 313, 314, 38, -1, + -1, -1, 42, 190, -1, 45, -1, -1, -1, -1, + -1, -1, 52, 53, 54, 55, 56, -1, -1, 59, + 60, -1, -1, 281, -1, -1, 66, -1, -1, 287, + 288, 289, 290, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 301, 302, 303, 304, 305, 306, -1, + -1, 309, -1, 93, 312, 313, 314, -1, -1, -1, + -1, -1, -1, -1, -1, 287, 288, 289, 290, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 143, -1, -1, -1, -1, - -1, -1, -1, 151, 152, 153, 154, 155, 156, 157, - 158, 159, 160, 161, 162, 163, 164, -1, -1, -1, + 302, 303, 304, 305, 306, -1, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 175, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, @@ -1102,16 +1015,16 @@ dEXT short yycheck[] = { 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 256, -1, + -1, -1, 252, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 284, + -1, -1, -1, 283, }; #define YYFINAL 1 #ifndef YYDEBUG #define YYDEBUG 0 #endif -#define YYMAXTOKEN 313 +#define YYMAXTOKEN 314 #if YYDEBUG dEXT char * yyname[] = { "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, @@ -1124,9 +1037,9 @@ dEXT char * yyname[] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","FUNCMETH","THING", "PMFUNC","PRIVATEREF","FUNC0SUB","UNIOPSUB","LSTOPSUB","LABEL","FORMAT","SUB", "ANONSUB","PACKAGE","USE","WHILE","UNTIL","IF","UNLESS","ELSE","ELSIF", -"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","RELOP","EQOP", -"MULOP","ADDOP","DOLSHARP","DO","LOCAL","HASHBRACK","NOAMP","OROP","ANDOP", -"NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP", +"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","UNIOP","LSTOP", +"RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","HASHBRACK","NOAMP","LOCAL","MY", +"OROP","ANDOP","NOTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP", "SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", "POSTDEC","ARROW", }; @@ -1136,6 +1049,8 @@ dEXT char * yyrule[] = { "prog : $$1 lineseq", "block : '{' remember lineseq '}'", "remember :", +"mblock : '{' mremember lineseq '}'", +"mremember :", "lineseq :", "lineseq : lineseq decl", "lineseq : lineseq line", @@ -1148,44 +1063,52 @@ dEXT char * yyrule[] = { "sideff : expr IF expr", "sideff : expr UNLESS expr", "sideff : expr WHILE expr", -"sideff : expr UNTIL expr", +"sideff : expr UNTIL iexpr", "else :", -"else : ELSE block", -"else : ELSIF '(' expr ')' block else", -"cond : IF '(' expr ')' block else", -"cond : UNLESS '(' expr ')' block else", -"cond : IF block block else", -"cond : UNLESS block block else", +"else : ELSE mblock", +"else : ELSIF '(' mexpr ')' mblock else", +"cond : IF '(' remember mexpr ')' mblock else", +"cond : UNLESS '(' remember miexpr ')' mblock else", "cont :", "cont : CONTINUE block", -"loop : label WHILE '(' texpr ')' block cont", -"loop : label UNTIL '(' expr ')' block cont", -"loop : label WHILE block block cont", -"loop : label UNTIL block block cont", -"loop : label FOR scalar '(' expr ')' block cont", -"loop : label FOR '(' expr ')' block cont", -"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", +"loop : label WHILE '(' remember mtexpr ')' mblock cont", +"loop : label UNTIL '(' remember miexpr ')' mblock cont", +"loop : label FOR MY remember my_scalar '(' mexpr ')' mblock cont", +"loop : label FOR scalar '(' remember mexpr ')' mblock cont", +"loop : label FOR '(' remember mexpr ')' mblock cont", +"loop : label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock", "loop : label block cont", "nexpr :", "nexpr : sideff", "texpr :", "texpr : expr", +"iexpr : expr", +"mexpr : expr", +"mnexpr : nexpr", +"mtexpr : texpr", +"miexpr : iexpr", "label :", "label : LABEL", "decl : format", "decl : subrout", "decl : package", "decl : use", -"format : FORMAT startsub WORD block", -"format : FORMAT startsub block", -"subrout : SUB startsub WORD proto block", -"subrout : SUB startsub WORD proto ';'", +"format : FORMAT startformsub formname block", +"formname : WORD", +"formname :", +"subrout : SUB startsub subname proto subbody", +"startsub :", +"startanonsub :", +"startformsub :", +"subname : WORD", "proto :", "proto : THING", -"startsub :", +"subbody : block", +"subbody : ';'", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", -"use : USE startsub WORD WORD listexpr ';'", +"$$2 :", +"use : USE startsub $$2 WORD WORD listexpr ';'", "expr : expr ANDOP expr", "expr : expr OROP expr", "expr : argexpr", @@ -1199,7 +1122,8 @@ dEXT char * yyrule[] = { "listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", "listop : FUNC '(' listexprcom ')'", -"listop : LSTOPSUB startsub block listexpr", +"$$3 :", +"listop : LSTOPSUB startanonsub block $$3 listexpr", "method : METHOD", "method : scalar", "term : term ASSIGNOP term", @@ -1225,14 +1149,14 @@ dEXT char * yyrule[] = { "term : term POSTDEC", "term : PREINC term", "term : PREDEC term", -"term : LOCAL term", +"term : local term", "term : '(' expr ')'", "term : '(' ')'", "term : '[' expr ']'", "term : '[' ']'", "term : HASHBRACK expr ';' '}'", "term : HASHBRACK ';' '}'", -"term : ANONSUB startsub proto block", +"term : ANONSUB startanonsub proto block", "term : scalar", "term : star '{' expr ';' '}'", "term : star", @@ -1281,6 +1205,9 @@ dEXT char * yyrule[] = { "listexprcom :", "listexprcom : expr", "listexprcom : expr ','", +"local : LOCAL", +"local : MY", +"my_scalar : scalar", "amper : '&' indirob", "scalar : '$' indirob", "ary : '@' indirob", @@ -1313,9 +1240,9 @@ dEXT int yyerrflag; dEXT int yychar; dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; -#line 571 "perly.y" +#line 626 "perly.y" /* PROGRAM */ -#line 1388 "y_tab.c" +#line 1315 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1336,15 +1263,15 @@ yydestruct(ptr) void* ptr; { struct ysv* ysave = (struct ysv*)ptr; - if (ysave->yyss) safefree((char *)ysave->yyss); - if (ysave->yyvs) safefree((char *)ysave->yyvs); + if (ysave->yyss) Safefree(ysave->yyss); + if (ysave->yyvs) Safefree(ysave->yyvs); yydebug = ysave->oldyydebug; yynerrs = ysave->oldyynerrs; yyerrflag = ysave->oldyyerrflag; yychar = ysave->oldyychar; yyval = ysave->oldyyval; yylval = ysave->oldyylval; - safefree((char *)ysave); + Safefree(ysave); } int @@ -1540,7 +1467,7 @@ yyreduce: switch (yyn) { case 1: -#line 84 "perly.y" +#line 86 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1549,38 +1476,50 @@ case 1: } break; case 2: -#line 91 "perly.y" +#line 93 "perly.y" { newPROG(yyvsp[0].opval); } break; case 3: -#line 95 "perly.y" -{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } +#line 97 "perly.y" +{ if (copline > (line_t)yyvsp[-3].ival) + copline = yyvsp[-3].ival; + yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 4: -#line 99 "perly.y" -{ yyval.ival = block_start(); } +#line 103 "perly.y" +{ yyval.ival = block_start(TRUE); } break; case 5: -#line 103 "perly.y" -{ yyval.opval = Nullop; } +#line 107 "perly.y" +{ if (copline > (line_t)yyvsp[-3].ival) + copline = yyvsp[-3].ival; + yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 6: -#line 105 "perly.y" -{ yyval.opval = yyvsp[-1].opval; } +#line 113 "perly.y" +{ yyval.ival = block_start(FALSE); } break; case 7: -#line 107 "perly.y" +#line 117 "perly.y" +{ yyval.opval = Nullop; } +break; +case 8: +#line 119 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 9: +#line 121 "perly.y" { yyval.opval = append_list(OP_LINESEQ, (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); pad_reset_pending = TRUE; if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; } break; -case 8: -#line 114 "perly.y" +case 10: +#line 128 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; -case 10: -#line 117 "perly.y" +case 12: +#line 131 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1590,467 +1529,503 @@ case 10: } expect = XSTATE; } break; -case 11: -#line 126 "perly.y" +case 13: +#line 140 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); expect = XSTATE; } break; -case 12: -#line 131 "perly.y" -{ yyval.opval = Nullop; } -break; -case 13: -#line 133 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; case 14: -#line 135 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } +#line 145 "perly.y" +{ yyval.opval = Nullop; } break; case 15: -#line 137 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } +#line 147 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 16: -#line 139 "perly.y" -{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } +#line 149 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 17: -#line 141 "perly.y" -{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} +#line 151 "perly.y" +{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 18: -#line 145 "perly.y" -{ yyval.opval = Nullop; } +#line 153 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 19: -#line 147 "perly.y" -{ yyval.opval = scope(yyvsp[0].opval); } +#line 155 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; case 20: -#line 149 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, 0, - newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); - hints |= HINT_BLOCK_SCOPE; } +#line 159 "perly.y" +{ yyval.opval = Nullop; } break; case 21: -#line 156 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 161 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } break; case 22: -#line 159 "perly.y" +#line 163 "perly.y" { copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, - invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } + yyval.opval = newSTATEOP(0, Nullch, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); + hints |= HINT_BLOCK_SCOPE; } break; case 23: -#line 163 "perly.y" -{ copline = yyvsp[-3].ival; - deprecate("if BLOCK BLOCK"); - yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 170 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; case 24: -#line 167 "perly.y" -{ copline = yyvsp[-3].ival; - deprecate("unless BLOCK BLOCK"); - yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), - scope(yyvsp[-1].opval), yyvsp[0].opval); } +#line 174 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; case 25: -#line 174 "perly.y" +#line 180 "perly.y" { yyval.opval = Nullop; } break; case 26: -#line 176 "perly.y" +#line 182 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 27: -#line 180 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 186 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 28: -#line 185 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 192 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: -#line 190 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } +#line 198 "perly.y" +{ yyval.opval = block_end(yyvsp[-6].ival, + newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 30: -#line 195 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } +#line 201 "perly.y" +{ yyval.opval = block_end(yyvsp[-4].ival, + newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP), + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 31: -#line 200 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP), - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 205 "perly.y" +{ yyval.opval = block_end(yyvsp[-4].ival, + newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 32: -#line 203 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 209 "perly.y" +{ copline = yyvsp[-9].ival; + yyval.opval = block_end(yyvsp[-7].ival, + append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval), + newSTATEOP(0, yyvsp[-10].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + scalar(yyvsp[-4].opval), + yyvsp[0].opval, scalar(yyvsp[-2].opval))))); } break; case 33: -#line 206 "perly.y" -{ copline = yyvsp[-8].ival; - yyval.opval = append_elem(OP_LINESEQ, - newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), - newSTATEOP(0, yyvsp[-9].pval, - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } -break; -case 34: -#line 213 "perly.y" +#line 217 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; -case 35: -#line 219 "perly.y" +case 34: +#line 223 "perly.y" { yyval.opval = Nullop; } break; -case 37: -#line 224 "perly.y" +case 36: +#line 228 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; +case 38: +#line 233 "perly.y" +{ yyval.opval = invert(scalar(yyvsp[0].opval)); } +break; case 39: -#line 229 "perly.y" -{ yyval.pval = Nullch; } +#line 237 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } +break; +case 40: +#line 241 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 41: -#line 234 "perly.y" -{ yyval.ival = 0; } +#line 245 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 42: -#line 236 "perly.y" -{ yyval.ival = 0; } +#line 249 "perly.y" +{ yyval.opval = yyvsp[0].opval; intro_my(); } break; case 43: -#line 238 "perly.y" -{ yyval.ival = 0; } -break; -case 44: -#line 240 "perly.y" -{ yyval.ival = 0; } +#line 253 "perly.y" +{ yyval.pval = Nullch; } break; case 45: -#line 244 "perly.y" -{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +#line 258 "perly.y" +{ yyval.ival = 0; } break; case 46: -#line 246 "perly.y" -{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } +#line 260 "perly.y" +{ yyval.ival = 0; } break; case 47: -#line 250 "perly.y" -{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } +#line 262 "perly.y" +{ yyval.ival = 0; } break; case 48: -#line 252 "perly.y" -{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; } +#line 264 "perly.y" +{ yyval.ival = 0; } break; case 49: -#line 256 "perly.y" -{ yyval.opval = Nullop; } +#line 268 "perly.y" +{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 50: +#line 271 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 51: -#line 261 "perly.y" -{ yyval.ival = start_subparse(); } +#line 272 "perly.y" +{ yyval.opval = Nullop; } break; case 52: -#line 265 "perly.y" -{ package(yyvsp[-1].opval); } +#line 276 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 53: -#line 267 "perly.y" -{ package(Nullop); } +#line 280 "perly.y" +{ yyval.ival = start_subparse(); } break; case 54: -#line 271 "perly.y" -{ utilize(yyvsp[-5].ival, yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } +#line 284 "perly.y" +{ yyval.ival = start_subparse(); + CvANON_on(compcv); } break; case 55: -#line 275 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 289 "perly.y" +{ yyval.ival = start_subparse(); + CvFORMAT_on(compcv); } break; case 56: -#line 277 "perly.y" +#line 293 "perly.y" +{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END")) + CvUNIQUE_on(compcv); + yyval.opval = yyvsp[0].opval; } +break; +case 57: +#line 300 "perly.y" +{ yyval.opval = Nullop; } +break; +case 59: +#line 304 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 60: +#line 305 "perly.y" +{ yyval.opval = Nullop; expect = XSTATE; } +break; +case 61: +#line 309 "perly.y" +{ package(yyvsp[-1].opval); } +break; +case 62: +#line 311 "perly.y" +{ package(Nullop); } +break; +case 63: +#line 315 "perly.y" +{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } +break; +case 64: +#line 317 "perly.y" +{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } +break; +case 65: +#line 321 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 66: +#line 323 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 58: -#line 282 "perly.y" +case 68: +#line 328 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 59: -#line 284 "perly.y" +case 69: +#line 330 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 61: -#line 289 "perly.y" +case 71: +#line 335 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; -case 62: -#line 292 "perly.y" +case 72: +#line 338 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; -case 63: -#line 295 "perly.y" +case 73: +#line 341 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval), + prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; -case 64: -#line 300 "perly.y" +case 74: +#line 346 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; -case 65: -#line 305 "perly.y" +case 75: +#line 351 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; -case 66: -#line 310 "perly.y" +case 76: +#line 356 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 67: -#line 312 "perly.y" +case 77: +#line 358 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 68: -#line 314 "perly.y" +case 78: +#line 360 "perly.y" +{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } +break; +case 79: +#line 362 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval), - yyvsp[-3].opval)); } + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; -case 71: -#line 325 "perly.y" +case 82: +#line 372 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; -case 72: -#line 327 "perly.y" +case 83: +#line 374 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 73: -#line 329 "perly.y" +case 84: +#line 376 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; -case 74: -#line 333 "perly.y" +case 85: +#line 380 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 75: -#line 335 "perly.y" +case 86: +#line 382 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 76: -#line 337 "perly.y" +case 87: +#line 384 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 77: -#line 339 "perly.y" +case 88: +#line 386 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 78: -#line 341 "perly.y" +case 89: +#line 388 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 79: -#line 343 "perly.y" +case 90: +#line 390 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 80: -#line 345 "perly.y" +case 91: +#line 392 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; -case 81: -#line 347 "perly.y" +case 92: +#line 394 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 82: -#line 349 "perly.y" +case 93: +#line 396 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 83: -#line 351 "perly.y" +case 94: +#line 398 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 84: -#line 353 "perly.y" +case 95: +#line 400 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 85: -#line 356 "perly.y" +case 96: +#line 403 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; -case 86: -#line 358 "perly.y" +case 97: +#line 405 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 87: -#line 360 "perly.y" +case 98: +#line 407 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 88: -#line 362 "perly.y" +case 99: +#line 409 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; -case 89: -#line 364 "perly.y" +case 100: +#line 411 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; -case 90: -#line 366 "perly.y" +case 101: +#line 413 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; -case 91: -#line 369 "perly.y" +case 102: +#line 416 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; -case 92: -#line 372 "perly.y" +case 103: +#line 419 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; -case 93: -#line 375 "perly.y" +case 104: +#line 422 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; -case 94: -#line 378 "perly.y" +case 105: +#line 425 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; -case 95: -#line 380 "perly.y" +case 106: +#line 427 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; -case 96: -#line 382 "perly.y" +case 107: +#line 429 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; -case 97: -#line 384 "perly.y" +case 108: +#line 431 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; -case 98: -#line 386 "perly.y" +case 109: +#line 433 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; -case 99: -#line 388 "perly.y" +case 110: +#line 435 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; -case 100: -#line 390 "perly.y" +case 111: +#line 437 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; -case 101: -#line 392 "perly.y" +case 112: +#line 439 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 102: -#line 394 "perly.y" +case 113: +#line 441 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 103: -#line 396 "perly.y" +case 114: +#line 443 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; -case 104: -#line 398 "perly.y" +case 115: +#line 445 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 105: -#line 400 "perly.y" +case 116: +#line 447 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; -case 106: -#line 402 "perly.y" +case 117: +#line 449 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 107: -#line 406 "perly.y" +case 118: +#line 453 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 108: -#line 410 "perly.y" +case 119: +#line 457 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 109: -#line 412 "perly.y" +case 120: +#line 459 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 110: -#line 414 "perly.y" +case 121: +#line 461 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; -case 111: -#line 416 "perly.y" +case 122: +#line 463 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 112: -#line 419 "perly.y" +case 123: +#line 466 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 113: -#line 424 "perly.y" +case 124: +#line 471 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 114: -#line 429 "perly.y" +case 125: +#line 476 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; -case 115: -#line 431 "perly.y" +case 126: +#line 478 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; -case 116: -#line 433 "perly.y" +case 127: +#line 480 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, list(yyvsp[-1].opval), ref(yyvsp[-3].opval, OP_ASLICE))); } break; -case 117: -#line 439 "perly.y" +case 128: +#line 486 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2058,38 +2033,38 @@ case 117: ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); expect = XOPERATOR; } break; -case 118: -#line 446 "perly.y" +case 129: +#line 493 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 119: -#line 448 "perly.y" +case 130: +#line 495 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; -case 120: -#line 450 "perly.y" +case 131: +#line 497 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; -case 121: -#line 452 "perly.y" +case 132: +#line 499 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; -case 122: -#line 455 "perly.y" +case 133: +#line 502 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 123: -#line 458 "perly.y" +case 134: +#line 505 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; -case 124: -#line 460 "perly.y" +case 135: +#line 507 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; -case 125: -#line 462 "perly.y" +case 136: +#line 509 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2098,8 +2073,8 @@ case 125: scalar(yyvsp[-2].opval) )),Nullop)); dep();} break; -case 126: -#line 470 "perly.y" +case 137: +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2109,139 +2084,151 @@ case 126: scalar(yyvsp[-3].opval) )))); dep();} break; -case 127: -#line 479 "perly.y" +case 138: +#line 526 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; -case 128: -#line 483 "perly.y" +case 139: +#line 530 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; -case 129: -#line 488 "perly.y" +case 140: +#line 535 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; -case 130: -#line 491 "perly.y" +case 141: +#line 538 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 131: -#line 493 "perly.y" +case 142: +#line 540 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 132: -#line 495 "perly.y" +case 143: +#line 542 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 133: -#line 497 "perly.y" +case 144: +#line 544 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 134: -#line 499 "perly.y" +case 145: +#line 546 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 135: -#line 501 "perly.y" +case 146: +#line 548 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 136: -#line 504 "perly.y" +case 147: +#line 551 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 137: -#line 506 "perly.y" +case 148: +#line 553 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; -case 138: -#line 508 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUB, 0, +case 149: +#line 555 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; -case 139: -#line 511 "perly.y" +case 150: +#line 558 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; -case 140: -#line 513 "perly.y" +case 151: +#line 560 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 141: -#line 515 "perly.y" +case 152: +#line 562 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; -case 142: -#line 517 "perly.y" +case 153: +#line 564 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; -case 145: -#line 523 "perly.y" +case 156: +#line 570 "perly.y" { yyval.opval = Nullop; } break; -case 146: -#line 525 "perly.y" +case 157: +#line 572 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 147: -#line 529 "perly.y" +case 158: +#line 576 "perly.y" { yyval.opval = Nullop; } break; -case 148: -#line 531 "perly.y" +case 159: +#line 578 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 149: -#line 533 "perly.y" +case 160: +#line 580 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 150: -#line 537 "perly.y" +case 161: +#line 583 "perly.y" +{ yyval.ival = 0; } +break; +case 162: +#line 584 "perly.y" +{ yyval.ival = 1; } +break; +case 163: +#line 588 "perly.y" +{ in_my = 0; yyval.opval = my(yyvsp[0].opval); } +break; +case 164: +#line 592 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 151: -#line 541 "perly.y" +case 165: +#line 596 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; -case 152: -#line 545 "perly.y" +case 166: +#line 600 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 153: -#line 549 "perly.y" +case 167: +#line 604 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; -case 154: -#line 553 "perly.y" +case 168: +#line 608 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 155: -#line 557 "perly.y" +case 169: +#line 612 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; -case 156: -#line 561 "perly.y" +case 170: +#line 616 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 157: -#line 563 "perly.y" +case 171: +#line 618 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 158: -#line 565 "perly.y" +case 172: +#line 620 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 159: -#line 568 "perly.y" +case 173: +#line 623 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2230 "y_tab.c" +#line 2217 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/vms/perly_h.vms b/vms/perly_h.vms index c6ec3a41ad..ebeaaf735a 100644 --- a/vms/perly_h.vms +++ b/vms/perly_h.vms @@ -1,4 +1,4 @@ -/* Postprocessed by vms_yfix.pl 1.1 to add VMS declarations of globals */ +/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */ #define WORD 257 #define METHOD 258 #define FUNCMETH 259 @@ -27,35 +27,36 @@ #define FUNC0 282 #define FUNC1 283 #define FUNC 284 -#define RELOP 285 -#define EQOP 286 -#define MULOP 287 -#define ADDOP 288 -#define DOLSHARP 289 -#define DO 290 -#define LOCAL 291 -#define HASHBRACK 292 -#define NOAMP 293 -#define OROP 294 -#define ANDOP 295 -#define NOTOP 296 -#define LSTOP 297 -#define ASSIGNOP 298 -#define OROR 299 -#define ANDAND 300 -#define BITOROP 301 -#define BITANDOP 302 -#define UNIOP 303 -#define SHIFTOP 304 -#define MATCHOP 305 -#define UMINUS 306 -#define REFGEN 307 -#define POWOP 308 -#define PREINC 309 -#define PREDEC 310 -#define POSTINC 311 -#define POSTDEC 312 -#define ARROW 313 +#define UNIOP 285 +#define LSTOP 286 +#define RELOP 287 +#define EQOP 288 +#define MULOP 289 +#define ADDOP 290 +#define DOLSHARP 291 +#define DO 292 +#define HASHBRACK 293 +#define NOAMP 294 +#define LOCAL 295 +#define MY 296 +#define OROP 297 +#define ANDOP 298 +#define NOTOP 299 +#define ASSIGNOP 300 +#define OROR 301 +#define ANDAND 302 +#define BITOROP 303 +#define BITANDOP 304 +#define SHIFTOP 305 +#define MATCHOP 306 +#define UMINUS 307 +#define REFGEN 308 +#define POWOP 309 +#define PREINC 310 +#define PREDEC 311 +#define POSTINC 312 +#define POSTDEC 313 +#define ARROW 314 typedef union { I32 ival; char *pval; diff --git a/vms/test.com b/vms/test.com index 156b2dca81..72354d2823 100644 --- a/vms/test.com +++ b/vms/test.com @@ -74,7 +74,7 @@ $ $! And do it $ testdir = "Directory/NoHead/NoTrail/Column=1" $ Define/User Perlshr Sys$Disk:[-]PerlShr'exe' -$ MCR Sys$Disk:[]Perl. "''p2'" "''p3'" "''p4'" "''p5'" "''p6'" +$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p2'" "''p3'" "''p4'" "''p5'" "''p6'" $ Deck/Dollar=$$END-OF-TEST$$ # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ # Modified for VMS 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu @@ -85,13 +85,22 @@ $ Deck/Dollar=$$END-OF-TEST$$ # skip those tests we know will fail entirely or cause perl to hang bacause # of Unixisms in the tests. (The Perl operators being tested may work fine, # but the tests may use other operators which don't.) +use Config; + @compexcl=('cpp.t','script.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_sock.t', - 'ndbm.t','odbm.t','posix.t','sdbm.t','soundex.t'); - # Note: POSIX is not part of basic build, but can be built - # separately if you're using DECC + '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'); + +# Note: POSIX is not part of basic build, but can be built +# separately if you're using DECC +# io_xs.t tests the new_tmpfile routine, which doesn't work with the +# VAXCRTL, since the file can't be stat()d, an Perl's do_open() +# insists on stat()ing a file descriptor before it'll use it. +push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc'; + @opexcl=('exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t'); @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl); foreach $file (@exclist) { $skip{$file}++; } @@ -137,6 +146,8 @@ while ($test = shift) { close(script); if (/#!..perl(.*)/) { $switch = $1; + # Add "" to protect uppercase switches on command line + $switch =~ s/-(\S*[A-Z]\S*)/"-$1"/g; } else { $switch = ''; } @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.3.1 + * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.3.7 */ #include <acedef.h> @@ -119,7 +119,7 @@ char * my_getenv(char *lnm) { static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; - char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; unsigned long int idx = 0; int trnsuccess; @@ -322,6 +322,7 @@ my_crypt(const char *textpasswd, const char *usrname) /*}}}*/ +static char *do_rmsexpand(char *, char *, int, char *, unsigned); static char *do_fileify_dirspec(char *, char *, int); static char *do_tovmsspec(char *, char *, int); @@ -353,7 +354,7 @@ do_rmdir(char *name) int kill_file(char *name) { - char vmsname[NAM$C_MAXRSS+1]; + char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1]; unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; @@ -374,7 +375,12 @@ kill_file(char *name) lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; - if (!remove(name)) return 0; /* Can we just get rid of it? */ + /* Expand the input spec using RMS, since the CRTL remove() and + * system services won't do this by themselves, so we may miss + * a file "hiding" behind a logical name or search list. */ + if (do_tovmsspec(name,vmsname,0) == NULL) return -1; + if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1; + if (!remove(rspec)) return 0; /* Can we just get rid of it? */ /* If not, can changing protections help? */ if (vaxc$errno != RMS$_PRV) return -1; @@ -383,9 +389,8 @@ kill_file(char *name) * to delete the file. */ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); - if (do_tovmsspec(name,vmsname,0) == NULL) return -1; - fildsc.dsc$w_length = strlen(vmsname); - fildsc.dsc$a_pointer = vmsname; + fildsc.dsc$w_length = strlen(rspec); + fildsc.dsc$a_pointer = rspec; cxt = 0; newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { @@ -758,6 +763,28 @@ I32 my_pclose(FILE *fp) /* get here => no such pipe open */ croak("No such pipe open"); + /* If we were writing to a subprocess, insure that someone reading from + * the mailbox gets an EOF. It looks like a simple fclose() doesn't + * produce an EOF record in the mailbox. */ + if (info->mode != 'r') { + char devnam[NAM$C_MAXRSS+1], *cp; + unsigned long int chan, iosb[2], retsts, retsts2; + struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; + + if (fgetname(info->fp,devnam)) { + /* It oughta be a mailbox, so fgetname should give just the device + * name, but just in case . . . */ + if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; + devdsc.dsc$w_length = strlen(devnam); + _ckvmssts(sys$assign(&devdsc,&chan,0,0)); + retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); + if (retsts & 1) retsts = iosb[0]; + retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ + if (retsts & 1) retsts = retsts2; + _ckvmssts(retsts); + } + else _ckvmssts(vaxc$errno); /* Should never happen */ + } PerlIO_close(info->fp); if (info->done) retsts = info->completion; @@ -832,6 +859,14 @@ my_gconvert(double val, int ndig, int trail, char *buf) char *loc; loc = buf ? buf : __gcvtbuf; + +#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */ + if (val < 1) { + sprintf(loc,"%.*g",ndig,val); + return loc; + } +#endif + if (val) { if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; return gcvt(val,ndig,loc); @@ -844,6 +879,108 @@ my_gconvert(double val, int ndig, int trail, char *buf) } /*}}}*/ + +/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ +/* Shortcut for common case of simple calls to $PARSE and $SEARCH + * to expand file specification. Allows for a single default file + * specification and a simple mask of options. If outbuf is non-NULL, + * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which + * the resultant file specification is placed. If outbuf is NULL, the + * resultant file specification is placed into a static buffer. + * The third argument, if non-NULL, is taken to be a default file + * specification string. The fourth argument is unused at present. + * rmesexpand() returns the address of the resultant string if + * successful, and NULL on error. + */ +static char * +do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) +{ + static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; + char esa[NAM$C_MAXRSS], *cp, *out = NULL; + struct FAB myfab = cc$rms_fab; + struct NAM mynam = cc$rms_nam; + STRLEN speclen; + unsigned long int retsts, haslower = 0; + + if (!filespec || !*filespec) { + set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); + return NULL; + } + if (!outbuf) { + if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char); + else outbuf = __rmsexpand_retbuf; + } + + myfab.fab$l_fna = filespec; + myfab.fab$b_fns = strlen(filespec); + myfab.fab$l_nam = &mynam; + + if (defspec && *defspec) { + myfab.fab$l_dna = defspec; + myfab.fab$b_dns = strlen(defspec); + } + + mynam.nam$l_esa = esa; + mynam.nam$b_ess = sizeof esa; + mynam.nam$l_rsa = outbuf; + mynam.nam$b_rss = NAM$C_MAXRSS; + + retsts = sys$parse(&myfab,0,0); + if (!(retsts & 1)) { + if (retsts == RMS$_DNF || retsts == RMS$_DIR || + retsts == RMS$_DEV || retsts == RMS$_DEV) { + mynam.nam$b_nop |= NAM$M_SYNCHK; + retsts = sys$parse(&myfab,0,0); + if (retsts & 1) goto expanded; + } + if (out) Safefree(out); + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_DEV) set_errno(ENODEV); + else if (retsts == RMS$_DIR) set_errno(ENOTDIR); + else set_errno(EVMSERR); + return NULL; + } + retsts = sys$search(&myfab,0,0); + if (!(retsts & 1) && retsts != RMS$_FNF) { + if (out) Safefree(out); + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else set_errno(EVMSERR); + return NULL; + } + + /* If the input filespec contained any lowercase characters, + * downcase the result for compatibility with Unix-minded code. */ + expanded: + for (out = myfab.fab$l_fna; *out; out++) + if (islower(*out)) { haslower = 1; break; } + if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } + else { out = esa; speclen = mynam.nam$b_esl; } + if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && + (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';'))) + speclen = mynam.nam$l_ver - out; + /* If we just had a directory spec on input, $PARSE "helpfully" + * adds an empty name and type for us */ + if (mynam.nam$l_name == mynam.nam$l_type && + mynam.nam$l_ver == mynam.nam$l_type + 1 && + !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) + speclen = mynam.nam$l_name - out; + out[speclen] = '\0'; + if (haslower) __mystrtolower(out); + + /* Have we been working with an expanded, but not resultant, spec? */ + if (!mynam.nam$b_rsl) strcpy(outbuf,esa); + return outbuf; +} +/*}}}*/ +/* External entry points */ +char *rmsexpand(char *spec, char *buf, char *def, unsigned opt) +{ return do_rmsexpand(spec,buf,0,def,opt); } +char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt) +{ return do_rmsexpand(spec,buf,1,def,opt); } + + /* ** The following routines are provided to make life easier when ** converting among VMS-style and Unix-style directory specifications. @@ -2010,6 +2147,7 @@ unsigned long int zero = 0, sts; set_errno(ENOENT); break; case RMS$_DEV: set_errno(ENODEV); break; + case RMS$_FNM: case RMS$_SYN: set_errno(EINVAL); break; case RMS$_PRV: @@ -3020,7 +3158,7 @@ struct tm * my_gmtime(const time_t *time) { static int gmtime_emulation_type; - static time_t utc_offset_secs; + static long int utc_offset_secs; char *p; time_t when; @@ -3032,7 +3170,7 @@ my_gmtime(const time_t *time) if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) gmtime_emulation_type++; else - utc_offset_secs = (time_t) atol(p); + utc_offset_secs = atol(p); } } @@ -3258,10 +3396,13 @@ cando_by_name(I32 bit, I32 effective, char *fname) } retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); - if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || - retsts == RMS$_FNF || retsts == RMS$_DIR || - retsts == RMS$_DEV) { - set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts); + if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || + retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || + retsts == RMS$_DIR || retsts == RMS$_DEV) { + set_vaxc_errno(retsts); + if (retsts == SS$_NOPRIV) set_errno(EACCES); + else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL); + else set_errno(ENOENT); return FALSE; } if (retsts == SS$_NORMAL) { @@ -3291,6 +3432,7 @@ int flex_fstat(int fd, struct mystat *statbufp) { if (!fstat(fd,(stat_t *) statbufp)) { + if (statbufp == &statcache) *namecache == '\0'; statbufp->st_dev = encode_dev(statbufp->st_devnam); return 0; } @@ -3309,10 +3451,8 @@ int flex_stat(char *fspec, struct mystat *statbufp) { char fileified[NAM$C_MAXRSS+1]; - int retval,myretval; - struct mystat tmpbuf; + int retval = -1; - if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0); if (is_null_device(fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); @@ -3325,22 +3465,19 @@ flex_stat(char *fspec, struct mystat *statbufp) return 0; } - if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1; - else { - myretval = stat(fileified,(stat_t *) &tmpbuf); - } - retval = stat(fspec,(stat_t *) statbufp); - if (!myretval) { - if (retval == -1) { - *statbufp = tmpbuf; - retval = 0; - } - else if (!retval) { /* Dir with same name. Substitute it. */ - statbufp->st_mode &= ~S_IFDIR; - statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR; - strcpy(namecache,fileified); - } + /* Try for a directory name first. If fspec contains a filename without + * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir + * and sea:[wine.dark]water. exist, we prefer the directory here. + * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir, + * not sea:[wine.dark]., if the latter exists. If the intended target is + * the file with null type, specify this by calling flex_stat() with + * a '.' at the end of fspec. + */ + if (do_fileify_dirspec(fspec,fileified,0) != NULL) { + retval = stat(fileified,(stat_t *) statbufp); + if (!retval && statbufp == &statcache) strcpy(namecache,fileified); } + if (retval) retval = stat(fspec,(stat_t *) statbufp); if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam); return retval; @@ -3358,16 +3495,22 @@ my_binmode(FILE *fp, char iotype) fpos_t pos; if (!fgetname(fp,filespec)) return NULL; - if (fgetpos(fp,&pos) == -1) return NULL; + if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL; switch (iotype) { case '<': case 'r': acmode = "rb"; break; - case '>': case 'w': acmode = "wb"; break; - case '+': case '|': case 's': acmode = "rb+"; break; + case '>': case 'w': + /* use 'a' instead of 'w' to avoid creating new file; + fsetpos below will take care of restoring file position */ case 'a': acmode = "ab"; break; - case '-': acmode = fileno(fp) ? "wb" : "rb"; break; + case '+': case '|': case 's': acmode = "rb+"; break; + case '-': acmode = fileno(fp) ? "ab" : "rb"; break; + default: + warn("Unrecognized iotype %c in my_binmode",iotype); + acmode = "rb+"; } if (freopen(filespec,acmode,fp) == NULL) return NULL; - if (fsetpos(fp,&pos) == -1) return NULL; + if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL; + return fp; } /* end of my_binmode() */ /*}}}*/ @@ -3583,71 +3726,17 @@ void rmsexpand_fromperl(CV *cv) { dXSARGS; - char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out; - struct FAB myfab = cc$rms_fab; - struct NAM mynam = cc$rms_nam; - STRLEN speclen; - unsigned long int retsts, haslower = 0; - - if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); - - myfab.fab$l_fna = SvPV(ST(0),speclen); - myfab.fab$b_fns = speclen; - myfab.fab$l_nam = &mynam; - - if (items == 2) { - myfab.fab$l_dna = SvPV(ST(1),speclen); - myfab.fab$b_dns = speclen; - } + char *fspec, *defspec = NULL, *rslt; - mynam.nam$l_esa = esa; - mynam.nam$b_ess = sizeof esa; - mynam.nam$l_rsa = rsa; - mynam.nam$b_rss = sizeof rsa; + if (!items || items > 2) + croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); + fspec = SvPV(ST(0),na); + if (!fspec || !*fspec) XSRETURN_UNDEF; + if (items == 2) defspec = SvPV(ST(1),na); - retsts = sys$parse(&myfab,0,0); - if (!(retsts & 1)) { - if (retsts == RMS$_DNF || retsts == RMS$_DIR || - retsts == RMS$_DEV || retsts == RMS$_DEV) { - mynam.nam$b_nop |= NAM$M_SYNCHK; - retsts = sys$parse(&myfab,0,0); - if (retsts & 1) goto expanded; - } - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else if (retsts == RMS$_DEV) set_errno(ENODEV); - else if (retsts == RMS$_DIR) set_errno(ENOTDIR); - else set_errno(EVMSERR); - XSRETURN_UNDEF; - } - retsts = sys$search(&myfab,0,0); - if (!(retsts & 1) && retsts != RMS$_FNF) { - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else set_errno(EVMSERR); - XSRETURN_UNDEF; - } - - /* If the input filespec contained any lowercase characters, - * downcase the result for compatibility with Unix-minded code. */ - expanded: - for (out = myfab.fab$l_fna; *out; out++) - if (islower(*out)) { haslower = 1; break; } - if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; } - else { out = esa; speclen = mynam.nam$b_esl; } - if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && - (items == 1 || !strchr(myfab.fab$l_dna,';'))) - speclen = mynam.nam$l_ver - out; - /* If we just had a directory spec on input, $PARSE "helpfully" - * adds an empty name and type for us */ - if (mynam.nam$l_name == mynam.nam$l_type && - mynam.nam$l_ver == mynam.nam$l_type + 1 && - !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) - speclen = mynam.nam$l_name - out; - out[speclen] = '\0'; - if (haslower) __mystrtolower(out); - - ST(0) = sv_2mortal(newSVpv(out, speclen)); + rslt = do_rmsexpand(fspec,NULL,1,defspec,0); + ST(0) = sv_newmortal(); + if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt)); XSRETURN(1); } diff --git a/vms/vms_yfix.pl b/vms/vms_yfix.pl index 33af914b25..9f29c80825 100644 --- a/vms/vms_yfix.pl +++ b/vms/vms_yfix.pl @@ -6,10 +6,12 @@ # If it finds that the input files are already patches for VMS, # it just copies the input to the output. # -# Revised 29-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu +# Revised 20-Dec-1996 by Charles Bailey bailey@genetics.upenn.edu -$VERSION = '1.1'; +$VERSION = '1.11'; +push(@ARGV,(qw[ perly.c perly.h vms/perly_c.vms vms/perly_h.vms])[@ARGV..4]) + if @ARGV < 4; ($cinfile,$hinfile,$coutfile,$houtfile) = @ARGV; open C,$cinfile or die "Can't read $cinfile: $!\n"; diff --git a/vms/vmsish.h b/vms/vmsish.h index a362374e1c..7fec438628 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -15,12 +15,12 @@ #include <ssdef.h> /* explicitly set in the perl source code */ /* Suppress compiler warnings from DECC for VMS-specific extensions: - * GLOBALEXT, NOSHAREEXT: global[dr]ef declarations + * GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations * ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values * (e.g. pointer fields of descriptors) */ #ifdef __DECC -# pragma message disable (GLOBALEXT,NOSHAREEXT,ADDRCONSTEXT,NEEDCONSTEXT) +# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT,ADDRCONSTEXT,NEEDCONSTEXT) #endif /* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */ @@ -51,6 +51,9 @@ #include <unixio.h> #include <unixlib.h> #include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */ +#ifdef __DECC +# include <unistd.h> /* DECC has this; VAXC and gcc don't */ +#endif /* Our own contribution to PerlShr's global symbols . . . */ #ifdef EMBED @@ -64,6 +67,8 @@ # define do_rmdir Perl_do_rmdir # define kill_file Perl_kill_file # define my_utime Perl_my_utime +# define rmsexpand Perl_rmsexpand +# define rmsexpand_ts Perl_rmsexpand_ts # define fileify_dirspec Perl_fileify_dirspec # define fileify_dirspec_ts Perl_fileify_dirspec_ts # define pathify_dirspec Perl_pathify_dirspec @@ -138,6 +143,18 @@ */ #undef ACME_MESS /**/ +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +#define ALTERNATE_SHEBANG "$" + /* Macros to set errno using the VAX thread-safe calls, if present */ #if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA) # define set_errno(v) (cma$tis_errno_set_value(v)) @@ -232,6 +249,11 @@ /* Assorted fiddling with sigs . . . */ # include <signal.h> #define ABORT() abort() + /* VAXC's signal.h doesn't #define SIG_ERR, but provides BADSIG instead. */ +#if !defined(SIG_ERR) && defined(BADSIG) +# define SIG_ERR BADSIG +#endif + /* Used with our my_utime() routine in vms.c */ struct utimbuf { @@ -253,6 +275,9 @@ struct utimbuf { clock_t tms_cutime; /* user time, children */ clock_t tms_cstime; /* system time, children - always 0 on VMS */ }; +#else + /* The new headers change the times() prototype to tms from tbuffer */ +# define tbuffer_t struct tms #endif /* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always @@ -400,6 +425,25 @@ typedef unsigned myino_t; * <data type><TAB>name<WHITESPACE>_((<prototype args>)); */ +#ifdef NO_PERL_TYPEDEFS + /* We don't have Perl typedefs available (e.g. when building a2p), so + we fake them here. N.B. There is *no* guarantee that the faked + prototypes will actually match the real routines. If you want to + call Perl routines, include perl.h to get the real typedefs. */ +# ifndef bool +# define bool int +# define __MY_BOOL_TYPE_FAKE +# endif +# ifndef I32 +# define I32 int +# define __MY_I32_TYPE_FAKE +# endif +# ifndef SV +# define SV void /* Since we only see SV * in prototypes */ +# define __MY_SV_TYPE_FAKE +# endif +#endif + void prime_env_iter _((void)); void getredirection _((int *, char ***)); void init_os_extras _(()); @@ -413,6 +457,8 @@ char * my_gconvert _((double, int, int, char *)); int do_rmdir _((char *)); int kill_file _((char *)); int my_utime _((char *, struct utimbuf *)); +char * rmsexpand _((char *, char *, char *, unsigned)); +char * rmsexpand_ts _((char *, char *, char *, unsigned)); char * fileify_dirspec _((char *, char *)); char * fileify_dirspec_ts _((char *, char *)); char * pathify_dirspec _((char *, char *)); @@ -453,6 +499,21 @@ int rmscopy _((char *, char *, int)); typedef char __VMS_SEPYTOTORP__; /* prototype section end marker; `typedef' passes through cpp */ +#ifdef NO_PERL_TYPEDEFS /* We'll try not to scramble later files */ +# ifdef __MY_BOOL_TYPE_FAKE +# undef bool +# undef __MY_BOOL_TYPE_FAKE +# endif +# ifdef __MY_I32_TYPE_FAKE +# undef I32 +# undef __MY_I32_TYPE_FAKE +# endif +# ifdef __MY_SV_TYPE_FAKE +# undef SV +# undef __MY_SV_TYPE_FAKE +# endif +#endif + #ifndef VMS_DO_SOCKETS /* This relies on tricks in perl.h to pick up that these manifest constants * are undefined and set up conversion routines. It will then redefine diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index ac3625021b..0ca3ff35db 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -80,7 +80,7 @@ plextract = find2perl s2p addedbyconf = $(shextract) $(plextract) -h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h +h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h c = hash.c $(mallocsrc) str.c util.c walk.c @@ -112,7 +112,8 @@ run_byacc: FORCE a2p.c: a2p.y -@touch a2p.c -a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h +a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h \ + ../handy.h ../config.h str.h hash.h $(CCCMD) $(LARGE) a2p.c clean: @@ -150,6 +151,7 @@ $(plextract): malloc.c: ../malloc.c rm -f malloc.c sed <../malloc.c >malloc.c \ + -e 's/"EXTERN.h"/"..\/EXTERN.h"/' \ -e 's/"perl.h"/"..\/perl.h"/' \ -e 's/my_exit/exit/' @@ -74,7 +74,7 @@ short yylhs[] = { -1, 0, 3, 6, 6, 2, 2, 7, 7, 7, 7, 7, 7, 9, 8, 8, 11, 11, 11, 11, 11, 15, 15, 15, 15, 14, 14, 14, 14, 13, 13, - 13, 13, 12, 12, 12, 16, 16, 16, 16, 16, + 13, 13, 12, 12, 12, 12, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, @@ -90,8 +90,8 @@ short yylen[] = { 2, 2, 6, 5, 2, 3, 0, 1, 5, 10, 4, 1, 1, 1, 1, 3, 1, 1, 1, 1, 5, 3, 4, 4, 2, 3, 3, 3, 3, 3, 3, - 1, 3, 1, 2, 3, 1, 1, 1, 3, 3, - 3, 3, 3, 3, 3, 5, 2, 2, 2, 2, + 1, 3, 1, 2, 5, 3, 1, 1, 1, 3, + 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 3, 1, 2, 3, 4, 3, 4, 1, 3, 4, 4, 4, 2, 8, 6, 8, 8, 6, 6, 6, 6, 6, 6, 6, 6, 8, 8, 8, @@ -105,951 +105,981 @@ short yylen[] = { 2, short yydefred[] = { 93, 0, 0, 95, 96, 97, 94, 0, 92, 0, 0, 31, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 37, 0, 0, 0, 38, 0, 0, 0, 0, + 0, 38, 0, 0, 0, 39, 0, 0, 0, 0, 0, 84, 0, 99, 0, 11, 0, 93, 0, 0, 0, 17, 18, 19, 0, 0, 99, 99, 0, 0, 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 24, 49, - 50, 0, 0, 0, 0, 0, 0, 4, 0, 99, - 0, 99, 99, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 47, 48, - 0, 0, 61, 0, 0, 0, 0, 99, 99, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 100, 101, 0, 98, 53, 32, 28, 21, - 0, 0, 0, 0, 0, 30, 0, 0, 0, 0, - 45, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 62, 63, 91, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 13, 64, 83, 0, 0, 99, - 0, 0, 0, 0, 0, 0, 120, 119, 123, 0, - 99, 0, 99, 10, 99, 0, 106, 0, 111, 0, - 0, 0, 22, 59, 93, 3, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 99, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 99, 99, 99, 99, 99, 8, 0, 0, 70, 0, - 75, 0, 74, 0, 77, 0, 76, 0, 72, 73, - 0, 67, 0, 71, 128, 127, 129, 0, 0, 0, - 0, 0, 112, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 99, 0, - 0, 0, 99, 99, 99, 0, 0, 0, 99, 69, - 68, 79, 78, 81, 80, 0, 66, 0, 0, 0, - 0, 0, 0, 126, 0, 0, 0, 132, 136, 0, - 0, 0, 9, 99, 99, 0, 133, 0, 0, 99, - 131, 135, 0, 134, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 24, + 49, 50, 0, 0, 0, 0, 0, 0, 4, 0, + 99, 0, 99, 99, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 47, 48, 0, 0, 61, 0, 0, 0, 0, 0, + 99, 99, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 100, 101, 0, 98, 53, + 32, 28, 21, 0, 0, 0, 0, 0, 0, 30, + 0, 0, 0, 0, 46, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 62, 63, 91, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 13, 64, + 83, 0, 0, 99, 0, 0, 0, 0, 0, 0, + 120, 119, 123, 0, 99, 0, 99, 10, 99, 0, + 106, 0, 111, 0, 0, 0, 22, 0, 59, 93, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 99, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 99, 99, 99, 99, 99, + 8, 0, 0, 0, 70, 0, 75, 0, 74, 0, + 77, 0, 76, 0, 72, 73, 0, 67, 0, 71, + 128, 127, 129, 0, 0, 0, 0, 0, 112, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 99, 0, 0, 0, 99, 99, + 99, 0, 0, 0, 99, 69, 68, 79, 78, 81, + 80, 0, 66, 0, 0, 0, 0, 0, 0, 126, + 0, 0, 0, 132, 136, 0, 0, 0, 9, 99, + 99, 0, 133, 0, 0, 99, 131, 135, 0, 134, }; short yydgoto[] = { 1, - 2, 7, 36, 73, 125, 37, 38, 39, 164, 52, - 53, 41, 42, 43, 44, 45, 46, 55, 8, 126, - 225, 187, 188, 189, 254, 248, + 2, 7, 36, 74, 128, 37, 38, 39, 168, 52, + 75, 190, 42, 43, 44, 45, 46, 54, 8, 129, + 230, 191, 192, 193, 260, 254, }; short yysindex[] = { 0, - 0, -48, 0, 0, 0, 0, 6619, 0, -121, -110, - 0, -4, 32, 4183, 38, 30, 51, 64, 68, -260, - 70, 0, -61, 82, 83, 0, 4448, 4448, 4448, -183, - -183, 0, 4448, 0, 4448, 0, -188, 0, 3, 22, - 6884, 0, 0, 0, 34, -213, 0, 0, 2061, 4183, - 4183, 0, -49, 5612, 85, 4448, 4448, 14, 4713, 6753, - 4448, 87, 4183, 4183, 4448, 4448, -77, -77, 0, 0, - 0, 18, -192, -36, 91, 92, 95, 0, -48, 0, - 4448, 0, 0, 4448, 6980, 4448, 4448, 4448, 34, -154, - 4448, 4448, 4448, 4448, 4448, 4448, -135, 4448, 0, 0, - -192, -192, 0, 5658, 106, 5612, 11, 0, 0, 5704, - 186, 4448, 113, 5751, 115, 5805, 5885, 4183, 114, 67, - 5931, 5978, 0, 0, 4572, 0, 0, 0, 0, 0, - -192, 6032, 1964, 1964, -49, 0, 3230, 186, 186, 186, - 0, 97, 97, -77, -77, -77, -77, -183, -49, 4665, - 4765, 0, 0, 0, 1964, 1964, -131, 186, 4448, 4448, - 4448, 4448, 7026, 121, 0, 0, 0, 4448, 4448, 0, - 4183, 4183, 124, 125, 132, 4448, 0, 0, 0, 4448, - 0, -117, 0, 0, 0, 6884, 0, -44, 0, 4837, - 4448, -114, 0, 0, 0, 0, 6884, 6884, 13, 3635, - 5295, 5367, 5506, 137, 6078, 0, 5560, 6243, -192, -59, - -59, 4448, 4448, 5241, 6884, 6884, 3701, 93, -192, -192, - 0, 0, 0, 0, 0, 0, 6884, -48, 0, 7084, - 0, 4448, 0, 4448, 0, 4448, 0, 4448, 0, 0, - -119, 0, 4448, 0, 0, 0, 0, 4448, 4448, -34, - -16, 6343, 0, 123, -89, 4183, 4930, -192, -192, -192, - -192, -192, 144, 6389, 6435, 6508, 6554, 6700, 0, 6819, - 6884, 6884, 0, 0, 0, 6930, 146, 94, 0, 0, - 0, 0, 0, 0, 0, -192, 0, 3701, 3701, 3701, - 5241, -53, 4448, 0, -192, 5030, -83, 0, 0, 148, - 5241, -13, 0, 0, 0, 149, 0, 3701, 3701, 0, - 0, 0, 3701, 0, + 0, -50, 0, 0, 0, 0, 4775, 0, -91, -38, + 0, 34, 41, 7201, 42, 6, 46, 48, 50, -184, + 70, 0, 16, 77, 80, 0, 7255, 7255, 5051, -220, + -220, 0, 7255, 0, 5051, 0, -140, 0, 5, -13, + 5693, 0, 0, 0, -32, -233, 0, 0, 4619, 7201, + 5962, 0, 6006, 79, 7255, 7255, 71, 6890, 6936, 7255, + 87, 7201, 7201, 7255, 7255, 5051, -42, -244, -42, 0, + 0, 0, 20, -183, -41, 89, 92, 93, 0, -50, + 0, 7255, 0, 0, 5051, 7255, 6990, 7255, 7255, 7255, + -32, -157, 7255, 7255, 7255, 7255, 7255, 7255, -144, 5051, + 0, 0, -183, -183, 0, 3590, 96, 5962, 5577, 10, + 0, 0, 6049, 1522, 7255, 94, 6107, 95, 6153, 6195, + 7201, 99, 51, 6238, 6281, 0, 0, 4886, 0, 0, + 0, 0, 0, -183, 6323, 1605, 1605, -60, 6380, 0, + 1522, 1522, 1522, 1522, 0, -7, -7, -42, -42, -42, + -42, -220, -60, 4931, 4977, 0, 0, 0, 6425, 6425, + -151, 1522, 7255, 7255, 7255, 7255, 7052, 102, 0, 0, + 0, 7255, 7255, 0, 7201, 7201, 115, 119, 121, 7255, + 0, 0, 0, 7255, 0, -130, 0, 0, 0, 7112, + 0, 18, 0, 5242, 7255, -126, 0, 7255, 0, 0, + 0, 7112, 7112, 32, 2427, 2474, 5735, 5779, 126, 6470, + 0, 5842, 6513, -183, -33, -33, 5051, 5051, 5428, 7112, + 7112, 4046, 81, -183, -183, 0, 0, 0, 0, 0, + 0, 7112, 7112, -50, 0, 7158, 0, 7255, 0, 7255, + 0, 7255, 0, 7255, 0, 0, -96, 0, 7255, 0, + 0, 0, 0, 7255, 7255, -39, -37, 6555, 0, 116, + -95, 7201, 5287, -183, -183, -183, -183, -183, 135, 6612, + 6657, 6702, 6745, 6787, 0, 6844, 7112, 7112, 0, 0, + 0, 5908, 144, 97, 0, 0, 0, 0, 0, 0, + 0, -183, 0, 4046, 4046, 4046, 5428, -51, 5051, 0, + -183, 5332, -85, 0, 0, 146, 5428, -35, 0, 0, + 0, 147, 0, 4046, 4046, 0, 0, 0, 4046, 0, }; short yyrindex[] = { 0, - 0, 2015, 0, 0, 0, 0, 192, 0, 0, 0, - 0, 56, 0, 3424, 0, 2619, 0, 0, 0, 0, + 0, 2000, 0, 0, 0, 0, 189, 0, 0, 0, + 0, 56, 0, 3312, 0, 2591, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 2147, 0, 2195, 1676, - 3509, 0, 0, 0, 1782, 1340, 0, 0, 0, 152, - 0, 0, 0, 3829, 111, 0, 0, 381, 0, 0, - 0, 0, 152, 101, 0, 0, 564, 834, 0, 0, - 0, 436, 5102, 0, -47, 39, 42, 0, 2245, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 1830, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 5102, 5102, 0, 72, 0, 17, 0, 0, 0, 72, - 2718, 0, 74, 72, 74, 72, 72, 152, 0, 0, - 72, 72, 0, 0, 0, 0, 0, 0, 0, 0, - 5102, 72, 0, 0, 1882, 0, 3464, 3057, 3097, 3145, - 0, 1468, 1734, 888, 942, 1016, 1286, 2564, 1395, 0, - 0, 0, 0, 0, 0, 0, 0, 3185, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 538, 538, 0, 0, 0, 122, 0, 0, 0, 241, - 0, 0, 0, 0, 0, -41, 0, 0, 0, 0, - 0, 491, 0, 0, 0, 0, 3549, 3594, 0, 72, - 72, 72, 72, 74, 72, 0, 72, 72, 3866, 296, - 357, 0, 0, 136, -10, 169, 0, 0, 5102, 3970, - 0, 0, 0, 0, 0, 0, 3784, 2294, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, -51, 0, 0, 0, 101, 0, 4038, 4135, 4235, - 4307, 4400, 74, 72, 72, 72, 72, 72, 0, 72, - 507, 553, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 5102, 0, 0, 0, 0, - 155, 0, 0, 0, 4500, 0, 5195, 0, 0, 0, - 155, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 2138, 0, 1930, 1209, + 3755, 0, 0, 0, 1818, 1394, 0, 0, 0, 151, + 0, 0, 3707, 111, 0, 0, 381, 0, 0, 0, + 0, 151, 100, 0, 0, 0, 564, 834, 889, 0, + 0, 0, 436, 5378, 0, -49, -46, -43, 0, 2195, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 2084, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 5378, 5378, 0, 0, 0, 0, -22, 0, + 0, 0, 0, 2639, 0, 0, 0, 0, 0, 0, + 151, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 5378, 0, 0, 0, 1872, 0, 0, + 2878, 2923, 2968, 3037, 0, 1719, 1770, 943, 1016, 1286, + 1340, 2536, 1664, 0, 0, 0, 0, 0, 0, 0, + 0, 3245, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 67, 67, 0, 0, 0, -34, + 0, 0, 0, 12, 0, 0, 0, 0, 0, 101, + 0, 0, 0, 0, 0, 491, 0, 0, 0, 0, + 0, 3360, 3432, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 4091, 104, 172, 0, 0, 136, 241, + 247, 0, 0, 5378, 4146, 0, 0, 0, 0, 0, + 0, 3520, 3640, 2266, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 137, 0, 0, + 0, 100, 0, 4220, 4411, 4485, 4530, 4576, 0, 0, + 0, 0, 0, 0, 0, 0, 296, 357, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 5378, 0, 0, 0, 0, 153, 0, 0, 0, + 4841, 0, 5643, 0, 0, 0, 153, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; short yygindex[] = { 0, - -18, 0, 0, 7251, -19, 0, 0, 0, 0, -31, - 33, 2875, -14, -12, 16, 7373, 76, 147, 0, 0, - 0, 231, -205, 0, -267, -9, + -15, 0, 0, 3236, -67, 0, 0, 0, 0, -29, + 171, 4012, -19, 4, 14, 7669, 7480, -4, 0, 0, + 0, -113, -201, 0, -232, -18, }; -#define YYTABLESIZE 7645 -short yytable[] = { 114, - 82, 47, 246, 269, 127, 301, 273, 114, 253, 81, - 6, 16, 48, 81, 224, 17, 96, 114, 105, 79, - 75, 16, 76, 300, 274, 62, 81, 307, 81, 64, - 122, 119, 120, 306, 97, 49, 75, 82, 76, 40, - 82, 82, 82, 82, 82, 82, 81, 82, 122, 81, - 77, 154, 16, 229, 109, 60, 230, 16, 82, 82, - 82, 69, 82, 82, 247, 84, 77, 74, 123, 124, - 95, 50, 78, 112, 98, 93, 91, 56, 92, 16, - 94, 150, 151, 74, 81, 253, 165, 99, 100, 57, - 59, 58, 60, 82, 82, 253, 60, 60, 60, 60, - 60, 18, 60, 60, 19, 70, 71, 61, 23, 63, - 87, 190, 82, 60, 60, 60, 135, 60, 60, 32, - 33, 65, 66, 82, 82, 80, 118, 96, 109, 97, - 149, 128, 129, 95, 16, 130, 31, 141, 93, 210, - 211, 123, 124, 94, 148, 97, 153, 87, 60, 60, - 87, 87, 87, 87, 166, 87, 159, 87, 161, 167, - 199, 206, 121, 212, 213, 192, 193, 60, 87, 87, - 87, 214, 87, 87, 218, 83, 228, 239, 60, 60, - 121, 276, 277, 256, 280, 293, 294, 304, 305, 310, - 96, 1, 88, 88, 113, 113, 0, 107, 0, 257, - 0, 249, 0, 87, 87, 245, 0, 0, 97, 125, - 0, 3, 4, 5, 0, 221, 222, 223, 114, 114, - 114, 0, 87, 194, 278, 35, 0, 125, 27, 0, - 28, 16, 0, 87, 87, 82, 83, 16, 16, 82, - 83, 17, 17, 0, 250, 251, 0, 16, 16, 122, - 122, 122, 82, 83, 82, 83, 0, 82, 82, 82, - 82, 82, 82, 82, 82, 82, 296, 0, 82, 82, - 0, 0, 82, 83, 82, 82, 83, 0, 16, 16, - 82, 124, 82, 82, 82, 82, 82, 0, 82, 82, - 82, 82, 82, 82, 82, 82, 82, 0, 82, 124, - 82, 82, 82, 82, 82, 16, 16, 90, 292, 0, - 82, 83, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 23, 0, 60, 60, 302, 0, 18, 18, 60, - 19, 19, 32, 33, 0, 60, 116, 60, 60, 60, +#define YYTABLESIZE 7947 +short yytable[] = { 130, + 82, 279, 82, 280, 97, 313, 121, 307, 6, 95, + 93, 82, 94, 17, 96, 76, 18, 259, 16, 19, + 107, 82, 80, 82, 121, 82, 275, 82, 252, 97, + 85, 47, 122, 123, 95, 154, 155, 82, 77, 96, + 82, 82, 82, 82, 82, 82, 110, 82, 78, 82, + 158, 98, 124, 112, 100, 60, 101, 102, 82, 82, + 82, 98, 82, 82, 306, 56, 194, 101, 102, 99, + 124, 23, 235, 49, 312, 236, 229, 126, 127, 99, + 50, 55, 32, 33, 48, 58, 98, 59, 76, 60, + 253, 169, 60, 82, 82, 259, 60, 60, 60, 60, + 60, 61, 60, 110, 99, 259, 63, 88, 261, 62, + 87, 77, 82, 60, 60, 60, 64, 60, 60, 65, + 79, 78, 112, 82, 82, 88, 121, 81, 88, 131, + 115, 99, 132, 133, 145, 152, 157, 163, 165, 170, + 204, 114, 211, 171, 116, 215, 216, 87, 60, 60, + 87, 87, 87, 87, 217, 87, 263, 87, 218, 114, + 219, 223, 116, 84, 126, 127, 245, 60, 87, 87, + 87, 262, 87, 87, 282, 286, 283, 40, 60, 60, + 303, 304, 305, 299, 234, 310, 311, 316, 1, 300, + 88, 88, 88, 113, 113, 114, 0, 255, 0, 70, + 317, 318, 0, 87, 87, 320, 0, 0, 0, 3, + 4, 5, 118, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 87, 0, 302, 121, 121, 121, 83, 84, + 118, 251, 284, 87, 87, 0, 0, 83, 84, 17, + 17, 92, 18, 18, 0, 19, 19, 83, 84, 83, + 84, 83, 84, 83, 84, 138, 0, 82, 82, 82, + 82, 82, 82, 82, 82, 82, 16, 16, 82, 82, + 153, 124, 124, 124, 82, 83, 84, 226, 227, 228, + 82, 122, 82, 82, 82, 82, 82, 125, 82, 82, + 82, 82, 82, 82, 82, 82, 82, 23, 82, 122, + 82, 82, 82, 82, 82, 125, 196, 197, 32, 33, + 0, 0, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 0, 0, 60, 60, 0, 88, 88, 88, 60, + 0, 88, 0, 0, 0, 60, 115, 60, 60, 60, 60, 60, 0, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 0, 60, 116, 60, 60, 60, 60, 60, - 16, 16, 31, 31, 0, 0, 0, 87, 87, 87, + 60, 60, 0, 60, 115, 60, 60, 60, 60, 60, + 114, 114, 114, 116, 116, 116, 0, 87, 87, 87, 87, 87, 87, 87, 87, 87, 0, 0, 87, 87, - 55, 121, 121, 121, 87, 0, 0, 0, 0, 0, - 87, 0, 87, 87, 87, 87, 87, 118, 87, 87, + 55, 0, 0, 0, 87, 0, 0, 256, 257, 0, + 87, 0, 87, 87, 87, 87, 87, 117, 87, 87, 87, 87, 87, 87, 87, 87, 87, 0, 87, 0, - 87, 87, 87, 87, 87, 118, 0, 55, 0, 0, - 55, 55, 55, 55, 55, 55, 0, 55, 125, 125, - 125, 0, 0, 0, 0, 85, 0, 0, 55, 55, - 0, 0, 55, 55, 11, 0, 0, 255, 12, 13, - 0, 0, 0, 14, 15, 0, 0, 16, 16, 0, - 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, - 0, 21, 85, 55, 55, 33, 85, 85, 85, 85, - 85, 0, 85, 26, 0, 29, 30, 31, 32, 33, - 23, 0, 55, 85, 85, 33, 0, 33, 33, 0, - 124, 124, 124, 55, 55, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 297, 298, - 299, 0, 0, 0, 0, 0, 0, 23, 85, 85, - 23, 23, 23, 23, 23, 23, 0, 23, 311, 312, - 0, 0, 0, 314, 0, 0, 0, 115, 23, 23, - 23, 0, 23, 23, 0, 116, 116, 116, 85, 85, - 0, 0, 0, 52, 0, 115, 0, 0, 0, 16, - 0, 0, 0, 0, 0, 0, 0, 0, 88, 0, + 87, 87, 87, 87, 87, 117, 0, 55, 0, 0, + 55, 55, 55, 55, 55, 55, 0, 55, 0, 0, + 0, 118, 118, 118, 0, 85, 0, 0, 55, 55, + 0, 0, 55, 55, 0, 0, 0, 0, 0, 0, + 0, 0, 298, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 308, + 0, 0, 85, 55, 55, 85, 85, 85, 85, 85, + 85, 0, 85, 0, 0, 0, 0, 0, 0, 0, + 23, 0, 55, 85, 85, 85, 0, 85, 85, 0, + 122, 122, 122, 55, 55, 0, 125, 125, 125, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 23, 85, 85, + 23, 23, 23, 23, 23, 23, 0, 23, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 23, 23, + 23, 0, 23, 23, 0, 115, 115, 115, 85, 85, + 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 23, 0, 0, 0, 0, 0, - 0, 0, 0, 117, 0, 0, 88, 0, 0, 88, - 52, 0, 23, 33, 52, 52, 52, 52, 52, 0, - 52, 117, 0, 23, 23, 16, 118, 118, 118, 0, - 0, 52, 52, 33, 0, 33, 33, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 52, 0, 23, 52, 52, 52, 52, 52, 52, 0, + 52, 0, 0, 23, 23, 0, 117, 117, 117, 0, + 0, 52, 52, 52, 0, 52, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 55, 55, 55, 55, 55, 55, 55, 55, 55, 0, 0, 55, 55, 0, 0, 0, 0, 55, 0, 52, 0, 0, 0, - 55, 88, 55, 55, 55, 55, 55, 0, 55, 55, + 55, 0, 55, 55, 55, 55, 55, 0, 55, 55, 55, 55, 55, 55, 55, 55, 55, 0, 55, 0, 55, 55, 55, 55, 55, 0, 52, 52, 0, 0, - 0, 0, 85, 85, 33, 85, 85, 85, 33, 33, - 85, 0, 0, 33, 33, 0, 0, 0, 0, 85, - 0, 0, 0, 0, 0, 33, 0, 33, 33, 33, - 85, 33, 0, 85, 33, 33, 33, 33, 33, 33, - 33, 33, 0, 33, 0, 33, 33, 33, 33, 33, + 0, 0, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 0, 0, 85, 85, 0, 0, 0, 0, 85, + 0, 0, 0, 0, 0, 85, 0, 85, 85, 85, + 85, 85, 0, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 0, 85, 0, 85, 85, 85, 85, 85, 0, 0, 0, 0, 0, 0, 0, 23, 23, 23, 23, 23, 23, 23, 23, 23, 0, 0, 23, 23, - 0, 0, 0, 0, 23, 0, 115, 115, 115, 0, + 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, 23, 0, 23, 23, 23, 23, 23, 0, 23, 23, 0, 23, 23, 23, 23, 23, 23, 0, 23, 0, - 23, 23, 23, 23, 23, 16, 16, 88, 88, 88, - 0, 0, 88, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 117, 117, 117, 0, 0, 0, 0, 0, - 52, 52, 33, 52, 52, 52, 33, 33, 52, 0, - 0, 33, 33, 51, 0, 0, 0, 52, 0, 0, - 0, 16, 16, 33, 0, 33, 33, 33, 52, 33, - 0, 52, 33, 33, 33, 33, 33, 33, 33, 33, - 0, 33, 0, 33, 33, 33, 33, 33, 0, 0, - 51, 0, 0, 33, 51, 51, 51, 51, 51, 0, - 51, 0, 0, 0, 0, 0, 0, 41, 0, 0, - 0, 51, 51, 33, 0, 33, 33, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 41, 0, 51, 33, 41, 41, - 41, 41, 41, 0, 41, 0, 0, 0, 0, 0, - 0, 42, 0, 0, 0, 41, 41, 33, 0, 33, - 33, 0, 0, 0, 0, 0, 51, 51, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 42, 0, - 41, 33, 42, 42, 42, 42, 42, 0, 42, 0, + 23, 23, 23, 23, 23, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 52, 52, 52, 52, 52, 52, 52, 52, 52, 0, + 0, 52, 52, 37, 0, 0, 0, 52, 0, 0, + 0, 0, 0, 52, 0, 52, 52, 52, 52, 52, + 0, 52, 52, 52, 52, 52, 52, 52, 52, 52, + 0, 52, 0, 52, 52, 52, 52, 52, 0, 0, + 37, 0, 0, 37, 37, 37, 37, 37, 37, 0, + 37, 0, 0, 0, 0, 0, 0, 0, 51, 0, + 0, 37, 37, 37, 0, 37, 37, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 51, 37, 37, 51, 51, + 51, 51, 51, 51, 0, 51, 0, 0, 0, 0, + 0, 0, 42, 0, 0, 37, 51, 51, 51, 0, + 51, 51, 0, 0, 0, 0, 37, 37, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, - 42, 33, 0, 33, 33, 0, 0, 0, 0, 0, - 41, 41, 0, 0, 0, 43, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 42, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 43, 0, 0, 33, 43, 43, 43, 43, - 43, 0, 43, 0, 42, 42, 0, 0, 0, 0, - 0, 0, 0, 43, 43, 33, 0, 33, 33, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 51, 51, 33, 51, 51, 51, 33, 33, 51, 0, - 0, 33, 33, 0, 0, 0, 0, 51, 43, 0, - 0, 0, 0, 33, 0, 33, 33, 33, 51, 33, - 0, 51, 33, 33, 33, 33, 33, 33, 33, 33, - 0, 33, 0, 33, 33, 33, 33, 33, 43, 43, - 0, 0, 0, 0, 41, 41, 33, 41, 41, 41, - 33, 33, 41, 0, 0, 33, 33, 0, 0, 0, - 0, 41, 0, 0, 0, 0, 0, 33, 0, 33, - 33, 33, 41, 33, 0, 41, 33, 33, 33, 33, - 33, 33, 33, 33, 0, 33, 0, 33, 33, 33, - 33, 33, 0, 0, 0, 0, 0, 0, 42, 42, - 33, 42, 42, 42, 33, 33, 42, 0, 0, 33, - 33, 0, 0, 0, 0, 42, 0, 0, 0, 0, - 0, 33, 0, 33, 33, 33, 42, 33, 0, 42, - 33, 33, 33, 33, 33, 33, 33, 33, 0, 33, - 0, 33, 33, 33, 33, 33, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 43, 43, 33, 43, 43, 43, 33, 33, - 43, 0, 0, 33, 33, 44, 0, 0, 0, 43, - 0, 0, 0, 0, 0, 33, 0, 33, 33, 33, - 43, 33, 0, 43, 33, 33, 33, 33, 33, 33, - 33, 33, 0, 33, 0, 33, 33, 33, 33, 33, - 0, 0, 44, 0, 0, 33, 44, 44, 44, 44, - 44, 0, 44, 0, 0, 0, 0, 0, 0, 36, - 0, 0, 0, 44, 44, 33, 0, 33, 33, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 36, 0, 44, 36, - 36, 36, 36, 36, 36, 0, 36, 0, 0, 0, - 0, 0, 0, 0, 35, 0, 0, 36, 36, 36, - 0, 36, 36, 0, 0, 0, 0, 0, 44, 44, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 35, 36, 36, 35, 35, 35, 35, 35, 35, - 0, 35, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 36, 35, 35, 35, 0, 35, 0, 0, 0, - 0, 0, 36, 36, 0, 0, 0, 39, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 35, 35, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 35, 33, 39, 0, - 39, 39, 39, 0, 0, 0, 0, 35, 35, 0, - 0, 0, 0, 0, 0, 39, 39, 33, 0, 33, - 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 44, 44, 33, 44, 44, 44, 33, 33, - 44, 0, 0, 33, 33, 0, 0, 0, 0, 44, - 39, 0, 0, 0, 0, 33, 0, 33, 33, 33, - 44, 33, 0, 44, 33, 33, 33, 33, 33, 33, - 33, 33, 0, 33, 0, 33, 33, 33, 33, 33, - 39, 39, 0, 0, 0, 0, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 0, 0, 36, 36, 0, - 0, 0, 0, 36, 0, 0, 0, 0, 0, 36, - 0, 36, 36, 36, 36, 36, 0, 0, 36, 36, - 36, 36, 36, 36, 36, 36, 0, 36, 0, 36, - 0, 0, 36, 36, 0, 0, 0, 0, 0, 0, - 0, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 0, 0, 35, 35, 0, 0, 0, 0, 35, 0, - 0, 0, 0, 0, 35, 14, 35, 35, 35, 35, - 35, 0, 35, 0, 0, 35, 35, 35, 35, 35, - 35, 0, 35, 0, 35, 35, 35, 35, 35, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 0, 0, 14, 0, - 14, 0, 0, 0, 39, 39, 33, 39, 39, 39, - 33, 33, 39, 40, 14, 33, 33, 0, 0, 0, - 0, 39, 0, 0, 0, 0, 0, 33, 0, 33, - 33, 33, 39, 33, 0, 39, 33, 33, 33, 33, - 33, 33, 33, 33, 0, 33, 0, 33, 33, 33, - 33, 33, 0, 33, 40, 0, 40, 40, 40, 0, - 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 40, 40, 33, 0, 33, 33, 0, 14, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 33, 33, 0, 0, 33, 40, 0, 0, 34, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 33, - 33, 33, 0, 33, 33, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 40, 40, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 33, - 34, 0, 0, 34, 33, 0, 0, 0, 0, 0, - 0, 15, 0, 0, 0, 0, 0, 34, 34, 33, - 0, 33, 33, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 33, 33, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 15, 34, 0, 15, 0, 15, 0, 0, 0, - 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, - 15, 0, 0, 14, 14, 0, 0, 0, 0, 0, - 0, 0, 34, 34, 0, 14, 0, 14, 14, 14, - 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, - 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 40, 40, 33, 40, 40, 40, 33, 33, 40, 0, - 0, 33, 33, 35, 15, 0, 27, 40, 28, 0, - 0, 0, 0, 33, 6, 33, 33, 33, 40, 33, - 0, 40, 33, 33, 33, 33, 33, 33, 33, 33, - 0, 33, 0, 33, 33, 33, 33, 33, 33, 33, - 33, 33, 33, 33, 33, 33, 33, 0, 0, 33, - 33, 0, 0, 0, 6, 0, 0, 6, 0, 6, - 0, 33, 0, 33, 33, 33, 33, 33, 0, 33, - 33, 33, 33, 33, 33, 33, 33, 33, 0, 33, - 0, 33, 33, 33, 33, 33, 34, 34, 33, 34, - 34, 34, 33, 33, 34, 0, 0, 33, 33, 0, - 35, 103, 0, 27, 0, 28, 0, 0, 0, 33, - 0, 33, 33, 33, 34, 33, 0, 34, 33, 33, - 33, 33, 33, 33, 33, 33, 0, 33, 0, 33, - 33, 33, 33, 33, 0, 0, 0, 6, 15, 15, - 15, 15, 15, 15, 15, 15, 12, 0, 0, 15, + 0, 51, 42, 42, 42, 42, 42, 42, 0, 42, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 42, 42, 42, 0, 42, 42, 0, 0, 0, 0, + 0, 51, 51, 0, 0, 43, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 42, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 43, 0, 0, 43, 43, 43, 43, 43, + 43, 0, 43, 0, 0, 42, 42, 0, 0, 0, + 0, 0, 0, 43, 43, 43, 0, 43, 43, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 0, + 0, 37, 37, 0, 0, 0, 0, 37, 43, 0, + 0, 0, 0, 37, 0, 37, 37, 37, 37, 37, + 0, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 0, 37, 0, 37, 0, 0, 37, 37, 43, 43, + 0, 0, 0, 0, 0, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 0, 0, 51, 51, 0, 0, + 0, 0, 51, 0, 0, 0, 0, 0, 51, 0, + 51, 51, 51, 51, 51, 0, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 0, 51, 0, 51, 51, + 51, 51, 51, 0, 0, 0, 0, 0, 0, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 14, 0, + 42, 42, 0, 0, 0, 0, 42, 0, 0, 0, + 0, 0, 42, 0, 42, 42, 42, 42, 42, 0, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, + 42, 0, 42, 42, 42, 42, 42, 0, 14, 0, + 0, 14, 0, 14, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 0, 0, + 0, 0, 43, 43, 43, 43, 43, 43, 43, 43, + 43, 0, 0, 43, 43, 44, 0, 0, 0, 43, + 0, 0, 0, 0, 0, 43, 0, 43, 43, 43, + 43, 43, 0, 43, 43, 43, 43, 43, 43, 43, + 43, 43, 0, 43, 0, 43, 43, 43, 43, 43, + 0, 0, 44, 0, 0, 44, 44, 44, 44, 44, + 44, 14, 44, 0, 0, 0, 0, 0, 0, 45, + 0, 0, 0, 44, 44, 44, 0, 44, 44, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 45, 0, 44, 45, + 45, 45, 45, 45, 45, 0, 45, 0, 0, 0, + 0, 0, 0, 37, 0, 0, 0, 45, 45, 45, + 0, 45, 45, 0, 0, 0, 0, 0, 44, 44, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 37, 0, 45, 37, 37, 37, 37, 37, 37, 0, + 37, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 37, 37, 37, 0, 37, 37, 0, 0, 0, + 0, 0, 45, 45, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 14, 14, 0, 0, + 0, 0, 0, 0, 0, 0, 37, 37, 14, 0, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, + 14, 14, 14, 0, 0, 37, 14, 0, 14, 14, + 14, 14, 14, 0, 0, 0, 37, 37, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 44, 44, 44, 44, 44, 44, 44, 44, + 44, 0, 0, 44, 44, 0, 0, 0, 0, 44, + 0, 66, 0, 0, 27, 44, 28, 44, 44, 44, + 44, 44, 0, 44, 44, 44, 44, 44, 44, 44, + 44, 44, 0, 44, 0, 44, 44, 44, 44, 44, + 0, 0, 0, 0, 0, 0, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 0, 0, 45, 45, 0, + 0, 0, 0, 45, 0, 0, 0, 0, 0, 45, + 0, 45, 45, 45, 45, 45, 0, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 0, 45, 0, 45, + 45, 45, 45, 45, 35, 0, 0, 27, 0, 28, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 0, + 0, 37, 37, 36, 0, 0, 0, 37, 0, 0, + 0, 0, 0, 37, 0, 37, 37, 37, 37, 37, + 0, 0, 37, 37, 37, 37, 37, 37, 37, 37, + 0, 37, 0, 37, 0, 0, 37, 37, 0, 0, + 36, 0, 0, 36, 36, 36, 36, 36, 36, 0, + 36, 0, 0, 0, 0, 0, 0, 0, 40, 0, + 0, 36, 36, 36, 0, 36, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 36, 36, 40, 40, + 0, 40, 40, 40, 0, 0, 0, 0, 0, 41, + 0, 0, 0, 0, 0, 36, 40, 40, 40, 0, + 40, 40, 0, 0, 12, 13, 36, 36, 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 16, 0, 17, 18, 19, 0, 21, 0, 41, + 41, 40, 41, 41, 41, 0, 0, 33, 0, 26, + 0, 0, 30, 31, 32, 33, 0, 41, 41, 41, + 0, 41, 41, 0, 0, 0, 0, 0, 0, 0, + 0, 40, 40, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 33, 33, 0, + 0, 33, 41, 11, 0, 126, 127, 12, 13, 0, + 0, 15, 14, 15, 0, 33, 33, 33, 0, 33, + 33, 0, 0, 0, 16, 0, 17, 18, 19, 0, + 21, 0, 41, 41, 0, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 29, 30, 31, 32, 33, 0, + 33, 15, 0, 0, 15, 0, 15, 0, 0, 0, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 7, + 15, 36, 36, 0, 0, 0, 0, 36, 0, 0, + 33, 33, 0, 36, 0, 36, 36, 36, 36, 36, + 0, 36, 0, 0, 36, 36, 36, 36, 36, 36, + 0, 36, 0, 36, 36, 36, 36, 36, 0, 7, + 0, 0, 7, 0, 7, 40, 40, 40, 40, 40, + 40, 40, 40, 40, 0, 0, 40, 40, 7, 0, + 0, 0, 40, 0, 15, 0, 0, 0, 40, 6, + 40, 40, 40, 40, 40, 0, 40, 40, 40, 40, + 40, 40, 40, 40, 40, 0, 40, 0, 40, 40, + 40, 40, 40, 0, 0, 0, 41, 41, 41, 41, + 41, 41, 41, 41, 41, 0, 0, 41, 41, 6, + 0, 0, 6, 41, 6, 0, 0, 0, 0, 41, + 0, 41, 41, 41, 41, 41, 0, 41, 41, 41, + 41, 41, 41, 41, 41, 41, 0, 41, 0, 41, + 41, 41, 41, 41, 33, 33, 33, 33, 33, 33, + 33, 33, 33, 34, 0, 33, 33, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 33, 0, 33, + 33, 33, 33, 33, 0, 33, 33, 33, 33, 33, + 33, 33, 33, 33, 0, 33, 0, 33, 33, 33, + 33, 33, 6, 34, 34, 0, 0, 34, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 12, 0, 15, + 15, 34, 34, 34, 0, 34, 34, 0, 0, 0, 0, 15, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 15, - 0, 15, 15, 15, 15, 15, 12, 0, 0, 12, - 0, 12, 0, 0, 7, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 12, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 11, 0, 123, 124, 12, 13, 0, 0, - 0, 14, 15, 0, 7, 0, 0, 7, 0, 7, - 0, 0, 0, 16, 5, 17, 18, 19, 0, 21, - 0, 0, 0, 7, 22, 23, 24, 25, 0, 0, - 0, 26, 0, 29, 30, 31, 32, 33, 0, 12, - 0, 6, 6, 6, 0, 0, 0, 6, 6, 0, - 0, 0, 6, 6, 5, 0, 0, 5, 0, 5, - 0, 0, 0, 2, 6, 0, 6, 6, 6, 6, - 6, 0, 0, 0, 0, 6, 6, 6, 6, 0, - 0, 0, 6, 0, 6, 6, 6, 6, 6, 11, - 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, - 0, 0, 0, 2, 0, 0, 2, 0, 2, 0, - 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, - 0, 22, 23, 24, 25, 0, 0, 0, 26, 0, - 29, 30, 31, 32, 33, 0, 0, 5, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 12, 12, 12, 12, 0, 12, 12, - 12, 0, 0, 0, 12, 12, 2, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 12, 0, 12, 12, - 12, 12, 12, 0, 0, 0, 0, 12, 12, 12, - 12, 0, 0, 0, 12, 0, 12, 12, 12, 12, - 12, 7, 7, 7, 7, 7, 7, 7, 7, 0, - 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 7, 0, 7, 7, 7, 7, - 7, 0, 0, 0, 0, 7, 7, 7, 7, 0, - 0, 0, 7, 0, 7, 7, 7, 7, 7, 0, + 0, 15, 15, 15, 15, 15, 34, 12, 0, 0, + 12, 0, 12, 0, 0, 0, 7, 7, 7, 7, + 7, 7, 7, 7, 5, 0, 12, 7, 7, 0, + 0, 0, 0, 0, 0, 0, 34, 34, 0, 7, + 0, 7, 7, 7, 7, 7, 0, 0, 0, 0, + 7, 7, 7, 7, 0, 0, 0, 7, 0, 7, + 7, 7, 7, 7, 5, 0, 0, 5, 0, 5, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 6, 6, 6, 0, + 12, 0, 6, 6, 0, 2, 0, 6, 6, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, + 0, 6, 6, 6, 6, 6, 0, 0, 0, 0, + 6, 6, 6, 6, 0, 0, 0, 6, 0, 6, + 6, 6, 6, 6, 0, 2, 0, 0, 2, 0, + 2, 0, 0, 0, 0, 0, 0, 5, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 34, 34, 34, 34, 34, 34, 34, 34, 34, 0, + 0, 34, 34, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 34, 0, 34, 34, 34, 34, 34, + 0, 34, 34, 34, 34, 34, 34, 34, 34, 34, + 0, 34, 0, 34, 34, 34, 34, 34, 2, 0, + 0, 0, 0, 0, 12, 12, 12, 12, 0, 12, + 12, 12, 0, 0, 0, 12, 12, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 12, 0, 12, + 12, 12, 12, 12, 0, 0, 0, 0, 12, 12, + 12, 12, 0, 0, 0, 12, 0, 12, 12, 12, + 12, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 5, 5, 0, 0, 0, 5, 5, 0, - 0, 0, 5, 5, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 5, 0, 5, 5, 5, 5, - 5, 0, 0, 0, 0, 5, 5, 5, 5, 0, + 0, 0, 5, 5, 0, 0, 66, 237, 0, 27, + 238, 28, 0, 0, 5, 0, 5, 5, 5, 5, + 5, 0, 0, 0, 0, 5, 5, 5, 5, 86, 0, 0, 5, 0, 5, 5, 5, 5, 5, 0, - 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, - 0, 2, 2, 58, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 66, 239, 0, 27, 240, 28, 0, + 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, + 0, 0, 0, 2, 2, 58, 86, 0, 0, 0, + 0, 0, 0, 0, 0, 2, 0, 2, 2, 2, + 2, 2, 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 2, 0, 2, 2, 2, 2, 2, - 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, - 0, 2, 0, 2, 2, 2, 2, 2, 0, 0, - 58, 0, 0, 58, 58, 58, 58, 58, 58, 0, - 58, 0, 0, 0, 0, 0, 0, 0, 54, 0, - 0, 58, 58, 58, 0, 58, 58, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 54, 58, 58, 54, 54, - 54, 54, 54, 54, 0, 54, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 58, 54, 54, 0, 0, - 54, 54, 0, 0, 0, 0, 58, 58, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 54, 54, 0, 0, 0, 0, 56, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 54, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 54, 54, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 0, 0, 56, 56, - 0, 56, 0, 0, 56, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 56, 56, 56, 0, 56, - 16, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 56, 56, 0, 0, 0, 0, 0, 0, 0, 0, - 58, 58, 58, 58, 58, 58, 58, 58, 58, 56, - 0, 58, 58, 0, 0, 0, 0, 58, 0, 0, - 56, 56, 0, 58, 0, 58, 58, 58, 58, 58, - 0, 58, 58, 58, 58, 0, 58, 58, 58, 58, - 0, 58, 0, 58, 58, 58, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 54, 54, 54, 54, 54, - 54, 54, 54, 54, 0, 0, 54, 54, 54, 0, - 0, 0, 54, 0, 0, 0, 0, 0, 54, 0, - 54, 54, 54, 54, 54, 0, 54, 54, 54, 54, - 0, 54, 54, 54, 54, 0, 54, 0, 54, 54, - 54, 0, 0, 104, 54, 106, 0, 0, 0, 0, - 110, 111, 0, 114, 116, 117, 0, 54, 54, 121, - 122, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 132, 0, 0, 0, 137, - 138, 139, 140, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 56, 0, 56, 56, 56, - 0, 0, 56, 0, 0, 0, 158, 0, 0, 0, - 0, 56, 54, 0, 0, 0, 0, 0, 0, 186, - 0, 0, 56, 0, 0, 56, 16, 16, 56, 56, - 56, 56, 56, 56, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 186, 186, 0, 0, 0, 197, - 198, 0, 0, 200, 201, 202, 203, 205, 0, 0, - 0, 0, 207, 208, 0, 54, 54, 0, 0, 0, - 215, 0, 0, 0, 216, 0, 25, 0, 0, 0, - 0, 0, 0, 0, 186, 227, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 252, 0, - 0, 186, 0, 25, 0, 0, 27, 25, 25, 0, - 25, 0, 0, 25, 264, 0, 265, 0, 266, 0, - 267, 0, 268, 0, 25, 25, 25, 270, 25, 16, - 0, 0, 271, 272, 0, 0, 0, 0, 0, 0, - 54, 186, 0, 27, 0, 0, 0, 27, 27, 0, - 27, 0, 0, 27, 26, 0, 0, 0, 0, 25, - 25, 0, 0, 0, 27, 27, 27, 0, 27, 16, - 0, 0, 186, 186, 186, 186, 0, 0, 25, 0, - 186, 0, 0, 0, 0, 186, 0, 0, 0, 25, - 25, 26, 186, 186, 57, 26, 26, 186, 26, 27, - 27, 26, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 26, 26, 26, 0, 26, 16, 27, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 27, - 27, 57, 0, 0, 0, 57, 57, 0, 57, 0, - 0, 57, 0, 0, 0, 0, 0, 26, 26, 0, - 0, 0, 57, 57, 57, 0, 57, 16, 0, 0, - 0, 0, 0, 0, 0, 0, 26, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 26, 26, 35, - 0, 0, 27, 0, 28, 0, 0, 57, 57, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 87, - 0, 88, 0, 0, 0, 0, 57, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 57, 57, 0, - 0, 0, 0, 25, 25, 0, 25, 25, 25, 0, - 0, 25, 0, 0, 0, 0, 0, 0, 0, 0, - 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 25, 0, 0, 25, 16, 16, 25, 25, 25, - 25, 25, 25, 27, 27, 0, 27, 27, 27, 0, - 0, 27, 0, 0, 0, 0, 0, 0, 0, 0, - 27, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 27, 0, 0, 27, 16, 16, 27, 27, 27, - 27, 27, 27, 0, 0, 0, 0, 0, 0, 0, - 0, 26, 26, 0, 26, 26, 26, 0, 0, 26, - 0, 0, 0, 0, 0, 0, 0, 0, 26, 0, - 0, 0, 0, 88, 0, 0, 0, 0, 0, 26, - 0, 0, 26, 16, 16, 26, 26, 26, 26, 26, - 26, 57, 57, 0, 57, 57, 57, 0, 0, 57, - 0, 0, 0, 0, 0, 0, 0, 0, 57, 0, - 88, 0, 0, 29, 88, 88, 0, 88, 0, 57, - 88, 0, 57, 16, 16, 57, 57, 57, 57, 57, - 57, 88, 88, 88, 0, 88, 88, 0, 11, 0, + 0, 0, 58, 0, 0, 58, 58, 58, 58, 58, + 58, 0, 58, 0, 0, 0, 0, 0, 0, 0, + 54, 0, 0, 58, 58, 58, 0, 58, 58, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 54, 58, 58, + 54, 54, 54, 54, 54, 54, 0, 54, 56, 0, + 0, 0, 0, 0, 0, 0, 0, 58, 54, 54, + 0, 0, 54, 54, 0, 0, 0, 0, 58, 58, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 56, 0, 0, 0, 56, + 56, 0, 56, 54, 54, 56, 0, 0, 0, 12, + 13, 0, 0, 0, 14, 15, 56, 56, 56, 0, + 56, 56, 54, 0, 0, 0, 16, 0, 17, 18, + 19, 0, 21, 54, 54, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 56, 56, 0, 0, 0, 12, 13, 0, 0, + 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, + 56, 0, 0, 16, 0, 17, 18, 19, 0, 21, + 0, 56, 56, 0, 22, 23, 24, 25, 0, 0, + 0, 26, 0, 0, 30, 31, 32, 33, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 0, 0, 58, 58, 0, 0, 0, 0, 58, + 0, 0, 0, 0, 0, 58, 0, 58, 58, 58, + 58, 58, 0, 58, 58, 58, 58, 0, 58, 58, + 58, 58, 0, 58, 0, 58, 58, 58, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 54, 54, 54, + 54, 54, 54, 54, 54, 54, 0, 0, 54, 54, + 0, 0, 0, 0, 54, 0, 0, 0, 0, 0, + 54, 0, 54, 54, 54, 54, 54, 29, 54, 54, + 54, 54, 0, 54, 54, 54, 54, 0, 54, 0, + 54, 54, 54, 0, 0, 56, 56, 56, 56, 56, + 56, 0, 0, 56, 0, 0, 0, 0, 0, 0, + 0, 0, 56, 0, 29, 0, 0, 0, 29, 29, + 0, 29, 25, 56, 29, 0, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 29, 29, 29, 56, 29, + 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 25, + 0, 0, 0, 25, 25, 0, 25, 27, 0, 25, + 29, 29, 0, 0, 0, 0, 0, 0, 0, 0, + 25, 25, 25, 0, 25, 25, 0, 0, 0, 29, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 29, 29, 0, 0, 27, 0, 0, 0, 27, 27, + 0, 27, 0, 0, 27, 25, 25, 0, 0, 0, + 0, 0, 0, 0, 0, 27, 27, 27, 0, 27, + 27, 0, 0, 0, 25, 0, 26, 0, 0, 0, + 0, 0, 0, 0, 0, 25, 25, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 27, 27, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 26, 0, 0, 0, 26, 26, 27, + 26, 0, 0, 26, 0, 0, 0, 0, 0, 0, + 27, 27, 0, 0, 26, 26, 26, 0, 26, 26, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 26, + 26, 0, 0, 0, 29, 29, 29, 29, 29, 29, + 0, 0, 29, 0, 0, 0, 0, 0, 26, 0, + 0, 29, 0, 0, 0, 0, 0, 0, 0, 26, + 26, 0, 29, 0, 0, 29, 29, 29, 29, 29, + 29, 29, 29, 29, 0, 0, 0, 29, 0, 25, + 25, 25, 25, 25, 25, 0, 0, 25, 0, 0, + 0, 0, 0, 0, 0, 0, 25, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 25, 0, 0, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 0, + 0, 0, 25, 0, 27, 27, 27, 27, 27, 27, + 0, 0, 27, 0, 0, 0, 0, 0, 0, 0, + 0, 27, 0, 0, 57, 0, 0, 0, 0, 0, + 0, 0, 27, 0, 0, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 0, 0, 0, 27, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 57, 103, 104, 0, 57, 57, 0, 57, 0, + 0, 57, 0, 26, 26, 26, 26, 26, 26, 0, + 0, 26, 57, 57, 57, 0, 57, 57, 0, 0, + 26, 88, 0, 0, 0, 0, 134, 0, 136, 137, + 0, 26, 0, 0, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 0, 0, 0, 26, 57, 57, 0, + 0, 0, 0, 0, 0, 0, 159, 160, 88, 0, + 0, 0, 88, 88, 0, 88, 57, 0, 88, 89, + 0, 0, 0, 0, 0, 0, 0, 57, 57, 88, + 88, 88, 0, 88, 88, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, + 89, 89, 0, 89, 88, 88, 89, 0, 0, 214, + 0, 0, 0, 0, 0, 0, 0, 89, 89, 89, + 222, 89, 224, 88, 225, 0, 0, 0, 0, 0, + 0, 90, 0, 0, 88, 88, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 247, 0, 0, 0, + 0, 0, 89, 89, 0, 0, 0, 0, 0, 0, + 0, 264, 265, 266, 267, 268, 0, 0, 90, 0, + 0, 89, 90, 90, 0, 90, 0, 0, 90, 0, + 0, 0, 89, 89, 0, 0, 0, 0, 0, 90, + 90, 90, 0, 90, 0, 0, 0, 0, 0, 0, + 0, 57, 57, 57, 57, 57, 57, 0, 0, 57, + 292, 0, 0, 0, 294, 295, 296, 0, 57, 20, + 301, 0, 0, 0, 90, 90, 0, 0, 0, 57, + 0, 0, 57, 57, 57, 57, 57, 57, 57, 57, + 57, 0, 0, 90, 57, 314, 315, 0, 0, 0, + 0, 319, 0, 0, 90, 90, 20, 0, 0, 0, + 20, 20, 0, 20, 0, 0, 20, 0, 88, 88, + 88, 88, 88, 88, 0, 0, 88, 20, 20, 20, + 0, 20, 0, 0, 0, 88, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 88, 0, 0, 88, + 88, 88, 0, 0, 0, 0, 88, 88, 0, 0, + 0, 88, 20, 20, 0, 0, 89, 89, 89, 89, + 89, 89, 0, 0, 89, 0, 0, 0, 0, 66, + 156, 20, 27, 89, 28, 0, 0, 0, 0, 35, + 0, 0, 20, 20, 89, 0, 0, 89, 89, 89, + 0, 0, 86, 0, 89, 89, 0, 0, 0, 89, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 35, 0, 0, 0, + 35, 35, 0, 35, 0, 0, 35, 0, 90, 90, + 90, 90, 90, 90, 0, 0, 90, 35, 35, 35, + 0, 35, 0, 0, 0, 90, 86, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 90, 0, 0, 90, + 90, 90, 0, 0, 0, 0, 90, 90, 0, 0, + 0, 90, 35, 35, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 86, 0, 0, 0, 86, 86, 0, + 0, 35, 0, 86, 16, 0, 0, 0, 0, 0, + 0, 0, 35, 35, 86, 86, 86, 0, 86, 0, + 0, 0, 0, 0, 0, 0, 20, 20, 20, 20, + 20, 20, 0, 0, 20, 0, 0, 0, 0, 0, + 0, 16, 0, 20, 0, 16, 16, 0, 16, 86, + 86, 16, 0, 0, 20, 0, 0, 20, 20, 20, + 0, 0, 16, 16, 20, 20, 0, 0, 86, 20, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 16, 16, 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, - 29, 0, 0, 0, 29, 29, 0, 29, 16, 16, - 29, 17, 18, 19, 0, 21, 88, 88, 0, 0, - 0, 29, 29, 0, 0, 86, 16, 26, 0, 29, - 30, 31, 32, 33, 0, 88, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 16, 88, 88, 89, 16, - 16, 0, 16, 0, 0, 16, 29, 29, 0, 0, - 0, 0, 0, 0, 0, 0, 16, 16, 0, 0, - 0, 16, 0, 0, 0, 29, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 89, 29, 29, 0, 89, - 89, 0, 89, 90, 0, 89, 0, 0, 0, 0, - 0, 16, 16, 0, 0, 0, 89, 89, 0, 0, - 0, 16, 0, 0, 0, 0, 0, 0, 0, 0, - 16, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 90, 16, 16, 0, 90, 90, 0, 90, 0, 0, - 90, 89, 89, 0, 0, 0, 0, 0, 0, 0, - 0, 90, 90, 0, 0, 0, 16, 0, 0, 0, - 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 89, 89, 0, 35, 231, 0, 27, 232, 28, - 88, 88, 0, 88, 88, 88, 90, 90, 88, 0, - 0, 0, 0, 0, 87, 0, 88, 88, 0, 0, - 0, 0, 0, 0, 0, 90, 0, 0, 88, 0, - 0, 88, 88, 88, 0, 0, 90, 90, 88, 88, - 29, 29, 0, 29, 29, 29, 0, 0, 29, 0, - 0, 0, 0, 0, 0, 0, 0, 29, 0, 0, - 35, 0, 0, 27, 0, 28, 0, 0, 29, 0, - 0, 29, 16, 16, 29, 29, 29, 29, 29, 185, - 0, 0, 0, 0, 0, 16, 16, 0, 16, 16, - 16, 0, 0, 16, 0, 0, 0, 0, 0, 0, - 0, 0, 16, 20, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 16, 0, 0, 16, 16, 16, 0, - 0, 0, 0, 0, 0, 89, 89, 0, 89, 89, - 89, 0, 0, 89, 0, 0, 0, 0, 0, 0, - 20, 0, 89, 183, 20, 20, 0, 20, 86, 0, - 20, 0, 0, 89, 0, 0, 89, 16, 16, 0, - 0, 20, 20, 0, 0, 0, 16, 0, 0, 0, - 90, 90, 0, 90, 90, 90, 0, 0, 90, 0, - 0, 0, 0, 0, 0, 86, 0, 90, 0, 86, - 86, 0, 0, 0, 0, 86, 20, 20, 90, 0, - 0, 90, 16, 16, 0, 0, 86, 86, 0, 0, - 0, 16, 0, 11, 0, 20, 0, 12, 13, 0, - 0, 0, 14, 15, 0, 110, 20, 20, 110, 0, - 110, 0, 0, 0, 16, 0, 17, 18, 19, 0, - 21, 86, 86, 0, 110, 22, 23, 24, 25, 85, - 86, 0, 26, 0, 29, 30, 31, 32, 33, 0, + 0, 0, 0, 0, 0, 0, 16, 0, 0, 16, + 0, 17, 18, 19, 0, 21, 0, 16, 16, 0, + 22, 23, 24, 25, 0, 0, 0, 26, 0, 0, + 30, 31, 32, 33, 0, 0, 35, 35, 35, 35, + 35, 35, 0, 0, 35, 0, 0, 0, 0, 0, + 0, 0, 0, 35, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 35, 0, 0, 35, 35, 35, + 0, 0, 0, 0, 35, 35, 0, 0, 0, 35, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 86, 86, 86, 86, 86, 86, 0, + 0, 86, 0, 0, 0, 0, 0, 0, 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 86, 86, 0, 0, 0, 0, 0, 0, 11, - 170, 123, 124, 12, 13, 0, 171, 172, 14, 15, - 173, 0, 174, 175, 0, 176, 177, 178, 179, 180, - 16, 181, 17, 18, 19, 0, 21, 182, 110, 0, - 110, 22, 23, 24, 25, 0, 0, 0, 26, 0, - 29, 30, 31, 32, 33, 0, 0, 0, 0, 109, - 0, 0, 109, 0, 109, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 109, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 20, 20, 0, 20, 20, 20, 0, 0, 20, 0, - 0, 0, 0, 0, 0, 0, 0, 20, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 20, 0, - 0, 20, 16, 16, 0, 0, 0, 103, 0, 0, - 103, 0, 103, 0, 0, 86, 86, 0, 86, 86, - 86, 0, 109, 86, 109, 0, 103, 0, 0, 0, - 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 86, 0, 0, 86, 16, 16, 0, - 0, 0, 0, 0, 110, 110, 0, 0, 110, 110, - 0, 110, 110, 110, 110, 110, 110, 110, 110, 0, - 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, - 0, 110, 110, 0, 0, 0, 110, 110, 110, 110, - 103, 0, 103, 110, 0, 110, 110, 110, 110, 110, - 0, 0, 0, 0, 104, 0, 0, 104, 0, 104, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 104, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 51, 0, 0, 27, 0, 28, 109, 109, - 0, 0, 109, 109, 0, 109, 109, 109, 109, 109, - 109, 109, 109, 0, 109, 109, 109, 109, 109, 109, - 109, 109, 109, 109, 0, 109, 109, 104, 0, 104, - 109, 109, 109, 109, 0, 0, 0, 109, 0, 109, - 109, 109, 109, 109, 105, 0, 0, 105, 0, 105, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 105, 0, 0, 103, 103, 0, 0, - 103, 103, 0, 103, 103, 103, 103, 103, 103, 103, - 103, 0, 103, 103, 103, 103, 103, 103, 103, 103, - 103, 103, 0, 103, 103, 0, 0, 0, 103, 103, - 103, 103, 0, 0, 0, 103, 0, 103, 103, 103, - 103, 103, 0, 0, 0, 0, 102, 0, 0, 102, - 0, 102, 0, 0, 0, 0, 0, 105, 0, 105, - 0, 0, 0, 0, 0, 102, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 104, 104, 0, 0, 104, 104, 0, - 104, 104, 104, 104, 104, 104, 104, 104, 0, 104, - 104, 104, 104, 104, 104, 104, 104, 104, 104, 0, - 104, 104, 0, 0, 0, 104, 104, 104, 104, 102, - 0, 102, 104, 0, 104, 104, 104, 104, 104, 108, - 0, 11, 108, 0, 108, 12, 13, 0, 0, 0, - 14, 15, 0, 0, 0, 0, 0, 0, 108, 0, - 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, - 0, 0, 0, 22, 23, 24, 25, 0, 0, 0, - 26, 0, 29, 30, 31, 32, 33, 35, 0, 0, - 27, 0, 28, 105, 105, 0, 0, 105, 105, 0, + 0, 86, 0, 0, 86, 86, 86, 0, 0, 0, + 0, 86, 86, 0, 0, 0, 86, 0, 0, 0, + 0, 16, 16, 16, 16, 16, 16, 0, 41, 16, + 0, 0, 0, 0, 0, 53, 0, 0, 16, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, + 41, 0, 16, 16, 16, 0, 41, 0, 0, 0, + 0, 0, 0, 0, 16, 0, 0, 0, 0, 0, + 106, 53, 109, 0, 0, 0, 113, 114, 0, 117, + 119, 120, 0, 53, 53, 124, 125, 41, 0, 0, + 0, 0, 0, 0, 0, 66, 0, 0, 27, 0, + 28, 0, 0, 135, 0, 0, 41, 139, 141, 142, + 143, 144, 0, 0, 189, 0, 0, 0, 0, 0, + 0, 41, 0, 0, 0, 0, 0, 0, 0, 109, + 0, 0, 0, 0, 0, 0, 162, 0, 0, 0, + 110, 0, 53, 110, 0, 110, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 41, 41, 110, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 187, 0, + 202, 203, 0, 0, 205, 206, 207, 208, 210, 0, + 0, 0, 0, 212, 213, 109, 53, 53, 109, 0, + 109, 220, 0, 0, 0, 221, 0, 0, 0, 0, + 0, 0, 0, 0, 109, 0, 232, 0, 0, 233, + 0, 0, 0, 110, 0, 110, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 41, 41, + 258, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 270, 0, 271, + 0, 272, 0, 273, 0, 274, 0, 0, 0, 103, + 276, 0, 103, 0, 103, 277, 278, 0, 109, 0, + 109, 0, 0, 53, 0, 0, 0, 0, 103, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 41, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 174, 126, 127, 12, 13, + 41, 175, 176, 14, 15, 177, 0, 178, 179, 0, + 180, 181, 182, 183, 184, 16, 185, 17, 18, 19, + 0, 21, 186, 0, 0, 0, 22, 23, 24, 25, + 0, 0, 103, 26, 103, 0, 30, 31, 32, 33, + 110, 0, 0, 110, 110, 0, 110, 110, 110, 110, + 110, 110, 110, 110, 0, 110, 110, 110, 110, 110, + 110, 110, 110, 110, 110, 0, 110, 110, 0, 0, + 0, 110, 110, 110, 110, 0, 0, 0, 110, 0, + 0, 110, 110, 110, 110, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 109, 0, 0, 109, 109, + 0, 109, 109, 109, 109, 109, 109, 109, 109, 0, + 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, + 0, 109, 109, 0, 0, 0, 109, 109, 109, 109, + 0, 0, 0, 109, 0, 0, 109, 109, 109, 109, + 104, 0, 0, 104, 0, 104, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 104, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 103, + 0, 0, 103, 103, 0, 103, 103, 103, 103, 103, + 103, 103, 103, 0, 103, 103, 103, 103, 103, 103, + 103, 103, 103, 103, 0, 103, 103, 0, 0, 0, + 103, 103, 103, 103, 0, 0, 0, 103, 0, 0, + 103, 103, 103, 103, 105, 0, 0, 105, 0, 105, + 0, 0, 0, 104, 0, 104, 0, 0, 0, 0, + 0, 0, 0, 105, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, + 0, 0, 102, 0, 102, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 102, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 105, 0, 105, + 0, 0, 0, 0, 0, 108, 0, 0, 108, 0, + 108, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 108, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 102, 0, 102, 0, 0, 0, 66, 105, + 0, 27, 0, 28, 0, 0, 0, 0, 0, 0, + 104, 0, 0, 104, 104, 0, 104, 104, 104, 104, + 104, 104, 104, 104, 0, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 0, 104, 104, 108, 0, + 108, 104, 104, 104, 104, 0, 0, 0, 104, 0, + 0, 104, 104, 104, 104, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 105, 0, 0, 105, 105, 0, 105, 105, 105, 105, 105, 105, 105, 105, 0, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 0, - 105, 105, 108, 0, 108, 105, 105, 105, 105, 0, - 0, 0, 105, 0, 105, 105, 105, 105, 105, 137, - 0, 0, 137, 0, 137, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 137, 0, - 0, 0, 0, 0, 0, 102, 102, 0, 0, 102, - 102, 0, 102, 102, 102, 102, 102, 102, 102, 102, - 0, 102, 102, 102, 102, 102, 102, 102, 102, 102, - 102, 0, 102, 102, 0, 0, 0, 102, 102, 102, - 102, 0, 0, 0, 102, 0, 102, 102, 102, 102, - 102, 35, 0, 0, 27, 0, 28, 0, 0, 0, - 0, 0, 137, 0, 137, 0, 0, 0, 0, 0, - 185, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 108, 108, - 0, 0, 108, 108, 0, 108, 108, 108, 108, 108, - 108, 108, 108, 0, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 0, 108, 108, 0, 0, 0, - 108, 108, 108, 108, 183, 0, 184, 108, 0, 108, - 108, 108, 108, 108, 35, 0, 11, 27, 0, 28, - 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, - 0, 0, 0, 185, 0, 0, 0, 16, 0, 17, - 18, 19, 0, 21, 0, 0, 0, 0, 22, 23, - 24, 25, 0, 0, 0, 26, 0, 29, 30, 31, - 32, 33, 35, 0, 0, 27, 0, 28, 137, 137, - 0, 0, 137, 137, 0, 137, 137, 137, 137, 137, - 137, 137, 137, 0, 137, 137, 137, 137, 137, 137, - 137, 137, 137, 137, 0, 137, 137, 183, 0, 195, - 137, 137, 137, 137, 0, 0, 0, 137, 0, 137, - 137, 137, 137, 137, 35, 0, 0, 27, 0, 28, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 185, 0, 0, 0, 0, 0, 0, - 11, 170, 0, 0, 12, 13, 0, 171, 172, 14, - 15, 173, 0, 174, 175, 0, 176, 177, 178, 179, - 180, 16, 181, 17, 18, 19, 0, 21, 182, 0, - 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, - 0, 29, 30, 31, 32, 33, 35, 0, 0, 27, - 0, 28, 0, 0, 0, 0, 0, 183, 0, 196, - 0, 0, 0, 0, 0, 185, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 11, 170, 0, 0, 12, 13, 0, - 171, 172, 14, 15, 173, 0, 174, 175, 0, 176, - 177, 178, 179, 180, 16, 181, 17, 18, 19, 0, - 21, 182, 0, 0, 0, 22, 23, 24, 25, 183, - 0, 226, 26, 0, 29, 30, 31, 32, 33, 35, - 0, 113, 27, 0, 28, 12, 13, 0, 0, 0, - 14, 15, 0, 0, 0, 0, 0, 0, 185, 0, - 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, - 0, 0, 0, 22, 23, 24, 25, 0, 0, 0, - 26, 0, 29, 30, 31, 32, 33, 0, 0, 0, - 0, 0, 0, 11, 170, 0, 0, 12, 13, 0, - 171, 172, 14, 15, 173, 0, 174, 175, 0, 176, - 177, 178, 179, 180, 16, 181, 17, 18, 19, 0, - 21, 182, 183, 0, 279, 22, 23, 24, 25, 0, - 0, 0, 26, 0, 29, 30, 31, 32, 33, 35, - 0, 0, 27, 0, 28, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 185, 0, - 0, 0, 0, 0, 0, 11, 170, 0, 0, 12, - 13, 0, 171, 172, 14, 15, 173, 0, 174, 175, - 0, 176, 177, 178, 179, 180, 16, 181, 17, 18, - 19, 0, 21, 182, 0, 0, 0, 22, 23, 24, - 25, 0, 0, 0, 26, 0, 29, 30, 31, 32, - 33, 107, 0, 0, 107, 0, 107, 0, 0, 0, - 0, 0, 183, 0, 303, 0, 0, 0, 0, 0, - 107, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 11, 170, - 0, 0, 12, 13, 0, 171, 172, 14, 15, 173, - 0, 174, 175, 0, 176, 177, 178, 179, 180, 16, - 181, 17, 18, 19, 0, 21, 182, 0, 0, 0, - 22, 23, 24, 25, 107, 0, 107, 26, 0, 29, - 30, 31, 32, 33, 130, 0, 0, 130, 0, 130, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 130, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 35, 0, 0, 27, 0, 28, 0, 0, 11, 170, - 0, 0, 12, 13, 0, 171, 172, 14, 15, 173, - 0, 174, 175, 0, 176, 177, 178, 179, 180, 16, - 181, 17, 18, 19, 0, 21, 182, 130, 0, 130, - 22, 23, 24, 25, 0, 0, 0, 26, 0, 29, - 30, 31, 32, 33, 35, 233, 0, 27, 234, 28, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 87, 0, 88, 0, 0, 0, - 107, 107, 0, 0, 107, 107, 0, 107, 107, 107, - 107, 107, 0, 107, 107, 0, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 0, 107, 107, 0, - 0, 0, 107, 107, 107, 107, 0, 0, 0, 107, - 0, 107, 107, 107, 107, 107, 35, 235, 0, 27, - 236, 28, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 87, 0, 88, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 130, 130, 0, 0, 130, 130, 0, - 130, 130, 130, 130, 130, 0, 130, 130, 0, 130, - 130, 130, 130, 130, 130, 130, 130, 130, 130, 0, - 130, 130, 0, 0, 0, 130, 130, 130, 130, 0, - 0, 0, 130, 0, 130, 130, 130, 130, 130, 11, - 0, 0, 0, 12, 13, 0, 171, 172, 14, 15, - 0, 0, 0, 0, 0, 176, 177, 178, 179, 180, - 16, 0, 17, 18, 19, 0, 21, 182, 0, 0, + 105, 105, 0, 0, 0, 105, 105, 105, 105, 0, + 0, 0, 105, 0, 0, 105, 105, 105, 105, 102, + 0, 0, 102, 102, 0, 102, 102, 102, 102, 102, + 102, 102, 102, 0, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 35, 102, 102, 27, 0, 28, + 102, 102, 102, 102, 0, 0, 0, 102, 0, 0, + 102, 102, 102, 102, 0, 108, 0, 0, 108, 108, + 0, 108, 108, 108, 108, 108, 108, 108, 108, 0, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 0, 108, 108, 0, 0, 0, 108, 108, 108, 108, + 0, 0, 0, 108, 0, 0, 108, 108, 108, 108, + 137, 12, 13, 137, 0, 137, 14, 15, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 34, 16, 137, + 17, 18, 19, 0, 21, 0, 0, 0, 0, 22, + 23, 24, 25, 0, 0, 0, 26, 0, 0, 30, + 31, 32, 33, 0, 0, 66, 0, 0, 27, 0, + 28, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 189, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 137, 0, 137, 0, 0, 0, 0, + 66, 0, 0, 27, 0, 28, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 189, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 187, 0, + 188, 0, 0, 0, 0, 0, 66, 0, 0, 27, + 0, 28, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 9, 10, 11, 0, 189, 0, 12, 13, 0, + 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 187, 16, 200, 17, 18, 19, 20, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 29, 30, 31, 32, 33, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 35, 0, 0, 27, 0, 28, 0, 0, 0, 187, + 137, 201, 0, 137, 137, 0, 137, 137, 137, 137, + 137, 137, 137, 137, 0, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 0, 137, 137, 0, 0, + 0, 137, 137, 137, 137, 0, 0, 0, 137, 0, + 0, 137, 137, 137, 137, 174, 0, 0, 12, 13, + 0, 175, 176, 14, 15, 177, 0, 178, 179, 0, + 180, 181, 182, 183, 184, 16, 185, 17, 18, 19, + 0, 21, 186, 0, 0, 0, 22, 23, 24, 25, + 0, 0, 0, 26, 0, 0, 30, 31, 32, 33, + 174, 0, 0, 12, 13, 0, 175, 176, 14, 15, + 177, 0, 178, 179, 0, 180, 181, 182, 183, 184, + 16, 185, 17, 18, 19, 0, 21, 186, 0, 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, 0, - 29, 30, 31, 32, 33, 35, 237, 0, 27, 238, - 28, 0, 0, 11, 0, 0, 0, 12, 13, 0, - 0, 0, 14, 15, 0, 87, 0, 88, 0, 0, - 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, - 21, 0, 0, 0, 0, 22, 23, 24, 25, 85, - 86, 0, 26, 0, 29, 30, 31, 32, 33, 35, - 242, 0, 27, 243, 28, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 87, - 0, 88, 0, 0, 0, 11, 0, 0, 0, 12, - 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, - 19, 35, 21, 0, 27, 108, 28, 22, 23, 24, - 25, 85, 86, 0, 26, 0, 29, 30, 31, 32, - 33, 87, 0, 88, 0, 0, 0, 0, 0, 0, + 0, 30, 31, 32, 33, 0, 174, 0, 0, 12, + 13, 0, 175, 176, 14, 15, 177, 0, 178, 179, + 0, 180, 181, 182, 183, 184, 16, 185, 17, 18, + 19, 0, 21, 186, 0, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 66, 0, 0, 27, 0, 28, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 189, 0, 0, 0, 0, 0, 0, 0, 0, 11, + 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, + 0, 0, 0, 0, 0, 0, 66, 0, 0, 27, + 16, 28, 17, 18, 19, 0, 21, 0, 0, 0, + 0, 22, 23, 24, 25, 189, 0, 0, 26, 0, + 29, 30, 31, 32, 33, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 187, 0, 231, 0, 0, 0, + 0, 66, 0, 0, 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 35, 152, 0, - 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 87, 0, 88, + 189, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 187, + 0, 285, 0, 0, 0, 0, 0, 107, 0, 0, + 107, 0, 107, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 107, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 187, 0, 309, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 66, 0, 0, + 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 35, 0, 0, 27, 157, 28, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 87, 11, 88, 0, 0, 12, 13, - 0, 0, 0, 14, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, - 35, 21, 0, 27, 160, 28, 22, 23, 24, 25, - 85, 86, 0, 26, 0, 29, 30, 31, 32, 33, - 87, 0, 88, 0, 0, 0, 0, 0, 11, 0, - 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, - 0, 17, 18, 19, 35, 21, 0, 27, 162, 28, - 22, 23, 24, 25, 85, 86, 0, 26, 0, 29, - 30, 31, 32, 33, 87, 0, 88, 0, 0, 0, - 11, 0, 0, 0, 12, 13, 0, 0, 0, 14, - 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, - 0, 0, 22, 23, 24, 25, 85, 86, 0, 26, - 0, 29, 30, 31, 32, 33, 11, 0, 0, 0, - 12, 13, 0, 0, 35, 14, 15, 27, 163, 28, - 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, - 18, 19, 0, 21, 87, 0, 88, 0, 22, 23, - 24, 25, 85, 86, 0, 26, 0, 29, 30, 31, - 32, 33, 11, 0, 0, 0, 12, 13, 0, 0, - 35, 14, 15, 27, 168, 28, 0, 0, 0, 0, - 0, 0, 0, 16, 0, 17, 18, 19, 0, 21, - 87, 0, 88, 0, 22, 23, 24, 25, 85, 86, - 0, 26, 0, 29, 30, 31, 32, 33, 0, 11, - 0, 0, 0, 12, 13, 0, 0, 35, 14, 15, - 27, 169, 28, 0, 0, 0, 0, 0, 0, 0, - 16, 0, 17, 18, 19, 0, 21, 87, 0, 88, - 0, 22, 23, 24, 25, 85, 86, 0, 26, 0, - 29, 30, 31, 32, 33, 0, 0, 0, 0, 0, - 0, 0, 0, 11, 0, 0, 0, 12, 13, 0, - 0, 35, 14, 15, 27, 0, 28, 0, 0, 0, - 0, 0, 0, 0, 16, 0, 17, 18, 19, 191, - 21, 87, 0, 88, 0, 22, 23, 24, 25, 85, - 86, 0, 26, 0, 29, 30, 31, 32, 33, 0, - 0, 0, 0, 0, 0, 0, 0, 35, 240, 0, - 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 87, 0, 88, - 0, 0, 0, 11, 0, 0, 0, 12, 13, 0, - 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, + 107, 174, 107, 0, 12, 13, 0, 175, 176, 14, + 15, 177, 0, 178, 179, 0, 180, 181, 182, 183, + 184, 16, 185, 17, 18, 19, 0, 21, 186, 0, + 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 174, 0, 0, 12, + 13, 0, 175, 176, 14, 15, 177, 0, 178, 179, + 0, 180, 181, 182, 183, 184, 16, 185, 17, 18, + 19, 0, 21, 186, 0, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 174, 0, 0, 12, 13, 0, 175, 176, 14, + 15, 177, 0, 178, 179, 0, 180, 181, 182, 183, + 184, 16, 185, 17, 18, 19, 66, 21, 186, 27, + 111, 28, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 89, 107, 90, 86, + 107, 107, 0, 107, 107, 107, 107, 107, 0, 107, + 107, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 0, 107, 107, 0, 0, 0, 107, 107, + 107, 107, 0, 0, 0, 107, 0, 0, 107, 107, + 107, 107, 130, 0, 0, 130, 0, 130, 0, 0, + 12, 13, 0, 175, 176, 14, 15, 0, 0, 0, + 0, 130, 180, 181, 182, 183, 184, 16, 0, 17, + 18, 19, 0, 21, 186, 0, 0, 0, 22, 23, + 24, 25, 0, 0, 0, 26, 0, 0, 30, 31, + 32, 33, 66, 0, 0, 27, 0, 28, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 89, 0, 90, 86, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 130, 0, 130, 0, 0, + 0, 0, 0, 0, 66, 241, 0, 27, 242, 28, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 86, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 66, 243, + 0, 27, 244, 28, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 12, + 13, 86, 0, 0, 14, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, + 19, 0, 21, 0, 0, 0, 0, 22, 23, 24, + 25, 87, 88, 0, 26, 0, 0, 30, 31, 32, + 33, 66, 248, 0, 27, 249, 28, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 130, 0, 86, 130, 130, 0, 130, 130, + 130, 130, 130, 0, 130, 130, 0, 130, 130, 130, + 130, 130, 130, 130, 130, 130, 130, 0, 130, 130, + 0, 0, 0, 130, 130, 130, 130, 0, 0, 0, + 130, 0, 0, 130, 130, 130, 130, 35, 0, 0, + 27, 0, 28, 0, 0, 12, 13, 0, 0, 0, + 14, 15, 0, 0, 0, 0, 297, 0, 0, 0, + 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, + 0, 0, 0, 22, 23, 24, 25, 87, 88, 0, + 26, 0, 0, 30, 31, 32, 33, 12, 13, 0, + 0, 108, 14, 15, 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, - 21, 0, 0, 0, 0, 22, 23, 24, 25, 85, - 86, 0, 26, 0, 29, 30, 31, 32, 33, 11, - 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, - 0, 22, 23, 24, 25, 85, 86, 0, 26, 0, - 29, 30, 31, 32, 33, 0, 11, 0, 0, 0, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 0, + 0, 12, 13, 0, 0, 66, 14, 15, 27, 111, + 28, 0, 0, 0, 0, 0, 0, 0, 16, 0, + 17, 18, 19, 0, 21, 0, 0, 0, 86, 22, + 23, 24, 25, 0, 0, 0, 26, 0, 0, 30, + 31, 32, 33, 0, 0, 0, 0, 0, 66, 0, + 0, 27, 161, 28, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 12, 13, 0, 0, 0, 14, + 15, 86, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, + 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 66, 0, 0, 27, + 164, 28, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 11, 0, 0, 86, 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, - 18, 19, 0, 21, 0, 0, 0, 0, 22, 23, - 24, 25, 85, 86, 0, 26, 0, 29, 30, 31, - 32, 33, 35, 244, 0, 27, 0, 28, 0, 0, + 18, 19, 66, 21, 0, 27, 166, 28, 22, 23, + 24, 25, 0, 0, 0, 26, 0, 29, 30, 31, + 32, 33, 0, 0, 0, 86, 0, 0, 0, 0, 11, 0, 0, 0, 12, 13, 0, 0, 0, 14, - 15, 0, 87, 0, 88, 0, 0, 0, 0, 0, + 15, 0, 0, 0, 66, 0, 0, 27, 167, 28, 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, - 0, 0, 22, 23, 24, 25, 85, 86, 0, 26, - 0, 29, 30, 31, 32, 33, 11, 0, 0, 0, - 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, + 0, 0, 22, 23, 24, 25, 0, 86, 0, 26, + 0, 29, 30, 31, 32, 33, 0, 0, 12, 13, + 0, 0, 0, 14, 15, 0, 0, 66, 0, 0, + 27, 172, 28, 0, 0, 16, 0, 17, 18, 19, + 0, 21, 0, 0, 0, 0, 22, 23, 24, 25, + 86, 0, 0, 26, 0, 0, 30, 31, 32, 33, + 0, 12, 13, 0, 0, 0, 14, 15, 0, 0, + 66, 0, 0, 27, 173, 28, 0, 0, 16, 0, + 17, 18, 19, 0, 21, 0, 0, 0, 0, 22, + 23, 24, 25, 86, 0, 0, 26, 0, 0, 30, + 31, 32, 33, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 66, 0, 0, 27, 0, 28, 0, 12, + 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, + 195, 0, 0, 0, 0, 86, 16, 0, 17, 18, + 19, 0, 21, 0, 0, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 0, 0, 0, 0, 12, 13, 0, 0, 66, + 14, 15, 27, 0, 28, 0, 0, 0, 0, 0, + 0, 0, 16, 0, 17, 18, 19, 198, 21, 0, + 0, 0, 86, 22, 23, 24, 25, 0, 0, 0, + 26, 0, 0, 30, 31, 32, 33, 12, 13, 0, + 0, 0, 14, 15, 66, 0, 0, 27, 0, 28, + 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 0, + 12, 13, 0, 0, 0, 14, 15, 0, 0, 66, + 246, 0, 27, 0, 28, 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, 0, 22, 23, - 24, 25, 85, 86, 0, 26, 0, 29, 30, 31, - 32, 33, 35, 275, 0, 27, 0, 28, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 87, 0, 88, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 35, 281, - 0, 27, 0, 28, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 87, 0, - 88, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 35, 282, 0, 27, 0, 28, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 87, 0, 88, 0, 0, 0, - 0, 11, 0, 0, 0, 12, 13, 0, 0, 0, - 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 24, 25, 86, 0, 0, 26, 0, 0, 30, 31, + 32, 33, 0, 12, 13, 0, 0, 0, 14, 15, + 0, 0, 66, 250, 0, 27, 0, 28, 0, 0, + 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, + 0, 22, 23, 24, 25, 86, 0, 0, 26, 0, + 0, 30, 31, 32, 33, 12, 13, 0, 0, 0, + 14, 15, 0, 0, 66, 281, 0, 27, 0, 28, 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, - 0, 0, 0, 22, 23, 24, 25, 85, 86, 0, - 26, 0, 29, 30, 31, 32, 33, 35, 283, 0, - 27, 0, 28, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 87, 0, 88, + 0, 0, 0, 22, 23, 24, 25, 86, 0, 0, + 26, 0, 0, 30, 31, 32, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 35, 284, 0, 27, 0, 28, 0, - 0, 11, 0, 0, 0, 12, 13, 0, 0, 0, - 14, 15, 0, 87, 0, 88, 0, 0, 0, 0, + 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, + 0, 66, 287, 0, 27, 0, 28, 0, 0, 16, + 0, 17, 18, 19, 0, 21, 0, 0, 0, 0, + 22, 23, 24, 25, 86, 0, 0, 26, 0, 0, + 30, 31, 32, 33, 0, 126, 127, 12, 13, 0, + 0, 0, 14, 15, 0, 0, 66, 288, 0, 27, + 0, 28, 0, 0, 16, 0, 17, 18, 19, 0, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 86, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 0, + 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, + 0, 66, 289, 0, 27, 0, 28, 0, 0, 16, + 0, 17, 18, 19, 0, 21, 0, 0, 0, 0, + 22, 23, 24, 25, 86, 0, 0, 26, 0, 0, + 30, 31, 32, 33, 0, 12, 13, 0, 0, 0, + 14, 15, 0, 0, 66, 290, 0, 27, 0, 28, 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, - 0, 0, 0, 22, 23, 24, 25, 85, 86, 0, - 26, 0, 29, 30, 31, 32, 33, 11, 0, 0, - 0, 12, 13, 0, 0, 0, 14, 15, 35, 0, - 0, 27, 0, 28, 0, 0, 0, 0, 16, 0, - 17, 18, 19, 0, 21, 0, 0, 0, 0, 22, - 23, 24, 25, 85, 86, 0, 26, 0, 29, 30, - 31, 32, 33, 11, 0, 0, 0, 12, 13, 0, + 0, 0, 0, 22, 23, 24, 25, 86, 0, 0, + 26, 0, 0, 30, 31, 32, 33, 12, 13, 0, + 0, 0, 14, 15, 0, 0, 66, 291, 0, 27, + 0, 28, 0, 0, 16, 0, 17, 18, 19, 0, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 86, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 12, 13, 0, 0, 0, 14, + 15, 0, 0, 66, 293, 0, 27, 0, 28, 0, + 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, + 0, 0, 22, 23, 24, 25, 86, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 0, 0, 0, 12, + 13, 0, 0, 0, 14, 15, 0, 0, 0, 66, + 0, 0, 27, 0, 28, 0, 16, 0, 17, 18, + 19, 0, 21, 0, 0, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 0, 0, 0, 12, 13, 0, 0, 0, 14, + 15, 0, 0, 0, 0, 66, 0, 0, 27, 0, + 28, 16, 0, 17, 18, 19, 0, 21, 0, 0, + 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 0, 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, - 21, 0, 0, 0, 0, 22, 23, 24, 25, 85, - 86, 0, 26, 0, 29, 30, 31, 32, 33, 35, - 285, 34, 27, 0, 28, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 87, - 0, 88, 0, 0, 0, 0, 11, 0, 0, 0, - 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, - 18, 19, 35, 21, 0, 27, 0, 28, 22, 23, - 24, 25, 85, 86, 0, 26, 0, 29, 30, 31, - 32, 33, 11, 0, 0, 0, 12, 13, 0, 0, - 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 16, 0, 17, 18, 19, 0, 21, - 0, 0, 0, 0, 22, 23, 24, 25, 85, 86, - 0, 26, 0, 29, 30, 31, 32, 33, 35, 287, - 0, 27, 0, 28, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 9, 10, 11, 87, 0, - 88, 12, 13, 0, 0, 0, 14, 15, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, - 17, 18, 19, 20, 21, 0, 0, 0, 0, 22, - 23, 24, 25, 0, 0, 0, 26, 0, 29, 30, - 31, 32, 33, 35, 0, 0, 27, 0, 28, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 87, 0, 88, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 11, 0, - 0, 0, 12, 13, 0, 0, 0, 14, 15, 35, - 0, 0, 27, 0, 28, 0, 0, 0, 0, 16, - 0, 17, 18, 19, 0, 21, 0, 0, 291, 0, - 22, 23, 24, 25, 85, 86, 0, 26, 0, 29, - 30, 31, 32, 33, 0, 0, 0, 0, 0, 0, - 0, 115, 0, 0, 0, 12, 13, 0, 0, 35, - 14, 15, 27, 0, 28, 0, 0, 0, 0, 0, - 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, - 0, 0, 0, 22, 23, 24, 25, 0, 0, 0, - 26, 0, 29, 30, 31, 32, 33, 0, 0, 0, - 0, 0, 0, 0, 0, 35, 0, 0, 27, 0, - 28, 0, 0, 0, 0, 0, 0, 11, 0, 0, - 0, 12, 13, 0, 0, 0, 14, 15, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, - 17, 18, 19, 0, 21, 0, 0, 0, 0, 22, - 23, 24, 25, 85, 86, 0, 26, 0, 29, 30, - 31, 32, 33, 35, 0, 0, 27, 0, 28, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 11, 0, 0, 0, 12, 13, 0, 0, + 0, 0, 0, 0, 16, 0, 17, 18, 19, 66, + 21, 0, 27, 0, 28, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 12, + 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, + 19, 0, 21, 0, 0, 0, 0, 22, 23, 24, + 25, 0, 0, 0, 26, 0, 0, 30, 31, 32, + 33, 66, 0, 0, 27, 0, 28, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, 21, - 0, 0, 0, 0, 22, 23, 24, 25, 85, 86, - 0, 26, 0, 29, 30, 31, 32, 33, 11, 0, - 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, + 0, 0, 0, 0, 22, 23, 24, 25, 0, 0, + 0, 26, 0, 0, 30, 31, 32, 33, 116, 0, + 0, 66, 12, 13, 27, 0, 28, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, - 0, 17, 18, 19, 0, 21, 0, 0, 0, 0, - 22, 23, 24, 25, 0, 0, 0, 26, 0, 29, - 30, 31, 32, 33, 0, 0, 0, 0, 136, 0, + 0, 17, 18, 19, 86, 21, 0, 0, 0, 0, + 22, 23, 24, 25, 0, 0, 0, 26, 0, 0, + 30, 31, 32, 33, 118, 0, 0, 66, 12, 13, + 27, 0, 28, 14, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, + 0, 21, 0, 0, 0, 0, 22, 23, 24, 25, + 0, 0, 0, 26, 0, 0, 30, 31, 32, 33, + 51, 0, 0, 27, 0, 28, 0, 0, 140, 0, 0, 0, 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, 0, - 22, 23, 24, 25, 0, 0, 0, 26, 0, 29, - 30, 31, 32, 33, 204, 0, 0, 0, 12, 13, - 0, 0, 0, 14, 15, 0, 0, 101, 102, 0, - 0, 0, 0, 0, 0, 16, 0, 17, 18, 19, - 0, 21, 0, 0, 0, 0, 22, 23, 24, 25, - 0, 0, 0, 26, 0, 29, 30, 31, 32, 33, - 131, 0, 133, 134, 0, 0, 0, 0, 0, 0, - 0, 0, 263, 0, 0, 0, 12, 13, 0, 0, - 0, 14, 15, 0, 0, 0, 0, 0, 155, 156, - 0, 0, 0, 16, 0, 17, 18, 19, 0, 21, - 0, 0, 0, 0, 22, 23, 24, 25, 0, 0, - 0, 26, 0, 29, 30, 31, 32, 33, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 67, - 68, 0, 0, 0, 0, 72, 0, 0, 0, 0, - 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, - 209, 0, 0, 0, 0, 0, 89, 0, 0, 0, - 0, 217, 0, 219, 0, 220, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 241, 0, 0, 0, - 0, 0, 0, 142, 143, 144, 145, 146, 147, 0, - 0, 258, 259, 260, 261, 262, 89, 0, 89, 0, - 0, 0, 89, 89, 0, 0, 89, 0, 89, 89, - 0, 0, 0, 89, 89, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 89, 0, 0, 0, 0, 89, - 89, 89, 89, 0, 0, 0, 0, 0, 0, 286, - 0, 0, 0, 288, 289, 290, 0, 0, 0, 295, - 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 308, 309, 0, 0, 89, 0, - 313, 0, 0, 0, 0, 0, 0, 0, 0, 89, - 89, 0, 89, 89, 89, 89, 0, 89, 0, 89, - 89, 0, 0, 0, 0, 0, 0, 89, 89, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 89, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 89, 89, 89, 89, - 89, 0, 89, 89, 89, + 22, 23, 24, 25, 0, 0, 0, 26, 0, 0, + 30, 31, 32, 33, 66, 0, 0, 27, 0, 28, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 209, 0, 0, 0, 12, 13, 0, 0, 0, 14, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, + 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 12, 13, 0, 0, 0, 14, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 16, 0, 17, 18, 19, 0, 21, 0, 0, + 0, 0, 22, 23, 24, 25, 0, 0, 0, 26, + 0, 0, 30, 31, 32, 33, 269, 0, 0, 0, + 12, 13, 0, 0, 0, 14, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 16, 0, 17, + 18, 19, 0, 21, 0, 0, 0, 0, 22, 23, + 24, 25, 0, 0, 0, 26, 0, 0, 30, 31, + 32, 33, 0, 12, 13, 0, 0, 0, 14, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 16, 0, 17, 18, 19, 0, 21, 0, 0, 0, + 0, 22, 23, 24, 25, 57, 0, 0, 26, 0, + 0, 30, 31, 32, 33, 0, 68, 68, 0, 71, + 72, 0, 68, 0, 0, 0, 0, 12, 13, 0, + 68, 0, 14, 15, 0, 0, 0, 0, 0, 0, + 0, 0, 68, 0, 16, 0, 17, 18, 19, 0, + 21, 0, 0, 0, 0, 22, 23, 24, 25, 0, + 0, 0, 26, 0, 0, 30, 31, 32, 33, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 68, 68, 68, 68, 68, 68, 0, 0, + 0, 0, 0, 0, 0, 68, 0, 0, 68, 0, + 0, 0, 68, 68, 0, 0, 68, 0, 68, 68, + 0, 0, 0, 68, 68, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 68, 0, 0, 0, 68, 0, + 68, 68, 68, 68, 0, 0, 0, 0, 0, 0, + 0, 199, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 68, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 68, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 68, 68, 0, 68, 68, 68, 68, 0, 68, + 0, 68, 68, 0, 0, 67, 69, 0, 0, 68, + 68, 73, 0, 0, 0, 0, 0, 0, 0, 91, + 0, 68, 68, 0, 0, 0, 0, 0, 0, 0, + 0, 91, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 68, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 68, + 68, 68, 68, 68, 0, 68, 68, 68, 0, 0, + 0, 146, 147, 148, 149, 150, 151, 0, 0, 0, + 0, 0, 0, 0, 91, 0, 0, 91, 0, 0, + 0, 91, 91, 0, 0, 91, 0, 91, 91, 0, + 0, 0, 91, 91, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 91, 0, 0, 0, 91, 0, 91, + 91, 91, 91, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 91, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 91, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 91, 91, 0, 91, 91, 91, 91, 0, 91, 0, + 91, 91, 0, 0, 0, 0, 0, 0, 91, 91, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 91, 91, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 91, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 91, 91, + 91, 91, 91, 0, 91, 91, 91, }; short yycheck[] = { 41, - 0, 123, 62, 123, 41, 59, 41, 59, 214, 63, - 59, 63, 123, 63, 59, 63, 94, 59, 50, 38, - 35, 63, 35, 291, 41, 286, 63, 41, 63, 91, - 41, 63, 64, 301, 112, 40, 51, 37, 51, 7, - 40, 41, 42, 43, 44, 45, 63, 47, 59, 63, - 35, 41, 63, 41, 44, 0, 44, 41, 58, 59, - 60, 29, 62, 63, 124, 44, 51, 35, 261, 262, - 37, 40, 261, 60, 288, 42, 43, 40, 45, 63, - 47, 101, 102, 51, 63, 291, 118, 301, 302, 60, - 40, 16, 37, 93, 94, 301, 41, 42, 43, 44, - 45, 63, 47, 40, 63, 30, 31, 40, 292, 40, - 0, 131, 112, 58, 59, 60, 84, 62, 63, 303, - 304, 40, 40, 123, 124, 123, 40, 94, 44, 112, - 98, 41, 41, 37, 63, 41, 63, 292, 42, 171, - 172, 261, 262, 47, 280, 112, 41, 37, 93, 94, - 40, 41, 42, 43, 41, 45, 44, 47, 44, 93, - 292, 41, 41, 40, 40, 133, 134, 112, 58, 59, - 60, 40, 62, 63, 292, 290, 195, 41, 123, 124, - 59, 59, 272, 91, 41, 40, 93, 271, 41, 41, - 94, 0, 41, 93, 59, 41, -1, 51, -1, 219, - -1, 211, -1, 93, 94, 265, -1, -1, 112, 41, - -1, 260, 261, 262, -1, 260, 261, 262, 260, 261, - 262, -1, 112, 148, 256, 40, -1, 59, 43, -1, - 45, 63, -1, 123, 124, 289, 290, 289, 290, 289, - 290, 289, 290, -1, 212, 213, -1, 289, 290, 260, - 261, 262, 289, 290, 289, 290, -1, 257, 258, 259, - 260, 261, 262, 263, 264, 265, 286, -1, 268, 269, - -1, -1, 289, 290, 274, 289, 290, -1, 289, 290, - 280, 41, 282, 283, 284, 285, 286, -1, 288, 289, - 290, 291, 292, 293, 294, 295, 296, -1, 298, 59, - 300, 301, 302, 303, 304, 289, 290, 274, 276, -1, - 289, 290, 257, 258, 259, 260, 261, 262, 263, 264, - 265, 292, -1, 268, 269, 293, -1, 289, 290, 274, - 289, 290, 303, 304, -1, 280, 41, 282, 283, 284, + 0, 41, 63, 41, 37, 41, 41, 59, 59, 42, + 43, 63, 45, 63, 47, 35, 63, 219, 41, 63, + 50, 63, 38, 63, 59, 63, 123, 63, 62, 37, + 44, 123, 62, 63, 42, 103, 104, 37, 35, 47, + 40, 41, 42, 43, 44, 45, 51, 47, 35, 63, + 41, 94, 41, 44, 288, 0, 301, 302, 58, 59, + 60, 94, 62, 63, 297, 60, 134, 301, 302, 112, + 59, 292, 41, 40, 307, 44, 59, 261, 262, 112, + 40, 40, 303, 304, 123, 40, 94, 40, 108, 40, + 124, 121, 37, 93, 94, 297, 41, 42, 43, 44, + 45, 286, 47, 108, 112, 307, 91, 41, 222, 40, + 0, 108, 112, 58, 59, 60, 40, 62, 63, 40, + 261, 108, 44, 123, 124, 59, 40, 123, 62, 41, + 60, 112, 41, 41, 292, 280, 41, 44, 44, 41, + 292, 41, 41, 93, 41, 175, 176, 37, 93, 94, + 40, 41, 42, 43, 40, 45, 224, 47, 40, 59, + 40, 292, 59, 290, 261, 262, 41, 112, 58, 59, + 60, 91, 62, 63, 59, 41, 272, 7, 123, 124, + 294, 295, 296, 40, 200, 271, 41, 41, 0, 93, + 124, 41, 93, 41, 59, 59, -1, 216, -1, 29, + 314, 315, -1, 93, 94, 319, -1, -1, -1, 260, + 261, 262, 41, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 112, -1, 292, 260, 261, 262, 289, 290, + 59, 265, 262, 123, 124, -1, -1, 289, 290, 289, + 290, 274, 289, 290, -1, 289, 290, 289, 290, 289, + 290, 289, 290, 289, 290, 85, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 289, 290, 268, 269, + 100, 260, 261, 262, 274, 289, 290, 260, 261, 262, + 280, 41, 282, 283, 284, 285, 286, 41, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 292, 298, 59, + 300, 301, 302, 303, 304, 59, 136, 137, 303, 304, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, -1, -1, 268, 269, -1, 260, 261, 262, 274, + -1, 265, -1, -1, -1, 280, 41, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, 59, 300, 301, 302, 303, 304, - 289, 290, 289, 290, -1, -1, -1, 257, 258, 259, + 260, 261, 262, 260, 261, 262, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, - 0, 260, 261, 262, 274, -1, -1, -1, -1, -1, + 0, -1, -1, -1, 274, -1, -1, 217, 218, -1, 280, -1, 282, 283, 284, 285, 286, 41, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, 59, -1, 37, -1, -1, - 40, 41, 42, 43, 44, 45, -1, 47, 260, 261, - 262, -1, -1, -1, -1, 0, -1, -1, 58, 59, - -1, -1, 62, 63, 259, -1, -1, 217, 263, 264, - -1, -1, -1, 268, 269, -1, -1, 289, 290, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - -1, 286, 37, 93, 94, 40, 41, 42, 43, 44, - 45, -1, 47, 298, -1, 300, 301, 302, 303, 304, + 40, 41, 42, 43, 44, 45, -1, 47, -1, -1, + -1, 260, 261, 262, -1, 0, -1, -1, 58, 59, + -1, -1, 62, 63, -1, -1, -1, -1, -1, -1, + -1, -1, 282, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 299, + -1, -1, 37, 93, 94, 40, 41, 42, 43, 44, + 45, -1, 47, -1, -1, -1, -1, -1, -1, -1, 0, -1, 112, 58, 59, 60, -1, 62, 63, -1, - 260, 261, 262, 123, 124, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 288, 289, - 290, -1, -1, -1, -1, -1, -1, 37, 93, 94, - 40, 41, 42, 43, 44, 45, -1, 47, 308, 309, - -1, -1, -1, 313, -1, -1, -1, 41, 58, 59, + 260, 261, 262, 123, 124, -1, 260, 261, 262, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 37, 93, 94, + 40, 41, 42, 43, 44, 45, -1, 47, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, 60, -1, 62, 63, -1, 260, 261, 262, 123, 124, - -1, -1, -1, 0, -1, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, + -1, -1, -1, 0, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, -1, -1, -1, - -1, -1, -1, 41, -1, -1, 59, -1, -1, 62, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, -1, 112, 40, 41, 42, 43, 44, 45, -1, - 47, 59, -1, 123, 124, 63, 260, 261, 262, -1, + 47, -1, -1, 123, 124, -1, 260, 261, 262, -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, -1, -1, -1, -1, 274, -1, 93, -1, -1, -1, - 280, 124, 282, 283, 284, 285, 286, -1, 288, 289, + 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, 123, 124, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, @@ -1059,695 +1089,725 @@ short yycheck[] = { 41, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, - -1, -1, -1, -1, 274, -1, 260, 261, 262, -1, + -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, -1, 291, 292, 293, 294, 295, 296, -1, 298, -1, - 300, 301, 302, 303, 304, 289, 290, 260, 261, 262, - -1, -1, 265, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 260, 261, 262, -1, -1, -1, -1, -1, + 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, 0, -1, -1, -1, 274, -1, -1, - -1, 289, 290, 280, -1, 282, 283, 284, 285, 286, + -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, -1, 37, -1, -1, 40, 41, 42, 43, 44, 45, -1, - 47, -1, -1, -1, -1, -1, -1, 0, -1, -1, + 47, -1, -1, -1, -1, -1, -1, -1, 0, -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 37, -1, 93, 40, 41, 42, - 43, 44, 45, -1, 47, -1, -1, -1, -1, -1, - -1, 0, -1, -1, -1, 58, 59, 60, -1, 62, - 63, -1, -1, -1, -1, -1, 123, 124, -1, -1, + -1, -1, -1, -1, -1, 37, 93, 94, 40, 41, + 42, 43, 44, 45, -1, 47, -1, -1, -1, -1, + -1, -1, 0, -1, -1, 112, 58, 59, 60, -1, + 62, 63, -1, -1, -1, -1, 123, 124, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, + -1, 93, 40, 41, 42, 43, 44, 45, -1, 47, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 37, -1, - 93, 40, 41, 42, 43, 44, 45, -1, 47, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, - 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, - 123, 124, -1, -1, -1, 0, -1, -1, -1, -1, + 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, + -1, 123, 124, -1, -1, 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, -1, -1, 40, 41, 42, 43, 44, - 45, -1, 47, -1, 123, 124, -1, -1, -1, -1, + 45, -1, 47, -1, -1, 123, 124, -1, -1, -1, -1, -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, -1, -1, -1, -1, 274, 93, -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, 303, 304, 123, 124, - -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, - 263, 264, 265, -1, -1, 268, 269, -1, -1, -1, - -1, 274, -1, -1, -1, -1, -1, 280, -1, 282, - 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, -1, -1, -1, -1, -1, -1, 257, 258, - 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, - 269, -1, -1, -1, -1, 274, -1, -1, -1, -1, - -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, - 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, - -1, 300, 301, 302, 303, 304, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 298, -1, 300, -1, -1, 303, 304, 123, 124, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, -1, -1, 268, 269, -1, -1, + -1, -1, 274, -1, -1, -1, -1, -1, 280, -1, + 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, + 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, + 302, 303, 304, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 0, -1, + 268, 269, -1, -1, -1, -1, 274, -1, -1, -1, + -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, + 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, + 298, -1, 300, 301, 302, 303, 304, -1, 40, -1, + -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, 0, -1, -1, -1, 274, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, -1, 37, -1, -1, 40, 41, 42, 43, 44, - 45, -1, 47, -1, -1, -1, -1, -1, -1, 0, + 45, 123, 47, -1, -1, -1, -1, -1, -1, 0, -1, -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, -1, 93, 40, 41, 42, 43, 44, 45, -1, 47, -1, -1, -1, - -1, -1, -1, -1, 0, -1, -1, 58, 59, 60, + -1, -1, -1, 0, -1, -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, 123, 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 37, 93, 94, 40, 41, 42, 43, 44, 45, - -1, 47, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 112, 58, 59, 60, -1, 62, -1, -1, -1, - -1, -1, 123, 124, -1, -1, -1, 0, -1, -1, + 37, -1, 93, 40, 41, 42, 43, 44, 45, -1, + 47, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, + -1, -1, 123, 124, -1, 257, 258, 259, 260, 261, + 262, 263, 264, -1, -1, -1, 268, 269, -1, -1, + -1, -1, -1, -1, -1, -1, 93, 94, 280, -1, + 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, + 292, 293, 294, -1, -1, 112, 298, -1, 300, 301, + 302, 303, 304, -1, -1, -1, 123, 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 112, 40, 41, -1, - 43, 44, 45, -1, -1, -1, -1, 123, 124, -1, - -1, -1, -1, -1, -1, 58, 59, 60, -1, 62, - 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, -1, -1, -1, -1, 274, - 93, -1, -1, -1, -1, 280, -1, 282, 283, 284, + -1, 40, -1, -1, 43, 280, 45, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, - 123, 124, -1, -1, -1, -1, 257, 258, 259, 260, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, 280, - -1, 282, 283, 284, 285, 286, -1, -1, 289, 290, + -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, - -1, -1, 303, 304, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, - -1, -1, 268, 269, -1, -1, -1, -1, 274, -1, - -1, -1, -1, -1, 280, 0, 282, 283, 284, 285, - 286, -1, 288, -1, -1, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, - 45, -1, -1, -1, 257, 258, 259, 260, 261, 262, - 263, 264, 265, 0, 59, 268, 269, -1, -1, -1, - -1, 274, -1, -1, -1, -1, -1, 280, -1, 282, - 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, -1, 40, 41, -1, 43, 44, 45, -1, - -1, 0, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 58, 59, 60, -1, 62, 63, -1, 123, -1, + 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, + 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, + -1, 268, 269, 0, -1, -1, -1, 274, -1, -1, + -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, + -1, -1, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, -1, 300, -1, -1, 303, 304, -1, -1, + 37, -1, -1, 40, 41, 42, 43, 44, 45, -1, + 47, -1, -1, -1, -1, -1, -1, -1, 0, -1, + -1, 58, 59, 60, -1, 62, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 40, 41, -1, -1, 44, 93, -1, -1, 0, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, - 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 123, 124, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 40, - 41, -1, -1, 44, 93, -1, -1, -1, -1, -1, - -1, 0, -1, -1, -1, -1, -1, 58, 59, 60, + -1, -1, -1, -1, -1, -1, 93, 94, 40, 41, + -1, 43, 44, 45, -1, -1, -1, -1, -1, 0, + -1, -1, -1, -1, -1, 112, 58, 59, 60, -1, + 62, 63, -1, -1, 263, 264, 123, 124, -1, 268, + 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 280, -1, 282, 283, 284, -1, 286, -1, 40, + 41, 93, 43, 44, 45, -1, -1, 0, -1, 298, + -1, -1, 301, 302, 303, 304, -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 123, 124, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 40, 93, -1, 43, -1, 45, -1, -1, -1, - -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, - 59, -1, -1, 268, 269, -1, -1, -1, -1, -1, - -1, -1, 123, 124, -1, 280, -1, 282, 283, 284, - 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, - -1, -1, -1, 298, -1, 300, 301, 302, 303, 304, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, - -1, 268, 269, 40, 123, -1, 43, 274, 45, -1, - -1, -1, -1, 280, 0, 282, 283, 284, 285, 286, - -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, 303, 304, 257, 258, - 259, 260, 261, 262, 263, 264, 265, -1, -1, 268, - 269, -1, -1, -1, 40, -1, -1, 43, -1, 45, - -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, - 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, - -1, 300, 301, 302, 303, 304, 257, 258, 259, 260, - 261, 262, 263, 264, 265, -1, -1, 268, 269, -1, - 40, 41, -1, 43, -1, 45, -1, -1, -1, 280, + -1, 123, 124, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 40, 41, -1, + -1, 44, 93, 259, -1, 261, 262, 263, 264, -1, + -1, 0, 268, 269, -1, 58, 59, 60, -1, 62, + 63, -1, -1, -1, 280, -1, 282, 283, 284, -1, + 286, -1, 123, 124, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, 300, 301, 302, 303, 304, -1, + 93, 40, -1, -1, 43, -1, 45, -1, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 0, + 59, 268, 269, -1, -1, -1, -1, 274, -1, -1, + 123, 124, -1, 280, -1, 282, 283, 284, 285, 286, + -1, 288, -1, -1, 291, 292, 293, 294, 295, 296, + -1, 298, -1, 300, 301, 302, 303, 304, -1, 40, + -1, -1, 43, -1, 45, 257, 258, 259, 260, 261, + 262, 263, 264, 265, -1, -1, 268, 269, 59, -1, + -1, -1, 274, -1, 123, -1, -1, -1, 280, 0, + 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, + 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, + 302, 303, 304, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, -1, -1, 268, 269, 40, + -1, -1, 43, 274, 45, -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, - 301, 302, 303, 304, -1, -1, -1, 123, 257, 258, - 259, 260, 261, 262, 263, 264, 0, -1, -1, 268, - 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 301, 302, 303, 304, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 0, -1, 268, 269, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, + 283, 284, 285, 286, -1, 288, 289, 290, 291, 292, + 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, + 303, 304, 123, 40, 41, -1, -1, 44, 257, 258, + 259, 260, 261, 262, 263, 264, -1, 0, -1, 268, + 269, 58, 59, 60, -1, 62, 63, -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, - -1, 300, 301, 302, 303, 304, 40, -1, -1, 43, - -1, 45, -1, -1, 0, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 259, -1, 261, 262, 263, 264, -1, -1, - -1, 268, 269, -1, 40, -1, -1, 43, -1, 45, - -1, -1, -1, 280, 0, 282, 283, 284, -1, 286, - -1, -1, -1, 59, 291, 292, 293, 294, -1, -1, - -1, 298, -1, 300, 301, 302, 303, 304, -1, 123, - -1, 257, 258, 259, -1, -1, -1, 263, 264, -1, - -1, -1, 268, 269, 40, -1, -1, 43, -1, 45, - -1, -1, -1, 0, 280, -1, 282, 283, 284, 285, - 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, - -1, -1, 298, -1, 300, 301, 302, 303, 304, 259, - -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, - -1, -1, -1, 40, -1, -1, 43, -1, 45, -1, - 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, - -1, 291, 292, 293, 294, -1, -1, -1, 298, -1, - 300, 301, 302, 303, 304, -1, -1, 123, -1, -1, + -1, 300, 301, 302, 303, 304, 93, 40, -1, -1, + 43, -1, 45, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 0, -1, 59, 268, 269, -1, + -1, -1, -1, -1, -1, -1, 123, 124, -1, 280, + -1, 282, 283, 284, 285, 286, -1, -1, -1, -1, + 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, + 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, -1, + 123, -1, 263, 264, -1, 0, -1, 268, 269, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, + -1, 282, 283, 284, 285, 286, -1, -1, -1, -1, + 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, + 301, 302, 303, 304, -1, 40, -1, -1, 43, -1, + 45, -1, -1, -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 257, 258, 259, 260, -1, 262, 263, - 264, -1, -1, -1, 268, 269, 123, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, - 284, 285, 286, -1, -1, -1, -1, 291, 292, 293, - 294, -1, -1, -1, 298, -1, 300, 301, 302, 303, - 304, 257, 258, 259, 260, 261, 262, 263, 264, -1, - -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, - 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, - -1, -1, 298, -1, 300, 301, 302, 303, 304, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, -1, + -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, + -1, 288, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, -1, 300, 301, 302, 303, 304, 123, -1, + -1, -1, -1, -1, 257, 258, 259, 260, -1, 262, + 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, + 283, 284, 285, 286, -1, -1, -1, -1, 291, 292, + 293, 294, -1, -1, -1, 298, -1, 300, 301, 302, + 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, -1, -1, -1, 263, 264, -1, - -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 280, -1, 282, 283, 284, 285, - 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 268, 269, -1, -1, 40, 41, -1, 43, + 44, 45, -1, -1, 280, -1, 282, 283, 284, 285, + 286, -1, -1, -1, -1, 291, 292, 293, 294, 63, -1, -1, 298, -1, 300, 301, 302, 303, 304, -1, - 257, 258, 259, -1, -1, -1, 263, 264, -1, -1, - -1, 268, 269, 0, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 280, -1, 282, 283, 284, 285, 286, - -1, -1, -1, -1, 291, 292, 293, 294, -1, -1, - -1, 298, -1, 300, 301, 302, 303, 304, -1, -1, - 37, -1, -1, 40, 41, 42, 43, 44, 45, -1, - 47, -1, -1, -1, -1, -1, -1, -1, 0, -1, - -1, 58, 59, 60, -1, 62, 63, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 37, 93, 94, 40, 41, - 42, 43, 44, 45, -1, 47, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 112, 58, 59, -1, -1, - 62, 63, -1, -1, -1, -1, 123, 124, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 93, 94, -1, -1, -1, -1, 0, -1, -1, + -1, -1, -1, 40, 41, -1, 43, 44, 45, -1, + -1, -1, 257, 258, 259, -1, -1, -1, 263, 264, + -1, -1, -1, 268, 269, 0, 63, -1, -1, -1, + -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, -1, -1, -1, 291, 292, 293, 294, + -1, -1, -1, 298, -1, 300, 301, 302, 303, 304, + -1, -1, 37, -1, -1, 40, 41, 42, 43, 44, + 45, -1, 47, -1, -1, -1, -1, -1, -1, -1, + 0, -1, -1, 58, 59, 60, -1, 62, 63, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 37, 93, 94, + 40, 41, 42, 43, 44, 45, -1, 47, 0, -1, + -1, -1, -1, -1, -1, -1, -1, 112, 58, 59, + -1, -1, 62, 63, -1, -1, -1, -1, 123, 124, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 37, -1, -1, -1, 41, + 42, -1, 44, 93, 94, 47, -1, -1, -1, 263, + 264, -1, -1, -1, 268, 269, 58, 59, 60, -1, + 62, 63, 112, -1, -1, -1, 280, -1, 282, 283, + 284, -1, 286, 123, 124, -1, -1, 291, 292, 293, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, + 304, 93, 94, -1, -1, -1, 263, 264, -1, -1, + -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, + 112, -1, -1, 280, -1, 282, 283, 284, -1, 286, + -1, 123, 124, -1, 291, 292, 293, 294, -1, -1, + -1, 298, -1, -1, 301, 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 123, 124, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 37, -1, -1, -1, 41, 42, - -1, 44, -1, -1, 47, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 58, 59, 60, -1, 62, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, -1, -1, 268, 269, -1, -1, -1, -1, 274, + -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, + 285, 286, -1, 288, 289, 290, 291, -1, 293, 294, + 295, 296, -1, 298, -1, 300, 301, 302, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, -1, -1, 268, 269, + -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, + 280, -1, 282, 283, 284, 285, 286, 0, 288, 289, + 290, 291, -1, 293, 294, 295, 296, -1, 298, -1, + 300, 301, 302, -1, -1, 257, 258, 259, 260, 261, + 262, -1, -1, 265, -1, -1, -1, -1, -1, -1, + -1, -1, 274, -1, 37, -1, -1, -1, 41, 42, + -1, 44, 0, 285, 47, -1, 288, 289, 290, 291, + 292, 293, 294, 295, 296, 58, 59, 60, 300, 62, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, + -1, -1, -1, 41, 42, -1, 44, 0, -1, 47, + 93, 94, -1, -1, -1, -1, -1, -1, -1, -1, + 58, 59, 60, -1, 62, 63, -1, -1, -1, 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 123, 124, -1, -1, 37, -1, -1, -1, 41, 42, + -1, 44, -1, -1, 47, 93, 94, -1, -1, -1, + -1, -1, -1, -1, -1, 58, 59, 60, -1, 62, + 63, -1, -1, -1, 112, -1, 0, -1, -1, -1, + -1, -1, -1, -1, -1, 123, 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, -1, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, 262, 263, 264, 265, 112, - -1, 268, 269, -1, -1, -1, -1, 274, -1, -1, - 123, 124, -1, 280, -1, 282, 283, 284, 285, 286, - -1, 288, 289, 290, 291, -1, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, - 262, 263, 264, 265, -1, -1, 268, 269, 14, -1, - -1, -1, 274, -1, -1, -1, -1, -1, 280, -1, - 282, 283, 284, 285, 286, -1, 288, 289, 290, 291, - -1, 293, 294, 295, 296, -1, 298, -1, 300, 301, - 302, -1, -1, 49, 50, 51, -1, -1, -1, -1, - 56, 57, -1, 59, 60, 61, -1, 63, 64, 65, - 66, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 81, -1, -1, -1, 85, - 86, 87, 88, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 257, 258, -1, 260, 261, 262, - -1, -1, 265, -1, -1, -1, 112, -1, -1, -1, - -1, 274, 118, -1, -1, -1, -1, -1, -1, 125, + -1, -1, -1, 37, -1, -1, -1, 41, 42, 112, + 44, -1, -1, 47, -1, -1, -1, -1, -1, -1, + 123, 124, -1, -1, 58, 59, 60, -1, 62, 63, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, + 94, -1, -1, -1, 257, 258, 259, 260, 261, 262, + -1, -1, 265, -1, -1, -1, -1, -1, 112, -1, + -1, 274, -1, -1, -1, -1, -1, -1, -1, 123, + 124, -1, 285, -1, -1, 288, 289, 290, 291, 292, + 293, 294, 295, 296, -1, -1, -1, 300, -1, 257, + 258, 259, 260, 261, 262, -1, -1, 265, -1, -1, + -1, -1, -1, -1, -1, -1, 274, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 285, -1, -1, + 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, + -1, -1, 300, -1, 257, 258, 259, 260, 261, 262, + -1, -1, 265, -1, -1, -1, -1, -1, -1, -1, + -1, 274, -1, -1, 0, -1, -1, -1, -1, -1, -1, -1, 285, -1, -1, 288, 289, 290, 291, 292, - 293, 294, 295, 296, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 150, 151, -1, -1, -1, 155, - 156, -1, -1, 159, 160, 161, 162, 163, -1, -1, - -1, -1, 168, 169, -1, 171, 172, -1, -1, -1, - 176, -1, -1, -1, 180, -1, 0, -1, -1, -1, - -1, -1, -1, -1, 190, 191, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 214, -1, - -1, 217, -1, 37, -1, -1, 0, 41, 42, -1, - 44, -1, -1, 47, 230, -1, 232, -1, 234, -1, - 236, -1, 238, -1, 58, 59, 60, 243, 62, 63, - -1, -1, 248, 249, -1, -1, -1, -1, -1, -1, - 256, 257, -1, 37, -1, -1, -1, 41, 42, -1, - 44, -1, -1, 47, 0, -1, -1, -1, -1, 93, - 94, -1, -1, -1, 58, 59, 60, -1, 62, 63, - -1, -1, 288, 289, 290, 291, -1, -1, 112, -1, - 296, -1, -1, -1, -1, 301, -1, -1, -1, 123, - 124, 37, 308, 309, 0, 41, 42, 313, 44, 93, - 94, 47, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 58, 59, 60, -1, 62, 63, 112, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, - 124, 37, -1, -1, -1, 41, 42, -1, 44, -1, - -1, 47, -1, -1, -1, -1, -1, 93, 94, -1, - -1, -1, 58, 59, 60, -1, 62, 63, -1, -1, - -1, -1, -1, -1, -1, -1, 112, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 123, 124, 40, - -1, -1, 43, -1, 45, -1, -1, 93, 94, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, - -1, 62, -1, -1, -1, -1, 112, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 123, 124, -1, - -1, -1, -1, 257, 258, -1, 260, 261, 262, -1, - -1, 265, -1, -1, -1, -1, -1, -1, -1, -1, - 274, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 285, -1, -1, 288, 289, 290, 291, 292, 293, - 294, 295, 296, 257, 258, -1, 260, 261, 262, -1, - -1, 265, -1, -1, -1, -1, -1, -1, -1, -1, - 274, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 293, 294, 295, 296, -1, -1, -1, 300, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 37, 47, 48, -1, 41, 42, -1, 44, -1, + -1, 47, -1, 257, 258, 259, 260, 261, 262, -1, + -1, 265, 58, 59, 60, -1, 62, 63, -1, -1, + 274, 0, -1, -1, -1, -1, 81, -1, 83, 84, -1, 285, -1, -1, 288, 289, 290, 291, 292, 293, - 294, 295, 296, -1, -1, -1, -1, -1, -1, -1, - -1, 257, 258, -1, 260, 261, 262, -1, -1, 265, - -1, -1, -1, -1, -1, -1, -1, -1, 274, -1, - -1, -1, -1, 0, -1, -1, -1, -1, -1, 285, + 294, 295, 296, -1, -1, -1, 300, 93, 94, -1, + -1, -1, -1, -1, -1, -1, 111, 112, 37, -1, + -1, -1, 41, 42, -1, 44, 112, -1, 47, 0, + -1, -1, -1, -1, -1, -1, -1, 123, 124, 58, + 59, 60, -1, 62, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 37, -1, -1, -1, + 41, 42, -1, 44, 93, 94, 47, -1, -1, 174, + -1, -1, -1, -1, -1, -1, -1, 58, 59, 60, + 185, 62, 187, 112, 189, -1, -1, -1, -1, -1, + -1, 0, -1, -1, 123, 124, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 211, -1, -1, -1, + -1, -1, 93, 94, -1, -1, -1, -1, -1, -1, + -1, 226, 227, 228, 229, 230, -1, -1, 37, -1, + -1, 112, 41, 42, -1, 44, -1, -1, 47, -1, + -1, -1, 123, 124, -1, -1, -1, -1, -1, 58, + 59, 60, -1, 62, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, -1, -1, 265, + 275, -1, -1, -1, 279, 280, 281, -1, 274, 0, + 285, -1, -1, -1, 93, 94, -1, -1, -1, 285, -1, -1, 288, 289, 290, 291, 292, 293, 294, 295, - 296, 257, 258, -1, 260, 261, 262, -1, -1, 265, - -1, -1, -1, -1, -1, -1, -1, -1, 274, -1, - 37, -1, -1, 0, 41, 42, -1, 44, -1, 285, - 47, -1, 288, 289, 290, 291, 292, 293, 294, 295, - 296, 58, 59, 60, -1, 62, 63, -1, 259, -1, + 296, -1, -1, 112, 300, 310, 311, -1, -1, -1, + -1, 316, -1, -1, 123, 124, 37, -1, -1, -1, + 41, 42, -1, 44, -1, -1, 47, -1, 257, 258, + 259, 260, 261, 262, -1, -1, 265, 58, 59, 60, + -1, 62, -1, -1, -1, 274, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 285, -1, -1, 288, + 289, 290, -1, -1, -1, -1, 295, 296, -1, -1, + -1, 300, 93, 94, -1, -1, 257, 258, 259, 260, + 261, 262, -1, -1, 265, -1, -1, -1, -1, 40, + 41, 112, 43, 274, 45, -1, -1, -1, -1, 0, + -1, -1, 123, 124, 285, -1, -1, 288, 289, 290, + -1, -1, 63, -1, 295, 296, -1, -1, -1, 300, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 37, -1, -1, -1, + 41, 42, -1, 44, -1, -1, 47, -1, 257, 258, + 259, 260, 261, 262, -1, -1, 265, 58, 59, 60, + -1, 62, -1, -1, -1, 274, 0, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 285, -1, -1, 288, + 289, 290, -1, -1, -1, -1, 295, 296, -1, -1, + -1, 300, 93, 94, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 37, -1, -1, -1, 41, 42, -1, + -1, 112, -1, 47, 0, -1, -1, -1, -1, -1, + -1, -1, 123, 124, 58, 59, 60, -1, 62, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, -1, -1, 265, -1, -1, -1, -1, -1, + -1, 37, -1, 274, -1, 41, 42, -1, 44, 93, + 94, 47, -1, -1, 285, -1, -1, 288, 289, 290, + -1, -1, 58, 59, 295, 296, -1, -1, 112, 300, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, + 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, - 37, -1, -1, -1, 41, 42, -1, 44, 0, 280, - 47, 282, 283, 284, -1, 286, 93, 94, -1, -1, - -1, 58, 59, -1, -1, 296, 63, 298, -1, 300, - 301, 302, 303, 304, -1, 112, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 37, 123, 124, 0, 41, - 42, -1, 44, -1, -1, 47, 93, 94, -1, -1, - -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - -1, 63, -1, -1, -1, 112, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 37, 123, 124, -1, 41, - 42, -1, 44, 0, -1, 47, -1, -1, -1, -1, - -1, 93, 94, -1, -1, -1, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 37, 123, 124, -1, 41, 42, -1, 44, -1, -1, - 47, 93, 94, -1, -1, -1, -1, -1, -1, -1, - -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, - 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 123, 124, -1, 40, 41, -1, 43, 44, 45, - 257, 258, -1, 260, 261, 262, 93, 94, 265, -1, - -1, -1, -1, -1, 60, -1, 62, 274, -1, -1, - -1, -1, -1, -1, -1, 112, -1, -1, 285, -1, - -1, 288, 289, 290, -1, -1, 123, 124, 295, 296, - 257, 258, -1, 260, 261, 262, -1, -1, 265, -1, - -1, -1, -1, -1, -1, -1, -1, 274, -1, -1, - 40, -1, -1, 43, -1, 45, -1, -1, 285, -1, - -1, 288, 289, 290, 291, 292, 293, 294, 295, 59, - -1, -1, -1, -1, -1, 257, 258, -1, 260, 261, - 262, -1, -1, 265, -1, -1, -1, -1, -1, -1, - -1, -1, 274, 0, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 285, -1, -1, 288, 289, 290, -1, - -1, -1, -1, -1, -1, 257, 258, -1, 260, 261, - 262, -1, -1, 265, -1, -1, -1, -1, -1, -1, - 37, -1, 274, 123, 41, 42, -1, 44, 0, -1, - 47, -1, -1, 285, -1, -1, 288, 289, 290, -1, - -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, - 257, 258, -1, 260, 261, 262, -1, -1, 265, -1, - -1, -1, -1, -1, -1, 37, -1, 274, -1, 41, - 42, -1, -1, -1, -1, 47, 93, 94, 285, -1, - -1, 288, 289, 290, -1, -1, 58, 59, -1, -1, - -1, 63, -1, 259, -1, 112, -1, 263, 264, -1, - -1, -1, 268, 269, -1, 40, 123, 124, 43, -1, - 45, -1, -1, -1, 280, -1, 282, 283, 284, -1, - 286, 93, 94, -1, 59, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, - 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 123, 124, -1, -1, -1, -1, -1, -1, 259, - 260, 261, 262, 263, 264, -1, 266, 267, 268, 269, - 270, -1, 272, 273, -1, 275, 276, 277, 278, 279, - 280, 281, 282, 283, 284, -1, 286, 287, 123, -1, - 125, 291, 292, 293, 294, -1, -1, -1, 298, -1, - 300, 301, 302, 303, 304, -1, -1, -1, -1, 40, - -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, + -1, -1, -1, -1, -1, -1, 112, -1, -1, 280, + -1, 282, 283, 284, -1, 286, -1, 123, 124, -1, + 291, 292, 293, 294, -1, -1, -1, 298, -1, -1, + 301, 302, 303, 304, -1, -1, 257, 258, 259, 260, + 261, 262, -1, -1, 265, -1, -1, -1, -1, -1, + -1, -1, -1, 274, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 285, -1, -1, 288, 289, 290, + -1, -1, -1, -1, 295, 296, -1, -1, -1, 300, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 257, 258, -1, 260, 261, 262, -1, -1, 265, -1, - -1, -1, -1, -1, -1, -1, -1, 274, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 285, -1, - -1, 288, 289, 290, -1, -1, -1, 40, -1, -1, - 43, -1, 45, -1, -1, 257, 258, -1, 260, 261, - 262, -1, 123, 265, 125, -1, 59, -1, -1, -1, - -1, -1, 274, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 285, -1, -1, 288, 289, 290, -1, - -1, -1, -1, -1, 259, 260, -1, -1, 263, 264, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 257, 258, 259, 260, 261, 262, -1, + -1, 265, -1, -1, -1, -1, -1, -1, -1, -1, + 274, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 285, -1, -1, 288, 289, 290, -1, -1, -1, + -1, 295, 296, -1, -1, -1, 300, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, -1, 7, 265, + -1, -1, -1, -1, -1, 14, -1, -1, 274, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 285, + 29, -1, 288, 289, 290, -1, 35, -1, -1, -1, + -1, -1, -1, -1, 300, -1, -1, -1, -1, -1, + 49, 50, 51, -1, -1, -1, 55, 56, -1, 58, + 59, 60, -1, 62, 63, 64, 65, 66, -1, -1, + -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, + 45, -1, -1, 82, -1, -1, 85, 86, 87, 88, + 89, 90, -1, -1, 59, -1, -1, -1, -1, -1, + -1, 100, -1, -1, -1, -1, -1, -1, -1, 108, + -1, -1, -1, -1, -1, -1, 115, -1, -1, -1, + 40, -1, 121, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 136, 137, 59, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, + 159, 160, -1, -1, 163, 164, 165, 166, 167, -1, + -1, -1, -1, 172, 173, 40, 175, 176, 43, -1, + 45, 180, -1, -1, -1, 184, -1, -1, -1, -1, + -1, -1, -1, -1, 59, -1, 195, -1, -1, 198, + -1, -1, -1, 123, -1, 125, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 217, 218, + 219, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 236, -1, 238, + -1, 240, -1, 242, -1, 244, -1, -1, -1, 40, + 249, -1, 43, -1, 45, 254, 255, -1, 123, -1, + 125, -1, -1, 262, -1, -1, -1, -1, 59, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 282, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 260, 261, 262, 263, 264, + 299, 266, 267, 268, 269, 270, -1, 272, 273, -1, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + -1, 286, 287, -1, -1, -1, 291, 292, 293, 294, + -1, -1, 123, 298, 125, -1, 301, 302, 303, 304, + 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, + 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, + 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, + -1, 291, 292, 293, 294, -1, -1, -1, 298, -1, + -1, 301, 302, 303, 304, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, 293, 294, - 123, -1, 125, 298, -1, 300, 301, 302, 303, 304, - -1, -1, -1, -1, 40, -1, -1, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 40, -1, -1, 43, -1, 45, 259, 260, + -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, + 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, -1, 286, 287, 123, -1, 125, - 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, + 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, + 291, 292, 293, 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, + -1, -1, -1, 123, -1, 125, -1, -1, -1, -1, + -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 59, -1, -1, 259, 260, -1, -1, - 263, 264, -1, 266, 267, 268, 269, 270, 271, 272, - 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, - 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, - 293, 294, -1, -1, -1, 298, -1, 300, 301, 302, - 303, 304, -1, -1, -1, -1, 40, -1, -1, 43, - -1, 45, -1, -1, -1, -1, -1, 123, -1, 125, - -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 259, 260, -1, -1, 263, 264, -1, - 266, 267, 268, 269, 270, 271, 272, 273, -1, 275, - 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, - 286, 287, -1, -1, -1, 291, 292, 293, 294, 123, - -1, 125, 298, -1, 300, 301, 302, 303, 304, 40, - -1, 259, 43, -1, 45, 263, 264, -1, -1, -1, - 268, 269, -1, -1, -1, -1, -1, -1, 59, -1, - -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, - -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, - 298, -1, 300, 301, 302, 303, 304, 40, -1, -1, - 43, -1, 45, 259, 260, -1, -1, 263, 264, -1, - 266, 267, 268, 269, 270, 271, 272, 273, -1, 275, - 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, - 286, 287, 123, -1, 125, 291, 292, 293, 294, -1, - -1, -1, 298, -1, 300, 301, 302, 303, 304, 40, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, - -1, -1, -1, -1, -1, 259, 260, -1, -1, 263, - 264, -1, 266, 267, 268, 269, 270, 271, 272, 273, - -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, - 284, -1, 286, 287, -1, -1, -1, 291, 292, 293, - 294, -1, -1, -1, 298, -1, 300, 301, 302, 303, - 304, 40, -1, -1, 43, -1, 45, -1, -1, -1, - -1, -1, 123, -1, 125, -1, -1, -1, -1, -1, - 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 259, 260, - -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, - 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, - 291, 292, 293, 294, 123, -1, 125, 298, -1, 300, - 301, 302, 303, 304, 40, -1, 259, 43, -1, 45, - 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, - -1, -1, -1, 59, -1, -1, -1, 280, -1, 282, - 283, 284, -1, 286, -1, -1, -1, -1, 291, 292, - 293, 294, -1, -1, -1, 298, -1, 300, 301, 302, - 303, 304, 40, -1, -1, 43, -1, 45, 259, 260, - -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, - 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, -1, 286, 287, 123, -1, 125, - 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, - 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, + -1, -1, -1, -1, -1, -1, -1, 123, -1, 125, + -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, + 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, - 259, 260, -1, -1, 263, 264, -1, 266, 267, 268, - 269, 270, -1, 272, 273, -1, 275, 276, 277, 278, - 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, - -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, - -1, 300, 301, 302, 303, 304, 40, -1, -1, 43, - -1, 45, -1, -1, -1, -1, -1, 123, -1, 125, - -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, + -1, -1, 123, -1, 125, -1, -1, -1, 40, 41, + -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, + 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, + 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, + 280, 281, 282, 283, 284, -1, 286, 287, 123, -1, + 125, 291, 292, 293, 294, -1, -1, -1, 298, -1, + -1, 301, 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 259, 260, -1, -1, 263, 264, -1, - 266, 267, 268, 269, 270, -1, 272, 273, -1, 275, - 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, - 286, 287, -1, -1, -1, 291, 292, 293, 294, 123, - -1, 125, 298, -1, 300, 301, 302, 303, 304, 40, - -1, 259, 43, -1, 45, 263, 264, -1, -1, -1, - 268, 269, -1, -1, -1, -1, -1, -1, 59, -1, - -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, - -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, - 298, -1, 300, 301, 302, 303, 304, -1, -1, -1, - -1, -1, -1, 259, 260, -1, -1, 263, 264, -1, - 266, 267, 268, 269, 270, -1, 272, 273, -1, 275, + -1, -1, -1, -1, 260, -1, -1, 263, 264, -1, + 266, 267, 268, 269, 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, - 286, 287, 123, -1, 125, 291, 292, 293, 294, -1, - -1, -1, 298, -1, 300, 301, 302, 303, 304, 40, - -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, - -1, -1, -1, -1, -1, 259, 260, -1, -1, 263, + 286, 287, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, -1, 301, 302, 303, 304, 260, + -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, + 271, 272, 273, -1, 275, 276, 277, 278, 279, 280, + 281, 282, 283, 284, 40, 286, 287, 43, -1, 45, + 291, 292, 293, 294, -1, -1, -1, 298, -1, -1, + 301, 302, 303, 304, -1, 260, -1, -1, 263, 264, + -1, 266, 267, 268, 269, 270, 271, 272, 273, -1, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + -1, 286, 287, -1, -1, -1, 291, 292, 293, 294, + -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, + 40, 263, 264, 43, -1, 45, 268, 269, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 123, 280, 59, + 282, 283, 284, -1, 286, -1, -1, -1, -1, 291, + 292, 293, 294, -1, -1, -1, 298, -1, -1, 301, + 302, 303, 304, -1, -1, 40, -1, -1, 43, -1, + 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 59, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 123, -1, 125, -1, -1, -1, -1, + 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, + 125, -1, -1, -1, -1, -1, 40, -1, -1, 43, + -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, -1, 59, -1, 263, 264, -1, + -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 123, 280, 125, 282, 283, 284, 285, + 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, 300, 301, 302, 303, 304, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 40, -1, -1, 43, -1, 45, -1, -1, -1, 123, + 260, 125, -1, 263, 264, -1, 266, 267, 268, 269, + 270, 271, 272, 273, -1, 275, 276, 277, 278, 279, + 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, + -1, 291, 292, 293, 294, -1, -1, -1, 298, -1, + -1, 301, 302, 303, 304, 260, -1, -1, 263, 264, + -1, 266, 267, 268, 269, 270, -1, 272, 273, -1, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + -1, 286, 287, -1, -1, -1, 291, 292, 293, 294, + -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, + 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, + 270, -1, 272, 273, -1, 275, 276, 277, 278, 279, + 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, + -1, 291, 292, 293, 294, -1, -1, -1, 298, -1, + -1, 301, 302, 303, 304, -1, 260, -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, -1, 272, 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, 293, - 294, -1, -1, -1, 298, -1, 300, 301, 302, 303, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, -1, -1, -1, - -1, -1, 123, -1, 125, -1, -1, -1, -1, -1, - 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 259, 260, - -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, - -1, 272, 273, -1, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, - 291, 292, 293, 294, 123, -1, 125, 298, -1, 300, - 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, + 59, -1, -1, -1, -1, -1, -1, -1, -1, 259, + -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, + -1, -1, -1, -1, -1, -1, 40, -1, -1, 43, + 280, 45, 282, 283, 284, -1, 286, -1, -1, -1, + -1, 291, 292, 293, 294, 59, -1, -1, 298, -1, + 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 123, -1, 125, -1, -1, -1, + -1, 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, + 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, + -1, 125, -1, -1, -1, -1, -1, 40, -1, -1, + 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 123, -1, 125, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 40, -1, -1, + 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 40, -1, -1, 43, -1, 45, -1, -1, 259, 260, - -1, -1, 263, 264, -1, 266, 267, 268, 269, 270, - -1, 272, 273, -1, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, -1, 286, 287, 123, -1, 125, - 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, - 301, 302, 303, 304, 40, 41, -1, 43, 44, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 60, -1, 62, -1, -1, -1, - 259, 260, -1, -1, 263, 264, -1, 266, 267, 268, + 123, 260, 125, -1, 263, 264, -1, 266, 267, 268, 269, 270, -1, 272, 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, - -1, 300, 301, 302, 303, 304, 40, 41, -1, 43, - 44, 45, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 60, -1, 62, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 259, 260, -1, -1, 263, 264, -1, - 266, 267, 268, 269, 270, -1, 272, 273, -1, 275, - 276, 277, 278, 279, 280, 281, 282, 283, 284, -1, - 286, 287, -1, -1, -1, 291, 292, 293, 294, -1, - -1, -1, 298, -1, 300, 301, 302, 303, 304, 259, - -1, -1, -1, 263, 264, -1, 266, 267, 268, 269, - -1, -1, -1, -1, -1, 275, 276, 277, 278, 279, - 280, -1, 282, 283, 284, -1, 286, 287, -1, -1, - -1, 291, 292, 293, 294, -1, -1, -1, 298, -1, - 300, 301, 302, 303, 304, 40, 41, -1, 43, 44, - 45, -1, -1, 259, -1, -1, -1, 263, 264, -1, - -1, -1, 268, 269, -1, 60, -1, 62, -1, -1, - -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, - 286, -1, -1, -1, -1, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, 40, - 41, -1, 43, 44, 45, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, - -1, 62, -1, -1, -1, 259, -1, -1, -1, 263, - 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, - 284, 40, 286, -1, 43, 44, 45, 291, 292, 293, - 294, 295, 296, -1, 298, -1, 300, 301, 302, 303, - 304, 60, -1, 62, -1, -1, -1, -1, -1, -1, + -1, -1, 301, 302, 303, 304, 260, -1, -1, 263, + 264, -1, 266, 267, 268, 269, 270, -1, 272, 273, + -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, + 284, -1, 286, 287, -1, -1, -1, 291, 292, 293, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, + 304, 260, -1, -1, 263, 264, -1, 266, 267, 268, + 269, 270, -1, 272, 273, -1, 275, 276, 277, 278, + 279, 280, 281, 282, 283, 284, 40, 286, 287, 43, + 44, 45, 291, 292, 293, 294, -1, -1, -1, 298, + -1, -1, 301, 302, 303, 304, 60, 260, 62, 63, + 263, 264, -1, 266, 267, 268, 269, 270, -1, 272, + 273, -1, 275, 276, 277, 278, 279, 280, 281, 282, + 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, + 293, 294, -1, -1, -1, 298, -1, -1, 301, 302, + 303, 304, 40, -1, -1, 43, -1, 45, -1, -1, + 263, 264, -1, 266, 267, 268, 269, -1, -1, -1, + -1, 59, 275, 276, 277, 278, 279, 280, -1, 282, + 283, 284, -1, 286, 287, -1, -1, -1, 291, 292, + 293, 294, -1, -1, -1, 298, -1, -1, 301, 302, + 303, 304, 40, -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 40, 41, -1, - 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 60, -1, 62, + -1, -1, 60, -1, 62, 63, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 123, -1, 125, -1, -1, + -1, -1, -1, -1, 40, 41, -1, 43, 44, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 40, -1, -1, 43, 44, 45, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 40, 41, + -1, 43, 44, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 263, + 264, 63, -1, -1, 268, 269, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, + 284, -1, 286, -1, -1, -1, -1, 291, 292, 293, + 294, 295, 296, -1, 298, -1, -1, 301, 302, 303, + 304, 40, 41, -1, 43, 44, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 60, 259, 62, -1, -1, 263, 264, - -1, -1, -1, 268, 269, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - 40, 286, -1, 43, 44, 45, 291, 292, 293, 294, - 295, 296, -1, 298, -1, 300, 301, 302, 303, 304, - 60, -1, 62, -1, -1, -1, -1, -1, 259, -1, - -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, - -1, 282, 283, 284, 40, 286, -1, 43, 44, 45, - 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, - 301, 302, 303, 304, 60, -1, 62, -1, -1, -1, - 259, -1, -1, -1, 263, 264, -1, -1, -1, 268, - 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, - -1, -1, 291, 292, 293, 294, 295, 296, -1, 298, - -1, 300, 301, 302, 303, 304, 259, -1, -1, -1, - 263, 264, -1, -1, 40, 268, 269, 43, 44, 45, - -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, - 283, 284, -1, 286, 60, -1, 62, -1, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, 259, -1, -1, -1, 263, 264, -1, -1, - 40, 268, 269, 43, 44, 45, -1, -1, -1, -1, - -1, -1, -1, 280, -1, 282, 283, 284, -1, 286, - 60, -1, 62, -1, 291, 292, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, 303, 304, -1, 259, - -1, -1, -1, 263, 264, -1, -1, 40, 268, 269, - 43, 44, 45, -1, -1, -1, -1, -1, -1, -1, - 280, -1, 282, 283, 284, -1, 286, 60, -1, 62, - -1, 291, 292, 293, 294, 295, 296, -1, 298, -1, - 300, 301, 302, 303, 304, -1, -1, -1, -1, -1, - -1, -1, -1, 259, -1, -1, -1, 263, 264, -1, + -1, -1, 260, -1, 63, 263, 264, -1, 266, 267, + 268, 269, 270, -1, 272, 273, -1, 275, 276, 277, + 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, + -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, + 298, -1, -1, 301, 302, 303, 304, 40, -1, -1, + 43, -1, 45, -1, -1, 263, 264, -1, -1, -1, + 268, 269, -1, -1, -1, -1, 59, -1, -1, -1, + -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, + -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, + 298, -1, -1, 301, 302, 303, 304, 263, 264, -1, -1, 40, 268, 269, 43, -1, 45, -1, -1, -1, - -1, -1, -1, -1, 280, -1, 282, 283, 284, 58, - 286, 60, -1, 62, -1, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, -1, - -1, -1, -1, -1, -1, -1, -1, 40, 41, -1, - 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 60, -1, 62, - -1, -1, -1, 259, -1, -1, -1, 263, 264, -1, - -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, - 286, -1, -1, -1, -1, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, 259, - -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, - -1, 291, 292, 293, 294, 295, 296, -1, 298, -1, - 300, 301, 302, 303, 304, -1, 259, -1, -1, -1, + 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, -1, 301, 302, 303, 304, -1, + -1, 263, 264, -1, -1, 40, 268, 269, 43, 44, + 45, -1, -1, -1, -1, -1, -1, -1, 280, -1, + 282, 283, 284, -1, 286, -1, -1, -1, 63, 291, + 292, 293, 294, -1, -1, -1, 298, -1, -1, 301, + 302, 303, 304, -1, -1, -1, -1, -1, 40, -1, + -1, 43, 44, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 263, 264, -1, -1, -1, 268, + 269, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, + -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, + -1, -1, 301, 302, 303, 304, 40, -1, -1, 43, + 44, 45, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 259, -1, -1, 63, 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, - 283, 284, -1, 286, -1, -1, -1, -1, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, 40, 41, -1, 43, -1, 45, -1, -1, + 283, 284, 40, 286, -1, 43, 44, 45, 291, 292, + 293, 294, -1, -1, -1, 298, -1, 300, 301, 302, + 303, 304, -1, -1, -1, 63, -1, -1, -1, -1, 259, -1, -1, -1, 263, 264, -1, -1, -1, 268, - 269, -1, 60, -1, 62, -1, -1, -1, -1, -1, + 269, -1, -1, -1, 40, -1, -1, 43, 44, 45, -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, - -1, -1, 291, 292, 293, 294, 295, 296, -1, 298, - -1, 300, 301, 302, 303, 304, 259, -1, -1, -1, - 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, + -1, -1, 291, 292, 293, 294, -1, 63, -1, 298, + -1, 300, 301, 302, 303, 304, -1, -1, 263, 264, + -1, -1, -1, 268, 269, -1, -1, 40, -1, -1, + 43, 44, 45, -1, -1, 280, -1, 282, 283, 284, + -1, 286, -1, -1, -1, -1, 291, 292, 293, 294, + 63, -1, -1, 298, -1, -1, 301, 302, 303, 304, + -1, 263, 264, -1, -1, -1, 268, 269, -1, -1, + 40, -1, -1, 43, 44, 45, -1, -1, 280, -1, + 282, 283, 284, -1, 286, -1, -1, -1, -1, 291, + 292, 293, 294, 63, -1, -1, 298, -1, -1, 301, + 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 40, -1, -1, 43, -1, 45, -1, 263, + 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, + 58, -1, -1, -1, -1, 63, 280, -1, 282, 283, + 284, -1, 286, -1, -1, -1, -1, 291, 292, 293, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, + 304, -1, -1, -1, -1, 263, 264, -1, -1, 40, + 268, 269, 43, -1, 45, -1, -1, -1, -1, -1, + -1, -1, 280, -1, 282, 283, 284, 58, 286, -1, + -1, -1, 63, 291, 292, 293, 294, -1, -1, -1, + 298, -1, -1, 301, 302, 303, 304, 263, 264, -1, + -1, -1, 268, 269, 40, -1, -1, 43, -1, 45, + -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, + 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, -1, 301, 302, 303, 304, -1, + 263, 264, -1, -1, -1, 268, 269, -1, -1, 40, + 41, -1, 43, -1, 45, -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, -1, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, 40, 41, -1, 43, -1, 45, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 60, -1, 62, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 40, 41, - -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, - 62, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 40, 41, -1, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 60, -1, 62, -1, -1, -1, - -1, 259, -1, -1, -1, 263, 264, -1, -1, -1, - 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, + 293, 294, 63, -1, -1, 298, -1, -1, 301, 302, + 303, 304, -1, 263, 264, -1, -1, -1, 268, 269, + -1, -1, 40, 41, -1, 43, -1, 45, -1, -1, + 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, + -1, 291, 292, 293, 294, 63, -1, -1, 298, -1, + -1, 301, 302, 303, 304, 263, 264, -1, -1, -1, + 268, 269, -1, -1, 40, 41, -1, 43, -1, 45, -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, - -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, - 298, -1, 300, 301, 302, 303, 304, 40, 41, -1, - 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 60, -1, 62, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 291, 292, 293, 294, 63, -1, -1, + 298, -1, -1, 301, 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 40, 41, -1, 43, -1, 45, -1, - -1, 259, -1, -1, -1, 263, 264, -1, -1, -1, - 268, 269, -1, 60, -1, 62, -1, -1, -1, -1, + -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, + -1, 40, 41, -1, 43, -1, 45, -1, -1, 280, + -1, 282, 283, 284, -1, 286, -1, -1, -1, -1, + 291, 292, 293, 294, 63, -1, -1, 298, -1, -1, + 301, 302, 303, 304, -1, 261, 262, 263, 264, -1, + -1, -1, 268, 269, -1, -1, 40, 41, -1, 43, + -1, 45, -1, -1, 280, -1, 282, 283, 284, -1, + 286, -1, -1, -1, -1, 291, 292, 293, 294, 63, + -1, -1, 298, -1, -1, 301, 302, 303, 304, -1, + -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, + -1, 40, 41, -1, 43, -1, 45, -1, -1, 280, + -1, 282, 283, 284, -1, 286, -1, -1, -1, -1, + 291, 292, 293, 294, 63, -1, -1, 298, -1, -1, + 301, 302, 303, 304, -1, 263, 264, -1, -1, -1, + 268, 269, -1, -1, 40, 41, -1, 43, -1, 45, -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, - -1, -1, -1, 291, 292, 293, 294, 295, 296, -1, - 298, -1, 300, 301, 302, 303, 304, 259, -1, -1, - -1, 263, 264, -1, -1, -1, 268, 269, 40, -1, - -1, 43, -1, 45, -1, -1, -1, -1, 280, -1, - 282, 283, 284, -1, 286, -1, -1, -1, -1, 291, - 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, - 302, 303, 304, 259, -1, -1, -1, 263, 264, -1, + -1, -1, -1, 291, 292, 293, 294, 63, -1, -1, + 298, -1, -1, 301, 302, 303, 304, 263, 264, -1, + -1, -1, 268, 269, -1, -1, 40, 41, -1, 43, + -1, 45, -1, -1, 280, -1, 282, 283, 284, -1, + 286, -1, -1, -1, -1, 291, 292, 293, 294, 63, + -1, -1, 298, -1, -1, 301, 302, 303, 304, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 263, 264, -1, -1, -1, 268, + 269, -1, -1, 40, 41, -1, 43, -1, 45, -1, + -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, + -1, -1, 291, 292, 293, 294, 63, -1, -1, 298, + -1, -1, 301, 302, 303, 304, -1, -1, -1, 263, + 264, -1, -1, -1, 268, 269, -1, -1, -1, 40, + -1, -1, 43, -1, 45, -1, 280, -1, 282, 283, + 284, -1, 286, -1, -1, -1, -1, 291, 292, 293, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, + 304, -1, -1, -1, 263, 264, -1, -1, -1, 268, + 269, -1, -1, -1, -1, 40, -1, -1, 43, -1, + 45, 280, -1, 282, 283, 284, -1, 286, -1, -1, + -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, + -1, -1, 301, 302, 303, 304, -1, 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, - 286, -1, -1, -1, -1, 291, 292, 293, 294, 295, - 296, -1, 298, -1, 300, 301, 302, 303, 304, 40, - 41, 123, 43, -1, 45, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, - -1, 62, -1, -1, -1, -1, 259, -1, -1, -1, - 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, - 283, 284, 40, 286, -1, 43, -1, 45, 291, 292, - 293, 294, 295, 296, -1, 298, -1, 300, 301, 302, - 303, 304, 259, -1, -1, -1, 263, 264, -1, -1, - -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 280, -1, 282, 283, 284, -1, 286, - -1, -1, -1, -1, 291, 292, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, 303, 304, 40, 41, - -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 257, 258, 259, 60, -1, - 62, 263, 264, -1, -1, -1, 268, 269, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, - 282, 283, 284, 285, 286, -1, -1, -1, -1, 291, - 292, 293, 294, -1, -1, -1, 298, -1, 300, 301, - 302, 303, 304, 40, -1, -1, 43, -1, 45, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 60, -1, 62, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 259, -1, - -1, -1, 263, 264, -1, -1, -1, 268, 269, 40, - -1, -1, 43, -1, 45, -1, -1, -1, -1, 280, - -1, 282, 283, 284, -1, 286, -1, -1, 59, -1, - 291, 292, 293, 294, 295, 296, -1, 298, -1, 300, - 301, 302, 303, 304, -1, -1, -1, -1, -1, -1, - -1, 259, -1, -1, -1, 263, 264, -1, -1, 40, - 268, 269, 43, -1, 45, -1, -1, -1, -1, -1, - -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, - -1, -1, -1, 291, 292, 293, 294, -1, -1, -1, - 298, -1, 300, 301, 302, 303, 304, -1, -1, -1, - -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, - 45, -1, -1, -1, -1, -1, -1, 259, -1, -1, - -1, 263, 264, -1, -1, -1, 268, 269, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, - 282, 283, 284, -1, 286, -1, -1, -1, -1, 291, - 292, 293, 294, 295, 296, -1, 298, -1, 300, 301, - 302, 303, 304, 40, -1, -1, 43, -1, 45, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 259, -1, -1, -1, 263, 264, -1, -1, + -1, -1, -1, -1, 280, -1, 282, 283, 284, 40, + 286, -1, 43, -1, 45, 291, 292, 293, 294, -1, + -1, -1, 298, -1, -1, 301, 302, 303, 304, 263, + 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, + 284, -1, 286, -1, -1, -1, -1, 291, 292, 293, + 294, -1, -1, -1, 298, -1, -1, 301, 302, 303, + 304, 40, -1, -1, 43, -1, 45, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, 286, - -1, -1, -1, -1, 291, 292, 293, 294, 295, 296, - -1, 298, -1, 300, 301, 302, 303, 304, 259, -1, - -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, + -1, -1, -1, -1, 291, 292, 293, 294, -1, -1, + -1, 298, -1, -1, 301, 302, 303, 304, 259, -1, + -1, 40, 263, 264, 43, -1, 45, 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, - -1, 282, 283, 284, -1, 286, -1, -1, -1, -1, - 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, - 301, 302, 303, 304, -1, -1, -1, -1, 259, -1, + -1, 282, 283, 284, 63, 286, -1, -1, -1, -1, + 291, 292, 293, 294, -1, -1, -1, 298, -1, -1, + 301, 302, 303, 304, 259, -1, -1, 40, 263, 264, + 43, -1, 45, 268, 269, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, + -1, 286, -1, -1, -1, -1, 291, 292, 293, 294, + -1, -1, -1, 298, -1, -1, 301, 302, 303, 304, + 40, -1, -1, 43, -1, 45, -1, -1, 259, -1, -1, -1, 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, -1, - 291, 292, 293, 294, -1, -1, -1, 298, -1, 300, - 301, 302, 303, 304, 259, -1, -1, -1, 263, 264, - -1, -1, -1, 268, 269, -1, -1, 47, 48, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - -1, 286, -1, -1, -1, -1, 291, 292, 293, 294, - -1, -1, -1, 298, -1, 300, 301, 302, 303, 304, - 80, -1, 82, 83, -1, -1, -1, -1, -1, -1, - -1, -1, 259, -1, -1, -1, 263, 264, -1, -1, - -1, 268, 269, -1, -1, -1, -1, -1, 108, 109, - -1, -1, -1, 280, -1, 282, 283, 284, -1, 286, - -1, -1, -1, -1, 291, 292, 293, 294, -1, -1, - -1, 298, -1, 300, 301, 302, 303, 304, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 27, - 28, -1, -1, -1, -1, 33, -1, -1, -1, -1, - -1, -1, -1, 41, -1, -1, -1, -1, -1, -1, - 170, -1, -1, -1, -1, -1, 54, -1, -1, -1, - -1, 181, -1, 183, -1, 185, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 206, -1, -1, -1, - -1, -1, -1, 91, 92, 93, 94, 95, 96, -1, - -1, 221, 222, 223, 224, 225, 104, -1, 106, -1, - -1, -1, 110, 111, -1, -1, 114, -1, 116, 117, - -1, -1, -1, 121, 122, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 132, -1, -1, -1, -1, 137, - 138, 139, 140, -1, -1, -1, -1, -1, -1, 269, - -1, -1, -1, 273, 274, 275, -1, -1, -1, 279, - 158, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 304, 305, -1, -1, 186, -1, - 310, -1, -1, -1, -1, -1, -1, -1, -1, 197, - 198, -1, 200, 201, 202, 203, -1, 205, -1, 207, - 208, -1, -1, -1, -1, -1, -1, 215, 216, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 227, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 252, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 264, 265, 266, 267, - 268, -1, 270, 271, 272, + 291, 292, 293, 294, -1, -1, -1, 298, -1, -1, + 301, 302, 303, 304, 40, -1, -1, 43, -1, 45, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 259, -1, -1, -1, 263, 264, -1, -1, -1, 268, + 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, + -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, + -1, -1, 301, 302, 303, 304, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 263, 264, -1, -1, -1, 268, + 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 280, -1, 282, 283, 284, -1, 286, -1, -1, + -1, -1, 291, 292, 293, 294, -1, -1, -1, 298, + -1, -1, 301, 302, 303, 304, 259, -1, -1, -1, + 263, 264, -1, -1, -1, 268, 269, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 280, -1, 282, + 283, 284, -1, 286, -1, -1, -1, -1, 291, 292, + 293, 294, -1, -1, -1, 298, -1, -1, 301, 302, + 303, 304, -1, 263, 264, -1, -1, -1, 268, 269, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 280, -1, 282, 283, 284, -1, 286, -1, -1, -1, + -1, 291, 292, 293, 294, 16, -1, -1, 298, -1, + -1, 301, 302, 303, 304, -1, 27, 28, -1, 30, + 31, -1, 33, -1, -1, -1, -1, 263, 264, -1, + 41, -1, 268, 269, -1, -1, -1, -1, -1, -1, + -1, -1, 53, -1, 280, -1, 282, 283, 284, -1, + 286, -1, -1, -1, -1, 291, 292, 293, 294, -1, + -1, -1, 298, -1, -1, 301, 302, 303, 304, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 93, 94, 95, 96, 97, 98, -1, -1, + -1, -1, -1, -1, -1, 106, -1, -1, 109, -1, + -1, -1, 113, 114, -1, -1, 117, -1, 119, 120, + -1, -1, -1, 124, 125, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 135, -1, -1, -1, 139, -1, + 141, 142, 143, 144, -1, -1, -1, -1, -1, -1, + -1, 152, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 162, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 190, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 202, 203, -1, 205, 206, 207, 208, -1, 210, + -1, 212, 213, -1, -1, 27, 28, -1, -1, 220, + 221, 33, -1, -1, -1, -1, -1, -1, -1, 41, + -1, 232, 233, -1, -1, -1, -1, -1, -1, -1, + -1, 53, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 258, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 270, + 271, 272, 273, 274, -1, 276, 277, 278, -1, -1, + -1, 93, 94, 95, 96, 97, 98, -1, -1, -1, + -1, -1, -1, -1, 106, -1, -1, 109, -1, -1, + -1, 113, 114, -1, -1, 117, -1, 119, 120, -1, + -1, -1, 124, 125, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 135, -1, -1, -1, 139, -1, 141, + 142, 143, 144, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 162, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 190, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 202, 203, -1, 205, 206, 207, 208, -1, 210, -1, + 212, 213, -1, -1, -1, -1, -1, -1, 220, 221, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 232, 233, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 258, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 270, 271, + 272, 273, 274, -1, 276, 277, 278, }; #define YYFINAL 1 #ifndef YYDEBUG @@ -1806,6 +1866,7 @@ char *yyrule[] = { "match : '(' match ')'", "expr : term", "expr : expr term", +"expr : expr '?' expr ':' expr", "expr : variable ASGNOP cond", "term : variable", "term : NUMBER", @@ -1817,7 +1878,6 @@ char *yyrule[] = { "term : term '%' term", "term : term '^' term", "term : term IN VAR", -"term : cond '?' expr ':' expr", "term : variable INCR", "term : variable DECR", "term : INCR variable", @@ -1941,7 +2001,7 @@ YYSTYPE yyvs[YYSTACKSIZE]; #define yystacksize YYSTACKSIZE #line 396 "a2p.y" #include "a2py.c" -#line 1945 "y.tab.c" +#line 2005 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -2196,6 +2256,10 @@ case 34: break; case 35: #line 137 "a2p.y" +{ yyval = oper3(OCOND,yyvsp[-4],yyvsp[-2],yyvsp[0]); } +break; +case 36: +#line 139 "a2p.y" { yyval = oper3(OASSIGN,yyvsp[-1],yyvsp[-2],yyvsp[0]); if ((ops[yyvsp[-2]].ival & 255) == OFLD) lval_field = TRUE; @@ -2203,49 +2267,45 @@ case 35: lval_field = TRUE; } break; -case 36: -#line 146 "a2p.y" -{ yyval = yyvsp[0]; } -break; case 37: #line 148 "a2p.y" -{ yyval = oper1(ONUM,yyvsp[0]); } +{ yyval = yyvsp[0]; } break; case 38: #line 150 "a2p.y" -{ yyval = oper1(OSTR,yyvsp[0]); } +{ yyval = oper1(ONUM,yyvsp[0]); } break; case 39: #line 152 "a2p.y" -{ yyval = oper2(OADD,yyvsp[-2],yyvsp[0]); } +{ yyval = oper1(OSTR,yyvsp[0]); } break; case 40: #line 154 "a2p.y" -{ yyval = oper2(OSUBTRACT,yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(OADD,yyvsp[-2],yyvsp[0]); } break; case 41: #line 156 "a2p.y" -{ yyval = oper2(OMULT,yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(OSUBTRACT,yyvsp[-2],yyvsp[0]); } break; case 42: #line 158 "a2p.y" -{ yyval = oper2(ODIV,yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(OMULT,yyvsp[-2],yyvsp[0]); } break; case 43: #line 160 "a2p.y" -{ yyval = oper2(OMOD,yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(ODIV,yyvsp[-2],yyvsp[0]); } break; case 44: #line 162 "a2p.y" -{ yyval = oper2(OPOW,yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(OMOD,yyvsp[-2],yyvsp[0]); } break; case 45: #line 164 "a2p.y" -{ yyval = oper2(ODEFINED,aryrefarg(yyvsp[0]),yyvsp[-2]); } +{ yyval = oper2(OPOW,yyvsp[-2],yyvsp[0]); } break; case 46: #line 166 "a2p.y" -{ yyval = oper3(OCOND,yyvsp[-4],yyvsp[-2],yyvsp[0]); } +{ yyval = oper2(ODEFINED,aryrefarg(yyvsp[0]),yyvsp[-2]); } break; case 47: #line 168 "a2p.y" @@ -2607,7 +2667,7 @@ case 137: #line 392 "a2p.y" { yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); } break; -#line 2611 "y.tab.c" +#line 2671 "y.tab.c" } yyssp -= yym; yystate = *yyssp; @@ -8,7 +8,6 @@ * $Log: a2p.h,v $ */ -#include "../embed.h" #define VOIDUSED 1 #include "../config.h" @@ -31,7 +30,6 @@ # include <sys/types.h> #endif - #ifdef USE_NEXT_CTYPE #if NX_CURRENT_COMPILER_RELEASE >= 400 @@ -46,6 +44,15 @@ #define MEM_SIZE Size_t +#ifdef STANDARD_C +# include <stdlib.h> +#else + Malloc_t malloc _((MEM_SIZE nbytes)); + Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size)); + Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes)); + Free_t free _((Malloc_t where)); +#endif + #if defined(I_STRING) || defined(__cplusplus) # include <string.h> #else @@ -93,7 +100,8 @@ # endif #else # if defined(VMS) -# include "../vmsish.h" +# define NO_PERL_TYPEDEFS +# include "[-]vmsish.h" # endif #endif @@ -105,7 +113,11 @@ char *strchr(), *strrchr(); char *strcpy(), *strcat(); #endif /* ! STANDARD_C */ -#include "handy.h" +#include "../handy.h" + +#undef Nullfp +#define Nullfp Null(FILE*) + #define Nullop 0 #define OPROG 1 diff --git a/x2p/a2p.pod b/x2p/a2p.pod index 3976abab67..4e61fd6ab9 100644 --- a/x2p/a2p.pod +++ b/x2p/a2p.pod @@ -134,7 +134,7 @@ A2p uses no environment variables. =head1 AUTHOR -Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt> +Larry Wall E<lt>F<larry@wall.org>E<gt> =head1 FILES @@ -133,6 +133,8 @@ expr : term { $$ = $1; } | expr term { $$ = oper2(OCONCAT,$1,$2); } + | expr '?' expr ':' expr + { $$ = oper3(OCOND,$1,$3,$5); } | variable ASGNOP cond { $$ = oper3(OASSIGN,$2,$1,$3); if ((ops[$1].ival & 255) == OFLD) @@ -162,8 +164,6 @@ term : variable { $$ = oper2(OPOW,$1,$3); } | term IN VAR { $$ = oper2(ODEFINED,aryrefarg($3),$1); } - | cond '?' expr ':' expr - { $$ = oper3(OCOND,$1,$3,$5); } | variable INCR { $$ = oper1(OPOSTINCR,$1); } | variable DECR diff --git a/x2p/a2py.c b/x2p/a2py.c index 454e2dc860..0c37b6bbf9 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -154,7 +154,9 @@ register char **env; tmpstr = walk(0,0,root,&i,P_MIN); str = str_make(STARTPERL); - str_cat(str, "\neval 'exec perl -S $0 \"$@\"'\n\ + str_cat(str, "\neval 'exec "); + str_cat(str, BIN); + str_cat(str, "/perl -S $0 ${1+\"$@\"}'\n\ if $running_under_some_shell;\n\ # this emulates #! processing on NIH machines.\n\ # (remove #! line above if indigestible)\n\n"); diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index 32f78fe23f..2ffc338075 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,10 +23,11 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; \$startperl = "$Config{startperl}"; +\$perlpath = "$Config{perlpath}"; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -241,8 +240,7 @@ while (@ARGV) { print <<"END"; $startperl - -eval 'exec perl -S \$0 \${1+"\$@"}' + eval 'exec $perlpath -S \$0 \${1+"\$@"}' if \$running_under_some_shell; END diff --git a/x2p/handy.h b/x2p/handy.h deleted file mode 100644 index 0049a1108b..0000000000 --- a/x2p/handy.h +++ /dev/null @@ -1,172 +0,0 @@ -/* handy.h - * - * Copyright (c) 1991-1994, Larry Wall - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ - -#if !defined(__STDC__) -#ifdef NULL -#undef NULL -#endif -#ifndef I286 -# define NULL 0 -#else -# define NULL 0L -#endif -#endif - -#define Null(type) ((type)NULL) -#define Nullch Null(char*) -#define Nullfp Null(FILE*) -#define Nullsv Null(SV*) - -#ifdef UTS -#define bool int -#else -#define bool char -#endif - -#ifdef TRUE -#undef TRUE -#endif -#ifdef FALSE -#undef FALSE -#endif -#define TRUE (1) -#define FALSE (0) - -typedef char I8; -typedef unsigned char U8; - -typedef short I16; -typedef unsigned short U16; - -#if BYTEORDER > 0x4321 - typedef int I32; - typedef unsigned int U32; -#else - typedef long I32; - typedef unsigned long U32; -#endif - -#define Ctl(ch) (ch & 037) - -#define strNE(s1,s2) (strcmp(s1,s2)) -#define strEQ(s1,s2) (!strcmp(s1,s2)) -#define strLT(s1,s2) (strcmp(s1,s2) < 0) -#define strLE(s1,s2) (strcmp(s1,s2) <= 0) -#define strGT(s1,s2) (strcmp(s1,s2) > 0) -#define strGE(s1,s2) (strcmp(s1,s2) >= 0) -#define strnNE(s1,s2,l) (strncmp(s1,s2,l)) -#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) - -#ifdef HAS_SETLOCALE /* XXX Is there a better test for this? */ -# ifndef CTYPE256 -# define CTYPE256 -# endif -#endif - -#ifdef USE_NEXT_CTYPE -#define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_') -#define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_') -#define isALPHA(c) NXIsAlpha((unsigned int)c) -#define isSPACE(c) NXIsSpace((unsigned int)c) -#define isDIGIT(c) NXIsDigit((unsigned int)c) -#define isUPPER(c) NXIsUpper((unsigned int)c) -#define isLOWER(c) NXIsLower((unsigned int)c) -#define toUPPER(c) NXToUpper((unsigned int)c) -#define toLOWER(c) NXToLower((unsigned int)c) -#else /* USE_NEXT_CTYPE */ -#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) -#define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_') -#define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_') -#define isALPHA(c) isalpha((unsigned char)(c)) -#define isSPACE(c) isspace((unsigned char)(c)) -#define isDIGIT(c) isdigit((unsigned char)(c)) -#define isUPPER(c) isupper((unsigned char)(c)) -#define isLOWER(c) islower((unsigned char)(c)) -#define toUPPER(c) toupper((unsigned char)(c)) -#define toLOWER(c) tolower((unsigned char)(c)) -#else -#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_')) -#define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_')) -#define isALPHA(c) (isascii(c) && isalpha(c)) -#define isSPACE(c) (isascii(c) && isspace(c)) -#define isDIGIT(c) (isascii(c) && isdigit(c)) -#define isUPPER(c) (isascii(c) && isupper(c)) -#define isLOWER(c) (isascii(c) && islower(c)) -#define toUPPER(c) toupper(c) -#define toLOWER(c) tolower(c) -#endif -#endif /* USE_NEXT_CTYPE */ - -/* Line numbers are unsigned, 16 bits. */ -typedef U16 line_t; -#ifdef lint -#define NOLINE ((line_t)0) -#else -#define NOLINE ((line_t) 65535) -#endif - -#ifndef lint -#ifndef LEAKTEST -#ifndef safemalloc -Malloc_t safemalloc _((MEM_SIZE)); -Malloc_t saferealloc _((char *, MEM_SIZE)); -void safefree _((char *)); -#endif -#ifndef MSDOS -#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) -#else -#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) -#endif /* MSDOS */ -#define Safefree(d) safefree((char*)d) -#define NEWSV(x,len) newSV(len) -#else /* LEAKTEST */ -char *safexmalloc(); -char *safexrealloc(); -void safexfree(); -#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Safefree(d) safexfree((char*)d) -#define NEWSV(x,len) newSV(x,len) -#define MAXXCOUNT 1200 -long xcount[MAXXCOUNT]; -long lastxcount[MAXXCOUNT]; -#endif /* LEAKTEST */ -#define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) -#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) -#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) -#else /* lint */ -#define New(x,v,n,s) (v = Null(s *)) -#define Newc(x,v,n,s,c) (v = Null(s *)) -#define Newz(x,v,n,s) (v = Null(s *)) -#define Renew(v,n,s) (v = Null(s *)) -#define Move(s,d,n,t) -#define Copy(s,d,n,t) -#define Zero(d,n,t) -#define Safefree(d) d = d -#endif /* lint */ - -#ifdef USE_STRUCT_COPY -#define StructCopy(s,d,t) *((t*)(d)) = *((t*)(s)) -#else -#define StructCopy(s,d,t) Copy(s,d,1,t) -#endif diff --git a/x2p/proto.h b/x2p/proto.h new file mode 100644 index 0000000000..eb5fb15b37 --- /dev/null +++ b/x2p/proto.h @@ -0,0 +1,8 @@ +/* proto.h + * + * Copyright (c) 1991-1996, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ diff --git a/x2p/s2p.PL b/x2p/s2p.PL index 6664dcd616..7564d51d99 100644 --- a/x2p/s2p.PL +++ b/x2p/s2p.PL @@ -12,10 +12,8 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); open OUT,">$file" or die "Can't create $file: $!"; @@ -25,10 +23,11 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; \$startperl = "$Config{startperl}"; +\$perlpath = "$Config{perlpath}"; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -95,7 +94,7 @@ S2p uses no environment variables. =head1 AUTHOR -Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt> +Larry Wall E<lt>F<larry@wall.org>E<gt> =head1 FILES @@ -366,7 +365,7 @@ unless ($debug) { print &q(<<"EOT"); : $startperl -: eval 'exec perl -S \$0 \${1+"\$@"}' +: eval 'exec $perlpath -S \$0 \${1+"\$@"}' : if \$running_under_some_shell; : EOT @@ -297,6 +297,16 @@ register FILE *fp; int i; int bpx; +#if defined(VMS) + /* An ungetc()d char is handled separately from the regular + * buffer, so we getc() it back out and stuff it in the buffer. + */ + i = getc(fp); + if (i == EOF) return Nullch; + *(--((*fp)->_ptr)) = (unsigned char) i; + (*fp)->_cnt++; +#endif + cnt = FILE_cnt(fp); /* get count into register */ str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ @@ -317,7 +327,7 @@ register FILE *fp; FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */ FILE_ptr(fp) = ptr; - i = FILE_filbuf(fp); /* get more characters */ + i = getc(fp); /* get more characters */ cnt = FILE_cnt(fp); ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */ diff --git a/x2p/util.c b/x2p/util.c index 5c3554b7e3..519fae5a8a 100644 --- a/x2p/util.c +++ b/x2p/util.c @@ -13,6 +13,9 @@ #include "INTERN.h" #include "util.h" +#ifdef I_STDARG +# include <stdarg.h> +#endif #define FLUSH static char nomem[] = "Out of memory!\n"; @@ -24,10 +27,10 @@ Malloc_t safemalloc(size) MEM_SIZE size; { - char *ptr; - Malloc_t malloc(); + Malloc_t ptr; - ptr = (char *) malloc(size?size:1); /* malloc(0) is NASTY on our system */ + /* malloc(0) is NASTY on some systems */ + ptr = malloc(size ? size : 1); #ifdef DEBUGGING if (debug & 128) fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); @@ -45,14 +48,13 @@ MEM_SIZE size; Malloc_t saferealloc(where,size) -char *where; +Malloc_t where; MEM_SIZE size; { - char *ptr; - Malloc_t realloc(); + Malloc_t ptr; - ptr = (char *) - realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ + /* realloc(0) is NASTY on some systems */ + ptr = realloc(where, size ? size : 1); #ifdef DEBUGGING if (debug & 128) { fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); @@ -70,9 +72,9 @@ MEM_SIZE size; /* safe version of free */ -void +Free_t safefree(where) -char *where; +Malloc_t where; { #ifdef DEBUGGING if (debug & 128) @@ -189,32 +191,65 @@ int newlen; } } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +croak(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ croak(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif exit(1); } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +fatal(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ fatal(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif exit(1); } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +warn(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ warn(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif } diff --git a/x2p/util.h b/x2p/util.h index 35f796121c..bdd85c199d 100644 --- a/x2p/util.h +++ b/x2p/util.h @@ -24,10 +24,22 @@ int makedir(); char * cpy2 _(( char *to, char *from, int delim )); char * cpytill _(( char *to, char *from, int delim )); -void croak _(( char *pat, int a1, int a2, int a3, int a4 )); void growstr _(( char **strptr, int *curlen, int newlen )); char * instr _(( char *big, char *little )); -void Myfatal (); char * safecpy _(( char *to, char *from, int len )); char * savestr _(( char *str )); +#if defined(I_STDARG) && defined(HAS_VPRINTF) +void croak _(( char *pat, ... )); +void fatal _(( char *pat, ... )); +void warn _(( char *pat, ... )); +#else /* defined(I_STDARG) && defined(HAS_VPRINTF) */ +void croak _(( char *pat, int a1, int a2, int a3, int a4 )); +void Myfatal (); void warn (); +#endif /* defined(I_STDARG) && defined(HAS_VPRINTF) */ +int prewalk _(( int numit, int level, int node, int *numericptr )); + +Malloc_t safemalloc _((MEM_SIZE nbytes)); +Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes)); +Free_t safefree _((Malloc_t where)); |