diff options
136 files changed, 5313 insertions, 1628 deletions
diff --git a/Changes5.005 b/Changes5.005 index 1b6742d1c8..325ffeb6a5 100644 --- a/Changes5.005 +++ b/Changes5.005 @@ -73,6 +73,753 @@ indicator: !> merged changes (from elsewhere) +---------------- +Version 5.005_02 Second maintenance release of 5.005 +---------------- + +____________________________________________________________________________ +[ 1758] By: gsar on 1998/08/08 03:45:04 + Log: set patchlevel.h, other minor tweaks + Branch: maint-5.005/perl + ! Changes patchlevel.h pod/perlhist.pod pod/perlport.pod +____________________________________________________________________________ +[ 1757] By: gsar on 1998/08/08 03:33:33 + Log: prevent lexical leaks from Benchmark into target code (inspired by + an attempt by John Allen) + Branch: maint-5.005/perl + ! lib/Benchmark.pm +____________________________________________________________________________ +[ 1755] By: gsar on 1998/08/07 23:58:33 + Log: temporary opcode.pl workaround for ebcdic (suggested by + David J. Fiander <davidf@mks.com> and M.J.T. Guy) + Branch: maint-5.005/perl + ! opcode.pl +____________________________________________________________________________ +[ 1754] By: gsar on 1998/08/07 22:21:10 + Log: From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Date: Fri, 7 Aug 1998 09:56:01 +0100 (BST) + Message-Id: <9808070856.AA28065@claudius.bfsec.bt.co.uk> + Subject: [PATCH 5.005_50 & 5.005_02] Fix for command line use of source filters + Branch: maint-5.005/perl + ! perl.c +____________________________________________________________________________ +[ 1753] By: gsar on 1998/08/07 22:19:42 + Log: perlport.pod notes from Jarkko Hietaniemi; utime() note for Win32 + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 1752] By: gsar on 1998/08/07 22:08:29 + Log: perlport.pod v1.33 from Chris Nandor <pudge@pobox.com> + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 1751] By: gsar on 1998/08/07 22:01:04 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 6 Aug 1998 19:44:16 -0400 (EDT) + Message-Id: <199808062344.TAA09505@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Minor cleanup of RE tests and docs + Branch: maint-5.005/perl + ! pod/perlre.pod t/op/regexp.t +____________________________________________________________________________ +[ 1750] By: gsar on 1998/08/07 21:51:52 + Log: allow more compatible interpretation of spaces File::DosGlob::glob() + patterns + Branch: maint-5.005/perl + ! lib/File/DosGlob.pm +____________________________________________________________________________ +[ 1749] By: gsar on 1998/08/07 21:36:04 + Log: don't use © in Test.pm (suggested by M.J.T. Guy) + Branch: maint-5.005/perl + ! lib/Test.pm +____________________________________________________________________________ +[ 1748] By: gsar on 1998/08/07 21:31:46 + Log: From: Dominic Dunlop <domo@computer.org> + Date: Thu, 6 Aug 1998 12:38:07 +0000 + Message-Id: <v03110702b1ef5274635a@[195.95.102.104]> + Subject: [Patch perl5.005_02-TRIAL2] Update hints, Configure for MachTen 4.1.1 + Branch: maint-5.005/perl + ! Configure hints/machten.sh +____________________________________________________________________________ +[ 1746] By: gsar on 1998/08/05 22:55:59 + Log: MM_Win32.pm and Liblist.pm tweaks + Branch: maint-5.005/perl + ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm +____________________________________________________________________________ +[ 1745] By: gsar on 1998/08/05 21:57:00 + Log: pod/perlfaq* update from Tom Christiansen <tchrist@perl.com> + Branch: maint-5.005/perl + ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod + ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq8.pod +____________________________________________________________________________ +[ 1744] By: gsar on 1998/08/05 21:53:30 + Log: From: Chris Nandor <pudge@pobox.com> + Date: Wed, 5 Aug 1998 15:38:48 -0400 + Message-Id: <v04011701b1ee58b86c63@[192.168.0.3]> + Subject: [PATCH] perlport 1.32 + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 1743] By: gsar on 1998/08/05 21:52:05 + Log: README.os2 update + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 5 Aug 1998 05:44:46 -0400 (EDT) + Message-Id: <199808050944.FAA09053@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Additional OS/2 tweaks: docs, tests + Branch: maint-5.005/perl + ! README.os2 t/lib/posix.t t/op/exec.t +____________________________________________________________________________ +[ 1742] By: gsar on 1998/08/05 21:50:07 + Log: additional INSTALL notes from Jarkko Hietaniemi <jhi@cc.hut.fi> + on semget failure in t/lib/ipc_sysv.t + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 1741] By: gsar on 1998/08/05 21:46:13 + Log: correct URL for perlcrt.dll + Branch: maint-5.005/perl + ! Changes win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 1740] By: gsar on 1998/08/05 10:05:46 + Log: update Changes, patchlevel, tweak Liblist.pm + Branch: maint-5.005/perl + ! Changes lib/ExtUtils/Liblist.pm patchlevel.h +____________________________________________________________________________ +[ 1739] By: gsar on 1998/08/05 09:10:45 + Log: newer cperl-mode.el + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 5 Aug 1998 03:50:16 -0400 (EDT) + Message-Id: <199808050750.DAA07240@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] CPerl update + Branch: maint-5.005/perl + ! emacs/cperl-mode.el +____________________________________________________________________________ +[ 1738] By: gsar on 1998/08/05 09:08:33 + Log: support :nosearch in ExtUtils::Liblist for win32, and make -lfoo + processing (somewhat) compiler-specific + Branch: maint-5.005/perl + ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm +____________________________________________________________________________ +[ 1737] By: gsar on 1998/08/05 03:20:03 + Log: add index entries for -X + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 02 Aug 1998 16:33:18 EDT + Message-Id: <199808022033.QAA18778@monk.mps.ohio-state.edu> + Subject: [PATCH] A missing docu patch + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 1736] By: gsar on 1998/08/05 03:09:58 + Log: make Test::Harness optionally check for stray files when running tests + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 2 Aug 1998 18:12:48 -0400 (EDT) + Message-Id: <199808022212.SAA20126@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] File leaked from test suite + Branch: maint-5.005/perl + ! lib/Test/Harness.pm +____________________________________________________________________________ +[ 1735] By: gsar on 1998/08/05 02:29:46 + Log: back out change#1703 that break bincompat with PERL_OBJECT and + MULTIPLICITY + Branch: maint-5.005/perl + ! ext/re/re.pm regcomp.c regexec.c thrdvar.h +____________________________________________________________________________ +[ 1734] By: gsar on 1998/08/05 02:23:47 + Log: fixes to enable ISC to build IPC/SysV + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Date: 05 Aug 1998 00:59:13 +0300 + Message-ID: <oee3ebce7da.fsf@alpha.hut.fi> + Subject: [PATCH] 5.005_02-TRIAL1: (Re: Bug in pp_rename and ISC hint) + Branch: maint-5.005/perl + ! ext/IPC/SysV/SysV.xs hints/isc.sh hints/isc_2.sh +____________________________________________________________________________ +[ 1733] By: gsar on 1998/08/05 01:20:29 + Log: let some 'tr' be '$tr' for occult reasons + From: Jeff Okamoto <okamoto@xfiles.intercon.hp.com> + Date: Mon, 3 Aug 1998 11:04:30 -0700 (PDT) + Message-Id: <199808031804.LAA25595@xfiles.intercon.hp.com> + Subject: PATCH: Configure uses tr, not $tr + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 1732] By: gsar on 1998/08/05 01:16:40 + Log: perlre.pod tweak suggested by Mike Wescott <mike.wescott@columbiasc.ncr.com> + Branch: maint-5.005/perl + ! pod/perlre.pod +____________________________________________________________________________ +[ 1731] By: gsar on 1998/08/05 01:10:41 + Log: explain caveat about use of numeric constants in podoc for sysopen() + From: "David J. Fiander" <davidf@mks.com> + Date: Tue, 4 Aug 1998 13:09:58 -0400 + Message-Id: <199808041709.NAA01750@mks.com> + Subject: Re: [PATCH] 5.005_01: OE MVS + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 1730] By: gsar on 1998/08/05 00:46:53 + Log: end pod processing when source file is closed (prevents it carrying + over into require()d files) + Branch: maint-5.005/perl + ! t/comp/require.t toke.c +____________________________________________________________________________ +[ 1729] By: gsar on 1998/08/04 23:03:23 + Log: correct prototype for des_fcrypt(), explain how to add it in more + detail, and supply a patch for libdes-3.06 + Branch: maint-5.005/perl + + win32/des_fcrypt.patch + ! MANIFEST README.win32 win32/Makefile win32/makefile.mk + ! win32/win32.c +____________________________________________________________________________ +[ 1728] By: gsar on 1998/08/04 21:50:40 + Log: tweak to avoid ambiguity warnings + Branch: maint-5.005/perl + ! pp.c +____________________________________________________________________________ +[ 1727] By: gsar on 1998/08/04 20:31:04 + Log: remove useless 'rcsid' (extension of a suggestion by + Stephen McCamant) + Branch: maint-5.005/perl + ! embed.h ext/SDBM_File/sdbm/pair.c ext/SDBM_File/sdbm/sdbm.c + ! global.sym gv.c perl.c vms/gen_shrfls.pl +____________________________________________________________________________ +[ 1726] By: gsar on 1998/08/04 19:52:43 + Log: correct Pod::Html's notion of email addresses + From: abigail@fnx.com + Date: Mon, 3 Aug 1998 20:22:49 -0400 (EDT) + Message-ID: <19980804002249.2011.qmail@betelgeuse.wayne.fnx.com> + Subject: [PATCH 5.005_01] lib/Pod/Html.pm + Branch: maint-5.005/perl + ! lib/Pod/Html.pm +____________________________________________________________________________ +[ 1725] By: gsar on 1998/08/04 19:50:06 + Log: perlport.pod additions from Peter Prymmer <pvhp@forte.com> + Date: Mon, 3 Aug 98 15:31:35 PDT + Message-Id: <9808032231.AA22324@forte.com> + -- + Date: Tue, 4 Aug 98 12:44:20 PDT + Message-Id: <9808041944.AA04815@forte.com> + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 1724] By: gsar on 1998/08/04 18:08:07 + Log: From: Chris Nandor <pudge@pobox.com> + Date: Mon, 3 Aug 1998 13:35:25 -0400 + Message-Id: <v04011711b1eba46d0827@[192.168.0.3]> + Subject: [PATCH] perlport 1.30 + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 1723] By: gsar on 1998/08/04 18:06:13 + Log: update postscript generator + From: Tom Christiansen <tchrist@chthon.perl.com> + Date: Mon, 3 Aug 1998 05:29:25 -0600 + Message-Id: <199808031129.FAA24985@chthon.perl.com> + Subject: PATCH: pod/roffitall (5.005_02) + Branch: maint-5.005/perl + ! pod/roffitall +____________________________________________________________________________ +[ 1722] By: gsar on 1998/08/03 17:01:12 + Log: applied suggested patch, slightly tweaked + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Date: Mon, 3 Aug 1998 11:52:30 +0300 (EET DST) + Message-Id: <199808030852.LAA14153@alpha.hut.fi> + Subject: [PATCH] perl5.005_02-TRIAL1: pod/perlhist.pod + Branch: maint-5.005/perl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 1721] By: gsar on 1998/08/03 16:30:20 + Log: fix segfault when threadsv is used as foreach itervar + From: Stephen McCamant <alias@mcs.com> + Date: Sun, 02 Aug 1998 21:44:34 CDT + Message-Id: <13765.8641.997452.14516@alias-2.pr.mcs.net> + Subject: [PATCH] threadsv index in enteriter targ in op_free() + Branch: maint-5.005/perl + ! op.c +____________________________________________________________________________ +[ 1720] By: gsar on 1998/08/02 23:33:42 + Log: close() open files before unlink() + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 2 Aug 1998 18:14:22 -0400 (EDT) + Message-Id: <199808022214.SAA20135@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] File leaked from test suite - tests + Branch: maint-5.005/perl + ! t/base/rs.t t/op/defins.t +____________________________________________________________________________ +[ 1719] By: gsar on 1998/08/02 23:31:51 + Log: more pack() tests + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Mon, 3 Aug 1998 00:59:41 +0300 (EET DST) + Message-Id: <199808022159.AAA17160@alpha.hut.fi> + Subject: Re: uudecode 'u' problem + Branch: maint-5.005/perl + ! t/op/pack.t +____________________________________________________________________________ +[ 1718] By: gsar on 1998/08/02 23:26:51 + Log: t/TEST aesthetic tweak suggested by Jarkko + Branch: maint-5.005/perl + ! t/TEST +____________________________________________________________________________ +[ 1717] By: gsar on 1998/08/02 23:23:43 + Log: add Digital Unix 3.x notes to README.threads (as suggested by + Phoenix <awrobel@jedi.cis.temple.edu>) + Branch: maint-5.005/perl + ! README.threads +____________________________________________________________________________ +[ 1716] By: gsar on 1998/08/02 23:15:00 + Log: allow *FOO{BAR}[0] etc. (without intervening arrow) + From: Stephen McCamant <alias@mcs.com> + Date: Sun, 2 Aug 1998 16:16:50 -0500 (CDT) + Message-ID: <13764.54929.60137.104838@alias-2.pr.mcs.net> + Subject: [PATCH] Re: Minor nit in glob notation + Branch: maint-5.005/perl + ! Changes op.c +____________________________________________________________________________ +[ 1715] By: gsar on 1998/08/02 22:49:53 + Log: fix unpack('u',...) problem with spaces in input + Branch: maint-5.005/perl + ! pp.c t/op/pack.t +____________________________________________________________________________ +[ 1714] By: gsar on 1998/08/02 21:27:19 + Log: update location of perlcrt.dll for win32 builds + Branch: maint-5.005/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 1713] By: gsar on 1998/08/02 09:28:32 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 2 Aug 1998 04:35:11 -0400 (EDT) + Message-Id: <199808020835.EAA09367@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Better debugging output from malloc.c + Branch: maint-5.005/perl + ! malloc.c +____________________________________________________________________________ +[ 1712] By: gsar on 1998/08/02 09:16:55 + Log: fix longstanding bug in pack('u',...) (reads garbage beyond the end + of the input string) + Branch: maint-5.005/perl + ! pp.c +____________________________________________________________________________ +[ 1711] By: gsar on 1998/08/02 08:14:25 + Log: update Changes, tweak Porting/makerel + Branch: maint-5.005/perl + ! Changes Porting/makerel +____________________________________________________________________________ +[ 1710] By: gsar on 1998/08/02 07:31:37 + Log: remove CRs from djgpp/configure.bat (Porting/makerel adds them) + Branch: maint-5.005/perl + ! djgpp/configure.bat +____________________________________________________________________________ +[ 1709] By: gsar on 1998/08/02 07:27:34 + Log: Porting/makerel tweaks + Branch: maint-5.005/perl + ! Porting/makerel +____________________________________________________________________________ +[ 1708] By: gsar on 1998/08/02 07:09:35 + Log: fixes for pod noises + Branch: maint-5.005/perl + ! ext/B/B/Bytecode.pm ext/Thread/Thread/Specific.pm + ! pod/perlembed.pod pod/perlfaq.pod +____________________________________________________________________________ +[ 1707] By: gsar on 1998/08/02 06:59:47 + Log: malloc.c tweaks + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 01 Aug 1998 18:46:32 EDT + Message-Id: <199808012246.SAA00699@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Better malloc.c + Branch: maint-5.005/perl + ! malloc.c +____________________________________________________________________________ +[ 1706] By: gsar on 1998/08/02 06:56:37 + Log: fix quoting of keys with embedded nulls + From: Slaven Rezic <eserte@cs.tu-berlin.de> + Date: Sat, 01 Aug 1998 13:38:03 +0200 + Message-Id: <199808011138.NAA05189@mail.cs.tu-berlin.de> + Subject: Data::Dumper 2.09, patch + Branch: maint-5.005/perl + ! ext/Data/Dumper/Dumper.xs +____________________________________________________________________________ +[ 1705] By: gsar on 1998/08/02 06:50:07 + Log: From: pvhp@forte.com (Peter Prymmer) + Date: Fri, 31 Jul 1998 14:50:41 PDT + Message-Id: <9807312150.AA08867@forte.com> + Subject: Re: \Q doesn't work in interpolated regular expressions + Branch: maint-5.005/perl + ! pod/perlre.pod +____________________________________________________________________________ +[ 1704] By: gsar on 1998/08/02 06:37:06 + Log: add test for magic autovivification + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Thu, 30 Jul 1998 12:18:15 +0100 + Message-Id: <E0z1qit-0003O5-00@taurus.cus.cam.ac.uk> + Subject: Re: Perl5.005_01 failing to autovivify subroutine args + Branch: maint-5.005/perl + ! pod/perldiag.pod t/cmd/subval.t +____________________________________________________________________________ +[ 1703] By: gsar on 1998/08/02 06:26:57 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 21 Jul 1998 23:58:53 -0400 (EDT) + Message-Id: <199807220358.XAA19811@monk.mps.ohio-state.edu> + Subject: [PATCH 5.004_76] better RE colors + Branch: maint-5.005/perl + ! ext/re/re.pm regcomp.c regexec.c thrdvar.h +____________________________________________________________________________ +[ 1702] By: gsar on 1998/08/02 06:22:15 + Log: mark link type of exported functions for OS/2 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 26 Jul 1998 21:03:03 -0400 (EDT) + Message-Id: <199807270103.VAA04977@monk.mps.ohio-state.edu> + Subject: Re: Compiler linkage's types [PATCH 5.005] + Branch: maint-5.005/perl + ! os2/os2ish.h proto.h +____________________________________________________________________________ +[ 1701] By: gsar on 1998/08/02 06:16:03 + Log: tweaked version of suggested patch + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 20 Jul 1998 21:40:00 -0400 (EDT) + Message-Id: <199807210140.VAA17186@monk.mps.ohio-state.edu> + Subject: [PATCH 5.004_75] Enable -DS + Branch: maint-5.005/perl + ! README.threads ext/Thread/Thread.xs ext/Thread/typemap mg.c + ! op.c perl.c perl.h pod/perlrun.pod pp.c pp_hot.c scope.c + ! thread.h util.c win32/win32thread.c +____________________________________________________________________________ +[ 1700] By: gsar on 1998/08/02 05:54:00 + Log: up patchlevel to 5.005_02 + Branch: maint-5.005/perl + ! Changes patchlevel.h win32/Makefile win32/config_H.bc + ! win32/config_H.gc win32/config_H.vc win32/makefile.mk +____________________________________________________________________________ +[ 1699] By: gsar on 1998/08/02 05:50:01 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Message-Id: <199807180809.EAA09379@monk.mps.ohio-state.edu> + Date: Sat, 18 Jul 1998 04:09:26 -0400 (EDT) + Subject: [PATCH 5.004_72] Make tests succeed on OS/2 + Branch: maint-5.005/perl + ! t/io/fs.t t/lib/io_pipe.t t/lib/io_sock.t t/op/stat.t +____________________________________________________________________________ +[ 1698] By: gsar on 1998/08/02 05:41:41 + Log: use I32_MAX as the limit when U16_MAX > I32_MAX (for CRAY) + Branch: maint-5.005/perl + ! regcomp.c +____________________________________________________________________________ +[ 1697] By: gsar on 1998/08/02 05:20:12 + Log: support OE/MVS + From: Jarkko Hietaniemi <jhi@iki.fi> + Message-Id: <199808010903.MAA09371@alpha.hut.fi> + Date: Sat, 1 Aug 1998 12:03:02 +0300 (EET DST) + Subject: [PATCH] 5.005_01: OE MVS + Branch: maint-5.005/perl + + README.os390 ebcdic.c + ! Configure MANIFEST doio.c ext/Errno/Errno_pm.PL gv.c handy.h + ! hints/os390.sh lib/bigint.pl mg.c patchlevel.h perl.c perl.h + ! perly.c perly.h perly.y perly_c.diff pod/perldelta.pod + ! pod/perlport.pod pp.c pp_ctl.c pp_hot.c pp_sys.c sv.c + ! t/base/term.t t/comp/package.t t/comp/require.t + ! t/lib/bigintpm.t t/lib/cgi-html.t t/lib/filehand.t t/lib/ph.t + ! t/op/auto.t t/op/bop.t t/op/each.t t/op/magic.t t/op/misc.t + ! t/op/ord.t t/op/pack.t t/op/quotemeta.t t/op/re_tests + ! t/op/regexp.t t/op/sort.t t/op/sprintf.t t/op/subst.t + ! t/op/taint.t t/op/universal.t t/pragma/constant.t + ! t/pragma/overload.t t/pragma/subs.t toke.c x2p/a2p.h + ! x2p/a2py.c +____________________________________________________________________________ +[ 1696] By: gsar on 1998/08/02 05:03:09 + Log: VMS patches + From: pvhp@forte.com (Peter Prymmer) + Message-Id: <9807290017.AA01833@forte.com> + Date: Tue, 28 Jul 98 17:17:33 PDT + Subject: Re: Not OK: perl 5.00501 on VMS_AXP-thread I7.2 + -- + From: Dan Sugalski <sugalskd@osshe.edu> + Message-Id: <3.0.5.32.19980729125623.00b562b0@ous.edu> + Date: Wed, 29 Jul 1998 12:56:23 -0700 + Subject: [PATCH 5.005_01]Typo in CONFIGURE.COM (vms) + -- + From: Dan Sugalski <sugalskd@osshe.edu> + Date: Thu, 30 Jul 1998 09:02:24 -0700 + Message-Id: <3.0.5.32.19980730090224.00b70eb0@ous.edu> + Subject: [PATCH 5.005_01]VMS config SOCKETSHR typo patch and fcntl check + Branch: maint-5.005/perl + ! configure.com vms/subconfigure.com +____________________________________________________________________________ +[ 1695] By: gsar on 1998/08/02 04:49:32 + Log: rename duplicate warning in regexec.c + Branch: maint-5.005/perl + ! regexec.c +____________________________________________________________________________ +[ 1694] By: gsar on 1998/08/02 04:44:20 + Log: beware egcs' ld on Solaris + From: Tom Spindler <dogcow@home.merit.edu> + Message-ID: <19980801212158.A2934@home.merit.edu> + Date: Sat, 1 Aug 1998 21:21:58 -0400 + Subject: Re: [PATCH perl5.005_01] hints/solaris_2.sh, egcs, and ld + Branch: maint-5.005/perl + ! hints/solaris_2.sh +____________________________________________________________________________ +[ 1693] By: gsar on 1998/08/02 04:41:43 + Log: de-utf-ized variation of Ilya's patch + From: Jan-Pieter Cornet <johnpc@xs4all.net> + Date: 31 Jul 1998 12:44:57 +0200 + Message-ID: <6ps779$hmj$1@xs1.xs4all.nl> + Subject: Re: s/\s*$//g in majordomo causes segfault under 5.005_01 + Branch: maint-5.005/perl + ! regexec.c +____________________________________________________________________________ +[ 1692] By: gsar on 1998/08/02 04:39:14 + Log: better validation of SysV IPC availability + From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com> + Date: Fri, 31 Jul 1998 13:13:57 +0300 (EEST) + Message-Id: <199807311013.NAA28887@koah.research.nokia.com> + Subject: Re: lib/ipc_sysv.t fails under FreeBSD 2.2.1 + Branch: maint-5.005/perl + ! Configure INSTALL ext/IPC/SysV/SysV.xs pod/perldiag.pod + ! t/lib/ipc_sysv.t +____________________________________________________________________________ +[ 1691] By: gsar on 1998/08/02 04:32:30 + Log: fix bug in display of watched expressions + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 30 Jul 1998 20:02:04 -0400 (EDT) + Message-Id: <199807310002.UAA21681@monk.mps.ohio-state.edu> + Subject: Re: Bug? in perl5db.pl [PATCH] + Branch: maint-5.005/perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 1690] By: gsar on 1998/08/02 04:29:08 + Log: applied all but one hunk + From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl> + Date: Thu, 30 Jul 1998 17:19:42 -0400 + Message-Id: <199807302119.RAA06852@sleipnir.valparaiso.cl> + Subject: Some typos in perldelta.pod + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 1689] By: gsar on 1998/08/02 04:27:02 + Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Date: Thu, 30 Jul 1998 10:22:36 -0400 (EDT) + Message-Id: <Pine.SUN.3.96.980730101627.17514B-100000@newton.phys> + Subject: [PATCH 5.005_05] Remove redundant dTHR + Branch: maint-5.005/perl + ! mg.c sv.c +____________________________________________________________________________ +[ 1688] By: gsar on 1998/08/02 04:25:49 + Log: From: Tom Hughes <thh@cyberscience.com> + Date: 30 Jul 1998 09:47:31 +0100 + Message-ID: <yek1zr3vi70.fsf@elva.cyberscience.com> + Subject: Class::Struct has an incomplete tied array package + Branch: maint-5.005/perl + ! lib/Class/Struct.pm +____________________________________________________________________________ +[ 1687] By: gsar on 1998/08/02 04:21:48 + Log: ensure implicit close on local(*FH) doesn't affect $! and thence $? + Branch: maint-5.005/perl + ! sv.c t/op/die_exit.t +____________________________________________________________________________ +[ 1686] By: gsar on 1998/08/02 03:57:28 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Thu, 30 Jul 1998 00:39:30 +0300 (EET DST) + Message-Id: <199807292139.AAA01795@alpha.hut.fi> + Subject: Re: [PATCH] 5.004_05-MAINT_TRIAL_5: three locale fixes + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.xs pod/perllocale.pod +____________________________________________________________________________ +[ 1685] By: gsar on 1998/08/02 03:54:15 + Log: PERL_OBJECT bincompat fixes from Douglas Lankshear <dougl@ActiveState.com> + Date: Wed, 29 Jul 1998 10:45:31 -0700 + Message-ID: <000101bdbb18$ae767550$a32fa8c0@tau.Active> + Subject: [PATCH 5.005_01] Fixes binary compatibility for PERL_OBJECT + -- + Date: Sat, 1 Aug 1998 09:33:19 -0700 + Message-ID: <000701bdbd6a$17ada180$a32fa8c0@tau.Active> + Subject: [PATCH 5.005_01] + Branch: maint-5.005/perl + ! perl.h proto.h +____________________________________________________________________________ +[ 1684] By: gsar on 1998/08/02 03:49:33 + Log: hand-apply whitespace-mutiliated patch + From: Nicholas Clark <nick@flirble.org> + Date: Tue, 28 Jul 1998 16:40:42 +0100 (BST) + Message-Id: <199807281540.QAA04640@flirble.org> + Subject: [PATCH] POSIX::ELOOP + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 1683] By: gsar on 1998/08/02 03:45:26 + Log: document return values of do() better + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Tue, 28 Jul 1998 12:44:36 +0100 + Message-Id: <E0z18BI-0003cH-00@taurus.cus.cam.ac.uk> + Subject: [PATCH] Re: Obscurity of lexicals with do "" + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 1682] By: gsar on 1998/08/02 03:42:26 + Log: avoid reusing foreach itervar if magic got tacked onto it + From: Stephen McCamant <alias@mcs.com> + Date: Tue, 28 Jul 1998 22:18:25 -0500 (CDT) + Message-ID: <13758.36756.215424.719750@alias-2.pr.mcs.net> + Subject: [PATCH] Re: pos() resetting changed with 5.005? + Branch: maint-5.005/perl + ! pp_hot.c +____________________________________________________________________________ +[ 1681] By: gsar on 1998/08/02 03:39:27 + Log: From: Nick Ing-Simmons <nik@tiuk.ti.com> + Date: Wed, 29 Jul 1998 13:28:14 +0100 + Message-Id: <199807291228.NAA20055@tiuk.ti.com> + Subject: [Patch] Math::Complex - Ambiguous call resolved as CORE::foo() + Branch: maint-5.005/perl + + Porting/fixCORE + ! MANIFEST lib/Math/Complex.pm +____________________________________________________________________________ +[ 1680] By: gsar on 1998/08/02 03:33:07 + Log: From: h.sanden@elsevier.nl (Hugo van der Sanden) + Date: Mon, 27 Jul 1998 13:34:45 +0200 + Message-Id: <199807271134.NAA24475@dorlas.elsevier.nl> + Subject: perlcall.pod + Branch: maint-5.005/perl + ! pod/perlcall.pod +____________________________________________________________________________ +[ 1679] By: gsar on 1998/08/02 03:29:41 + Log: MM_Win32::maybe_command() case-insesitivity tweak + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Win32.pm +____________________________________________________________________________ +[ 1678] By: gsar on 1998/08/02 03:24:29 + Log: fix MM_Win32::maybe_command() + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Win32.pm +____________________________________________________________________________ +[ 1677] By: gsar on 1998/08/01 19:52:19 + Log: fixes for overloading bugs and docs, tweaked some + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 25 Jul 1998 21:28:16 -0400 (EDT) + Message-Id: <199807260128.VAA10543@monk.mps.ohio-state.edu> + Subject: [PATCH 5.004_76] better overloading + Branch: maint-5.005/perl + ! Changes gv.c lib/dumpvar.pl lib/overload.pm lib/perl5db.pl + ! t/pragma/overload.t +____________________________________________________________________________ +[ 1676] By: gsar on 1998/08/01 19:37:13 + Log: stray s/foo/PL_foo/ + From: win@in.rhein-main.de (Winfried Koenig) + Date: Mon, 27 Jul 98 21:13 MET + Message-Id: <m0z0teW-00019aC@incom.rhein-main.de> + Subject: Bug in pp_rename and ISC hint + Branch: maint-5.005/perl + ! pp_sys.c +____________________________________________________________________________ +[ 1675] By: gsar on 1998/08/01 19:22:13 + Log: newer Porting/patchls from maint-5.004 + Branch: maint-5.005/perl + ! Porting/patchls +____________________________________________________________________________ +[ 1674] By: gsar on 1998/08/01 17:50:44 + Log: fix buggy detection of failed glob() + Branch: maint-5.005/perl + ! pp_hot.c +____________________________________________________________________________ +[ 1673] By: gsar on 1998/07/29 18:14:32 + Log: fix typo in change#1489 that prevented magic-autovivification + Branch: maint-5.005/perl + ! mg.c + +---------------- +Version 5.005_01 First maintenance release of 5.005 +---------------- + +____________________________________________________________________________ +[ 1669] By: gsar on 1998/07/26 23:19:02 + Log: update Changes; add sv_*_mg() entries in win32/GenCAPI.pl + Branch: maint-5.005/perl + ! Changes proto.h win32/GenCAPI.pl +____________________________________________________________________________ +[ 1668] By: gsar on 1998/07/26 21:12:11 + Log: s/TMP_CRLF_PATCH/PERL_STRICT_CR/ with sense reversed, so they + can disable it from config.sh if they want; up patchlevel to 5_01; + little tweaks to pods + Branch: maint-5.005/perl + ! README.win32 patchlevel.h pod/perldelta.pod toke.c + ! win32/Makefile win32/config_H.bc win32/config_H.gc + ! win32/config_H.vc win32/makefile.mk win32/win32.c +____________________________________________________________________________ +[ 1662] By: gsar on 1998/07/26 05:01:52 + Log: add missing sv_*_mg() prototypes in proto.h, update perlhist.pod + Branch: maint-5.005/perl + ! pod/perlhist.pod proto.h +____________________________________________________________________________ +[ 1658] By: gsar on 1998/07/26 02:23:46 + Log: VMS patches from Dan Sugalski <sugalskd@osshe.edu> + Date: Fri, 24 Jul 1998 11:38:25 -0700 + Message-Id: <3.0.5.32.19980724113825.00a067b0@ous.edu> + Subject: [PATCH 5.005] version number problem with VMS (Corrected) + -- + Date: Fri, 24 Jul 1998 12:30:36 -0700 + Message-Id: <3.0.5.32.19980724123036.009f0390@ous.edu> + Subject: [PATCH 5.005]Tweaks to README.vms + -- + Date: Sat, 25 Jul 1998 17:56:55 -0700 (PDT) + Message-ID: <Pine.GSO.3.96.980725175626.15740D-100000@netserve.ous.edu> + Subject: [PATCH 5.005] Final build cleanup patch + Branch: maint-5.005/perl + ! README.vms vms/descrip_mms.template vms/subconfigure.com +____________________________________________________________________________ +[ 1657] By: gsar on 1998/07/26 02:19:50 + Log: another platform where pp_sselect() needs a whole fd_set buffer + From: Lupe Christoph <lupe@alanya.m.isar.de> + Date: Sat, 25 Jul 1998 19:49:33 +0200 (MET DST) + Message-Id: <199807251749.TAA22347@alanya.m.isar.de> + Subject: Patch for Not OK: perl 5.005 on i86pc-solaris-thread 2.6 + Branch: maint-5.005/perl + ! pp_sys.c +____________________________________________________________________________ +[ 1656] By: gsar on 1998/07/26 02:12:46 + Log: fix problem building modules on dos-djgpp + From: Laszlo Molnar <molnarl@cdata.tvnet.hu> + Date: Sat, 25 Jul 1998 00:53:39 +0200 + Message-ID: <19980725005339.C222@cdata.tvnet.hu> + Subject: [PATCH 5.005] dos-djgpp and modules problem + Branch: maint-5.005/perl + ! djgpp/fixpmain +____________________________________________________________________________ +[ 1655] By: gsar on 1998/07/26 02:11:09 + Log: From: Tom Spindler <dogcow@home.merit.edu> + Date: Wed, 22 Jul 1998 16:11:07 -0400 + Message-ID: <19980722161107.A16813@home.merit.edu> + Subject: [PATCH 5.005] BeOS tweak + Branch: maint-5.005/perl + ! hints/beos.sh +____________________________________________________________________________ +[ 1654] By: gsar on 1998/07/26 02:09:29 + Log: various pod tweaks + Branch: maint-5.005/perl + ! Changes pod/perldelta.pod pod/perlmodinstall.pod + ! pod/perltoc.pod +____________________________________________________________________________ +[ 1653] By: gsar on 1998/07/26 02:05:46 + Log: fix emacs/ptags for PL_* changes + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 24 Jul 1998 03:12:35 -0400 (EDT) + Message-Id: <199807240712.DAA04204@monk.mps.ohio-state.edu> + Subject: [PATCH 5.004_76] Yet better ptags + Branch: maint-5.005/perl + ! emacs/ptags +____________________________________________________________________________ +[ 1652] By: gsar on 1998/07/26 02:03:01 + Log: fix behavior of <=> on bigints + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Message-Id: <E0yzlfF-0004kz-00@taurus.cus.cam.ac.uk> + Date: Fri, 24 Jul 1998 18:29:53 +0100 + Subject: [PATCH] Re: Math::BigInt <=> op is not correct. + Branch: maint-5.005/perl + ! lib/Math/BigInt.pm t/lib/bigintpm.t +____________________________________________________________________________ +[ 1649] By: gsar on 1998/07/24 03:56:56 + Log: create maint-5.005 branch + Branch: maint-5.005/perl + +> (branch 1079 files) +____________________________________________________________________________ +[ 1648] By: gsar on 1998/07/24 03:36:35 + Log: un-checked-in 5.005 Changes (this is 5.005 *exactly*) + Branch: perl + ! Changes + ------------- Version 5.005 Production release ------------- @@ -1823,14 +1823,14 @@ ABYZ) *) # There is a discontinuity in EBCDIC between 'I' and 'J' # (0xc9 and 0xd1), therefore that is a nice testing point. if test "X$up" = X -o "X$low" = X; then - case "`echo IJ | tr '[I-J]' '[i-j]' 2>/dev/null`" in + case "`echo IJ | $tr '[I-J]' '[i-j]' 2>/dev/null`" in ij) up='[A-Z]' low='[a-z]' ;; esac fi if test "X$up" = X -o "X$low" = X; then - case "`echo IJ | tr I-J i-j 2>/dev/null`" in + case "`echo IJ | $tr I-J i-j 2>/dev/null`" in ij) up='A-Z' low='a-z' ;; @@ -1858,7 +1858,7 @@ ABYZ) esac fi esac -case "`echo IJ | tr \"$up\" \"$low\" 2>/dev/null`" in +case "`echo IJ | $tr \"$up\" \"$low\" 2>/dev/null`" in ij) echo "Using $up and $low to convert case." >&4 ;; @@ -1887,7 +1887,7 @@ myuname=`( ($uname -a) 2>/dev/null || hostname) 2>&1` # tr '[A-Z]' '[a-z]' would not work in EBCDIC # because the A-Z/a-z are not consecutive. myuname=`echo $myuname | $sed -e 's/^[^=]*=//' -e 's/\///g' | \ - ./tr '[A-Z]' '[a-z]' | tr $trnl ' '` + ./tr '[A-Z]' '[a-z]' | $tr $trnl ' '` newmyuname="$myuname" dflt=n case "$knowitall" in @@ -1956,7 +1956,7 @@ EOM $test -d /usr/apollo/bin && osname=apollo $test -f /etc/saf/_sactab && osname=svr4 $test -d /usr/include/minix && osname=minix - if $test -d /MachTen; then + if $test -d /MachTen -o -d /MachTen_Folder; then osname=machten if $test -x /sbin/version; then osvers=`/sbin/version | $awk '{print $2}' | @@ -7631,6 +7631,25 @@ echo " " case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in *"$undef"*) h_msg=false;; esac +case "$osname" in +freebsd) + case "`ipcs 2>&1`" in + "SVID messages"*"not configured"*) + echo "But your FreeBSD kernel does not have the msg*(2) configured." >&4 + h_msg=false + val="$undef" + set msgctl d_msgctl + eval $setvar + set msgget d_msgget + eval $setvar + set msgsnd d_msgsnd + eval $setvar + set msgrcv d_msgrcv + eval $setvar + ;; + esac + ;; +esac : we could also check for sys/ipc.h ... if $h_msg && $test `./findhdr sys/msg.h`; then echo "You have the full msg*(2) library." >&4 @@ -8113,6 +8132,23 @@ echo " " case "$d_semctl$d_semget$d_semop" in *"$undef"*) h_sem=false;; esac +case "$osname" in +freebsd) + case "`ipcs 2>&1`" in + "SVID messages"*"not configured"*) + echo "But your FreeBSD kernel does not have the sem*(2) configured." >&4 + h_sem=false + val="$undef" + set semctl d_semctl + eval $setvar + set semget d_semget + eval $setvar + set semop d_semop + eval $setvar + ;; + esac + ;; +esac : we could also check for sys/ipc.h ... if $h_sem && $test `./findhdr sys/sem.h`; then echo "You have the full sem*(2) library." >&4 @@ -8459,6 +8495,25 @@ echo " " case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in *"$undef"*) h_shm=false;; esac +case "$osname" in +freebsd) + case "`ipcs 2>&1`" in + "SVID shared memory"*"not configured"*) + echo "But your FreeBSD kernel does not have the shm*(2) configured." >&4 + h_shm=false + val="$undef" + set shmctl d_shmctl + evat $setvar + set shmget d_shmget + evat $setvar + set shmat d_shmat + evat $setvar + set shmdt d_shmdt + evat $setvar + ;; + esac + ;; +esac : we could also check for sys/ipc.h ... if $h_shm && $test `./findhdr sys/shm.h`; then echo "You have the full shm*(2) library." >&4 @@ -11971,7 +12026,7 @@ esac case "$ebcdic" in $define) xxx='' - echo "This is an EBCDIC system, checking if any parser files may need regenerating." >&4 + echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4 rm -f y.tab.c y.tab.h yacc -d perly.y >/dev/null 2>&1 if cmp -s y.tab.c perly.c; then @@ -11993,8 +12048,8 @@ $define) fi echo "x2p/a2p.y" >&4 cd x2p - rm -f y.tab.c y.tab.h - yacc -d a2p.y >/dev/null 2>&1 + rm -f y.tab.c + yacc a2p.y >/dev/null 2>&1 if cmp -s y.tab.c a2p.c then rm -f y.tab.c @@ -12006,14 +12061,6 @@ $define) -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c xxx="$xxx a2p.c" fi - if cmp -s y.tab.h a2p.h - then - rm -f y.tab.h - else - echo "a2p.h -> a2p.h" >&4 - mv -f y.tab.h a2p.h - xxx="$xxx a2p.h" - fi cd .. case "$xxx" in '') echo "No parser files were regenerated. That's okay." >&4 ;; @@ -1203,6 +1203,21 @@ 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. +=item Bad arg length for semctl, is XX, should be ZZZ + +If you get this error message from the lib/ipc_sysv test, your System +V IPC may be broken. The XX typically is 20, and that is what ZZZ +also should be. Consider upgrading your OS, or reconfiguring your OS +to include the System V semaphores. + +=item lib/ipc_sysv........semget: No space left on device + +Either your account or the whole system has run out of semaphores. Or +both. Either list the semaphores with "ipcs" and remove the unneeded +ones (which ones these are depends on your system and applications) +with "ipcrm -s SEMAPHORE_ID_HERE" or configure more semaphores to your +system. + =item Miscellaneous Some additional things that have been reported for either perl4 or perl5: @@ -1213,6 +1228,10 @@ NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT. +FreeBSD can fail the lib/ipc_sysv.t test if SysV IPC has not been +configured to the kernel. Perl tries to detect this, though, and +you will get a message telling what to do. + If you get syntax errors on '(', try -DCRIPPLED_CC. Machines with half-implemented dbm routines will need to #undef I_ODBM @@ -20,6 +20,7 @@ Porting/Glossary Glossary of config.sh variables Porting/config.sh Sample config.sh Porting/config_H Sample config.h Porting/findvars Find occurrences of words +Porting/fixCORE Find and fix modules that generate warnings Porting/fixvars Find undeclared variables with C compiler and fix em Porting/genlog Generate formatted changelogs by querying p4d Porting/makerel Release making utility @@ -34,6 +35,7 @@ README.cygwin32 Notes about Cygwin32 port README.dos Notes about dos/djgpp port README.mpeix Notes about MPE/iX port README.os2 Notes about OS/2 port +README.os390 Notes about OS/390 (nee MVS) port README.plan9 Notes about Plan9 port README.qnx Notes about QNX port README.threads Notes about multithreading @@ -73,6 +75,7 @@ doio.c I/O operations doop.c Support code for various operations dosish.h Some defines for MS/DOSish machines dump.c Debugging output +ebcdic.c EBCDIC support routines eg/ADB An adb wrapper to put in your crash dir eg/README Intro to example perl scripts eg/cgi/RunMeFirst Setup script for CGI examples @@ -1198,6 +1201,7 @@ win32/config_H.gc Win32 config header (GNU build)? win32/config_H.vc Win32 config header (Visual C++ build) win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_sh.PL Perl code to update Win32 config.sh from Makefile +win32/des_fcrypt.patch Win32 port win32/dl_win32.xs Win32 port win32/genxsdef.pl Win32 port win32/include/arpa/inet.h Win32 port diff --git a/Porting/fixCORE b/Porting/fixCORE new file mode 100755 index 0000000000..4c586d8969 --- /dev/null +++ b/Porting/fixCORE @@ -0,0 +1,68 @@ +#!/usr/local/bin/perl -w +use Data::Dumper; + +my $targ = shift; +my $inc = join(' ',map("-I$_",@INC)); + +my $work = 1; +while ($work) + { + open(PIPE,"$^X -w $inc -M$targ -e '' 2>&1 |") || die "Cannot open pipe to child:$!"; + my %fix; + while (<PIPE>) + { + if (/^Ambiguous call resolved as CORE::(\w+)\(\), qualify as such or use \& at (\S+) line (\d+)/ + && -f $2 ) + { + my ($var,$file,$line) = ($1,$2,$3); + $fix{$file} = [] unless exists $fix{$file}; + push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/); + } + print; + } + close(PIPE); +# warn "Make retured $?\n"; +# last unless $?; + my $changed = 0; + foreach my $file (keys %fix) + { + my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}}); + my @miss; + my $fixed = 0; + @ARGV = ($file); + $. = 0; + local $^I = '.sav'; + while (<>) + { + while (@ar && $. == $ar[0][0]) + { + my ($line,$var) = @{shift(@ar)}; + if (s/(?<!CORE::)\b$var\b(?=\s*\()/CORE::$var/) + { + warn "$file:$line: FIX $var\n"; + $fixed++; + $changed++; + } + else + { + push(@miss,[$line,$var,$_]); + } + } + print; + } + unless ($fixed) + { + rename("$file$^I",$file); + if (@miss) + { + while (@miss) + { + my ($line,$var,$txt) = @{shift(@miss)}; + warn "$file:$line:$var | $txt"; + } + } + } + } + last unless $changed; + } + diff --git a/Porting/makerel b/Porting/makerel index 1a00e973a3..f2e1f9750b 100644 --- a/Porting/makerel +++ b/Porting/makerel @@ -66,11 +66,27 @@ print "\n"; #system("perl -pi -e 's/^\QPERL_VERSION = \E\d\_\d+(\s*\#)/PERL_VERSION = $vms_vers$1/' vms/descrip.mms"); + +print "Creating $relroot/$reldir release directory...\n"; +die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir"; +die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz"; +mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n"; +print "\n"; + + +print "Copying files to release directory...\n"; +# ExtUtils::Manifest maniread does not preserve the order +$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir"; +system($cmd) == 0 or die "$cmd failed"; +print "\n"; + +chdir "$relroot/$reldir" or die $!; + print "Setting file permissions...\n"; system("find . -type f -print | xargs chmod -w"); system("find . -type d -print | xargs chmod g-s"); system("find t -name '*.t' -print | xargs chmod +x"); -@exe = qw( +my @exe = qw( Configure configpm embed.pl @@ -90,23 +106,19 @@ system("find t -name '*.t' -print | xargs chmod +x"); Porting/makerel ); system("chmod +x @exe"); -print "\n"; - - -print "Creating $relroot/$reldir release directory...\n"; -die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir"; -die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz"; -mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n"; -print "\n"; - -print "Copying files to release directory...\n"; -# ExtUtils::Manifest maniread does not preserve the order -$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir"; -system($cmd) == 0 or die "$cmd failed"; +print "Adding CRs to DOSish files...\n"; +my @crlf = qw( + djgpp/configure.bat + README.dos + README.win32 + win32/Makefile + win32/makefile.mk +); +system("perl -pi -e 's/\$/\\r/' @crlf"); print "\n"; -chdir $relroot or die $!; +chdir ".." or die $!; print "Creating and compressing the tar file...\n"; my $src = (-e $perl) ? $perl : 'perl'; # 'perl' in maint branch diff --git a/Porting/patchls b/Porting/patchls index 5b958323d2..38c4dd1f47 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -17,7 +17,7 @@ use Text::Tabs qw(expand unexpand); use strict; use vars qw($VERSION); -$VERSION = 2.05; +$VERSION = 2.08; sub usage { die qq{ @@ -30,6 +30,7 @@ die qq{ -m print formatted Meta-information (Subject,From,Msg-ID etc). -p N strip N levels of directory Prefix (like patch), else automatic. -v more verbose (-d for noisy debugging). + -n give a count of the number of patches applied to a file if >1. -f F only list patches which patch files matching regexp F (F has \$ appended unless it contains a /). -e Expect patched files to Exist (relative to current directory) @@ -40,6 +41,7 @@ die qq{ -5 like -4 but add "|| exit 1" after each command -M T Like -m but only output listed meta tags (eg -M 'Title From') -W N set wrap width to N (defaults to 70, use 0 for no wrap) + -X list patchfiles that may clash (i.e. patch the same file) patchls version $VERSION by Tim Bunce } @@ -49,6 +51,7 @@ $::opt_p = undef; # undef != 0 $::opt_d = 0; $::opt_v = 0; $::opt_m = 0; +$::opt_n = 0; $::opt_i = 0; $::opt_h = 0; $::opt_l = 0; @@ -63,35 +66,55 @@ $::opt_5 = 0; $::opt_M = ''; # like -m but only output these meta items (-M Title) $::opt_W = 70; # set wrap width columns (see Text::Wrap module) $::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented +$::opt_X = 0; # list patchfiles that patch the same file usage unless @ARGV; -getopts("mihlvecC45p:f:IM:W:") or usage; +getopts("dmnihlvecC45Xp:f:IM:W:") or usage; $columns = $::opt_W || 9999999; $::opt_m = 1 if $::opt_M; $::opt_4 = 1 if $::opt_5; -my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID'); # see get_meta_info() +$::opt_i = 1 if $::opt_X; + +# see get_meta_info() +my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID Files'); +my %show_meta = map { ($_,1) } @show_meta; my %cat_title = ( 'BUILD' => 'BUILD PROCESS', 'CORE' => 'CORE LANGUAGE', 'DOC' => 'DOCUMENTATION', - 'LIB' => 'LIBRARY AND EXTENSIONS', + 'LIB' => 'LIBRARY', 'PORT1' => 'PORTABILITY - WIN32', 'PORT2' => 'PORTABILITY - GENERAL', 'TEST' => 'TESTS', 'UTIL' => 'UTILITIES', 'OTHER' => 'OTHER CHANGES', + 'EXT' => 'EXTENSIONS', + 'UNKNOWN' => 'UNKNOWN - NO FILES PATCH', ); sub get_meta_info { my $ls = shift; local($_) = shift; - $ls->{From}{$1}=1 if /^From:\s+(.*\S)/i; - $ls->{Title}{$1}=1 if /^Subject:\s+(?:Re: )?(.*\S)/i; + if (/^From:\s+(.*\S)/i) {; + my $from = $1; # temporary measure for Chip Salzenberg + $from =~ s/chip\@(atlantic\.net|perlsupport\.com)/chip\@pobox.com/; + $from =~ s/\(Tim Bunce\) \(Tim Bunce\)/(Tim Bunce)/; + $ls->{From}{$from} = 1 + } + if (/^Subject:\s+(?:Re: )?(.*\S)/i) { + my $title = $1; + $title =~ s/\[(PATCH|PERL)[\w\. ]*\]:?//g; + $title =~ s/\b(PATCH|PERL)[\w\.]*://g; + $title =~ s/\bRe:\s+/ /g; + $title =~ s/\s+/ /g; + $title =~ s/^\s*(.*?)\s*$/$1/g; + $ls->{Title}{$title} = 1; + } $ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i; $ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i; $ls->{$1}{$2}=1 if $::opt_M && /^([-\w]+):\s+(.*\S)/; @@ -118,7 +141,9 @@ sub get_meta_info { my %ls; -my ($in, $prevline, $ls); +my $in; +my $ls; +my $prevline = ''; my $prevtype = ''; my (@removed, @added); my $prologue = 1; # assume prologue till patch or /^exit\b/ seen @@ -149,13 +174,17 @@ foreach my $argv (@ARGV) { next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/; $prologue = 0; - print "Last: $prevline","This: ${_}Got: $1\n\n" if $::opt_d; + print "Last: $prevline","This: ${_}Got: $type\n\n" if $::opt_d; # Some patches have Index lines but not diff headers # Patch copes with this, so must we. It's also handy for # documenting manual changes by simply adding Index: lines - # to the file which describes the problem bing fixed. - add_file($ls, $1), next if /^Index:\s+(\S+)/; + # to the file which describes the problem being fixed. + if (/^Index:\s+(.*)/) { + my $f; + foreach $f (split(/ /, $1)) { add_file($ls, $f) } + next; + } if ( ($type eq '---' and $prevtype eq '***') # Style 1 or ($type eq '+++' and $prevtype eq '---') # Style 2 @@ -170,26 +199,30 @@ foreach my $argv (@ARGV) { } continue { $prevline = $_; - $prevtype = $type; + $prevtype = $type || ''; $type = ''; } # special mode for patch sets from Chip - if ($::opt_C && $in =~ m:[\\/]patch$:) { + if ($in =~ m:[\\/]patch$:) { + my $is_chip; my $chip; my $dir; ($dir = $in) =~ s:[\\/]patch$::; if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) { get_meta_info($ls, $_) while (<CHIP>); + $is_chip = 1; } if (open CHIP,"<$dir/from") { chop($chip = <CHIP>); $ls->{From} = { $chip => 1 }; + $is_chip = 1; } if (open CHIP,"<$dir/tag") { chop($chip = <CHIP>); $ls->{Title} = { $chip => 1 }; + $is_chip = 1; } - $ls->{From} = { "Chip Salzenberg" => 1 } unless $ls->{From}; + $ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From}; } # if we don't have a title for -m then use the file name @@ -207,13 +240,15 @@ print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1; my @ls = values %ls; if ($::opt_f) { # filter out patches based on -f <regexp> - my $out; $::opt_f .= '$' unless $::opt_f =~ m:/:; @ls = grep { - my @out = keys %{$_->{out}}; my $match = 0; - for $out (@out) { - ++$match if $out =~ m/$::opt_f/o; + if ($_->{is_in}) { + my @out = keys %{ $_->{out} }; + $match=1 if grep { m/$::opt_f/o } @out; + } + else { + $match=1 if $_->{in} =~ m/$::opt_f/o; } $match; } @ls; @@ -230,36 +265,51 @@ if ($::opt_4) { my $tail = ($::opt_5) ? "|| exit 1" : ""; print map { "p4 delete $_$tail\n" } @removed if @removed; print map { "p4 add $_$tail\n" } @added if @added; - my @patches = grep { $_->{is_in} } @ls; + my @patches = sort grep { $_->{is_in} } @ls; + my @no_outs = grep { keys %{$_->{out}} == 0 } @patches; + warn "Warning: Some files contain no patches:", + join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs; my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches; delete @patched{@added}; my @patched = sort keys %patched; - print map { + foreach(@patched) { my $edit = ($::opt_e && !-f $_) ? "add " : "edit"; - "p4 $edit $_$tail\n" - } @patched if @patched; + print "p4 $edit $_$tail\n"; + } exit 0 unless $::opt_C; } + if ($::opt_I) { my $n_patches = 0; my($in,$out); my %all_out; + my @no_outs; foreach $in (@ls) { next unless $in->{is_in}; ++$n_patches; my @outs = keys %{$in->{out}}; + push @no_outs, $in unless @outs; @all_out{@outs} = ($in->{in}) x @outs; } my @all_out = sort keys %all_out; my @missing = grep { ! -f $_ } @all_out; print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n"; + print @no_outs." patch files don't contain patches.\n" if @no_outs; print "(use -v to list patches which patch 'missing' files)\n" - if @missing && !$::opt_v; + if (@missing || @no_outs) && !$::opt_v; + if ($::opt_v and @no_outs) { + print "Patch files which don't contain patches:\n"; + foreach $out (@no_outs) { + printf " %-20s\n", $out->{in}; + } + } if ($::opt_v and @missing) { print "Missing files:\n"; foreach $out (@missing) { - printf " %-20s\t%s\n", $out, $all_out{$out}; + printf " %-20s\t", $out unless $::opt_h; + print $all_out{$out} unless $::opt_l; + print "\n"; } } print "Added files: @added\n" if @added; @@ -270,6 +320,7 @@ if ($::opt_I) { unless ($::opt_c and $::opt_m) { foreach $ls (@ls) { next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; + next if $::opt_X and keys %{$ls->{out}} <= 1; list_files_by_patch($ls); } } @@ -304,6 +355,7 @@ exit 0; sub add_file { my $ls = shift; + print "add_file '$_[0]'\n" if $::opt_d; my $out = trim_name(shift); $ls->{out}->{$out} = 1; @@ -351,7 +403,7 @@ sub list_files_by_patch { my @list = sort keys %{$ls->{$meta}}; push @meta, sprintf "%7s: ", $meta; if ($meta eq 'Title') { - @list = map { s/\[?(PATCH|PERL)\]?:?\s*//g; "\"$_\""; } @list; + @list = map { "\"$_\""; } @list; push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:; } elsif ($meta eq 'From') { @@ -372,17 +424,27 @@ sub list_files_by_patch { $name = "\n$name" if @meta and $name; } # don't print the header unless the file contains something interesting - return if !@meta and !$ls->{out}; - print("$ls->{in}\n"),return if $::opt_l; # -l = no listing, just names + return if !@meta and !$ls->{out} and !$::opt_v; + if ($::opt_l) { # -l = no listing, just names + print "$ls->{in}"; + my $n = keys %{ $ls->{out} }; + print " ($n patches)" if $::opt_n and $n>1; + print "\n"; + return; + } # a twisty maze of little options my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : ""; print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat"; print join('',"\n",@meta) if @meta; + return if $::opt_m && !$show_meta{Files}; my @v = sort PATORDER keys %{ $ls->{out} }; - my $v = "@v\n"; + my $n = @v; + my $v = "@v"; print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v; + print " ($n patches)" if $::opt_n and $n>1; + print "\n"; } @@ -408,8 +470,10 @@ sub categorize_files { if m:^(cygwin32|os2|plan9|qnx|vms)/: or m:^(hints|Porting|ext/DynaLoader)/: or m:^README\.:; + $c{EXT} += 10,next + if m:^(ext|lib/ExtUtils)/:; $c{LIB} += 10,next - if m:^(lib|ext)/:; + if m:^(lib)/:; $c{'CORE'} += 15,next if m:^[^/]+[\._]([chH]|sym|pl)$:; $c{BUILD} += 10,next @@ -435,7 +499,7 @@ sub categorize_files { } else { my($c, $v) = %c; - $c ||= 'OTHER'; $v ||= 0; + $c ||= 'UNKNOWN'; $v ||= 0; print " ".@$files." patches: $c: $v\n" if $verb; return $c; } diff --git a/README.os2 b/README.os2 index a0b3d979d3..409c774591 100644 --- a/README.os2 +++ b/README.os2 @@ -112,6 +112,7 @@ Contents - Threading - Calls to external programs - Memory allocation + - Threads AUTHOR SEE ALSO @@ -883,50 +884,65 @@ Now run make test -Some tests (4..6) should fail. Some perl invocations should end in a -segfault (system error C<SYS3175>). To get finer error reports, call +All tests should succeed (with some of them skipped). Note that on one +of the systems I see intermittent failures of F<io/pipe.t> subtest 9. +Any help to track what happens with this test is appreciated. - perl t/harness +Some tests may generate extra messages similar to -The report you get may look like +=over 4 - Failed Test Status Wstat Total Fail Failed List of failed - --------------------------------------------------------------- - io/fs.t 26 11 42.31% 2-5, 7-11, 18, 25 - 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/140 test scripts, 97.14% okay. 27/2937 subtests failed, 99.08% okay. +=item A lot of C<bad free> -Note that using C<make test> target two more tests may fail: C<op/exec:1> -because of (mis)feature of pdksh, and C<lib/posix:15>, which checks -that the buffers are not flushed on C<_exit> (this is a bug in the test -which assumes that tty output is buffered). +in database tests related to Berkeley DB. This is a confirmed bug of +DB. You may disable this warnings, see L<"PERL_BADFREE">. -I submitted a patch to 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. +There is not much we can do with it (but apparently it does not cause +any real error with data). -However, the test F<lib/io_udp.t> is disabled, since it never terminates, I -do not know why. Comments/fixes welcome. +=item Process terminated by SIGTERM/SIGINT -The reasons for failed tests are: +This is a standard message issued by OS/2 applications. *nix +applications die in silence. It is considered a feature. One can +easily disable this by appropriate sighandlers. -=over 8 +However the test engine bleeds these message to screen in unexpected +moments. Two messages of this kind I<should> be present during +testing. -=item F<io/fs.t> +=back -Checks I<file system> operations. Tests: +Two F<lib/io_*> tests may generate popups (system error C<SYS3175>), +but should succeed anyway. This is due to a bug of EMX related to +fork()ing with dynamically loaded libraries. -=over 10 +I submitted a patch to EMX which makes it possible to fork() with EMX +dynamic libraries loaded, which makes F<lib/io*> tests pass without +skipping offended tests. This means that soon the number of skipped tests +may decrease yet more. + +To get finer test reports, call + + perl t/harness + +The report with F<io/pipe.t> failing may look like this: -=item 2-5, 7-11 + Failed Test Status Wstat Total Fail Failed List of failed + ------------------------------------------------------------ + io/pipe.t 12 1 8.33% 9 + 7 tests skipped, plus 56 subtests skipped. + Failed 1/195 test scripts, 99.49% okay. 1/6542 subtests failed, 99.98% okay. + +The reasons for most important skipped tests are: + +=over 8 -Check C<link()> and C<inode count> - nonesuch under OS/2. +=item F<op/fs.t> =item 18 -Checks C<atime> and C<mtime> of C<stat()> - I could not understand this test. +Checks C<atime> and C<mtime> of C<stat()> - unfortunately, HPFS +provides only 2sec time granularity (for compatibility with FAT?). =item 25 @@ -951,62 +967,20 @@ Checks C<stat()>. Tests: =over 4 -=item 3 - -Checks C<inode count> - nonesuch under OS/2. - =item 4 -Checks C<mtime> and C<ctime> of C<stat()> - I could not understand this test. - -=item 20 - -Checks C<-x> - determined by the file extension only under OS/2. - -=item 35 - -Needs F</usr/bin>. - -=item 39 - -Checks C<-t> of F</dev/null>. Should not fail! - -=back +Checks C<atime> and C<mtime> of C<stat()> - unfortunately, HPFS +provides only 2sec time granularity (for compatibility with FAT?). =back -In addition to errors, you should get a lot of warnings. - -=over 4 - -=item A lot of C<bad free> - -in databases related to Berkeley DB. This is a confirmed bug of -DB. You may disable this warnings, see L<"PERL_BADFREE">. - -=item Process terminated by SIGTERM/SIGINT +=item F<lib/io_udp.t> -This is a standard message issued by OS/2 applications. *nix -applications die in silence. It is considered a feature. One can -easily disable this by appropriate sighandlers. - -However the test engine bleeds these message to screen in unexpected -moments. Two messages of this kind I<should> be present during -testing. - -=item F<*/sh.exe>: ln: not found - -=item C<ls>: /dev: No such file or directory - -The last two should be self-explanatory. The test suite discovers that -the system it runs on is not I<that much> *nixish. +It never terminates, apparently some bug in storing the last socket from +which we obtained a message. =back -A lot of C<bad free>... in databases, bug in DB confirmed on other -platforms. You may disable it by setting PERL_BADFREE environment variable -to 1. - =head2 Installing the built perl If you haven't yet moved perl.dll onto LIBPATH, do it now. @@ -1550,14 +1524,10 @@ as when processing B<-S> command-line switch. =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. +for speed, but perl is not, since its malloc is lightning-fast. +Perl-memory-usage-tuned benchmarks show that Perl's malloc is 5 times quickier +than EMX one. I do not have convincing data about memory footpring, but +a (pretty random) benchmark showed that Perl one is 5% better. Combination of perl's malloc() and rigid DLL name resolution creates a special problem with library functions which expect their return value to @@ -1566,6 +1536,31 @@ 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.) +=head2 Threads + +One can build perl with thread support enabled by providing C<-D usethreads> +option to F<Configure>. Currently OS/2 support of threads is very +preliminary. + +Most notable problems: + +=over + +=item C<COND_WAIT> + +may have a race condition. Needs a reimplementation (in terms of chaining +waiting threads, with linker list stored in per-thread structure?). + +=item F<os2.c> + +has a couple of static variables used in OS/2-specific functions. (Need to be +moved to per-thread structure, or serialized?) + +=back + +Note that these problems should not discourage experimenting, since they +have a low probability of affecting small programs. + =cut OS/2 extensions diff --git a/README.os390 b/README.os390 new file mode 100644 index 0000000000..b5ddaffacc --- /dev/null +++ b/README.os390 @@ -0,0 +1,83 @@ +This is a fully ported perl for OS/390 Release 3. It may work on +other versions, but that's the one we've tested it on. + +If you've downloaded the binary distribution, it needs to be +installed below /usr/local. Source code distributions have an +automated `make install` step that means you do not need to extract +the source code below /usr/local (though that is where it will be +installed by default). You may need to worry about the networking +configuration files discussed in the last bullet below. + +Gunzip/gzip for OS/390 is discussed at: + + http://www.s390.ibm.com/products/oe/bpxqp1.html + +to extract an ASCII tar archive on OS/390, try this: + + pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar + +GNU make for OS/390, which may be required for the build of perl, +is available from: + + http://www.mks.com/s390/gnu/index.htm + +Once you've unpacked the distribution, run Configure (see INSTALL for +full discussion of the Configure options), and then run make, then +"make test" then "make install" (this last step may require UID=0 +privileges) + +There is a "hints" file for os390 that specifies the correct values +for most things. Some things to watch out for are + + - this port doesn't support dynamic loading. Although + OS/390 has support for DLLs, there are some differences + that cause problems for perl. + + - You may see a "WHOA THERE!!!" message for $d_shmatprototype + it is OK to keep the recommended "define". + + - Don't turn on the compiler optimization flag "-O". There's + a bug in either the optimizer or perl that causes perl to + not work correctly when the optimizer is on. + + - Some of the configuration files in /etc used by the + networking APIs are either missing or have the wrong + names. In particular, make sure that there's either + an /etc/resolv.conf or and /etc/hosts, so that + gethostbyname() works, and make sure that the file + /etc/proto has been renamed to /etc/protocol (NOT + /etc/protocols, as used by other Unix systems). + +When using perl on OS/390 please keep in mind that the EBCDIC and ASCII +character sets are different. Perl builtin functions that may behave +differently under EBCDIC are mentioned in the perlport.pod document. + +OpenEdition (UNIX System Services) does not (yet) support the #! means +of script invokation. +See: + + head `whence perldoc` + +for an example of how to use the "eval exec" trick to ask the shell to +have perl run your scripts for you. + +perl-mvs mailing list: The Perl Institute (http://www.perl.org/) +maintains a mailing list of interest to all folks building and/or +using perl on EBCDIC platforms. To subscibe, send a message of: + + subscribe perl-mvs + +to majordomo@perl.org. + +Regression tests: as the 5.005 kit was was being assembled +the following "failures" were known to appear on some machines +during `make test` (mostly due to ASCII vs. EBCDIC conflicts), +your results may differ: + +comp/cpp..........FAILED at test 0 +op/pack...........FAILED at test 58 +op/stat...........Out of memory! +op/taint..........FAILED at test 73 +lib/errno.........FAILED at test 1 +lib/posix.........FAILED at test 19 +lib/searchdict....FAILED at test 1 diff --git a/README.threads b/README.threads index e9f69663f9..952623fcbd 100644 --- a/README.threads +++ b/README.threads @@ -8,6 +8,8 @@ running one of the following: * Digital UNIX 4.x + * Digital UNIX 3.x (Formerly DEC OSF/1), see additional note below + * Solaris 2.x for recentish x (2.5 is OK) * IRIX 6.2 or newer. 6.2 will require a few os patches. @@ -59,6 +61,14 @@ For Digital Unix 4.x: Zap mallocobj and mallocsrc (foo='') Change d_mymalloc to undef +For Digital Unix 3.x (Formerly DEC OSF/1): + Add -DOLD_PTHREADS_API to ccflags + If compiling with the GNU cc compiler, remove -thread from ccflags + + (The following should be done automatically if you call Configure + with the -Dusethreads option). + Add -lpthread -lmach -lc_r to libs (in the order specified). + For IRIX: (This should all be done automatically by the hint file). Add -lpthread to libs @@ -150,13 +160,13 @@ haven't tracked down yet) and there are very probably others too. Debugging -Use the -DL command-line option to turn on debugging of the +Use the -DS command-line option to turn on debugging of the multi-threading code. Under Linux, that also turns on a quick hack I did to grab a bit of extra information from segfaults. If you have a fancier gdb/threads setup than I do then you'll have to delete the lines in perl.c which say #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) - DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); + DEBUG_S(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); #endif diff --git a/README.win32 b/README.win32 index 6ac163a0a8..85bab908b4 100644 --- a/README.win32 +++ b/README.win32 @@ -171,7 +171,12 @@ available worldwide, usually along with SSLeay (for example: "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/"). Set CRYPT_SRC to the name of the file that implements des_fcrypt(). Alternatively, if you have built a library that contains des_fcrypt(), you can set -CRYPT_LIB to point to the library name. +CRYPT_LIB to point to the library name. The location above contains +many versions of the "libdes" library, all with slightly different +implementations of des_fcrypt(). Older versions have a single, +self-contained file (fcrypt.c) that implements crypt(), so they may be +easier to use. A patch against the fcrypt.c found in libdes-3.06 is +in des_fcrypt.patch. Perl will also build without des_fcrypt(), but the crypt() builtin will fail at run time. diff --git a/configure.com b/configure.com index 64ad730763..521221978b 100644 --- a/configure.com +++ b/configure.com @@ -1,23 +1,16 @@ $ sav_ver = 'F$VERIFY(0)' $! SET VERIFY $! -$! Installation and usage: COPY this file into you perl source tree - at or -$! below where the main MANIFEST. file is located. -$! $! For example, if you unpacked perl into: [USER.PERL5_00n...] then you will -$! want to: -$! -$! $ COPY Configure.com [USER.PERL5_00n.VMS] -$! -$! Now cd into the tree and execute Configure: +$! want to cd into the tree and execute Configure: $! $! $ SET DEFAULT [USER.PERL5_00n] -$! $ @[.vms]Configure +$! $ @Configure $! $! or $! $! $ SET DEFAULT [USER.PERL5_00n] -$! $ @[.vms]Configure "-des" +$! $ @Configure "-des" $! $! That's it. If you get into a bind trying to build perl on VMS then $! definitely read through the README.VMS file. @@ -388,6 +381,8 @@ $ ENDIF $ ELSE $! MANIFEST. has been found and we have set def'ed there - $! time to bail out before it's too late. +$ tmp = f$extract(1,3,f$edit(f$getsyi("VERSION"),"TRIM,COLLAPSE")) +$ IF tmp .GES. "7.2" THEN GOTO Beyond_depth_check $ IF (F$ELEMENT(max_allowed_dir_depth,".",F$ENVIRONMENT("Default")).nes.".") $ THEN $ TYPE SYS$INPUT: @@ -400,6 +395,7 @@ $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP $ EXIT !2 !$STATUS = "%X00000002" (error) $ ENDIF +$Beyond_depth_check: $! $! after finding MANIFEST let's create (but not yet enter) the UU subdirectory $! @@ -874,7 +870,7 @@ $ ENDIF $ ENDIF $ IF (archname.EQS."VMS_AXP") $ THEN -$ dflt = "N" +$ dflt = "n" $ rp = "Are you sharing your PERL_ROOT with a VAX? [''dflt'] " $ GOSUB myread $ if ans.NES."" @@ -1657,7 +1653,7 @@ $ if "''has_dec_c_sockets'".eqs."T" $ THEN $ dflt = "DECC" $ else -$ dlft = "SOCKETSHR" +$ dflt = "SOCKETSHR" $ endif $ rp = "Choose socket stack (NONE" $ if "''has_socketshr'".eqs."T" THEN rp = rp + ",SOCKETSHR" @@ -1700,7 +1696,7 @@ $ echo "machine. Unfortunately this feature isn't safe on an $ echo "unpatched 7.1 system. (Several OS patches were required when $ echo "this procedure was written) $ echo "" -$ dflt = "N" +$ dflt = "n" $ rp = "Enable multiple kernel threads and upcalls? [''dflt'] " $ gosub myread $ if ans.eqs."" then ans="''dflt'" @@ -1727,7 +1723,7 @@ $ echo "This will exact both a memory penalty (to store the keys) and $ echo "a time penalty (to spawn the subprocess) every time you invoke $ echo "perl. Depending on your system, this might not be a big deal. $ echo "" -$ dflt = "N" +$ dflt = "n" $ rp = "Populate %ENV at startup time? [''dflt'] " $ GOSUB myread $ if ans.eqs."" then ans="''dflt'" @@ -1740,7 +1736,7 @@ $ echo "normal memory usage. It's oftentimes better than the standard $ echo "system memory allocator. It also has the advantage of providing $ echo "memory allocation statistics, if you choose to enable them. $ echo "" -$ dflt = "N" +$ dflt = "n" $ rp = "Build with perl's memory allocator? [''dflt'] " $ GOSUB myread $ if ans.eqs."" then ans="''dflt'" @@ -1754,7 +1750,7 @@ $ echo "Perl can keep statistics on memory usage if you choose to use $ echo "them. This is useful for debugging, but does have some $ echo "performance overhead. $ echo "" -$ dflt = "N" +$ dflt = "n" $ rp = "Do you want the debugging memory allocator? [''dflt'] " $ gosub myread $ if ans.eqs."" then ans="''dflt'" @@ -1935,7 +1931,7 @@ $! $! Invoke the subconfig piece $! $ echo "" -$ echo4 "Generating config.h" +$ echo4 "Checking the C Run time library" $ dflt = F$ENVIRONMENT("DEFAULT") $ SET DEFAULT [-.vms] $ @subconfigure diff --git a/djgpp/configure.bat b/djgpp/configure.bat index 64b46ec34f..e7d41d7130 100644 --- a/djgpp/configure.bat +++ b/djgpp/configure.bat @@ -1,37 +1,37 @@ -@echo off
-set CONFIG=
-set PATH_SEPARATOR=;
-set PATH_EXPAND=y
-sh -c 'if test $PATH_SEPARATOR = ";"; then exit 1; fi'
-if ERRORLEVEL 1 goto path_sep_ok
-echo Error:
-echo Make sure the environment variable PATH_SEPARATOR=; while building perl!
-echo Please check your DJGPP.ENV!
-goto end
-
-:path_sep_ok
-sh -c 'if test $PATH_EXPAND = "Y" -o $PATH_EXPAND = "y"; then exit 1; fi'
-if ERRORLEVEL 1 goto path_exp_ok
-echo Error:
-echo Make sure the environment variable PATH_EXPAND=Y while building perl!
-echo Please check your DJGPP.ENV!
-goto end
-
-:path_exp_ok
-sh -c '$SHELL -c "exit 128"'
-if ERRORLEVEL 128 goto shell_ok
-
-echo Error:
-echo The SHELL environment variable must be set to the full path of your sh.exe!
-goto end
-
-:shell_ok
-sh -c 'if test ! -d /tmp; then mkdir /tmp; fi'
-cp djgpp.c config.over ..
-cd ..
-echo Running sed...
-sh djgpp/djgppsed.sh
-
-echo Running Configure...
-sh Configure %1 %2 %3 %4 %5 %6 %7 %8 %9
-:end
+@echo off +set CONFIG= +set PATH_SEPARATOR=; +set PATH_EXPAND=y +sh -c 'if test $PATH_SEPARATOR = ";"; then exit 1; fi' +if ERRORLEVEL 1 goto path_sep_ok +echo Error: +echo Make sure the environment variable PATH_SEPARATOR=; while building perl! +echo Please check your DJGPP.ENV! +goto end + +:path_sep_ok +sh -c 'if test $PATH_EXPAND = "Y" -o $PATH_EXPAND = "y"; then exit 1; fi' +if ERRORLEVEL 1 goto path_exp_ok +echo Error: +echo Make sure the environment variable PATH_EXPAND=Y while building perl! +echo Please check your DJGPP.ENV! +goto end + +:path_exp_ok +sh -c '$SHELL -c "exit 128"' +if ERRORLEVEL 128 goto shell_ok + +echo Error: +echo The SHELL environment variable must be set to the full path of your sh.exe! +goto end + +:shell_ok +sh -c 'if test ! -d /tmp; then mkdir /tmp; fi' +cp djgpp.c config.over .. +cd .. +echo Running sed... +sh djgpp/djgppsed.sh + +echo Running Configure... +sh Configure %1 %2 %3 %4 %5 %6 %7 %8 %9 +:end @@ -125,22 +125,37 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe } if (as_raw) { - result = rawmode & 3; - IoTYPE(io) = "<>++"[result]; +#ifndef O_ACCMODE +#define O_ACCMODE 3 /* Assume traditional implementation */ +#endif + switch (result = rawmode & O_ACCMODE) { + case O_RDONLY: + IoTYPE(io) = '<'; + break; + case O_WRONLY: + IoTYPE(io) = '>'; + break; + case O_RDWR: + default: + IoTYPE(io) = '+'; + break; + } + writing = (result > 0); fd = PerlLIO_open3(name, rawmode, rawperm); + if (fd == -1) fp = NULL; else { char *fpmode; - if (result == 0) + if (result == O_RDONLY) fpmode = "r"; #ifdef O_APPEND else if (rawmode & O_APPEND) - fpmode = (result == 1) ? "a" : "a+"; + fpmode = (result == O_WRONLY) ? "a" : "a+"; #endif else - fpmode = (result == 1) ? "w" : "r+"; + fpmode = (result == O_WRONLY) ? "w" : "r+"; fp = PerlIO_fdopen(fd, fpmode); if (!fp) PerlLIO_close(fd); @@ -400,7 +415,7 @@ nextargv(register GV *gv) sv_setsv(GvSV(gv),sv); SvSETMAGIC(GvSV(gv)); PL_oldname = SvPVx(GvSV(gv), oldlen); - if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,0,0,Nullfp)) { + if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) { if (PL_inplace) { TAINT_PROPER("inplace open"); if (oldlen == 1 && *PL_oldname == '-') { @@ -462,7 +477,7 @@ nextargv(register GV *gv) do_close(gv,FALSE); (void)PerlLIO_unlink(SvPVX(sv)); (void)PerlLIO_rename(PL_oldname,SvPVX(sv)); - do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,0,0,Nullfp); + do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp); #endif /* DOSISH */ #else (void)UNLINK(SvPVX(sv)); diff --git a/ebcdic.c b/ebcdic.c new file mode 100644 index 0000000000..890bd086d2 --- /dev/null +++ b/ebcdic.c @@ -0,0 +1,32 @@ +#include "EXTERN.h" +#include "perl.h" + +/* in ASCII order, not that it matters */ +static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; + +int +ebcdic_control(int ch) +{ + if (ch > 'a') { + char *ctlp; + + if (islower(ch)) + ch = toupper(ch); + + if ((ctlp = strchr(controllablechars, ch)) == 0) { + die("unrecognised control character '%c'\n", ch); + } + + if (ctlp == controllablechars) + return('\177'); /* DEL */ + else + return((unsigned char)(ctlp - controllablechars - 1)); + } else { /* Want uncontrol */ + if (ch == '\177' || ch == -1) + return('?'); + else if (0 < ch && ch < (sizeof(controllablechars) - 1)) + return(controllablechars[ch+1]); + else + die("invalid control request: '\\%03o'\n", ch & 0xFF); + } +} diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index 0a467b0fd8..3d7be098c0 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -46,7 +46,7 @@ ;;; Commentary: -;; $Id: cperl-mode.el 3.14 1998/07/03 00:32:02 vera Exp vera $ +;; $Id: cperl-mode.el 4.5 1998/07/28 08:55:41 vera Exp vera $ ;;; Before (future?) RMS Emacs 20.3: To use this mode put the following into ;;; your .emacs file: @@ -737,6 +737,69 @@ ;;; (`cperl-find-pods-heres'): 1 << 6 was OK, but 1<<6 was considered as HERE ;;; <file/glob> made into a string. +;;;; After 3.14: +;;; (`cperl-find-pods-heres'): Postpone addition of faces after syntactic step +;;; Recognition of <FH> was wrong. +;;; (`cperl-clobber-lisp-bindings'): if set, C-c variants are the old ones +;;; (`cperl-unwind-to-safe'): New function. +;;; (`cperl-fontify-syntaxically'): Use `cperl-unwind-to-safe' to start at reasonable position. + +;;;; After 3.15: +;;; (`cperl-forward-re'): Highlight the trailing / in s/foo// as string. +;;; Highlight the starting // in s//foo/ as function-name. + +;;;; After 3.16: +;;; (`cperl-find-pods-heres'): Highlight `gem' in s///gem as a keyword. + +;;;; After 4.0: +;;; (`cperl-find-pods-heres'): `qr' added +;;; (`cperl-electric-keyword'): Likewise +;;; (`cperl-electric-else'): Likewise +;;; (`cperl-to-comment-or-eol'): Likewise +;;; (`cperl-make-regexp-x'): Likewise +;;; (`cperl-init-faces'): Likewise, and `lock' (as overridable?). +;;; (`cperl-find-pods-heres'): Knows that split// is null-RE. +;;; Highlights separators in 3-parts expressions +;;; as labels. + +;;;; After 4.1: +;;; (`cperl-find-pods-heres'): <> was considered as a glob +;;; (`cperl-syntaxify-unwind'): New configuration variable +;;; (`cperl-fontify-m-as-s'): New configuration variable + +;;;; After 4.2: +;;; (`cperl-find-pods-heres'): of the last line being `=head1' fixed. + +;;; Handling of a long construct is still buggy if only the part of +;;; construct touches the updated region (we unwind to the start of +;;; long construct, but the end may have residual properties). + +;;; (`cperl-unwind-to-safe'): would not go to beginning of buffer. +;;; (`cperl-electric-pod'): check for after-expr was performed +;;; inside of POD too. + +;;;; After 4.3: +;;; (`cperl-backward-to-noncomment'): better treatment of PODs and HEREs. + +;;; Indent-line works good, but indent-region does not - at toplevel... +;;; (`cperl-unwind-to-safe'): Signature changed. +;;; (`x-color-defined-p'): was defmacro'ed with a tick. Remove another def. +;;; (`cperl-clobber-mode-lists'): New configuration variable. +;;; (`cperl-array-face'): One of definitions was garbled. + +;;;; After 4.4: +;;; (`cperl-not-bad-regexp'): Updated. +;;; (`cperl-make-regexp-x'): Misprint in a message. +;;; (`cperl-find-pods-heres'): $a-1 ? foo : bar; was a regexp. +;;; `<< (' was considered a start of POD. +;;; Init: `cperl-is-face' was busted. +;;; (`cperl-make-face'): New macros. +;;; (`cperl-force-face'): New macros. +;;; (`cperl-init-faces'): Corrected to use new macros; +;;; `if' for copying `reference-face' to +;;; `constant-face' was backward. +;;; (`font-lock-other-type-face'): Done via `defface' too. + ;;; Code: @@ -757,22 +820,33 @@ nil)) ;; Avoid warning (tmp definitions) (or (fboundp 'x-color-defined-p) - (defmacro 'x-color-defined-p (col) + (defmacro x-color-defined-p (col) (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) ;; XEmacs >= 19.12 ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col)))) ;; XEmacs 19.11 (t (` (x-valid-color-name-p (, col))))))) - (fset 'cperl-is-face + (defmacro cperl-is-face (arg) ; Takes quoted arg (cond ((fboundp 'find-face) - (symbol-function 'find-face)) - ((and (fboundp 'face-list) - (face-list)) - (function (lambda (face) - (member face (and (fboundp 'face-list) - (face-list)))))) + (` (find-face (, arg)))) + (;;(and (fboundp 'face-list) + ;; (face-list)) + (fboundp 'face-list) + (` (member (, arg) (and (fboundp 'face-list) + (face-list))))) (t - (function (lambda (face) (boundp face)))))))) + (` (boundp (, arg)))))) + (defmacro cperl-make-face (arg descr) ; Takes unquoted arg + (cond ((fboundp 'make-face) + (` (make-face (quote (, arg))))) + (t + (` (defconst (, arg) (quote (, arg)) (, descr)))))) + (defmacro cperl-force-face (arg descr) ; Takes unquoted arg + (` (progn + (or (cperl-is-face (quote (, arg))) + (cperl-make-face (, arg) (, descr))) + (or (boundp (quote (, arg))) ; We use unquoted variants too + (defconst (, arg) (quote (, arg)) (, descr)))))))) (require 'custom) (defun cperl-choose-color (&rest list) @@ -980,6 +1054,16 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space', :type '(repeat (list symbol string)) :group 'cperl) +(defcustom cperl-clobber-mode-lists + (not + (and + (boundp 'interpreter-mode-alist) + (assoc "miniperl" interpreter-mode-alist) + (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) + "*Whether to install us into `interpreter-' and `extension' mode lists." + :type 'boolean + :group 'cperl) + (defcustom cperl-info-on-command-no-prompt nil "*Not-nil (and non-null) means not to prompt on C-h f. The opposite behaviour is always available if prefixed with C-c. @@ -1021,6 +1105,11 @@ Font for POD headers." :type 'boolean :group 'cperl-faces) +(defcustom cperl-fontify-m-as-s t + "*Not-nil means highlight 1arg regular expressions operators same as 2arg." + :type 'boolean + :group 'cperl-faces) + (defcustom cperl-pod-here-scan t "*Not-nil means look for pod and here-docs sections during startup. You can always make lookup from menu or using \\[cperl-find-pods-heres]." @@ -1131,10 +1220,32 @@ Having it TRUE may be not completely debugged yet." :type '(choice (const message) boolean) :group 'cperl-speed) +(defcustom cperl-syntaxify-unwind + t + "*Non-nil means that CPerl unwinds to a start of along construction +when syntaxifying a chunk of buffer." + :type 'boolean + :group 'cperl-speed) + (if window-system (progn (defvar cperl-dark-background (cperl-choose-color "navy" "os2blue" "darkgreen")) + (defvar cperl-dark-foreground + (cperl-choose-color "orchid1" "orange")) + + (defface font-lock-other-type-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :italic t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :italic t :underline t :bold t)) + (((class color) (background light)) + (:foreground "chartreuse3")) + (((class color) (background dark)) + (:foreground (, cperl-dark-foreground))) + (t (:bold t :underline t)))) + "Font Lock mode face used to highlight array names." + :group 'cperl-faces) (defface cperl-array-face (` ((((class grayscale) (background light)) @@ -1358,6 +1469,9 @@ voice); to B if A; + n) Highlights (by user-choice) either 3-delimiters constructs + (such as tr/a/b/), or regular expressions and `y/tr'. + 5) The indentation engine was very smart, but most of tricks may be not needed anymore with the support for `syntax-table' property. Has progress indicator for indentation (with `imenu' loaded). @@ -1414,6 +1528,9 @@ B) Speed of editing operations. syntax-engine-helping scan, thus will make many more Perl constructs be wrongly recognized by CPerl, thus may lead to wrongly matched parentheses, wrong indentation, etc. + + One can unset `cperl-syntaxify-unwind'. This might speed up editing + of, say, long POD sections. ") @@ -1472,9 +1589,12 @@ B) Speed of editing operations. 'lazy-lock) "Text property which inhibits refontification.") -(defsubst cperl-put-do-not-fontify (from to) - (put-text-property (max (point-min) (1- from)) - to cperl-do-not-fontify t)) +(defsubst cperl-put-do-not-fontify (from to &optional post) + ;; If POST, do not do it with postponed fontification + (if (and post cperl-syntaxify-by-font-lock) + nil + (put-text-property (max (point-min) (1- from)) + to cperl-do-not-fontify t))) (defcustom cperl-mode-hook nil "Hook run by `cperl-mode'." @@ -1495,11 +1615,12 @@ B) Speed of editing operations. ;;; Probably it is too late to set these guys already, but it can help later: -(setq auto-mode-alist +(and cperl-clobber-mode-lists + (setq auto-mode-alist (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) -(and (boundp 'interpreter-mode-alist) - (setq interpreter-mode-alist (append interpreter-mode-alist - '(("miniperl" . perl-mode))))) + (and (boundp 'interpreter-mode-alist) + (setq interpreter-mode-alist (append interpreter-mode-alist + '(("miniperl" . perl-mode)))))) (if (fboundp 'eval-when-compile) (eval-when-compile (condition-case nil @@ -1563,14 +1684,8 @@ B) Speed of editing operations. (cperl-define-key "\177" 'cperl-electric-backspace) (cperl-define-key "\t" 'cperl-indent-command) ;; don't clobber the backspace binding: - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command [(control c) (control h) F]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control c) (control h) v]) (if (cperl-val 'cperl-clobber-lisp-bindings) (progn (cperl-define-key "\C-hf" @@ -1580,7 +1695,21 @@ B) Speed of editing operations. (cperl-define-key "\C-hv" ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help - [(control h) v]))) + [(control h) v]) + (cperl-define-key "\C-c\C-hf" + ;;(concat (char-to-string help-char) "f") ; does not work + (key-binding "\C-hf") + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + (key-binding "\C-hv") + [(control c) (control h) v])) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help + [(control c) (control h) v])) (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn @@ -2357,7 +2486,7 @@ to nil." (save-excursion (not (re-search-backward - "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (or @@ -2429,6 +2558,7 @@ to nil." (forward-char -1) (bolp)) (or + (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t) @@ -2489,7 +2619,7 @@ to nil." (save-excursion (not (re-search-backward - "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (looking-at "=cut") @@ -2846,7 +2976,7 @@ Return the amount the indentation changed by." (backward-sexp) ;; Need take into account `bless', `return', `tr',... (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax - (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) + (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) (progn (skip-chars-backward " \t\n\f") (and (memq (char-syntax (preceding-char)) '(?w ?_)) @@ -2911,7 +3041,8 @@ Returns nil if line starts inside a string, t if in a comment." (if parse-data (progn (setcar parse-data pre-indent-point) - (setcar (cdr parse-data) state))) + (setcar (cdr parse-data) state) + (setq old-indent (nth 2 parse-data)))) ;; (or parse-start (null symbol) ;; (setq parse-start (symbol-value symbol) ;; start-indent (nth 2 parse-start) @@ -2962,9 +3093,9 @@ Returns nil if line starts inside a string, t if in a comment." ;; in which case this line is the first argument decl. (skip-chars-forward " \t") (+ start-indent - (if (= (following-char) ?{) cperl-continued-brace-offset 0) + (if (= char-after ?{) cperl-continued-brace-offset 0) (progn - (cperl-backward-to-noncomment (or (car parse-data) (point-min))) + (cperl-backward-to-noncomment (or old-indent (point-min))) ;; Look at previous line that's at column 0 ;; to determine whether we are in top-level decls ;; or function's arg decls. Set basic-indent accordingly. @@ -2980,7 +3111,12 @@ Returns nil if line starts inside a string, t if in a comment." (forward-sexp -1) (skip-chars-backward " \t") (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) - 0 + (progn + (if (and parse-data + (not (eq char-after ?\C-j))) + (setcdr (cdr parse-data) + (list pre-indent-point))) + 0) cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) ;; line is expression, not statement: @@ -3331,7 +3467,7 @@ Returns true if comment is found." "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" lim 'move) (setq stop-in t))) - ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") + ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") (or (re-search-forward "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" lim 'move) @@ -3371,9 +3507,10 @@ Returns true if comment is found." (while (re-search-forward "^\\s(" e 'to-end) (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) -(defun cperl-commentify (bb e string) +(defun cperl-commentify (bb e string &optional noface) (if cperl-use-syntax-table-text-property - (progn + (if (eq noface 'n) ; Only immediate + nil ;; We suppose that e is _after_ the end of construction, as after eol. (setq string (if string cperl-st-sfence cperl-st-cfence)) (cperl-modify-syntax-type bb string) @@ -3381,7 +3518,16 @@ Returns true if comment is found." (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) (put-text-property (1+ bb) (1- e) 'syntax-table cperl-string-syntax-table)) - (cperl-protect-defun-start bb e)))) + (cperl-protect-defun-start bb e)) + ;; Fontify + (or noface + (not cperl-pod-here-fontify) + (put-text-property bb e 'face (if string 'font-lock-string-face + 'font-lock-comment-face))))) +(defvar cperl-starters '(( ?\( . ?\) ) + ( ?\[ . ?\] ) + ( ?\{ . ?\} ) + ( ?\< . ?\> ))) (defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument &optional ostart oend) @@ -3392,12 +3538,7 @@ Returns true if comment is found." ;; ender means matching-char matcher. (setq b (point) starter (char-after b) - ;; ender: - ender (cdr (assoc starter '(( ?\( . ?\) ) - ( ?\[ . ?\] ) - ( ?\{ . ?\} ) - ( ?\< . ?\> ) - )))) + ender (cdr (assoc starter cperl-starters))) ;; What if starter == ?\\ ???? (if set-st (if (car st-l) @@ -3419,6 +3560,8 @@ Returns true if comment is found." (modify-syntax-entry ender (concat ")" (list starter)) st))) (condition-case bb (progn + ;; We use `$' syntax class to find matching stuff, but $$ + ;; is recognized the same as $, so we need to check this manually. (if (and (eq starter (char-after (cperl-1+ b))) (not ender)) ;; $ has TeXish matching rules, so $$ equiv $... @@ -3434,6 +3577,7 @@ Returns true if comment is found." (forward-char -2) (= 0 (% (skip-chars-backward "\\\\") 2))) (forward-char -1))) + ;; Now we are after the first part. (and is-2arg ; Have trailing part (not ender) (eq (following-char) starter) ; Empty trailing part @@ -3456,15 +3600,14 @@ Returns true if comment is found." (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) (if ender (modify-syntax-entry ender "." st)) (setq set-st nil) - (setq - ender - (cperl-forward-re lim end nil t st-l err-l argument starter ender) - ender (nth 2 ender))))) + (setq ender (cperl-forward-re lim end nil t st-l err-l + argument starter ender) + ender (nth 2 ender))))) (error (goto-char lim) (setq set-st nil) (or end (message - "End of `%s%s%c ... %c' string not found: %s" + "End of `%s%s%c ... %c' string/RE not found: %s" argument (if ostart (format "%c ... %c" ostart (or oend ostart)) "") starter (or ender starter) bb) @@ -3473,11 +3616,49 @@ Returns true if comment is found." (progn (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) (if ender (modify-syntax-entry ender "." st)))) + ;; i: have 2 args, after end of the first arg + ;; i2: start of the second arg, if any (before delim iff `ender'). + ;; ender: the last arg bounded by parens-like chars, the second one of them + ;; starter: the starting delimiter of the first arg + ;; go-forward: has 2 args, and the second part is empth (list i i2 ender starter go-forward))) (defvar font-lock-string-face) -(defvar font-lock-reference-face) +;;(defvar font-lock-reference-face) (defvar font-lock-constant-face) +(defsubst cperl-postpone-fontification (b e type val &optional now) + ;; Do after syntactic fontification? + (if cperl-syntaxify-by-font-lock + (or now (put-text-property b e 'cperl-postpone (cons type val))) + (put-text-property b e type val))) + +;;; Here is how the global structures (those which cannot be +;;; recognized locally) are marked: +;; a) PODs: +;; Start-to-end is marked `in-pod' ==> t +;; Each non-literal part is marked `syntax-type' ==> `pod' +;; Each literal part is marked `syntax-type' ==> `in-pod' +;; b) HEREs: +;; Start-to-end is marked `here-doc-group' ==> t +;; The body is marked `syntax-type' ==> `here-doc' +;; The delimiter is marked `syntax-type' ==> `here-doc-delim' +;; a) FORMATs: +;; After-initial-line--to-end is marked `syntax-type' ==> `format' + +(defun cperl-unwind-to-safe (before) + (let ((pos (point))) + (while (and pos (get-text-property pos 'syntax-type)) + (setq pos (previous-single-property-change pos 'syntax-type)) + (if pos + (if before + (progn + (goto-char (cperl-1- pos)) + (beginning-of-line) + (setq pos (point))) + (goto-char (setq pos (cperl-1- pos)))) + ;; Up to the start + (goto-char (point-min)))))) + (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -3505,6 +3686,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (font-lock-string-face (if (boundp 'font-lock-string-face) font-lock-string-face 'font-lock-string-face)) + (font-lock-constant-face (if (boundp 'font-lock-constant-face) + font-lock-constant-face + 'font-lock-constant-face)) + (font-lock-function-name-face + (if (boundp 'font-lock-function-name-face) + font-lock-function-name-face + 'font-lock-function-name-face)) + (font-lock-other-type-face + (if (boundp 'font-lock-other-type-face) + font-lock-other-type-face + 'font-lock-other-type-face)) (stop-point (if ignore-max (point-max) max)) @@ -3533,7 +3725,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (concat "\\|" ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" "\\|" ;; 1+6+2+1=10 extra () before this: "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> @@ -3562,7 +3754,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', head-face cperl-pod-head-face here-face cperl-here-face)) (remove-text-properties min max - '(syntax-type t in-pod t syntax-table t)) + '(syntax-type t in-pod t syntax-table t + cperl-postpone t)) ;; Need to remove face as well... (goto-char min) (and (eq system-type 'emx) @@ -3586,52 +3779,65 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq b (point) bb b - tb (match-beginning 0)) + tb (match-beginning 0) + b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random (or (re-search-forward "\n\n=cut\\>" stop-point 'toend) (progn (message "End of a POD section not marked by =cut") + (setq b1 t) (or (car err-l) (setcar err-l b)))) (beginning-of-line 2) ; An empty line after =cut is not POD! (setq e (point)) - (and (> e max) - (progn - (remove-text-properties - max e '(syntax-type t in-pod t syntax-table t)) - (setq tmpend tb))) - (put-text-property b e 'in-pod t) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) - ;; We start 'pod 1 char earlier to include the preceding line - (beginning-of-line) - (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point)) - (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) - (re-search-forward "\n\n[^ \t\f\n]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e) - (if cperl-pod-here-fontify - (progn (put-text-property (point) e 'face face) - (goto-char bb) - (if (looking-at - "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - (put-text-property - (match-beginning 1) (match-end 1) - 'face head-face)) - (while (re-search-forward - ;; One paragraph - "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) - (put-text-property - (match-beginning 1) (match-end 1) - 'face head-face)))) - (cperl-commentify bb e nil) - (goto-char e) - (or (eq e (point-max)) - (forward-char -1)))) ; Prepare for immediate pod start. + (if (and b1 (eobp)) + ;; Unrecoverable error + nil + (and (> e max) + (progn + (remove-text-properties + max e '(syntax-type t in-pod t syntax-table t + 'cperl-postpone t)) + (setq tmpend tb))) + (put-text-property b e 'in-pod t) + (put-text-property b e 'syntax-type 'in-pod) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + ;; We start 'pod 1 char earlier to include the preceding line + (beginning-of-line) + (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) + (cperl-put-do-not-fontify b (point) t) + ;; mark the non-literal parts as PODs + (if cperl-pod-here-fontify + (cperl-postpone-fontification b (point) 'face face t)) + (re-search-forward "\n\n[^ \t\f\n]" e 'toend) + (beginning-of-line) + (setq b (point))) + (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) + (cperl-put-do-not-fontify (point) e t) + (if cperl-pod-here-fontify + (progn + ;; mark the non-literal parts as PODs + (cperl-postpone-fontification (point) e 'face face t) + (goto-char bb) + (if (looking-at + "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)) + (while (re-search-forward + ;; One paragraph + "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + e 'toend) + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)))) + (cperl-commentify bb e nil) + (goto-char e) + (or (eq e (point-max)) + (forward-char -1))))) ; Prepare for immediate pod start. ;; Here document ;; We do only one here-per-line ;; ;; One extra () before this: @@ -3661,7 +3867,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (match-beginning 5) (not (match-beginning 6)) ; Empty (looking-at - "[ \t]*[=0-9$@%&]")))) + "[ \t]*[=0-9$@%&(]")))) (if c ; Not here-doc nil ; Skip it. (if (match-beginning 5) ;4 + 1 @@ -3672,8 +3878,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq tag (buffer-substring b1 e1) qtag (regexp-quote tag)) (cond (cperl-pod-here-fontify - (put-text-property b1 e1 'face font-lock-constant-face) - (cperl-put-do-not-fontify b1 e1))) + ;; Highlight the starting delimiter + (cperl-postpone-fontification b1 e1 'face font-lock-constant-face) + (cperl-put-do-not-fontify b1 e1 t))) (forward-line) (setq b (point)) ;; We do not search to max, since we may be called from @@ -3682,10 +3889,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', stop-point 'toend) (if cperl-pod-here-fontify (progn - (put-text-property (match-beginning 0) (match-end 0) + ;; Highlight the ending delimiter + (cperl-postpone-fontification (match-beginning 0) (match-end 0) 'face font-lock-constant-face) - (cperl-put-do-not-fontify b (match-end 0)) - (put-text-property b (match-beginning 0) + (cperl-put-do-not-fontify b (match-end 0) t) + ;; Highlight the HERE-DOC + (cperl-postpone-fontification b (match-beginning 0) 'face here-face))) (setq e1 (cperl-1+ (match-end 0))) (put-text-property b (match-beginning 0) @@ -3695,7 +3904,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (put-text-property b e1 'here-doc-group t) (cperl-commentify b e1 nil) - (cperl-put-do-not-fontify b (match-end 0)) + (cperl-put-do-not-fontify b (match-end 0) t) (if (> e1 max) (setq tmpend tb))) (t (message "End of here-document `%s' not found." tag) @@ -3726,20 +3935,22 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq b1 (point)) (setq argument (looking-at "^[^\n]*[@^]")) (end-of-line) - (put-text-property b1 (point) + ;; Highlight the format line + (cperl-postpone-fontification b1 (point) 'face font-lock-string-face) (cperl-commentify b1 (point) nil) - (cperl-put-do-not-fontify b1 (point))))) + (cperl-put-do-not-fontify b1 (point) t)))) ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random (re-search-forward "^[.;]$" stop-point 'toend)) (beginning-of-line) - (if (looking-at "^[.;]$") + (if (looking-at "^\\.$") ; ";" is not supported yet (progn - (put-text-property (point) (+ (point) 2) + ;; Highlight the ending delimiter + (cperl-postpone-fontification (point) (+ (point) 2) 'face font-lock-string-face) (cperl-commentify (point) (+ (point) 2) nil) - (cperl-put-do-not-fontify (point) (+ (point) 2))) + (cperl-put-do-not-fontify (point) (+ (point) 2) t)) (message "End of format `%s' not found." name) (or (car err-l) (setcar err-l b))) (forward-line) @@ -3749,7 +3960,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; Regexp: ((or (match-beginning 10) (match-beginning 11)) ;; 1+6+2=9 extra () before this: - ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ;; "\\|" ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> (setq b1 (if (match-beginning 10) 10 11) @@ -3759,15 +3970,19 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', i b c (char-after (match-beginning b1)) bb (char-after (1- (match-beginning b1))) ; tmp holder - bb (and ; user variables/whatever - (match-beginning 10) - (or - (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y - (and (eq bb ?-) (eq c ?s)) ; -s file test - (and (eq bb ?\&) ; &&m/blah/ - (not (eq (char-after - (- (match-beginning b1) 2)) - ?\&))))) + bb (if (eq b1 10) ; user variables/whatever + (or + (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y + (and (eq bb ?-) (eq c ?s)) ; -s file test + (and (eq bb ?\&) ; &&m/blah/ + (not (eq (char-after + (- (match-beginning b1) 2)) + ?\&)))) + ;; <file> or <$file> + (and (eq c ?\<) + (save-match-data + (looking-at + "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>")))) tb (match-beginning 0)) (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) @@ -3793,7 +4008,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; functions/builtins which expect an argument, but ... (if (eq (preceding-char) ?-) ;; -d ?foo? is a RE - (looking-at "\\w\\>") + (looking-at "[a-zA-Z]\\>") (looking-at "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))) (and (eq (preceding-char) ?.) @@ -3806,11 +4021,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not (bobp)) (progn (forward-char -1) - (looking-at "\\s|")))) - ;; <file> or <$file> - (not - (and (eq c ?\<) - (looking-at "\\s *\\$?[_a-zA-Z:][_a-zA-Z0-9:]*\\s *>")))))) + (looking-at "\\s|"))))))) b (1- b)) ;; s y tr m ;; Check for $a->y @@ -3831,45 +4042,92 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; 2 or 3 later if some special quoting is needed. ;; e1 means matching-char matcher. (setq b (point) + ;; has 2 args + i2 (string-match "^\\([sy]\\|tr\\)$" argument) ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random i (cperl-forward-re stop-point end - (string-match "^\\([sy]\\|tr\\)$" argument) + i2 t st-l err-l argument) - i2 (nth 1 i) ; start of the second part - e1 (nth 2 i) ; ender, true if matching second part + ;; Note that if `go', then it is considered as 1-arg + b1 (nth 1 i) ; start of the second part + tag (nth 2 i) ; ender-char, true if second part + ; is with matching chars [] go (nth 4 i) ; There is a 1-char part after the end i (car i) ; intermediate point - tail (if (and i (not e1)) (1- (point))) - e nil) ; need to preserve backslashitis + e1 (point) ; end + ;; Before end of the second part if non-matching: /// + tail (if (and i (not tag)) + (1- e1)) + e (if i i e1) ; end of the first part + qtag nil) ; need to preserve backslashitis ;; Commenting \\ is dangerous, what about ( ? (and i tail (eq (char-after i) ?\\) - (setq e t)) + (setq qtag t)) (if (null i) + ;; Considered as 1arg form (progn (cperl-commentify b (point) t) - (if go (forward-char 1))) + (and go + (setq e1 (1+ e1)) + (forward-char 1))) (cperl-commentify b i t) (if (looking-at "\\sw*e") ; s///e (progn (and ;; silent: - (cperl-find-pods-heres i2 (1- (point)) t end) + (cperl-find-pods-heres b1 (1- (point)) t end) ;; Error (goto-char (1+ max))) - (if (and e1 (eq (preceding-char) ?\>)) + (if (and tag (eq (preceding-char) ?\>)) (progn (cperl-modify-syntax-type (1- (point)) cperl-st-ket) (cperl-modify-syntax-type i cperl-st-bra)))) - (cperl-commentify i2 (point) t) - (if e + (cperl-commentify b1 (point) t) + (if qtag (cperl-modify-syntax-type (1+ i) cperl-st-punct)) (setq tail nil))) + ;; Now: tail: if the second part is non-matching without ///e (if (eq (char-syntax (following-char)) ?w) (progn (forward-word 1) ; skip modifiers s///s - (if tail (cperl-commentify tail (point) t)))) + (if tail (cperl-commentify tail (point) t)) + (cperl-postpone-fontification + e1 (point) 'face font-lock-other-type-face))) + ;; Check whether it is m// which means "previous match" + ;; and highlight differently + (if (and (eq e (+ 2 b)) + (string-match "^\\([sm]?\\|qr\\)$" argument) + ;; <> is already filtered out + ;; split // *is* using zero-pattern + (save-excursion + (condition-case nil + (progn + (goto-char tb) + (forward-sexp -1) + (not (looking-at "split\\>"))) + (error t)))) + (cperl-postpone-fontification + b e 'face font-lock-function-name-face) + (if (or i2 ; Has 2 args + (and cperl-fontify-m-as-s + (or + (string-match "^\\(m\\|qr\\)$" argument) + (and (eq 0 (length argument)) + (not (eq ?\< (char-after b))))))) + (progn + (cperl-postpone-fontification + b (1+ b) 'face font-lock-constant-face) + (cperl-postpone-fontification + (1- e) e 'face font-lock-constant-face)))) + (if i2 + (progn + (cperl-postpone-fontification + (1- e1) e1 'face font-lock-constant-face) + (if (assoc (char-after b) cperl-starters) + (cperl-postpone-fontification + b1 (1+ b1) 'face font-lock-constant-face)))) (if (> (point) max) (setq tmpend tb)))) ((match-beginning 13) ; sub with prototypes @@ -3947,18 +4205,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (defun cperl-backward-to-noncomment (lim) ;; Stops at lim or after non-whitespace that is not in comment - (let (stop p) + (let (stop p pr) (while (and (not stop) (> (point) (or lim 1))) (skip-chars-backward " \t\n\f" lim) (setq p (point)) (beginning-of-line) - (if (or (looking-at "^[ \t]*\\(#\\|$\\)") - (progn (cperl-to-comment-or-eol) (bolp))) - nil ; Only comment, skip - ;; Else - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t))))) + (if (memq (setq pr (get-text-property (point) 'syntax-type)) + '(pod here-doc here-doc-delim)) + (cperl-unwind-to-safe nil) + (if (or (looking-at "^[ \t]*\\(#\\|$\\)") + (progn (cperl-to-comment-or-eol) (bolp))) + nil ; Only comment, skip + ;; Else + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t)))))) (defun cperl-after-block-p (lim) ;; We suppose that the preceding char is }. @@ -4259,7 +4520,7 @@ conditional/loop constructs." (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) (let (st comm old-comm-indent new-comm-indent p pp i (indent-info (if cperl-emacs-can-parse - '(nil nil) + (list nil nil) ; Cannot use '(), since will modify nil)) after-change-functions ; Speed it up! (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) @@ -4659,7 +4920,7 @@ indentation and initial hashes. Behaves usually outside of comment." (setq font-lock-constant-face 'font-lock-constant-face))) (defun cperl-init-faces () - (condition-case nil + (condition-case errs (progn (require 'font-lock) (and (fboundp 'font-lock-fontify-anchored-keywords) @@ -4704,7 +4965,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "getservbyport" "getservent" "getsockname" ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" - ;; "link" "listen" "localtime" "log" "lstat" "lt" + ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt" ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" ;; "quotemeta" "rand" "read" "readdir" "readline" @@ -4736,7 +4997,7 @@ indentation and initial hashes. Behaves usually outside of comment." "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" - "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" + "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" @@ -4772,7 +5033,7 @@ indentation and initial hashes. Behaves usually outside of comment." "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" + "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually @@ -4852,10 +5113,14 @@ indentation and initial hashes. Behaves usually outside of comment." ;; (if (cperl-slash-is-regexp) ;; font-lock-function-name-face 'default) nil t)) ))) - (setq perl-font-lock-keywords-1 t-font-lock-keywords + (setq perl-font-lock-keywords-1 + (if cperl-syntaxify-by-font-lock + (cons 'cperl-fontify-update + t-font-lock-keywords) + t-font-lock-keywords) perl-font-lock-keywords perl-font-lock-keywords-1 perl-font-lock-keywords-2 (append - t-font-lock-keywords + perl-font-lock-keywords-1 t-font-lock-keywords-1))) (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) @@ -4935,69 +5200,89 @@ indentation and initial hashes. Behaves usually outside of comment." t t nil)))) + ;; Do it the dull way, without choose-color (defvar cperl-guessed-background nil "Display characteristics as guessed by cperl.") - (or (fboundp 'x-color-defined-p) - (defalias 'x-color-defined-p - (cond ((fboundp 'color-defined-p) 'color-defined-p) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; XEmacs 19.11 - (t 'x-valid-color-name-p)))) - (defvar font-lock-constant-face 'font-lock-constant-face) - (defvar font-lock-variable-name-face 'font-lock-variable-name-face) - (or (boundp 'font-lock-type-face) - (defconst font-lock-type-face - 'font-lock-type-face - "Face to use for data types.")) - (or (boundp 'font-lock-other-type-face) - (defconst font-lock-other-type-face - 'font-lock-other-type-face - "Face to use for data types from another group.")) - (if (not cperl-xemacs-p) nil - (or (boundp 'font-lock-comment-face) - (defconst font-lock-comment-face - 'font-lock-comment-face - "Face to use for comments.")) - (or (boundp 'font-lock-keyword-face) - (defconst font-lock-keyword-face - 'font-lock-keyword-face - "Face to use for keywords.")) - (or (boundp 'font-lock-function-name-face) - (defconst font-lock-function-name-face - 'font-lock-function-name-face - "Face to use for function names."))) +;; (or (fboundp 'x-color-defined-p) +;; (defalias 'x-color-defined-p +;; (cond ((fboundp 'color-defined-p) 'color-defined-p) +;; ;; XEmacs >= 19.12 +;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) +;; ;; XEmacs 19.11 +;; (t 'x-valid-color-name-p)))) + (cperl-force-face font-lock-constant-face + "Face for constant and label names") + (cperl-force-face font-lock-variable-name-face + "Face for variable names") + (cperl-force-face font-lock-type-face + "Face for data types") + (cperl-force-face font-lock-other-type-face + "Face for data types from another group") + (cperl-force-face font-lock-comment-face + "Face for comments") + (cperl-force-face font-lock-keyword-face + "Face for keywords") + (cperl-force-face font-lock-function-name-face + "Face for function names") + (cperl-force-face cperl-hash-face + "Face for hashes") + (cperl-force-face cperl-array-face + "Face for arrays") + ;;(defvar font-lock-constant-face 'font-lock-constant-face) + ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) + ;;(or (boundp 'font-lock-type-face) + ;; (defconst font-lock-type-face + ;; 'font-lock-type-face + ;; "Face to use for data types.")) + ;;(or (boundp 'font-lock-other-type-face) + ;; (defconst font-lock-other-type-face + ;; 'font-lock-other-type-face + ;; "Face to use for data types from another group.")) + ;;(if (not cperl-xemacs-p) nil + ;; (or (boundp 'font-lock-comment-face) + ;; (defconst font-lock-comment-face + ;; 'font-lock-comment-face + ;; "Face to use for comments.")) + ;; (or (boundp 'font-lock-keyword-face) + ;; (defconst font-lock-keyword-face + ;; 'font-lock-keyword-face + ;; "Face to use for keywords.")) + ;; (or (boundp 'font-lock-function-name-face) + ;; (defconst font-lock-function-name-face + ;; 'font-lock-function-name-face + ;; "Face to use for function names."))) (if (and (not (cperl-is-face 'cperl-array-face)) (cperl-is-face 'font-lock-emphasized-face)) - (copy-face 'font-lock-emphasized-face 'cperl-emphasized-face)) + (copy-face 'font-lock-emphasized-face 'cperl-array-face)) (if (and (not (cperl-is-face 'cperl-hash-face)) (cperl-is-face 'font-lock-other-emphasized-face)) (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face)) - (or (boundp 'cperl-hash-face) - (defconst cperl-hash-face - 'cperl-hash-face - "Face to use for another type of emphasizing.")) - (or (boundp 'cperl-emphasized-face) - (defconst cperl-emphasized-face - 'cperl-emphasized-face - "Face to use for emphasizing.")) + ;;(or (boundp 'cperl-hash-face) + ;; (defconst cperl-hash-face + ;; 'cperl-hash-face + ;; "Face to use for hashes.")) + ;;(or (boundp 'cperl-array-face) + ;; (defconst cperl-array-face + ;; 'cperl-array-face + ;; "Face to use for arrays.")) ;; Here we try to guess background (let ((background (if (boundp 'font-lock-background-mode) font-lock-background-mode 'light)) (face-list (and (fboundp 'face-list) (face-list))) - cperl-is-face) - (fset 'cperl-is-face - (cond ((fboundp 'find-face) - (symbol-function 'find-face)) - (face-list - (function (lambda (face) (member face face-list)))) - (t - (function (lambda (face) (boundp face)))))) + ;; cperl-is-face + ) +;;;; (fset 'cperl-is-face +;;;; (cond ((fboundp 'find-face) +;;;; (symbol-function 'find-face)) +;;;; (face-list +;;;; (function (lambda (face) (member face face-list)))) +;;;; (t +;;;; (function (lambda (face) (boundp face)))))) (defvar cperl-guessed-background (if (and (boundp 'font-lock-display-type) (eq font-lock-display-type 'grayscale)) @@ -5007,7 +5292,6 @@ indentation and initial hashes. Behaves usually outside of comment." (if (and (not (cperl-is-face 'font-lock-constant-face)) (cperl-is-face 'font-lock-reference-face)) - nil (copy-face 'font-lock-reference-face 'font-lock-constant-face)) (if (cperl-is-face 'font-lock-type-face) nil (copy-face 'default 'font-lock-type-face) @@ -5077,7 +5361,7 @@ indentation and initial hashes. Behaves usually outside of comment." (if (cperl-is-face 'font-lock-constant-face) nil (copy-face 'italic 'font-lock-constant-face)))) (setq cperl-faces-init t)) - (error nil))) + (error (message "cperl-init-faces (ignored): %s" errs)))) (defun cperl-ps-print-init () @@ -5969,14 +6253,17 @@ One may build such TAGS files from CPerl mode menu." "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h> - "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file + "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN "-[0-9]" ; -5 "\\+\\+" ; ++var "--" ; --var ".->" ; a->b "->" ; a SPACE ->b "\\[-" ; a[-1] + "\\\\[&$@*\\\\]" ; \&func "^=" ; =head + "\\$." ; $| + "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' "||" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> @@ -6247,6 +6534,7 @@ $^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. +$^M A buffer for emergency memory allocation when running out of memory. $^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. @@ -6785,11 +7073,11 @@ prototype \&SUB Returns prototype of the function given a reference. ;; Returns position of the start (save-excursion (or cperl-use-syntax-table-text-property - (error "I need to have regex marked!")) + (error "I need to have a regexp marked!")) ;; Find the start (if (looking-at "\\s|") nil ; good already - (if (looking-at "[smy]\\s|") + (if (looking-at "\\([smy]\\|qr\\)\\s|") (forward-char 1) (re-search-backward "\\s|"))) ; Assume it is scanned already. ;;(forward-char 1) @@ -7100,6 +7388,8 @@ We suppose that the regexp is scanned already." (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) + (and cperl-syntaxify-unwind + (cperl-unwind-to-safe t)) (let ((start (point)) (dbg (point))) (or cperl-syntax-done-to (setq cperl-syntax-done-to (point-min))) @@ -7125,6 +7415,15 @@ We suppose that the regexp is scanned already." (car cperl-syntax-state))) ; For debugging nil)) ; Do not iterate +(defun cperl-fontify-update (end) + (let ((pos (point)) prop posend) + (while (< pos end) + (setq prop (get-text-property pos 'cperl-postpone)) + (setq posend (next-single-property-change pos 'cperl-postpone nil end)) + (and prop (put-text-property pos posend (car prop) (cdr prop))) + (setq pos posend))) + nil) ; Do not iterate + (defun cperl-update-syntaxification (from to) (if (and cperl-use-syntax-table-text-property cperl-syntaxify-by-font-lock @@ -841,7 +841,6 @@ #define push_return Perl_push_return #define push_scope Perl_push_scope #define q Perl_q -#define rcsid Perl_rcsid #define reall_srchlen Perl_reall_srchlen #define ref Perl_ref #define refkids Perl_refkids diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index 60b93a5b23..0c5a58dc54 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -887,7 +887,7 @@ C<main_root> and C<curpad> are omitted. =back -=head EXAMPLES +=head1 EXAMPLES perl -MO=Bytecode,-O6,-o,foo.plc foo.pl diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 6add52fe0f..d8012eec5b 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -5,7 +5,7 @@ static SV *freezer; static SV *toaster; -static I32 num_q _((char *s)); +static I32 num_q _((char *s, STRLEN slen)); static I32 esc_q _((char *dest, char *src, STRLEN slen)); static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n)); static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval, @@ -42,14 +42,15 @@ TOP: /* count the number of "'"s and "\"s in string */ static I32 -num_q(register char *s) +num_q(register char *s, register STRLEN slen) { register I32 ret = 0; - - while (*s) { + + while (slen > 0) { if (*s == '\'' || *s == '\\') ++ret; ++s; + --slen; } return ret; } @@ -380,7 +381,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, hval = hv_iterval((HV*)ival, entry); if (quotekeys || needs_quote(key)) { - nticks = num_q(key); + nticks = num_q(key, klen); New(0, nkey, klen+nticks+3, char); nkey[0] = '\''; if (nticks) diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index a8a7cf73fe..f4d50206b5 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -53,6 +53,9 @@ sub get_files { } elsif ($Config{vms_cc_type} eq 'gcc') { $file{'gnu_cc_include:[000000]errno.h'} = 1; } + } elsif ($^O eq 'os390') { + # OS/390 C compiler doesn't generate #file or #line directives + $file{'/usr/include/errno.h'} = 1; } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -104,7 +107,7 @@ sub write_errno_pm { $cpp =~ s/sys\$input//i; open(CPPO,"$cpp errno.c |") or die "Cannot exec $Config{cppstdin}"; - } elsif($^O eq 'next') { + } elsif(!$Config{'cpprun'} or $^O eq 'next') { # NeXT will do syntax checking unless it is reading from stdin my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; open(CPPO,"$cpp < errno.c |") diff --git a/ext/IPC/SysV/SysV.xs b/ext/IPC/SysV/SysV.xs index 3503ad92b1..0fbf783347 100644 --- a/ext/IPC/SysV/SysV.xs +++ b/ext/IPC/SysV/SysV.xs @@ -15,7 +15,7 @@ #include <sys/sem.h> #endif #ifdef HAS_SHM -#ifdef PERL_SCO5 +#if defined(PERL_SCO5) || defined(PERL_ISC) #include <sys/sysmacros.h> #endif #include <sys/shm.h> @@ -41,6 +41,7 @@ pack(obj) SV * obj PPCODE: { +#ifdef HAS_MSG SV *sv; struct msqid_ds ds; AV *list = (AV*)SvRV(obj); @@ -50,6 +51,9 @@ PPCODE: sv = *av_fetch(list,6,TRUE); ds.msg_qbytes = SvIV(sv); ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds))); XSRETURN(1); +#else + croak("System V msgxxx is not implemented on this machine"); +#endif } void @@ -58,6 +62,7 @@ unpack(obj,buf) SV * buf PPCODE: { +#ifdef HAS_MSG STRLEN len; SV **sv_ptr; struct msqid_ds *ds = (struct msqid_ds *)SvPV(buf,len); @@ -92,6 +97,9 @@ PPCODE: sv_ptr = av_fetch(list,11,TRUE); sv_setiv(*sv_ptr, ds->msg_ctime); XSRETURN(1); +#else + croak("System V msgxxx is not implemented on this machine"); +#endif } MODULE=IPC::SysV PACKAGE=IPC::Semaphore::stat @@ -102,6 +110,7 @@ unpack(obj,ds) SV * ds PPCODE: { +#ifdef HAS_SEM STRLEN len; AV *list = (AV*)SvRV(obj); struct semid_ds *data = (struct semid_ds *)SvPV(ds,len); @@ -122,6 +131,9 @@ PPCODE: sv_setiv(*av_fetch(list,6,TRUE), data[0].sem_otime); sv_setiv(*av_fetch(list,7,TRUE), data[0].sem_nsems); XSRETURN(1); +#else + croak("System V semxxx is not implemented on this machine"); +#endif } void @@ -129,6 +141,7 @@ pack(obj) SV * obj PPCODE: { +#ifdef HAS_SEM SV **sv_ptr; SV *sv; struct semid_ds ds; @@ -154,6 +167,9 @@ PPCODE: ds.sem_nsems = SvIV(*sv_ptr); ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds))); XSRETURN(1); +#else + croak("System V semxxx is not implemented on this machine"); +#endif } MODULE=IPC::SysV PACKAGE=IPC::SysV diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 32010d62e0..5d3ef5cb50 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -68,7 +68,7 @@ $VERSION = "1.02" ; _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)], + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME NULL localeconv setlocale)], diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 59b688e7a2..6958c00c47 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -822,6 +822,8 @@ constant(char *name, int arg) #else goto not_there; #endif + break; + case 'L': if (strEQ(name, "ELOOP")) #ifdef ELOOP return ELOOP; @@ -2954,7 +2956,6 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); - SET_NUMERIC_LOCAL(); if (lcbuf = localeconv()) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) diff --git a/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index 6b41f88471..a9a805a4aa 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -7,10 +7,6 @@ * page-level routines */ -#ifndef lint -static char rcsid[] = "$Id: pair.c,v 1.10 90/12/13 13:00:35 oz Exp $"; -#endif - #include "config.h" #include "EXTERN.h" #include "sdbm.h" diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index 7bf9d3a97b..637fbe98a1 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -7,10 +7,6 @@ * core routines */ -#ifndef lint -static char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $"; -#endif - #include "INTERN.h" #include "config.h" #include "sdbm.h" diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 665956577d..48f8aa03fc 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -23,7 +23,7 @@ static void remove_thread(struct perl_thread *t) { #ifdef USE_THREADS - DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), "%p: remove_thread %p\n", thr, t))); MUTEX_LOCK(&PL_threads_mutex); MUTEX_DESTROY(&t->mutex); @@ -48,7 +48,7 @@ threadstart(void *arg) AV *av; int i; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); thr = (Thread) arg; savemark = TOPMARK; @@ -67,7 +67,7 @@ threadstart(void *arg) myop.op_flags |= OPf_KNOW; myop.op_flags |= OPf_WANT_LIST; PL_op = pp_entersub(ARGS); - DEBUG_L(if (!PL_op) + DEBUG_S(if (!PL_op) PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n")); /* * When this thread is next scheduled, we start in the right @@ -88,7 +88,7 @@ threadstart(void *arg) AV *av = newAV(); int i, ret; dJMPENV; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n", thr)); /* Don't call *anything* requiring dTHR until after SET_THR() */ @@ -110,7 +110,7 @@ threadstart(void *arg) SET_THR(thr); /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); sv = POPs; @@ -125,10 +125,10 @@ threadstart(void *arg) MUTEX_UNLOCK(&thr->mutex); av_store(av, 0, &PL_sv_no); av_store(av, 1, newSVsv(thr->errsv)); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n", thr, SvPV(thr->errsv, PL_na))); } else { - DEBUG_L(STMT_START { + DEBUG_S(STMT_START { for (i = 1; i <= retval; i++) { PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n", thr, i, SvPEEK(SP[i - 1])); @@ -177,28 +177,28 @@ threadstart(void *arg) /*SvREFCNT_dec(PL_defoutgv);*/ MUTEX_LOCK(&thr->mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: threadstart finishing: state is %u\n", thr, ThrSTATE(thr))); switch (ThrSTATE(thr)) { case THRf_R_JOINABLE: ThrSETSTATE(thr, THRf_ZOMBIE); MUTEX_UNLOCK(&thr->mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: R_JOINABLE thread finished\n", thr)); break; case THRf_R_JOINED: ThrSETSTATE(thr, THRf_DEAD); MUTEX_UNLOCK(&thr->mutex); remove_thread(thr); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: R_JOINED thread finished\n", thr)); break; case THRf_R_DETACHED: ThrSETSTATE(thr, THRf_DEAD); MUTEX_UNLOCK(&thr->mutex); SvREFCNT_dec(av); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: DETACHED thread finished\n", thr)); remove_thread(thr); /* This might trigger main thread to finish */ break; @@ -234,7 +234,7 @@ newthread (SV *startsv, AV *initargs, char *classname) savethread = thr; thr = new_struct_thread(thr); SPAGAIN; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: newthread (%p), tid is %u, preparing stack\n", savethread, thr, thr->tid)); /* The following pushes the arg list and startsv onto the *new* stack */ @@ -283,7 +283,7 @@ newthread (SV *startsv, AV *initargs, char *classname) MUTEX_UNLOCK(&thr->mutex); #endif if (err) { - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: create of %p failed %d\n", savethread, thr, err)); /* Thread creation failed--clean up */ @@ -322,7 +322,7 @@ handle_thread_signal(int sig) * so don't be surprised if this isn't robust while debugging * with -DL. */ - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "handle_thread_signal: got signal %d\n", sig);); write(sig_pipe[1], &c, 1); } @@ -345,7 +345,7 @@ join(t) int i = NO_INIT PPCODE: #ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n", thr, t, ThrSTATE(t));); MUTEX_LOCK(&t->mutex); switch (ThrSTATE(t)) { @@ -372,7 +372,7 @@ join(t) XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE))); } else { char *mess = SvPV(*av_fetch(av, 1, FALSE), PL_na); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: join propagating die message: %s\n", thr, mess)); croak(mess); @@ -384,7 +384,7 @@ detach(t) Thread t CODE: #ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n", thr, t, ThrSTATE(t));); MUTEX_LOCK(&t->mutex); switch (ThrSTATE(t)) { @@ -476,7 +476,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv)); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { MUTEX_UNLOCK(MgMUTEXP(mg)); @@ -500,7 +500,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv)); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { MUTEX_UNLOCK(MgMUTEXP(mg)); @@ -520,7 +520,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n", thr, sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { @@ -623,7 +623,7 @@ await_signal() ST(0) = sv_newmortal(); if (ret) sv_setsv(ST(0), c ? psig_ptr[c] : &PL_sv_no); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "await_signal returning %s\n", SvPEEK(ST(0)));); MODULE = Thread PACKAGE = Thread::Specific diff --git a/ext/Thread/Thread/Specific.pm b/ext/Thread/Thread/Specific.pm index c3591f4b94..9c8a66a9e6 100644 --- a/ext/Thread/Thread/Specific.pm +++ b/ext/Thread/Thread/Specific.pm @@ -9,6 +9,10 @@ Thread::Specific - thread-specific keys use Thread::Specific; my $k = key_create Thread::Specific; +=head1 DESCRIPTION + +C<key_create> returns a unique thread-specific key. + =cut sub import { diff --git a/ext/Thread/typemap b/ext/Thread/typemap index fd6e99d947..21eb6c3240 100644 --- a/ext/Thread/typemap +++ b/ext/Thread/typemap @@ -13,7 +13,7 @@ T_XSCPTR || mg->mg_private != ${ntype}_MAGIC_SIGNATURE) croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\"); $var = ($type) SvPVX(mg->mg_obj); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), \"XSUB ${func_name}: %p\\n\", $var);) } STMT_END T_IVREF diff --git a/global.sym b/global.sym index ef16b8a873..9426128273 100644 --- a/global.sym +++ b/global.sym @@ -79,7 +79,6 @@ pow_ass_amg ppaddr psig_name psig_ptr -rcsid reall_srchlen regkind repeat_amg @@ -19,8 +19,6 @@ #include "EXTERN.h" #include "perl.h" -EXT char rcsid[]; - GV * gv_AVadd(register GV *gv) { @@ -502,25 +500,19 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) bool global = FALSE; if (isUPPER(*name)) { - if (*name > 'I') { - if (*name == 'S' && ( - strEQ(name, "SIG") || - strEQ(name, "STDIN") || - strEQ(name, "STDOUT") || - strEQ(name, "STDERR") )) - global = TRUE; - } - else if (*name > 'E') { - if (*name == 'I' && strEQ(name, "INC")) - global = TRUE; - } - else if (*name > 'A') { - if (*name == 'E' && strEQ(name, "ENV")) - global = TRUE; - } + if (*name == 'S' && ( + strEQ(name, "SIG") || + strEQ(name, "STDIN") || + strEQ(name, "STDOUT") || + strEQ(name, "STDERR"))) + global = TRUE; + else if (*name == 'I' && strEQ(name, "INC")) + global = TRUE; + else if (*name == 'E' && strEQ(name, "ENV")) + global = TRUE; else if (*name == 'A' && ( strEQ(name, "ARGV") || - strEQ(name, "ARGVOUT") )) + strEQ(name, "ARGVOUT"))) global = TRUE; } else if (*name == '_' && !name[1]) @@ -759,8 +751,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case '\005': case '\006': case '\010': + case '\011': /* NOT \t in EBCDIC */ case '\017': - case '\t': case '\020': case '\024': case '\027': @@ -1154,7 +1146,7 @@ amagic_call(SV *left, SV *right, int method, int flags) CV **cvp=NULL, **ocvp=NULL; AMT *amtp, *oamtp; int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; - int postpr=0, inc_dec_ass=0, assignshift=assign?1:0; + int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) @@ -1171,16 +1163,19 @@ amagic_call(SV *left, SV *right, int method, int flags) int logic; /* look for substituted methods */ + /* In all the covered cases we should be called with assign==0. */ switch (method) { case inc_amg: - if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1)) - || ((cv = cvp[off=add_amg]) && (postpr=1))) { + force_cpy = 1; + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { right = &PL_sv_yes; lr = -1; assign = 1; } break; case dec_amg: - if (((cv = cvp[off=subtr_ass_amg]) && (inc_dec_ass=1)) - || ((cv = cvp[off=subtr_amg]) && (postpr=1))) { + force_cpy = 1; + if ((cv = cvp[off = subtr_ass_amg]) + || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { right = &PL_sv_yes; lr = -1; assign = 1; } break; @@ -1327,6 +1322,7 @@ amagic_call(SV *left, SV *right, int method, int flags) } return NULL; } + force_cpy = force_cpy || assign; } } if (!notfound) { @@ -1343,14 +1339,33 @@ amagic_call(SV *left, SV *right, int method, int flags) flags & AMGf_unary? " for argument" : "", HvNAME(stash), fl? ",\n\tassignment variant used": "") ); + } /* Since we use shallow copy during assignment, we need * to dublicate the contents, probably calling user-supplied * version of copy operator */ - if ((method + assignshift==off - && (assign || method==inc_amg || method==dec_amg)) - || inc_dec_ass) RvDEEPCP(left); - } + /* We need to copy in following cases: + * a) Assignment form was called. + * assignshift==1, assign==T, method + 1 == off + * b) Increment or decrement, called directly. + * assignshift==0, assign==0, method + 0 == off + * c) Increment or decrement, translated to assignment add/subtr. + * assignshift==0, assign==T, + * force_cpy == T + * d) Increment or decrement, translated to nomethod. + * assignshift==0, assign==0, + * force_cpy == T + * e) Assignment form translated to nomethod. + * assignshift==1, assign==T, method + 1 != off + * force_cpy == T + */ + /* off is method, method+assignshift, or a result of opcode substitution. + * In the latter case assignshift==0, so only notfound case is important. + */ + if (( (method + assignshift == off) + && (assign || (method == inc_amg) || (method == dec_amg))) + || force_cpy) + RvDEEPCP(left); { dSP; BINOP myop; @@ -183,11 +183,20 @@ typedef unsigned short U16; #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 EBCDIC + /* In EBCDIC we do not do locales: therefore() isupper() is fine. */ +# define isUPPER(c) isupper(c) +# define isLOWER(c) islower(c) +# define isPRINT(c) isprint(c) +# define toUPPER(c) toupper(c) +# define toLOWER(c) tolower(c) +#else +# 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)) +#endif #ifdef USE_NEXT_CTYPE @@ -286,8 +295,13 @@ typedef unsigned short U16; #define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv(p, 0)) #define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv(p, 0)) -/* This conversion works both ways, strangely enough. */ -#define toCTRL(c) (toUPPER(c) ^ 64) +#ifdef EBCDIC +EXT int ebcdic_control _((int)); +# define toCTRL(c) ebcdic_control(c) +#else + /* This conversion works both ways, strangely enough. */ +# define toCTRL(c) (toUPPER(c) ^ 64) +#endif /* Line numbers are unsigned, 16 bits. */ typedef U16 line_t; diff --git a/hints/isc.sh b/hints/isc.sh index 43b70fde36..cdfe91c605 100644 --- a/hints/isc.sh +++ b/hints/isc.sh @@ -34,6 +34,9 @@ ccflags="$ccflags -DBOGUS_GETNAME_RETURN=256" # rename(2) can't rename long filenames d_rename=undef +# for ext/IPC/SysV/SysV.xs +ccflags="$ccflags -DPERL_ISC" + # 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/isc_2.sh b/hints/isc_2.sh index c73908cbc6..d8ca7dc63a 100644 --- a/hints/isc_2.sh +++ b/hints/isc_2.sh @@ -20,3 +20,6 @@ esac # Compensate for conflicts in <net/errno.h> doio_cflags='ccflags="$ccflags -DENOTSOCK=103"' pp_sys_cflags='ccflags="$ccflags -DENOTSOCK=103"' + +# for ext/IPC/SysV/SysV.xs +ccflags="$ccflags -DPERL_ISC" diff --git a/hints/machten.sh b/hints/machten.sh index 8e30108f20..f283873699 100644 --- a/hints/machten.sh +++ b/hints/machten.sh @@ -13,6 +13,10 @@ # Martijn Koster <m.koster@webcrawler.com> # Richard Yeh <rcyeh@cco.caltech.edu> # +# For now, explicitly disable dynamic loading -- MT 4.1.1 has it, +# but these hints do not yet support it. +# Define NOTEDEF_MACHTEN to undo gratuitous Tenon hack to signal.h. +# -- Dominic Dunlop <domo@computer.org> 9800802 # Completely disable SysV IPC pending more complete support from Tenon # -- Dominic Dunlop <domo@computer.org> 980712 # Use vfork and perl's malloc by default @@ -32,8 +36,16 @@ # # Comments, questions, and improvements welcome! # -# MachTen 4.X does support dynamic loading, but perl doesn't +# MachTen 4.1.1 does support dynamic loading, but perl doesn't # know how to use it yet. +usedl=${usedl:-undef} + +# MachTen 4.1.1 may have an unhelpful hack in /usr/include/signal.h. +# Undo it if so. +if grep NOTDEF_MACHTEN /usr/include/signal.h > /dev/null +then + ccflags="$ccflags -DNOTDEF_MACHTEN" +fi # Power MachTen is a real memory system and its standard malloc # has been optimized for this. Using this malloc instead of Perl's diff --git a/hints/os390.sh b/hints/os390.sh index fd590eaa4e..1cf945dca3 100644 --- a/hints/os390.sh +++ b/hints/os390.sh @@ -1,4 +1,7 @@ # hints/os390.sh +# +# OS/390 hints by David J. Fiander <davidf@mks.com> +# # OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to: # # John Pfuntner <pfuntner@vnet.ibm.com> @@ -11,23 +14,43 @@ # as well as the authors of the aix.sh file # +# To get ANSI C, we need to use c89, and ld doesn't exist cc='c89' -ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE' +ld='c89' +# c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again, +# YYDYNAMIC ensures that the OS/390 yacc generated parser is reentrant. +# -DEBCDIC should come from Configure. +ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC' +# Turning on optimization breaks perl optimize='none' + alignbytes=8 -usemymalloc='y' + +usemymalloc='n' + so='a' + +# On OS/390, libc.a doesn't really hold anything at all, +# so running nm on it is pretty useless. +usenm='n' + +# Dynamic loading doesn't work on OS/390 quite yet +usedl='n' dlext='none' + +# Configure can't figure this out for some reason d_shmatprototype='define' + usenm='false' i_time='define' i_systime='define' -d_select='undef' # (from aix.sh) # uname -m output is too specific and not appropriate here +# osname should come from Configure # case "$archname" in '') archname="$osname" ;; esac +archobjs=ebcdic.o diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index 6f5ee32092..856f80103f 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -173,10 +173,28 @@ END # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. # Recompute $verbose since we may have just changed $cc. - verbose=`${cc:-cc} -v -o try try.c 2>&1` + verbose=`${cc:-cc} -v -o try try.c 2>&1 | grep ld 2>&1` if echo "$verbose" | grep ' /usr/ccs/bin/ld ' >/dev/null 2>&1; then : else + # It's not /usr/ccs/bin/ld - but it might be egcs's ld wrapper, + # which calls /usr/ccs/bin/ld in turn. Passing -V to it will + # make it show its true colors. + + myld=`echo $verbose| grep ld | awk '/\/ld/ {print $1}'` + # This assumes that gcc's output will not change, and that + # /full/path/to/ld will be the first word of the output. + + # all Solaris versions of ld I've seen contain the magic + # string used in the grep below. + if $myld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then + cat <<END >&2 + +Aha. You're using egcs and /usr/ccs/bin/ld. + +END + + else cat <<END >&2 NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. @@ -185,6 +203,7 @@ in your ${cc:-cc} command. (Note that the trailing "/" is required.) END cc="${cc:-cc} -B/usr/ccs/bin/" + fi fi else diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index f490998039..a28f510d11 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -238,6 +238,13 @@ functionality. =cut +# evaluate something in a clean lexical environment +sub _doeval { eval shift } + +# +# put any lexicals at file scope AFTER here +# + use Carp; use Exporter; @ISA=(Exporter); @@ -280,7 +287,7 @@ sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } sub timediff { my($a, $b) = @_; my @r; - for ($i=0; $i < @$a; ++$i) { + for (my $i=0; $i < @$a; ++$i) { push(@r, $a->[$i] - $b->[$i]); } bless \@r; @@ -329,10 +336,15 @@ sub runloop { last if $pack ne $curpack; } - my $subcode = (ref $c eq 'CODE') - ? "sub { package $pack; my(\$_i)=$n; while (\$_i--){&\$c;} }" - : "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; - my $subref = eval $subcode; + my ($subcode, $subref); + if (ref $c eq 'CODE') { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }"; + $subref = eval $subcode; + } + else { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }"; + $subref = _doeval($subcode); + } croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if $debug; diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index a39d1ac04a..8fddfbf68e 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -40,6 +40,11 @@ sub printem { $self->[$index]; } + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + sub DESTROY { } } diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 94f36018e2..b072c1292c 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -191,10 +191,14 @@ sub _win32_ext { # (caller should probably use the list in $Config{libs}) return ("", "", "", "") unless $potential_libs; - my($so) = $Config{'so'}; - my($libs) = $Config{'libs'}; - my($libpth) = $Config{'libpth'}; - my($libext) = $Config{'lib_ext'} || ".lib"; + my $cc = $Config{cc}; + my $VC = 1 if $cc =~ /^cl/i; + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; + my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; if ($libs and $potential_libs !~ /:nodefault/i) { # If Config.pm defines a set of default libs, we always @@ -212,61 +216,100 @@ sub _win32_ext { # compute $extralibs from $potential_libs - my(@searchpath); # from "-L/path" entries in $potential_libs - my(@libpath) = Text::ParseWords::quotewords('\s+', 0, $libpth); - my(@extralibs); + my @searchpath; # from "-L/path" in $potential_libs + my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth); + my @extralibs; + my $pwd = cwd(); # from Cwd.pm + my $lib = ''; + my $found = 0; + my $search = 1; my($fullname, $thislib, $thispth); - my($pwd) = cwd(); # from Cwd.pm - my($lib) = ''; - my($found) = 0; - foreach $thislib (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ - # Handle possible linker path arguments. - if ($thislib =~ s/^-L// and not -d $thislib) { - warn "-L$thislib ignored, directory does not exist\n" + $thislib = $_; + + # see if entry is a flag + if (/^:\w+$/) { + $search = 0 if lc eq ':nosearch'; + $search = 1 if lc eq ':search'; + warn "Ignoring unknown flag '$thislib'\n" + if $verbose and !/^:(no)?(search|default)$/i; + next; + } + + # if searching is disabled, do compiler-specific translations + unless ($search) { + s/^-L/-libpath:/ if $VC; + s/^-l(.+)$/$1.lib/ unless $GC; + push(@extralibs, $_); + $found++; + next; + } + + # handle possible linker path arguments + if (s/^-L// and not -d) { + warn "$thislib ignored, directory does not exist\n" if $verbose; next; } - elsif (-d $thislib) { - unless ($self->file_name_is_absolute($thislib)) { - warn "Warning: '-L$thislib' changed to '-L$pwd/$thislib'\n"; - $thislib = $self->catdir($pwd,$thislib); + elsif (-d) { + unless ($self->file_name_is_absolute($_)) { + warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; + $_ = $self->catdir($pwd,$_); } - push(@searchpath, $thislib); + push(@searchpath, $_); next; } - # Handle possible library arguments. - if ($thislib =~ s/^-l// and $thislib !~ /^lib/i) { - $thislib = "lib$thislib"; + # handle possible library arguments + if (s/^-l// and $GC and !/^lib/i) { + $_ = "lib$_"; } - $thislib .= $libext if $thislib !~ /\Q$libext\E$/i; + $_ .= $libext if !/\Q$libext\E$/i; + + my $secondpass = 0; + LOOKAGAIN: # look for the file itself - if (-f $thislib) { - warn "'$thislib' found\n" if $verbose; + if (-f) { + warn "'$thislib' found as '$_'\n" if $verbose; $found++; - push(@extralibs, $thislib); + push(@extralibs, $_); next; } - my($found_lib)=0; + my $found_lib = 0; foreach $thispth (@searchpath, @libpath){ - unless (-f ($fullname="$thispth\\$thislib")) { - warn "$thislib not found in $thispth\n" if $verbose; + unless (-f ($fullname="$thispth\\$_")) { + warn "'$thislib' not found as '$fullname'\n" if $verbose; next; } - warn "'$thislib' found at $fullname\n" if $verbose; + warn "'$thislib' found as '$fullname'\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); last; } + + # do another pass with (or without) leading 'lib' if they used -l + if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) { + if ($GC) { + goto LOOKAGAIN if s/^lib//i; + } + elsif (!/^lib/i) { + $_ = "lib$_"; + goto LOOKAGAIN; + } + } + + # give up warn "Note (probably harmless): " ."No library found for '$thislib'\n" unless $found_lib>0; + } + return ('','','','') unless $found; # make sure paths with spaces are properly quoted @@ -579,16 +622,38 @@ Unix-OS/2 version in several respects: =item * +If C<$potential_libs> is empty, the return value will be empty. +Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) +will be appended to the list of C<$potential_libs>. The libraries +will be searched for in the directories specified in C<$potential_libs> +as well as in C<$Config{libpth}>. For each library that is found, a +space-separated list of fully qualified library pathnames is generated. + +=item * + Input library and path specifications are accepted with or without the -C<-l> and C<-L> prefices used by Unix linkers. C<-lfoo> specifies the -library C<libfoo.lib> (unless C<foo> already starts with C<lib>), and -C<-Ls:ome\dir> specifies a directory to look for the libraries that follow. -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. The -C<$Config{lib_ext}> suffix will be appended to any entries that are not -directories and don't already have the suffix. 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. +C<-l> and C<-L> prefices used by Unix linkers. + +An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look +for the libraries that follow. + +An entry of the form C<-lfoo> specifies the library C<foo>, which may be +spelled differently depending on what kind of compiler you are using. If +you are using GCC, it gets translated to C<libfoo.a>, but for other win32 +compilers, it becomes C<foo.lib>. If no files are found by those translated +names, one more attempt is made to find them using either C<foo.a> or +C<libfoo.lib>, depending on whether GCC or some other win32 compiler is +being used, respectively. + +If neither the C<-L> or C<-l> prefix is present in an entry, the entry is +considered a directory to search if it is in fact a directory, and a +library to search for otherwise. The C<$Config{lib_ext}> suffix will +be appended to any entries that are not directories and don't already have +the suffix. + +Note that the C<-L> and <-l> prefixes are B<not required>, but authors +who wish their extensions to be portable to Unix or OS/2 should use the +prefixes, since the Unix-OS/2 version of ext() requires them. =item * @@ -597,15 +662,21 @@ not handle object files in the place of libraries. =item * -If C<$potential_libs> is empty, the return value will be empty. -Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) -will be appended to the list of C<$potential_libs>. The libraries -will be searched for in the directories specified in C<$potential_libs> -as well as in C<$Config{libpth}>. For each library that is found, a -space-separated list of fully qualified library pathnames is generated. -You may specify an entry that matches C</:nodefault/i> in -C<$potential_libs> to disable the appending of default libraries -found in C<$Config{libs}> (this should be only needed very rarely). +Entries in C<$potential_libs> beginning with a colon and followed by +alphanumeric characters are treated as flags. Unknown flags will be ignored. + +An entry that matches C</:nodefault/i> disables the appending of default +libraries found in C<$Config{libs}> (this should be only needed very rarely). + +An entry that matches C</:nosearch/i> disables all searching for +the libraries specified after it. Translation of C<-Lfoo> and +C<-lfoo> still happens as appropriate (depending on compiler being used, +as reflected by C<$Config{cc}>), but the entries are not verified to be +valid files or directories. + +An entry that matches C</:search/i> reenables searching for +the libraries specified after it. You can put it at the end to +enable searching for default libraries specified by C<$Config{libs}>. =item * @@ -630,6 +701,44 @@ C<$potential_libs> could be (literally): Note how the first and last entries are protected by quotes in order to protect the spaces. +=item * + +Since this module is most often used only indirectly from extension +C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add +a library to the build process for an extension: + + LIBS => ['-lgl'] + +When using GCC, that entry specifies that MakeMaker should first look +for C<libgl.a> (followed by C<gl.a>) in all the locations specified by +C<$Config{libpth}>. + +When using a compiler other than GCC, the above entry will search for +C<gl.lib> (followed by C<libgl.lib>). + +If the library happens to be in a location not in C<$Config{libpth}>, +you need: + + LIBS => ['-Lc:\gllibs -lgl'] + +Here is a less often used example: + + LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] + +This specifies a search for library C<gl> as before. If that search +fails to find the library, it looks at the next item in the list. The +C<:nosearch> flag will prevent searching for the libraries that follow, +so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, +since GCC can use that value as is with its linker. + +When using the Visual C compiler, the second item is returned as +C<-libpath:d:\mesalibs mesa.lib user32.lib>. + +When using the Borland compiler, the second item is returned as +C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of +moving the C<-Ld:\mesalibs> to the correct place in the linker +command line. + =back diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 72c32fb195..a1226b5463 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -67,7 +67,21 @@ sub replace_manpage_separator { sub maybe_command { my($self,$file) = @_; - return "$file.exe" if -e "$file.exe"; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } return; } @@ -155,21 +169,19 @@ sub init_others $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f'; $self->{'LD'} = $Config{'ld'} || 'link'; $self->{'AR'} = $Config{'ar'} || 'lib'; - if ($GCC) - { - $self->{'LDLOADLIBS'} ||= ' '; - } - else - { - $self->{'LDLOADLIBS'} - ||= ( $BORLAND - ? 'import32.lib' - : # compiler adds msvcrtd?.lib according to debug switches - 'oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' - .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib ' - .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib' - ) . ' $(LIBC) odbc32.lib odbccp32.lib'; - } + $self->{'LDLOADLIBS'} ||= $Config{'libs'}; + # -Lfoo must come first for Borland, so we put it in LDDLFLAGS + if ($BORLAND) { + my $libs = $self->{'LDLOADLIBS'}; + my $libpath = ''; + while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { + $libpath .= ' ' if length $libpath; + $libpath .= $1; + } + $self->{'LDLOADLIBS'} = $libs; + $self->{'LDDLFLAGS'} ||= $Config{'lddlflags'}; + $self->{'LDDLFLAGS'} .= " $libpath"; + } $self->{'DEV_NULL'} = '> NUL'; # $self->{'NOECHO'} = ''; # till we have it working } @@ -718,6 +730,7 @@ We don't want manpage process. XXX add pod2html support later. =cut sub manifypods { + my($self) = shift; return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n"; } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index 24b28b2dce..594ee2ec84 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -97,17 +97,27 @@ my %entries; sub glob { my $pat = shift; my $cxix = shift; + my @pat; # glob without args defaults to $_ $pat = $_ unless defined $pat; + # extract patterns + if ($pat =~ /\s/) { + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + else { + push @pat, $pat; + } + # assume global context if not provided one $cxix = '_G_' unless defined $cxix; $iter{$cxix} = 0 unless exists $iter{$cxix}; # if we're just beginning, do it all first if ($iter{$cxix} == 0) { - $entries{$cxix} = [doglob(1,$pat)]; + $entries{$cxix} = [doglob(1,@pat)]; } # chuck it all out, quick or slow @@ -174,6 +184,15 @@ backslashes and forward slashes are both accepted, and preserved. You may have to double the backslashes if you are putting them in literally, due to double-quotish parsing of the pattern by perl. +Spaces in the argument delimit distinct patterns, so +C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> +or C<.dll>. If you want to put in literal spaces in the glob +pattern, you can escape them with either double quotes, or backslashes. +e.g. C<glob('c:/"Program Files"/*/*.dll')>, or +C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using +C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details +of the quoting rules used. + Extending it to csh patterns is left as an exercise to the reader. =head1 EXPORTS (by request only) @@ -224,5 +243,7 @@ perl perlglob.bat +Text::ParseWords + =cut diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index aca85c6acd..e711c1483d 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -179,7 +179,7 @@ sub cplxe { # # The number defined as pi = 180 degrees # -use constant pi => 4 * atan2(1, 1); +use constant pi => 4 * CORE::atan2(1, 1); # # pit2 @@ -208,7 +208,7 @@ use constant deg1 => pi / 180; # # Used in log10(). # -use constant uplog10 => 1 / log(10); +use constant uplog10 => 1 / CORE::log(10); # # i @@ -246,7 +246,7 @@ sub update_cartesian { my $self = shift; my ($r, $t) = @{$self->{'polar'}}; $self->{c_dirty} = 0; - return $self->{'cartesian'} = [$r * cos $t, $r * sin $t]; + return $self->{'cartesian'} = [$r * CORE::cos($t), $r * CORE::sin($t)]; } # @@ -260,7 +260,7 @@ sub update_polar { 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'} = [CORE::sqrt($x*$x + $y*$y), CORE::atan2($y, $x)]; } # @@ -432,7 +432,7 @@ sub power { return 0 if ($z1z); return 1 if ($z2z or $z1 == 1); } - my $w = $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1); + my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) : CORE::exp($z2 * CORE::log($z1)); # If both arguments cartesian, return cartesian, else polar. return $z1->{c_dirty} == 0 && (not ref $z2 or $z2->{c_dirty} == 0) ? @@ -548,9 +548,9 @@ sub arg { sub sqrt { my ($z) = @_; my ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0); - return $re < 0 ? cplx(0, sqrt(-$re)) : sqrt($re) if $im == 0; + return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) if $im == 0; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake(sqrt($r), $t/2); + return (ref $z)->emake(CORE::sqrt($r), $t/2); } # @@ -562,10 +562,10 @@ sub sqrt { # sub cbrt { my ($z) = @_; - return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) + return $z < 0 ? -CORE::exp(CORE::log(-$z)/3) : ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) unless ref $z; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake(exp(log($r)/3), $t/3); + return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3); } # @@ -596,7 +596,7 @@ sub _rootbad { sub root { my ($z, $n) = @_; _rootbad($n) if ($n < 1 or int($n) != $n); - my ($r, $t) = ref $z ? @{$z->polar} : (abs($z), $z >= 0 ? 0 : pi); + my ($r, $t) = ref $z ? @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi); my @root; my $k; my $theta_inc = pit2 / $n; @@ -671,7 +671,7 @@ sub theta { sub exp { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - return (ref $z)->emake(exp($x), $y); + return (ref $z)->emake(CORE::exp($x), $y); } # @@ -704,13 +704,13 @@ sub log { my ($z) = @_; unless (ref $z) { _logofzero("log") if $z == 0; - return $z > 0 ? log($z) : cplx(log(-$z), pi); + return $z > 0 ? CORE::log($z) : cplx(CORE::log(-$z), pi); } my ($r, $t) = @{$z->polar}; _logofzero("log") if $r == 0; if ($t > pi()) { $t -= pit2 } elsif ($t <= -pi()) { $t += pit2 } - return (ref $z)->make(log($r), $t); + return (ref $z)->make(CORE::log($r), $t); } # @@ -739,8 +739,8 @@ sub logn { my ($z, $n) = @_; $z = cplx($z, 0) unless ref $z; my $logn = $logn{$n}; - $logn = $logn{$n} = log($n) unless defined $logn; # Cache log(n) - return log($z) / $logn; + $logn = $logn{$n} = CORE::log($n) unless defined $logn; # Cache log(n) + return CORE::log($z) / $logn; } # @@ -751,10 +751,10 @@ sub logn { sub cos { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - my $ey = exp($y); + my $ey = CORE::exp($y); my $ey_1 = 1 / $ey; - return (ref $z)->make(cos($x) * ($ey + $ey_1)/2, - sin($x) * ($ey_1 - $ey)/2); + return (ref $z)->make(CORE::cos($x) * ($ey + $ey_1)/2, + CORE::sin($x) * ($ey_1 - $ey)/2); } # @@ -765,10 +765,10 @@ sub cos { sub sin { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - my $ey = exp($y); + my $ey = CORE::exp($y); my $ey_1 = 1 / $ey; - return (ref $z)->make(sin($x) * ($ey + $ey_1)/2, - cos($x) * ($ey - $ey_1)/2); + return (ref $z)->make(CORE::sin($x) * ($ey + $ey_1)/2, + CORE::cos($x) * ($ey - $ey_1)/2); } # @@ -778,9 +778,9 @@ sub sin { # sub tan { my ($z) = @_; - my $cz = cos($z); - _divbyzero "tan($z)", "cos($z)" if (abs($cz) < $eps); - return sin($z) / $cz; + my $cz = CORE::cos($z); + _divbyzero "tan($z)", "cos($z)" if (CORE::abs($cz) < $eps); + return CORE::sin($z) / $cz; } # @@ -790,7 +790,7 @@ sub tan { # sub sec { my ($z) = @_; - my $cz = cos($z); + my $cz = CORE::cos($z); _divbyzero "sec($z)", "cos($z)" if ($cz == 0); return 1 / $cz; } @@ -802,7 +802,7 @@ sub sec { # sub csc { my ($z) = @_; - my $sz = sin($z); + my $sz = CORE::sin($z); _divbyzero "csc($z)", "sin($z)" if ($sz == 0); return 1 / $sz; } @@ -821,9 +821,9 @@ sub cosec { Math::Complex::csc(@_) } # sub cot { my ($z) = @_; - my $sz = sin($z); + my $sz = CORE::sin($z); _divbyzero "cot($z)", "sin($z)" if ($sz == 0); - return cos($z) / $sz; + return CORE::cos($z) / $sz; } # @@ -840,17 +840,17 @@ sub cotan { Math::Complex::cot(@_) } # sub acos { my $z = $_[0]; - return atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1; + return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::abs($z) <= 1; my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); - my $t1 = sqrt(($x+1)*($x+1) + $y*$y); - my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; my $beta = ($t1 - $t2)/2; $alpha = 1 if $alpha < 1; if ($beta > 1) { $beta = 1 } elsif ($beta < -1) { $beta = -1 } - my $u = atan2(sqrt(1-$beta*$beta), $beta); - my $v = log($alpha + sqrt($alpha*$alpha-1)); + my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta); + my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); return $package->make($u, $v); } @@ -862,17 +862,17 @@ sub acos { # sub asin { my $z = $_[0]; - return atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1; + return CORE::atan2($z, CORE::sqrt(1-$z*$z)) if (! ref $z) && CORE::abs($z) <= 1; my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); - my $t1 = sqrt(($x+1)*($x+1) + $y*$y); - my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; my $beta = ($t1 - $t2)/2; $alpha = 1 if $alpha < 1; if ($beta > 1) { $beta = 1 } elsif ($beta < -1) { $beta = -1 } - my $u = atan2($beta, sqrt(1-$beta*$beta)); - my $v = -log($alpha + sqrt($alpha*$alpha-1)); + my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta)); + my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); return $package->make($u, $v); } @@ -884,10 +884,10 @@ sub asin { # sub atan { my ($z) = @_; - return atan2($z, 1) unless ref $z; + return CORE::atan2($z, 1) unless ref $z; _divbyzero "atan(i)" if ( $z == i); _divbyzero "atan(-i)" if (-$z == i); - my $log = log((i + $z) / (i - $z)); + my $log = CORE::log((i + $z) / (i - $z)); $ip2 = 0.5 * i unless defined $ip2; return $ip2 * $log; } @@ -928,10 +928,10 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; - _divbyzero "acot(0)" if (abs($z) < $eps); - return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z; - _divbyzero "acot(i)" if (abs($z - i) < $eps); - _logofzero "acot(-i)" if (abs($z + i) < $eps); + _divbyzero "acot(0)" if (CORE::abs($z) < $eps); + return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) unless ref $z; + _divbyzero "acot(i)" if (CORE::abs($z - i) < $eps); + _logofzero "acot(-i)" if (CORE::abs($z + i) < $eps); return atan(1 / $z); } @@ -951,14 +951,14 @@ sub cosh { my ($z) = @_; my $ex; unless (ref $z) { - $ex = exp($z); + $ex = CORE::exp($z); return ($ex + 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - $ex = exp($x); + $ex = CORE::exp($x); my $ex_1 = 1 / $ex; - return (ref $z)->make(cos($y) * ($ex + $ex_1)/2, - sin($y) * ($ex - $ex_1)/2); + return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2, + CORE::sin($y) * ($ex - $ex_1)/2); } # @@ -970,14 +970,14 @@ sub sinh { my ($z) = @_; my $ex; unless (ref $z) { - $ex = exp($z); + $ex = CORE::exp($z); return ($ex - 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - $ex = exp($x); + $ex = CORE::exp($x); my $ex_1 = 1 / $ex; - return (ref $z)->make(cos($y) * ($ex - $ex_1)/2, - sin($y) * ($ex + $ex_1)/2); + return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2, + CORE::sin($y) * ($ex + $ex_1)/2); } # @@ -1050,15 +1050,15 @@ sub cotanh { Math::Complex::coth(@_) } sub acosh { my ($z) = @_; unless (ref $z) { - return log($z + sqrt($z*$z-1)) if $z >= 1; + return CORE::log($z + CORE::sqrt($z*$z-1)) if $z >= 1; $z = cplx($z, 0); } my ($re, $im) = @{$z->cartesian}; if ($im == 0) { - return cplx(log($re + sqrt($re*$re - 1)), 0) if $re >= 1; - return cplx(0, atan2(sqrt(1-$re*$re), $re)) if abs($re) <= 1; + return cplx(CORE::log($re + CORE::sqrt($re*$re - 1)), 0) if $re >= 1; + return cplx(0, CORE::atan2(CORE::sqrt(1-$re*$re), $re)) if CORE::abs($re) <= 1; } - return log($z + sqrt($z*$z - 1)); + return CORE::log($z + CORE::sqrt($z*$z - 1)); } # @@ -1068,7 +1068,7 @@ sub acosh { # sub asinh { my ($z) = @_; - return log($z + sqrt($z*$z + 1)); + return CORE::log($z + CORE::sqrt($z*$z + 1)); } # @@ -1079,12 +1079,12 @@ sub asinh { sub atanh { my ($z) = @_; unless (ref $z) { - return log((1 + $z)/(1 - $z))/2 if abs($z) < 1; + return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1; $z = cplx($z, 0); } _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); _logofzero 'atanh(-1)' if ($z == -1); - return 0.5 * log((1 + $z) / (1 - $z)); + return 0.5 * CORE::log((1 + $z) / (1 - $z)); } # @@ -1123,14 +1123,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; - _divbyzero 'acoth(0)' if (abs($z) < $eps); + _divbyzero 'acoth(0)' if (CORE::abs($z) < $eps); unless (ref $z) { - return log(($z + 1)/($z - 1))/2 if abs($z) > 1; + return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1; $z = cplx($z, 0); } - _divbyzero 'acoth(1)', "$z - 1" if (abs($z - 1) < $eps); - _logofzero 'acoth(-1)', "1 / $z" if (abs($z + 1) < $eps); - return log((1 + $z) / ($z - 1)) / 2; + _divbyzero 'acoth(1)', "$z - 1" if (CORE::abs($z - 1) < $eps); + _logofzero 'acoth(-1)', "1 / $z" if (CORE::abs($z + 1) < $eps); + return CORE::log((1 + $z) / ($z - 1)) / 2; } # @@ -1156,7 +1156,7 @@ sub atan2 { ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); } if ($im2 == 0) { - return cplx(atan2($re1, $re2), 0) if $im1 == 0; + return cplx(CORE::atan2($re1, $re2), 0) if $im1 == 0; return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; } my $w = atan($z1/$z2); @@ -1232,14 +1232,14 @@ sub stringify_cartesian { my ($re, $im); $x = int($x + ($x < 0 ? -1 : 1) * $eps) - if int(abs($x)) != int(abs($x) + $eps); + if int(CORE::abs($x)) != int(CORE::abs($x) + $eps); $y = int($y + ($y < 0 ? -1 : 1) * $eps) - if int(abs($y)) != int(abs($y) + $eps); + if int(CORE::abs($y)) != int(CORE::abs($y) + $eps); - $re = "$x" if abs($x) >= $eps; + $re = "$x" if CORE::abs($x) >= $eps; if ($y == 1) { $im = 'i' } elsif ($y == -1) { $im = '-i' } - elsif (abs($y) >= $eps) { $im = $y . "i" } + elsif (CORE::abs($y) >= $eps) { $im = $y . "i" } my $str = ''; $str = $re if defined $re; @@ -1298,15 +1298,15 @@ sub stringify_polar { $nt = ($nt - int($nt)) * pit2; $nt += pit2 if $nt < 0; # Range [0, 2pi] - if (abs($nt) <= $eps) { $theta = 0 } - elsif (abs(pi-$nt) <= $eps) { $theta = 'pi' } + if (CORE::abs($nt) <= $eps) { $theta = 0 } + elsif (CORE::abs(pi-$nt) <= $eps) { $theta = 'pi' } if (defined $theta) { $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(abs($r)) != int(abs($r) + $eps); + if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) if ($theta ne 'pi' and - int(abs($theta)) != int(abs($theta) + $eps)); + int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); return "\[$r,$theta\]"; } @@ -1316,13 +1316,13 @@ sub stringify_polar { $nt -= pit2 if $nt > pi; - if (abs($nt) >= deg1) { + if (CORE::abs($nt) >= deg1) { my ($n, $k, $kpi); for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); - if (abs($kpi/$n - $nt) <= $eps) { - $n = abs $n; + if (CORE::abs($kpi/$n - $nt) <= $eps) { + $n = CORE::abs($n); my $gcd = gcd($k, $n); if ($gcd > 1) { $k /= $gcd; @@ -1340,10 +1340,10 @@ sub stringify_polar { $theta = $nt unless defined $theta; $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(abs($r)) != int(abs($r) + $eps); + if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) if ($theta !~ m(^-?\d*pi/\d+$) and - int(abs($theta)) != int(abs($theta) + $eps)); + int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); return "\[$r,$theta\]"; } diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index a0dc4b3f11..5d2e07b2af 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -1293,7 +1293,7 @@ sub process_puretext { } elsif ($word =~ m,^\w+://\w,) { # looks like a URL $word = qq(<A HREF="$word">$word</A>); - } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { + } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) { # looks like an e-mail address my ($w1, $w2, $w3) = ("", $word, ""); ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; diff --git a/lib/Test.pm b/lib/Test.pm index 5f198c234c..6f57415efd 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -225,7 +225,7 @@ L<Test::Harness> and various test coverage analysis tools. =head1 AUTHOR -Copyright © 1998 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 5decc756ff..9c61d3a9dd 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -16,6 +16,8 @@ $VERSION = "1.1602"; # Some experimental versions of OS/2 build have broken $? my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; +my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR}; + my $tests_skipped = 0; my $subtests_skipped = 0; @@ -46,6 +48,8 @@ format STDOUT = $verbose = 0; $switches = "-w"; +sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f } + sub runtests { my(@tests) = @_; local($|) = 1; @@ -62,6 +66,7 @@ sub runtests { if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g } + my @dir_files = globdir $files_in_dir if defined $files_in_dir; my $t_start = new Benchmark; while ($test = shift(@tests)) { $te = $test; @@ -212,6 +217,17 @@ sub runtests { }; } $subtests_skipped += $skipped; + if (defined $files_in_dir) { + my @new_dir_files = globdir $files_in_dir; + if (@new_dir_files != @dir_files) { + my %f; + @f{@new_dir_files} = (1) x @new_dir_files; + delete @f{@dir_files}; + my @f = sort keys %f; + print "LEAKED FILES: @f\n"; + @dir_files = @new_dir_files; + } + } } my $t_total = timediff(new Benchmark, $t_start); @@ -421,9 +437,19 @@ above messages. =head1 ENVIRONMENT -Setting C<HARNESS_IGNORE_EXITCODE> makes it ignore the exit status +Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status of child processes. +If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness +will check after each test whether new files appeared in that directory, +and report them as + + LEAKED FILES: scr.tmp 0 my.db + +If relative, directory name is with respect to the current directory at +the moment runtests() was called. Putting absolute path into +C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results. + =head1 SEE ALSO L<Test> for writing test scripts and also L<Benchmark> for the diff --git a/lib/bigint.pl b/lib/bigint.pl index bfd2efa88c..adeb17f28a 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -74,7 +74,7 @@ sub external { #(int_num_array) return num_str sub main'bneg { #(num_str) return num_str local($_) = &'bnorm(@_); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; - s/^H/N/; + s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC $_; } diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index cc7da89a62..32d4692d13 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -23,6 +23,7 @@ $tick = "auto" unless defined $tick; $unctrl = 'quote' unless defined $unctrl; $subdump = 1; $dumpReused = 0 unless defined $dumpReused; +$bareStringify = 1 unless defined $bareStringify; sub main::dumpValue { local %address; @@ -50,6 +51,10 @@ sub stringify { return 'undef' unless defined $_ or not $printUndef; return $_ . "" if ref \$_ eq 'GLOB'; + $_ = &{'overload::StrVal'}($_) + if $bareStringify and ref $_ + and defined %overload:: and defined &{'overload::StrVal'}; + if ($tick eq 'auto') { if (/[\000-\011\013-\037\177]/) { $tick = '"'; @@ -110,7 +115,7 @@ sub unwrap { return if $DB::signal; local($v) = shift ; local($s) = shift ; # extra no of spaces - local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ; + local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ; local($tHashDepth,$tArrayDepth) ; $sp = " " x $s ; @@ -118,9 +123,11 @@ sub unwrap { # Check for reused addresses if (ref $v) { - ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; + my $val = $v; + $val = &{'overload::StrVal'}($v) + if defined %overload:: and defined &{'overload::StrVal'}; + ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; if (!$dumpReused && defined $address) { - ($type) = $v =~ /=(.*?)\([^=]+$/ ; $address{$address}++ ; if ( $address{$address} > 1 ) { print "${sp}-> REUSED_ADDRESS\n" ; diff --git a/lib/overload.pm b/lib/overload.pm index dfcdb02b1e..43fef8ae5e 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -62,7 +62,10 @@ sub OverloadedStringify { my $package = shift; $package = ref $package if ref $package; #$package->can('(""') - ov_method mycan($package, '(""'), $package; + ov_method mycan($package, '(""'), $package + or ov_method mycan($package, '(0+'), $package + or ov_method mycan($package, '(bool'), $package + or ov_method mycan($package, '(nomethod'), $package; } sub Method { @@ -108,6 +111,18 @@ sub mycan { # Real can would leave stubs. 'qr' => 0x10000, ); +%ops = ( with_assign => "+ - * / % ** << >> x .", + assign => "+= -= *= /= %= **= <<= >>= x= .=", + str_comparison => "< <= > >= == !=", + '3way_comparison'=> "<=> cmp", + num_comparison => "lt le gt ge eq ne", + binary => "& | ^", + unary => "neg ! ~", + mutators => '++ --', + func => "atan2 cos sin exp abs log sqrt", + conversion => 'bool "" 0+', + special => 'nomethod fallback ='); + sub constant { # Arguments: what, sub while (@_) { @@ -220,7 +235,8 @@ the arguments are reversed. the current operation is an assignment variant (as in C<$a+=7>), but the usual function is called instead. This additional -information can be used to generate some optimizations. +information can be used to generate some optimizations. Compare +L<Calling Conventions for Mutators>. =back @@ -230,9 +246,67 @@ Unary operation are considered binary operations with the second argument being C<undef>. Thus the functions that overloads C<{"++"}> is called with arguments C<($a,undef,'')> when $a++ is executed. +=head2 Calling Conventions for Mutators + +Two types of mutators have different calling conventions: + +=over + +=item C<++> and C<--> + +The routines which implement these operators are expected to actually +I<mutate> their arguments. So, assuming that $obj is a reference to a +number, + + sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n} + +is an appropriate implementation of overloaded C<++>. Note that + + sub incr { ++$ {$_[0]} ; shift } + +is OK if used with preincrement and with postincrement. (In the case +of postincrement a copying will be performed, see L<Copy Constructor>.) + +=item C<x=> and other assignment versions + +There is nothing special about these methods. They may change the +value of their arguments, and may leave it as is. The result is going +to be assigned to the value in the left-hand-side if different from +this value. + +This allows for the same method to be used as averloaded C<+=> and +C<+>. Note that this is I<allowed>, but not recommended, since by the +semantic of L<"Fallback"> Perl will call the method for C<+> anyway, +if C<+=> is not overloaded. + +=back + +B<Warning.> Due to the presense of assignment versions of operations, +routines which may be called in assignment context may create +self-referencial structures. Currently Perl will not free self-referential +structures until cycles are C<explicitly> broken. You may get problems +when traversing your structures too. + +Say, + + use overload '+' => sub { bless [ \$_[0], \$_[1] ] }; + +is asking for trouble, since for code C<$obj += $foo> the subroutine +is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, +\$foo]>. If using such a subroutine is an important optimization, one +can overload C<+=> explicitly by a non-"optimized" version, or switch +to non-optimized version if C<not defined $_[2]> (see +L<Calling Conventions for Binary Operations>). + +Even if no I<explicit> assignment-variants of operators are present in +the script, they may be generated by the optimizer. Say, C<",$obj,"> or +C<',' . $obj . ','> may be both optimized to + + my $tmp = ',' . $obj; $tmp .= ','; + =head2 Overloadable Operations -The following symbols can be specified in C<use overload>: +The following symbols can be specified in C<use overload> directive: =over 5 @@ -247,6 +321,10 @@ the assignment variant is not available. Methods for operations "C<+>", increment and decrement methods. The operation "C<->" can be used to autogenerate missing methods for unary minus or C<abs>. +See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and +L<"Calling Conventions for Binary Operations">) for details of these +substitutions. + =item * I<Comparison operations> "<", "<=", ">", ">=", "==", "!=", "<=>", @@ -298,7 +376,23 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>. =back -See L<"Fallback"> for an explanation of when a missing method can be autogenerated. +See L<"Fallback"> for an explanation of when a missing method can be +autogenerated. + +A computer-readable form of the above table is available in the hash +%overload::ops, with values being space-separated lists of names: + + with_assign => '+ - * / % ** << >> x .', + assign => '+= -= *= /= %= **= <<= >>= x= .=', + str_comparison => '< <= > >= == !=', + '3way_comparison'=> '<=> cmp', + num_comparison => 'lt le gt ge eq ne', + binary => '& | ^', + unary => 'neg ! ~', + mutators => '++ --', + func => 'atan2 cos sin exp abs log sqrt', + conversion => 'bool "" 0+', + special => 'nomethod fallback =' =head2 Inheritance and overloading @@ -401,15 +495,15 @@ to a reference that shares its object with some other reference, such as $a=$b; - $a++; + ++$a; To make this change $a and not change $b, a copy of C<$$a> is made, and $a is assigned a reference to this new object. This operation is -done during execution of the C<$a++>, and not during the assignment, +done during execution of the C<++$a>, and not during the assignment, (so before the increment C<$$a> coincides with C<$$b>). This is only -done if C<++> is expressed via a method for C<'++'> or C<'+='>. Note -that if this operation is expressed via C<'+'> a nonmutator, i.e., as -in +done if C<++> is expressed via a method for C<'++'> or C<'+='> (or +C<nomethod>). Note that if this operation is expressed via C<'+'> +a nonmutator, i.e., as in $a=$b; $a=$a+1; @@ -443,6 +537,9 @@ C<'='> was overloaded with C<\&clone>. =back +Same behaviour is triggered by C<$b = $a++>, which is consider a synonim for +C<$b = $a; ++$a>. + =head1 MAGIC AUTOGENERATION If a method for an operation is not found, and the value for C<"fallback"> is @@ -499,7 +596,7 @@ value is a scalar and not a reference. =back -=head1 WARNING +=head1 Losing overloading The restriction for the comparison operation is that even if, for example, `C<cmp>' should return a blessed reference, the autogenerated `C<lt>' @@ -661,6 +758,416 @@ behavior by defining your own copy constructor (see L<"Copy Constructor">). It is expected that arguments to methods that are not explicitly supposed to be changed are constant (but this is not enforced). +=head1 Metaphor clash + +One may wonder why the semantic of overloaded C<=> is so counterintuive. +If it I<looks> counterintuive to you, you are subject to a metaphor +clash. + +Here is a Perl object metaphor: + +I< object is a reference to blessed data> + +and an arithmetic metaphor: + +I< object is a thing by itself>. + +The I<main> problem of overloading C<=> is the fact that these metaphors +imply different actions on the assignment C<$a = $b> if $a and $b are +objects. Perl-think implies that $a becomes a reference to whatever +$b was referencing. Arithmetic-think implies that the value of "object" +$a is changed to become the value of the object $b, preserving the fact +that $a and $b are separate entities. + +The difference is not relevant in the absence of mutators. After +a Perl-way assignment an operation which mutates the data referenced by $a +would change the data referenced by $b too. Effectively, after +C<$a = $b> values of $a and $b become I<indistinguishable>. + +On the other hand, anyone who has used algebraic notation knows the +expressive power of the arithmetic metaphor. Overloading works hard +to enable this metaphor while preserving the Perlian way as far as +possible. Since it is not not possible to freely mix two contradicting +metaphors, overloading allows the arithmetic way to write things I<as +far as all the mutators are called via overloaded access only>. The +way it is done is described in L<Copy Constructor>. + +If some mutator methods are directly applied to the overloaded values, +one may need to I<explicitly unlink> other values which references the +same value: + + $a = new Data 23; + ... + $b = $a; # $b is "linked" to $a + ... + $a = $a->clone; # Unlink $b from $a + $a->increment_by(4); + +Note that overloaded access makes this transparent: + + $a = new Data 23; + $b = $a; # $b is "linked" to $a + $a += 4; # would unlink $b automagically + +However, it would not make + + $a = new Data 23; + $a = 4; # Now $a is a plain 4, not 'Data' + +preserve "objectness" of $a. But Perl I<has> a way to make assignments +to an object do whatever you want. It is just not the overload, but +tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method +which returns the object itself, and STORE() method which changes the +value of the object, one can reproduce the arithmetic metaphor in its +completeness, at least for variables which were tie()d from the start. + +(Note that a workaround for a bug may be needed, see L<"BUGS">.) + +=head1 Cookbook + +Please add examples to what follows! + +=head2 Two-face scalars + +Put this in F<two_face.pm> in your Perl library directory: + + package two_face; # Scalars with separate string and + # numeric values. + sub new { my $p = shift; bless [@_], $p } + use overload '""' => \&str, '0+' => \&num, fallback => 1; + sub num {shift->[1]} + sub str {shift->[0]} + +Use it as follows: + + require two_face; + my $seven = new two_face ("vii", 7); + printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; + print "seven contains `i'\n" if $seven =~ /i/; + +(The second line creates a scalar which has both a string value, and a +numeric value.) This prints: + + seven=vii, seven=7, eight=8 + seven contains `i' + +=head2 Symbolic calculator + +Put this in F<symbolic.pm> in your Perl library directory: + + package symbolic; # Primitive symbolic calculator + use overload nomethod => \&wrap; + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + +This module is very unusual as overloaded modules go: it does not +provide any usual overloaded operators, instead it provides the L<Last +Resort> operator C<nomethod>. In this example the corresponding +subroutine returns an object which encupsulates operations done over +the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new +symbolic 3> contains C<['+', 2, ['n', 3]]>. + +Here is an example of the script which "calculates" the side of +circumscribed octagon using the above package: + + require symbolic; + my $iter = 1; # 2**($iter+2) = 8 + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + print "OK\n"; + +The value of $side is + + ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]], + undef], 1], ['n', 1]] + +Note that while we obtained this value using a nice little script, +there is no simple way to I<use> this value. In fact this value may +be inspected in debugger (see L<perldebug>), but ony if +C<bareStringify> B<O>ption is set, and not via C<p> command. + +If one attempts to print this value, then the overloaded operator +C<""> will be called, which will call C<nomethod> operator. The +result of this operator will be stringified again, but this result is +again of type C<symbolic>, which will lead to an infinite loop. + +Add a pretty-printer method to the module F<symbolic.pm>: + + sub pretty { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + $a = $a->pretty if ref $a; + $b = $b->pretty if ref $b; + "[$meth $a $b]"; + } + +Now one can finish the script by + + print "side = ", $side->pretty, "\n"; + +The method C<pretty> is doing object-to-string conversion, so it +is natural to overload the operator C<""> using this method. However, +inside such a method it is not necessary to pretty-print the +I<components> $a and $b of an object. In the above subroutine +C<"[$meth $a $b]"> is a catenation of some strings and components $a +and $b. If these components use overloading, the catenation operator +will look for an overloaded operator C<.>, if not present, it will +look for an overloaded operator C<"">. Thus it is enough to use + + use overload nomethod => \&wrap, '""' => \&str; + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + "[$meth $a $b]"; + } + +Now one can change the last line of the script to + + print "side = $side\n"; + +which outputs + + side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]] + +and one can inspect the value in debugger using all the possible +methods. + +Something is is still amiss: consider the loop variable $cnt of the +script. It was a number, not an object. We cannot make this value of +type C<symbolic>, since then the loop will not terminate. + +Indeed, to terminate the cycle, the $cnt should become false. +However, the operator C<bool> for checking falsity is overloaded (this +time via overloaded C<"">), and returns a long string, thus any object +of type C<symbolic> is true. To overcome this, we need a way to +compare an object to 0. In fact, it is easier to write a numeric +conversion routine. + +Here is the text of F<symbolic.pm> with such a routine added (and +slightly modifed str()): + + package symbolic; # Primitive symbolic calculator + use overload + nomethod => \&wrap, '""' => \&str, '0+' => \# + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( n => sub {$_[0]}, + sqrt => sub {sqrt $_[0]}, + '-' => sub {shift() - shift()}, + '+' => sub {shift() + shift()}, + '/' => sub {shift() / shift()}, + '*' => sub {shift() * shift()}, + '**' => sub {shift() ** shift()}, + ); + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + +All the work of numeric conversion is done in %subr and num(). Of +course, %subr is not complete, it contains only operators used in teh +example below. Here is the extra-credit question: why do we need an +explicit recursion in num()? (Answer is at the end of this section.) + +Use this module like this: + + require symbolic; + my $iter = new symbolic 2; # 16-gon + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # Mutator `--' not implemented + $side = (sqrt(1 + $side**2) - 1)/$side; + } + printf "%s=%f\n", $side, $side; + printf "pi=%f\n", $side*(2**($iter+2)); + +It prints (without so many line breaks) + + [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] + [n 1]] 2]]] 1] + [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912 + pi=3.182598 + +The above module is very primitive. It does not implement +mutator methods (C<++>, C<-=> and so on), does not do deep copying +(not required without mutators!), and implements only those arithmetic +operations which are used in the example. + +To implement most arithmetic operattions is easy, one should just use +the tables of operations, and change the code which fills %subr to + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + print "defining `$op'\n"; + $subr{$op} = eval "sub {$op shift()}"; + } + +Due to L<Calling Conventions for Mutators>, we do not need anything +special to make C<+=> and friends work, except filling C<+=> entry of +%subr, and defining a copy constructor (needed since Perl has no +way to know that the implementation of C<'+='> does not mutate +the argument, compare L<Copy Constructor>). + +To implement a copy constructor, add C<'=' => \&cpy> to C<use overload> +line, and code (this code assumes that mutators change things one level +deep only, so recursive copying is not needed): + + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + +To make C<++> and C<--> work, we need to implement actual mutators, +either directly, or in C<nomethod>. We continue to do things inside +C<nomethod>, thus add + + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + +after the first line of wrap(). This is not a most effective +implementation, one may consider + + sub inc { $_[0] = bless ['++', shift, 1]; } + +instead. + +As a final remark, note that one can fill %subr by + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + +This finishes implementation of a primitive symbolic calculator in +50 lines of Perl code. Since the numeric values of subexpressions +are not cached, the calculator is very slow. + +Here is the answer for the exercise: In the case of str(), we need no +explicit recursion since the overloaded C<.>-operator will fall back +to an existing overloaded operator C<"">. Overloaded arithmetic +operators I<do not> fall back to numeric conversion if C<fallback> is +not explicitly requested. Thus without an explicit recursion num() +would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild +the argument of num(). + +If you wonder why defaults for conversion are different for str() and +num(), note how easy it was to write the symbolic calculator. This +simplicity is due to an appropriate choice of defaults. One extra +note: due to teh explicit recursion num() is more fragile than sym(): +we need to explicitly check for the type of $a and $b. If componets +$a and $b happen to be of some related type, this may lead to problems. + +=head2 I<Really> symbolic calculator + +One may wonder why we call the above calculator symbolic. The reason +is that the actual calculation of the value of expression is postponed +until the value is I<used>. + +To see it in action, add a method + + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } + +to the package C<symbolic>. After this change one can do + + my $a = new symbolic 3; + my $b = new symbolic 4; + my $c = sqrt($a**2 + $b**2); + +and the numeric value of $c becomes 5. However, after calling + + $a->STORE(12); $b->STORE(5); + +the numeric value of $c becomes 13. There is no doubt now that the module +symbolic provides a I<symbolic> calculator indeed. + +To hide the rough edges under the hood, provide a tie()d interface to the +package C<symbolic> (compare with L<Metaphor clash>). Add methods + + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + +(the bug is described in L<"BUGS">). One can use this new interface as + + tie $a, 'symbolic', 3; + tie $b, 'symbolic', 4; + $a->nop; $b->nop; # Around a bug + + my $c = sqrt($a**2 + $b**2); + +Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value +of $c becomes 13. To insulate the user of the module add a method + + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + +Now + + my ($a, $b); + symbolic->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + + $a = 3; $b = 4; + printf "c5 %s=%f\n", $c, $c; + + $a = 12; $b = 5; + printf "c13 %s=%f\n", $c, $c; + +shows that the numeric value of $c follows changes to the values of $a +and $b. + =head1 AUTHOR Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. @@ -676,7 +1183,7 @@ this overloading). Say, if C<eq> is overloaded, then the method C<(eq> is shown by debugger. The method C<()> corresponds to the C<fallback> key (in fact a presence of this method shows that this package has overloading enabled, and it is what is used by the C<Overloaded> -function). +function of module C<overload>). =head1 BUGS @@ -689,9 +1196,21 @@ C<fallback> is present (possibly undefined). This may create interesting effects if some package is not overloaded, but inherits from two overloaded packages. +Relation between overloading and tie()ing is broken. Overloading is +triggered or not basing on the I<previous> class of tie()d value. + +This happens because the presence of overloading is checked too early, +before any tie()d access is attempted. If the FETCH()ed class of the +tie()d value does not change, a simple workaround is to access the value +immediately after tie()ing, so that after this call the I<previous> class +coincides with the current one. + +B<Needed:> a way to fix this without a speed penalty. + Barewords are not covered by overloaded string constants. -This document is confusing. +This document is confusing. There are grammos and misleading language +used in places. It would seem a total rewrite is needed. =cut diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 67a6a6d839..099a49b49f 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.03; +$VERSION = 1.0401; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -179,7 +179,7 @@ $inhibit_exit = $option{PrintRet} = 1; TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit - ImmediateStop); + ImmediateStop bareStringify); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -191,6 +191,7 @@ $inhibit_exit = $option{PrintRet} = 1; undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, UsageOnly => \$dumpvar::usageOnly, + bareStringify => \$dumpvar::bareStringify, frame => \$frame, AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, @@ -390,6 +391,7 @@ sub DB { if ($trace & 2) { for (my $n = 0; $n <= $#to_watch; $n++) { $evalarg = $to_watch[$n]; + local $onetimeDump; # Do not output results my ($val) = &eval; # Fix context (&eval is doing array)? $val = ( (defined $val) ? "'$val'" : 'undef' ); if ($val ne $old_watch[$n]) { @@ -1823,6 +1825,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<DumpPackages>: dump symbol tables of packages; I<DumpReused>: dump contents of \"reused\" addresses; I<quote>, I<HighBit>, I<undefPrint>: change style of string dump; + I<bareStringify>: Do not print the overload-stringified value; Option I<PrintRet> affects printing of return value after B<r> command, I<frame> affects printing messages on entry and exit from subroutines. I<AutoTrace> affects printing messages on every possible breaking point. @@ -101,6 +101,11 @@ # This many continuous sbrk()s compensate for one discontinuous one. SBRK_FAILURE_PRICE 50 + # Some configurations may ask for 12-byte-or-so allocations which + # require 8-byte alignment (?!). In such situation one needs to + # define this to disable 12-byte bucket (will increase memory footprint) + STRICT_ALIGNMENT undef + This implementation assumes that calling PerlIO_printf() does not result in any memory allocation calls (used during a panic). @@ -281,6 +286,7 @@ static void botch _((char *diag, char *s)); #endif static void morecore _((int bucket)); static int findbucket _((union overhead *freep, int srchlen)); +static void add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip); #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ @@ -571,46 +577,59 @@ static Malloc_t emergency_sbrk(size) MEM_SIZE size; { + MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA; + if (size >= BIG_SIZE) { /* Give the possibility to recover: */ MUTEX_UNLOCK(&PL_malloc_mutex); croak("Out of memory during \"large\" request for %i bytes", size); } - if (!emergency_buffer) { + if (emergency_buffer_size >= rsize) { + char *old = emergency_buffer; + + emergency_buffer_size -= rsize; + emergency_buffer += rsize; + return old; + } else { dTHR; /* First offense, give a possibility to recover by dieing. */ /* No malloc involved here: */ GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0); SV *sv; char *pv; + int have = 0; + if (emergency_buffer_size) { + add_to_chain(emergency_buffer, emergency_buffer_size, 0); + emergency_buffer_size = 0; + emergency_buffer = Nullch; + have = 1; + } if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) - || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) + || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) { + if (have) + goto do_croak; return (char *)-1; /* Now die die die... */ - + } /* Got it, now detach SvPV: */ pv = SvPV(sv, PL_na); /* Check alignment: */ - if (((u_bigint)(pv - M_OVERHEAD)) & ((1<<LOG_OF_MIN_ARENA) - 1)) { + if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 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; + emergency_buffer = pv - sizeof(union overhead); + emergency_buffer_size = malloced_size(pv) + M_OVERHEAD; SvPOK_off(sv); - SvREADONLY_on(sv); - MUTEX_UNLOCK(&PL_malloc_mutex); - croak("Out of memory during request for %i bytes", size); - } - else if (emergency_buffer_size >= size) { - emergency_buffer_size -= size; - return emergency_buffer + emergency_buffer_size; + SvPVX(sv) = Nullch; + SvCUR(sv) = SvLEN(sv) = 0; } - - return (char *)-1; /* poor guy... */ + do_croak: + MUTEX_UNLOCK(&PL_malloc_mutex); + croak("Out of memory during request for %i bytes", size); } #else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ @@ -1033,6 +1052,12 @@ getpages_adjacent(int require) sbrked_remains = 0; last_sbrk_top = cp + require; } else { + if (cp == (char*)-1) { /* Out of memory */ +#ifdef DEBUGGING_MSTATS + goodsbrk -= require; +#endif + return 0; + } /* Report the failure: */ if (sbrked_remains) add_to_chain((void*)(last_sbrk_top - sbrked_remains), @@ -1352,6 +1377,10 @@ realloc(void *mp, size_t nbytes) #endif res = cp; MUTEX_UNLOCK(&PL_malloc_mutex); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%lx: (%05lu) realloc %ld bytes inplace\n", + (unsigned long)res,(unsigned long)(PL_an++), + (long)size)); } else if (incr == 1 && (cp - M_OVERHEAD == last_op) && (onb > (1 << LOG_OF_MIN_ARENA))) { MEM_SIZE require, newarena = nbytes, pow; @@ -1380,6 +1409,10 @@ realloc(void *mp, size_t nbytes) } else { hard_way: MUTEX_UNLOCK(&PL_malloc_mutex); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%lx: (%05lu) realloc %ld bytes the hard way\n", + (unsigned long)cp,(unsigned long)(PL_an++), + (long)size)); if ((res = (char*)malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ @@ -1387,13 +1420,6 @@ realloc(void *mp, size_t nbytes) if (was_alloced) free(cp); } - - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lu: (%05lu) rfree\n", - (unsigned long)res,(unsigned long)(PL_an++))); - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) realloc %ld bytes\n", - (unsigned long)res,(unsigned long)(PL_an++), - (long)size)); return ((Malloc_t)res); } @@ -422,7 +422,7 @@ magic_get(SV *sv, MAGIC *mg) case '\010': /* ^H */ sv_setiv(sv, (IV)PL_hints); break; - case '\t': /* ^I */ + case '\011': /* ^I */ /* NOT \t in EBCDIC */ if (PL_inplace) sv_setpv(sv, PL_inplace); else @@ -520,7 +520,6 @@ magic_get(SV *sv, MAGIC *mg) break; case '?': { - dTHR; sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS LvTARGOFF(sv) = PL_statusvalue; @@ -1419,12 +1418,12 @@ vivify_defelem(SV *sv) if (mg->mg_obj) { SV *ahv = LvTARG(sv); if (SvTYPE(ahv) == SVt_PVHV) { - HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); + HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); if (he) value = HeVAL(he); } else { - SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0); + SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0); if (svp) value = *svp; } @@ -1542,7 +1541,7 @@ magic_set(SV *sv, MAGIC *mg) case '\010': /* ^H */ PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; - case '\t': /* ^I */ + case '\011': /* ^I */ /* NOT \t in EBCDIC */ if (PL_inplace) Safefree(PL_inplace); if (SvOK(sv)) @@ -1867,7 +1866,7 @@ int magic_mutexfree(SV *sv, MAGIC *mg) { dTHR; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) if (MgOWNER(mg)) croak("panic: magic_mutexfree"); @@ -92,7 +92,7 @@ void assertref(OP *o) { int type = o->op_type; - if (type != OP_AELEM && type != OP_HELEM) { + if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) { yyerror(form("Can't use subscript on %s", op_desc[type])); if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) { dTHR; @@ -548,7 +548,7 @@ find_threadsv(char *name) default: sv_magic(sv, 0, 0, name, 1); } - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "find_threadsv: new SV %p for $%s%c\n", sv, (*name < 32) ? "^" : "", (*name < 32) ? toCTRL(*name) : *name)); @@ -582,6 +582,10 @@ op_free(OP *o) o->op_targ = 0; /* Was holding hints. */ break; #ifdef USE_THREADS + case OP_ENTERITER: + if (!(o->op_flags & OPf_SPECIAL)) + break; + /* FALL THROUGH */ case OP_THREADSV: o->op_targ = 0; /* Was holding index into thr->threadsv AV. */ break; @@ -189,7 +189,7 @@ for (@ops) { $argsum |= 64 if $flags =~ /d/; # danger, unknown side effects $argsum |= 128 if $flags =~ /u/; # defaults to $_ - $flags =~ /([^a-zA-Z])/ or die qq[Opcode "$_" has no class indicator]; + $flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator]; $argsum |= $opclass{$1} << 8; $mul = 4096; # 2 ^ OASHIFT for $arg (split(' ',$args{$_})) { diff --git a/os2/os2ish.h b/os2/os2ish.h index c02202abce..586f75b0e6 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -169,11 +169,16 @@ void Perl_OS2_init(char **); /* XXX This code hideously puts env inside: */ -#define PERL_SYS_INIT(argcp, argvp) STMT_START { \ +#ifdef __EMX__ +# define PERL_SYS_INIT(argcp, argvp) STMT_START { \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ Perl_OS2_init(env); } STMT_END - +#else /* Compiling embedded Perl with non-EMX compiler */ +# define PERL_SYS_INIT(argcp, argvp) STMT_START { \ + Perl_OS2_init(env); } STMT_END +# define PERL_CALLCONV _System +#endif #define PERL_SYS_TERM() MALLOC_TERM /* #define PERL_SYS_TERM() STMT_START { \ diff --git a/patchlevel.h b/patchlevel.h index c28f2b11df..dc33a3afb6 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,6 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ #define PATCHLEVEL 5 +#undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */ #define SUBVERSION 50 /* @@ -31,8 +31,6 @@ char *getenv _((char *)); /* Usually in <stdlib.h> */ #include <sys/file.h> #endif -dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; - #ifdef IAMSUID #ifndef DOSUID #define DOSUID @@ -256,7 +254,7 @@ perl_destruct(register PerlInterpreter *sv_interp) /* Pass 1 on any remaining threads: detach joinables, join zombies */ retry_cleanup: MUTEX_LOCK(&PL_threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: waiting for %d threads...\n", PL_nthreads - 1)); for (t = thr->next; t != thr; t = t->next) { @@ -264,7 +262,7 @@ perl_destruct(register PerlInterpreter *sv_interp) switch (ThrSTATE(t)) { AV *av; case THRf_ZOMBIE: - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: joining zombie %p\n", t)); ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); @@ -278,11 +276,11 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&PL_threads_mutex); JOIN(t, &av); SvREFCNT_dec((SV*)av); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: joined zombie %p OK\n", t)); goto retry_cleanup; case THRf_R_JOINABLE: - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); /* @@ -296,7 +294,7 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&t->mutex); goto retry_cleanup; default: - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: ignoring %p (state %u)\n", t, ThrSTATE(t))); MUTEX_UNLOCK(&t->mutex); @@ -308,14 +306,14 @@ perl_destruct(register PerlInterpreter *sv_interp) /* Pass 2 on remaining threads: wait for the thread count to drop to one */ while (PL_nthreads > 1) { - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: final wait for %d threads\n", PL_nthreads - 1)); COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex); } /* At this point, we're the last thread */ MUTEX_UNLOCK(&PL_threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); #endif /* !defined(FAKE_THREADS) */ @@ -1064,10 +1062,8 @@ perl_run(PerlInterpreter *sv_interp) if (!PL_restartop) { DEBUG_x(dump_all()); DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", (unsigned long) thr)); -#endif /* USE_THREADS */ if (PL_minus_c) { PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename); @@ -1571,7 +1567,7 @@ moreswitches(char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXD"; + static char debopts[] = "psltocPmfrxuLHXDS"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -1738,6 +1734,9 @@ moreswitches(char *s) #ifdef MPE printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n"); #endif +#ifdef OEMVS + printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n"); +#endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif @@ -2886,10 +2885,8 @@ my_exit(U32 status) { dTHR; -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); -#endif /* USE_THREADS */ switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -2974,8 +2971,10 @@ read_e_script(int idx, SV *buf_sv, int maxlen) p = SvPVX(PL_e_script); nl = strchr(p, '\n'); nl = (nl) ? nl+1 : SvEND(PL_e_script); - if (nl-p == 0) + if (nl-p == 0) { + filter_del(read_e_script); return 0; + } sv_catpvn(buf_sv, p, nl-p); sv_chop(PL_e_script, nl); return 1; @@ -1424,6 +1424,7 @@ Gid_t getegid _((void)); #ifndef Perl_debug_log #define Perl_debug_log PerlIO_stderr() #endif +#undef YYDEBUG #define YYDEBUG 1 #define DEB(a) a #define DEBUG(a) if (PL_debug) a @@ -1443,6 +1444,11 @@ Gid_t getegid _((void)); #define DEBUG_H(a) if (PL_debug & 8192) a #define DEBUG_X(a) if (PL_debug & 16384) a #define DEBUG_D(a) if (PL_debug & 32768) a +# ifdef USE_THREADS +# define DEBUG_S(a) if (PL_debug & (1<<16)) a +# else +# define DEBUG_S(a) +# endif #else #define DEB(a) #define DEBUG(a) @@ -1458,10 +1464,11 @@ Gid_t getegid _((void)); #define DEBUG_r(a) #define DEBUG_x(a) #define DEBUG_u(a) -#define DEBUG_L(a) +#define DEBUG_S(a) #define DEBUG_H(a) #define DEBUG_X(a) #define DEBUG_D(a) +#define DEBUG_S(a) #endif #define YYMAXDEPTH 300 @@ -1490,8 +1497,13 @@ double atof _((const char*)); /* All of these are in stdlib.h or time.h for ANSI C */ Time_t time(); struct tm *gmtime(), *localtime(); +#ifdef OEMVS +char *(strchr)(), *(strrchr)(); +char *(strcpy)(), *(strcat)(); +#else char *strchr(), *strrchr(); char *strcpy(), *strcat(); +#endif #endif /* ! STANDARD_C */ @@ -1669,6 +1681,42 @@ EXT SV * psig_name[]; /* fast case folding tables */ #ifdef DOINIT +#ifdef EBCDIC +EXT unsigned char fold[] = { /* fast EBCDIC case folding table */ + 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, 65, 66, 67, 68, 69, 70, 71, + 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, + 88, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, + 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 123, 124, 125, 126, 127, + 128, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 138, 139, 140, 141, 142, 143, + 144, 'J', 'K', 'L', 'M', 'N', 'O', 'P', + 'Q', 'R', 154, 155, 156, 157, 158, 159, + 160, 161, 'S', 'T', 'U', 'V', 'W', 'X', + 'Y', 'Z', 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 202, 203, 204, 205, 206, 207, + 208, 'j', 'k', 'l', 'm', 'n', 'o', 'p', + 'q', 'r', 218, 219, 220, 221, 222, 223, + 224, 225, 's', 't', 'u', 'v', 'w', 'x', + 'y', 'z', 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 +}; +#else /* ascii rather than ebcdic */ EXTCONST unsigned char fold[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, @@ -1703,6 +1751,7 @@ EXTCONST unsigned char fold[] = { 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; +#endif /* !EBCDIC */ #else EXTCONST unsigned char fold[]; #endif @@ -1747,6 +1796,42 @@ EXT unsigned char fold_locale[]; #endif #ifdef DOINIT +#ifdef EBCDIC +EXT unsigned char freq[] = {/* EBCDIC 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, + 129, 140, 147, 148, 149, 150, 152, 153, + 255, 6, 8, 9, 10, 11, 12, 13, + 14, 15, 24, 25, 26, 27, 28, 226, + 29, 30, 31, 32, 33, 43, 44, 45, + 46, 47, 48, 49, 50, 76, 77, 78, + 79, 80, 81, 82, 83, 84, 85, 86, + 87, 94, 95, 234, 181, 233, 187, 190, + 180, 96, 97, 98, 99, 100, 101, 102, + 104, 112, 182, 174, 236, 232, 229, 103, + 228, 226, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 235, 176, 230, 194, 162, + 130, 131, 132, 133, 134, 135, 136, 137, + 138, 139, 201, 205, 163, 217, 220, 224, + 5, 248, 227, 244, 242, 255, 241, 231, + 240, 253, 16, 197, 19, 20, 21, 187, + 23, 169, 210, 245, 237, 249, 247, 239, + 168, 252, 34, 196, 36, 37, 38, 39, + 41, 42, 251, 254, 238, 223, 221, 213, + 225, 177, 52, 53, 54, 55, 56, 57, + 58, 59, 60, 61, 63, 64, 65, 66, + 67, 68, 69, 70, 71, 72, 74, 75, + 205, 208, 186, 202, 200, 218, 198, 179, + 178, 214, 88, 89, 90, 91, 92, 93, + 217, 166, 170, 207, 199, 209, 206, 204, + 160, 212, 105, 106, 108, 109, 110, 111, + 203, 113, 216, 215, 192, 175, 193, 243, + 172, 161, 123, 124, 125, 126, 127, 128, + 222, 219, 211, 195, 188, 193, 185, 184, + 191, 183, 141, 142, 143, 144, 145, 146 +}; +#else /* ascii rather than ebcdic */ 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, @@ -1781,6 +1866,7 @@ EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */ 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 141, 142, 143, 144, 145, 146 }; +#endif #else EXTCONST unsigned char freq[]; #endif @@ -1994,6 +2080,12 @@ typedef void *Thread; #endif #ifdef PERL_OBJECT +/* + * The following is a buffer where new variables must + * be defined to maintain binary compatibility with PERL_OBJECT + * for 5.005 + */ +PERLVAR(object_compatibility[30], char) }; #include "objpp.h" @@ -21,7 +21,7 @@ dep(void) } #endif -#line 16 "perly.c" +#line 30 "perly.y" #define YYERRCODE 256 short yylhs[] = { -1, 45, 0, 9, 7, 10, 8, 11, 11, 11, 12, @@ -1280,11 +1280,13 @@ int yydebug; int yynerrs; int yyerrflag; int yychar; +short *yyssp; +YYSTYPE *yyvsp; YYSTYPE yyval; YYSTYPE yylval; -#line 635 "perly.y" +#line 643 "perly.y" /* PROGRAM */ -#line 1349 "perly.c" +#line 1353 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1513,7 +1515,7 @@ yyreduce: switch (yyn) { case 1: -#line 86 "perly.y" +#line 94 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (PL_debug & 1); @@ -1522,50 +1524,50 @@ case 1: } break; case 2: -#line 93 "perly.y" +#line 101 "perly.y" { newPROG(yyvsp[0].opval); } break; case 3: -#line 97 "perly.y" +#line 105 "perly.y" { if (PL_copline > (line_t)yyvsp[-3].ival) PL_copline = yyvsp[-3].ival; yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 4: -#line 103 "perly.y" +#line 111 "perly.y" { yyval.ival = block_start(TRUE); } break; case 5: -#line 107 "perly.y" +#line 115 "perly.y" { if (PL_copline > (line_t)yyvsp[-3].ival) PL_copline = yyvsp[-3].ival; yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); } break; case 6: -#line 113 "perly.y" +#line 121 "perly.y" { yyval.ival = block_start(FALSE); } break; case 7: -#line 117 "perly.y" +#line 125 "perly.y" { yyval.opval = Nullop; } break; case 8: -#line 119 "perly.y" +#line 127 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 9: -#line 121 "perly.y" +#line 129 "perly.y" { yyval.opval = append_list(OP_LINESEQ, (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); PL_pad_reset_pending = TRUE; if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; } break; case 10: -#line 128 "perly.y" +#line 136 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; case 12: -#line 131 "perly.y" +#line 139 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1576,76 +1578,76 @@ case 12: PL_expect = XSTATE; } break; case 13: -#line 140 "perly.y" +#line 148 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); PL_expect = XSTATE; } break; case 14: -#line 145 "perly.y" +#line 153 "perly.y" { yyval.opval = Nullop; } break; case 15: -#line 147 "perly.y" +#line 155 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 16: -#line 149 "perly.y" +#line 157 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 17: -#line 151 "perly.y" +#line 159 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 18: -#line 153 "perly.y" +#line 161 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 19: -#line 155 "perly.y" +#line 163 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; case 20: -#line 157 "perly.y" +#line 165 "perly.y" { yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival, Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); } break; case 21: -#line 162 "perly.y" +#line 170 "perly.y" { yyval.opval = Nullop; } break; case 22: -#line 164 "perly.y" +#line 172 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 23: -#line 166 "perly.y" +#line 174 "perly.y" { PL_copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, Nullch, newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); PL_hints |= HINT_BLOCK_SCOPE; } break; case 24: -#line 173 "perly.y" +#line 181 "perly.y" { PL_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 177 "perly.y" +#line 185 "perly.y" { PL_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 26: -#line 183 "perly.y" +#line 191 "perly.y" { yyval.opval = Nullop; } break; case 27: -#line 185 "perly.y" +#line 193 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 28: -#line 189 "perly.y" +#line 197 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1653,7 +1655,7 @@ case 28: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: -#line 195 "perly.y" +#line 203 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1661,23 +1663,23 @@ case 29: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 30: -#line 201 "perly.y" +#line 209 "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 31: -#line 204 "perly.y" +#line 212 "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 32: -#line 208 "perly.y" +#line 216 "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 33: -#line 212 "perly.y" +#line 220 "perly.y" { OP *forop = append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval), newWHILEOP(0, 1, (LOOP*)Nullop, @@ -1687,89 +1689,89 @@ case 33: yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); } break; case 34: -#line 220 "perly.y" +#line 228 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 35: -#line 226 "perly.y" +#line 234 "perly.y" { yyval.opval = Nullop; } break; case 37: -#line 231 "perly.y" +#line 239 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; case 39: -#line 236 "perly.y" +#line 244 "perly.y" { yyval.opval = invert(scalar(yyvsp[0].opval)); } break; case 40: -#line 240 "perly.y" +#line 248 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 41: -#line 244 "perly.y" +#line 252 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 42: -#line 248 "perly.y" +#line 256 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 43: -#line 252 "perly.y" +#line 260 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 44: -#line 256 "perly.y" +#line 264 "perly.y" { yyval.pval = Nullch; } break; case 46: -#line 261 "perly.y" +#line 269 "perly.y" { yyval.ival = 0; } break; case 47: -#line 263 "perly.y" +#line 271 "perly.y" { yyval.ival = 0; } break; case 48: -#line 265 "perly.y" +#line 273 "perly.y" { yyval.ival = 0; } break; case 49: -#line 267 "perly.y" +#line 275 "perly.y" { yyval.ival = 0; } break; case 50: -#line 271 "perly.y" +#line 279 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 51: -#line 274 "perly.y" +#line 282 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 52: -#line 275 "perly.y" +#line 283 "perly.y" { yyval.opval = Nullop; } break; case 53: -#line 279 "perly.y" +#line 287 "perly.y" { newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 54: -#line 283 "perly.y" +#line 291 "perly.y" { yyval.ival = start_subparse(FALSE, 0); } break; case 55: -#line 287 "perly.y" +#line 295 "perly.y" { yyval.ival = start_subparse(FALSE, CVf_ANON); } break; case 56: -#line 291 "perly.y" +#line 299 "perly.y" { yyval.ival = start_subparse(TRUE, 0); } break; case 57: -#line 294 "perly.y" +#line 302 "perly.y" { char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) @@ -1777,297 +1779,297 @@ case 57: yyval.opval = yyvsp[0].opval; } break; case 58: -#line 302 "perly.y" +#line 310 "perly.y" { yyval.opval = Nullop; } break; case 60: -#line 306 "perly.y" +#line 314 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 61: -#line 307 "perly.y" +#line 315 "perly.y" { yyval.opval = Nullop; PL_expect = XSTATE; } break; case 62: -#line 311 "perly.y" +#line 319 "perly.y" { package(yyvsp[-1].opval); } break; case 63: -#line 313 "perly.y" +#line 321 "perly.y" { package(Nullop); } break; case 64: -#line 317 "perly.y" +#line 325 "perly.y" { CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ } break; case 65: -#line 319 "perly.y" +#line 327 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 66: -#line 323 "perly.y" +#line 331 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 67: -#line 325 "perly.y" +#line 333 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 69: -#line 330 "perly.y" +#line 338 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 70: -#line 332 "perly.y" +#line 340 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 72: -#line 337 "perly.y" +#line 345 "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 73: -#line 340 "perly.y" +#line 348 "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 74: -#line 343 "perly.y" +#line 351 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; case 75: -#line 348 "perly.y" +#line 356 "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 76: -#line 353 "perly.y" +#line 361 "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 77: -#line 358 "perly.y" +#line 366 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 78: -#line 360 "perly.y" +#line 368 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 79: -#line 362 "perly.y" +#line 370 "perly.y" { yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 80: -#line 364 "perly.y" +#line 372 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; case 83: -#line 374 "perly.y" +#line 382 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 84: -#line 376 "perly.y" +#line 384 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 85: -#line 378 "perly.y" +#line 386 "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 86: -#line 382 "perly.y" +#line 390 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 87: -#line 384 "perly.y" +#line 392 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 88: -#line 386 "perly.y" +#line 394 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 89: -#line 388 "perly.y" +#line 396 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 90: -#line 390 "perly.y" +#line 398 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 91: -#line 392 "perly.y" +#line 400 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 92: -#line 394 "perly.y" +#line 402 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 93: -#line 396 "perly.y" +#line 404 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 94: -#line 398 "perly.y" +#line 406 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 95: -#line 400 "perly.y" +#line 408 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 96: -#line 402 "perly.y" +#line 410 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 97: -#line 405 "perly.y" +#line 413 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 98: -#line 407 "perly.y" +#line 415 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 99: -#line 409 "perly.y" +#line 417 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 100: -#line 411 "perly.y" +#line 419 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 101: -#line 413 "perly.y" +#line 421 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 102: -#line 415 "perly.y" +#line 423 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 103: -#line 418 "perly.y" +#line 426 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 104: -#line 421 "perly.y" +#line 429 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 105: -#line 424 "perly.y" +#line 432 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 106: -#line 427 "perly.y" +#line 435 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 107: -#line 429 "perly.y" +#line 437 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 108: -#line 431 "perly.y" +#line 439 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 109: -#line 433 "perly.y" +#line 441 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 110: -#line 435 "perly.y" +#line 443 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 111: -#line 437 "perly.y" +#line 445 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 112: -#line 439 "perly.y" +#line 447 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 113: -#line 441 "perly.y" +#line 449 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 114: -#line 443 "perly.y" +#line 451 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 115: -#line 445 "perly.y" +#line 453 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); } break; case 116: -#line 447 "perly.y" +#line 455 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 117: -#line 449 "perly.y" +#line 457 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 118: -#line 451 "perly.y" +#line 459 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 455 "perly.y" +#line 463 "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 120: -#line 459 "perly.y" +#line 467 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 461 "perly.y" +#line 469 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 122: -#line 463 "perly.y" +#line 471 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 123: -#line 465 "perly.y" +#line 473 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 124: -#line 468 "perly.y" +#line 476 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 125: -#line 473 "perly.y" +#line 481 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 126: -#line 478 "perly.y" +#line 486 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 127: -#line 480 "perly.y" +#line 488 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 128: -#line 482 "perly.y" +#line 490 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2075,7 +2077,7 @@ case 128: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 129: -#line 488 "perly.y" +#line 496 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2084,37 +2086,37 @@ case 129: PL_expect = XOPERATOR; } break; case 130: -#line 495 "perly.y" +#line 503 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 131: -#line 497 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 132: -#line 499 "perly.y" +#line 507 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 133: -#line 501 "perly.y" +#line 509 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 134: -#line 504 "perly.y" +#line 512 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 135: -#line 507 "perly.y" +#line 515 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 136: -#line 509 "perly.y" +#line 517 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 137: -#line 511 "perly.y" +#line 519 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2124,7 +2126,7 @@ case 137: )),Nullop)); dep();} break; case 138: -#line 519 "perly.y" +#line 527 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2135,161 +2137,161 @@ case 138: )))); dep();} break; case 139: -#line 528 "perly.y" +#line 536 "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 140: -#line 532 "perly.y" +#line 540 "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 141: -#line 537 "perly.y" +#line 545 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 142: -#line 540 "perly.y" +#line 548 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 143: -#line 544 "perly.y" +#line 552 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; } break; case 144: -#line 547 "perly.y" +#line 555 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 145: -#line 549 "perly.y" +#line 557 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 146: -#line 551 "perly.y" +#line 559 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 147: -#line 553 "perly.y" +#line 561 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 148: -#line 555 "perly.y" +#line 563 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 149: -#line 557 "perly.y" +#line 565 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 150: -#line 560 "perly.y" +#line 568 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 151: -#line 562 "perly.y" +#line 570 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 152: -#line 564 "perly.y" +#line 572 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 153: -#line 567 "perly.y" +#line 575 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 154: -#line 569 "perly.y" +#line 577 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 155: -#line 571 "perly.y" +#line 579 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 156: -#line 573 "perly.y" +#line 581 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 159: -#line 579 "perly.y" +#line 587 "perly.y" { yyval.opval = Nullop; } break; case 160: -#line 581 "perly.y" +#line 589 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 161: -#line 585 "perly.y" +#line 593 "perly.y" { yyval.opval = Nullop; } break; case 162: -#line 587 "perly.y" +#line 595 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 163: -#line 589 "perly.y" +#line 597 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 164: -#line 592 "perly.y" +#line 600 "perly.y" { yyval.ival = 0; } break; case 165: -#line 593 "perly.y" +#line 601 "perly.y" { yyval.ival = 1; } break; case 166: -#line 597 "perly.y" +#line 605 "perly.y" { PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 167: -#line 601 "perly.y" +#line 609 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 168: -#line 605 "perly.y" +#line 613 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 169: -#line 609 "perly.y" +#line 617 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 170: -#line 613 "perly.y" +#line 621 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 171: -#line 617 "perly.y" +#line 625 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 172: -#line 621 "perly.y" +#line 629 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 173: -#line 625 "perly.y" +#line 633 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 174: -#line 627 "perly.y" +#line 635 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 175: -#line 629 "perly.y" +#line 637 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 176: -#line 632 "perly.y" +#line 640 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2266 "perly.c" +#line 2270 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -63,4 +63,3 @@ typedef union { GV *gvval; } YYSTYPE; extern YYSTYPE yylval; -extern YYSTYPE yylval; @@ -26,6 +26,10 @@ dep(void) %start prog +%{ +#ifndef OEMVS +%} + %union { I32 ival; char *pval; @@ -33,6 +37,10 @@ dep(void) GV *gvval; } +%{ +#endif /* OEMVS */ +%} + %token <ival> '{' ')' %token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF diff --git a/perly_c.diff b/perly_c.diff index 0ee7cb2d7f..aa0555b034 100644 --- a/perly_c.diff +++ b/perly_c.diff @@ -1,92 +1,96 @@ -Index: perly.c -*** perly.c.old Wed Jun 10 03:48:43 1998 ---- perly.c Wed Jun 10 03:55:10 1998 +*** perly.c.orig Tue Jul 28 15:02:41 1998 +--- perly.c Tue Jul 28 15:14:54 1998 *************** -*** 7,10 **** ---- 7,18 ---- +*** 7,11 **** +--- 7,19 ---- #include "perl.h" + #ifdef PERL_OBJECT -+ static void + static void + Dep(CPerlObj *pPerl) + { + pPerl->deprecate("\"do\" to call subroutines"); + } + #define dep() Dep(this) + #else - static void ++ static void dep(void) + { *************** -*** 12,82 **** +*** 12,86 **** deprecate("\"do\" to call subroutines"); } -! #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 + #line 30 "perly.y" +- #ifndef OEMVS +- #line 33 "perly.y" +- typedef union { +- I32 ival; +- char *pval; +- OP *opval; +- GV *gvval; +- } YYSTYPE; +- #line 41 "perly.y" +- #endif /* OEMVS */ +- #line 27 "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, --- 20,26 ---- @@ -94,23 +98,19 @@ Index: perly.c } + #endif -! #line 16 "perly.c" + #line 30 "perly.y" #define YYERRCODE 256 short yylhs[] = { -1, *************** -*** 1337,1361 **** - int yyerrflag; - int yychar; -- short *yyssp; -- YYSTYPE *yyvsp; +*** 1345,1365 **** YYSTYPE yyval; YYSTYPE yylval; - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 635 "perly.y" + #line 643 "perly.y" /* PROGRAM */ -! #line 1349 "y.tab.c" +! #line 1353 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -124,14 +124,12 @@ Index: perly.c if (yys = getenv("YYDEBUG")) { ---- 1281,1347 ---- - int yyerrflag; - int yychar; +--- 1285,1349 ---- YYSTYPE yyval; YYSTYPE yylval; - #line 635 "perly.y" + #line 643 "perly.y" /* PROGRAM */ -! #line 1349 "perly.c" +! #line 1353 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -178,7 +176,7 @@ Index: perly.c extern char *getenv(); + #endif + #endif -+ + + struct ysv *ysave; + New(73, ysave, 1, struct ysv); + SAVEDESTRUCTOR(yydestruct, ysave); @@ -188,13 +186,13 @@ Index: perly.c + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; - ++ + #if YYDEBUG if (yys = getenv("YYDEBUG")) { *************** -*** 1370,1373 **** ---- 1356,1369 ---- +*** 1374,1377 **** +--- 1358,1371 ---- yychar = (-1); + /* @@ -210,36 +208,39 @@ Index: perly.c yyssp = yyss; yyvsp = yyvs; *************** -*** 1385,1389 **** +*** 1389,1393 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } ---- 1381,1385 ---- +--- 1383,1387 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } *************** -*** 1395,1404 **** +*** 1399,1403 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif - if (yyssp >= yyss + yystacksize - 1) - { -! goto yyoverflow; - } - *++yyssp = yystate = yytable[yyn]; ---- 1391,1414 ---- +--- 1393,1397 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif +*************** +*** 1404,1408 **** + if (yyssp >= yyss + yystacksize - 1) + { +! goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; +--- 1398,1416 ---- if (yyssp >= yyss + yystacksize - 1) { ! /* @@ -260,7 +261,7 @@ Index: perly.c } *++yyssp = yystate = yytable[yyn]; *************** -*** 1436,1445 **** +*** 1440,1449 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, error recovery shifting\ @@ -271,7 +272,7 @@ Index: perly.c ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; ---- 1446,1470 ---- +--- 1448,1472 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -298,14 +299,14 @@ Index: perly.c } *++yyssp = yystate = yytable[yyn]; *************** -*** 1451,1456 **** +*** 1455,1460 **** #if YYDEBUG if (yydebug) ! printf("yydebug: error recovery discarding state %d\n", ! *yyssp); #endif if (yyssp <= yyss) goto yyabort; ---- 1476,1482 ---- +--- 1478,1484 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -314,14 +315,14 @@ Index: perly.c #endif if (yyssp <= yyss) goto yyabort; *************** -*** 1469,1474 **** +*** 1473,1478 **** 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 ---- 1495,1501 ---- +--- 1497,1503 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, @@ -330,40 +331,40 @@ Index: perly.c } #endif *************** -*** 1479,1483 **** +*** 1483,1487 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif ---- 1506,1510 ---- +--- 1508,1512 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif *************** -*** 2263,2267 **** +*** 2267,2271 **** { yyval.opval = yyvsp[0].opval; } break; -! #line 2266 "y.tab.c" +! #line 2270 "y.tab.c" } yyssp -= yym; ---- 2290,2294 ---- +--- 2292,2296 ---- { yyval.opval = yyvsp[0].opval; } break; -! #line 2266 "perly.c" +! #line 2270 "perly.c" } yyssp -= yym; *************** -*** 2273,2278 **** +*** 2277,2282 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state 0 to\ ! state %d\n", YYFINAL); #endif yystate = YYFINAL; ---- 2300,2306 ---- +--- 2302,2308 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -372,20 +373,20 @@ Index: perly.c #endif yystate = YYFINAL; *************** -*** 2288,2292 **** +*** 2292,2296 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } ---- 2316,2320 ---- +--- 2318,2322 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } *************** -*** 2303,2312 **** +*** 2307,2316 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state %d \ @@ -396,7 +397,7 @@ Index: perly.c ! goto yyoverflow; } *++yyssp = yystate; ---- 2331,2355 ---- +--- 2333,2357 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -423,7 +424,7 @@ Index: perly.c } *++yyssp = yystate; *************** -*** 2314,2321 **** +*** 2318,2325 **** goto yyloop; yyoverflow: ! yyerror("yacc stack overflow"); @@ -432,7 +433,7 @@ Index: perly.c yyaccept: ! return (0); } ---- 2357,2364 ---- +--- 2359,2366 ---- goto yyloop; yyoverflow: ! yyerror("Out of memory for yacc stack"); diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 7c94d377c7..c239cfe324 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -279,8 +279,8 @@ belongs to C<joe>. It is possible for the Perl subroutine you are calling to terminate 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 +existing. By default, when either of these events occurs, the +process will terminate immediately. If you want to trap this type of event, specify the G_EVAL flag. It will put an I<eval { }> around the subroutine call. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index d43f657b14..a3c6b6cc05 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -165,7 +165,7 @@ perl program. The C backend generates C code that captures perl's state just before execution begins. It eliminates the compile-time overheads of the regular perl interpreter, but the run-time performance remains comparatively the same. The CC backend generates optimized C code -equivivalent to the code path at run-time. The CC backend has greater +equivalent to the code path at run-time. The CC backend has greater potential for big optimizations, but only a few optimizations are implemented currently. The Bytecode backend generates a platform independent bytecode representation of the interpreter's state @@ -208,12 +208,12 @@ Changes in the RE engine: New types of nodes to process (SUBEXPR)* and similar expressions quickly, used if the SUBEXPR has no side effects and matches strings of the same length; - better optimizations by lookup for constant substrings; + Better optimizations by lookup for constant substrings; Better search for constants substrings anchored by $ ; Changes in Perl code using RE engine: - more optimizations to s/longer/short/; + More optimizations to s/longer/short/; study() was not working; /blah/ may be optimized to an analogue of index() if $& $` $' not seen; Unneeded copying of matched-against string removed; @@ -230,7 +230,7 @@ Note that only the major bug fixes are listed here. See F<Changes> for others. possibility of a segfault; (ZERO-LENGTH)* could segfault; (ZERO-LENGTH)* was prohibited; - Long RE were not allowed; + Long REs were not allowed; /RE/g could skip matches at the same position after a zero-length match; @@ -253,9 +253,10 @@ See L<New C<qr//> operator>. =item Other improvements - better debugging output (possibly with colors), even from non-debugging Perl; + Better debugging output (possibly with colors), + even from non-debugging Perl; RE engine code now looks like C, not like assembler; - behaviour of RE modifiable by `use re' directive; + Behaviour of RE modifiable by `use re' directive; Improved documentation; Test suite significantly extended; Syntax [:^upper:] etc., reserved inside character classes; @@ -455,7 +456,7 @@ substr() can now both return and replace in one operation. The optional =head2 Negative LENGTH argument to splice -Splice() with a negative LENGTH argument now work similar to what the +splice() with a negative LENGTH argument now work similar to what the LENGTH did for substr(). Previously a negative LENGTH was treated as 0. See L<perlfunc/splice>. @@ -501,6 +502,8 @@ DOS is now supported under the DJGPP tools. See L<README.dos>. MPE/iX is now supported. See L<README.mpeix>. +MVS (OS390) is now supported. See L<README.os390>. + =head2 Changes in existing support Win32 support has been vastly enhanced. Support for Perl Object, a C++ diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 5fdeb70ab8..8d213235a8 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1538,7 +1538,7 @@ backwards. =item Modification of non-creatable hash value attempted, subscript "%s" -(F) You tried to make a hash value spring into existence, and it couldn't +(P) You tried to make a hash value spring into existence, and it couldn't be created for some peculiar reason. =item Module name must be constant @@ -2479,10 +2479,12 @@ if the error went away. Sort of the cybernetic version of S<20 questions>. instead of Perl. Check the #! line, or manually feed your script into Perl yourself. -=item System V IPC is not implemented on this machine +=item System V %s is not implemented on this machine -(F) You tried to do something with a function beginning with "sem", "shm", -or "msg". See L<perlfunc/semctl>, for example. +(F) You tried to do something with a function beginning with "sem", +"shm", or "msg" but that System V IPC is not implemented in your +machine. In some machines the functionality can exist but be +unconfigured. Consult your system support. =item Syswrite on closed filehandle diff --git a/pod/perlembed.pod b/pod/perlembed.pod index 0323fd1110..c09d6e33cb 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -35,6 +35,8 @@ Read on... =head2 ROADMAP +=over 5 + L<Compiling your C program> L<Adding a Perl interpreter to your C program> diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod index 1d81077760..e6be112008 100644 --- a/pod/perlfaq.pod +++ b/pod/perlfaq.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq - frequently asked questions about Perl ($Date: 1998/07/20 23:12:17 $) +perlfaq - frequently asked questions about Perl ($Date: 1998/08/05 12:09:32 $) =head1 DESCRIPTION @@ -117,7 +117,7 @@ in respect of this information or its use. =over 4 -=head 22/June/98 +=item 22/June/98 Significant changes throughout in preparation for the 5.005 release. diff --git a/pod/perlfaq1.pod b/pod/perlfaq1.pod index ee071e4216..5a95f19c79 100644 --- a/pod/perlfaq1.pod +++ b/pod/perlfaq1.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq1 - General Questions About Perl ($Revision: 1.14 $, $Date: 1998/06/14 22:15:25 $) +perlfaq1 - General Questions About Perl ($Revision: 1.15 $, $Date: 1998/08/05 11:52:24 $) =head1 DESCRIPTION @@ -29,7 +29,8 @@ distribution policy of perl. Perl is supported by its users. The core, the standard Perl library, the optional modules, and the documentation you're reading now were all written by volunteers. See the personal note at the end of the README file in the perl source -distribution for more details. +distribution for more details. See L<perlhist> (new as of 5.005) +for Perl's milestone releases. In particular, the core development team (known as the Perl Porters) are a rag-tag band of highly altruistic individuals @@ -51,10 +52,10 @@ users the informal support will more than suffice. See the answer to You should definitely use version 5. Version 4 is old, limited, and no longer maintained; its last patch (4.036) was in 1992. The most -recent production release is 5.004_01. Further references to the Perl +recent production release is 5.005_01. Further references to the Perl language in this document refer to this production release unless otherwise specified. There may be one or more official bug fixes for -5.004_01 by the time you read this, and also perhaps some experimental +5.005_01 by the time you read this, and also perhaps some experimental versions on the way to the next release. =head2 What are perl4 and perl5? @@ -210,7 +211,7 @@ available from http://www.perl.com/CPAN/misc/japh . Over a hundred quips by Larry, from postings of his or source code, can be found at http://www.perl.com/CPAN/misc/lwall-quotes . -=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.004/Perl instead of some other language)? +=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)? If your manager or employees are wary of unsupported software, or software which doesn't officially ship with your Operating System, you @@ -240,10 +241,15 @@ for any given task. Also mention that the difference between version (Well, ok, maybe not quite that distinct, but you get the idea.) If you want support and a reasonable guarantee that what you're developing will continue to work in the future, then you have to run -the supported version. That probably means running the 5.004 release, -although 5.003 isn't that bad (it's just one year and one release +the supported version. That probably means running the 5.005 release, +although 5.004 isn't that bad (it's just one year and one release behind). Several important bugs were fixed from the 5.000 through -5.002 versions, though, so try upgrading past them if possible. +5.003 versions, though, so try upgrading past them if possible. + +Of particular note is the massive bughunt for buffer overflow +problems that went into the 5.004 release. All releases prior to +that, including perl4, are considered insecure and should be upgraded +as soon as possible. =head1 AUTHOR AND COPYRIGHT diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index c743a0efc8..918e9369ae 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.24 $, $Date: 1998/07/20 23:40:28 $) +perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.25 $, $Date: 1998/08/05 11:47:25 $) =head1 DESCRIPTION @@ -11,22 +11,25 @@ related matters. =head2 What machines support Perl? Where do I get it? The standard release of Perl (the one maintained by the perl -development team) is distributed only in source code form. You can -find this at http://www.perl.com/CPAN/src/latest.tar.gz, which is a -gzipped archive in POSIX tar format. This source builds with no -porting whatsoever on most Unix systems (Perl's native environment), -as well as Plan 9, VMS, QNX, OS/2, and the Amiga. - -Although it's rumored that the (imminent) 5.004 release may build -on Windows NT, this is yet to be proven. Binary distributions -for 32-bit Microsoft systems and for Apple systems can be found -http://www.perl.com/CPAN/ports/ directory. Because these are not part of -the standard distribution, they may and in fact do differ from the base -Perl port in a variety of ways. You'll have to check their respective -release notes to see just what the differences are. These differences -can be either positive (e.g. extensions for the features of the particular -platform that are not supported in the source release of perl) or negative -(e.g. might be based upon a less current source release of perl). +development team) is distributed only in source code form. You +can find this at http://www.perl.com/CPAN/src/latest.tar.gz, which +in standard Internet format (a gzipped archive in POSIX tar format). + +Perl builds and runs on a bewildering number of platforms. Virtually +all known and current Unix derivatives are supported (Perl's native +platform), as are proprietary systems like VMS, DOS, OS/2, Windows, +QNX, BeOS, and the Amiga. There are also the beginnings of support +for MPE/iX. + +Binary distributions for some proprietary platforms, including +Apple systems can be found http://www.perl.com/CPAN/ports/ directory. +Because these are not part of the standard distribution, they may +and in fact do differ from the base Perl port in a variety of ways. +You'll have to check their respective release notes to see just +what the differences are. These differences can be either positive +(e.g. extensions for the features of the particular platform that +are not supported in the source release of perl) or negative (e.g. +might be based upon a less current source release of perl). A useful FAQ for Win32 Perl users is http://www.endcontsw.com/people/evangelo/Perl_for_Win32_FAQ.html @@ -177,25 +180,41 @@ these are good, some are ok, but many aren't worth your money. Tom Christiansen maintains a list of these books, some with extensive reviews, at http://www.perl.com/perl/critiques/index.html. -The incontestably definitive reference book on Perl, written by the -creator of Perl and his apostles, is now in its second edition and -fourth printing. +The incontestably definitive reference book on Perl, written by +the creator of Perl, is now in its second edition: Programming Perl (the "Camel Book"): Authors: Larry Wall, Tom Christiansen, and Randal Schwartz ISBN 1-56592-149-6 (English) ISBN 4-89052-384-7 (Japanese) - (French, German, and Italian translations also available) + URL: http://www.oreilly.com/catalog/pperl2/ + (French, German, Italian, and Hungarian translations also + available) -Note that O'Reilly books are color-coded: turquoise (some would call -it teal) covers indicate perl5 coverage, while magenta (some would -call it pink) covers indicate perl4 only. Check the cover color -before you buy! +The companion volume to the Camel containing thousands +of real-world examples, mini-tutorials, and complete programs +(first premiering at the 1998 Perl Conference), is: + + The Perl Cookbook (the "Ram Book"): + Authors: Tom Christiansen and Nathan Torkington, + with Foreword by Larry Wall + ISBN: 1-56592-243-3 + URL: http://perl.oreilly.com/cookbook/ If you're already a hard-core systems programmer, then the Camel Book might suffice for you to learn Perl from. But if you're not, check -out I<Learning Perl> by Randal and Tom. The second edition of "Llama -Book" has a blue cover, and is updated for the 5.004 release of Perl. +out: + + Learning Perl (the "Llama Book"): + Authors: Randal Schwartz and Tom Christiansen + with Foreword by Larry Wall + ISBN: 1-56592-284-0 + URL: http://www.oreilly.com/catalog/lperl2/ + +Despite the picture at the URL above, the second edition of "Llama +Book" really has a blue cover, and is updated for the 5.004 release +of Perl. Various foreign language editions are available, including +I<Learning Perl on Win32 Systems> (the Gecko Book). If you're not an accidental programmer, but a more serious and possibly even degreed computer scientist who doesn't need as much hand-holding as @@ -211,8 +230,8 @@ See http://www.ora.com/ on the Web. What follows is a list of the books that the FAQ authors found personally useful. Your mileage may (but, we hope, probably won't) vary. -Recommended books on (or muchly on) Perl are the following. -Those marked with a star may be ordered from O'Reilly. +Recommended books on (or muchly on) Perl follow; those marked with +a star may be ordered from O'Reilly. =over @@ -228,6 +247,7 @@ Those marked with a star may be ordered from O'Reilly. *Learning Perl [2nd edition] by Randal L. Schwartz and Tom Christiansen + with foreword by Larry Wall *Learning Perl on Win32 Systems by Randal L. Schwartz, Erik Olson, and Tom Christiansen, @@ -273,9 +293,10 @@ The first and only periodical devoted to All Things Perl, I<The Perl Journal> contains tutorials, demonstrations, case studies, announcements, contests, and much more. TPJ has columns on web development, databases, Win32 Perl, graphical programming, regular -expressions, and networking, and sponsors the Obfuscated Perl Contest. -It is published quarterly by Jon Orwant. See http://www.tpj.com/ or -send mail to subscriptions@tpj.com. +expressions, and networking, and sponsors the Obfuscated Perl +Contest. It is published quarterly under the gentle hand of its +editor, Jon Orwant. See http://www.tpj.com/ or send mail to +subscriptions@tpj.com. Beyond this, magazines that frequently carry high-quality articles on Perl are I<Web Techniques> (see http://www.webtechniques.com/), @@ -297,9 +318,6 @@ following list is I<not> the complete list of CPAN mirrors. http://www.cs.ruu.nl/pub/PERL/CPAN/ ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ -http:/www.oasis.leo.org/perl/ has, amongst other things, source to -versions 1 through 5 of Perl. - =head2 What mailing lists are there for perl? Most of the major modules (tk, CGI, libwww-perl) have their own @@ -427,6 +445,8 @@ For more information, contact the The Perl Clinic: Web: http://www.perl.co.uk/ Email: perl-support-info@perl.co.uk or Tim.Bunce@ig.co.uk +See also www.perl.com for updates on training and support. + =head2 Where do I send bug reports? If you are reporting a bug in the perl interpreter or the modules @@ -443,7 +463,7 @@ Read the perlbug(1) man page (perl5.004 or later) for more information. =head2 What is perl.com? perl.org? The Perl Institute? -The perl.com domain is Tom Christiansen's domain. He created it as a +The perl.com domain is managed by Tom Christiansen, who created it as a public service long before perl.org came about. Despite the name, it's a pretty non-commercial site meant to be a clearinghouse for information about all things Perlian, accepting no paid advertisements, bouncy @@ -454,9 +474,7 @@ Systems, a software-oriented subsidiary of O'Reilly and Associates. perl.org is the official vehicle for The Perl Institute. The motto of TPI is "helping people help Perl help people" (or something like that). It's a non-profit organization supporting development, -documentation, and dissemination of perl. Current directors of TPI -include Larry Wall, Tom Christiansen, and Randal Schwartz, whom you -may have heard of somewhere else around here. +documentation, and dissemination of perl. =head2 How do I learn about object-oriented Perl programming? diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 11f105c48c..d06f2bef7a 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq3 - Programming Tools ($Revision: 1.28 $, $Date: 1998/07/16 22:08:49 $) +perlfaq3 - Programming Tools ($Revision: 1.29 $, $Date: 1998/08/05 11:57:04 $) =head1 DESCRIPTION @@ -372,10 +372,10 @@ you want to be sure your licence's wording will stand up in court. =head2 How can I compile my Perl program into byte code or C? Malcolm Beattie has written a multifunction backend compiler, -available from CPAN, that can do both these things. It is as of -Jul-1998 in late alpha release, which means it's fun to play with if -you're a programmer but not really for people looking for turn-key -solutions. +available from CPAN, that can do both these things. It is included +in the perl5.005 release, but is still considered experimental. +This means it's fun to play with if you're a programmer but not +really for people looking for turn-key solutions. Merely compiling into C does not in and of itself guarantee that your code will run very much faster. That's because except for lucky cases @@ -386,11 +386,6 @@ compilation time, leaving execution no more than 10-30% faster. A few rare programs actually benefit significantly (like several times faster), but this takes some tweaking of your code. -The 5.005 release of Perl itself, whose main goal is merging the various -non-Unix ports back into the one Perl source, will also have preliminary -(strictly beta) support for Malcolm's compiler and his light-weight -processes (sometimes called ``threads''). - You'll probably be astonished to learn that the current version of the compiler generates a compiled form of your script whose executable is just as big as the original perl executable, and then some. That's @@ -410,7 +405,7 @@ and compilation never stopped software piracy in the form of crackers, viruses, or bootleggers. The real advantage of the compiler is merely packaging, and once you see the size of what it makes (well, unless you use a shared I<libperl.so>), you'll probably want a complete -Perl install anywayt. +Perl install anyway. =head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]? diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index 0a47145a28..633f5f109b 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq4 - Data Manipulation ($Revision: 1.25 $, $Date: 1998/07/16 22:49:55 $) +perlfaq4 - Data Manipulation ($Revision: 1.26 $, $Date: 1998/08/05 12:04:00 $) =head1 DESCRIPTION @@ -177,7 +177,11 @@ You can find the week of the year by dividing this by 7: Of course, this believes that weeks start at zero. The Date::Calc module from CPAN has a lot of date calculation functions, including -day of the year, week of the year, and so on. +day of the year, week of the year, and so on. Note that not +all business consider ``week 1'' to be the same; for example, +American business often consider the first week with a Monday +in it to be Work Week #1, despite ISO 8601, which consider +WW1 to be the frist week with a Thursday in it. =head2 How can I compare two dates and find the difference? @@ -202,8 +206,9 @@ http://www.perl.com/CPAN/authors/David_Muir_Sharnoff/modules/Time/JulianDay.pm.g =head2 Does Perl have a year 2000 problem? Is Perl Y2K compliant? -Short answer: No, Perl does not have a Year 2000 problem. Yes, Perl -is Y2K compliant. +Short answer: No, Perl does not have a Year 2000 problem. Yes, +Perl is Y2K compliant. The programmers you're hired to use it, +however, probably are not. Long answer: Perl is just as Y2K compliant as your pencil--no more, and no less. The date and time functions supplied with perl (gmtime @@ -471,7 +476,7 @@ Or more nicely written as: s/\s+$//; } -This idiom takes advantage of the C<for(each)> loop's aliasing +This idiom takes advantage of the C<foreach> loop's aliasing behavior to factor out common code. You can do this on several strings at once, or arrays, or even the values of a hash if you use a slide: diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index e99cf426ca..c4036ff35d 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq8 - System Interaction ($Revision: 1.25 $, $Date: 1998/07/05 15:07:20 $) +perlfaq8 - System Interaction ($Revision: 1.26 $, $Date: 1998/08/05 12:20:28 $) =head1 DESCRIPTION @@ -1005,7 +1005,7 @@ Perl offers several different ways to include code from one file into another. Here are the deltas between the various inclusion constructs: 1) do $file is like eval `cat $file`, except the former: - 1.1: searches @INC. + 1.1: searches @INC and updates %INC. 1.2: bequeaths an *unrelated* lexical scope on the eval'ed code. 2) require $file is like do $file, except the former: diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index ec76881f63..e62532e0ce 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -225,6 +225,8 @@ the undefined value if the file doesn't exist. Despite the funny names, precedence is the same as any other named unary operator, and the argument may be parenthesized like any other unary operator. The operator may be any of: +X<-r>X<-w>X<-x>X<-o>X<-R>X<-W>X<-X>X<-O>X<-e>X<-z>X<-s>X<-f>X<-d>X<-l>X<-p> +X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C> -r File is readable by effective uid/gid. -w File is writable by effective uid/gid. @@ -917,6 +919,12 @@ scope like C<eval STRING> does. It's the same, however, in that it does reparse the file every time you call it, so you probably don't want to do this inside a loop. +If C<do> cannot read the file, it returns undef and sets C<$!> to the +error. If C<do> can read the file but cannot compile it, it +returns undef and sets an error message in C<$@>. If the file is +successfully compiled, C<do> returns the value of the last expression +evaluated. + Note that inclusion of library modules is better done with the C<use()> and C<require()> operators, which also do automatic error checking and raise an exception if there's a problem. @@ -3828,8 +3836,11 @@ FILENAME, MODE, PERMS. The possible values and flag bits of the MODE parameter are system-dependent; they are available via the standard module C<Fcntl>. -However, for historical reasons, some values are universal: zero means -read-only, one means write-only, and two means read/write. +For historical reasons, some values work on almost every system +supported by perl: zero means read-only, one means write-only, and two +means read/write. We know that these values do I<not> work under +OS/390 Unix and on the Macintosh; you probably don't want to use them +in new code. If the file named by FILENAME does not exist and the C<open()> call creates it (typically because MODE includes the C<O_CREAT> flag), then the value of diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 431f44e451..9ed8b6f52e 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -6,7 +6,7 @@ perlhist - the Perl history records =for RCS # -# $Id: perlhist.pod,v 1.41 1998/06/09 15:20:18 jhi Exp $ +# $Id: perlhist.pod,v 1.48 1998/08/03 08:50:12 jhi Exp $ # =end RCS @@ -32,7 +32,7 @@ Perl history in brief, by Larry Wall: Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, Nick Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie, Gurusamy -Sarathy. +Sarathy, Graham Barr. =head2 PUMPKIN? @@ -70,16 +70,16 @@ the strings?). Larry 0 Classified. Don't ask. Larry 1.000 1987-Dec-18 - + 1.001..10 1988-Jan-30 1.011..14 1988-Feb-02 - + Larry 2.000 1988-Jun-05 - + 2.001 1988-Jun-28 - + Larry 3.000 1989-Oct-18 - + 3.001 1989-Oct-26 3.002..4 1989-Nov-11 3.005 1989-Nov-18 @@ -96,9 +96,9 @@ the strings?). 3.041 1990-Nov-13 3.042..43 1990-Jan-?? 3.044 1991-Jan-12 - + Larry 4.000 1991-Mar-21 - + 4.001..3 1991-Apr-12 4.004..9 1991-Jun-07 4.010 1991-Jun-10 @@ -108,7 +108,7 @@ the strings?). 4.034 1992-Jun-11 4.035 1992-Jun-23 Larry 4.036 1993-Feb-05 Very stable. - + 5.000alpha1 1993-Jul-31 5.000alpha2 1993-Aug-16 5.000alpha3 1993-Oct-10 @@ -148,9 +148,9 @@ the strings?). 5.000b3f 1994-Sep-30 5.000b3g 1994-Oct-04 Andy 5.000b3h 1994-Oct-07 - + Larry 5.000 1994-Oct-18 - + Andy 5.000a 1994-Dec-19 5.000b 1995-Jan-18 5.000c 1995-Jan-18 @@ -165,9 +165,9 @@ the strings?). 5.000l 1995-Feb-21 5.000m 1995-???-?? 5.000n 1995-Mar-07 - + Larry 5.001 1995-Mar-13 - + Andy 5.001a 1995-Mar-15 5.001b 1995-Mar-31 5.001c 1995-Apr-07 @@ -195,13 +195,13 @@ the strings?). Larry 5.002b3 1996-Feb-02 Andy 5.002gamma 1996-Feb-11 Larry 5.002delta 1996-Feb-27 - - Larry 5.002 1996-Feb-29 - + + Larry 5.002 1996-Feb-29 Prototypes. + Charles 5.002_01 1996-Mar-25 - + 5.003 1996-Jun-25 Security release. - + 5.003_01 1996-Jul-31 Nick 5.003_02 1996-Aug-10 Andy 5.003_03 1996-Aug-28 @@ -252,10 +252,10 @@ the strings?). 5.003_99 1997-May-01 5.003_99a 1997-May-09 p54rc1 1997-May-12 Release Candidates. - p54rc2 1997-May-14 - + p54rc2 1997-May-14 + Chip 5.004 1997-May-15 A major maintenance release. - + Tim 5.004_01 1997-Jun-13 The 5.004 maintenance track. 5.004_02 1997-Aug-07 5.004_03 1997-Sep-05 @@ -263,7 +263,9 @@ the strings?). 5.004m5t1 1998-Mar-04 Maintenance Trials (for 5.004_05). 5.004_04-m2 1997-May-01 5.004_04-m3 1998-May-15 - + 5.004_04-m4 1998-May-19 + 5.004_04-MT5 1998-Jul-21 + Malcolm 5.004_50 1997-Sep-09 The 5.005 development track. 5.004_51 1997-Oct-02 5.004_52 1997-Oct-15 @@ -288,10 +290,18 @@ the strings?). 5.004_71 1998-Jul-09 5.004_72 1998-Jul-12 5.004_73 1998-Jul-13 - 5.004_74 1998-Jul-14 - 5.004_75 1998-Jul-15 - 5.004_76 1998-Jul-21 - 5.005 1998-Jul-22 + 5.004_74 1998-Jul-14 5.005 beta candidate. + 5.004_75 1998-Jul-15 5.005 beta1. + 5.004_76 1998-Jul-21 5.005 beta2. + 5.005 1998-Jul-22 Oneperl. + + Sarathy 5.005_01 1998-Jul-27 The 5.005 maintenance track. + 5.005_02-T1 1998-Aug-02 + 5.005_02-T2 1998-Aug-05 + 5.005_02 1998-Aug-08 + Graham 5.005_03 1998- + + Sarathy 5.005_50 1998-Jul-26 The 5.006 development track. =head2 SELECTED RELEASE SIZES @@ -322,14 +332,19 @@ explained below. 5.003 1129 54 680 102 291 43 166 100 853 35 5.003_07 1231 60 748 106 396 53 213 137 976 39 5.004 1351 60 1230 136 408 51 355 161 1587 55 - 5.004_01 1356 60 1258 138 410 51 358 161 1587 55 + 5.004_01 1356 60 1258 138 410 51 358 161 1587 55 5.004_04 1375 60 1294 139 413 51 394 162 1629 55 5.004_51 1401 61 1260 140 413 53 358 162 1594 56 5.004_53 1422 62 1295 141 438 70 394 162 1637 56 5.004_56 1501 66 1301 140 447 74 408 165 1648 57 - 5.004_59 1555 72 1317 142 448 74 424 171 1678 58 + 5.004_59 1555 72 1317 142 448 74 424 171 1678 58 5.004_62 1602 77 1327 144 629 92 428 173 1674 58 5.004_65 1626 77 1358 146 615 92 446 179 1698 60 + 5.004_68 1856 74 1382 152 619 92 463 187 1784 60 + 5.004_70 1863 75 1456 154 675 92 494 194 1809 60 + 5.004_73 1874 76 1467 152 762 102 506 196 1883 61 + 5.004_75 1877 76 1467 152 770 103 508 196 1896 62 + 5.005 1896 76 1469 152 795 103 509 197 1945 63 The "core"..."doc" mean the following files from the Perl source code distribution. The glob notation ** means recursively, (.) means @@ -347,62 +362,84 @@ the Perl source distribution for somewhat more selected releases. ====================================================================== Legend: kB # - 1.014 2.001 3.044 4.000 4.019 4.036 - - atarist - - - - - - - - - - 113 31 - Configure 31 1 37 1 62 1 73 1 83 1 86 1 - eg - - 34 28 47 39 47 39 47 39 47 39 - emacs - - - - - - 67 4 67 4 67 4 - h2pl - - - - 12 12 12 12 12 12 12 12 - hints - - - - - - - - 5 42 11 56 - msdos - - - - 41 13 57 15 58 15 60 15 - os2 - - - - 63 22 81 29 81 29 113 31 - usub - - - - 21 16 25 7 43 8 43 8 - x2p 103 17 104 17 137 17 147 18 152 19 154 19 + 1.014 2.001 3.044 4.000 4.019 4.036 + + atarist - - - - - - - - - - 113 31 + Configure 31 1 37 1 62 1 73 1 83 1 86 1 + eg - - 34 28 47 39 47 39 47 39 47 39 + emacs - - - - - - 67 4 67 4 67 4 + h2pl - - - - 12 12 12 12 12 12 12 12 + hints - - - - - - - - 5 42 11 56 + msdos - - - - 41 13 57 15 58 15 60 15 + os2 - - - - 63 22 81 29 81 29 113 31 + usub - - - - 21 16 25 7 43 8 43 8 + x2p 103 17 104 17 137 17 147 18 152 19 154 19 ====================================================================== - 5.000a2 5.000a12h 5.000b3h 5.000 5.001m 5.002 5.003 - + 5.000a2 5.000a12h 5.000b3h 5.000 5.001m 5.002 5.003 + atarist 113 31 113 31 - - - - - - - - - - bench - - 0 1 - - - - - - - - - - Bugs 2 5 26 1 - - - - - - - - - - dlperl 40 5 - - - - - - - - - - - - do 127 71 - - - - - - - - - - - - - Configure - - 153 1 159 1 160 1 180 1 201 1 201 1 - Doc - - 26 1 75 7 11 1 11 1 - - - - - eg 79 58 53 44 51 43 54 44 54 44 54 44 54 44 - emacs 67 4 104 6 104 6 104 1 104 6 108 1 108 1 - h2pl 12 12 12 12 12 12 12 12 12 12 12 12 12 12 - hints 11 56 12 46 18 48 18 48 44 56 73 59 77 60 - msdos 60 15 60 15 - - - - - - - - - - - os2 113 31 113 31 - - - - - - 84 17 56 10 - U - - 62 8 112 42 - - - - - - - - + Configure - - 153 1 159 1 160 1 180 1 201 1 201 1 + Doc - - 26 1 75 7 11 1 11 1 - - - - + eg 79 58 53 44 51 43 54 44 54 44 54 44 54 44 + emacs 67 4 104 6 104 6 104 1 104 6 108 1 108 1 + h2pl 12 12 12 12 12 12 12 12 12 12 12 12 12 12 + hints 11 56 12 46 18 48 18 48 44 56 73 59 77 60 + msdos 60 15 60 15 - - - - - - - - - - + os2 113 31 113 31 - - - - - - 84 17 56 10 + U - - 62 8 112 42 - - - - - - - - usub 43 8 - - - - - - - - - - - - - utils - - - - - - - - - - 87 7 88 7 - vms - - 80 7 123 9 184 15 304 20 500 24 475 26 - x2p 171 22 171 21 162 20 162 20 279 20 280 20 280 20 + utils - - - - - - - - - - 87 7 88 7 + vms - - 80 7 123 9 184 15 304 20 500 24 475 26 + x2p 171 22 171 21 162 20 162 20 279 20 280 20 280 20 + + ====================================================================== + + 5.003_07 5.004 5.004_04 5.004_62 5.004_65 5.004_68 + + beos - - - - - - - - 1 1 1 1 + Configure 217 1 225 1 225 1 240 1 248 1 256 1 + cygwin32 - - 23 5 23 5 23 5 24 5 24 5 + djgpp - - - - - - 14 5 14 5 14 5 + eg 54 44 81 62 81 62 81 62 81 62 81 62 + emacs 143 1 194 1 204 1 212 2 212 2 212 2 + h2pl 12 12 12 12 12 12 12 12 12 12 12 12 + hints 90 62 129 69 132 71 144 72 151 74 155 74 + os2 117 42 121 42 127 42 127 44 129 44 129 44 + plan9 79 15 82 15 82 15 82 15 82 15 82 15 + Porting 51 1 94 2 109 4 203 6 234 8 241 9 + qnx - - 1 2 1 2 1 2 1 2 1 2 + utils 97 7 112 8 118 8 124 8 156 9 159 9 + vms 505 27 518 34 524 34 538 34 569 34 569 34 + win32 - - 285 33 378 36 470 39 493 39 575 41 + x2p 280 19 281 19 281 19 281 19 282 19 281 19 ====================================================================== - 5.003_07 5.004 5.004_04 5.004_62 5.004_65 - - beos - - - - - - - - 1 1 - Configure 217 1 225 1 225 1 240 1 248 1 - cygwin32 - - 23 5 23 5 23 5 24 5 - djgpp - - - - - - 14 5 14 5 - eg 54 44 81 62 81 62 81 62 81 62 - emacs 143 1 194 1 204 1 212 2 212 2 - h2pl 12 12 12 12 12 12 12 12 12 12 - hints 90 62 129 69 132 71 144 72 151 74 - os2 117 42 121 42 127 42 127 44 129 44 - plan9 79 15 82 15 82 15 82 15 82 15 - Porting 51 1 94 2 109 4 203 6 234 8 - qnx - - 1 2 1 2 1 2 1 2 - utils 97 7 112 8 118 8 124 8 156 9 - vms 505 27 518 34 524 34 538 34 569 34 - win32 - - 285 33 378 36 470 39 493 39 - x2p 280 19 281 19 281 19 281 19 282 19 + 5.004_70 5.004_73 5.004_75 5.005 + + beos 1 1 1 1 1 1 1 1 + Configure 256 1 256 1 264 1 264 1 + cygwin32 24 5 24 5 24 5 24 5 + djgpp 14 5 14 5 14 5 14 5 + eg 86 65 86 65 86 65 86 65 + emacs 262 2 262 2 262 2 262 2 + h2pl 12 12 12 12 12 12 12 12 + hints 157 74 157 74 159 74 160 74 + mpeix - - - - 5 3 5 3 + os2 129 44 139 44 142 44 143 44 + plan9 82 15 82 15 82 15 82 15 + Porting 241 9 253 9 259 10 264 12 + qnx 1 2 1 2 1 2 1 2 + utils 160 9 160 9 160 9 160 9 + vms 570 34 572 34 573 34 575 34 + win32 577 41 585 41 585 41 587 41 + x2p 281 19 281 19 281 19 281 19 =head2 SELECTED PATCH SIZES diff --git a/pod/perllocale.pod b/pod/perllocale.pod index a3e3998883..4401be2053 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -169,15 +169,23 @@ 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 then use this in yet another 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 you gave.) +If no second argument is provided and the category is something else +than LC_ALL, 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 no second argument is provided and the category is LC_ALL, the +result is implementation-dependent. It may be a string of +concatenated locales names (separator also implementation-dependent) +or a single locale name. Please consult your L<setlocale(3)> for +details. + +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 then use this in yet +another 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 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 @@ -210,10 +218,12 @@ I<SEE ALSO> section). If that fails, try the following command lines: and see whether they list something resembling these en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5 + en_US.iso88591 de_DE.iso88591 ru_RU.iso88595 en_US de_DE ru_RU en de ru english german russian english.iso88591 german.iso88591 russian.iso88595 + english.roman8 russian.koi8r Sadly, even though the calling interface for setlocale() has been standardized, names of locales and the directories where the @@ -368,11 +378,12 @@ with a single parameter--see L<The setlocale function>.) localeconv() takes no arguments, and returns B<a reference to> a hash. The keys of this hash are variable names for formatting, such as -C<decimal_point> and C<thousands_sep>. The values are the corresponding, -er, values. See L<POSIX (3)/localeconv> for a longer example listing -the categories an implementation might be expected to provide; some -provide more and others fewer, however. You don't need an explicit C<use -locale>, because localeconv() always observes the current locale. +C<decimal_point> and C<thousands_sep>. The values are the +corresponding, er, values. See L<POSIX (3)/localeconv> for a longer +example listing the categories an implementation might be expected to +provide; some provide more and others fewer. You don't need an +explicit C<use locale>, because localeconv() always observes the +current locale. Here's a simple-minded example program that rewrites its command-line parameters as integers correctly formatted in the current locale: @@ -387,13 +398,29 @@ parameters as integers correctly formatted in the current locale: # Apply defaults if values are missing $thousands_sep = ',' unless $thousands_sep; - $grouping = 3 unless $grouping; + + # grouping and mon_grouping are packed lists + # of small integers (characters) telling the + # grouping (thousand_seps and mon_thousand_seps + # being the group dividers) of numbers and + # monetary quantities. The integers' meanings: + # 255 means no more grouping, 0 means repeat + # the previous grouping, 1-254 means use that + # as the current grouping. Grouping goes from + # right to left (low to high digits). In the + # below we cheat slightly by never using anything + # else than the first grouping (whatever that is). + if ($grouping) { + @grouping = unpack("C*", $grouping); + } else { + @grouping = (3); + } # 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/; + s/(\d)(\d{$grouping[0]}($|$thousands_sep))/$1$thousands_sep$2/; print "$_"; } print "\n"; diff --git a/pod/perlport.pod b/pod/perlport.pod index 83654689a6..79ca76769f 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -10,23 +10,25 @@ a lot in common, they also have their own very particular and unique features. This document is meant to help you to find out what constitutes portable -perl code, so that once you have made your decision to write portably, +Perl code, so that once you have made your decision to write portably, you know where the lines are drawn, and you can stay within them. There is a tradeoff between taking full advantage of B<a> particular type -of computer, and taking advantage of a full B<range> of them. Naturally, -as you make your range bigger (and thus more diverse), the common denominators -drop, and you are left with fewer areas of common ground in which -you can operate to accomplish a particular task. Thus, when you begin -attacking a problem, it is important to consider which part of the tradeoff -curve you want to operate under. Specifically, whether it is important to -you that the task that you are coding needs the full generality of being -portable, or if it is sufficient to just get the job done. This is the -hardest choice to be made. The rest is easy, because Perl provides lots -of choices, whichever way you want to approach your problem. - -Looking at it another way, writing portable code is usually about willfully -limiting your available choices. Naturally, it takes discipline to do that. +of computer, and taking advantage of a full B<range> of them. Naturally, +as you make your range bigger (and thus more diverse), the common +denominators drop, and you are left with fewer areas of common ground in +which you can operate to accomplish a particular task. Thus, when you +begin attacking a problem, it is important to consider which part of the +tradeoff curve you want to operate under. Specifically, whether it is +important to you that the task that you are coding needs the full +generality of being portable, or if it is sufficient to just get the job +done. This is the hardest choice to be made. The rest is easy, because +Perl provides lots of choices, whichever way you want to approach your +problem. + +Looking at it another way, writing portable code is usually about +willfully limiting your available choices. Naturally, it takes discipline +to do that. Be aware of two important points: @@ -59,18 +61,25 @@ take advantage of some unique feature of a particular platform, as is often the case with systems programming (whether for Unix, Windows, S<Mac OS>, VMS, etc.), consider writing platform-specific code. -When the code will run on only two or three operating systems, then you may -only need to consider the differences of those particular systems. The -important thing is to decide where the code will run, and to be deliberate -in your decision. +When the code will run on only two or three operating systems, then you +may only need to consider the differences of those particular systems. +The important thing is to decide where the code will run, and to be +deliberate in your decision. + +The material below is separated into three main sections: main issues of +portability (L<"ISSUES">, platform-specific issues (L<"PLATFORMS">, and +builtin perl functions that behave differently on various ports +(L<"FUNCTION IMPLEMENTATIONS">. This information should not be considered complete; it includes possibly -transient information about idiosyncracies of some of the ports, almost +transient information about idiosyncrasies of some of the ports, almost all of which are in a state of constant evolution. Thus this material should be considered a perpetual work in progress (E<lt>IMG SRC="yellow_sign.gif" ALT="Under Construction"E<gt>). + + =head1 ISSUES =head2 Newlines @@ -97,7 +106,7 @@ C<binmode> on a file, however, you can usually use C<seek> and C<tell> with arbitrary values quite safely. A common misconception in socket programming is that C<\n> eq C<\012> -everywhere. When using protocols, such as common Internet protocols, +everywhere. When using protocols such as common Internet protocols, C<\012> and C<\015> are called for specifically, and the values of the logical C<\n> and C<\r> (carriage return) are not reliable. @@ -110,9 +119,9 @@ the most popular EBCDIC webserver, for instance, accepts C<\r\n>, which translates those characters, along with all other characters in text streams, from EBCDIC to ASCII.] -However, C<\015\012> (or C<\cM\cJ>, or C<\x0D\x0A>) can be tedious and -unsightly, as well as confusing to those maintaining the code. As such, -the C<Socket> module supplies the Right Thing for those who want it. +However, using C<\015\012> (or C<\cM\cJ>, or C<\x0D\x0A>) can be tedious +and unsightly, as well as confusing to those maintaining the code. As +such, the C<Socket> module supplies the Right Thing for those who want it. use Socket qw(:DEFAULT :crlf); print SOCKET "Hi there, client!$CRLF" # RIGHT @@ -140,7 +149,33 @@ platforms, because now any C<\015>'s (C<\cM>'s) are stripped out (and there was much rejoicing). -=head2 File Paths +=head2 Numbers endianness and Width + +Different CPUs store integers and floating point numbers in different +orders (called I<endianness>) and widths (32-bit and 64-bit being the +most common). This affects your programs if they attempt to transfer +numbers in binary format from a CPU architecture to another over some +channel: either 'live' via network connections or storing the numbers +to secondary storage such as a disk file. + +Conflicting storage orders make utter mess out of the numbers: if a +little-endian host (Intel, Alpha) stores 0x12345678 (305419896 in +decimal), a big-endian host (Motorola, MIPS, Sparc, PA) reads it as +0x78563412 (2018915346 in decimal). To avoid this problem in network +(socket) connections use the C<pack()> and C<unpack()> formats C<"n"> +and C<"N">, the "network" orders, they are guaranteed to be portable. + +Different widths can cause truncation even between platforms of equal +endianness: the platform of shorter width loses the upper parts of the +number. There is no good solution for this problem except to avoid +transferring or storing raw binary numbers. + +One can circumnavigate both these problems in two ways: either +transfer and store numbers always in text format, instead of raw +binary, or consider using modules like C<Data::Dumper> (included in +the standard distribution as of Perl 5.005) and C<Storable>. + +=head2 Files Most platforms these days structure files in a hierarchical fashion. So, it is reasonably safe to assume that any platform supports the @@ -148,11 +183,20 @@ notion of a "path" to uniquely identify a file on the system. Just how that path is actually written, differs. While they are similar, file path specifications differ between Unix, -Windows, S<Mac OS>, OS/2, VMS and probably others. Unix, for example, is -one of the few OSes that has the idea of a root directory. S<Mac OS> -uses C<:> as a path separator instead of C</>. VMS, Windows, and OS/2 -can work similarly to Unix with C</> as path separator, or in their own -idiosyncratic ways. +Windows, S<Mac OS>, OS/2, VMS, S<RISC OS> and probably others. Unix, +for example, is one of the few OSes that has the idea of a single root +directory. + +VMS, Windows, and OS/2 can work similarly to Unix with C</> as path +separator, or in their own idiosyncratic ways (such as having several +root directories and various "unrooted" device files such NIL: and +LPT:). + +S<Mac OS> uses C<:> as a path separator instead of C</>. + +C<RISC OS> perl can emulate Unix filenames with C</> as path +separator, or go native and use C<.> for path separator and C<:> to +signal filing systems and disc names. As with the newline problem above, there are modules that can help. The C<File::Spec> modules provide methods to do the Right Thing on whatever @@ -180,10 +224,32 @@ Also of use is C<File::Basename>, from the standard distribution, which splits a pathname into pieces (base filename, full path to directory, and file suffix). -Remember not to count on the existence of system-specific files, like -F</etc/resolv.conf>. If code does need to rely on such a file, include a -description of the file and its format in the code's documentation, and -make it easy for the user to override the default location of the file. +Even when on a single platform (if you can call UNIX a single +platform), remember not to count on the existence or the contents of +system-specific files, like F</etc/passwd>, F</etc/sendmail.conf>, or +F</etc/resolv.conf>. For example the F</etc/passwd> may exist but it +may not contain the encrypted passwords because the system is using +some form of enhanced security-- or it may not contain all the +accounts because the system is using NIS. If code does need to rely +on such a file, include a description of the file and its format in +the code's documentation, and make it easy for the user to override +the default location of the file. + +Do not have two files of the same name with different case, like +F<test.pl> and <Test.pl>, as many platforms have case-insensitive +filenames. Also, try not to have non-word characters (except for C<.>) +in the names, and keep them to the 8.3 convention, for maximum +portability. + +Likewise, if using C<AutoSplit>, try to keep the split functions to +8.3 naming and case-insensitive conventions; or, at the very least, +make it so the resulting files have a unique (case-insensitively) +first 8 characters. + +Don't assume C<E<lt>> won't be the first character of a filename. Always +use C<E<gt>> explicitly to open a file for reading: + + open(FILE, "<$existing_file") or die $!; =head2 System Interaction @@ -199,21 +265,27 @@ the system. Remember to C<close> files when you are done with them. Don't C<unlink> or C<rename> an open file. Don't C<tie> to or C<open> a file that is already tied to or opened; C<untie> or C<close> first. +Don't open the same file more than once at a time for writing, as some +operating systems put mandatory locks on such files. + Don't count on a specific environment variable existing in C<%ENV>. -Don't even count on C<%ENV> entries being case-sensitive, or even +Don't count on C<%ENV> entries being case-sensitive, or even case-preserving. -Don't count on signals in portable programs. +Don't count on signals. Don't count on filename globbing. Use C<opendir>, C<readdir>, and C<closedir> instead. +Don't count on per-program environment variables, or per-program current +directories. + =head2 Interprocess Communication (IPC) In general, don't directly access the system in code that is meant to be -portable. That means, no: C<system>, C<exec>, C<fork>, C<pipe>, C<``>, -C<qx//>, C<open> with a C<|>, or any of the other things that makes being +portable. That means, no C<system>, C<exec>, C<fork>, C<pipe>, C<``>, +C<qx//>, C<open> with a C<|>, nor any of the other things that makes being a Unix perl hacker worth being. Commands that launch external processes are generally supported on @@ -238,10 +310,11 @@ mailing methods, including mail, sendmail, and direct SMTP (via C<Net::SMTP>) if a mail transfer agent is not available. The rule of thumb for portable code is: Do it all in portable Perl, or -use a module that may internally implement it with platform-specific code, -but expose a common interface. By portable Perl, we mean code that -avoids the constructs described in this document as being non-portable. +use a module (that may internally implement it with platform-specific +code, but expose a common interface). +The UNIX System V IPC (C<msg*(), sem*(), shm*()>) is not available +even in all UNIX platforms. =head2 External Subroutines (XS) @@ -252,8 +325,8 @@ code might be. If the libraries and headers are portable, then it is normally reasonable to make sure the XS code is portable, too. There is a different kind of portability issue with writing XS -code: availability of a C compiler on the end-user's system. C brings with -it its own portability issues, and writing XS code will expose you to +code: availability of a C compiler on the end-user's system. C brings +with it its own portability issues, and writing XS code will expose you to some of those. Writing purely in perl is a comparatively easier way to achieve portability. @@ -267,7 +340,8 @@ C<ExtUtils::MM_VMS>), and DBM modules. There is no one DBM module that is available on all platforms. C<SDBM_File> and the others are generally available on all Unix and DOSish -ports, but not in MacPerl, where C<NBDM_File> and C<DB_File> are available. +ports, but not in MacPerl, where only C<NBDM_File> and C<DB_File> are +available. The good news is that at least some DBM module should be available, and C<AnyDBM_File> will use whichever module it can find. Of course, then @@ -277,24 +351,49 @@ denominator (e.g., not exceeding 1K for each record). =head2 Time and Date -The system's notion of time of day and calendar date is controlled in widely -different ways. Don't assume the timezone is stored in C<$ENV{TZ}>, and even -if it is, don't assume that you can control the timezone through that -variable. +The system's notion of time of day and calendar date is controlled in +widely different ways. Don't assume the timezone is stored in C<$ENV{TZ}>, +and even if it is, don't assume that you can control the timezone through +that variable. + +Don't assume that the epoch starts at 00:00:00, January 1, 1970, +because that is OS-specific. Better to store a date in an unambiguous +representation. The ISO 8601 standard defines YYYY-MM-DD as the date +format. A text representation (like C<1 Jan 1970>) can be easily +converted into an OS-specific value using a module like +C<Date::Parse>. An array of values, such as those returned by +C<localtime>, can be converted to an OS-specific representation using +C<Time::Local>. + + +=head2 Character sets and character encoding + +Assume very little about character sets. Do not assume anything about +the numerical values (C<ord()>, C<chr()>) of characters. Do not +assume that the alphabetic characters are encoded contiguously (in +numerical sense). Do no assume anything about the ordering of the +characters. The lowercase letters may come before or after the +uppercase letters, the lowercase and uppercase may be interlaced so +that both 'a' and 'A' come before the 'b', the accented and other +international characters may be interlaced so that E<auml> comes +before the 'b'. + -Don't assume that the epoch starts at January 1, 1970, because that is -OS-specific. Better to store a date in an unambiguous representation. -A text representation (like C<1 Jan 1970>) can be easily converted into an -OS-specific value using a module like C<Date::Parse>. An array of values, -such as those returned by C<localtime>, can be converted to an OS-specific -representation using C<Time::Local>. +=head2 Internationalisation + +If you may assume POSIX (a rather large assumption, that: in practise +that means UNIX) you may read more about the POSIX locale system from +L<perllocale>. The locale system at least attempts to make things a +little bit more portable or at least more convenient and +native-friendly for non-English users. The system affects character +sets and encoding, and date and time formatting, among other things. =head2 System Resources -If your code is destined for systems with severely constrained (or missing!) -virtual memory systems then you want to be especially mindful of avoiding -wasteful constructs such as: +If your code is destined for systems with severely constrained (or +missing!) virtual memory systems then you want to be I<especially> mindful +of avoiding wasteful constructs such as: # NOTE: this is no longer "bad" in perl5.005 for (0..10000000) {} # bad @@ -303,41 +402,45 @@ wasteful constructs such as: @lines = <VERY_LARGE_FILE>; # bad while (<FILE>) {$file .= $_} # sometimes bad - $file = join '', <FILE>; # better + $file = join('', <FILE>); # better The last two may appear unintuitive to most people. The first of those two constructs repeatedly grows a string, while the second allocates a large chunk of memory in one go. On some systems, the latter is more efficient that the former. + =head2 Security -Most Unix platforms provide basic levels of security that is usually felt -at the file-system level. Other platforms usually don't (unfortunately). -Thus the notion of User-ID, or "home" directory, or even the state of -being logged-in may be unrecognizable on may platforms. If you write -programs that are security conscious, it is usually best to know what -type of system you will be operating under, and write code explicitly +Most multi-user platforms provide basic levels of security that is usually +felt at the file-system level. Other platforms usually don't +(unfortunately). Thus the notion of user id, or "home" directory, or even +the state of being logged-in, may be unrecognizable on many platforms. If +you write programs that are security conscious, it is usually best to know +what type of system you will be operating under, and write code explicitly for that platform (or class of platforms). + =head2 Style For those times when it is necessary to have platform-specific code, consider keeping the platform-specific code in one place, making porting to other platforms easier. Use the C<Config> module and the special -variable C<$^O> to differentiate platforms, as described in L<"PLATFORMS">. +variable C<$^O> to differentiate platforms, as described in +L<"PLATFORMS">. -=head1 CPAN TESTERS +=head1 CPAN Testers -Module uploaded to CPAN are tested by a variety of volunteers on -different platforms. These CPAN testers are notified by e-mail of each +Modules uploaded to CPAN are tested by a variety of volunteers on +different platforms. These CPAN testers are notified by mail of each new upload, and reply to the list with PASS, FAIL, NA (not applicable to -this platform), or ???? (unknown), along with any relevant notations. +this platform), or UNKNOWN (unknown), along with any relevant notations. The purpose of the testing is twofold: one, to help developers fix any -problems in their code; two, to provide users with information about -whether or not a given module works on a given platform. +problems in their code that crop up because of lack of testing on other +platforms; two, to provide users with information about whether or not +a given module works on a given platform. =over 4 @@ -363,23 +466,24 @@ Perl works on a bewildering variety of Unix and Unix-like platforms (see e.g. most of the files in the F<hints/> directory in the source code kit). On most of these systems, the value of C<$^O> (hence C<$Config{'osname'}>, too) is determined by lowercasing and stripping punctuation from the first -field of the string returned by typing - - % uname -a - -(or a similar command) at the shell prompt. Here, for example, are a few -of the more popular Unix flavors: - - uname $^O - -------------------- - AIX aix - FreeBSD freebsd - Linux linux - HP-UX hpux - OSF1 dec_osf - SunOS solaris - SunOS4 sunos - +field of the string returned by typing C<uname -a> (or a similar command) +at the shell prompt. Here, for example, are a few of the more popular +Unix flavors: + + uname $^O $Config{'archname'} + ------------------------------------------- + AIX aix aix + FreeBSD freebsd freebsd-i386 + Linux linux i386-linux + HP-UX hpux PA-RISC1.1 + IRIX irix irix + OSF1 dec_osf alpha-dec_osf + SunOS solaris sun4-solaris + SunOS solaris i86pc-solaris + SunOS4 sunos sun4-sunos + +Note that because the C<$Config{'archname'}> may depend on the hardware +architecture it may vary quite a lot, much more than the C<$^O>. =head2 DOS and Derivatives @@ -402,9 +506,9 @@ from calling any external programs, C</> will work just fine, and probably better, as it is more consistent with popular usage, and avoids the problem of remembering what to backwhack and what not to. -The DOS FAT file system can only accomodate "8.3" style filenames. Under +The DOS FAT filesystem can only accommodate "8.3" style filenames. Under the "case insensitive, but case preserving" HPFS (OS/2) and NTFS (NT) -file systems you may have to be careful about case returned with functions +filesystems you may have to be careful about case returned with functions like C<readdir> or used with functions like C<open> or C<opendir>. DOS also treats several filenames as special, such as AUX, PRN, NUL, CON, @@ -452,12 +556,13 @@ C<http://www.juge.com/bbs/Hobb.19.html> =back -=head2 MacPerl +=head2 S<Mac OS> Any module requiring XS compilation is right out for most people, because MacPerl is built using non-free (and non-cheap!) compilers. Some XS modules that can work with MacPerl are built and distributed in binary -form on CPAN. See I<MacPerl: Power and Ease> for more details. +form on CPAN. See I<MacPerl: Power and Ease> and L<"CPAN Testers"> +for more details. Directories are specified as: @@ -472,8 +577,8 @@ Files in a directory are stored in alphabetical order. Filenames are limited to 31 characters, and may include any character except C<:>, which is reserved as a path separator. -Instead of C<flock>, see C<FSpSetFLock> and C<FSpRstFLock> in -C<Mac::Files>. +Instead of C<flock>, see C<FSpSetFLock> and C<FSpRstFLock> in the +C<Mac::Files> module. In the MacPerl application, you can't run a program from the command line; programs that expect C<@ARGV> to be populated can be edited with something @@ -495,7 +600,7 @@ shell: perl myscript.plx some arguments ToolServer is another app from Apple that provides access to MPW tools -from MPW and the MacPerl app, which allows MacPerl program to use +from MPW and the MacPerl app, which allows MacPerl programs to use C<system>, backticks, and piped C<open>. "S<Mac OS>" is the proper name for the operating system, but the value @@ -508,6 +613,10 @@ the application or MPW tool version is running, check: $is_ppc = $MacPerl::Architecture eq 'MacPPC'; $is_68k = $MacPerl::Architecture eq 'Mac68K'; +S<Mac OS X>, to be based on NeXT's OpenStep OS, will be able to run +MacPerl natively (in the Blue Box, and even in the Yellow Box, once some +changes to the toolbox calls are made), but Unix perl will also run +natively. Also see: @@ -523,7 +632,7 @@ Also see: =head2 VMS Perl on VMS is discussed in F<vms/perlvms.pod> in the perl distribution. -Note that perl on VMS can accept either VMS or Unix style file +Note that perl on VMS can accept either VMS- or Unix-style file specifications as in either of the following: $ perl -ne "print if /perl_setup/i" SYS$LOGIN:LOGIN.COM @@ -566,20 +675,22 @@ extensions is also 39 characters. Version is a number from 1 to VMS' RMS filesystem is case insensitive and does not preserve case. C<readdir> returns lowercased filenames, but specifying a file for -opening remains case insensitive. Files without extensions have a +opening remains case insensitive. Files without extensions have a trailing period on them, so doing a C<readdir> with a file named F<A.;5> -will return F<a.> (though that file could be opened with C<open(FH, 'A')>. +will return F<a.> (though that file could be opened with +C<open(FH, 'A')>). -RMS has an eight level limit on directory depths from any rooted logical -(allowing 16 levels overall). Hence C<PERL_ROOT:[LIB.2.3.4.5.6.7.8]> -is a valid directory specification but C<PERL_ROOT:[LIB.2.3.4.5.6.7.8.9]> -is not. F<Makefile.PL> authors might have to take this into account, but -at least they can refer to the former as C</PERL_ROOT/lib/2/3/4/5/6/7/8/>. +RMS had an eight level limit on directory depths from any rooted logical +(allowing 16 levels overall) prior to VMS 7.2. Hence +C<PERL_ROOT:[LIB.2.3.4.5.6.7.8]> is a valid directory specification but +C<PERL_ROOT:[LIB.2.3.4.5.6.7.8.9]> is not. F<Makefile.PL> authors might +have to take this into account, but at least they can refer to the former +as C</PERL_ROOT/lib/2/3/4/5/6/7/8/>. -The C<VMS::Filespec> module, which gets installed as part -of the build process on VMS, is a pure Perl module that can easily be -installed on non-VMS platforms and can be helpful for conversions to -and from RMS native formats. +The C<VMS::Filespec> module, which gets installed as part of the build +process on VMS, is a pure Perl module that can easily be installed on +non-VMS platforms and can be helpful for conversions to and from RMS +native formats. What C<\n> represents depends on the type of file that is open. It could be C<\015>, C<\012>, C<\015\012>, or nothing. Reading from a file @@ -637,15 +748,15 @@ can executed with a header similar to the following simple script: print "Hello from perl!\n"; On these platforms, bear in mind that the EBCDIC character set may have -an effect on what happens with perl functions such as C<chr>, C<pack>, -C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>; as well as -bit-fiddling with ASCII constants using operators like C<^>, C<&> and -C<|>; not to mention dealing with socket interfaces to ASCII computers +an effect on what happens with some perl functions (such as C<chr>, +C<pack>, C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>), as +well as bit-fiddling with ASCII constants using operators like C<^>, C<&> +and C<|>, not to mention dealing with socket interfaces to ASCII computers (see L<"NEWLINES">). Fortunately, most web servers for the mainframe will correctly translate the C<\n> in the following statement to its ASCII equivalent (note that -C<\r> is the same under both ASCII and EBCDIC): +C<\r> is the same under both Unix and OS/390): print "Content-type: text/html\r\n\r\n"; @@ -661,9 +772,9 @@ platform could include any of the following (perhaps all): if (chr(169) eq 'z') { print "EBCDIC may be spoken here!\n"; } Note that one thing you may not want to rely on is the EBCDIC encoding -of punctuation characters since these may differ from code page to code page -(and once your module or script is rumoured to work with EBCDIC, folks will -want it to work with all EBCDIC character sets). +of punctuation characters since these may differ from code page to code +page (and once your module or script is rumoured to work with EBCDIC, +folks will want it to work with all EBCDIC character sets). Also see: @@ -675,19 +786,131 @@ The perl-mvs@perl.org list is for discussion of porting issues as well as general usage issues for all EBCDIC Perls. Send a message body of "subscribe perl-mvs" to majordomo@perl.org. -=item AS/400 Perl information at C<http://as400.rochester.ibm.com> +=item AS/400 Perl information at C<http://as400.rochester.ibm.com/> =back + +=head2 Acorn RISC OS + +As Acorns use ASCII with newlines (C<\n>) in text files as C<\012> like +Unix and Unix filename emulation is turned on by default, it is quite +likely that most simple scripts will work "out of the box". The native +filing system is modular, and individual filing systems are free to be +case-sensitive or insensitive, and are usually case-preserving. Some +native filing systems have name length limits which file and directory +names are silently truncated to fit - scripts should be aware that the +standard disc filing system currently has a name length limit of B<10> +characters, with up to 77 items in a directory, but other filing systems +may not impose such limitations. + +Native filenames are of the form + + Filesystem#Special_Field::DiscName.$.Directory.Directory.File + +where + + Special_Field is not usually present, but may contain . and $ . + Filesystem =~ m|[A-Za-z0-9_]| + DsicName =~ m|[A-Za-z0-9_/]| + $ represents the root directory + . is the path separator + @ is the current directory (per filesystem but machine global) + ^ is the parent directory + Directory and File =~ m|[^\0- "\.\$\%\&:\@\\^\|\177]+| + +The default filename translation is roughly C<tr|/.|./|;> + +Note that C<"ADFS::HardDisc.$.File" ne 'ADFS::HardDisc.$.File'> and that +the second stage of C<$> interpolation in regular expressions will fall +foul of the C<$.> if scripts are not careful. + +Logical paths specified by system variables containing comma-separated +search lists are also allowed, hence C<System:Modules> is a valid +filename, and the filesystem will prefix C<Modules> with each section of +C<System$Path> until a name is made that points to an object on disc. +Writing to a new file C<System:Modules> would only be allowed if +C<System$Path> contains a single item list. The filesystem will also +expand system variables in filenames if enclosed in angle brackets, so +C<E<lt>System$DirE<gt>.Modules> would look for the file +S<C<$ENV{'System$Dir'} . 'Modules'>>. The obvious implication of this is +that B<fully qualified filenames can start with C<E<lt>E<gt>> and should +be protected when C<open> is used for input. + +Because C<.> was in use as a directory separator and filenames could not +be assumed to be unique after 10 characters, Acorn implemented the C +compiler to strip the trailing C<.c> C<.h> C<.s> and C<.o> suffix from +filenames specified in source code and store the respective files in +subdirectories named after the suffix. Hence files are translated: + + foo.h h.foo + C:foo.h C:h.foo (logical path variable) + sys/os.h sys.h.os (C compiler groks Unix-speak) + 10charname.c c.10charname + 10charname.o o.10charname + 11charname_.c c.11charname (assuming filesystem truncates at 10) + +The Unix emulation library's translation of filenames to native assumes +that this sort of translation is required, and allows a user defined list +of known suffixes which it will transpose in this fashion. This may +appear transparent, but consider that with these rules C<foo/bar/baz.h> +and C<foo/bar/h/baz> both map to C<foo.bar.h.baz>, and that C<readdir> and +C<glob> cannot and do not attempt to emulate the reverse mapping. Other +C<.>s in filenames are translated to C</>. + +As implied above the environment accessed through C<%ENV> is global, and +the convention is that program specific environment variables are of the +form C<Program$Name>. Each filing system maintains a current directory, +and the current filing system's current directory is the B<global> current +directory. Consequently, sociable scripts don't change the current +directory but rely on full pathnames, and scripts (and Makefiles) cannot +assume that they can spawn a child process which can change the current +directory without affecting its parent (and everyone else for that +matter). + +As native operating system filehandles are global and currently are +allocated down from 255, with 0 being a reserved value the Unix emulation +library emulates Unix filehandles. Consequently, you can't rely on +passing C<STDIN>, C<STDOUT>, or C<STDERR> to your children. + +The desire of users to express filenames of the form +C<E<lt>Foo$DirE<gt>.Bar> on the command line unquoted causes problems, +too: C<``> command output capture has to perform a guessing game. It +assumes that a string C<E<lt>[^E<lt>E<gt>]+\$[^E<lt>E<gt>]E<gt>> is a +reference to an environment variable, whereas anything else involving +C<E<lt>> or C<E<gt>> is redirection, and generally manages to be 99% +right. Of course, the problem remains that scripts cannot rely on any +Unix tools being available, or that any tools found have Unix-like command +line arguments. + +Extensions and XS are, in theory, buildable by anyone using free tools. +In practice, many don't, as users of the Acorn platform are used to binary +distribution. MakeMaker does run, but no available make currently copes +with MakeMaker's makefiles; even if/when this is fixed, the lack of a +Unix-like shell can cause problems with makefile rules, especially lines +of the form C<cd sdbm && make all>, and anything using quoting. + +"S<RISC OS>" is the proper name for the operating system, but the value +in C<$^O> is "riscos" (because we don't like shouting). + +Also see: + +=over 4 + +=item perl list + +=back + + =head2 Other perls Perl has been ported to a variety of platforms that do not fit into any of the above categories. Some, such as AmigaOS, BeOS, QNX, and Plan 9, have -been well integrated into the standard Perl source code kit. You may need +been well-integrated into the standard Perl source code kit. You may need to see the F<ports/> directory on CPAN for information, and possibly -binaries, for the likes of: acorn, aos, atari, lynxos, HP-MPE/iX, riscos, -Tandem Guardian, vos, I<etc.> (yes we know that some of these OSes may fall -under the Unix category but we are not a standards body.) +binaries, for the likes of: aos, atari, lynxos, riscos, Tandem Guardian, +vos, I<etc.> (yes we know that some of these OSes may fall under the Unix +category, but we are not a standards body.) See also: @@ -699,7 +922,7 @@ See also: =item Novell Netware -A free Perl 5 based PERL.NLM for Novell Netware is available from +A free perl5-based PERL.NLM for Novell Netware is available from C<http://www.novell.com/> =back @@ -715,14 +938,12 @@ The list may very well be incomplete, or wrong in some places. When in doubt, consult the platform-specific README files in the Perl source distribution, and other documentation resources for a given port. -Be aware, moreover, that even among Unix-ish systems there are variations, -and not all functions listed here are necessarily available, though -most usually are. +Be aware, moreover, that even among Unix-ish systems there are variations. For many functions, you can also query C<%Config>, exported by default from C<Config.pm>. For example, to check if the platform has the C<lstat> -call, check C<$Config{'d_lstat'}>. See L<Config> for a full description -of available variables. +call, check C<$Config{'d_lstat'}>. See L<Config.pm> for a full +description of available variables. =head2 Alphabetical Listing of Perl Functions @@ -742,28 +963,38 @@ considerations. C<-o> is not supported. (S<Mac OS>) C<-r>, C<-w>, C<-x>, and C<-o> tell whether or not file is accessible, which may not reflect UIC-based file protections. (VMS) +C<-s> returns the size of the data fork, not the total size of data fork +plus resource fork. (S<Mac OS>). + +C<-s> by name on an open file will return the space reserved on disk, +rather than the current extent. C<-s> on an open filehandle returns the +current size. (S<RISC OS>) + C<-R>, C<-W>, C<-X>, C<-O> are indistinguishable from C<-r>, C<-w>, -C<-x>, C<-o>. (S<Mac OS>, Win32, VMS) +C<-x>, C<-o>. (S<Mac OS>, Win32, VMS, S<RISC OS>) C<-b>, C<-c>, C<-k>, C<-g>, C<-p>, C<-u>, C<-A> are not implemented. (S<Mac OS>) C<-g>, C<-k>, C<-l>, C<-p>, C<-u>, C<-A> are not particularly meaningful. -(Win32, VMS) +(Win32, VMS, S<RISC OS>) C<-d> is true if passed a device spec without an explicit directory. (VMS) C<-T> and C<-B> are implemented, but might misclassify Mac text files -with foreign characters; this is the case will all platforms, but -affects S<Mac OS> a lot. (S<Mac OS>) +with foreign characters; this is the case will all platforms, but may +affect S<Mac OS> often. (S<Mac OS>) C<-x> (or C<-X>) determine if a file ends in one of the executable suffixes. C<-S> is meaningless. (Win32) +C<-x> (or C<-X>) determine if a file has an executable file type. +(S<RISC OS>) + =item binmode FILEHANDLE -Meaningless. (S<Mac OS>) +Meaningless. (S<Mac OS>, S<RISC OS>) Reopens file and restores pointer; if function fails, underlying filehandle may be closed, or pointer may be in a different position. @@ -780,9 +1011,11 @@ locking/unlocking the file. (S<Mac OS>) Only good for changing "owner" read-write access, "group", and "other" bits are meaningless. (Win32) +Only good for changing "owner" and "other" read-write access. (S<RISC OS>) + =item chown LIST -Not implemented. (S<Mac OS>, Win32, Plan9) +Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>) Does nothing, but won't fail. (Win32) @@ -790,12 +1023,12 @@ Does nothing, but won't fail. (Win32) =item chroot -Not implemented. (S<Mac OS>, Win32, VMS, Plan9) +Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>) =item crypt PLAINTEXT,SALT May not be available if library or source was not provided when building -perl. (Win32) +perl. (Win32) =item dbmclose HASH @@ -807,11 +1040,11 @@ Not implemented. (VMS, Plan9) =item dump LABEL -Not useful. (S<Mac OS>) +Not useful. (S<Mac OS>, S<RISC OS>) Not implemented. (Win32) -Invokes VMS debugger. (VMS) +Invokes VMS debugger. (VMS) =item exec LIST @@ -823,37 +1056,39 @@ Not implemented. (Win32, VMS) =item flock FILEHANDLE,OPERATION -Not implemented (S<Mac OS>, VMS). +Not implemented (S<Mac OS>, VMS, S<RISC OS>). Available only on Windows NT (not on Windows 95). (Win32) =item fork -Not implemented. (S<Mac OS>, Win32, AmigaOS) +Not implemented. (S<Mac OS>, Win32, AmigaOS, S<RISC OS>) =item getlogin -Not implemented. (S<Mac OS>) +Not implemented. (S<Mac OS>, S<RISC OS>) =item getpgrp PID -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getppid -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getpriority WHICH,WHO -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getpwnam NAME Not implemented. (S<Mac OS>, Win32) +Not useful. (S<RISC OS>) + =item getgrnam NAME -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getnetbyname NAME @@ -863,9 +1098,11 @@ Not implemented. (S<Mac OS>, Win32, Plan9) Not implemented. (S<Mac OS>, Win32) +Not useful. (S<RISC OS>) + =item getgrgid GID -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getnetbyaddr ADDR,ADDRTYPE @@ -905,27 +1142,27 @@ Not implemented. (Win32, Plan9) =item setpwent -Not implemented. (S<Mac OS>, Win32) +Not implemented. (S<Mac OS>, Win32, S<RISC OS>) =item setgrent -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item sethostent STAYOPEN -Not implemented. (S<Mac OS>, Win32, Plan9) +Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>) =item setnetent STAYOPEN -Not implemented. (S<Mac OS>, Win32, Plan9) +Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>) =item setprotoent STAYOPEN -Not implemented. (S<Mac OS>, Win32, Plan9) +Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>) =item setservent STAYOPEN -Not implemented. (Plan9, Win32) +Not implemented. (Plan9, Win32, S<RISC OS>) =item endpwent @@ -933,7 +1170,7 @@ Not implemented. (S<Mac OS>, Win32) =item endgrent -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item endhostent @@ -962,8 +1199,14 @@ Not implemented. (S<Mac OS>, Plan9) Globbing built-in, but only C<*> and C<?> metacharacters are supported. (S<Mac OS>) -Features depend on external perlglob.exe or perlglob.bat. May be overridden -with something like File::DosGlob, which is recommended. (Win32) +Features depend on external perlglob.exe or perlglob.bat. May be +overridden with something like File::DosGlob, which is recommended. +(Win32) + +Globbing built-in, but only C<*> and C<?> metacharacters are supported. +Globbing relies on operating system calls, which may return filenames +in any order. As most filesystems are case-insensitive, even "sorted" +filenames will not be in case-sensitive order. (S<RISC OS>) =item ioctl FILEHANDLE,FUNCTION,SCALAR @@ -972,16 +1215,19 @@ Not implemented. (VMS) Available only for socket handles, and it does what the ioctlsocket() call in the Winsock API does. (Win32) +Available only for socket handles. (S<RISC OS>) + =item kill LIST -Not implemented. (S<Mac OS>) +Not implemented, hence not useful for taint checking. (S<Mac OS>, +S<RISC OS>) -Available only for process handles returned by the C<system(1, ...)> method of -spawning a process. (Win32) +Available only for process handles returned by the C<system(1, ...)> +method of spawning a process. (Win32) =item link OLDFILE,NEWFILE -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item lstat FILEHANDLE @@ -989,9 +1235,9 @@ Not implemented. (S<Mac OS>, Win32, VMS) =item lstat -Not implemented. (VMS) +Not implemented. (VMS, S<RISC OS>) -Return values may be bogus. (Win32) +Return values may be bogus. (Win32) =item msgctl ID,CMD,ARG @@ -1001,7 +1247,7 @@ Return values may be bogus. (Win32) =item msgrcv ID,VAR,SIZE,TYPE,FLAGS -Not implemented. (S<Mac OS>, Win32, VMS, Plan9) +Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>) =item open FILEHANDLE,EXPR @@ -1010,7 +1256,7 @@ Not implemented. (S<Mac OS>, Win32, VMS, Plan9) The C<|> variants are only supported if ToolServer is installed. (S<Mac OS>) -open to C<|-> and C<-|> are unsupported. (S<Mac OS>, Win32) +open to C<|-> and C<-|> are unsupported. (S<Mac OS>, Win32, S<RISC OS>) =item pipe READHANDLE,WRITEHANDLE @@ -1020,27 +1266,29 @@ Not implemented. (S<Mac OS>) =item readlink -Not implemented. (Win32, VMS) +Not implemented. (Win32, VMS, S<RISC OS>) =item select RBITS,WBITS,EBITS,TIMEOUT Only implemented on sockets. (Win32) +Only reliable on sockets. (S<RISC OS>) + =item semctl ID,SEMNUM,CMD,ARG =item semget KEY,NSEMS,FLAGS =item semop KEY,OPSTRING -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item setpgrp PID,PGRP -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item setpriority WHICH,WHO,PRIORITY -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL @@ -1054,11 +1302,11 @@ Not implemented. (S<Mac OS>, Plan9) =item shmwrite ID,STRING,POS,SIZE -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item stat FILEHANDLE @@ -1073,13 +1321,23 @@ device and inode are not meaningful. (Win32) device and inode are not necessarily reliable. (VMS) +mtime, atime and ctime all return the last modification time. Device and +inode are not necessarily reliable. (S<RISC OS>) + =item symlink OLDFILE,NEWFILE -Not implemented. (Win32, VMS) +Not implemented. (Win32, VMS, S<RISC OS>) =item syscall LIST -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) + +=item sysopen FILEHANDLE,FILENAME,MODE,PERMS + +The traditional "0", "1", and "2" MODEs are implemented with different +numeric values on some systems. The flags exported by C<Fcntl> +(O_RDONLY, O_WRONLY, O_RDWR) should work everywhere though. (S<Mac +OS>, OS/390) =item system LIST @@ -1091,6 +1349,16 @@ process and immediately returns its process designator, without waiting for it to terminate. Return value may be used subsequently in C<wait> or C<waitpid>. (Win32) +There is no shell to process metacharacters, and the native standard is +to pass a command line terminated by "\n" "\r" or "\0" to the spawned +program. Redirection such as C<E<gt> foo> is performed (if at all) by +the run time library of the spawned program. C<system> I<list> will call +the Unix emulation library's C<exec> emulation, which attempts to provide +emulation of the stdin, stdout, stderr in force in the parent, providing +the child program uses a compatible version of the emulation library. +I<scalar> will call the native command line direct and no such emulation +of a child Unix program will exists. Mileage B<will> vary. (S<RISC OS>) + =item times Only the first entry returned is nonzero. (S<Mac OS>) @@ -1099,6 +1367,8 @@ Only the first entry returned is nonzero. (S<Mac OS>) "system" time will be bogus, and "user" time is actually the time returned by the clock() function in the C runtime library. (Win32) +Not useful. (S<RISC OS>) + =item truncate FILEHANDLE,LENGTH =item truncate EXPR,LENGTH @@ -1113,9 +1383,13 @@ Returns undef where unavailable, as of version 5.005. =item utime LIST -Only the modification time is updated. (S<Mac OS>, VMS) +Only the modification time is updated. (S<Mac OS>, VMS, S<RISC OS>) -May not behave as expected. (Win32) +May not behave as expected. Behavior depends on the C runtime +library's implementation of utime(), and the filesystem being +used. The FAT filesystem typically does not support an "access +time" field, and it may limit timestamps to a granularity of +two seconds. (Win32) =item wait @@ -1126,35 +1400,62 @@ Not implemented. (S<Mac OS>) Can only be applied to process handles returned for processes spawned using C<system(1, ...)>. (Win32) +Not useful. (S<RISC OS>) + =back +=head1 CHANGES + +=over 4 + +=item 1.33, 06 August 1998 + +Integrate more minor changes. + +=item 1.32, 05 August 1998 + +Integrate more minor changes. + +=item 1.30, 03 August 1998 + +Major update for RISC OS, other minor changes. + +=item 1.23, 10 July 1998 + +First public release with perl5.005. + +=back =head1 AUTHORS / CONTRIBUTORS -Chris Nandor E<lt>pudge@pobox.comE<gt>, -Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>, -Peter Prymmer E<lt>pvhp@forte.comE<gt>, -Tom Christiansen E<lt>tchrist@perl.comE<gt>, -Nathan Torkington E<lt>gnat@frii.comE<gt>, -Paul Moore E<lt>Paul.Moore@uk.origin-it.comE<gt>, -Matthias Neercher E<lt>neeri@iis.ee.ethz.chE<gt>, +Abigail E<lt>abigail@fnx.comE<gt>, Charles Bailey E<lt>bailey@genetics.upenn.eduE<gt>, +Graham Barr E<lt>gbarr@pobox.comE<gt>, +Tom Christiansen E<lt>tchrist@perl.comE<gt>, +Nicholas Clark E<lt>Nicholas.Clark@liverpool.ac.ukE<gt>, +Andy Dougherty E<lt>doughera@lafcol.lafayette.eduE<gt>, +Dominic Dunlop E<lt>domo@vo.luE<gt>, +M.J.T. Guy E<lt>mjtg@cus.cam.ac.ukE<gt>, Luther Huffman E<lt>lutherh@stratcom.comE<gt>, -Gary Ng E<lt>71564.1743@CompuServe.COME<gt>, Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt>, -Paul J. Schinder E<lt>schinder@pobox.comE<gt>, +Andreas J. KE<ouml>nig E<lt>koenig@kulturbox.deE<gt>, +Andrew M. Langmead E<lt>aml@world.std.comE<gt>, +Paul Moore E<lt>Paul.Moore@uk.origin-it.comE<gt>, +Chris Nandor E<lt>pudge@pobox.comE<gt>, +Matthias Neeracher E<lt>neeri@iis.ee.ethz.chE<gt>, +Gary Ng E<lt>71564.1743@CompuServe.COME<gt>, Tom Phoenix E<lt>rootbeer@teleport.comE<gt>, -Hugo van der Sanden E<lt>h.sanden@elsevier.nlE<gt>, -Dominic Dunlop E<lt>domo@vo.luE<gt>, +Peter Prymmer E<lt>pvhp@forte.comE<gt>, +Hugo van der Sanden E<lt>hv@crypt0.demon.co.ukE<gt>, +Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>, +Paul J. Schinder E<lt>schinder@pobox.comE<gt>, Dan Sugalski E<lt>sugalskd@ous.eduE<gt>, -Andreas J. Koenig E<lt>koenig@kulturbox.deE<gt>, -Andrew M. Langmead E<lt>aml@world.std.comE<gt>, -Andy Dougherty E<lt>doughera@lafcol.lafayette.eduE<gt>, -Abigail E<lt>abigail@fnx.comE<gt>. +Nathan Torkington E<lt>gnat@frii.comE<gt>. This document is maintained by Chris Nandor. =head1 VERSION -Version 1.23, last modified 10 July 1998. +Version 1.34, last modified 07 August 1998. + diff --git a/pod/perlre.pod b/pod/perlre.pod index b7fda54061..1b49ba4e7b 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -7,12 +7,13 @@ perlre - Perl regular expressions This page describes the syntax of regular expressions in Perl. For a description of how to I<use> regular expressions in matching operations, plus various examples of the same, see discussion -of C<m//>, C<s///>, C<qr//> and C<??> in L<perlop/Regexp Quote-Like Operators>. +of C<m//>, C<s///>, C<qr//> and C<??> in L<perlop/"Regexp Quote-Like Operators">. The matching operations can have various modifiers. The modifiers that relate to the interpretation of the regular expression inside -are listed below. For the modifiers that alter the way regular expression -is used by Perl, see L<perlop/Regexp Quote-Like Operators>. +are listed below. For the modifiers that alter the way a regular expression +is used by Perl, see L<perlop/"Regexp Quote-Like Operators"> and +L<perlop/"Gory details of parsing quoted constructs">. =over 4 @@ -346,10 +347,6 @@ Experimental "evaluate any Perl code" zero-width assertion. Always succeeds. C<code> is not interpolated. Currently the rules to determine where the C<code> ends are somewhat convoluted. -Owing to the risks to security, this is only available when the -C<use re 'eval'> pragma is used, and then only for patterns that don't -have any variables that must be interpolated at run time. - The C<code> is properly scoped in the following sense: if the assertion is backtracked (compare L<"Backtracking">), all the changes introduced after C<local>isation are undone, so @@ -380,6 +377,28 @@ other C<(?{ code })> assertions inside the same regular expression. The above assignment to $^R is properly localized, thus the old value of $^R is restored if the assertion is backtracked (compare L<"Backtracking">). +Due to security concerns, this construction is not allowed if the regular +expression involves run-time interpolation of variables, unless +C<use re 'eval'> pragma is used (see L<re>), or the variables contain +results of qr() operator (see L<perlop/"qr/STRING/imosx">). + +This restriction is due to the wide-spread (questionable) practice of +using the construct + + $re = <>; + chomp $re; + $string =~ /$re/; + +without tainting. While this code is frowned upon from security point +of view, when C<(?{})> was introduced, it was considered bad to add +I<new> security holes to existing scripts. + +B<NOTE:> Use of the above insecure snippet without also enabling taint mode +is to be severely frowned upon. C<use re 'eval'> does not disable tainting +checks, thus to allow $re in the above snippet to contain C<(?{})> +I<with tainting enabled>, one needs both C<use re 'eval'> and untaint +the $re. + =item C<(?E<gt>pattern)> An "independent" subexpression. Matches the substring that a @@ -392,7 +411,7 @@ C<a> at the beginning of string, leaving no C<a> for C<ab> to match. In contrast, C<a*ab> will match the same as C<a+b>, since the match of the subgroup C<a*> is influenced by the following group C<ab> (see L<"Backtracking">). In particular, C<a*> inside C<a*ab> will match -less characters that a standalone C<a*>, since this makes the tail match. +fewer characters than a standalone C<a*>, since this makes the tail match. An effect similar to C<(?E<gt>pattern)> may be achieved by @@ -401,40 +420,42 @@ An effect similar to C<(?E<gt>pattern)> may be achieved by since the lookahead is in I<"logical"> context, thus matches the same substring as a standalone C<a+>. The following C<\1> eats the matched string, thus making a zero-length assertion into an analogue of -C<(?>...)>. (The difference between these two constructs is that the +C<(?E<gt>...)>. (The difference between these two constructs is that the second one uses a catching group, thus shifting ordinals of backreferences in the rest of a regular expression.) This construct is useful for optimizations of "eternal" matches, because it will not backtrack (see L<"Backtracking">). - m{ \( ( - [^()]+ - | - \( [^()]* \) - )+ - \) - }x + m{ \( + ( + [^()]+ + | + \( [^()]* \) + )+ + \) + }x That will efficiently match a nonempty group with matching two-or-less-level-deep parentheses. However, if there is no such group, it will take virtually forever on a long string. That's because there are so many different ways to split a long string into several substrings. -This is essentially what C<(.+)+> is doing, and this is a subpattern -of the above pattern. Consider that C<((()aaaaaaaaaaaaaaaaaa> on the -pattern above detects no-match in several seconds, but that each extra +This is what C<(.+)+> is doing, and C<(.+)+> is similar to a subpattern +of the above pattern. Consider that the above pattern detects no-match +on C<((()aaaaaaaaaaaaaaaaaa> in several seconds, but that each extra letter doubles this time. This exponential performance will make it appear that your program has hung. However, a tiny modification of this pattern - m{ \( ( - (?> [^()]+ ) - | - \( [^()]* \) - )+ - \) - }x + m{ \( + ( + (?> [^()]+ ) + | + \( [^()]* \) + )+ + \) + }x which uses C<(?E<gt>...)> matches exactly when the one above does (verifying this yourself would be a productive exercise), but finishes in a fourth @@ -457,9 +478,9 @@ matched), or lookahead/lookbehind/evaluate zero-width assertion. Say, m{ ( \( )? - [^()]+ + [^()]+ (?(1) \) ) - }x + }x matches a chunk of non-parentheses, possibly included in parentheses themselves. @@ -608,10 +629,10 @@ When using lookahead assertions and negations, this can all get even tricker. Imagine you'd like to find a sequence of non-digits not followed by "123". You might try to write that as - $_ = "ABC123"; - if ( /^\D*(?!123)/ ) { # Wrong! - print "Yup, no 123 in $_\n"; - } + $_ = "ABC123"; + if ( /^\D*(?!123)/ ) { # Wrong! + print "Yup, no 123 in $_\n"; + } But that isn't going to match; at least, not the way you're hoping. It claims that there is no 123 in the string. Here's a clearer picture of @@ -904,6 +925,8 @@ part of this regular expression needs to be converted explicitly L<perlop/"Regexp Quote-Like Operators">. +L<perlop/"Gory details of parsing quoted constructs">. + L<perlfunc/pos>. L<perllocale>. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index da96acd9dc..a0c85b917b 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -272,6 +272,7 @@ equivalent to B<-Dtls>): 8192 H Hash dump -- usurps values() 16384 X Scratchpad allocation 32768 D Cleaning up + 65536 S Thread synchronization All these flags require C<-DDEBUGGING> when you compile the Perl executable. This flag is automatically set if you include C<-g> diff --git a/pod/roffitall b/pod/roffitall index 244048af2d..918fe0270a 100644 --- a/pod/roffitall +++ b/pod/roffitall @@ -14,8 +14,8 @@ fi mandir=$installman1dir libdir=$installman3dir -test -d $mandir || mandir=/usr/local/man/man1 -test -d $libdir || libdir=/usr/local/man/man3 +test -d $mandir || mandir=/usr/new/man/man1 +test -d $libdir || libdir=/usr/new/man/man3 case "$1" in -nroff) cmd="nroff -man"; ext='txt';; @@ -30,40 +30,44 @@ esac toroff=` echo \ $mandir/perl.1 \ - $mandir/perldelta.1 \ $mandir/perldata.1 \ $mandir/perlsyn.1 \ $mandir/perlop.1 \ $mandir/perlre.1 \ $mandir/perlrun.1 \ - $mandir/perllocale.1 \ $mandir/perlfunc.1 \ $mandir/perlvar.1 \ $mandir/perlsub.1 \ $mandir/perlmod.1 \ $mandir/perlmodlib.1 \ + $mandir/perlmodinstall.1 \ + $mandir/perlform.1 \ + $mandir/perllocale.1 \ $mandir/perlref.1 \ $mandir/perldsc.1 \ $mandir/perllol.1 \ + $mandir/perltoot.1 \ $mandir/perlobj.1 \ $mandir/perltie.1 \ - $mandir/perltoot.1 \ $mandir/perlbot.1 \ + $mandir/perlipc.1 \ $mandir/perldebug.1 \ $mandir/perldiag.1 \ - $mandir/perlform.1 \ - $mandir/perlipc.1 \ $mandir/perlsec.1 \ $mandir/perltrap.1 \ + $mandir/perlport.1 \ $mandir/perlstyle.1 \ + $mandir/perlpod.1 \ + $mandir/perlbook.1 \ + $mandir/perlembed.1 \ $mandir/perlapio.1 \ $mandir/perlxs.1 \ $mandir/perlxstut.1 \ $mandir/perlguts.1 \ $mandir/perlcall.1 \ - $mandir/perlembed.1 \ - $mandir/perlpod.1 \ - $mandir/perlbook.1 \ + $mandir/perlhist.1 \ + $mandir/perldelta.1 \ + $mandir/perl5004delta.1 \ $mandir/perlfaq.1 \ $mandir/perlfaq1.1 \ $mandir/perlfaq2.1 \ @@ -75,13 +79,33 @@ toroff=` $mandir/perlfaq8.1 \ $mandir/perlfaq9.1 \ \ + $mandir/a2p.1 \ + $mandir/c2ph.1 \ + $mandir/h2ph.1 \ + $mandir/h2xs.1 \ + $mandir/perlbug.1 \ + $mandir/perldoc.1 \ + $mandir/pl2pm.1 \ + $mandir/pod2html.1 \ + $mandir/pod2man.1 \ + $mandir/s2p.1 \ + $mandir/splain.1 \ + $mandir/xsubpp.1 \ + \ + $libdir/attrs.3 \ + $libdir/autouse.3 \ + $libdir/base.3 \ $libdir/blib.3 \ + $libdir/constant.3 \ $libdir/diagnostics.3 \ + $libdir/fields.3 \ $libdir/integer.3 \ $libdir/less.3 \ $libdir/lib.3 \ $libdir/locale.3 \ + $libdir/ops.3 \ $libdir/overload.3 \ + $libdir/re.3 \ $libdir/sigtrap.3 \ $libdir/strict.3 \ $libdir/subs.3 \ @@ -90,34 +114,81 @@ toroff=` $libdir/AnyDBM_File.3 \ $libdir/AutoLoader.3 \ $libdir/AutoSplit.3 \ + $libdir/B.3 \ + $libdir/B::Asmdata.3 \ + $libdir/B::Assembler.3 \ + $libdir/B::Bblock.3 \ + $libdir/B::Bytecode.3 \ + $libdir/B::C.3 \ + $libdir/B::CC.3 \ + $libdir/B::Debug.3 \ + $libdir/B::Deparse.3 \ + $libdir/B::Disassembler.3 \ + $libdir/B::Lint.3 \ + $libdir/B::Showlex.3 \ + $libdir/B::Stackobj.3 \ + $libdir/B::Terse.3 \ + $libdir/B::Xref.3 \ $libdir/Benchmark.3 \ $libdir/Carp.3 \ + $libdir/CGI.3 \ + $libdir/CGI::Apache.3 \ + $libdir/CGI::Carp.3 \ + $libdir/CGI::Cookie.3 \ + $libdir/CGI::Fast.3 \ + $libdir/CGI::Push.3 \ + $libdir/CGI::Switch.3 \ + $libdir/Class::Struct.3 \ $libdir/Config.3 \ + $libdir/CPAN.3 \ + $libdir/CPAN::FirstTime.3 \ + $libdir/CPAN::Nox.3 \ $libdir/Cwd.3 \ + $libdir/Data::Dumper.3 \ $libdir/DB_File.3 \ $libdir/Devel::SelfStubber.3 \ + $libdir/DirHandle.3 \ $libdir/DynaLoader.3 \ $libdir/English.3 \ $libdir/Env.3 \ + $libdir/Errno.3 \ $libdir/Exporter.3 \ + $libdir/ExtUtils::Command.3 \ $libdir/ExtUtils::Embed.3 \ $libdir/ExtUtils::Install.3 \ + $libdir/ExtUtils::Installed.3 \ $libdir/ExtUtils::Liblist.3 \ $libdir/ExtUtils::MakeMaker.3 \ $libdir/ExtUtils::Manifest.3 \ + $libdir/ExtUtils::Miniperl.3 \ $libdir/ExtUtils::Mkbootstrap.3 \ $libdir/ExtUtils::Mksymlists.3 \ + $libdir/ExtUtils::MM_OS2.3 \ + $libdir/ExtUtils::MM_Unix.3 \ + $libdir/ExtUtils::MM_VMS.3 \ + $libdir/ExtUtils::MM_Win32.3 \ + $libdir/ExtUtils::Packlist.3 \ + $libdir/ExtUtils::testlib.3 \ + $libdir/Fatal.3 \ $libdir/Fcntl.3 \ $libdir/File::Basename.3 \ $libdir/File::CheckTree.3 \ - $libdir/File::Copy.3 \ $libdir/File::Compare.3 \ + $libdir/File::Copy.3 \ + $libdir/File::DosGlob.3 \ $libdir/File::Find.3 \ $libdir/File::Path.3 \ + $libdir/File::Spec.3 \ + $libdir/File::Spec::Mac.3 \ + $libdir/File::Spec::OS2.3 \ + $libdir/File::Spec::Unix.3 \ + $libdir/File::Spec::VMS.3 \ + $libdir/File::Spec::Win32.3 \ $libdir/File::stat.3 \ $libdir/FileCache.3 \ $libdir/FileHandle.3 \ $libdir/FindBin.3 \ + $libdir/GDBM_File.3 \ $libdir/Getopt::Long.3 \ $libdir/Getopt::Std.3 \ $libdir/I18N::Collate.3 \ @@ -128,21 +199,28 @@ toroff=` $libdir/IO::Seekable.3 \ $libdir/IO::Select.3 \ $libdir/IO::Socket.3 \ + $libdir/IPC::Msg.3 \ $libdir/IPC::Open2.3 \ $libdir/IPC::Open3.3 \ + $libdir/IPC::Semaphore.3 \ + $libdir/IPC::SysV.3 \ $libdir/Math::BigFloat.3 \ $libdir/Math::BigInt.3 \ $libdir/Math::Complex.3 \ $libdir/Math::Trig.3 \ - $libdir/Net::Ping.3 \ + $libdir/NDBM_File.3 \ $libdir/Net::hostent.3 \ $libdir/Net::netent.3 \ + $libdir/Net::Ping.3 \ $libdir/Net::protoent.3 \ $libdir/Net::servent.3 \ + $libdir/O.3 \ $libdir/Opcode.3 \ - $libdir/POSIX.3 \ + $libdir/Pod::Html.3 \ $libdir/Pod::Text.3 \ + $libdir/POSIX.3 \ $libdir/Safe.3 \ + $libdir/SDBM_File.3 \ $libdir/Search::Dict.3 \ $libdir/SelectSaver.3 \ $libdir/SelfLoader.3 \ @@ -153,50 +231,54 @@ toroff=` $libdir/Sys::Syslog.3 \ $libdir/Term::Cap.3 \ $libdir/Term::Complete.3 \ + $libdir/Term::ReadLine.3 \ + $libdir/Test.3 \ $libdir/Test::Harness.3 \ $libdir/Text::Abbrev.3 \ $libdir/Text::ParseWords.3 \ $libdir/Text::Soundex.3 \ $libdir/Text::Tabs.3 \ + $libdir/Text::Wrap.3 \ + $libdir/Tie::Array.3 \ + $libdir/Tie::Handle.3 \ $libdir/Tie::Hash.3 \ $libdir/Tie::RefHash.3 \ $libdir/Tie::Scalar.3 \ $libdir/Tie::SubstrHash.3 \ - $libdir/Time::Local.3 \ $libdir/Time::gmtime.3 \ + $libdir/Time::Local.3 \ $libdir/Time::localtime.3 \ $libdir/Time::tm.3 \ $libdir/UNIVERSAL.3 \ $libdir/User::grent.3 \ $libdir/User::pwent.3 | \ -perl -ne 'map { -r && print "$_ " } split'` + perl -ne 'map { -r && print "$_ " } split'` -# Bypass internal shell buffer limit -- can't use case -if perl -e '$a = shift; exit($a =~ m|/|)' $toroff; then + # Bypass internal shell buffer limit -- can't use case + if perl -e '$a = shift; exit($a =~ m|/|)' $toroff; then echo "$me: empty file list -- did you run install?" >&2 exit 1 -fi - -#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 + fi -# First, create the raw data -run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw" -echo "$me: running $run" -eval $run $toroff + #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 -#Now create the TOC -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 + # First, create the raw data + run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw" + echo "$me: running $run" + eval $run $toroff -# Finally, recreate the Doc, without the blank page 0 -run="$cmd -rC1 -rD1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw" -echo "$me: running $run" -eval $run $toroff -rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw -echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext" + #Now create the TOC + 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 + # Finally, recreate the Doc, without the blank page 0 + run="$cmd -rC1 -rD1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw" + echo "$me: running $run" + eval $run $toroff + rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw + echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext" @@ -3100,6 +3100,20 @@ mul128(SV *sv, U8 m) /* Explosives and implosives. */ +static const char uuemap[] = + "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; +static char uudmap[256]; /* Initialised on first use */ +#if 'I' == 73 && 'J' == 74 +/* On an ASCII/ISO kind of system */ +#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') +#else +/* + Some other sort of character set - use memchr() so we don't match + the null byte. + */ +#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ') +#endif + PP(pp_unpack) { djSP; @@ -3748,31 +3762,48 @@ PP(pp_unpack) } break; case 'u': + /* MKS: + * Initialise the decode mapping. By using a table driven + * algorithm, the code will be character-set independent + * (and just as fast as doing character arithmetic) + */ + if (uudmap['M'] == 0) { + int i; + + for (i = 0; i < sizeof(uuemap); i += 1) + uudmap[uuemap[i]] = i; + /* + * Because ' ' and '`' map to the same value, + * we need to decode them both the same. + */ + uudmap[' '] = 0; + } + along = (strend - s) * 3 / 4; sv = NEWSV(42, along); if (along) SvPOK_on(sv); - while (s < strend && *s > ' ' && *s < 'a') { + while (s < strend && *s > ' ' && ISUUCHAR(*s)) { I32 a, b, c, d; char hunk[4]; hunk[3] = '\0'; len = (*s++ - ' ') & 077; while (len > 0) { - if (s < strend && *s >= ' ') - a = (*s++ - ' ') & 077; - else - a = 0; - if (s < strend && *s >= ' ') - b = (*s++ - ' ') & 077; - else - b = 0; - if (s < strend && *s >= ' ') - c = (*s++ - ' ') & 077; - else - c = 0; - if (s < strend && *s >= ' ') - d = (*s++ - ' ') & 077; + if (s < strend && ISUUCHAR(*s)) + a = uudmap[*s++] & 077; + else + a = 0; + if (s < strend && ISUUCHAR(*s)) + b = uudmap[*s++] & 077; + else + b = 0; + if (s < strend && ISUUCHAR(*s)) + c = uudmap[*s++] & 077; + else + c = 0; + if (s < strend && ISUUCHAR(*s)) + d = uudmap[*s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); @@ -3833,21 +3864,25 @@ doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; - *hunk = len + ' '; + *hunk = uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; - while (len > 0) { - hunk[0] = ' ' + (077 & (*s >> 2)); - hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017))); - hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03))); - hunk[3] = ' ' + (077 & (s[2] & 077)); + while (len > 2) { + hunk[0] = uuemap[(077 & (*s >> 2))]; + hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; + hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; + hunk[3] = uuemap[(077 & (s[2] & 077))]; sv_catpvn(sv, hunk, 4); s += 3; len -= 3; } - for (s = SvPVX(sv); *s; s++) { - if (*s == ' ') - *s = '`'; + if (len > 0) { + char r = (len > 1 ? s[1] : '\0'); + hunk[0] = uuemap[(077 & (*s >> 2))]; + hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; + hunk[2] = uuemap[(077 & ((r << 2) & 074))]; + hunk[3] = uuemap[0]; + sv_catpvn(sv, hunk, 4); } sv_catpvn(sv, "\n", 1); } @@ -4682,7 +4717,7 @@ unlock_condpair(void *svv) croak("panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", (unsigned long)thr, (unsigned long)svv);) MUTEX_UNLOCK(MgMUTEXP(mg)); } @@ -4707,7 +4742,7 @@ PP(pp_lock) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */ @@ -522,15 +522,13 @@ PP(pp_formline) break; } while (arg--) { -#if 'z' - 'a' != 25 +#ifdef EBCDIC int ch = *t++ = *s++; - if (!iscntrl(ch)) - t[-1] = ' '; + if (iscntrl(ch)) #else if ( !((*t++ = *s++) & ~31) ) - t[-1] = ' '; #endif - + t[-1] = ' '; } break; @@ -21,6 +21,12 @@ #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef I_FCNTL +#include <fcntl.h> +#endif +#ifdef I_SYS_FILE +#include <sys/file.h> +#endif #define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) @@ -35,10 +41,10 @@ unset_cvowner(void *cvarg) dTHR; #endif /* DEBUGGING */ - DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); MUTEX_LOCK(CvMUTEXP(cv)); - DEBUG_L(if (CvDEPTH(cv) != 0) + DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", CvDEPTH(cv));); assert(thr == CvOWNER(cv)); @@ -1068,7 +1074,7 @@ do_readline(void) IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; if (av_len(GvAVn(PL_last_in_gv)) < 0) { - do_open(PL_last_in_gv,"-",1,FALSE,0,0,Nullfp); + do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); sv_setpvn(GvSV(PL_last_in_gv), "-", 1); SvSETMAGIC(GvSV(PL_last_in_gv)); fp = IoIFP(io); @@ -1202,7 +1208,7 @@ do_readline(void) #endif /* !CSH */ #endif /* !DOSISH */ (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, 0, 0, Nullfp); + FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); #endif /* !VMS */ LEAVE; @@ -1249,7 +1255,7 @@ do_readline(void) IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - if (do_close(PL_last_in_gv, FALSE) & ~0xFF) + if (!do_close(PL_last_in_gv, FALSE)) warn("internal error: glob failed"); } if (gimme == G_SCALAR) { @@ -1465,7 +1471,9 @@ PP(pp_iter) char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1) { + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { /* safe to reuse old SV */ sv_setsv(*cx->blk_loop.itervar, cur); } @@ -1491,7 +1499,9 @@ PP(pp_iter) RETPUSHNO; #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1) { + if (SvREFCNT(*cx->blk_loop.itervar) == 1 + && !SvMAGICAL(*cx->blk_loop.itervar)) + { /* safe to reuse old SV */ sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); } @@ -2089,7 +2099,7 @@ PP(pp_entersub) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */ @@ -2133,7 +2143,7 @@ PP(pp_entersub) /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "entersub: %p already has clone %p:%s\n", thr, cv, SvPEEK((SV*)cv))); CvOWNER(cv) = thr; @@ -2147,7 +2157,7 @@ PP(pp_entersub) CvOWNER(cv) = thr; SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "entersub: %p grabbing %p:%s in stash %s\n", thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? HvNAME(CvSTASH(cv)) : "(none)")); @@ -2156,7 +2166,7 @@ PP(pp_entersub) CV *clonecv; SvREFCNT_inc(cv); /* don't let it vanish from under us */ MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_L((PerlIO_printf(PerlIO_stderr(), + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "entersub: %p cloning %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); /* @@ -2173,7 +2183,7 @@ PP(pp_entersub) cv = clonecv; SvREFCNT_inc(cv); } - DEBUG_L(if (CvDEPTH(cv) != 0) + DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", CvDEPTH(cv));); SAVEDESTRUCTOR(unset_cvowner, (void*) cv); @@ -2323,7 +2333,7 @@ PP(pp_entersub) SV** ary; #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p entersub preparing @_\n", thr)); #endif av = (AV*)PL_curpad[0]; @@ -2361,7 +2371,7 @@ PP(pp_entersub) } } #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p entersub returning %p\n", thr, CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); @@ -382,7 +382,7 @@ PP(pp_open) if (GvIOp(gv)) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; tmps = SvPV(sv, len); - if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp)) + if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp)) PUSHi( (I32)PL_forkprocess ); else if (PL_forkprocess == 0) /* we are a new child */ PUSHi(0); @@ -2608,12 +2608,17 @@ PP(pp_fttext) odd += len; break; } +#ifdef EBCDIC + else if (!(isPRINT(*s) || isSPACE(*s))) + odd++; +#else else if (*s & 128) odd++; else if (*s < 32 && *s != '\n' && *s != '\r' && *s != '\b' && *s != '\t' && *s != '\f' && *s != 27) odd++; +#endif } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ @@ -2739,7 +2744,7 @@ PP(pp_rename) if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { - if (euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) + if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps, tmps2))) anum = UNLINK(tmps); @@ -1,10 +1,19 @@ +#ifndef PERL_CALLCONV +# define PERL_CALLCONV +#endif + #ifdef PERL_OBJECT -#define VIRTUAL virtual +#define VIRTUAL virtual PERL_CALLCONV #else -#define VIRTUAL +#define VIRTUAL PERL_CALLCONV START_EXTERN_C #endif +/* NOTE!!! When new virtual functions are added, they must be added at + * the end of this file to maintain binary compatibility with PERL_OBJECT + */ + + #ifndef NEXT30_NO_ATTRIBUTE #ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ #ifdef __attribute__ /* Avoid possible redefinition errors */ @@ -559,13 +568,9 @@ VIRTUAL void sv_add_arena _((char* ptr, U32 size, U32 flags)); VIRTUAL int sv_backoff _((SV* sv)); VIRTUAL SV* sv_bless _((SV* sv, HV* stash)); VIRTUAL void sv_catpvf _((SV* sv, const char* pat, ...)); -VIRTUAL void sv_catpvf_mg _((SV *sv, const char* pat, ...)); VIRTUAL void sv_catpv _((SV* sv, char* ptr)); -VIRTUAL void sv_catpv_mg _((SV *sv, char *ptr)); VIRTUAL void sv_catpvn _((SV* sv, char* ptr, STRLEN len)); -VIRTUAL void sv_catpvn_mg _((SV *sv, char *ptr, STRLEN len)); VIRTUAL void sv_catsv _((SV* dsv, SV* ssv)); -VIRTUAL void sv_catsv_mg _((SV *dstr, SV *sstr)); VIRTUAL void sv_chop _((SV* sv, char* ptr)); VIRTUAL void sv_clean_all _((void)); VIRTUAL void sv_clean_objs _((void)); @@ -607,25 +612,17 @@ VIRTUAL void sv_replace _((SV* sv, SV* nsv)); VIRTUAL void sv_report_used _((void)); VIRTUAL void sv_reset _((char* s, HV* stash)); VIRTUAL void sv_setpvf _((SV* sv, const char* pat, ...)); -VIRTUAL void sv_setpvf_mg _((SV *sv, const char* pat, ...)); VIRTUAL void sv_setiv _((SV* sv, IV num)); -VIRTUAL void sv_setiv_mg _((SV *sv, IV i)); VIRTUAL void sv_setpviv _((SV* sv, IV num)); -VIRTUAL void sv_setpviv_mg _((SV *sv, IV iv)); VIRTUAL void sv_setuv _((SV* sv, UV num)); -VIRTUAL void sv_setuv_mg _((SV *sv, UV u)); VIRTUAL void sv_setnv _((SV* sv, double num)); -VIRTUAL void sv_setnv_mg _((SV *sv, double num)); VIRTUAL SV* sv_setref_iv _((SV* rv, char* classname, IV iv)); VIRTUAL SV* sv_setref_nv _((SV* rv, char* classname, double nv)); VIRTUAL SV* sv_setref_pv _((SV* rv, char* classname, void* pv)); VIRTUAL SV* sv_setref_pvn _((SV* rv, char* classname, char* pv, I32 n)); VIRTUAL void sv_setpv _((SV* sv, const char* ptr)); -VIRTUAL void sv_setpv_mg _((SV *sv, const char *ptr)); VIRTUAL void sv_setpvn _((SV* sv, const char* ptr, STRLEN len)); -VIRTUAL void sv_setpvn_mg _((SV *sv, const char *ptr, STRLEN len)); VIRTUAL void sv_setsv _((SV* dsv, SV* ssv)); -VIRTUAL void sv_setsv_mg _((SV *dstr, SV *sstr)); VIRTUAL void sv_taint _((SV* sv)); VIRTUAL bool sv_tainted _((SV* sv)); VIRTUAL int sv_unmagic _((SV* sv, int type)); @@ -633,7 +630,6 @@ VIRTUAL void sv_unref _((SV* sv)); VIRTUAL void sv_untaint _((SV* sv)); VIRTUAL bool sv_upgrade _((SV* sv, U32 mt)); VIRTUAL void sv_usepvn _((SV* sv, char* ptr, STRLEN len)); -VIRTUAL void sv_usepvn_mg _((SV *sv, char *ptr, STRLEN len)); VIRTUAL void sv_vcatpvfn _((SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *used_locale)); @@ -932,3 +928,21 @@ VIRTUAL void byterun _((struct bytestream bs)); VIRTUAL void byterun _((PerlIO *fp)); #endif /* INDIRECT_BGET_MACROS */ +VIRTUAL void sv_catpvf_mg _((SV *sv, const char* pat, ...)); +VIRTUAL void sv_catpv_mg _((SV *sv, char *ptr)); +VIRTUAL void sv_catpvn_mg _((SV *sv, char *ptr, STRLEN len)); +VIRTUAL void sv_catsv_mg _((SV *dstr, SV *sstr)); +VIRTUAL void sv_setpvf_mg _((SV *sv, const char* pat, ...)); +VIRTUAL void sv_setiv_mg _((SV *sv, IV i)); +VIRTUAL void sv_setpviv_mg _((SV *sv, IV iv)); +VIRTUAL void sv_setuv_mg _((SV *sv, UV u)); +VIRTUAL void sv_setnv_mg _((SV *sv, double num)); +VIRTUAL void sv_setpv_mg _((SV *sv, const char *ptr)); +VIRTUAL void sv_setpvn_mg _((SV *sv, const char *ptr, STRLEN len)); +VIRTUAL void sv_setsv_mg _((SV *dstr, SV *sstr)); +VIRTUAL void sv_usepvn_mg _((SV *sv, char *ptr, STRLEN len)); + +/* New virtual functions must be added here to maintain binary + * compatablity with PERL_OBJECT + */ + @@ -319,7 +319,10 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 } if (OP(scan) != CURLYX) { - int max = (reg_off_by_arg[OP(scan)] ? I32_MAX : U16_MAX); + int max = (reg_off_by_arg[OP(scan)] + ? I32_MAX + /* I32 may be smaller than U16 on CRAYs! */ + : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX)); int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan)); int noff; regnode *n = scan; @@ -872,10 +872,13 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, else { STRLEN len; char *little = SvPV(prog->float_substr, len); - last = rninstr(s, strend, little, little + len); + if (len) + last = rninstr(s, strend, little, little + len); + else + last = strend; /* matching `$' */ } if (last == NULL) goto phooey; /* Should not happen! */ - dontbother = strend - last - 1; + dontbother = strend - last + prog->float_min_offset; } if (minlen && (dontbother < minlen)) dontbother = minlen - 1; @@ -883,11 +886,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, /* We don't know much -- general case. */ if (UTF) { for (;;) { - if (regtry(prog, s)) { - strend += dontbother; /* this one's always in bytes! */ - dontbother = 0; + if (regtry(prog, s)) goto got_it; - } if (s >= strend) break; s += UTF8SKIP(s); @@ -905,9 +905,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, goto phooey; got_it: - strend = HOP(strend, dontbother); /* uncheat */ prog->subbeg = strbeg; - prog->subend = strend; + prog->subend = PL_regeol; /* strend may have been modified */ RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted); /* make sure $`, $&, $', and $digit will work later */ @@ -919,7 +918,7 @@ got_it: } } else { - I32 i = strend - startpos + (stringarg - strbeg); + I32 i = PL_regeol - startpos + (stringarg - strbeg); s = savepvn(strbeg, i); Safefree(prog->subbase); prog->subbase = s; @@ -1728,7 +1727,9 @@ regmatch(regnode *prog) } if (PL_dowarn && n >= REG_INFTY && !(PL_reg_flags & RF_warned)) { PL_reg_flags |= RF_warned; - warn("count exceeded %d", REG_INFTY - 1); + warn("%s limit (%d) exceeded", + "Complex regular subexpression recursion", + REG_INFTY - 1); } /* Failed deeper matches of scan, so see if this one works. */ @@ -382,7 +382,7 @@ save_threadsv(PADOFFSET i) #ifdef USE_THREADS dTHR; SV **svp = &THREADSV(i); /* XXX Change to save by offset */ - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n", i, svp, *svp, SvPEEK(*svp))); save_svref(svp); return svp; @@ -567,7 +567,7 @@ leave_scope(I32 base) ptr = SSPOPPTR; restore_sv: sv = *(SV**)ptr; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "restore svref: %p %p:%s -> %p:%s\n", ptr, sv, SvPEEK(sv), value, SvPEEK(value))); if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) && @@ -2097,7 +2097,6 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - dTHR; SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; int intro = GvINTRO(dstr); @@ -2886,7 +2885,8 @@ sv_clear(register SV *sv) stash = NULL; switch (SvTYPE(sv)) { case SVt_PVIO: - if (IoIFP(sv) != PerlIO_stdin() && + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) io_close((IO*)sv); @@ -3620,10 +3620,24 @@ sv_inc(register SV *sv) *(d--) = '0'; } else { +#ifdef EBCDIC + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (*d != 'z' && *d != 'Z') { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; +#else ++*d; if (isALPHA(*d)) return; *(d--) -= 'z' - 'a' + 1; +#endif } } /* oh,oh, the number grew */ @@ -48,6 +48,14 @@ EOT $total = @tests; $files = 0; $totmax = 0; + $maxlen = 0; + foreach (@tests) { + $len = length; + $maxlen = $len if $len > $maxlen; + } + # +3 : we want three dots between the test name and the "ok" + # -2 : the .t suffix + $dotdotdot = $maxlen + 3 - 2; while ($test = shift @tests) { if ( $infinite{$test} && $type eq 'compile' ) { @@ -59,7 +67,7 @@ EOT } $te = $test; chop($te); - print "$te" . '.' x (18 - length($te)); + print "$te" . '.' x ($dotdotdot - length($te)); open(SCRIPT,"<$test") or die "Can't run $test.\n"; $_ = <SCRIPT>; diff --git a/t/base/rs.t b/t/base/rs.t index 5428603304..52a957260f 100755 --- a/t/base/rs.t +++ b/t/base/rs.t @@ -85,6 +85,7 @@ $bar = <TESTFILE>; if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";} # Get rid of the temp file +close TESTFILE; unlink "./foo"; # Now for the tricky bit--full record reading @@ -120,6 +121,7 @@ if ($^O eq 'VMS') { $bar = <TESTFILE>; if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";} + close TESTFILE; unlink "./foo.bar"; unlink "./foo.com"; } else { diff --git a/t/base/term.t b/t/base/term.t index 782ad397d3..e96313dec5 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -2,12 +2,22 @@ # $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + print "1..7\n"; # check "" interpretation $x = "\n"; -if ($x eq chr(10)) {print "ok 1\n";} else {print "not ok 1\n";} +# 10 is ASCII/Iso Latin, 21 is EBCDIC. +if ($x eq chr(10) || + ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";} +else {print "not ok 1\n";} # check `` processing diff --git a/t/cmd/subval.t b/t/cmd/subval.t index 3c1ffb89ea..3c60690ebf 100755 --- a/t/cmd/subval.t +++ b/t/cmd/subval.t @@ -33,7 +33,7 @@ sub foo6 { 'true2' unless $_[0]; } -print "1..34\n"; +print "1..36\n"; if (&foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";} if (&foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} @@ -177,3 +177,10 @@ sub iseof { eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n"; } } + +sub autov { $_[0] = 23 }; + +my $href = {}; +print keys %$href ? 'not ' : '', "ok 35\n"; +autov($href->{b}); +print join(':', %$href) eq 'b:23' ? '' : 'not ', "ok 36\n"; diff --git a/t/comp/package.t b/t/comp/package.t index cef02c5cb4..d7d19ae882 100755 --- a/t/comp/package.t +++ b/t/comp/package.t @@ -23,7 +23,11 @@ $main = join(':', sort(keys %main::)); $xyz = join(':', sort(keys %xyz::)); $ABC = join(':', sort(keys %ABC::)); -print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +if ('a' lt 'A') { + print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +} else { + print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +} print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; diff --git a/t/comp/require.t b/t/comp/require.t index bae0712dfa..203b996e06 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -7,17 +7,27 @@ BEGIN { # don't make this lexical $i = 1; -print "1..3\n"; +print "1..4\n"; sub do_require { %INC = (); - open(REQ,">bleah.pm") or die "Can't write 'bleah.pm': $!"; - print REQ @_; - close REQ; + write_file('bleah.pm',@_); eval { require "bleah.pm" }; my @a; # magic guard for scope violations (must be first lexical in file) } +sub write_file { + my $f = shift; + open(REQ,">$f") or die "Can't write '$f': $!"; + print REQ @_; + close REQ; +} + +# interaction with pod (see the eof) +write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); +require "bleah.pm"; +$i++; + # run-time failure in require do_require "0;\n"; print "# $@\nnot " unless $@ =~ /did not return a true/; @@ -25,7 +35,7 @@ print "ok ",$i++,"\n"; # compile-time failure in require do_require "1)\n"; -print "# $@\nnot " unless $@ =~ /syntax error/; +print "# $@\nnot " unless $@ =~ /syntax error/i; print "ok ",$i++,"\n"; # successful require @@ -33,4 +43,8 @@ do_require "1"; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; -unlink 'bleah.pm'; +END { unlink 'bleah.pm'; } + +# ***interaction with pod (don't put any thing after here)*** + +=pod @@ -9,7 +9,7 @@ BEGIN { use Config; -$Is_Dos=$^O eq 'dos'; +$Is_Dosish = ($^O eq 'dos' or $^O eq 'os2'); # avoid win32 (for now) do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; @@ -32,35 +32,56 @@ close(fh); open(fh,'>a') || die "Can't create a"; close(fh); -if (eval {link('a','b')} || $Is_Dos) {print "ok 2\n";} else {print "not ok 2\n";} +if ($Is_Dosish) {print "ok 2 # skipped: no link\n";} +elsif (eval {link('a','b')}) {print "ok 2\n";} +else {print "not ok 2\n";} -if (eval {link('b','c')} || $Is_Dos) {print "ok 3\n";} else {print "not ok 3\n";} +if ($Is_Dosish) {print "ok 3 # skipped: no link\n";} +elsif (eval {link('b','c')}) {print "ok 3\n";} +else {print "not ok 3\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); -if ($Config{dont_use_nlink} || $nlink == 3 || $Is_Dos) - {print "ok 4\n";} else {print "not ok 4\n";} +if ($Config{dont_use_nlink} || $Is_Dosish) + {print "ok 4 # skipped: no link\n";} +elsif ($nlink == 3) + {print "ok 4\n";} +else {print "not ok 4\n";} -if (($mode & 0777) == 0666 || $^O eq 'amigaos' || $Is_Dos) - {print "ok 5\n";} else {print "not ok 5\n";} +if ($^O eq 'amigaos' || $Is_Dosish) + {print "ok 5 # skipped: no link\n";} +elsif (($mode & 0777) == 0666) + {print "ok 5\n";} +else {print "not ok 5\n";} if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); -if (($mode & 0777) == 0777 || $Is_Dos) {print "ok 7\n";} else {print "not ok 7\n";} +if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} +elsif (($mode & 0777) == 0777) {print "ok 7\n";} +else {print "not ok 7\n";} -if ((chmod 0700,'c','x') == 2 || $Is_Dos) {print "ok 8\n";} else {print "not ok 8\n";} +if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} +elsif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} +else {print "not ok 8\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); -if (($mode & 0777) == 0700 || $Is_Dos) {print "ok 9\n";} else {print "not ok 9\n";} +if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {print "ok 9\n";} +else {print "not ok 9\n";} + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); -if (($mode & 0777) == 0700 || $Is_Dos) {print "ok 10\n";} else {print "not ok 10\n";} +if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {print "ok 10\n";} +else {print "not ok 10\n";} -if ((unlink 'b','x') == 2 || $Is_Dos) {print "ok 11\n";} else {print "not ok 11\n";} +if ($Is_Dosish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; } +elsif ((unlink 'b','x') == 2) {print "ok 11\n";} +else {print "not ok 11\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";} @@ -72,13 +93,15 @@ if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('a'); if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} -$foo = (utime 500000000,500000001,'b'); +$delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem +$foo = (utime 500000000,500000000 + $delta,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} -if (($atime == 500000000 && $mtime == 500000001) - || $wd =~ m#/afs/# || $^O eq 'amigaos' || $Is_Dos) +if ($wd =~ m#/afs/# || $^O eq 'amigaos') + {print "ok 18 # skipped: granularity of the filetime\n";} +elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";} @@ -122,12 +145,12 @@ else { { select FH; $| = 1; select STDOUT } print FH "helloworld\n"; truncate FH, 5; - if ($Is_Dos) { + if ($^O eq 'dos') { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} truncate FH, 0; - if ($Is_Dos) { + if ($^O eq 'dos') { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t index 4357975f2b..e7cac26323 100755 --- a/t/lib/bigintpm.t +++ b/t/lib/bigintpm.t @@ -5,7 +5,6 @@ BEGIN { @INC = '../lib'; } -use Config; use Math::BigInt; $test = 0; diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t index d7f3ffb4aa..16aa824c51 100755 --- a/t/lib/cgi-html.t +++ b/t/lib/cgi-html.t @@ -9,7 +9,8 @@ BEGIN { } BEGIN {$| = 1; print "1..17\n"; } -BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";} +BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; + $eol = "\r\n" if $^O eq 'os390'; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug'); $loaded = 1; diff --git a/t/lib/filehand.t b/t/lib/filehand.t index 08cae71872..b8ec95f320 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -31,7 +31,7 @@ $buffer = <$fh>; print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; -ungetc $fh 65; +ungetc $fh ord 'A'; CORE::read($fh, $buf,1); print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; diff --git a/t/lib/io_pipe.t b/t/lib/io_pipe.t index e1c48b6a7e..e617c92432 100755 --- a/t/lib/io_pipe.t +++ b/t/lib/io_pipe.t @@ -41,6 +41,13 @@ print $pipe "not ok 3\n" ; $pipe->close or print "# \$!=$!\nnot "; print "ok 4\n"; +# Check if can fork with dynamic extensions (bug in CRT): +if ($^O eq 'os2' and + system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { + print "ok $_ # skipped: broken fork\n" for 5..10; + exit 0; +} + $pipe = new IO::Pipe; $pid = fork(); diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 9fab56b237..8fc52e4026 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -32,6 +32,13 @@ $listen = IO::Socket::INET->new(Listen => 2, print "ok 1\n"; +# Check if can fork with dynamic extensions (bug in CRT): +if ($^O eq 'os2' and + system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { + print "ok $_ # skipped: broken fork\n" for 2..5; + exit 0; +} + $port = $listen->sockport; if($pid = fork()) { diff --git a/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t index f74c5fa060..30ea48d999 100755 --- a/t/lib/ipc_sysv.t +++ b/t/lib/ipc_sysv.t @@ -28,6 +28,27 @@ my $sem; $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed +# FreeBSD is known to throw this if there's no SysV IPC in the kernel. +$SIG{SYS} = sub { + print STDERR <<EOM; +SIGSYS caught. +It may be that your kernel does not have SysV IPC configured. + +EOM + if ($^O eq 'freebsd') { + print STDERR <<EOM; +You must have following options in your kernel: + +options SYSVSHM +options SYSVSEM +options SYSVMSG + +See config(8). +EOM + } + exit(1); +}; + if ($Config{'d_msgget'} eq 'define' && $Config{'d_msgctl'} eq 'define' && $Config{'d_msgsnd'} eq 'define' && diff --git a/t/lib/ph.t b/t/lib/ph.t index d0a48f6c51..de27dee5e2 100755 --- a/t/lib/ph.t +++ b/t/lib/ph.t @@ -9,8 +9,6 @@ BEGIN { @INC = '../lib'; } -use Config; - # All the constants which Socket.pm tries to make available: my @possibly_defined = qw( INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT diff --git a/t/lib/posix.t b/t/lib/posix.t index c071c3b067..8dafc80387 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -96,5 +96,6 @@ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); $| = 0; -print '@#!*$@(!@#$'; +# The following line assumes buffered output, which may be not true with EMX: +print '@#!*$@(!@#$' unless $^O eq 'os2'; _exit(0); diff --git a/t/op/auto.t b/t/op/auto.t index 93a42f8472..2eb0097650 100755 --- a/t/op/auto.t +++ b/t/op/auto.t @@ -2,7 +2,7 @@ # $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $ -print "1..34\n"; +print "1..37\n"; $x = 10000; if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";} @@ -46,3 +46,7 @@ if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";} if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";} if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";} if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";} +if (++($foo = 'A99') eq 'B00') {print "ok 35\n";} else {print "not ok 35\n";} +# EBCDIC guards: i and j, r and s, are not contiguous. +if (++($foo = 'zi') eq 'zj') {print "ok 36\n";} else {print "not ok 36\n";} +if (++($foo = 'zr') eq 'zs') {print "ok 37\n";} else {print "not ok 37\n";} diff --git a/t/op/bop.t b/t/op/bop.t index 0c55029b93..b247341417 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -42,14 +42,23 @@ print ((($cusp >> 1) == ($cusp / 2) && do { use integer; $cusp >> 1 } == -($cusp / 2)) ? "ok 12\n" : "not ok 12\n"); +$Aaz = chr(ord("A") & ord("z")); +$Aoz = chr(ord("A") | ord("z")); +$Axz = chr(ord("A") ^ ord("z")); + # short strings -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"); +print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n"); # long strings $foo = "A" x 150; $bar = "z" x 75; -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"); +$zap = "A" x 75; +# & truncates +print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n"); +# | does not truncate +print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n"); +# ^ does not truncate +print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n"); + diff --git a/t/op/defins.t b/t/op/defins.t index 0ed61ce2fb..33c74ea28e 100755 --- a/t/op/defins.t +++ b/t/op/defins.t @@ -61,6 +61,7 @@ while ($where{$seen} = <FILE>) } print "not " unless $seen; print "ok 5\n"; +close FILE; opendir(DIR,'.'); $seen = 0; diff --git a/t/op/die_exit.t b/t/op/die_exit.t index b5760d6fa0..ffbb1e015e 100755 --- a/t/op/die_exit.t +++ b/t/op/die_exit.t @@ -30,6 +30,8 @@ my %tests = ( 14 => [ 255, 0], 15 => [ 255, 1], 16 => [ 255, 256], + # see if implicit close preserves $? + 17 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } die;'], ); my $max = keys %tests; @@ -37,11 +39,12 @@ my $max = keys %tests; print "1..$max\n"; foreach my $test (1 .. $max) { - my($bang, $query) = @{$tests{$test}}; + my($bang, $query, $code) = @{$tests{$test}}; + $code ||= 'die;'; my $exit = ($^O eq 'MSWin32' - ? system qq($perl -e "\$! = $bang; \$? = $query; die;" 2> nul) - : system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null)); + ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul) + : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null)); printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query unless $exit == (($bang || ($query >> 8) || 255) << 8); diff --git a/t/op/each.t b/t/op/each.t index 420fdc09c3..9063c2c3ed 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -43,7 +43,8 @@ if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";} $i = 0; # stop -w complaints while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + if ($key eq $keys[$i] && $value eq $values[$i] + && (('a' lt 'A' && $key lt $value) || $key gt $value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } diff --git a/t/op/exec.t b/t/op/exec.t index 506fc09fbd..098a455455 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -13,7 +13,12 @@ if ($^O eq 'MSWin32') { print "1..8\n"; -print "not ok 1\n" if system "echo ok \\1"; # shell interpreted +if ($^O ne 'os2') { + print "not ok 1\n" if system "echo ok \\1"; # shell interpreted +} +else { + print "ok 1 # skipped: bug/feature of pdksh\n"; # shell interpreted +} print "not ok 2\n" if system "echo ok 2"; # split and directly called print "not ok 3\n" if system "echo", "ok", "3"; # directly called diff --git a/t/op/magic.t b/t/op/magic.t index 61e4522913..7f08e06f85 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -135,6 +135,12 @@ __END__ :endofperl EOT } + if ($^O eq 'os390') { # no shebang + $headmaybe = <<EOH ; + eval 'exec ./perl -S \$0 \${1+"\$\@"}' + if 0; +EOH + } $s1 = $s2 = "\$^X is $perl, \$0 is $script\n"; ok 19, open(SCRIPT, ">$script"), $!; ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; diff --git a/t/op/misc.t b/t/op/misc.t index 449d87cea1..7292ffebd4 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -36,6 +36,7 @@ for (@prgs){ $status = $?; $results = `$CAT $tmpfile`; $results =~ s/\n+$//; + $results =~ s/syntax error/syntax error/i; $expected =~ s/\n+$//; if ( $results ne $expected){ print STDERR "PROG: $switch\n$prog\n"; diff --git a/t/op/ord.t b/t/op/ord.t index 37128382d8..ba943f4e8c 100755 --- a/t/op/ord.t +++ b/t/op/ord.t @@ -6,11 +6,13 @@ print "1..3\n"; # compile time evaluation -if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";} +# 65 ASCII +# 193 EBCDIC +if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} # run time evaluation $x = 'ABC'; -if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";} +if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} -if (chr 65 == A) {print "ok 3\n";} else {print "not ok 3\n";} +if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op/pack.t b/t/op/pack.t index b8aece6b6b..9b7bc351f9 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..56\n"; +print "1..60\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -30,7 +30,10 @@ print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ? "ok 6\n" : "not ok 6 $x\n"; -print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == 129 +my $sum = 129; # ASCII +$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant. + +print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ? "ok 7\n" : "not ok 7 $x\n"; open(BIN, "./perl") || open(BIN, "./perl.exe") @@ -154,3 +157,49 @@ foreach my $t (@templates) { unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i)); print "ok ", $test++, "\n"; } + +# 57..60: uuencode/decode + +$in = join "", map { chr } 0..255; + +# just to be anal, we do some random tr/`/ / +$uu = <<'EOUU'; +M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL +M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9 +M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6& +MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S +MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@ +?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` +EOUU + +$_ = $uu; +tr/ /`/; +print "not " unless pack('u', $in) eq $_; +print "ok ", $test++, "\n"; + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +$in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; +$uu = <<'EOUU'; +M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F +&8%P:```` +EOUU + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +# 60 identical to 59 except that backquotes have been changed to spaces + +$uu = <<'EOUU'; +M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F +&8%P: +EOUU + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +# Note that first uuencoding known 'text' data and then checking the +# binary values of the uuencoded version would not be portable between +# character sets. Uuencoding is meant for encoding binary data, not +# text data. diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t index 20dd312b31..913e07cdd6 100755 --- a/t/op/quotemeta.t +++ b/t/op/quotemeta.t @@ -1,14 +1,26 @@ #!./perl + print "1..15\n"; -$_=join "", map chr($_), 32..127; +if ($^O eq 'os390') { # An EBCDIC variant. + $_=join "", map chr($_), 129..233; + + # 105 characters - 52 letters = 53 backslashes + # 105 characters + 53 backslashes = 158 characters + $_=quotemeta $_; + if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} + # 104 non-backslash characters + if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} +} else { # some ASCII descendant, then. + $_=join "", map chr($_), 32..127; -# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes -# 96 characters + 33 backslashes = 129 characters -$_=quotemeta $_; -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"} + # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes + # 96 characters + 33 backslashes = 129 characters + $_=quotemeta $_; + 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"} +} if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} diff --git a/t/op/re_tests b/t/op/re_tests index 7ac20c3852..a5295f5aae 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -151,8 +151,8 @@ a[bcd]+dcdcde adcdcde n - - (bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz- ((((((((((a)))))))))) a y $10 a ((((((((((a))))))))))\10 aa y $& aa -((((((((((a))))))))))\41 aa n - - -((((((((((a))))))))))\41 a! y $& a! +((((((((((a))))))))))${bang} aa n - - +((((((((((a))))))))))${bang} a! y $& a! (((((((((a))))))))) a y $& a multiple words of text uh-uh n - - multiple words multiple words, yeah y $& multiple words @@ -291,8 +291,8 @@ a[-]?c ac y $& ac '(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ- '((((((((((a))))))))))'i A y $10 A '((((((((((a))))))))))\10'i AA y $& AA -'((((((((((a))))))))))\41'i AA n - - -'((((((((((a))))))))))\41'i A! y $& A! +'((((((((((a))))))))))${bang}'i AA n - - +'((((((((((a))))))))))${bang}'i A! y $& A! '(((((((((a)))))))))'i A y $& A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C diff --git a/t/op/regexp.t b/t/op/regexp.t index 0ec069b19a..11b3ee31da 100755 --- a/t/op/regexp.t +++ b/t/op/regexp.t @@ -24,7 +24,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # -# \n in the tests are interpolated. +# \n in the tests are interpolated, as are variables of the form ${\w+}. # # If you want to add a regular expression test that can't be expressed # in this format, don't add it here: put it in op/pat.t instead. @@ -34,8 +34,6 @@ BEGIN { @INC = '../lib' if -d '../lib'; } -use re 'eval'; - $iters = shift || 1; # Poor man performance suite, 10000 is OK. open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || @@ -46,6 +44,8 @@ $numtests = $.; seek(TESTS,0,0); $. = 0; +$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. + $| = 1; print "1..$numtests\n# $iters iterations\n"; TEST: @@ -58,6 +58,7 @@ while (<TESTS>) { infty_subst(\$expect); $pat = "'$pat'" unless $pat =~ /^[:']/; $pat =~ s/\\n/\n/g; + $pat =~ s/(\$\{\w+\})/$1/eeg; $subject =~ s/\\n/\n/g; $expect =~ s/\\n/\n/g; $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; diff --git a/t/op/sort.t b/t/op/sort.t index a6829e01e4..70341b9106 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -6,20 +6,41 @@ print "1..21\n"; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +my $upperfirst = 'A' lt 'a'; + +# Beware: in future this may become hairier because of possible +# collation complications: qw(A a B c) can be sorted at least as +# any of the following +# +# A a B b +# A B a b +# a b A B +# a A b B +# +# All the above orders make sense. +# +# That said, EBCDIC sorts all small letters first, as opposed +# to ASCII which sorts all big letters first. + @harry = ('dog','cat','x','Cain','Abel'); @george = ('gone','chased','yz','punished','Axed'); $x = join('', sort @harry); -print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); -print "# x = '$x'\n"; +$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; +print "# 1: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 1\n" : "not ok 1\n"); $x = join('', sort( backwards @harry)); -print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); -print "# x = '$x'\n"; +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 2: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); $x = join('', sort @george, 'to', @harry); -print ($x eq 'AbelAxedCaincatchaseddoggonepunishedtoxyz'?"ok 3\n":"not ok 3\n"); -print "# x = '$x'\n"; +$expected = $upperfirst ? + 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : + 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 3\n":"not ok 3\n"); @a = (); @b = reverse @a; @@ -47,7 +68,9 @@ print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); -print ($x eq 'xdogcatCainAbel' ? "ok 10\n" : "not ok 10\n"); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 10: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); # literals, combinations diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 7556c80a41..b9b4751c79 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -14,7 +14,7 @@ $SIG{__WARN__} = sub { }; $w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,65,3.0999); +$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999); if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) { print "ok 1\n"; } else { diff --git a/t/op/stat.t b/t/op/stat.t index 03bfd8da39..2207b40e30 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -13,9 +13,10 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; +$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless ($Is_MSWin32 || $Is_Dos); +$DEV = `ls -l /dev` unless $Is_Dosish; unlink "Op.stat.tmp"; open(FOO, ">Op.stat.tmp"); @@ -34,7 +35,7 @@ close(FOO); sleep 2; -if ($Is_MSWin32 || $Is_Dos) { unlink "Op.stat.tmp2" } +if ($Is_Dosish) { unlink "Op.stat.tmp2" } else { `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; } @@ -42,15 +43,19 @@ else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.stat.tmp'); -if ($Is_MSWin32 || $Is_Dos || $Config{dont_use_nlink} || $nlink == 2) - {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";} +if ($Is_Dosish || $Config{dont_use_nlink}) + {print "ok 3 # skipped: no link count\n";} +elsif ($nlink == 2) + {print "ok 3\n";} +else {print "# \$nlink is |$nlink|\nnot ok 3\n";} -if ( ($mtime && $mtime != $ctime) - || $Is_MSWin32 - || $Is_Dos +if ( $Is_Dosish || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug || $cwd =~ m#/afs/# || $^O eq 'amigaos') { + print "ok 4 # skipped: different semantic of mtime/ctime\n"; +} +elsif ( ($mtime && $mtime != $ctime) ) { print "ok 4\n"; } else { @@ -91,7 +96,9 @@ foreach ((12,13,14,15,16,17)) { chmod 0700,'Op.stat.tmp'; if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";} if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";} -if ($Is_MSWin32 or $Is_Dos or -x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";} +if ($Is_Dosish) {print "ok 20 # skipped: -x by extension\n";} +elsif (-x 'Op.stat.tmp') {print "ok 20\n";} +else {print "not ok 20\n";} if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";} if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";} @@ -99,7 +106,7 @@ if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";} if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";} if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";} -if (!($Is_MSWin32 || $Is_Dos) and `ls -l perl` =~ /^l.*->/) { +if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) { if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";} } else { @@ -142,7 +149,9 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_MSWin32 || $Is_Dos) {print "ok 35\n"; goto tty_test;} +if ($^O eq 'amigaos' or $Is_Dosish) { + print "ok 35 # skipped: no -u\n"; goto tty_test; +} $cnt = $uid = 0; diff --git a/t/op/subst.t b/t/op/subst.t index 2d42eeb386..afa06ab772 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -1,11 +1,5 @@ #!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; -} - print "1..71\n"; $x = 'foo'; @@ -187,13 +181,21 @@ tr/a-z/A-Z/; print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; # same as tr/A-Z/a-z/; -y[\101-\132][\141-\172]; +if ($^O eq 'os390') { # An EBCDIC variant. + y[\301-\351][\201-\251]; +} else { # Ye Olde ASCII. Or something like it. + y[\101-\132][\141-\172]; +} print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n"; -$_ = '+,-'; -tr/+--/a-c/; -print $_ eq 'abc' ? "ok 54\n" : "not ok 54\n"; +if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 && + ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) { + $_ = '+,-'; + tr/+--/a-c/; + print "not " unless $_ eq 'abc'; +} +print "ok 54\n"; $_ = '+,-'; tr/+\--/a\/c/; diff --git a/t/op/taint.t b/t/op/taint.t index f2181d82fd..d2cae8e70a 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -15,6 +15,10 @@ BEGIN { use strict; use Config; +# We do not want the whole taint.t to fail +# just because Errno possibly failing. +eval { require Errno; import Errno }; + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -360,7 +364,9 @@ else { test 71, eval { open FOO, $foo } eq '', 'open for read'; test 72, $@ eq '', $@; # NB: This should be allowed - test 73, $! == 2 || ($Is_Dos && $! == 22); # File not found + + # Try first new style but allow also old style. + test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found test 74, eval { open FOO, "> $foo" } eq '', 'open for write'; test 75, $@ =~ /^Insecure dependency/, $@; diff --git a/t/op/universal.t b/t/op/universal.t index bd6c73afe9..bde78fd04c 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -75,7 +75,11 @@ test ! (eval { $a->VERSION(2.719) }) && test (eval { $a->VERSION(2.718) }) && ! $@; my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -test $subs eq "VERSION can isa"; +if ('a' lt 'A') { + test $subs eq "can isa VERSION"; +} else { + test $subs eq "VERSION can isa"; +} test $a->isa("UNIVERSAL"); @@ -86,7 +90,11 @@ test $a->isa("UNIVERSAL"); my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug -test $sub2 eq "VERSION can import isa"; +if ('a' lt 'A') { + test $sub2 eq "can import isa VERSION"; +} else { + test $sub2 eq "VERSION can import isa"; +} eval 'sub UNIVERSAL::sleep {}'; test $a->can("sleep"); diff --git a/t/pragma/constant.t b/t/pragma/constant.t index 0095f3b627..0b58bae607 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -81,7 +81,7 @@ test 18, (COUNTLIST)[1] == 4; use constant ABC => 'ABC'; test 19, "abc${\( ABC )}abc" eq "abcABCabc"; -use constant DEF => 'D', "\x45", chr 70; +use constant DEF => 'D', 'E', chr ord 'F'; test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; use constant SINGLE => "'"; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index 05035c612d..afba8a3221 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -5,8 +5,6 @@ BEGIN { @INC = '../lib'; } -use Config; - package Oscalar; use overload ( # Anonymous subroutines: @@ -436,6 +434,265 @@ test($b, "_<oups1 >_"); # 134 test($c, "bareword"); # 135 +{ + package symbolic; # Primitive symbolic calculator + use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, + '=' => \&cpy, '++' => \&inc, '--' => \&dec; + + sub new { shift; bless ['n', @_] } + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + sub inc { $_[0] = bless ['++', $_[0], 1]; } + sub dec { $_[0] = bless ['--', $_[0], 1]; } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } +} + +{ + my $foo = new symbolic 11; + my $baz = $foo++; + test( (sprintf "%d", $foo), '12'); + test( (sprintf "%d", $baz), '11'); + my $bar = $foo; + $baz = ++$foo; + test( (sprintf "%d", $foo), '13'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '13'); + my $ban = $foo; + $baz = ($foo += 1); + test( (sprintf "%d", $foo), '14'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '14'); + test( (sprintf "%d", $ban), '13'); + $baz = 0; + $baz = $foo++; + test( (sprintf "%d", $foo), '15'); + test( (sprintf "%d", $baz), '14'); + test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); +} + +{ + my $iter = new symbolic 2; + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # The "simple" way + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my $iter = new symbolic 2; + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my ($a, $b); + symbolic->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + $a = 3; $b = 4; + test( (sprintf "%d", $c), '5'); + $a = 12; $b = 5; + test( (sprintf "%d", $c), '13'); +} + +{ + package symbolic1; # Primitive symbolic calculator + # Mutator inc/dec + use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; + + sub new { shift; bless ['n', @_] } + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } +} + +{ + my $foo = new symbolic1 11; + my $baz = $foo++; + test( (sprintf "%d", $foo), '12'); + test( (sprintf "%d", $baz), '11'); + my $bar = $foo; + $baz = ++$foo; + test( (sprintf "%d", $foo), '13'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '13'); + my $ban = $foo; + $baz = ($foo += 1); + test( (sprintf "%d", $foo), '14'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '14'); + test( (sprintf "%d", $ban), '13'); + $baz = 0; + $baz = $foo++; + test( (sprintf "%d", $foo), '15'); + test( (sprintf "%d", $baz), '14'); + test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); +} + +{ + my $iter = new symbolic1 2; + my $side = new symbolic1 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # The "simple" way + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my $iter = new symbolic1 2; + my $side = new symbolic1 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my ($a, $b); + symbolic1->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + $a = 3; $b = 4; + test( (sprintf "%d", $c), '5'); + $a = 12; $b = 5; + test( (sprintf "%d", $c), '13'); +} + +{ + package two_face; # Scalars with separate string and + # numeric values. + sub new { my $p = shift; bless [@_], $p } + use overload '""' => \&str, '0+' => \&num, fallback => 1; + sub num {shift->[1]} + sub str {shift->[0]} +} + +{ + my $seven = new two_face ("vii", 7); + test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), + 'seven=vii, seven=7, eight=8'); + test( scalar ($seven =~ /i/), '1') +} # Last test is: -sub last {135} +sub last {173} diff --git a/t/pragma/subs.t b/t/pragma/subs.t index 056c4bd7cf..680564f843 100755 --- a/t/pragma/subs.t +++ b/t/pragma/subs.t @@ -55,6 +55,7 @@ for (@prgs){ # 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 + $results =~ s/Syntax/syntax/; # non-standard yacc $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; if ( $results =~ s/^SKIPPED\n//) { @@ -194,7 +194,7 @@ struct perl_thread *getTHR _((void)); #define ThrSETSTATE(t, s) STMT_START { \ (t)->flags &= ~THRf_STATE_MASK; \ (t)->flags |= (s); \ - DEBUG_L(PerlIO_printf(PerlIO_stderr(), \ + DEBUG_S(PerlIO_printf(PerlIO_stderr(), \ "thread %p set to state %d\n", (t), (s))); \ } STMT_END @@ -187,7 +187,13 @@ missingterm(char *s) if (nl) *nl = '\0'; } - else if (PL_multi_close < 32 || PL_multi_close == 127) { + else if ( +#ifdef EBCDIC + iscntrl(PL_multi_close) +#else + PL_multi_close < 32 || PL_multi_close == 127 +#endif + ) { *tmpbuf = '^'; tmpbuf[1] = toCTRL(PL_multi_close); s = "\\n"; @@ -1069,8 +1075,15 @@ scan_const(char *start) /* \c is a control character */ case 'c': s++; +#ifdef EBCDIC + *d = *s++; + if (isLOWER(*d)) + *d = toUPPER(*d); + *d++ = toCTRL(*d); +#else len = *s++; *d++ = toCTRL(len); +#endif continue; /* printf-style backslashes, formfeeds, newlines, etc */ @@ -1470,7 +1483,7 @@ filter_gets(register SV *sv, register PerlIO *fp, STRLEN append) else return Nullch ; } - else + else return (sv_gets(sv, fp, append)); } @@ -1899,6 +1912,7 @@ yylex(void) else (void)PerlIO_close(PL_rsfp); PL_rsfp = Nullfp; + PL_doextract = FALSE; } if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : ""); @@ -4147,7 +4161,17 @@ yylex(void) FUN0(OP_WANTARRAY); case KEY_write: - gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ +#ifdef EBCDIC + { + static char ctl_l[2]; + + if (ctl_l[0] == '\0') + ctl_l[0] = toCTRL('L'); + gv_fetchpv(ctl_l,TRUE, SVt_PV); + } +#else + gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ +#endif UNI(OP_ENTERWRITE); case KEY_x: @@ -1253,21 +1253,17 @@ die(const char* pat, ...) GV *gv; CV *cv; -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); -#endif /* USE_THREADS */ va_start(args, pat); message = pat ? mess(pat, &args) : Nullch; va_end(args); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); -#endif /* USE_THREADS */ if (PL_diehook) { /* sv_2cv might call croak() */ SV *olddiehook = PL_diehook; @@ -1301,11 +1297,9 @@ die(const char* pat, ...) } PL_restartop = die_where(message); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); -#endif /* USE_THREADS */ if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); return PL_restartop; @@ -1324,9 +1318,7 @@ croak(const char* pat, ...) va_start(args, pat); message = mess(pat, &args); va_end(args); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); -#endif /* USE_THREADS */ + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); if (PL_diehook) { /* sv_2cv might call croak() */ SV *olddiehook = PL_diehook; @@ -2719,7 +2711,7 @@ condpair_magic(SV *sv) mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); UNLOCK_SV_MUTEX; - DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), "%p: condpair_magic %p\n", thr, sv));) } } @@ -2820,7 +2812,7 @@ new_struct_thread(struct perl_thread *t) SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); } } diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index e937e696c2..43029692b2 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -427,7 +427,6 @@ exec "\$ \@$drvrname" if $isvax; __END__ # Oddball cases, so we can keep the perl.h scan above simple -rcsid=vars # declared in perl.c regkind=vars # declared in regcomp.h simple=vars # declared in regcomp.h varies=vars # declared in regcomp.h diff --git a/vms/subconfigure.com b/vms/subconfigure.com index d15adeb3ab..181ae65dfb 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -862,6 +862,145 @@ $ perl_selecttype = "int *" $ ENDIF $ WRITE_RESULT "selectype is ''perl_selecttype'" $! +$! Check for sys/file.h +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "#include <unistd.h> +$ WS "#include <sys/file.h> +$ WS "int main() +$ WS "{" +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_i_sysfile="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_i_sysfile="undef" +$ ELSE +$ perl_i_sysfile="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "i_sysfile is ''perl_i_sysfile'" +$! +$! Check for fcntl.h +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "#include <unistd.h> +$ WS "#include <fcntl.h> +$ WS "int main() +$ WS "{" +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_i_fcntl="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_i_fcntl="undef" +$ ELSE +$ perl_i_fcntl="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "i_fcntl is ''perl_i_fcntl'" +$! +$! Check for fcntl +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "#include <unistd.h> +$ WS "#include <fcntl.h> +$ WS "int main() +$ WS "{" +$ WS "fcntl(1,2,3); +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_d_fcntl="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_d_fcntl="undef" +$ ELSE +$ perl_d_fcntl="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "d_fcntl is ''perl_d_fcntl'" +$! $! Check for bzero $! $ OS @@ -2429,7 +2568,7 @@ $ SOCKET_REPLACE = "SOCKET=DECC_SOCKETS=1" $ ELSE $ if "''Has_Socketshr'" .eqs."T" $ THEN -$ SOCKET_REPLACE = "SOCKET=SOCKETSHRSOCKETS=1" +$ SOCKET_REPLACE = "SOCKET=SOCKETSHR_SOCKETS=1" $ ELSE $ SOCKET_REPLACE = "SOCKET=" $ ENDIF diff --git a/win32/Makefile b/win32/Makefile index addf487a44..6bf6382197 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -51,7 +51,8 @@ INST_VER = \5.00550 # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. # Highly recommended. It has patches that fix known bugs in MSVCRT.DLL. -# You will need to download it from: http://www.activestate.com/ +# This currently requires VC 5.0 with Service Pack 3. +# Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # #USE_PERLCRT = define @@ -70,14 +71,14 @@ INST_VER = \5.00550 # file exists (see README.win32). File should be located in the same # directory as this file. # -#CRYPT_SRC = des_fcrypt.c +#CRYPT_SRC = fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) # Specify the full pathname of the library. # -#CRYPT_LIB = des_fcrypt.lib +#CRYPT_LIB = fcrypt.lib # # set this if you wish to use perl's malloc diff --git a/win32/des_fcrypt.patch b/win32/des_fcrypt.patch new file mode 100644 index 0000000000..7088e94a7e --- /dev/null +++ b/win32/des_fcrypt.patch @@ -0,0 +1,75 @@ +You need the GNU `patch' utility to apply this patch. Get: + + ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/libdes-3.06.tar.gz + +Uncompress it somewhere, and use the command line: + + patch -p1 -N < this_file + +to apply the patch. Move the fcrypt.c file to the win32 subdirectory +of the Perl source distribution. + +--- libdes-3.06/fcrypt.c.dist Tue Aug 4 18:41:49 1998 ++++ libdes-3.06/fcrypt.c Tue Aug 4 18:42:03 1998 +@@ -325,12 +325,15 @@ + + static char shifts2[16]={0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0}; + +-static int body(); +-static int des_set_key(); ++static int body( ++ unsigned long *out0, ++ unsigned long *out1, ++ des_key_schedule ks, ++ unsigned long Eswap0, ++ unsigned long Eswap1); + +-static int des_set_key(key,schedule) +-des_cblock *key; +-des_key_schedule schedule; ++static int ++des_set_key(des_cblock *key, des_key_schedule schedule) + { + register unsigned long c,d,t,s; + register unsigned char *in; +@@ -460,16 +463,14 @@ + 0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A + }; + +-char *crypt(buf,salt) +-char *buf; +-char *salt; ++char * ++des_fcrypt(const char *buf, const char *salt, char *buff) + { + unsigned int i,j,x,y; + unsigned long Eswap0=0,Eswap1=0; + unsigned long out[2],ll; + des_cblock key; + des_key_schedule ks; +- static unsigned char buff[20]; + unsigned char bb[9]; + unsigned char *b=bb; + unsigned char c,u; +@@ -521,13 +522,15 @@ + buff[i]=cov_2char[c]; + } + buff[13]='\0'; +- return((char *)buff); ++ return buff; + } + +-static int body(out0,out1,ks,Eswap0,Eswap1) +-unsigned long *out0,*out1; +-des_key_schedule *ks; +-unsigned long Eswap0,Eswap1; ++static int ++body( unsigned long *out0, ++ unsigned long *out1, ++ des_key_schedule ks, ++ unsigned long Eswap0, ++ unsigned long Eswap1) + { + register unsigned long l,r,t,u,v; + #ifdef ALT_ECB +End of Patch. diff --git a/win32/makefile.mk b/win32/makefile.mk index 50cdda9fc3..386bfa6143 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -59,7 +59,8 @@ CCTYPE *= BORLAND # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. # Highly recommended. It has patches that fix known bugs in MSVCRT.DLL. -# You will need to download it from: http://www.activestate.com/ +# This currently requires VC 5.0 with Service Pack 3. +# Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # #USE_PERLCRT *= define @@ -78,14 +79,14 @@ CCTYPE *= BORLAND # file exists (see README.win32). File should be located in the same # directory as this file. # -#CRYPT_SRC *= des_fcrypt.c +#CRYPT_SRC *= fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) # Specify the full pathname of the library. # -#CRYPT_LIB *= des_fcrypt.lib +#CRYPT_LIB *= fcrypt.lib # # set this if you wish to use perl's malloc diff --git a/win32/win32.c b/win32/win32.c index 721b62ace9..3f1c215b85 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1164,7 +1164,7 @@ win32_alarm(unsigned int sec) #if defined(HAVE_DES_FCRYPT) || defined(PERL_OBJECT) #ifdef HAVE_DES_FCRYPT -extern char * des_fcrypt(char *cbuf, const char *txt, const char *salt); +extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); #endif DllExport char * @@ -1172,7 +1172,7 @@ win32_crypt(const char *txt, const char *salt) { #ifdef HAVE_DES_FCRYPT dTHR; - return des_fcrypt(crypt_buffer, txt, salt); + return des_fcrypt(txt, salt, crypt_buffer); #else die("The crypt() function is unimplemented due to excessive paranoia."); return Nullch; diff --git a/win32/win32thread.c b/win32/win32thread.c index 14ac5d7f42..1eb0e872c6 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -93,7 +93,7 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn) unsigned long th; MUTEX_LOCK(&thr->mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: create OS thread\n", thr)); #ifdef USE_RTL_THREAD_API /* See comment about USE_RTL_THREAD_API in win32thread.h */ @@ -124,7 +124,7 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn) #else /* !USE_RTL_THREAD_API */ thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk); #endif /* !USE_RTL_THREAD_API */ - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: OS thread = %p, id=%ld\n", thr, thr->self, junk)); MUTEX_UNLOCK(&thr->mutex); return thr->self ? 0 : -1; @@ -412,6 +412,10 @@ EXT int debug INIT(0); EXT int dlevel INIT(0); #define YYDEBUG 1 extern int yydebug; +#else +# ifndef YYDEBUG +# define YYDEBUG 0 +# endif #endif EXT STR *freestrroot INIT(Nullstr); diff --git a/x2p/a2py.c b/x2p/a2py.c index a4753ab864..8a6155f455 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -66,7 +66,7 @@ main(register int argc, register char **argv, register char **env) #ifdef DEBUGGING case 'D': debug = atoi(argv[0]+2); -#ifdef YYDEBUG +#if YYDEBUG yydebug = (debug & 1); #endif break; @@ -211,7 +211,7 @@ yylex(void) register int tmp; retry: -#ifdef YYDEBUG +#if YYDEBUG if (yydebug) if (strchr(s,'\n')) fprintf(stderr,"Tokener at %s",s); @@ -273,7 +273,11 @@ yylex(void) case ':': tmp = *s++; XOP(tmp); +#ifdef EBCDIC + case 7: +#else case 127: +#endif s++; XTERM('}'); case '}': |