diff options
author | Nick Ing-Simmons <nik@tiuk.ti.com> | 2001-06-19 08:18:18 +0000 |
---|---|---|
committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 2001-06-19 08:18:18 +0000 |
commit | d68db9151d9143821835dfeeb5a616cc23d437d7 (patch) | |
tree | 653d233f36cc2424cfa0d19e3ef86cc8ed762178 | |
parent | 1076f1fdb19bacf64e54d08f4a34bbf8042caa24 (diff) | |
parent | ecb2f33519ba533cbb8a58944ee243527071ea13 (diff) | |
download | perl-d68db9151d9143821835dfeeb5a616cc23d437d7.tar.gz |
Integrate mainline
p4raw-id: //depot/perlio@10709
-rw-r--r-- | Changes | 338 | ||||
-rwxr-xr-x | Configure | 97 | ||||
-rw-r--r-- | INSTALL | 40 | ||||
-rw-r--r-- | MANIFEST | 79 | ||||
-rw-r--r-- | Makefile.SH | 4 | ||||
-rw-r--r-- | Makefile.micro | 14 | ||||
-rwxr-xr-x | cflags.SH | 3 | ||||
-rw-r--r-- | configure.com | 1 | ||||
-rw-r--r-- | embed.h | 14 | ||||
-rwxr-xr-x | embed.pl | 88 | ||||
-rw-r--r-- | ext/IO/IO.xs | 30 | ||||
-rwxr-xr-x | ext/IPC/SysV/t/msg.t | 12 | ||||
-rwxr-xr-x | ext/IPC/SysV/t/sem.t | 11 | ||||
-rw-r--r-- | ext/POSIX/Makefile.PL | 1 | ||||
-rw-r--r-- | ext/Socket/Makefile.PL | 1 | ||||
-rw-r--r-- | ext/Sys/Syslog/Makefile.PL | 1 | ||||
-rw-r--r-- | ext/Time/Piece/Piece.xs | 4 | ||||
-rwxr-xr-x | installperl | 3 | ||||
-rw-r--r-- | lib/Carp/Heavy.pm | 2 | ||||
-rw-r--r-- | lib/locale.t | 4 | ||||
-rw-r--r-- | lib/perl5db.pl | 10 | ||||
-rw-r--r-- | lib/strict.t | 2 | ||||
-rw-r--r-- | objXSUB.h | 2 | ||||
-rw-r--r-- | patchlevel.h | 2 | ||||
-rw-r--r-- | perlapi.c | 2 | ||||
-rw-r--r-- | perly.c | 482 | ||||
-rw-r--r-- | perly.y | 28 | ||||
-rw-r--r-- | perly_c.diff | 95 | ||||
-rw-r--r-- | pod/perl572delta.pod | 128 | ||||
-rw-r--r-- | pod/perlapi.pod | 750 | ||||
-rw-r--r-- | pod/perldebug.pod | 4 | ||||
-rw-r--r-- | pod/perlguts.pod | 16 | ||||
-rw-r--r-- | pod/perlhack.pod | 3 | ||||
-rw-r--r-- | pod/perlintern.pod | 49 | ||||
-rw-r--r-- | pod/perlmod.pod | 17 | ||||
-rw-r--r-- | pod/perlsub.pod | 4 | ||||
-rw-r--r-- | pod/perltoc.pod | 160 | ||||
-rw-r--r-- | pod/perltodo.pod | 16 | ||||
-rw-r--r-- | pod/perlutil.pod | 15 | ||||
-rw-r--r-- | pod/perlvar.pod | 8 | ||||
-rw-r--r-- | pp.c | 1813 | ||||
-rw-r--r-- | pp_pack.c | 1825 | ||||
-rw-r--r-- | proto.h | 5 | ||||
-rw-r--r-- | sv.c | 1131 | ||||
-rw-r--r-- | sv.h | 93 | ||||
-rw-r--r-- | t/lib/locale/latin1 (renamed from lib/locale/latin1) | 0 | ||||
-rw-r--r-- | t/lib/locale/utf8 (renamed from lib/locale/utf8) | 0 | ||||
-rw-r--r-- | t/lib/strict/refs (renamed from lib/strict/refs) | 0 | ||||
-rw-r--r-- | t/lib/strict/subs (renamed from lib/strict/subs) | 0 | ||||
-rw-r--r-- | t/lib/strict/vars (renamed from lib/strict/vars) | 0 | ||||
-rw-r--r-- | t/lib/warnings/1global (renamed from lib/warnings/1global) | 0 | ||||
-rw-r--r-- | t/lib/warnings/2use (renamed from lib/warnings/2use) | 0 | ||||
-rw-r--r-- | t/lib/warnings/3both (renamed from lib/warnings/3both) | 0 | ||||
-rw-r--r-- | t/lib/warnings/4lint (renamed from lib/warnings/4lint) | 0 | ||||
-rw-r--r-- | t/lib/warnings/5nolint (renamed from lib/warnings/5nolint) | 0 | ||||
-rw-r--r-- | t/lib/warnings/6default (renamed from lib/warnings/6default) | 0 | ||||
-rw-r--r-- | t/lib/warnings/7fatal (renamed from lib/warnings/7fatal) | 0 | ||||
-rw-r--r-- | t/lib/warnings/8signal (renamed from lib/warnings/8signal) | 0 | ||||
-rwxr-xr-x | t/lib/warnings/9enabled (renamed from lib/warnings/9enabled) | 0 | ||||
-rw-r--r-- | t/lib/warnings/av (renamed from lib/warnings/av) | 0 | ||||
-rw-r--r-- | t/lib/warnings/doio (renamed from lib/warnings/doio) | 0 | ||||
-rw-r--r-- | t/lib/warnings/doop (renamed from lib/warnings/doop) | 0 | ||||
-rw-r--r-- | t/lib/warnings/gv (renamed from lib/warnings/gv) | 0 | ||||
-rw-r--r-- | t/lib/warnings/hv (renamed from lib/warnings/hv) | 0 | ||||
-rw-r--r-- | t/lib/warnings/malloc (renamed from lib/warnings/malloc) | 0 | ||||
-rw-r--r-- | t/lib/warnings/mg (renamed from lib/warnings/mg) | 0 | ||||
-rw-r--r-- | t/lib/warnings/op (renamed from lib/warnings/op) | 0 | ||||
-rw-r--r-- | t/lib/warnings/perl (renamed from lib/warnings/perl) | 0 | ||||
-rw-r--r-- | t/lib/warnings/perlio (renamed from lib/warnings/perlio) | 0 | ||||
-rw-r--r-- | t/lib/warnings/perly (renamed from lib/warnings/perly) | 0 | ||||
-rw-r--r-- | t/lib/warnings/pp (renamed from lib/warnings/pp) | 0 | ||||
-rw-r--r-- | t/lib/warnings/pp_ctl (renamed from lib/warnings/pp_ctl) | 0 | ||||
-rw-r--r-- | t/lib/warnings/pp_hot (renamed from lib/warnings/pp_hot) | 0 | ||||
-rw-r--r-- | t/lib/warnings/pp_sys (renamed from lib/warnings/pp_sys) | 0 | ||||
-rw-r--r-- | t/lib/warnings/regcomp (renamed from lib/warnings/regcomp) | 0 | ||||
-rw-r--r-- | t/lib/warnings/regexec (renamed from lib/warnings/regexec) | 0 | ||||
-rw-r--r-- | t/lib/warnings/run (renamed from lib/warnings/run) | 0 | ||||
-rw-r--r-- | t/lib/warnings/sv (renamed from lib/warnings/sv) | 0 | ||||
-rw-r--r-- | t/lib/warnings/taint (renamed from lib/warnings/taint) | 0 | ||||
-rw-r--r-- | t/lib/warnings/toke (renamed from lib/warnings/toke) | 0 | ||||
-rw-r--r-- | t/lib/warnings/universal (renamed from lib/warnings/universal) | 0 | ||||
-rw-r--r-- | t/lib/warnings/utf8 (renamed from lib/warnings/utf8) | 0 | ||||
-rw-r--r-- | t/lib/warnings/util (renamed from lib/warnings/util) | 0 | ||||
-rw-r--r-- | universal.c | 2 | ||||
-rw-r--r-- | utils/libnetcfg.PL | 136 | ||||
-rw-r--r-- | vms/descrip_mms.template | 11 | ||||
-rw-r--r-- | vms/perly_c.vms | 490 | ||||
-rw-r--r-- | vos/Changes | 1 | ||||
-rw-r--r-- | vos/Makefile | 21 | ||||
-rw-r--r-- | vos/build.cm | 6 | ||||
-rw-r--r-- | vos/config.alpha.def | 1 | ||||
-rw-r--r-- | vos/config.alpha.h | 80 | ||||
-rw-r--r-- | vos/config.ga.def | 1 | ||||
-rw-r--r-- | vos/config.ga.h | 80 | ||||
-rw-r--r-- | vos/perl.bind | 3 | ||||
-rw-r--r-- | win32/Makefile | 3 | ||||
-rw-r--r-- | win32/makefile.mk | 5 |
97 files changed, 5279 insertions, 2968 deletions
@@ -31,6 +31,344 @@ or any other branch. Version v5.7.1 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 10688] By: jhi on 2001/06/18 13:44:18 + Log: Subject: [PATCH 5.7.1] sv.c documentation + From: davem@fdgroup.co.uk + Date: Mon, 18 Jun 2001 00:47:52 +0100 (BST) + Message-Id: <200106172347.AAA05475@gizmo.fdgroup.co.uk> + Branch: perl + ! embed.pl pod/perlapi.pod pod/perlguts.pod pod/perlintern.pod + ! sv.c sv.h +____________________________________________________________________________ +[ 10687] By: jhi on 2001/06/18 13:38:03 + Log: Subject: [PATCH bleadperl DOC] $@ Clarification in pod/perlvar.pod + From: "Jon Gunnip" <jongunnip@hotmail.com> + Date: Sun, 17 Jun 2001 18:24:29 -0400 + Message-ID: <F136EXUIEAOeIiGXix40000e3a7@hotmail.com> + Branch: perl + ! pod/perlvar.pod +____________________________________________________________________________ +[ 10686] By: jhi on 2001/06/18 13:32:13 + Log: Move the locale/strict/warnings helper files back + under the t/lib; this way the amount of non-installabled + stuff under lib/ stays smaller. + Branch: perl + + t/lib/locale/latin1 t/lib/locale/utf8 t/lib/strict/refs + + t/lib/strict/subs t/lib/strict/vars t/lib/warnings/1global + + t/lib/warnings/2use t/lib/warnings/3both t/lib/warnings/4lint + + t/lib/warnings/5nolint t/lib/warnings/6default + + t/lib/warnings/7fatal t/lib/warnings/8signal + + t/lib/warnings/9enabled t/lib/warnings/av t/lib/warnings/doio + + t/lib/warnings/doop t/lib/warnings/gv t/lib/warnings/hv + + t/lib/warnings/malloc t/lib/warnings/mg t/lib/warnings/op + + t/lib/warnings/perl t/lib/warnings/perlio t/lib/warnings/perly + + t/lib/warnings/pp t/lib/warnings/pp_ctl t/lib/warnings/pp_hot + + t/lib/warnings/pp_sys t/lib/warnings/regcomp + + t/lib/warnings/regexec t/lib/warnings/run t/lib/warnings/sv + + t/lib/warnings/taint t/lib/warnings/toke + + t/lib/warnings/universal t/lib/warnings/utf8 + + t/lib/warnings/util + - lib/locale/latin1 lib/locale/utf8 lib/strict/refs + - lib/strict/subs lib/strict/vars lib/warnings/1global + - lib/warnings/2use lib/warnings/3both lib/warnings/4lint + - lib/warnings/5nolint lib/warnings/6default lib/warnings/7fatal + - lib/warnings/8signal lib/warnings/9enabled lib/warnings/av + - lib/warnings/doio lib/warnings/doop lib/warnings/gv + - lib/warnings/hv lib/warnings/malloc lib/warnings/mg + - lib/warnings/op lib/warnings/perl lib/warnings/perlio + - lib/warnings/perly lib/warnings/pp lib/warnings/pp_ctl + - lib/warnings/pp_hot lib/warnings/pp_sys lib/warnings/regcomp + - lib/warnings/regexec lib/warnings/run lib/warnings/sv + - lib/warnings/taint lib/warnings/toke lib/warnings/universal + - lib/warnings/utf8 lib/warnings/util + ! MANIFEST installperl lib/locale.t lib/strict.t +____________________________________________________________________________ +[ 10685] By: jhi on 2001/06/18 13:11:49 + Log: Split off the pack/unpack code, from Nicholas Clark. + Branch: perl + + pp_pack.c + ! MANIFEST Makefile.SH Makefile.micro cflags.SH embed.h embed.pl + ! objXSUB.h perlapi.c pod/perlhack.pod pp.c proto.h + ! vms/descrip_mms.template win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 10684] By: jhi on 2001/06/18 12:25:55 + Log: Guard the SysV IPC tests against being invoked in + SysV-IPC-less places. + Branch: perl + ! ext/IPC/SysV/t/msg.t ext/IPC/SysV/t/sem.t +____________________________________________________________________________ +[ 10683] By: nick on 2001/06/18 12:24:42 + Log: Integrate mainline (new test scheme now ok on Linux). + Branch: perlio + +> lib/warnings.t + !> dump.c sv.c +____________________________________________________________________________ +[ 10682] By: jhi on 2001/06/18 12:20:50 + Log: Add the locale.c and numeric.c to the microperl sources. + Branch: perl + ! Makefile.micro win32/Makefile +____________________________________________________________________________ +[ 10681] By: jhi on 2001/06/18 11:57:45 + Log: Subject: [PATCH dump.c] FLAGS = (...,OUR,TYPED,...) + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Mon, 18 Jun 2001 14:23:44 +0530 + Message-ID: <20010618142344.A13136@lustre.linux.in> + Branch: perl + ! dump.c +____________________________________________________________________________ +[ 10680] By: jhi on 2001/06/18 11:56:12 + Log: Subject: Re: [PATCH] more anonymous stash cleanups + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Mon, 18 Jun 2001 15:50:32 +0530 + Message-ID: <20010618155032.A13223@lustre.linux.in> + + Plus the comment left in as suggested by NI-S. + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 10679] By: jhi on 2001/06/18 11:49:27 + Log: One missed file. + Branch: perl + + lib/warnings.t +____________________________________________________________________________ +[ 10678] By: nick on 2001/06/18 08:05:29 + Log: Integrate mainline (part2 - the deletes) + Branch: perlio + - lib/Text/Abbrev/t/abbrev.t t/lib/anydbm.t t/lib/b-stash.t + - t/lib/bigfltpm.t t/lib/bigintpm.t t/lib/cwd.t t/lib/db-btree.t + - t/lib/db-hash.t t/lib/db-recno.t t/lib/extutils.t + - t/lib/filefind.t t/lib/filehand.t t/lib/filter-util.t + - t/lib/findtaint.t t/lib/ftmp-security.t t/lib/gdbm.t + - t/lib/glob-basic.t t/lib/glob-case.t t/lib/io_dup.t + - t/lib/io_poll.t t/lib/io_sel.t t/lib/io_taint.t t/lib/mbimbf.t + - t/lib/ndbm.t t/lib/net-hostent.t t/lib/odbm.t t/lib/open2.t + - t/lib/open3.t t/lib/posix.t t/lib/sdbm.t t/lib/sigaction.t + - t/lib/syslfs.t t/pragma/locale.t t/pragma/strict.t + - t/pragma/subs.t t/pragma/warn/mg t/pragma/warnings.t +____________________________________________________________________________ +[ 10677] By: nick on 2001/06/18 08:04:44 + Log: Integrate mainline (part1) + Branch: perlio + +> (branch 376 files) + - (delete 219 files) + !> (integrate 151 files) +____________________________________________________________________________ +[ 10676] By: jhi on 2001/06/18 04:17:15 + Log: The Grand Trek: move the *.t files from t/ to lib/ and ext/. + No doubt I made some mistakes like missed some files or + misnamed some files. The naming rules were more or less: + (1) if the module is from CPAN, follows its ways, be it + t/*.t or test.pl. + (2) otherwise if there are multiple tests for a module + put them in a t/ + (3) otherwise if there's only one test put it in Module.t + (4) helper files go to module/ (locale, strict, warnings) + (5) use longer filenames now that we can (but e.g. the + compat-0.6.t and the Text::Balanced test files still + were renamed to be more civil against the 8.3 people) + installperl was updated appropriately not to install the + *.t files or the help files from under lib. + + TODO: some helper files still remain under t/ that could + follow their 'masters'. UPDATE: On second thoughts, why + should they. They can continue to live under t/lib, and + in fact the locale/strict/warnings helpers that were moved + could be moved back. This way the amount of non-installable + stuff under lib/ stays smaller. + Branch: perl + + (add 253 files) + - (delete 254 files) + ! MANIFEST installperl lib/Test/Harness.pm t/TEST t/harness +____________________________________________________________________________ +[ 10675] By: jhi on 2001/06/18 03:15:02 + Log: The warning no more comes from util.c, it comes from numeric.c. + Branch: perl + ! README.tru64 +____________________________________________________________________________ +[ 10674] By: jhi on 2001/06/18 00:56:22 + Log: Subject: Re: anyone good at casting spells? + From: Spider Boardman <spider@Orb.Nashua.NH.US> + Date: Sun, 17 Jun 2001 21:21:04 -0400 + Message-Id: <200106180121.VAA10195@Orb.Nashua.NH.US> + Branch: perl + ! ext/POSIX/POSIX.xs hv.h +____________________________________________________________________________ +[ 10673] By: jhi on 2001/06/17 22:24:53 + Log: Protect the (original) thread tests against testing if no 5.005 + threads have been configured. + Branch: perl + ! ext/Thread/create.t ext/Thread/die.t ext/Thread/die2.t + ! ext/Thread/io.t ext/Thread/join.t ext/Thread/join2.t + ! ext/Thread/list.t ext/Thread/lock.t ext/Thread/queue.t + ! ext/Thread/specific.t ext/Thread/sync.t ext/Thread/sync2.t + ! ext/Thread/unsync.t ext/Thread/unsync2.t ext/Thread/unsync3.t + ! ext/Thread/unsync4.t +____________________________________________________________________________ +[ 10672] By: jhi on 2001/06/17 22:09:28 + Log: Try the new test scanning scheme on Text::Abbrev. + Branch: perl + + lib/Text/Abbrev.t + - lib/Text/Abbrev/t/abbrev.t + ! MANIFEST +____________________________________________________________________________ +[ 10671] By: jhi on 2001/06/17 22:07:08 + Log: Change the scan policy of the *.t and test.pl files, + now the *.t do not need to live in a t/ directory. + Branch: perl + ! t/TEST t/harness +____________________________________________________________________________ +[ 10670] By: jhi on 2001/06/17 20:32:35 + Log: Subject: [PATCH perlfaq7.pod] fix dangling L<perlobj/"WARNING"> + From: Ilmari Karonen <iltzu@sci.fi> + Date: Mon, 18 Jun 2001 00:30:21 +0300 (EET DST) + Message-ID: <Pine.SOL.3.96.1010618002009.6629A-100000@simpukka> + Branch: perl + ! pod/perlfaq7.pod +____________________________________________________________________________ +[ 10669] By: jhi on 2001/06/17 20:30:22 + Log: Quench the warnings from Tru64; the HP-UX is still + broken because it really, REALLY, doesn't like the + HvARRAY() being lvalue: + + cc: "hv.c", line 192: warning 524: Cast (non-lvalue) appears on left-hand side of assignment. + cc: "hv.c", line 192: error 1549: Modifiable lvalue required for assignment operator. + Branch: perl + ! hv.c +____________________________________________________________________________ +[ 10668] By: jhi on 2001/06/17 19:13:24 + Log: Integrate change #10667 from maintperl: + + change#10449 broke the special-case that makes lexicals inside the + eval"" within DB::DB() visible + Branch: perl + !> op.c +____________________________________________________________________________ +[ 10667] By: gsar on 2001/06/17 19:08:27 + Log: change#10449 broke the special-case that makes lexicals inside the + eval"" within DB::DB() visible + Branch: maint-5.6/perl + ! op.c +____________________________________________________________________________ +[ 10666] By: jhi on 2001/06/17 17:50:07 + Log: Still spurious output; indent the code a bit. + + TODO1: separate the utility functions like MkDir + into a helper script? + + TODO2: I see a lot of repetition in the filepath() + and dirpath() calls. + Branch: perl + ! t/lib/filefind.t t/lib/findtaint.t +____________________________________________________________________________ +[ 10665] By: jhi on 2001/06/17 16:59:42 + Log: Regen modlib, toc. + Branch: perl + ! pod/perlmodlib.pod pod/perltoc.pod +____________________________________________________________________________ +[ 10664] By: jhi on 2001/06/17 16:55:28 + Log: Add libnetcfg to perlutil. + Branch: perl + ! pod/perlutil.pod +____________________________________________________________________________ +[ 10663] By: jhi on 2001/06/17 16:53:29 + Log: Initial integration of libnet-1.0703. + The Configure script renamed as libnetcfg, will be + installed along other utilities. + Branch: perl + + lib/Net/ChangeLog.libnet lib/Net/Cmd.pm lib/Net/Config.eg + + lib/Net/Config.pm lib/Net/Domain.pm lib/Net/DummyInetd.pm + + lib/Net/FTP.pm lib/Net/FTP/A.pm lib/Net/FTP/E.pm + + lib/Net/FTP/I.pm lib/Net/FTP/L.pm lib/Net/FTP/dataconn.pm + + lib/Net/Hostname.eg lib/Net/NNTP.pm lib/Net/Netrc.pm + + lib/Net/PH.pm lib/Net/POP3.pm lib/Net/README.config + + lib/Net/README.libnet lib/Net/SMTP.pm lib/Net/SNPP.pm + + lib/Net/Time.pm lib/Net/demos/ftp lib/Net/demos/inetd + + lib/Net/demos/nntp lib/Net/demos/nntp.mirror + + lib/Net/demos/pop3 lib/Net/demos/smtp.self lib/Net/demos/snpp + + lib/Net/demos/time lib/Net/libnet.ppd lib/Net/libnetFAQ.pod + + lib/Net/t/ftp.t lib/Net/t/hostname.t lib/Net/t/nntp.t + + lib/Net/t/ph.t lib/Net/t/require.t lib/Net/t/smtp.t + + utils/libnetcfg.PL + ! MANIFEST utils.lst utils/Makefile +____________________________________________________________________________ +[ 10662] By: jhi on 2001/06/17 15:37:32 + Log: Less potentially test-harness-confusing output. + Branch: perl + ! lib/Memoize/t/expire_module_t.t +____________________________________________________________________________ +[ 10661] By: jhi on 2001/06/17 15:31:04 + Log: The final print annoys make test. + Branch: perl + ! t/lib/filefind.t t/lib/findtaint.t +____________________________________________________________________________ +[ 10660] By: jhi on 2001/06/17 14:00:21 + Log: Add an option for handling dangling symbolic links. + Branch: perl + ! lib/File/Find.pm t/lib/filefind.t +____________________________________________________________________________ +[ 10659] By: jhi on 2001/06/17 13:45:48 + Log: Subject: Re: [MacPerl-Porters] Re: [PATCH] File::Find for bleadperl, Mac OS etc. + From: Thomas Wegner <wegner_thomas@yahoo.com> + Date: Sun, 17 Jun 2001 14:43:11 +0200 + Message-Id: <p04320400b751fb74714a@[149.225.10.45]> + Branch: perl + + t/lib/findtaint.t + ! MANIFEST lib/File/Find.pm t/lib/filefind.t +____________________________________________________________________________ +[ 10658] By: jhi on 2001/06/17 13:13:25 + Log: Subject: [PATCH ExtUtils/MM_Unix.pm perl@10654] Remove tmon.out in make clean + From: Jonathan Stowe <gellyfish@gellyfish.com> + Date: Sun, 17 Jun 2001 11:26:21 +0100 (BST) + Message-ID: <Pine.LNX.4.33.0106171120540.28753-100000@orpheus.gellyfish.com> + Branch: perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 10657] By: jhi on 2001/06/17 13:12:25 + Log: Subject: [PATCH] more anonymous stash cleanups + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 11:44:06 +0530 + Message-ID: <20010617114406.A25203@lustre.linux.in> + Branch: perl + ! op.c +____________________________________________________________________________ +[ 10656] By: jhi on 2001/06/17 13:11:11 + Log: Subject: [PATCH #1/7] xhv_array (was Re: Using xhv_foo instead of HvFOO) + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:02:59 +0530 + Message-ID: <20010617080259.A28776@lustre.linux.in> + + Subject: [PATCH #2/7] xhv_eiter + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:13:18 +0530 + Message-ID: <20010617081318.B28776@lustre.linux.in> + + Subject: [PATCH #3/7] xhv_fill + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:25:16 +0530 + Message-ID: <20010617082516.C28776@lustre.linux.in> + + Subject: [PATCH #4/7] xhv_keys + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:36:17 +0530 + Message-ID: <20010617083617.D28776@lustre.linux.in> + + Subject: [PATCH #5/7] xhv_max + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:39:48 +0530 + Message-ID: <20010617083948.E28776@lustre.linux.in> + + Subject: [PATCH #6,7/7] xhv_pmroot, xhv_riter + From: Abhijit Menon-Sen <ams@wiw.org> + Date: Sun, 17 Jun 2001 08:51:11 +0530 + Message-ID: <20010617085111.F28776@lustre.linux.in> + Branch: perl + ! hv.c +____________________________________________________________________________ +[ 10655] By: jhi on 2001/06/16 23:32:03 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 10654] By: jhi on 2001/06/16 23:18:37 Log: Subject: [PATCH] Re: DYNAMIC_ENV_FETCH HvNAME abuse. From: Abhijit Menon-Sen <ams@wiw.org> @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Sat Jun 16 19:06:04 EET DST 2001 [metaconfig 3.0 PL70] +# Generated on Tue Jun 19 02:14:42 EET DST 2001 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -2313,45 +2313,75 @@ esac case "$usecrosscompile" in $define|true|[yY]*) + $echo "Cross-compiling..." croak='' case "$cc" in *-*-gcc) # A cross-compiling gcc, probably. - targetarch=`echo $cc|sed 's/-gcc$//'` + targetarch=`$echo $cc|$sed 's/-gcc$//'` ar=$targetarch-ar # leave out ld, choosing it is more complex nm=$targetarch-nm ranlib=$targetarch-ranlib + $echo 'extern int foo;' > try.c + set X `$cc -v -E perl.c 2>&1 | $awk '/^#include </,/^End of search /'|$grep '/include'` + shift + if $test $# -gt 0; then + incpth="$incpth $*" + incpth="$echo $incpth|$sed 's/^ //'" + echo "Guessing incpth $incpth" >&4 + for i in $*; do + j=`$echo $i|$sed 's,/include$,/lib,'` + if $test -d $j; then + libpth="$libpth $j" + fi + done + libpth="$echo $libpth|$sed 's/^ //'" + echo "Guessing libpth $libpth." >&4 + fi + $rm -f try.c ;; esac case "$targetarch" in - '') echo "Cross-compiling: you should define targetarch." >&4; croak=y ;; - esac - case "$usrinc" in - '') echo "Cross-compiling: you should define usrinc." >&4; croak=y ;; + '') echo "Targetarch not defined." >&4; croak=y ;; + *) echo "Using targetarch $targetarch." >&4 ;; esac case "$incpth" in - '') echo "Cross-compiling: you should define incpth." >&4; croak=y ;; + '') echo "Incpth not defined." >&4; croak=y ;; + *) echo "Using incpth $incpth." >&4 ;; esac case "$libpth" in - '') echo "Cross-compiling: you should define libpth." >&4; croak=y ;; + '') echo "Libpth not defined." >&4; croak=y ;; + *) echo "Using libpth $libpth." >&4 ;; esac - case "$targethost" in - '') echo "Cross-compiling: targethost not defined." >&4; croak=y ;; + case "$usrinc" in + '') for i in $incpth; do + if $test -f $i/errno.h -a -f $i/stdio.h -a -f $i/time.h; then + usrinc=$i + echo "Guessing usrinc $usrinc." >&4 + break + fi + done + case "$usrinc" in + '') echo "Usrinc not defined." >&4; croak=y ;; + esac + ;; + *) echo "Using usrinc $usrinc." >&4 ;; esac - case "$targetdir" in - '') echo "Cross compiling: targetdir not defined." >&4; croak=y ;; + case "$targethost" in + '') echo "Targethost not defined." >&4; croak=y ;; + *) echo "Using targethost $targethost." >&4 esac - locincpth='' - loclibpth='' + locincpth=' ' + loclibpth=' ' case "$croak" in - y) exit 1 ;; + y) echo "Cannot continue, aborting." >&4; exit 1 ;; esac case "$src" in /*) run=$src/Cross/run to=$src/Cross/to from=$src/Cross/from ;; - *) pwd=`test -f ../Configure & cd ..; pwd` + *) pwd=`$test -f ../Configure & cd ..; pwd` run=$pwd/Cross/run to=$pwd/Cross/to from=$pwd/Cross/from @@ -2369,8 +2399,15 @@ $define|true|[yY]*) run=$run-$targetrun to=$to-$targetto from=$from-$targetfrom + case "$targetdir" in + '') targetdir=/tmp + echo "Guessing targetdir $targetdir." >&4 + ;; + esac case "$targetuser" in - '') targetuser=root ;; + '') targetuser=root + echo "Guessing targetuser $targetuser." >&4 + ;; esac case "$targetfrom" in scp) q=-q ;; @@ -2386,7 +2423,7 @@ $to \$exe $targetrun -l $targetuser $targethost "cd $targetdir && ./\$exe \$@" EOF ;; - *) echo "Cross-compiling: unknown targetrun '$targetrun'" >&4 + *) echo "Unknown targetrun '$targetrun'" >&4 exit 1 ;; esac @@ -2406,7 +2443,7 @@ EOF cp \$@ $targetdir/. EOF ;; - *) echo "Cross-compiling: unknown targetto '$targetto'" >&4 + *) echo "Unknown targetto '$targetto'" >&4 exit 1 ;; esac @@ -2430,33 +2467,31 @@ done exit 0 EOF ;; - *) echo "Cross-compiling: unknown targetfrom '$targetfrom'" >&4 + *) echo "Unknown targetfrom '$targetfrom'" >&4 exit 1 ;; esac - if test ! -f $run; then - echo "Cross-compiling: target 'run' script '$run' not found." >&4 + if $test ! -f $run; then + echo "Target 'run' script '$run' not found." >&4 else chmod a+rx $run fi - if test ! -f $to; then - echo "Cross-compiling: target 'to' script '$to' not found." >&4 + if $test ! -f $to; then + echo "Target 'to' script '$to' not found." >&4 else chmod a+rx $to fi - if test ! -f $from; then - echo "Cross-compiling: target 'from' script '$from' not found." >&4 + if $test ! -f $from; then + echo "Target 'from' script '$from' not found." >&4 else chmod a+rx $from fi - if test ! -f $run -o ! -f $to -o ! -f $from; then + if $test ! -f $run -o ! -f $to -o ! -f $from; then exit 1 fi cat >&4 <<EOF -Cross-compiling: Using - $run-ssh - $to-ssh - $from-ssh +Using '$run' for remote execution, and '$from' and '$to' +for remote file transfer. EOF ;; *) run='' @@ -1748,13 +1748,20 @@ File::Glob dynamically, for extensions one needs MakeMaker and MakeMaker is not yet cross-compilation aware, and neither is the main Makefile. +Since the functionality is so lacking, it must be considered +highly experimental. It is so experimental that it is not even +mentioned during an interactive Configure session, a direct comand +line invocation (detailed shortly) is required to access the +functionality. + NOTE: Perl is routinely built using cross-compilation in the EPOC environment but the solutions from there - can't directly be used. + can't directly be used elsewhere. The one environment where cross-compilation has successfully been used as of this writing is the Compaq iPAQ running ARM Linux. The build -host was Intel Linux, the networking setup was PPP + SSH, see +host was Intel Linux, the networking setup was PPP + SSH. The exact +setup details are beyond the scope of this document, see http://www.handhelds.org/ for more information. To run Configure in cross-compilation mode the basic switch is @@ -1781,18 +1788,18 @@ happens), supply Configure with -Dtargethost=so.me.ho.st -Dtargetdir=/tar/get/dir The targethost is what e.g. ssh will use as the hostname, the targetdir -must exists (the scripts won't create it). You can also specify a -username to use +must exist (the scripts won't create it), the targetdir defaults to /tmp. +You can also specify a username to use for ssh/rsh logins -Dtargetuser=luser but in case you don't, "root" will be used. -Because this is a cross-compilation effort, you will also need to -specify which target environment and which compilation environment to -use. This includes the compiler, the header files, and the libraries. -In the below we will use the usual settings for the iPAQ -cross-compilation environment: +Because this is a cross-compilation effort, you will also need to specify +which target environment and which compilation environment to use. +This includes the compiler, the header files, and the libraries. +In the below we use the usual settings for the iPAQ cross-compilation +environment: -Dtargetarch=arm-linux -Dcc=arm-linux-gcc @@ -1803,7 +1810,10 @@ cross-compilation environment: If the name of the C<cc> has the usual GNU C semantics for cross compilers, that is, CPU-OS-gcc, the names of the C<ar>, C<nm>, and C<ranlib> will also be automatically chosen to be CPU-OS-ar and so on. -(The C<ld> requires more thought and will be chosen later by Configure.) +(The C<ld> requires more thought and will be chosen later by Configure +as appropriate.) Also, in this case the incpth, libpth, and usrinc +will be guessed by Configure (unless explicitly set to something else, +in which case Configure's guesses with be appended). In addition to the default execution/transfer methods you can also choose B<rsh> for execution, and B<rcp> or B<cp> for transfer, @@ -1814,7 +1824,8 @@ for example: Putting it all together: sh ./Configure -des -Dusecrosscompile \ - -Dtargethost=so.me.ho.st -Dtargetdir=/tar/get/dir \ + -Dtargethost=so.me.ho.st \ + -Dtargetdir=/tar/get/dir \ -Dtargetuser=root \ -Dtargetarch=arm-linux \ -Dcc=arm-linux-gcc \ @@ -1823,6 +1834,13 @@ Putting it all together: -Dlibpth=/skiff/local/arm-linux/lib \ -D... +or if you are happy with the defaults + + sh ./Configure -des -Dusecrosscompile \ + -Dtargethost=so.me.ho.st \ + -Dcc=arm-linux-gcc \ + -D... + =head1 make test This will run the regression tests on the perl you just made. If @@ -1216,8 +1216,6 @@ lib/less.pm For "use less" lib/lib_pm.PL For "use lib", produces lib/lib.pm lib/locale.pm For "use locale" lib/locale.t See if locale support works -lib/locale/latin1 Part of locale.t in Latin 1 -lib/locale/utf8 Part of locale.t in UTF8 lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing lib/open.pm Pragma to specify default I/O disciplines @@ -1233,9 +1231,6 @@ lib/sigtrap.pm For trapping an abort and giving traceback lib/stat.pl Perl library supporting stat function lib/strict.pm For "use strict" lib/strict.t See if strictures work -lib/strict/refs Tests of "use strict 'refs'" for strict.t -lib/strict/subs Tests of "use strict 'subs'" for strict.t -lib/strict/vars Tests of "use strict 'vars'" for strict.t lib/subs.pm Declare overriding subs lib/subs.t See if subroutine pseudo-importation works lib/syslog.pl Perl library supporting syslogging @@ -1531,41 +1526,8 @@ lib/validate.pl Perl library supporting wholesale file mode validation lib/vars.pm Declare pseudo-imported global variables lib/vars.t See if "use vars" work lib/warnings.pm For "use warnings" -lib/warnings.t See if warning controls work -lib/warnings/1global Tests of global warnings for warnings.t -lib/warnings/2use Tests for "use warnings" for warnings.t -lib/warnings/3both Tests for interaction of $^W and "use warnings" -lib/warnings/4lint Tests for -W switch -lib/warnings/5nolint Tests for -X switch -lib/warnings/6default Tests default warnings -lib/warnings/7fatal Tests fatal warnings -lib/warnings/8signal Tests warnings + __WARN__ and __DIE__ -lib/warnings/9enabled Tests warnings -lib/warnings/av Tests for av.c for warnings.t -lib/warnings/doio Tests for doio.c for warnings.t -lib/warnings/doop Tests for doop.c for warnings.t -lib/warnings/gv Tests for gv.c for warnings.t -lib/warnings/hv Tests for hv.c for warnings.t -lib/warnings/malloc Tests for malloc.c for warnings.t -lib/warnings/mg Tests for mg.c for warnings.t -lib/warnings/op Tests for op.c for warnings.t -lib/warnings/perl Tests for perl.c for warnings.t -lib/warnings/perlio Tests for perlio.c for warnings.t -lib/warnings/perly Tests for perly.y for warnings.t -lib/warnings/pp Tests for pp.c for warnings.t -lib/warnings/pp_ctl Tests for pp_ctl.c for warnings.t -lib/warnings/pp_hot Tests for pp_hot.c for warnings.t -lib/warnings/pp_sys Tests for pp_sys.c for warnings.t -lib/warnings/regcomp Tests for regcomp.c for warnings.t -lib/warnings/regexec Tests for regexec.c for warnings.t +lib/warnings.t See if warning controls work lib/warnings/register.pm For "use warnings::register" -lib/warnings/run Tests for run.c for warnings.t -lib/warnings/sv Tests for sv.c for warnings.t -lib/warnings/taint Tests for taint.c for warnings.t -lib/warnings/toke Tests for toke.c for warnings.t -lib/warnings/universal Tests for universal.c for warnings.t -lib/warnings/utf8 Tests for utf8.c for warnings.t -lib/warnings/util Tests for util.c for warnings.t locale.c locale-specific utility functions makeaperl.SH perl script that produces a new perl binary makedef.pl Create symbol export lists for linking @@ -1778,6 +1740,7 @@ pp.h Push/Pop code defs pp.sym Push/Pop code symbols pp_ctl.c Push/Pop code for control flow pp_hot.c Push/Pop code for heavily used opcodes +pp_pack.c Push/Pop code for pack/unpack pp_proto.h C++ definitions for Push/Pop code pp_sys.c Push/Pop code for system interaction proto.h Prototypes @@ -1859,6 +1822,8 @@ t/lib/dprof/test6_v Perl code profiler tests t/lib/filter-util.pl See if Filter::Util::Call works t/lib/h2ph.h Test header file for h2ph t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison +t/lib/locale/latin1 Part of locale.t in Latin 1 +t/lib/locale/utf8 Part of locale.t in UTF8 t/lib/sample-tests/bailout Test data for Test::Harness t/lib/sample-tests/combined Test data for Test::Harness t/lib/sample-tests/descriptive Test data for Test::Harness @@ -1872,6 +1837,42 @@ t/lib/sample-tests/skip_all Test data for Test::Harness t/lib/sample-tests/todo Test data for Test::Harness t/lib/sample-tests/with_comments Test data for Test::Harness t/lib/st-dump.pl See if Storable works +t/lib/strict/refs Tests of "use strict 'refs'" for strict.t +t/lib/strict/subs Tests of "use strict 'subs'" for strict.t +t/lib/strict/vars Tests of "use strict 'vars'" for strict.t +t/lib/warnings/1global Tests of global warnings for warnings.t +t/lib/warnings/2use Tests for "use warnings" for warnings.t +t/lib/warnings/3both Tests for interaction of $^W and "use warnings" +t/lib/warnings/4lint Tests for -W switch +t/lib/warnings/5nolint Tests for -X switch +t/lib/warnings/6default Tests default warnings +t/lib/warnings/7fatal Tests fatal warnings +t/lib/warnings/8signal Tests warnings + __WARN__ and __DIE__ +t/lib/warnings/9enabled Tests warnings +t/lib/warnings/av Tests for av.c for warnings.t +t/lib/warnings/doio Tests for doio.c for warnings.t +t/lib/warnings/doop Tests for doop.c for warnings.t +t/lib/warnings/gv Tests for gv.c for warnings.t +t/lib/warnings/hv Tests for hv.c for warnings.t +t/lib/warnings/malloc Tests for malloc.c for warnings.t +t/lib/warnings/mg Tests for mg.c for warnings.t +t/lib/warnings/op Tests for op.c for warnings.t +t/lib/warnings/perl Tests for perl.c for warnings.t +t/lib/warnings/perlio Tests for perlio.c for warnings.t +t/lib/warnings/perly Tests for perly.y for warnings.t +t/lib/warnings/pp Tests for pp.c for warnings.t +t/lib/warnings/pp_ctl Tests for pp_ctl.c for warnings.t +t/lib/warnings/pp_hot Tests for pp_hot.c for warnings.t +t/lib/warnings/pp_sys Tests for pp_sys.c for warnings.t +t/lib/warnings/regcomp Tests for regcomp.c for warnings.t +t/lib/warnings/regexec Tests for regexec.c for warnings.t +t/lib/warnings/run Tests for run.c for warnings.t +t/lib/warnings/sv Tests for sv.c for warnings.t +t/lib/warnings/taint Tests for taint.c for warnings.t +t/lib/warnings/toke Tests for toke.c for warnings.t +t/lib/warnings/universal Tests for universal.c for warnings.t +t/lib/warnings/utf8 Tests for utf8.c for warnings.t +t/lib/warnings/util Tests for util.c for warnings.t t/op/64bitint.t See if 64 bit integers work t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works diff --git a/Makefile.SH b/Makefile.SH index 5eaef2cd25..133fd339cd 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -263,13 +263,13 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c -c4 = globals.c perlio.c perlapi.c numeric.c locale.c +c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) -obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) +obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) diff --git a/Makefile.micro b/Makefile.micro index 304db0b972..4ed2a1c907 100644 --- a/Makefile.micro +++ b/Makefile.micro @@ -12,10 +12,11 @@ O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \ uglobals$(_O) ugv$(_O) uhv$(_O) \ umg$(_O) uperlmain$(_O) uop$(_O) \ uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \ - upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) \ + upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) \ uregcomp$(_O) uregexec$(_O) urun$(_O) \ uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \ - uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O) + unumeric$(_O) ulocale$(_O) \ + uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O) \ microperl: $(O) $(LD) -o $@ $(O) $(LIBS) @@ -91,6 +92,9 @@ upp_hot$(_O): $(HE) pp_hot.c upp_sys$(_O): $(HE) pp_sys.c $(CC) -c -o $@ $(CFLAGS) pp_sys.c +upp_pack$(_O): $(HE) pp_pack.c + $(CC) -c -o $@ $(CFLAGS) pp_pack.c + uregcomp$(_O): $(HE) regcomp.c regcomp.h regnodes.h INTERN.h $(CC) -c -o $@ $(CFLAGS) regcomp.c @@ -112,6 +116,12 @@ utaint$(_O): $(HE) taint.c utoke$(_O): $(HE) toke.c keywords.h $(CC) -c -o $@ $(CFLAGS) toke.c +ulocale$(_O): $(HE) locale.c + $(CC) -c -o $@ $(CFLAGS) locale.c + +unumeric$(_O): $(HE) numeric.c + $(CC) -c -o $@ $(CFLAGS) numeric.c + uuniversal$(_O): $(HE) universal.c objXSUB.h XSUB.h $(CC) -c -o $@ $(CFLAGS) universal.c @@ -99,10 +99,12 @@ for file do dump) ;; gv) ;; hv) ;; + locale) ;; main) ;; malloc) ;; mg) ;; miniperlmain) ;; + numeric) ;; op) ;; perl) ;; perlapi) ;; @@ -111,6 +113,7 @@ for file do pp) ;; pp_ctl) ;; pp_hot) ;; + pp_pack) ;; pp_sys) ;; regcomp) ;; regexec) ;; diff --git a/configure.com b/configure.com index 447a98133e..d5de2003f4 100644 --- a/configure.com +++ b/configure.com @@ -1,3 +1,4 @@ +$! OpenVMS configuration procedure for Perl -- do not attempt to run under DOS $ sav_ver = 'F$VERIFY(0)' $! SET VERIFY $! @@ -967,9 +967,11 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define doencodes S_doencodes #define refto S_refto #define seed S_seed +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define doencodes S_doencodes #define mul128 S_mul128 #define is_an_int S_is_an_int #define div128 S_div128 @@ -2466,9 +2468,11 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c) #define refto(a) S_refto(aTHX_ a) #define seed() S_seed(aTHX) +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c) #define mul128(a,b) S_mul128(aTHX_ a,b) #define is_an_int(a,b) S_is_an_int(aTHX_ a,b) #define div128(a,b) S_div128(aTHX_ a,b) @@ -4825,12 +4829,14 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define S_doencodes CPerlObj::S_doencodes -#define doencodes S_doencodes #define S_refto CPerlObj::S_refto #define refto S_refto #define S_seed CPerlObj::S_seed #define seed S_seed +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define S_doencodes CPerlObj::S_doencodes +#define doencodes S_doencodes #define S_mul128 CPerlObj::S_mul128 #define mul128 S_mul128 #define S_is_an_int CPerlObj::S_is_an_int @@ -1348,8 +1348,7 @@ Ajnod |int |perl_run |PerlInterpreter* interp Ajnod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ |int argc|char** argv|char** env #if defined(USE_ITHREADS) -: XXX: perl_clone needs docs -Ajno |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags +Ajnod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags # if defined(PERL_IMPLICIT_SYS) Ajno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ |struct IPerlMem* m|struct IPerlMem* ms \ @@ -1827,7 +1826,7 @@ Ap |OP* |newPMOP |I32 type|I32 flags Ap |OP* |newPVOP |I32 type|I32 flags|char* pv Ap |SV* |newRV |SV* pref Apd |SV* |newRV_noinc |SV *sv -Ap |SV* |newSV |STRLEN len +Apd |SV* |newSV |STRLEN len Ap |OP* |newSVREF |OP* o Ap |OP* |newSVOP |I32 type|I32 flags|SV* sv Apd |SV* |newSViv |IV i @@ -1997,25 +1996,25 @@ np |Signal_t |sighandler |int sig Ap |SV** |stack_grow |SV** sp|SV**p|int n Ap |I32 |start_subparse |I32 is_format|U32 flags p |void |sub_crush_depth|CV* cv -Ap |bool |sv_2bool |SV* sv -Ap |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref -Ap |IO* |sv_2io |SV* sv -Ap |IV |sv_2iv |SV* sv +Apd |bool |sv_2bool |SV* sv +Apd |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref +Apd |IO* |sv_2io |SV* sv +Apd |IV |sv_2iv |SV* sv Apd |SV* |sv_2mortal |SV* sv -Ap |NV |sv_2nv |SV* sv +Apd |NV |sv_2nv |SV* sv Aop |char* |sv_2pv |SV* sv|STRLEN* lp -Ap |char* |sv_2pvutf8 |SV* sv|STRLEN* lp -Ap |char* |sv_2pvbyte |SV* sv|STRLEN* lp -Ap |UV |sv_2uv |SV* sv -Ap |IV |sv_iv |SV* sv -Ap |UV |sv_uv |SV* sv -Ap |NV |sv_nv |SV* sv -Ap |char* |sv_pvn |SV *sv|STRLEN *len -Ap |char* |sv_pvutf8n |SV *sv|STRLEN *len -Ap |char* |sv_pvbyten |SV *sv|STRLEN *len +Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp +Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp +Apd |UV |sv_2uv |SV* sv +Apd |IV |sv_iv |SV* sv +Apd |UV |sv_uv |SV* sv +Apd |NV |sv_nv |SV* sv +Apd |char* |sv_pvn |SV *sv|STRLEN *len +Apd |char* |sv_pvutf8n |SV *sv|STRLEN *len +Apd |char* |sv_pvbyten |SV *sv|STRLEN *len Apd |I32 |sv_true |SV *sv -p |void |sv_add_arena |char* ptr|U32 size|U32 flags -Ap |int |sv_backoff |SV* sv +pd |void |sv_add_arena |char* ptr|U32 size|U32 flags +Apd |int |sv_backoff |SV* sv Apd |SV* |sv_bless |SV* sv|HV* stash Afpd |void |sv_catpvf |SV* sv|const char* pat|... Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args @@ -2023,13 +2022,13 @@ Apd |void |sv_catpv |SV* sv|const char* ptr Aopd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len Aopd |void |sv_catsv |SV* dsv|SV* ssv Apd |void |sv_chop |SV* sv|char* ptr -p |I32 |sv_clean_all -p |void |sv_clean_objs +pd |I32 |sv_clean_all +pd |void |sv_clean_objs Apd |void |sv_clear |SV* sv Apd |I32 |sv_cmp |SV* sv1|SV* sv2 Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 #if defined(USE_LOCALE_COLLATE) -Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp +Apd |char* |sv_collxfrm |SV* sv|STRLEN* nxp #endif Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|AV** avp Apd |int |sv_getcwd |SV* sv @@ -2038,7 +2037,7 @@ Ap |void |sv_dump |SV* sv Apd |bool |sv_derived_from|SV* sv|const char* name Apd |I32 |sv_eq |SV* sv1|SV* sv2 Apd |void |sv_free |SV* sv -p |void |sv_free_arenas +pd |void |sv_free_arenas Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append Apd |char* |sv_grow |SV* sv|STRLEN newlen Apd |void |sv_inc |SV* sv @@ -2052,18 +2051,18 @@ Apd |void |sv_magic |SV* sv|SV* obj|int how|const char* name \ |I32 namlen Apd |SV* |sv_mortalcopy |SV* oldsv Apd |SV* |sv_newmortal -Ap |SV* |sv_newref |SV* sv +Apd |SV* |sv_newref |SV* sv Ap |char* |sv_peek |SV* sv -Ap |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp -Ap |void |sv_pos_b2u |SV* sv|I32* offsetp +Apd |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp +Apd |void |sv_pos_b2u |SV* sv|I32* offsetp Aopd |char* |sv_pvn_force |SV* sv|STRLEN* lp Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp -Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp +Apd |char* |sv_pvbyten_force|SV* sv|STRLEN* lp Apd |int |sv_realpath |SV* sv|char *path|STRLEN len Apd |char* |sv_reftype |SV* sv|int ob Apd |void |sv_replace |SV* sv|SV* nsv -Ap |void |sv_report_used -Ap |void |sv_reset |char* s|HV* stash +Apd |void |sv_report_used +Apd |void |sv_reset |char* s|HV* stash Afpd |void |sv_setpvf |SV* sv|const char* pat|... Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args Apd |void |sv_setiv |SV* sv|IV num @@ -2079,12 +2078,12 @@ Apd |SV* |sv_setref_pvn |SV* rv|const char* classname|char* pv \ Apd |void |sv_setpv |SV* sv|const char* ptr Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len Aopd |void |sv_setsv |SV* dsv|SV* ssv -Ap |void |sv_taint |SV* sv -Ap |bool |sv_tainted |SV* sv +Apd |void |sv_taint |SV* sv +Apd |bool |sv_tainted |SV* sv Apd |int |sv_unmagic |SV* sv|int type Apd |void |sv_unref |SV* sv Apd |void |sv_unref_flags |SV* sv|U32 flags -Ap |void |sv_untaint |SV* sv +Apd |void |sv_untaint |SV* sv Apd |bool |sv_upgrade |SV* sv|U32 mt Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \ @@ -2129,7 +2128,7 @@ p |void |vivify_defelem |SV* sv p |void |vivify_ref |SV* sv|U32 to_what p |I32 |wait4pid |Pid_t pid|int* statusp|int flags p |void |report_evil_fh |GV *gv|IO *io|I32 op -p |void |report_uninit +pd |void |report_uninit Afpd |void |warn |const char* pat|... Ap |void |vwarn |const char* pat|va_list* args Afp |void |warner |U32 err|const char* pat|... @@ -2203,18 +2202,18 @@ Ap |void* |vdefault_protect|volatile JMPENV *je|int *excpt \ |protect_body_t body|va_list *args #endif Ap |void |reginitcolors -Ap |char* |sv_2pv_nolen |SV* sv -Ap |char* |sv_2pvutf8_nolen|SV* sv -Ap |char* |sv_2pvbyte_nolen|SV* sv -Ap |char* |sv_pv |SV *sv -Ap |char* |sv_pvutf8 |SV *sv -Ap |char* |sv_pvbyte |SV *sv +Apd |char* |sv_2pv_nolen |SV* sv +Apd |char* |sv_2pvutf8_nolen|SV* sv +Apd |char* |sv_2pvbyte_nolen|SV* sv +Apd |char* |sv_pv |SV *sv +Apd |char* |sv_pvutf8 |SV *sv +Apd |char* |sv_pvbyte |SV *sv Aopd |STRLEN |sv_utf8_upgrade|SV *sv ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok Apd |void |sv_utf8_encode |SV *sv ApdM |bool |sv_utf8_decode |SV *sv -Ap |void |sv_force_normal|SV *sv -Ap |void |sv_force_normal_flags|SV *sv|U32 flags +Apd |void |sv_force_normal|SV *sv +Apd |void |sv_force_normal_flags|SV *sv|U32 flags Ap |void |tmps_grow |I32 n Apd |SV* |sv_rvweaken |SV *sv p |int |magic_killbackrefs|SV *sv|MAGIC *mg @@ -2359,9 +2358,12 @@ s |struct perl_thread * |init_main_thread #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -s |void |doencodes |SV* sv|char* s|I32 len s |SV* |refto |SV* sv s |U32 |seed +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +s |void |doencodes |SV* sv|char* s|I32 len s |SV* |mul128 |SV *sv|U8 m s |SV* |is_an_int |char *s|STRLEN l s |int |div128 |SV *pnum|bool *done @@ -2604,5 +2606,5 @@ Apd |void |sv_catpvn_flags|SV* sv|const char* ptr|STRLEN len|I32 flags Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags -Ap |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags +Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags Ap |char* |my_atof2 |const char *s|NV* value diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index ef91a97792..6741905b7b 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -361,33 +361,47 @@ fflush(handle) RETVAL void -setbuf(handle, buf) +setbuf(handle, ...) OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; CODE: if (handle) #ifdef PERLIO_IS_STDIO + { + char *buf = items == 2 && SvPOK(ST(1)) ? + sv_grow(ST(1), BUFSIZ) : 0; setbuf(handle, buf); + } #else not_here("IO::Handle::setbuf"); #endif SysRet -setvbuf(handle, buf, type, size) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; - int type - int size +setvbuf(...) CODE: + if (items != 4) + Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)"); #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF) + { + OutputStream handle = 0; + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; + int type; + int size; + + if (items == 4) { + handle = IoOFP(sv_2io(ST(0))); + buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; + type = (int)SvIV(ST(2)); + size = (int)SvIV(ST(3)); + } if (!handle) /* Try input stream. */ handle = IoIFP(sv_2io(ST(0))); - if (handle) + if (items == 4 && handle) RETVAL = setvbuf(handle, buf, type, size); else { RETVAL = -1; errno = EINVAL; } + } #else RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); #endif diff --git a/ext/IPC/SysV/t/msg.t b/ext/IPC/SysV/t/msg.t index 2a982f054a..f8c066b384 100755 --- a/ext/IPC/SysV/t/msg.t +++ b/ext/IPC/SysV/t/msg.t @@ -1,3 +1,15 @@ +BEGIN { + eval { require Config; import Config }; + if ($@) { + print "1..0 # Skip: no Config\n"; + exit(0); + } + if ($Config{extensions} !~ m!\bIPC/SysV\b!) { + print "1..0 # Skip: no SysV IPC\n"; + exit(0); + } +} + use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO); use IPC::Msg; diff --git a/ext/IPC/SysV/t/sem.t b/ext/IPC/SysV/t/sem.t index 9d6fff64f2..9fa5704c6f 100755 --- a/ext/IPC/SysV/t/sem.t +++ b/ext/IPC/SysV/t/sem.t @@ -1,3 +1,14 @@ +BEGIN { + eval { require Config; import Config }; + if ($@) { + print "1..0 # Skip: no Config\n"; + exit(0); + } + if ($Config{extensions} !~ m!\bIPC/SysV\b!) { + print "1..0 # Skip: no SysV IPC\n"; + exit(0); + } +} use IPC::SysV qw( SETALL diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 0d14224538..fa705f0046 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -11,6 +11,7 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', + realclean => {FILES=> 'constants.c constants.xs'}, ); my @names = diff --git a/ext/Socket/Makefile.PL b/ext/Socket/Makefile.PL index 3c13ad986d..3a7bc57ffd 100644 --- a/ext/Socket/Makefile.PL +++ b/ext/Socket/Makefile.PL @@ -7,6 +7,7 @@ WriteMakefile( ($Config{libs} =~ /(-lsocks\S*)/ ? (LIBS => [ "$1" ] ) : ()), MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? + realclean => {FILES=> 'constants.c constants.xs'}, ); my @names = (qw(AF_802 AF_APPLETALK AF_CCITT AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_LAT diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL index 5824dfbcfb..c79abe75c8 100644 --- a/ext/Sys/Syslog/Makefile.PL +++ b/ext/Sys/Syslog/Makefile.PL @@ -6,6 +6,7 @@ WriteMakefile( VERSION_FROM => 'Syslog.pm', MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', + realclean => {FILES=> 'constants.c constants.xs'}, ); WriteConstants( NAME => 'GDBM_File', diff --git a/ext/Time/Piece/Piece.xs b/ext/Time/Piece/Piece.xs index bae2d4c7bf..d888588dcb 100644 --- a/ext/Time/Piece/Piece.xs +++ b/ext/Time/Piece/Piece.xs @@ -32,9 +32,7 @@ __strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = - CODE: #XXX: an sv_strftime() that can make use of the TARG would faster buf = my_strftime(fmt, sec, min, hour, mday, mon, year, wday, yday, isdst); - if (buf) { - RETVAL = buf; - } + RETVAL = buf; OUTPUT: RETVAL diff --git a/installperl b/installperl index e681eaee92..2774553bb1 100755 --- a/installperl +++ b/installperl @@ -697,9 +697,6 @@ sub installlib { # .exists files, .PL files, and .t files. return if $name =~ m{\.orig$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.t$}; - # ignore locale, strict, and warnings test data files - return if $name =~ m{^lib/(locale|strict|warnings)/\w+$}; - $name = "$dir/$name" if $dir ne ''; my $installlib = $installprivlib; diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index a3d951b08c..9d3e000aa9 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -59,7 +59,7 @@ sub format_arg { # The following handling of "control chars" is direct from # the original code - I think it is broken on Unicode though. # Suggestions? - $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; return $arg; } diff --git a/lib/locale.t b/lib/locale.t index 19fba597c5..b18ff41c97 100644 --- a/lib/locale.t +++ b/lib/locale.t @@ -311,9 +311,9 @@ if ($^O eq 'os390') { sub in_utf8 () { $^H & 0x08 } if (in_utf8) { - require "locale/utf8"; + require "lib/locale/utf8"; } else { - require "locale/latin1"; + require "lib/locale/latin1"; } my @Locale; diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 74288945bf..2257e713fa 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.12; +$VERSION = 1.13; $header = "perl5db.pl version $VERSION"; # @@ -252,7 +252,8 @@ $header = "perl5db.pl version $VERSION"; # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu> # + Fixed warnings generated by "O" (Show debugger options) # + Fixed warnings generated by "p 42" (Print expression) - +# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com +# + Added windowSize option #################################################################### # Needed for the statement after exec(): @@ -290,7 +291,7 @@ $inhibit_exit = $option{PrintRet} = 1; recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit ImmediateStop bareStringify CreateTTY - RemotePort); + RemotePort windowSize); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -310,6 +311,7 @@ $inhibit_exit = $option{PrintRet} = 1; maxTraceLen => \$maxtrace, ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, + windowSize => \$window, ); %optionAction = ( @@ -2146,7 +2148,7 @@ sub parse_options { # too dangerous to let intuitive usage overwrite important things # defaultion should never be the default my %opt_needs_val = map { ( $_ => 1 ) } qw{ - arrayDepth hashDepth LineInfo maxTraceLen ornaments + arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize pager quote ReadLine recallCommand RemotePort ShellBang TTY }; while (length) { diff --git a/lib/strict.t b/lib/strict.t index 8b9083f4fc..6067ad39bf 100644 --- a/lib/strict.t +++ b/lib/strict.t @@ -18,7 +18,7 @@ END { if ($tmpfile) { 1 while unlink $tmpfile; } } my @prgs = () ; -foreach (sort glob($^O eq 'MacOS' ? ":pragma:strict-*" : "pragma/strict-*")) { +foreach (sort glob($^O eq 'MacOS' ? ":lib::strict:*" : "lib/strict/*")) { next if /(~|\.orig|,v)$/; @@ -2360,6 +2360,8 @@ #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #if defined(PERL_FLEXIBLE_EXCEPTIONS) #endif diff --git a/patchlevel.h b/patchlevel.h index d4e0c8d669..43d2735740 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL10654" + ,"DEVEL10688" ,NULL }; @@ -4225,6 +4225,8 @@ Perl_sys_intern_init(pTHXo) #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #if defined(PERL_FLEXIBLE_EXCEPTIONS) #endif @@ -53,29 +53,29 @@ typedef union { #line 54 "perly.c" #define YYERRCODE 256 static short yylhs[] = { -1, - 54, 0, 8, 6, 9, 7, 10, 10, 10, 11, - 11, 11, 11, 24, 24, 24, 24, 24, 24, 24, - 14, 14, 14, 13, 13, 42, 42, 12, 12, 12, - 12, 12, 12, 12, 26, 26, 27, 27, 28, 29, - 30, 31, 32, 53, 53, 1, 1, 1, 1, 1, - 2, 38, 38, 46, 55, 3, 4, 5, 39, 40, - 40, 44, 44, 44, 45, 45, 41, 41, 56, 56, - 58, 57, 15, 15, 15, 25, 25, 25, 36, 36, - 36, 36, 36, 36, 36, 36, 59, 36, 37, 37, + 0, 9, 7, 6, 10, 8, 11, 11, 11, 12, + 12, 12, 12, 25, 25, 25, 25, 25, 25, 25, + 15, 15, 15, 14, 14, 43, 43, 13, 13, 13, + 13, 13, 13, 13, 27, 27, 28, 28, 29, 30, + 31, 32, 33, 54, 54, 1, 1, 1, 1, 1, + 2, 39, 39, 47, 55, 3, 4, 5, 40, 41, + 41, 45, 45, 45, 46, 46, 42, 42, 56, 56, + 58, 57, 16, 16, 16, 26, 26, 26, 37, 37, + 37, 37, 37, 37, 37, 37, 59, 37, 38, 38, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 51, 51, 51, 51, 51, 51, + 51, 51, 52, 52, 52, 52, 52, 53, 53, 53, + 53, 53, 53, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 49, 49, 49, 49, 49, 49, 49, 49, 49, - 49, 49, 49, 49, 50, 50, 50, 50, 50, 50, - 50, 50, 51, 51, 51, 51, 51, 52, 52, 52, - 52, 52, 52, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 47, 47, 48, 48, 48, 48, - 48, 33, 33, 34, 34, 34, 43, 23, 18, 19, - 20, 21, 22, 35, 35, 35, 35, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 48, 48, 49, 49, 49, 49, + 49, 34, 34, 35, 35, 35, 44, 24, 19, 20, + 21, 22, 23, 36, 36, 36, 36, }; static short yylen[] = { 2, - 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, + 2, 4, 0, 0, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 3, 0, 2, 6, 7, 7, 0, 2, 8, 8, 10, 9, 8, 11, 3, 0, 1, 0, 1, 1, 1, @@ -96,10 +96,10 @@ static short yylen[] = { 2, 1, 0, 1, 0, 1, 2, 1, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, }; -static short yydefred[] = { 1, +static short yydefred[] = { 4, 0, 7, 0, 45, 58, 56, 0, 56, 56, 8, 46, 9, 11, 48, 0, 47, 49, 50, 0, 0, - 0, 70, 71, 0, 14, 4, 173, 0, 0, 154, + 0, 70, 71, 0, 14, 3, 173, 0, 0, 154, 0, 168, 0, 57, 57, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -107,8 +107,8 @@ static short yydefred[] = { 1, 0, 0, 0, 0, 0, 146, 148, 0, 0, 0, 0, 174, 140, 134, 135, 136, 137, 52, 0, 59, 0, 69, 0, 0, 7, 194, 197, 196, 195, 0, - 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, - 4, 0, 0, 0, 0, 0, 163, 0, 0, 0, + 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 163, 0, 0, 0, 0, 85, 0, 192, 0, 129, 0, 0, 0, 0, 0, 0, 0, 179, 181, 180, 0, 188, 0, 0, 0, 0, 0, 0, 0, 0, 124, 0, 0, 0, @@ -117,14 +117,14 @@ static short yydefred[] = { 1, 0, 0, 0, 0, 0, 0, 0, 119, 120, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 13, 0, 51, 61, 0, 0, 0, 0, 83, 0, 0, - 87, 0, 0, 0, 0, 0, 0, 0, 4, 167, + 87, 0, 0, 0, 0, 0, 0, 0, 3, 167, 169, 0, 0, 0, 0, 0, 0, 0, 126, 0, 158, 178, 0, 0, 175, 0, 0, 123, 27, 0, 0, 19, 0, 0, 0, 0, 73, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 90, 0, 0, 101, 0, 0, 0, 0, 0, 0, 0, 156, 0, 0, 0, - 0, 0, 0, 3, 0, 0, 171, 0, 0, 0, + 0, 0, 0, 2, 0, 0, 171, 0, 0, 0, 42, 0, 43, 0, 0, 0, 0, 187, 0, 0, 36, 41, 0, 0, 0, 170, 186, 86, 0, 130, 0, 132, 0, 125, 177, 65, 0, 0, 0, 0, @@ -139,12 +139,12 @@ static short yydefred[] = { 1, 0, 33, 0, 23, }; static short yydgoto[] = { 1, - 10, 11, 20, 104, 19, 95, 370, 98, 359, 3, - 12, 13, 70, 375, 285, 72, 73, 74, 75, 76, - 77, 78, 79, 291, 81, 292, 281, 283, 286, 294, - 282, 284, 122, 214, 100, 82, 257, 89, 91, 194, - 327, 156, 289, 271, 225, 14, 83, 137, 84, 85, - 86, 87, 15, 2, 16, 17, 18, 93, 278, + 10, 11, 20, 104, 19, 2, 95, 370, 98, 359, + 3, 12, 13, 70, 375, 285, 72, 73, 74, 75, + 76, 77, 78, 79, 291, 81, 292, 281, 283, 286, + 294, 282, 284, 122, 214, 100, 82, 257, 89, 91, + 194, 327, 156, 289, 271, 225, 14, 83, 137, 84, + 85, 86, 87, 15, 16, 17, 18, 93, 278, }; static short yysindex[] = { 0, 0, 0, -132, 0, 0, 0, -51, 0, 0, 0, @@ -231,11 +231,11 @@ static short yyrindex[] = { 0, 0, 0, 179, 0, }; static short yygindex[] = { 0, - 0, 0, 196, 425, 0, -2, 0, 37, 634, -94, - 0, 0, 0, -323, -15, 2445, 0, 999, 414, 417, - 0, 0, 0, 463, -43, 0, 0, 321, -198, 103, - 147, 280, -91, -185, 1, 0, 0, 0, 464, -44, - 222, 338, 0, -179, 0, 0, 0, 0, 0, 0, + 0, 0, 196, 425, 0, 0, -2, 0, 37, 634, + -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414, + 417, 0, 0, 0, 463, -43, 0, 0, 321, -198, + 103, 147, 280, -91, -185, 1, 0, 0, 0, 464, + -44, 222, 338, 0, -179, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; #define YYTABLESIZE 4568 @@ -264,7 +264,7 @@ static short yytable[] = { 71, 307, 21, 180, 226, 21, 21, 21, 345, 21, 350, 21, 21, 65, 21, 272, 96, 162, 163, 121, 298, 97, 162, 163, 270, 121, 304, 310, 21, 312, 313, - 306, 26, 21, 26, 26, 253, 2, 162, 163, 113, + 306, 26, 21, 26, 26, 253, 1, 162, 163, 113, 113, 113, 113, 162, 163, 308, 113, 314, 113, 367, 163, 110, 162, 163, 60, 75, 75, 75, 75, 21, 162, 163, 75, 162, 163, 381, 330, 113, 113, 44, @@ -1182,10 +1182,10 @@ static char *yyname[] = { }; static char *yyrule[] = { "$accept : prog", -"$$1 :", -"prog : $$1 lineseq", +"prog : progstart lineseq", "block : '{' remember lineseq '}'", "remember :", +"progstart :", "mblock : '{' mremember lineseq '}'", "mremember :", "lineseq :", @@ -1252,8 +1252,8 @@ static char *yyrule[] = { "subbody : ';'", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", -"$$2 :", -"use : USE startsub $$2 WORD WORD listexpr ';'", +"$$1 :", +"use : USE startsub $$1 WORD WORD listexpr ';'", "expr : expr ANDOP expr", "expr : expr OROP expr", "expr : argexpr", @@ -1268,8 +1268,8 @@ static char *yyrule[] = { "listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", "listop : FUNC '(' listexprcom ')'", -"$$3 :", -"listop : LSTOPSUB startanonsub block $$3 listexpr", +"$$2 :", +"listop : LSTOPSUB startanonsub block $$2 listexpr", "method : METHOD", "method : scalar", "subscripted : star '{' expr ';' '}'", @@ -1395,7 +1395,7 @@ static char *yyrule[] = { #define YYMAXDEPTH 500 #endif #endif -#line 789 "perly.y" +#line 793 "perly.y" /* PROGRAM */ /* more stuff added to make perly_c.diff easier to apply */ @@ -1435,7 +1435,7 @@ yyparse() ysave->oldyychar = yychar; ysave->oldyyval = yyval; ysave->oldyylval = yylval; - + #if YYDEBUG if ((yys = getenv("YYDEBUG"))) { @@ -1499,7 +1499,7 @@ yyloop: ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } @@ -1552,7 +1552,7 @@ yyinrecovery: ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } @@ -1600,59 +1600,59 @@ yyreduce: switch (yyn) { case 1: -#line 130 "perly.y" -{ -#if defined(YYDEBUG) && defined(DEBUGGING) - yydebug = (DEBUG_p_TEST); -#endif - PL_expect = XSTATE; yyval.ival = block_start(TRUE); - } +#line 131 "perly.y" +{ yyval.ival = yyvsp[-1].ival; newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); } break; case 2: -#line 137 "perly.y" -{ newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); } -break; -case 3: -#line 142 "perly.y" +#line 136 "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 148 "perly.y" +case 3: +#line 142 "perly.y" { yyval.ival = block_start(TRUE); } break; +case 4: +#line 146 "perly.y" +{ +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (DEBUG_p_TEST); +#endif + PL_expect = XSTATE; yyval.ival = block_start(TRUE); + } +break; case 5: -#line 152 "perly.y" +#line 156 "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 158 "perly.y" +#line 162 "perly.y" { yyval.ival = block_start(FALSE); } break; case 7: -#line 163 "perly.y" +#line 167 "perly.y" { yyval.opval = Nullop; } break; case 8: -#line 165 "perly.y" +#line 169 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 9: -#line 167 "perly.y" +#line 171 "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 175 "perly.y" +#line 179 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; case 12: -#line 178 "perly.y" +#line 182 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1663,75 +1663,75 @@ case 12: PL_expect = XSTATE; } break; case 13: -#line 187 "perly.y" +#line 191 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); PL_expect = XSTATE; } break; case 14: -#line 193 "perly.y" +#line 197 "perly.y" { yyval.opval = Nullop; } break; case 15: -#line 195 "perly.y" +#line 199 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 16: -#line 197 "perly.y" +#line 201 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 17: -#line 199 "perly.y" +#line 203 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 18: -#line 201 "perly.y" +#line 205 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 19: -#line 203 "perly.y" +#line 207 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; case 20: -#line 205 "perly.y" +#line 209 "perly.y" { yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival, Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); } break; case 21: -#line 211 "perly.y" +#line 215 "perly.y" { yyval.opval = Nullop; } break; case 22: -#line 213 "perly.y" +#line 217 "perly.y" { (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); } break; case 23: -#line 215 "perly.y" +#line 219 "perly.y" { PL_copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); PL_hints |= HINT_BLOCK_SCOPE; } break; case 24: -#line 222 "perly.y" +#line 226 "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 226 "perly.y" +#line 230 "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 233 "perly.y" +#line 237 "perly.y" { yyval.opval = Nullop; } break; case 27: -#line 235 "perly.y" +#line 239 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 28: -#line 240 "perly.y" +#line 244 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1739,7 +1739,7 @@ case 28: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: -#line 246 "perly.y" +#line 250 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1747,23 +1747,23 @@ case 29: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 30: -#line 252 "perly.y" +#line 256 "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 255 "perly.y" +#line 259 "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 259 "perly.y" +#line 263 "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 263 "perly.y" +#line 267 "perly.y" { OP *forop; PL_copline = yyvsp[-9].ival; forop = newSTATEOP(0, yyvsp[-10].pval, @@ -1780,97 +1780,97 @@ case 33: yyval.opval = block_end(yyvsp[-7].ival, forop); } break; case 34: -#line 278 "perly.y" +#line 282 "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 285 "perly.y" +#line 289 "perly.y" { yyval.opval = Nullop; } break; case 37: -#line 291 "perly.y" +#line 295 "perly.y" { (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: -#line 297 "perly.y" +#line 301 "perly.y" { yyval.opval = invert(scalar(yyvsp[0].opval)); } break; case 40: -#line 302 "perly.y" +#line 306 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 41: -#line 306 "perly.y" +#line 310 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 42: -#line 310 "perly.y" +#line 314 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 43: -#line 314 "perly.y" +#line 318 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 44: -#line 319 "perly.y" +#line 323 "perly.y" { yyval.pval = Nullch; } break; case 46: -#line 325 "perly.y" +#line 329 "perly.y" { yyval.ival = 0; } break; case 47: -#line 327 "perly.y" +#line 331 "perly.y" { yyval.ival = 0; } break; case 48: -#line 329 "perly.y" +#line 333 "perly.y" { yyval.ival = 0; } break; case 49: -#line 331 "perly.y" +#line 335 "perly.y" { yyval.ival = 0; } break; case 50: -#line 333 "perly.y" +#line 337 "perly.y" { yyval.ival = 0; } break; case 51: -#line 337 "perly.y" +#line 341 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 52: -#line 340 "perly.y" +#line 344 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 53: -#line 341 "perly.y" +#line 345 "perly.y" { yyval.opval = Nullop; } break; case 54: -#line 346 "perly.y" +#line 350 "perly.y" { newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 55: -#line 351 "perly.y" +#line 355 "perly.y" { newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 56: -#line 355 "perly.y" +#line 359 "perly.y" { yyval.ival = start_subparse(FALSE, 0); } break; case 57: -#line 359 "perly.y" +#line 363 "perly.y" { yyval.ival = start_subparse(FALSE, CVf_ANON); } break; case 58: -#line 363 "perly.y" +#line 367 "perly.y" { yyval.ival = start_subparse(TRUE, 0); } break; case 59: -#line 367 "perly.y" +#line 371 "perly.y" { STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT") || strEQ(name, "CHECK")) @@ -1878,305 +1878,305 @@ case 59: yyval.opval = yyvsp[0].opval; } break; case 60: -#line 376 "perly.y" +#line 380 "perly.y" { yyval.opval = Nullop; } break; case 62: -#line 382 "perly.y" +#line 386 "perly.y" { yyval.opval = Nullop; } break; case 63: -#line 384 "perly.y" +#line 388 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 64: -#line 386 "perly.y" +#line 390 "perly.y" { yyval.opval = Nullop; } break; case 65: -#line 391 "perly.y" +#line 395 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 66: -#line 393 "perly.y" +#line 397 "perly.y" { yyval.opval = Nullop; } break; case 67: -#line 397 "perly.y" +#line 401 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 68: -#line 398 "perly.y" +#line 402 "perly.y" { yyval.opval = Nullop; PL_expect = XSTATE; } break; case 69: -#line 402 "perly.y" +#line 406 "perly.y" { package(yyvsp[-1].opval); } break; case 70: -#line 404 "perly.y" +#line 408 "perly.y" { package(Nullop); } break; case 71: -#line 408 "perly.y" +#line 412 "perly.y" { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } break; case 72: -#line 410 "perly.y" +#line 414 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 73: -#line 415 "perly.y" +#line 419 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 74: -#line 417 "perly.y" +#line 421 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 76: -#line 423 "perly.y" +#line 427 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 77: -#line 425 "perly.y" +#line 429 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 79: -#line 431 "perly.y" +#line 435 "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 80: -#line 434 "perly.y" +#line 438 "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 81: -#line 437 "perly.y" +#line 441 "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 82: -#line 442 "perly.y" +#line 446 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, scalar(yyvsp[-2].opval), newUNOP(OP_METHOD, 0, yyvsp[0].opval))); } break; case 83: -#line 446 "perly.y" +#line 450 "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 84: -#line 451 "perly.y" +#line 455 "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 85: -#line 456 "perly.y" +#line 460 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 86: -#line 458 "perly.y" +#line 462 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 87: -#line 460 "perly.y" +#line 464 "perly.y" { yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); } break; case 88: -#line 462 "perly.y" +#line 466 "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 91: -#line 476 "perly.y" +#line 480 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); } break; case 92: -#line 478 "perly.y" +#line 482 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 93: -#line 480 "perly.y" +#line 484 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 94: -#line 484 "perly.y" +#line 488 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 95: -#line 488 "perly.y" +#line 492 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 96: -#line 491 "perly.y" +#line 495 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 97: -#line 496 "perly.y" +#line 500 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 98: -#line 501 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 99: -#line 504 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 100: -#line 509 "perly.y" +#line 513 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-3].opval)))); } break; case 101: -#line 513 "perly.y" +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-2].opval))); } break; case 102: -#line 519 "perly.y" +#line 523 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 103: -#line 521 "perly.y" +#line 525 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 104: -#line 523 "perly.y" +#line 527 "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 105: -#line 527 "perly.y" +#line 531 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 106: -#line 529 "perly.y" +#line 533 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 107: -#line 531 "perly.y" +#line 535 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 108: -#line 533 "perly.y" +#line 537 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 109: -#line 535 "perly.y" +#line 539 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 110: -#line 537 "perly.y" +#line 541 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 111: -#line 539 "perly.y" +#line 543 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 112: -#line 541 "perly.y" +#line 545 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 113: -#line 543 "perly.y" +#line 547 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 114: -#line 545 "perly.y" +#line 549 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 115: -#line 550 "perly.y" +#line 554 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 116: -#line 552 "perly.y" +#line 556 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 117: -#line 554 "perly.y" +#line 558 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 118: -#line 556 "perly.y" +#line 560 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 119: -#line 558 "perly.y" +#line 562 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 120: -#line 561 "perly.y" +#line 565 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 121: -#line 564 "perly.y" +#line 568 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 122: -#line 567 "perly.y" +#line 571 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 123: -#line 574 "perly.y" +#line 578 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 124: -#line 576 "perly.y" +#line 580 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 125: -#line 578 "perly.y" +#line 582 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 126: -#line 580 "perly.y" +#line 584 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 127: -#line 582 "perly.y" +#line 586 "perly.y" { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 128: -#line 588 "perly.y" +#line 592 "perly.y" { yyval.opval = dofile(yyvsp[0].opval); } break; case 129: -#line 590 "perly.y" +#line 594 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 130: -#line 592 "perly.y" +#line 596 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2186,7 +2186,7 @@ case 130: )),Nullop)); dep();} break; case 131: -#line 600 "perly.y" +#line 604 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2197,76 +2197,76 @@ case 131: )))); dep();} break; case 132: -#line 609 "perly.y" +#line 613 "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 133: -#line 613 "perly.y" +#line 617 "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 138: -#line 625 "perly.y" +#line 629 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 139: -#line 627 "perly.y" +#line 631 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 140: -#line 629 "perly.y" +#line 633 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 141: -#line 631 "perly.y" +#line 635 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 142: -#line 633 "perly.y" +#line 637 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 143: -#line 635 "perly.y" +#line 639 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 144: -#line 637 "perly.y" +#line 641 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 145: -#line 639 "perly.y" +#line 643 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 146: -#line 641 "perly.y" +#line 645 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 147: -#line 643 "perly.y" +#line 647 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 148: -#line 645 "perly.y" +#line 649 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 149: -#line 647 "perly.y" +#line 651 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 150: -#line 649 "perly.y" +#line 653 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 151: -#line 651 "perly.y" +#line 655 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 152: -#line 653 "perly.y" +#line 657 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2274,7 +2274,7 @@ case 152: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 153: -#line 659 "perly.y" +#line 663 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2283,176 +2283,176 @@ case 153: PL_expect = XOPERATOR; } break; case 154: -#line 666 "perly.y" +#line 670 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 155: -#line 668 "perly.y" +#line 672 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 156: -#line 670 "perly.y" +#line 674 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 157: -#line 672 "perly.y" +#line 676 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 158: -#line 675 "perly.y" +#line 679 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 159: -#line 678 "perly.y" +#line 682 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; } break; case 160: -#line 681 "perly.y" +#line 685 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 161: -#line 683 "perly.y" +#line 687 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 162: -#line 685 "perly.y" +#line 689 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 163: -#line 687 "perly.y" +#line 691 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 164: -#line 689 "perly.y" +#line 693 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 165: -#line 691 "perly.y" +#line 695 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 166: -#line 694 "perly.y" +#line 698 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 167: -#line 696 "perly.y" +#line 700 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 168: -#line 698 "perly.y" +#line 702 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 169: -#line 701 "perly.y" +#line 705 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 170: -#line 703 "perly.y" +#line 707 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 171: -#line 705 "perly.y" +#line 709 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 172: -#line 707 "perly.y" +#line 711 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 175: -#line 714 "perly.y" +#line 718 "perly.y" { yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); } break; case 176: -#line 716 "perly.y" +#line 720 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 177: -#line 721 "perly.y" +#line 725 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 178: -#line 723 "perly.y" +#line 727 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 179: -#line 725 "perly.y" +#line 729 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 180: -#line 727 "perly.y" +#line 731 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 181: -#line 729 "perly.y" +#line 733 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 182: -#line 734 "perly.y" +#line 738 "perly.y" { yyval.opval = Nullop; } break; case 183: -#line 736 "perly.y" +#line 740 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 184: -#line 740 "perly.y" +#line 744 "perly.y" { yyval.opval = Nullop; } break; case 185: -#line 742 "perly.y" +#line 746 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 186: -#line 744 "perly.y" +#line 748 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 187: -#line 750 "perly.y" +#line 754 "perly.y" { PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 188: -#line 754 "perly.y" +#line 758 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 189: -#line 758 "perly.y" +#line 762 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 190: -#line 762 "perly.y" +#line 766 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 191: -#line 766 "perly.y" +#line 770 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 192: -#line 770 "perly.y" +#line 774 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 193: -#line 774 "perly.y" +#line 778 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 194: -#line 779 "perly.y" +#line 783 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 195: -#line 781 "perly.y" +#line 785 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 196: -#line 783 "perly.y" +#line 787 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 197: -#line 786 "perly.y" +#line 790 "perly.y" { yyval.opval = yyvsp[0].opval; } break; #line 2459 "perly.c" @@ -2510,7 +2510,7 @@ to state %d\n", *yyssp, yystate); ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } @@ -83,7 +83,7 @@ static void yydestruct(pTHXo_ void *ptr); %token COLONATTR %type <ival> prog decl format startsub startanonsub startformsub -%type <ival> remember mremember '&' +%type <ival> progstart remember mremember '&' %type <opval> block mblock lineseq line loop cond else %type <opval> expr term subscripted scalar ary hsh arylen star amper sideff %type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr @@ -126,15 +126,9 @@ static void yydestruct(pTHXo_ void *ptr); %% /* RULES */ /* The whole program */ -prog : /* NULL */ - { -#if defined(YYDEBUG) && defined(DEBUGGING) - yydebug = (DEBUG_p_TEST); -#endif - PL_expect = XSTATE; $$ = block_start(TRUE); - } +prog : progstart /*CONTINUED*/ lineseq - { newPROG(block_end($1,$2)); } + { $$ = $1; newPROG(block_end($1,$2)); } ; /* An ordinary block */ @@ -148,6 +142,16 @@ remember: /* NULL */ /* start a full lexical scope */ { $$ = block_start(TRUE); } ; +progstart: + { +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (DEBUG_p_TEST); +#endif + PL_expect = XSTATE; $$ = block_start(TRUE); + } + ; + + mblock : '{' mremember lineseq '}' { if (PL_copline > (line_t)$1) PL_copline = $1; @@ -456,7 +460,7 @@ listop : LSTOP indirob argexpr /* print $fh @args */ { $$ = convert($1, 0, $2); } | FUNC '(' listexprcom ')' /* print (@args) */ { $$ = convert($1, 0, $3); } - | LSTOPSUB startanonsub block /* map { foo } ... */ + | LSTOPSUB startanonsub block /* map { foo } ... */ { $3 = newANONATTRSUB($2, 0, Nullop, $3); } listexpr %prec LSTOP /* ... @bar */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, @@ -575,7 +579,7 @@ anonymous: '[' expr ']' | '[' ']' { $$ = newANONLIST(Nullop); } | HASHBRACK expr ';' '}' %prec '(' /* { foo => "Bar" } */ - { $$ = newANONHASH($2); } + { $$ = newANONHASH($2); } | HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */ { $$ = newANONHASH(Nullop); } | ANONSUB startanonsub proto subattrlist block %prec '(' @@ -666,7 +670,7 @@ term : termbinop { $$ = $1; } | amper /* &foo; */ { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); } - | amper '(' ')' /* &foo() */ + | amper '(' ')' /* &foo() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } | amper '(' expr ')' /* &foo(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, diff --git a/perly_c.diff b/perly_c.diff index c15e95be27..8d584193de 100644 --- a/perly_c.diff +++ b/perly_c.diff @@ -1,5 +1,12 @@ ---- perly.c.orig Sun Jun 10 21:13:50 2001 -+++ perly.c Sun Jun 10 21:13:51 2001 +--- perly.c.orig Tue Jun 19 08:39:52 2001 ++++ perly.c Tue Jun 19 08:39:24 2001 +@@ -1,5 +1,5 @@ + #ifndef lint +-static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; ++/* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */ + #endif + #define YYBYACC 1 + #line 16 "perly.y" @@ -50,70 +50,9 @@ #define yylex yylex_r #endif @@ -70,39 +77,39 @@ #define YYERRCODE 256 -short yylhs[] = { -1, +static short yylhs[] = { -1, - 54, 0, 8, 6, 9, 7, 10, 10, 10, 11, - 11, 11, 11, 24, 24, 24, 24, 24, 24, 24, - 14, 14, 14, 13, 13, 42, 42, 12, 12, 12, + 0, 9, 7, 6, 10, 8, 11, 11, 11, 12, + 12, 12, 12, 25, 25, 25, 25, 25, 25, 25, + 15, 15, 15, 14, 14, 43, 43, 13, 13, 13, @@ -135,7 +74,7 @@ - 48, 33, 33, 34, 34, 34, 43, 23, 18, 19, - 20, 21, 22, 35, 35, 35, 35, + 49, 34, 34, 35, 35, 35, 44, 24, 19, 20, + 21, 22, 23, 36, 36, 36, 36, }; -short yylen[] = { 2, +static short yylen[] = { 2, - 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, + 2, 4, 0, 0, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 3, 0, 2, 6, 7, 7, 0, 2, 8, 8, 10, @@ -157,7 +96,7 @@ 1, 0, 1, 0, 1, 2, 1, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, }; --short yydefred[] = { 1, -+static short yydefred[] = { 1, +-short yydefred[] = { 4, ++static short yydefred[] = { 4, 0, 7, 0, 45, 58, 56, 0, 56, 56, 8, 46, 9, 11, 48, 0, 47, 49, 50, 0, 0, - 0, 70, 71, 0, 14, 4, 173, 0, 0, 154, + 0, 70, 71, 0, 14, 3, 173, 0, 0, 154, @@ -199,7 +138,7 @@ 0, 22, 0, 0, 0, 31, 5, 0, 30, 0, 0, 33, 0, 23, }; -short yydgoto[] = { 1, +static short yydgoto[] = { 1, - 10, 11, 20, 104, 19, 95, 370, 98, 359, 3, - 12, 13, 70, 375, 285, 72, 73, 74, 75, 76, - 77, 78, 79, 291, 81, 292, 281, 283, 286, 294, + 10, 11, 20, 104, 19, 2, 95, 370, 98, 359, + 3, 12, 13, 70, 375, 285, 72, 73, 74, 75, + 76, 77, 78, 79, 291, 81, 292, 281, 283, 286, @@ -207,7 +146,7 @@ - 327, 156, 289, 271, 225, 14, 83, 137, 84, 85, - 86, 87, 15, 2, 16, 17, 18, 93, 278, + 194, 327, 156, 289, 271, 225, 14, 83, 137, 84, + 85, 86, 87, 15, 16, 17, 18, 93, 278, }; -short yysindex[] = { 0, +static short yysindex[] = { 0, @@ -124,9 +131,9 @@ }; -short yygindex[] = { 0, +static short yygindex[] = { 0, - 0, 0, 196, 425, 0, -2, 0, 37, 634, -94, - 0, 0, 0, -323, -15, 2445, 0, 999, 414, 417, - 0, 0, 0, 463, -43, 0, 0, 321, -198, 103, + 0, 0, 196, 425, 0, 0, -2, 0, 37, 634, + -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414, + 417, 0, 0, 0, 463, -43, 0, 0, 321, -198, @@ -300,7 +239,7 @@ 0, 0, 0, 0, 0, 0, 0, 0, 0, }; @@ -161,8 +168,8 @@ -char *yyrule[] = { +static char *yyrule[] = { "$accept : prog", - "$$1 :", - "prog : $$1 lineseq", + "prog : progstart lineseq", + "block : '{' remember lineseq '}'", @@ -1456,17 +1395,6 @@ #define YYMAXDEPTH 500 #endif @@ -178,7 +185,7 @@ -short yyss[YYSTACKSIZE]; -YYSTYPE yyvs[YYSTACKSIZE]; -#define yystacksize YYSTACKSIZE - #line 789 "perly.y" + #line 793 "perly.y" /* PROGRAM */ @@ -1477,7 +1405,7 @@ @@ -186,11 +193,11 @@ #define yyparse() Perl_yyparse(pTHX) -#line 1481 "y.tab.c" -+#line 1481 "perly.c" ++#line 1409 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab -@@ -1485,10 +1413,30 @@ +@@ -1485,11 +1413,31 @@ yyparse() { register int yym, yyn, yystate; @@ -204,7 +211,7 @@ register char *yys; - extern char *getenv(); +#endif - ++ + struct ysv *ysave; +#ifdef USE_ITHREADS + ENTER; /* force yydestruct() before we return */ @@ -217,12 +224,14 @@ + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; -+ + +- if (yys = getenv("YYDEBUG")) +#if YYDEBUG - if (yys = getenv("YYDEBUG")) ++ if ((yys = getenv("YYDEBUG"))) { yyn = *yys; -@@ -1501,6 +1449,16 @@ + if (yyn >= '0' && yyn <= '9') +@@ -1501,12 +1449,22 @@ yyerrflag = 0; yychar = (-1); @@ -239,6 +248,13 @@ yyssp = yyss; yyvsp = yyvs; *yyssp = yystate = 0; + + yyloop: +- if (yyn = yydefred[yystate]) goto yyreduce; ++ if ((yyn = yydefred[yystate])) goto yyreduce; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; @@ -1516,7 +1474,7 @@ yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; @@ -258,7 +274,6 @@ #endif if (yyssp >= yyss + yystacksize - 1) { -- goto yyoverflow; + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen @@ -269,21 +284,25 @@ + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); + ysave->yyss = Renew(yyss, yystacksize, short); + if (!yyvs || !yyss) -+ goto yyoverflow; + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; -@@ -1549,12 +1519,12 @@ +@@ -1547,14 +1517,14 @@ + } + if (yyerrflag) goto yyinrecovery; #ifdef lint - goto yynewerror; +- goto yynewerror; ++ #endif -yynewerror: + yyerror("syntax error"); #ifdef lint - goto yyerrlab; +- goto yyerrlab; ++ #endif -yyerrlab: + @@ -300,7 +319,6 @@ #endif if (yyssp >= yyss + yystacksize - 1) { -- goto yyoverflow; + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen @@ -311,7 +329,7 @@ + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); + ysave->yyss = Renew(yyss, yystacksize, short); + if (!yyvs || !yyss) -+ goto yyoverflow; + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; } @@ -345,11 +363,11 @@ #endif yym = yylen[yyn]; @@ -2473,7 +2455,7 @@ - #line 786 "perly.y" + #line 790 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2477 "y.tab.c" -+#line 2477 "perly.c" ++#line 2459 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -381,7 +399,6 @@ #endif if (yyssp >= yyss + yystacksize - 1) { -- goto yyoverflow; + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen @@ -392,7 +409,7 @@ + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); + ysave->yyss = Renew(yyss, yystacksize, short); + if (!yyvs || !yyss) -+ goto yyoverflow; + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; } diff --git a/pod/perl572delta.pod b/pod/perl572delta.pod index a2e0bdf0fb..6ed4582ca7 100644 --- a/pod/perl572delta.pod +++ b/pod/perl572delta.pod @@ -29,12 +29,14 @@ for more information. =head1 Incompatible Changes +=head2 64-bit platforms and malloc + If your pointers are 64 bits wide, the Perl malloc is no more being used because it simply does not work with 8-byte pointers. Also, usually the system malloc on such platforms are much better optimized for such large memory models than the Perl malloc. -=head1 Future Deprecations +=head2 Future Deprecations The current user-visible implementation of pseudo-hashes (the weird use of the first array element) is deprecated starting from Perl 5.8.0 @@ -84,6 +86,11 @@ The C<op_clear> and C<op_null> are now exported. =item * +L<utime> now supports C<utime undef, undef, @files> to change the +times to the current time. + +=item * + The Perl parser has been stress tested using both random input and Markov chain input. @@ -91,41 +98,53 @@ Markov chain input. =head1 Modules and Pragmata -=head2 New Modules +=head2 New Modules and Distribution =over 4 =item * -Attribute::Handlers - Simpler definition of attribute handlers +L<Attribute::Handlers> - Simpler definition of attribute handlers + +=item * + +L<ExtUtils::Constant> - generate XS code to import C header constants + +=item * + +L<I18N::LangTags> - functions for dealing with RFC3066-style language tags + +=item * + +L<libnet> - a collection of perl5 modules related to network programming =item * -ExtUtils::Constant - generate XS code to import C header constants +L<List::Util> - selection of general-utility list subroutines =item * -I18N::LangTags - functions for dealing with RFC3066-style language tags +L<Locale::Maketext> - framework for localization =item * -List::Util - selection of general-utility list subroutines +L<Memoize> - Make your functions faster by trading space for time =item * -Locale::Maketext - framework for localization +L<NEXT> - pseudo-class for method redispatch =item * -NEXT - pseudo-class for method redispatch +L<Scalar::Util> - selection of general-utility scalar subroutines =item * -Scalar::Util - selection of general-utility scalar subroutines +L<Time::HiRes> - high resolution ualarm, usleep, and gettimeofday =item * -Time::HiRes - high resolution ualarm, usleep, and gettimeofday +L<Time::Piece> - Object Oriented time objects =back @@ -137,7 +156,8 @@ Time::HiRes - high resolution ualarm, usleep, and gettimeofday L<B::Deparse> module has been significantly enhanced. It now can deparse almost all of the standard test suite (so that the -tests still succeed). +tests still succeed). There is a make target "test.deparse" +for trying this out. =item * @@ -159,12 +179,19 @@ new-style constant dispatch section (see L<ExtUtils::Constant>). =item * +L<File::Find> is now (again) reentrant. It also has been made +more portable. + +=item * + L<File::Glob> now supports C<GLOB_LIMIT> constant to limit the size of the returned list of filenames. -=back +=item * -=head1 Performance Enhancements +L<vars> now supports declaring qualified variables. + +=back =head1 Utility Changes @@ -172,6 +199,10 @@ size of the returned list of filenames. =item * +The F<emacs/e2ctags.pl> is now much faster. + +=item * + L<h2xs> uses the new L<ExtUtils::Constant> module which will affect newly created extensions that define constants. Since the new code is more correct (if you have two constants where the first one is a @@ -183,7 +214,7 @@ extension code (the new scheme makes regenerating easy). =item * -The F<emacs/e2ctags.pl> is now much faster. +L<libnetcfg> has been added to configure the libnet. =item * @@ -207,7 +238,8 @@ kind permission. More README.$PLATFORM files have been converted into pod, which also means that they also be installed as perl$PLATFORM documentation files. The new files are L<perlapollo>, L<perlbeos>, L<perldgux>, -L<perlhurd>, L<perlmint>, L<perlplan9>, L<perlqnx>, and L<perltru64>. +L<perlhurd>, L<perlmint>, L<perlnetware>, L<perlplan9>, L<perlqnx>, +and L<perltru64>. =item * @@ -215,7 +247,9 @@ The F<Todo> and F<Todo-5.6> files have been merged into L<perltodo>. =item * -Use of the F<gprof> tool to profile Perl has been documented in L<perlhack>. +Use of the F<gprof> tool to profile Perl has been documented in +L<perlhack>. There is a make target "perl.gprof" for generating a +gprofiled Perl executable. =back @@ -227,8 +261,8 @@ Use of the F<gprof> tool to profile Perl has been documented in L<perlhack>. =item * -AIX should now work better with gcc. Also longdouble support in -AIX should be better now. +AIX should now work better with gcc. Also longdouble support in AIX +should be better now. See L<perlaix>. =item * @@ -236,20 +270,22 @@ AtheOS (http://www.atheos.cx/) is a new platform. =item * -DG/UX platform now supports the 5.005-style threads. +DG/UX platform now supports the 5.005-style threads. See L<perldgux>. =item * -MacOS (Classic) [HOPEFULLY] +Several MacOS (Classic) portability patches have been applied. We +hope to get a fully working port by 5.8.0. (The remaining problems +relate to the changed IO model of Perl.) See L<perlmacos>. =item * -MacOS X (or Darwin) should now be able to build Perl even on HFS+ filesystem. -(The case-insensitivity confused the Perl build process.) +MacOS X (or Darwin) should now be able to build Perl even on HFS+ +filesystems. (The case-insensitivity confused the Perl build process.) =item * -Netware [HOPEFULLY] +NetWare from Novell is now supported. See L<perlnetware>. =item * @@ -284,9 +320,9 @@ DB_VERSION_PATCH_CFG> from C. =item * -The Thread extension is not built at all under ithreads (C<Configure --Duseithreads>) because it wouldn't work anyway (the Thread extension -requires being Configured with C<-Duse5005threads>). +The Thread extension is now not built at all under ithreads +(C<Configure -Duseithreads>) because it wouldn't work anyway (the +Thread extension requires being Configured with C<-Duse5005threads>). =item * @@ -298,6 +334,35 @@ make target has been added to help in further testing: C<make test.deparse>. =head1 Selected Bug Fixes +=over 5 + +=item * + +The autouse pragma didn't work for Multi::Part::Function::Names. + +=item * + +The behaviour of non-decimal but numeric string constants such as +"0x23" was platform-dependent: in some platforms that was seen as 35, +in some as 0, in some as a floating point number (don't ask). This +was caused by Perl using the operating system libraries in a situation +where the result of the string to number conversion is undefined: now +Perl consistently handles such strings as zero in numeric contexts. + +=item * + +L<dprofpp> -R didn't work. + +=item * + +PERL5OPT with embedded spaces didn't work. + +=item * + +L<Sys::Syslog> ignored the C<LOG_AUTH> constant. + +=back + =head2 Platform Specific Changes and Fixes =over 4 @@ -354,9 +419,9 @@ complete information. Several new tests have been added, especially for the F<lib> subsection. -=back - -The test F<camel-III/vstring> has been merged with F<op/ver>. +The tests are now reported in a different order than in earlier Perls. +(This happens because the test scripts from under t/lib have been moved +to be closer to the library/extension they are testing.) =head1 Known Problems @@ -446,6 +511,11 @@ hard-to-fix ways. As a stop-gap measure to avoid people from getting frustrated at the mysterious results (core dumps, most often) it is for now forbidden (you will get a fatal error even from an attempt). +=head2 Variable Attributes are not Currently Usable for Tieing + +This limitation will hopefully be fixed in future. (Subroutine +attributes work fine for tieing, see L<Attribute::Handlers>). + =head2 Building Extensions Can Fail Because Of Largefiles Some extensions like mod_perl are known to have issues with diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 5128dc32f3..91d6b315fe 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -329,7 +329,7 @@ L<perlsub/"Constant Functions">. SV* cv_const_sv(CV* cv) =for hackers -Found in file opmini.c +Found in file op.c =item dAX @@ -1153,13 +1153,13 @@ method, similar to C<use Foo::Bar VERSION LIST>. void load_module(U32 flags, SV* name, SV* ver, ...) =for hackers -Found in file opmini.c +Found in file op.c =item looks_like_number -Test if an the content of an SV looks like a number (or is a -number). C<Inf> and C<Infinity> are treated as numbers (so will not -issue a non-numeric warning), even if your atof() doesn't grok them. +Test if the content of an SV looks like a number (or is a number). +C<Inf> and C<Infinity> are treated as numbers (so will not issue a +non-numeric warning), even if your atof() doesn't grok them. I32 looks_like_number(SV* sv) @@ -1292,7 +1292,7 @@ eligible for inlining at compile-time. CV* newCONSTSUB(HV* stash, char* name, SV* sv) =for hackers -Found in file opmini.c +Found in file op.c =item newHV @@ -1323,6 +1323,17 @@ SV is B<not> incremented. =for hackers Found in file sv.c +=item newSV + +Create a new null SV, or if len > 0, create a new empty SVt_PV type SV +with an initial PV allocation of len+1. Normally accessed via the C<NEWSV> +macro. + + SV* newSV(STRLEN len) + +=for hackers +Found in file sv.c + =item NEWSV Creates a new SV. A non-zero C<len> parameter indicates the number of @@ -1369,7 +1380,7 @@ Found in file sv.c =item newSVpvf -Creates a new SV an initialize it with the string formatted like +Creates a new SV and initializes it with the string formatted like C<sprintf>. SV* newSVpvf(const char* pat, ...) @@ -1391,11 +1402,13 @@ Found in file sv.c =item newSVpvn_share -Creates a new SV and populates it with a string from -the string table. Turns on READONLY and FAKE. -The idea here is that as string table is used for shared hash -keys these strings will have SvPVX == HeKEY and hash lookup -will avoid string compare. +Creates a new SV with its SvPVX pointing to a shared string in the string +table. If the string does not already exist in the table, it is created +first. Turns on READONLY and FAKE. The string's hash is stored in the UV +slot of the SV; if the C<hash> parameter is non-zero, that value is used; +otherwise the hash is computed. The idea here is that as the string table +is used for shared hash keys these strings will have SvPVX == HeKEY and +hash lookup will avoid string compare. SV* newSVpvn_share(const char* s, I32 len, U32 hash) @@ -1417,6 +1430,7 @@ Found in file sv.c =item newSVsv Creates a new SV which is an exact duplicate of the original SV. +(Uses C<sv_setsv>). SV* newSVsv(SV* old) @@ -1438,7 +1452,7 @@ Found in file sv.c Used by C<xsubpp> to hook up XSUBs as Perl subs. =for hackers -Found in file opmini.c +Found in file op.c =item newXSproto @@ -1509,6 +1523,15 @@ Allocates a new Perl interpreter. See L<perlembed>. =for hackers Found in file perl.c +=item perl_clone + +Create and return a new interpreter by cloning the current one. + + PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags) + +=for hackers +Found in file sv.c + =item perl_construct Initializes a new Perl interpreter. See L<perlembed>. @@ -2067,17 +2090,28 @@ Found in file sv.h =item SvIV -Coerces the given SV to an integer and returns it. +Coerces the given SV to an integer and returns it. See C<SvIVx> for a +version which guarantees to evaluate sv only once. IV SvIV(SV* sv) =for hackers Found in file sv.h +=item SvIVx + +Coerces the given SV to an integer and returns it. Guarantees to evaluate +sv only once. Use the more efficent C<SvIV> otherwise. + + IV SvIVx(SV* sv) + +=for hackers +Found in file sv.h + =item SvIVX -Returns the integer which is stored in the SV, assuming SvIOK is -true. +Returns the raw value in the SV's IV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C<SvIV()>. IV SvIVX(SV* sv) @@ -2171,17 +2205,28 @@ Found in file sv.h =item SvNV -Coerce the given SV to a double and return it. +Coerce the given SV to a double and return it. See C<SvNVx> for a version +which guarantees to evaluate sv only once. NV SvNV(SV* sv) =for hackers Found in file sv.h +=item SvNVx + +Coerces the given SV to a double and returns it. Guarantees to evaluate +sv only once. Use the more efficent C<SvNV> otherwise. + + NV SvNVx(SV* sv) + +=for hackers +Found in file sv.h + =item SvNVX -Returns the double which is stored in the SV, assuming SvNOK is -true. +Returns the raw value in the SV's NV slot, without checks or conversions. +Only use when you are sure SvNOK is true. See also C<SvNV()>. NV SvNVX(SV* sv) @@ -2270,16 +2315,125 @@ Found in file sv.h =item SvPV Returns a pointer to the string in the SV, or a stringified form of the SV -if the SV does not contain a string. Handles 'get' magic. +if the SV does not contain a string. Handles 'get' magic. See also +C<SvPVx> for a version which guarantees to evaluate sv only once. char* SvPV(SV* sv, STRLEN len) =for hackers Found in file sv.h +=item SvPVbyte + +Like C<SvPV>, but converts sv to byte representation first if necessary. + + char* SvPVbyte(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVbytex + +Like C<SvPV>, but converts sv to byte representation first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVbyte> +otherwise. + + + char* SvPVbytex(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVbytex_force + +Like C<SvPV_force>, but converts sv to byte representation first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVbyte_force> +otherwise. + + char* SvPVbytex_force(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVbyte_force + +Like C<SvPV_force>, but converts sv to byte representation first if necessary. + + char* SvPVbyte_force(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVbyte_nolen + +Like C<SvPV_nolen>, but converts sv to byte representation first if necessary. + + char* SvPVbyte_nolen(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVutf8 + +Like C<SvPV>, but converts sv to uft8 first if necessary. + + char* SvPVutf8(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVutf8x + +Like C<SvPV>, but converts sv to uft8 first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVutf8> +otherwise. + + char* SvPVutf8x(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVutf8x_force + +Like C<SvPV_force>, but converts sv to uft8 first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVutf8_force> +otherwise. + + char* SvPVutf8x_force(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVutf8_force + +Like C<SvPV_force>, but converts sv to uft8 first if necessary. + + char* SvPVutf8_force(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVutf8_nolen + +Like C<SvPV_nolen>, but converts sv to uft8 first if necessary. + + char* SvPVutf8_nolen(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + +=item SvPVx + +A version of C<SvPV> which guarantees to evaluate sv only once. + + char* SvPVx(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + =item SvPVX -Returns a pointer to the string in the SV. The SV must contain a +Returns a pointer to the physical string in the SV. The SV must contain a string. char* SvPVX(SV* sv) @@ -2297,6 +2451,16 @@ force if you are going to update the SvPVX directly. =for hackers Found in file sv.h +=item SvPV_force_nomg + +Like <SvPV> but will force the SV into becoming a string (SvPOK). You want +force if you are going to update the SvPVX directly. Doesn't process magic. + + char* SvPV_force_nomg(SV* sv, STRLEN len) + +=for hackers +Found in file sv.h + =item SvPV_nolen Returns a pointer to the string in the SV, or a stringified form of the SV @@ -2380,6 +2544,24 @@ argument more than once. =for hackers Found in file sv.h +=item SvSetMagicSV + +Like C<SvSetSV>, but does any set magic required afterwards. + + void SvSetMagicSV(SV* dsb, SV* ssv) + +=for hackers +Found in file sv.h + +=item SvSetMagicSV_nosteal + +Like C<SvSetMagicSV>, but does any set magic required afterwards. + + void SvSetMagicSV_nosteal(SV* dsv, SV* ssv) + +=for hackers +Found in file sv.h + =item SvSetSV Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments @@ -2576,33 +2758,188 @@ Found in file sv.h =item SvUV -Coerces the given SV to an unsigned integer and returns it. +Coerces the given SV to an unsigned integer and returns it. See C<SvUVx> +for a version which guarantees to evaluate sv only once. UV SvUV(SV* sv) =for hackers Found in file sv.h +=item SvUVx + +Coerces the given SV to an unsigned integer and returns it. Guarantees to +evaluate sv only once. Use the more efficent C<SvUV> otherwise. + + UV SvUVx(SV* sv) + +=for hackers +Found in file sv.h + =item SvUVX -Returns the unsigned integer which is stored in the SV, assuming SvIOK is -true. +Returns the raw value in the SV's UV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C<SvUV()>. UV SvUVX(SV* sv) =for hackers Found in file sv.h +=item sv_2bool + +This function is only called on magical items, and is only used by +sv_true() or its macro equivalent. + + bool sv_2bool(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2cv + +Using various gambits, try to get a CV from an SV; in addition, try if +possible to set C<*st> and C<*gvp> to the stash and GV associated with it. + + CV* sv_2cv(SV* sv, HV** st, GV** gvp, I32 lref) + +=for hackers +Found in file sv.c + +=item sv_2io + +Using various gambits, try to get an IO from an SV: the IO slot if its a +GV; or the recursive result if we're an RV; or the IO slot of the symbol +named after the PV if we're a string. + + IO* sv_2io(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2iv + +Return the integer value of an SV, doing any necessary string conversion, +magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. + + IV sv_2iv(SV* sv) + +=for hackers +Found in file sv.c + =item sv_2mortal -Marks an SV as mortal. The SV will be destroyed when the current context -ends. +Marks an existing SV as mortal. The SV will be destroyed when the current +context ends. See also C<sv_newmortal> and C<sv_mortalcopy>. SV* sv_2mortal(SV* sv) =for hackers Found in file sv.c +=item sv_2nv + +Return the num value of an SV, doing any necessary string or integer +conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> +macros. + + NV sv_2nv(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2pvbyte + +Return a pointer to the byte-encoded representation of the SV, and set *lp +to its length. May cause the SV to be downgraded from UTF8 as a +side-effect. + +Usually accessed via the C<SvPVbyte> macro. + + char* sv_2pvbyte(SV* sv, STRLEN* lp) + +=for hackers +Found in file sv.c + +=item sv_2pvbyte_nolen + +Return a pointer to the byte-encoded representation of the SV. +May cause the SV to be downgraded from UTF8 as a side-effect. + +Usually accessed via the C<SvPVbyte_nolen> macro. + + char* sv_2pvbyte_nolen(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2pvutf8 + +Return a pointer to the UTF8-encoded representation of the SV, and set *lp +to its length. May cause the SV to be upgraded to UTF8 as a side-effect. + +Usually accessed via the C<SvPVutf8> macro. + + char* sv_2pvutf8(SV* sv, STRLEN* lp) + +=for hackers +Found in file sv.c + +=item sv_2pvutf8_nolen + +Return a pointer to the UTF8-encoded representation of the SV. +May cause the SV to be upgraded to UTF8 as a side-effect. + +Usually accessed via the C<SvPVutf8_nolen> macro. + + char* sv_2pvutf8_nolen(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2pv_flags + +Returns pointer to the string value of an SV, and sets *lp to its length. +If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string +if necessary. +Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg> +usually end up here too. + + char* sv_2pv_flags(SV* sv, STRLEN* lp, I32 flags) + +=for hackers +Found in file sv.c + +=item sv_2pv_nolen + +Like C<sv_2pv()>, but doesn't return the length too. You should usually +use the macro wrapper C<SvPV_nolen(sv)> instead. + char* sv_2pv_nolen(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_2uv + +Return the unsigned integer value of an SV, doing any necessary string +conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> +macros. + + UV sv_2uv(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_backoff + +Remove any string offset. You should normally use the C<SvOOK_off> macro +wrapper instead. + + int sv_backoff(SV* sv) + +=for hackers +Found in file sv.c + =item sv_bless Blesses an SV into a specified package. The SV must be an RV. The package @@ -2730,7 +3067,7 @@ Found in file sv.c Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside the string buffer. The C<ptr> becomes the first character of the adjusted -string. +string. Uses the "OOK hack". void sv_chop(SV* sv, char* ptr) @@ -2739,8 +3076,13 @@ Found in file sv.c =item sv_clear -Clear an SV, making it empty. Does not free the memory used by the SV -itself. +Clear an SV: call any destructors, free up any memory used by the body, +and free the body itself. The SV's head is I<not> freed, although +its type is set to all 1's so that it won't inadvertently be assumed +to be live during global destruction etc. +This function should only be called when REFCNT is zero. Most of the time +you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>) +instead. void sv_clear(SV* sv) @@ -2751,7 +3093,8 @@ Found in file sv.c Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the string in C<sv1> is less than, equal to, or greater than the string in -C<sv2>. +C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will +coerce its args to strings if necessary. See also C<sv_cmp_locale>. I32 sv_cmp(SV* sv1, SV* sv2) @@ -2760,17 +3103,33 @@ Found in file sv.c =item sv_cmp_locale -Compares the strings in two SVs in a locale-aware manner. See -L</sv_cmp_locale> +Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and +'use bytes' aware, handles get magic, and will coerce its args to strings +if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>. I32 sv_cmp_locale(SV* sv1, SV* sv2) =for hackers Found in file sv.c +=item sv_collxfrm + +Add Collate Transform magic to an SV if it doesn't already have it. + +Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the +scalar data of the variable, but transformed to such a format that a normal +memory comparison can be used to compare the data according to the locale +settings. + + char* sv_collxfrm(SV* sv, STRLEN* nxp) + +=for hackers +Found in file sv.c + =item sv_dec -Auto-decrement of the value in the SV. +Auto-decrement of the value in the SV, doing string to numeric conversion +if necessary. Handles 'get' magic. void sv_dec(SV* sv) @@ -2791,16 +3150,43 @@ Found in file universal.c =item sv_eq Returns a boolean indicating whether the strings in the two SVs are -identical. +identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will +coerce its args to strings if necessary. I32 sv_eq(SV* sv1, SV* sv2) =for hackers Found in file sv.c +=item sv_force_normal + +Undo various types of fakery on an SV: if the PV is a shared string, make +a private copy; if we're a ref, stop refing; if we're a glob, downgrade to +an xpvmg. See also C<sv_force_normal_flags>. + + void sv_force_normal(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_force_normal_flags + +Undo various types of fakery on an SV: if the PV is a shared string, make +a private copy; if we're a ref, stop refing; if we're a glob, downgrade to +an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()> +when unrefing. C<sv_force_normal> calls this function with flags set to 0. + + void sv_force_normal_flags(SV *sv, U32 flags) + +=for hackers +Found in file sv.c + =item sv_free -Free the memory used by an SV. +Decrement an SV's reference count, and if it drops to zero, call +C<sv_clear> to invoke destructors and free up any memory used by +the body; finally, deallocate the SV's head itself. +Normally called via a wrapper macro C<SvREFCNT_dec>. void sv_free(SV* sv) @@ -2828,9 +3214,9 @@ Found in file sv.c =item sv_grow -Expands the character buffer in the SV. This will use C<sv_unref> and will -upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer. -Use C<SvGROW>. +Expands the character buffer in the SV. If necessary, uses C<sv_unref> and +upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. +Use the C<SvGROW> wrapper instead. char* sv_grow(SV* sv, STRLEN newlen) @@ -2839,7 +3225,8 @@ Found in file sv.c =item sv_inc -Auto-increment of the value in the SV. +Auto-increment of the value in the SV, doing string to numeric conversion +if necessary. Handles 'get' magic. void sv_inc(SV* sv) @@ -2878,9 +3265,20 @@ will return false. =for hackers Found in file sv.c +=item sv_iv + +A private implementation of the C<SvIVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + + IV sv_iv(SV* sv) + +=for hackers +Found in file sv.c + =item sv_len -Returns the length of the string in the SV. See also C<SvCUR>. +Returns the length of the string in the SV. Handles magic and type +coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot. STRLEN sv_len(SV* sv) @@ -2890,7 +3288,7 @@ Found in file sv.c =item sv_len_utf8 Returns the number of characters in the string in an SV, counting wide -UTF8 bytes as a single character. +UTF8 bytes as a single character. Handles magic and type coercion. STRLEN sv_len_utf8(SV* sv) @@ -2899,7 +3297,10 @@ Found in file sv.c =item sv_magic -Adds magic to an SV. +Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary, +then adds a new magic item of type C<how> to the head of the magic list. + +C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)> void sv_magic(SV* sv, SV* obj, int how, const char* name, I32 namlen) @@ -2908,8 +3309,9 @@ Found in file sv.c =item sv_mortalcopy -Creates a new SV which is a copy of the original SV. The new SV is marked -as mortal. +Creates a new SV which is a copy of the original SV (using C<sv_setsv>). +The new SV is marked as mortal. It will be destroyed when the current +context ends. See also C<sv_newmortal> and C<sv_2mortal>. SV* sv_mortalcopy(SV* oldsv) @@ -2918,16 +3320,117 @@ Found in file sv.c =item sv_newmortal -Creates a new SV which is mortal. The reference count of the SV is set to 1. +Creates a new null SV which is mortal. The reference count of the SV is +set to 1. It will be destroyed when the current context ends. See +also C<sv_mortalcopy> and C<sv_2mortal>. SV* sv_newmortal() =for hackers Found in file sv.c +=item sv_newref + +Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper +instead. + + SV* sv_newref(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_nv + +A private implementation of the C<SvNVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + + NV sv_nv(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_pos_b2u + +Converts the value pointed to by offsetp from a count of bytes from the +start of the string, to a count of the equivalent number of UTF8 chars. +Handles magic and type coercion. + + void sv_pos_b2u(SV* sv, I32* offsetp) + +=for hackers +Found in file sv.c + +=item sv_pos_u2b + +Converts the value pointed to by offsetp from a count of UTF8 chars from +the start of the string, to a count of the equivalent number of bytes; if +lenp is non-zero, it does the same to lenp, but this time starting from +the offset, rather than from the start of the string. Handles magic and +type coercion. + + void sv_pos_u2b(SV* sv, I32* offsetp, I32* lenp) + +=for hackers +Found in file sv.c + +=item sv_pv + +A private implementation of the C<SvPV_nolen> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + + char* sv_pv(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_pvbyte + +A private implementation of the C<SvPVbyte_nolen> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + + char* sv_pvbyte(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_pvbyten + +A private implementation of the C<SvPVbyte> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + + char* sv_pvbyten(SV *sv, STRLEN *len) + +=for hackers +Found in file sv.c + +=item sv_pvbyten_force + +A private implementation of the C<SvPVbytex_force> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + + char* sv_pvbyten_force(SV* sv, STRLEN* lp) + +=for hackers +Found in file sv.c + +=item sv_pvn + +A private implementation of the C<SvPV> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + + char* sv_pvn(SV *sv, STRLEN *len) + +=for hackers +Found in file sv.c + =item sv_pvn_force Get a sensible string out of the SV somehow. +A private implementation of the C<SvPV_force> macro for compilers which +can't cope with complex macro expressions. Always use the macro instead. char* sv_pvn_force(SV* sv, STRLEN* lp) @@ -2940,16 +3443,41 @@ Get a sensible string out of the SV somehow. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are implemented in terms of this function. +You normally want to use the various wrapper macros instead: see +C<SvPV_force> and C<SvPV_force_nomg> char* sv_pvn_force_flags(SV* sv, STRLEN* lp, I32 flags) =for hackers Found in file sv.c +=item sv_pvutf8 + +A private implementation of the C<SvPVutf8_nolen> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + + char* sv_pvutf8(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_pvutf8n + +A private implementation of the C<SvPVutf8> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + + char* sv_pvutf8n(SV *sv, STRLEN *len) + +=for hackers +Found in file sv.c + =item sv_pvutf8n_force -Get a sensible UTF8-encoded string out of the SV somehow. See -L</sv_pvn_force>. +A private implementation of the C<SvPVutf8_force> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. char* sv_pvutf8n_force(SV* sv, STRLEN* lp) @@ -2977,15 +3505,42 @@ Found in file sv.c =item sv_replace Make the first argument a copy of the second, then delete the original. +The target SV physically takes over ownership of the body of the source SV +and inherits its flags; however, the target keeps any magic it owns, +and any magic in the source is discarded. +Note that this a rather specialist SV copying operation; most of the +time you'll want to use C<sv_setsv> or one of its many macro front-ends. void sv_replace(SV* sv, SV* nsv) =for hackers Found in file sv.c +=item sv_report_used + +Dump the contents of all SVs not yet freed. (Debugging aid). + + void sv_report_used() + +=for hackers +Found in file sv.c + +=item sv_reset + +Underlying implementation for the C<reset> Perl function. +Note that the perl-level function is vaguely deprecated. + + void sv_reset(char* s, HV* stash) + +=for hackers +Found in file sv.c + =item sv_rvweaken -Weaken a reference. +Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the +referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and +push a back-reference to this RV onto the array of backreferences +associated with that magic. SV* sv_rvweaken(SV *sv) @@ -2994,8 +3549,8 @@ Found in file sv.c =item sv_setiv -Copies an integer into the given SV. Does not handle 'set' magic. See -C<sv_setiv_mg>. +Copies an integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setiv_mg>. void sv_setiv(SV* sv, IV num) @@ -3013,8 +3568,8 @@ Found in file sv.c =item sv_setnv -Copies a double into the given SV. Does not handle 'set' magic. See -C<sv_setnv_mg>. +Copies a double into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setnv_mg>. void sv_setnv(SV* sv, NV num) @@ -3182,10 +3737,16 @@ Found in file sv.c =item sv_setsv -Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. -The source SV may be destroyed if it is mortal. Does not handle 'set' -magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and -C<sv_setsv_mg>. +Copies the contents of the source SV C<ssv> into the destination SV +C<dsv>. The source SV may be destroyed if it is mortal, so don't use this +function if the source SV needs to be reused. Does not handle 'set' magic. +Loosely speaking, it performs a copy-by-value, obliterating any previous +content of the destination. + +You probably want to use one of the assortment of wrappers, such as +C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and +C<SvSetMagicSV_nosteal>. + void sv_setsv(SV* dsv, SV* ssv) @@ -3194,11 +3755,21 @@ Found in file sv.c =item sv_setsv_flags -Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. -The source SV may be destroyed if it is mortal. Does not handle 'set' -magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if -appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented -in terms of this function. +Copies the contents of the source SV C<ssv> into the destination SV +C<dsv>. The source SV may be destroyed if it is mortal, so don't use this +function if the source SV needs to be reused. Does not handle 'set' magic. +Loosely speaking, it performs a copy-by-value, obliterating any previous +content of the destination. +If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on +C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are +implemented in terms of this function. + +You probably want to use one of the assortment of wrappers, such as +C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and +C<SvSetMagicSV_nosteal>. + +This is the primary function for copying scalars, and most other +copy-ish functions and macros use this underneath. void sv_setsv_flags(SV* dsv, SV* ssv, I32 flags) @@ -3216,8 +3787,8 @@ Found in file sv.c =item sv_setuv -Copies an unsigned integer into the given SV. Does not handle 'set' magic. -See C<sv_setuv_mg>. +Copies an unsigned integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setuv_mg>. void sv_setuv(SV* sv, UV num) @@ -3233,9 +3804,27 @@ Like C<sv_setuv>, but also handles 'set' magic. =for hackers Found in file sv.c +=item sv_taint + +Taint an SV. Use C<SvTAINTED_on> instead. + void sv_taint(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_tainted + +Test an SV for taintedness. Use C<SvTAINTED> instead. + bool sv_tainted(SV* sv) + +=for hackers +Found in file sv.c + =item sv_true Returns true if the SV has a true value by Perl's rules. +Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may +instead use an in-line version. I32 sv_true(SV *sv) @@ -3244,7 +3833,7 @@ Found in file sv.c =item sv_unmagic -Removes magic from an SV. +Removes all magic of type C<type> from an SV. int sv_unmagic(SV* sv, int type) @@ -3278,10 +3867,19 @@ See C<SvROK_off>. =for hackers Found in file sv.c +=item sv_untaint + +Untaint an SV. Use C<SvTAINTED_off> instead. + void sv_untaint(SV* sv) + +=for hackers +Found in file sv.c + =item sv_upgrade -Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See -C<svtype>. +Upgrade an SV to a more complex form. Gnenerally adds a new body type to the +SV, then copies across as much information as possible from the old body. +You genrally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>. bool sv_upgrade(SV* sv, U32 mt) @@ -3315,7 +3913,7 @@ Found in file sv.c =item sv_utf8_decode Convert the octets in the PV from UTF-8 to chars. Scan for validity and then -turn of SvUTF8 if needed so that we see characters. Used as a building block +turn off SvUTF8 if needed so that we see characters. Used as a building block for decode_utf8 in Encode.xs NOTE: this function is experimental and may change or be @@ -3355,7 +3953,7 @@ Found in file sv.c =item sv_utf8_upgrade Convert the PV of an SV to its UTF8-encoded form. -Forces the SV to string form it it is not already. +Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. @@ -3367,7 +3965,7 @@ Found in file sv.c =item sv_utf8_upgrade_flags Convert the PV of an SV to its UTF8-encoded form. -Forces the SV to string form it it is not already. +Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and @@ -3378,6 +3976,16 @@ C<sv_utf8_upgrade_nomg> are implemented in terms of this function. =for hackers Found in file sv.c +=item sv_uv + +A private implementation of the C<SvUVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + + UV sv_uv(SV* sv) + +=for hackers +Found in file sv.c + =item sv_vcatpvfn Processes its arguments like C<vsprintf> and appends the formatted output @@ -3386,6 +3994,8 @@ missing (NULL). When running with taint checks enabled, indicates via C<maybe_tainted> if results are untrustworthy (often due to the use of locales). +Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>. + void sv_vcatpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted) =for hackers @@ -3396,6 +4006,8 @@ Found in file sv.c Works like C<vcatpvfn> but copies the text into the SV instead of appending it. +Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>. + void sv_vsetpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted) =for hackers diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 88e412cbec..326bdab503 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -557,6 +557,10 @@ next option: Length to truncate the argument list when the C<frame> option's bit 4 is set. +=item C<windowSize> + +Change the size of code list window (default is 10 lines). + =back The following options affect what happens with C<V>, C<X>, and C<x> diff --git a/pod/perlguts.pod b/pod/perlguts.pod index aa5de9f74f..e4d4a14372 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -825,11 +825,11 @@ The C<sv> argument is a pointer to the SV that is to acquire a new magical feature. If C<sv> is not already magical, Perl uses the C<SvUPGRADE> macro to -set the C<SVt_PVMG> flag for the C<sv>. Perl then continues by adding -it to the beginning of the linked list of magical features. Any prior -entry of the same type of magic is deleted. Note that this can be -overridden, and multiple instances of the same type of magic can be -associated with an SV. +convert C<sv> to type C<SVt_PVMG>. Perl then continues by adding new magic +to the beginning of the linked list of magical features. Any prior entry +of the same type of magic is deleted. Note that this can be overridden, +and multiple instances of the same type of magic can be associated with an +SV. The C<name> and C<namlen> arguments are used to associate a string with the magic, typically the name of a variable. C<namlen> is stored in the @@ -841,14 +841,14 @@ The sv_magic function uses C<how> to determine which, if any, predefined See the "Magic Virtual Table" section below. The C<how> argument is also stored in the C<mg_type> field. The value of C<how> should be chosen from the set of macros C<PERL_MAGIC_foo> found perl.h. Note that before -these macros were added, perl internals used to directly use character +these macros were added, Perl internals used to directly use character literals, so you may occasionally come across old code or documentation referrring to 'U' magic rather than C<PERL_MAGIC_uvar> for example. The C<obj> argument is stored in the C<mg_obj> field of the C<MAGIC> structure. If it is not the same as the C<sv> argument, the reference count of the C<obj> object is incremented. If it is the same, or if -the C<how> argument is C<PERL_MAGIC_arylen>", or if it is a NULL pointer, +the C<how> argument is C<PERL_MAGIC_arylen>, or if it is a NULL pointer, then C<obj> is merely stored, without the reference count being incremented. There is also a function to add magic to an C<HV>: @@ -928,7 +928,7 @@ The current kinds of Magic Virtual Tables are: L PERL_MAGIC_dbfile (none) Debugger %_<filename l PERL_MAGIC_dbline vtbl_dbline Debugger %_<filename element m PERL_MAGIC_mutex vtbl_mutex ??? - o PERL_MAGIC_collxfrm vtbl_collxfrm Locale transformation + o PERL_MAGIC_collxfrm vtbl_collxfrm Locale collate transformation P PERL_MAGIC_tied vtbl_pack Tied array or hash p PERL_MAGIC_tiedelem vtbl_packelem Tied array or hash element q PERL_MAGIC_tiedscalar vtbl_packelem Tied scalar or handle diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 6b67e5706b..64c69ad96e 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -1387,6 +1387,9 @@ the C<pack> happens at runtime, so it's going to be in one of the F<pp> files. Sure enough, C<pp_pack> is in F<pp.c>. Since we're going to be altering this file, let's copy it to F<pp.c~>. +[Well, it was in F<pp.c> when this tutorial was written. It has now been +split off with C<pp_unpack> to its own file, F<pp_pack.c>] + Now let's look over C<pp_pack>: we take a pattern into C<pat>, and then loop over the pattern, taking each format character in turn into C<datum_type>. Then for each possible format character, we swallow up diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 8bfe5a3cd3..a0cf47c049 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -118,6 +118,15 @@ The input record separator - C<$/> in Perl space. =for hackers Found in file thrdvar.h +=item report_uninit + +Print appropriate "Use of uninitialized variable" warning + + void report_uninit() + +=for hackers +Found in file sv.c + =item start_glob Function called by C<do_readline> to spawn a glob (or do the glob inside @@ -130,6 +139,46 @@ Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. =for hackers Found in file doio.c +=item sv_add_arena + +Given a chunk of memory, link it to the head of the list of arenas, +and split it into a list of free SVs. + + void sv_add_arena(char* ptr, U32 size, U32 flags) + +=for hackers +Found in file sv.c + +=item sv_clean_all + +Decrement the refcnt of each remaining SV, possibly triggering a +cleanup. This function may have to be called multiple times to free +SVs which are in complex self-referential heirarchies. + + I32 sv_clean_all() + +=for hackers +Found in file sv.c + +=item sv_clean_objs + +Attempt to destroy all objects not yet freed + + void sv_clean_objs() + +=for hackers +Found in file sv.c + +=item sv_free_arenas + +Deallocate the memory used by all arenas. Note that all the individual SV +heads and bodies within the arenas must already have been freed. + + void sv_free_arenas() + +=for hackers +Found in file sv.c + =back =head1 AUTHORS diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 01056f1d98..29ad67cb12 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -443,6 +443,23 @@ the module. It is the responsibility of the F<.pm> file to load although the POSIX module happens to do both dynamic loading and autoloading, the user can say just C<use POSIX> to get it all. +=head2 Making your module threadsafe + +Perl has since 5.6.0 support for a new type of threads called +interpreter threads. These threads can be used explicitly and implicitly. + +Ithreads work by cloning the data tree so that no data is shared +between different threads. These threads can be used using the threads +module or by doing fork() on win32 (fake fork() support). When a thread is +cloned all perl data is cloned, however non perl data cannot be cloned. +Perl after 5.7.2 has support for the C<CLONE> keyword. C<CLONE> will be +executed once for every package that has it defined (or inherits it). +It will be called in the context of the new thread, so all modifications +are made in the new area. + +If you want to CLONE all objects you will need to keep track of them per +package. This is simply done using a hash and Scalar::Util::weaken(). + =head1 SEE ALSO See L<perlmodlib> for general style issues related to building Perl diff --git a/pod/perlsub.pod b/pod/perlsub.pod index b440cd1d93..ea7546e95c 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -207,8 +207,8 @@ core, as are modules whose names are in all lower case. A function in all capitals is a loosely-held convention meaning it will be called indirectly by the run-time system itself, usually due to a triggered event. Functions that do special, pre-defined -things include C<BEGIN>, C<CHECK>, C<INIT>, C<END>, C<AUTOLOAD>, and -C<DESTROY>--plus all functions mentioned in L<perltie>. +things include C<BEGIN>, C<CHECK>, C<INIT>, C<END>, C<AUTOLOAD>, +C<CLONE> and C<DESTROY>--plus all functions mentioned in L<perltie>. =head2 Private Variables via my() diff --git a/pod/perltoc.pod b/pod/perltoc.pod index c355166748..1094d8c92d 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -839,10 +839,10 @@ cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, command, m expr, man [manpage] C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>, C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>, -C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>, -C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>, -C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, C<undefPrint>, -C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop> +C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<windowSize>, +C<arrayDepth>, C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, +C<DumpDBFiles>, C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, +C<undefPrint>, C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop> =item Debugger input/output @@ -2170,6 +2170,8 @@ chcp, dataset access, OS/390, z/OS iconv, locales =item Perl Modules +=item Making your module threadsafe + =back =item SEE ALSO @@ -2205,30 +2207,34 @@ Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, Digest, DirHandle, Dumpvalue, Encode, Encode::EncodeFormat, Encode::Tcl, English, Env, Exporter, Exporter::Heavy, ExtUtils::Command, ExtUtils::Constant, ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed, ExtUtils::Liblist, -ExtUtils::MM_Cygwin, ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, -ExtUtils::MM_Win32, ExtUtils::MakeMaker, ExtUtils::Manifest, -ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::Packlist, -ExtUtils::testlib, Fatal, Fcntl, File::Basename, File::CheckTree, -File::Compare, File::Copy, File::DosGlob, File::Find, File::Path, -File::Spec, File::Spec::Epoc, File::Spec::Functions, File::Spec::Mac, -File::Spec::OS2, File::Spec::Unix, File::Spec::VMS, File::Spec::Win32, -File::Temp, File::stat, FileCache, FileHandle, Filter::Simple, FindBin, -Getopt::Long, Getopt::Std, I18N::Collate, I18N::LangTags, -I18N::LangTags::List, IO, IPC::Open2, IPC::Open3, Locale::Constants, -Locale::Country, Locale::Currency, Locale::Language, Locale::Maketext, -Locale::Maketext::TPJ13, Math::BigFloat, Math::BigInt, Math::Complex, -Math::Trig, NDBM_File, NEXT, Net::Ping, Net::hostent, Net::netent, -Net::protoent, Net::servent, O, ODBM_File, Opcode, POSIX, PerlIO, -Pod::Checker, Pod::Find, Pod::Html, Pod::InputObjects, Pod::LaTeX, -Pod::Man, Pod::ParseUtils, Pod::Parser, Pod::Plainer, Pod::Select, -Pod::Text, Pod::Text::Color, Pod::Text::Overstrike, Pod::Text::Termcap, -Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell, -Socket, Storable, Switch, Symbol, Term::ANSIColor, Term::Cap, -Term::Complete, Term::ReadLine, Test, Test::Harness, Text::Abbrev, -Text::Balanced, Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, -Tie::Array, Tie::Handle, Tie::Hash, Tie::RefHash, Tie::Scalar, -Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, Time::tm, -UNIVERSAL, User::grent, User::pwent, Win32 +ExtUtils::MM_Cygwin, ExtUtils::MM_NW5, ExtUtils::MM_OS2, ExtUtils::MM_Unix, +ExtUtils::MM_VMS, ExtUtils::MM_Win32, ExtUtils::MakeMaker, +ExtUtils::Manifest, ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, +ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl, File::Basename, +File::CheckTree, File::Compare, File::Copy, File::DosGlob, File::Find, +File::Path, File::Spec, File::Spec::Epoc, File::Spec::Functions, +File::Spec::Mac, File::Spec::OS2, File::Spec::Unix, File::Spec::VMS, +File::Spec::Win32, File::Temp, File::stat, FileCache, FileHandle, +Filter::Simple, FindBin, Getopt::Long, Getopt::Std, I18N::Collate, +I18N::LangTags, I18N::LangTags::List, IO, IPC::Open2, IPC::Open3, +Locale::Constants, Locale::Country, Locale::Currency, Locale::Language, +Locale::Maketext, Locale::Maketext::TPJ13, Math::BigFloat, Math::BigInt, +Math::Complex, Math::Trig, Memoize, Memoize::AnyDBM_File, Memoize::Expire, +Memoize::ExpireFile, Memoize::ExpireTest, Memoize::NDBM_File, +Memoize::SDBM_File, Memoize::Saves, Memoize::Storable, NDBM_File, NEXT, +Net::Cmd, Net::Config, Net::Domain, Net::DummyInetd, Net::FTP, Net::NNTP, +Net::Netrc, Net::PH, Net::POP3, Net::Ping, Net::SMTP, Net::SNPP, Net::Time, +Net::hostent, Net::libnetFAQ, Net::netent, Net::protoent, Net::servent, O, +ODBM_File, Opcode, POSIX, PerlIO, Pod::Checker, Pod::Find, Pod::Html, +Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils, Pod::Parser, +Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, +Pod::Text::Overstrike, Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, +Search::Dict, SelectSaver, SelfLoader, Shell, Socket, Storable, Switch, +Symbol, Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine, Test, +Test::Harness, Text::Abbrev, Text::Balanced, Text::ParseWords, +Text::Soundex, Text::Tabs, Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash, +Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, +Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent, Win32 =item Extension Modules @@ -3787,15 +3793,19 @@ callback =item DOCUMENTATION -L<libnetcfg|libnetcfg>, L<perldoc|perldoc>, L<pod2man|pod2man> and -L<pod2text|pod2text>, L<pod2html|pod2html> and L<pod2latex|pod2latex>, -L<pod2usage|pod2usage>, L<podselect|podselect>, L<podchecker|podchecker>, -L<splain|splain>, L<roffitall|roffitall> +L<perldoc|perldoc>, L<pod2man|pod2man> and L<pod2text|pod2text>, +L<pod2html|pod2html> and L<pod2latex|pod2latex>, L<pod2usage|pod2usage>, +L<podselect|podselect>, L<podchecker|podchecker>, L<splain|splain>, +L<roffitall|roffitall> =item CONVERTORS L<a2p|a2p>, L<s2p|s2p>, L<find2perl|find2perl> +=item Administration + +L<libnetcfg|libnetcfg> + =item Development L<perlbug|perlbug>, L<h2ph|h2ph>, L<c2ph|c2ph> and L<pstruct|pstruct>, @@ -3888,44 +3898,53 @@ hv_iterval, hv_magic, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, is_utf8_char, is_utf8_string, items, ix, LEAVE, load_module, looks_like_number, MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_length, mg_magical, mg_set, Move, New, newAV, -Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv, -newSVpv, newSVpvf, newSVpvn, newSVpvn_share, newSVrv, newSVsv, newSVuv, -newXS, newXSproto, Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK, -perl_alloc, perl_construct, perl_destruct, perl_free, perl_parse, perl_run, -PL_modglobal, PL_na, PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn, -POPp, POPpbytex, POPpx, POPs, PUSHi, PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu, -PUTBACK, Renew, Renewc, require_pv, RETVAL, Safefree, savepv, savepvn, -SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, strLE, strLT, strNE, -strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set, SvEND, SvGETMAGIC, SvGROW, -SvIOK, SvIOKp, SvIOK_notUV, SvIOK_off, SvIOK_on, SvIOK_only, SvIOK_only_UV, -SvIOK_UV, SvIV, SvIVX, SvLEN, SvNIOK, SvNIOKp, SvNIOK_off, SvNOK, SvNOKp, -SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, SvOK, SvOOK, SvPOK, SvPOKp, -SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only_UTF8, SvPV, SvPVX, SvPV_force, +Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc, newSV, NEWSV, newSViv, +newSVnv, newSVpv, newSVpvf, newSVpvn, newSVpvn_share, newSVrv, newSVsv, +newSVuv, newXS, newXSproto, Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, +ORIGMARK, perl_alloc, perl_clone, perl_construct, perl_destruct, perl_free, +perl_parse, perl_run, PL_modglobal, PL_na, PL_sv_no, PL_sv_undef, +PL_sv_yes, POPi, POPl, POPn, POPp, POPpbytex, POPpx, POPs, PUSHi, PUSHMARK, +PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc, require_pv, RETVAL, +Safefree, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, +strLE, strLT, strNE, strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set, SvEND, +SvGETMAGIC, SvGROW, SvIOK, SvIOKp, SvIOK_notUV, SvIOK_off, SvIOK_on, +SvIOK_only, SvIOK_only_UV, SvIOK_UV, SvIV, SvIVx, SvIVX, SvLEN, SvNIOK, +SvNIOKp, SvNIOK_off, SvNOK, SvNOKp, SvNOK_off, SvNOK_on, SvNOK_only, SvNV, +SvNVx, SvNVX, SvOK, SvOOK, SvPOK, SvPOKp, SvPOK_off, SvPOK_on, SvPOK_only, +SvPOK_only_UTF8, SvPV, SvPVbyte, SvPVbytex, SvPVbytex_force, +SvPVbyte_force, SvPVbyte_nolen, SvPVutf8, SvPVutf8x, SvPVutf8x_force, +SvPVutf8_force, SvPVutf8_nolen, SvPVx, SvPVX, SvPV_force, SvPV_force_nomg, SvPV_nolen, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, -SvROK_on, SvRV, SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT, -SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, svtype, SvTYPE, SVt_IV, -SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUOK, SvUPGRADE, -SvUTF8, SvUTF8_off, SvUTF8_on, SvUV, SvUVX, sv_2mortal, sv_bless, sv_catpv, -sv_catpvf, sv_catpvf_mg, sv_catpvn, sv_catpvn_flags, sv_catpvn_mg, -sv_catpv_mg, sv_catsv, sv_catsv_flags, sv_catsv_mg, sv_chop, sv_clear, -sv_cmp, sv_cmp_locale, sv_dec, sv_derived_from, sv_eq, sv_free, sv_getcwd, -sv_gets, sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, sv_len, -sv_len_utf8, sv_magic, sv_mortalcopy, sv_newmortal, sv_pvn_force, -sv_pvn_force_flags, sv_pvutf8n_force, sv_realpath, sv_reftype, sv_replace, -sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv, -sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg, sv_setpvn, +SvROK_on, SvRV, SvSETMAGIC, SvSetMagicSV, SvSetMagicSV_nosteal, SvSetSV, +SvSetSV_nosteal, SvSTASH, SvTAINT, SvTAINTED, SvTAINTED_off, SvTAINTED_on, +SvTRUE, svtype, SvTYPE, SVt_IV, SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, +SVt_PVHV, SVt_PVMG, SvUOK, SvUPGRADE, SvUTF8, SvUTF8_off, SvUTF8_on, SvUV, +SvUVx, SvUVX, sv_2bool, sv_2cv, sv_2io, sv_2iv, sv_2mortal, sv_2nv, +sv_2pvbyte, sv_2pvbyte_nolen, sv_2pvutf8, sv_2pvutf8_nolen, sv_2pv_flags, +sv_2pv_nolen, sv_2uv, sv_backoff, sv_bless, sv_catpv, sv_catpvf, +sv_catpvf_mg, sv_catpvn, sv_catpvn_flags, sv_catpvn_mg, sv_catpv_mg, +sv_catsv, sv_catsv_flags, sv_catsv_mg, sv_chop, sv_clear, sv_cmp, +sv_cmp_locale, sv_collxfrm, sv_dec, sv_derived_from, sv_eq, +sv_force_normal, sv_force_normal_flags, sv_free, sv_getcwd, sv_gets, +sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, sv_iv, sv_len, +sv_len_utf8, sv_magic, sv_mortalcopy, sv_newmortal, sv_newref, sv_nv, +sv_pos_b2u, sv_pos_u2b, sv_pv, sv_pvbyte, sv_pvbyten, sv_pvbyten_force, +sv_pvn, sv_pvn_force, sv_pvn_force_flags, sv_pvutf8, sv_pvutf8n, +sv_pvutf8n_force, sv_realpath, sv_reftype, sv_replace, sv_report_used, +sv_reset, sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, +sv_setpv, sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg, sv_setpvn, sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setref_uv, sv_setsv, sv_setsv_flags, sv_setsv_mg, -sv_setuv, sv_setuv_mg, sv_true, sv_unmagic, sv_unref, sv_unref_flags, -sv_upgrade, sv_usepvn, sv_usepvn_mg, sv_utf8_decode, sv_utf8_downgrade, -sv_utf8_encode, sv_utf8_upgrade, sv_utf8_upgrade_flags, sv_vcatpvfn, -sv_vsetpvfn, THIS, toLOWER, toUPPER, utf8n_to_uvchr, utf8n_to_uvuni, -utf8_distance, utf8_hop, utf8_length, utf8_to_bytes, utf8_to_uvchr, -utf8_to_uvuni, uvchr_to_utf8, uvuni_to_utf8, warn, XPUSHi, XPUSHn, XPUSHp, -XPUSHs, XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, -XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, -XST_mNV, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, -Zero +sv_setuv, sv_setuv_mg, sv_taint, sv_tainted, sv_true, sv_unmagic, sv_unref, +sv_unref_flags, sv_untaint, sv_upgrade, sv_usepvn, sv_usepvn_mg, +sv_utf8_decode, sv_utf8_downgrade, sv_utf8_encode, sv_utf8_upgrade, +sv_utf8_upgrade_flags, sv_uv, sv_vcatpvfn, sv_vsetpvfn, THIS, toLOWER, +toUPPER, utf8n_to_uvchr, utf8n_to_uvuni, utf8_distance, utf8_hop, +utf8_length, utf8_to_bytes, utf8_to_uvchr, utf8_to_uvuni, uvchr_to_utf8, +uvuni_to_utf8, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN, +XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, +XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, XST_mNV, XST_mPV, +XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero =item AUTHORS @@ -3941,7 +3960,8 @@ Zero =item DESCRIPTION djSP, is_gv_magical, LVRET, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn, -PL_last_in_gv, PL_ofs_sv, PL_rs, start_glob +PL_last_in_gv, PL_ofs_sv, PL_rs, report_uninit, start_glob, sv_add_arena, +sv_clean_all, sv_clean_objs, sv_free_arenas =item AUTHORS @@ -4067,6 +4087,8 @@ PerlIO_apply_layers(f,mode,layers), PerlIO_binmode(f,ptype,imode,layers), =item Eliminate need for "use utf8"; +=item Create a char *sv_printify(sv, STRLEN *lenp, UV flags) function + =item Autoload byte.pm =item Make "\u{XXXX}" et al work @@ -4397,6 +4419,8 @@ PerlIO_apply_layers(f,mode,layers), PerlIO_binmode(f,ptype,imode,layers), =item Lazy evaluation / tail recursion removal +=item Make "use utf8" the default + =back =back diff --git a/pod/perltodo.pod b/pod/perltodo.pod index 3882498750..5d280e6936 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -28,6 +28,12 @@ always be set to true, but it needs to be set to false when F<utf8.pm> is being compiled. (To stop Perl trying to autoload the C<utf8> pragma...) +=head2 Create a char *sv_printify(sv, STRLEN *lenp, UV flags) function + +For displaying PVs with control characters, embedded nulls, and Unicode. +This would be useful for printing warnings, or data and regex dumping, +not_a_number(), and so on. + =head2 Autoload byte.pm When the lexer sees, for instance, C<bytes::length>, it should @@ -770,3 +776,13 @@ done manually, with C<goto &whoami;>. (However, MJD has found that C<goto &whoami> introduces a performance penalty, so maybe there should be a way to do this after all: C<sub foo {START: ... goto START;> is better.) + +=head2 Make "use utf8" the default + +There is a patch available for this, search p5p archives for +the Subject "[EXPERIMENTAL PATCH] make unicode (utf8) default" +but this would be unacceptable because of backward compatibility: +scripts could not contain B<any legacy eight-bit data>. Also would +introduce a measurable slowdown of at least few percentages since all +regular expression operations would be done in full UTF-8. + diff --git a/pod/perlutil.pod b/pod/perlutil.pod index 293a1bb1d9..93b9e0b51d 100644 --- a/pod/perlutil.pod +++ b/pod/perlutil.pod @@ -15,11 +15,6 @@ if appropriate. =over 3 -=item L<libnetcfg|libnetcfg> - -Starting from Perl 5.8 the libnet has been part of the standard -distribution. To configure libnet run the libnetcfg command. - =item L<perldoc|perldoc> The main interface to Perl's documentation is C<perldoc>, although @@ -128,6 +123,16 @@ As well as these filters for converting other languages, the L<pl2pm|pl2pm> utility will help you convert old-style Perl 4 libraries to new-style Perl5 modules. +=head2 Administration + +=over 3 + +=item L<libnetcfg|libnetcfg> + +To display and change the libnet configuration run the libnetcfg command. + +=back + =head2 Development There are a set of utilities which help you in developing Perl programs, diff --git a/pod/perlvar.pod b/pod/perlvar.pod index b72f3571bd..eae87c791c 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -611,10 +611,10 @@ Also see L<Error Indicators>. =item $@ -The Perl syntax error message from the last eval() operator. If null, the -last eval() parsed and executed correctly (although the operations you -invoked may have failed in the normal fashion). (Mnemonic: Where was -the syntax error "at"?) +The Perl syntax error message from the last eval() operator. +If $@ is the null string, the last eval() parsed and executed +correctly (although the operations you invoked may have failed in the +normal fashion). (Mnemonic: Where was the syntax error "at"?) Warning messages are not collected in this variable. You can, however, set up a routine to process warnings by setting C<$SIG{__WARN__}> @@ -16,70 +16,6 @@ #define PERL_IN_PP_C #include "perl.h" -/* - * The compiler on Concurrent CX/UX systems has a subtle bug which only - * seems to show up when compiling pp.c - it generates the wrong double - * precision constant value for (double)UV_MAX when used inline in the body - * of the code below, so this makes a static variable up front (which the - * compiler seems to get correct) and uses it in place of UV_MAX below. - */ -#ifdef CXUX_BROKEN_CONSTANT_CONVERT -static double UV_MAX_cxux = ((double)UV_MAX); -#endif - -/* - * Offset for integer pack/unpack. - * - * On architectures where I16 and I32 aren't really 16 and 32 bits, - * which for now are all Crays, pack and unpack have to play games. - */ - -/* - * These values are required for portability of pack() output. - * If they're not right on your machine, then pack() and unpack() - * wouldn't work right anyway; you'll need to apply the Cray hack. - * (I'd like to check them with #if, but you can't use sizeof() in - * the preprocessor.) --??? - */ -/* - The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE - defines are now in config.h. --Andy Dougherty April 1998 - */ -#define SIZE16 2 -#define SIZE32 4 - -/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). - --jhi Feb 1999 */ - -#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 -# define PERL_NATINT_PACK -#endif - -#if LONGSIZE > 4 && defined(_CRAY) -# if BYTEORDER == 0x12345678 -# define OFF16(p) (char*)(p) -# define OFF32(p) (char*)(p) -# else -# if BYTEORDER == 0x87654321 -# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) -# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) -# else - }}}} bad cray byte order -# endif -# endif -# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) -# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) -# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) -# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) -# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) -#else -# define COPY16(s,p) Copy(s, p, SIZE16, char) -# define COPY32(s,p) Copy(s, p, SIZE32, char) -# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) -# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) -# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) -#endif - /* variations on pp_null */ /* XXX I can't imagine anyone who doesn't have this actually _needs_ @@ -4071,1755 +4007,6 @@ PP(pp_reverse) RETURN; } -STATIC SV * -S_mul128(pTHX_ SV *sv, U8 m) -{ - STRLEN len; - char *s = SvPV(sv, len); - char *t; - U32 i = 0; - - if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *tmpNew = newSVpvn("0000000000", 10); - - sv_catsv(tmpNew, sv); - SvREFCNT_dec(sv); /* free old sv */ - sv = tmpNew; - s = SvPV(sv, len); - } - t = s + len - 1; - while (!*t) /* trailing '\0'? */ - t--; - while (t > s) { - i = ((*t - '0') << 7) + m; - *(t--) = '0' + (i % 10); - m = i / 10; - } - return (sv); -} - -/* Explosives and implosives. */ - -#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(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') -#endif - - -PP(pp_unpack) -{ - dSP; - dPOPPOPssrl; - I32 start_sp_offset = SP - PL_stack_base; - I32 gimme = GIMME_V; - SV *sv; - STRLEN llen; - STRLEN rlen; - register char *pat = SvPV(left, llen); -#ifdef PACKED_IS_OCTETS - /* Packed side is assumed to be octets - so force downgrade if it - has been UTF-8 encoded by accident - */ - register char *s = SvPVbyte(right, rlen); -#else - register char *s = SvPV(right, rlen); -#endif - char *strend = s + rlen; - char *strbeg = s; - register char *patend = pat + llen; - I32 datumtype; - register I32 len; - register I32 bits = 0; - register char *str; - - /* These must not be in registers: */ - short ashort; - int aint; - long along; -#ifdef HAS_QUAD - Quad_t aquad; -#endif - U16 aushort; - unsigned int auint; - U32 aulong; -#ifdef HAS_QUAD - Uquad_t auquad; -#endif - char *aptr; - float afloat; - double adouble; - I32 checksum = 0; - register U32 culong = 0; - NV cdouble = 0.0; - int commas = 0; - int star; -#ifdef PERL_NATINT_PACK - int natint; /* native integer */ - int unatint; /* unsigned native integer */ -#endif - - if (gimme != G_ARRAY) { /* arrange to do first one only */ - /*SUPPRESS 530*/ - for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; - if (strchr("aAZbBhHP", *patend) || *pat == '%') { - patend++; - while (isDIGIT(*patend) || *patend == '*') - patend++; - } - else - patend++; - } - while (pat < patend) { - reparse: - datumtype = *pat++ & 0xFF; -#ifdef PERL_NATINT_PACK - natint = 0; -#endif - if (isSPACE(datumtype)) - continue; - if (datumtype == '#') { - while (pat < patend && *pat != '\n') - pat++; - continue; - } - if (*pat == '!') { - char *natstr = "sSiIlL"; - - if (strchr(natstr, datumtype)) { -#ifdef PERL_NATINT_PACK - natint = 1; -#endif - pat++; - } - else - DIE(aTHX_ "'!' allowed only after types %s", natstr); - } - star = 0; - if (pat >= patend) - len = 1; - else if (*pat == '*') { - len = strend - strbeg; /* long enough */ - pat++; - star = 1; - } - else if (isDIGIT(*pat)) { - len = *pat++ - '0'; - while (isDIGIT(*pat)) { - len = (len * 10) + (*pat++ - '0'); - if (len < 0) - DIE(aTHX_ "Repeat count in unpack overflows"); - } - } - else - len = (datumtype != '@'); - redo_switch: - switch(datumtype) { - default: - DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); - case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && ckWARN(WARN_UNPACK)) - Perl_warner(aTHX_ WARN_UNPACK, - "Invalid type in unpack: '%c'", (int)datumtype); - break; - case '%': - if (len == 1 && pat[-1] != '1') - len = 16; - checksum = len; - culong = 0; - cdouble = 0; - if (pat < patend) - goto reparse; - break; - case '@': - if (len > strend - strbeg) - DIE(aTHX_ "@ outside of string"); - s = strbeg + len; - break; - case 'X': - if (len > s - strbeg) - DIE(aTHX_ "X outside of string"); - s -= len; - break; - case 'x': - if (len > strend - s) - DIE(aTHX_ "x outside of string"); - s += len; - break; - case '/': - if (start_sp_offset >= SP - PL_stack_base) - DIE(aTHX_ "/ must follow a numeric type"); - datumtype = *pat++; - if (*pat == '*') - pat++; /* ignore '*' for compatibility with pack */ - if (isDIGIT(*pat)) - DIE(aTHX_ "/ cannot take a count" ); - len = POPi; - star = 0; - goto redo_switch; - case 'A': - case 'Z': - case 'a': - if (len > strend - s) - len = strend - s; - if (checksum) - goto uchar_checksum; - sv = NEWSV(35, len); - sv_setpvn(sv, s, len); - s += len; - if (datumtype == 'A' || datumtype == 'Z') { - aptr = s; /* borrow register */ - if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ - s = SvPVX(sv); - while (*s) - s++; - } - else { /* 'A' strips both nulls and spaces */ - s = SvPVX(sv) + len - 1; - while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) - s--; - *++s = '\0'; - } - SvCUR_set(sv, s - SvPVX(sv)); - s = aptr; /* unborrow register */ - } - XPUSHs(sv_2mortal(sv)); - break; - case 'B': - case 'b': - if (star || len > (strend - s) * 8) - len = (strend - s) * 8; - if (checksum) { - if (!PL_bitcount) { - Newz(601, PL_bitcount, 256, char); - for (bits = 1; bits < 256; bits++) { - if (bits & 1) PL_bitcount[bits]++; - if (bits & 2) PL_bitcount[bits]++; - if (bits & 4) PL_bitcount[bits]++; - if (bits & 8) PL_bitcount[bits]++; - if (bits & 16) PL_bitcount[bits]++; - if (bits & 32) PL_bitcount[bits]++; - if (bits & 64) PL_bitcount[bits]++; - if (bits & 128) PL_bitcount[bits]++; - } - } - while (len >= 8) { - culong += PL_bitcount[*(unsigned char*)s++]; - len -= 8; - } - if (len) { - bits = *s; - if (datumtype == 'b') { - while (len-- > 0) { - if (bits & 1) culong++; - bits >>= 1; - } - } - else { - while (len-- > 0) { - if (bits & 128) culong++; - bits <<= 1; - } - } - } - break; - } - sv = NEWSV(35, len + 1); - SvCUR_set(sv, len); - SvPOK_on(sv); - str = SvPVX(sv); - if (datumtype == 'b') { - aint = len; - for (len = 0; len < aint; len++) { - if (len & 7) /*SUPPRESS 595*/ - bits >>= 1; - else - bits = *s++; - *str++ = '0' + (bits & 1); - } - } - else { - aint = len; - for (len = 0; len < aint; len++) { - if (len & 7) - bits <<= 1; - else - bits = *s++; - *str++ = '0' + ((bits & 128) != 0); - } - } - *str = '\0'; - XPUSHs(sv_2mortal(sv)); - break; - case 'H': - case 'h': - if (star || len > (strend - s) * 2) - len = (strend - s) * 2; - sv = NEWSV(35, len + 1); - SvCUR_set(sv, len); - SvPOK_on(sv); - str = SvPVX(sv); - if (datumtype == 'h') { - aint = len; - for (len = 0; len < aint; len++) { - if (len & 1) - bits >>= 4; - else - bits = *s++; - *str++ = PL_hexdigit[bits & 15]; - } - } - else { - aint = len; - for (len = 0; len < aint; len++) { - if (len & 1) - bits <<= 4; - else - bits = *s++; - *str++ = PL_hexdigit[(bits >> 4) & 15]; - } - } - *str = '\0'; - XPUSHs(sv_2mortal(sv)); - break; - case 'c': - if (len > strend - s) - len = strend - s; - if (checksum) { - while (len-- > 0) { - aint = *s++; - if (aint >= 128) /* fake up signed chars */ - aint -= 256; - culong += aint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - aint = *s++; - if (aint >= 128) /* fake up signed chars */ - aint -= 256; - sv = NEWSV(36, 0); - sv_setiv(sv, (IV)aint); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 'C': - if (len > strend - s) - len = strend - s; - if (checksum) { - uchar_checksum: - while (len-- > 0) { - auint = *s++ & 255; - culong += auint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - auint = *s++ & 255; - sv = NEWSV(37, 0); - sv_setiv(sv, (IV)auint); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 'U': - if (len > strend - s) - len = strend - s; - if (checksum) { - while (len-- > 0 && s < strend) { - STRLEN alen; - auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); - along = alen; - s += along; - if (checksum > 32) - cdouble += (NV)auint; - else - culong += auint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0 && s < strend) { - STRLEN alen; - auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); - along = alen; - s += along; - sv = NEWSV(37, 0); - sv_setuv(sv, (UV)auint); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 's': -#if SHORTSIZE == SIZE16 - along = (strend - s) / SIZE16; -#else - along = (strend - s) / (natint ? sizeof(short) : SIZE16); -#endif - if (len > along) - len = along; - if (checksum) { -#if SHORTSIZE != SIZE16 - if (natint) { - short ashort; - while (len-- > 0) { - COPYNN(s, &ashort, sizeof(short)); - s += sizeof(short); - culong += ashort; - - } - } - else -#endif - { - while (len-- > 0) { - COPY16(s, &ashort); -#if SHORTSIZE > SIZE16 - if (ashort > 32767) - ashort -= 65536; -#endif - s += SIZE16; - culong += ashort; - } - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); -#if SHORTSIZE != SIZE16 - if (natint) { - short ashort; - while (len-- > 0) { - COPYNN(s, &ashort, sizeof(short)); - s += sizeof(short); - sv = NEWSV(38, 0); - sv_setiv(sv, (IV)ashort); - PUSHs(sv_2mortal(sv)); - } - } - else -#endif - { - while (len-- > 0) { - COPY16(s, &ashort); -#if SHORTSIZE > SIZE16 - if (ashort > 32767) - ashort -= 65536; -#endif - s += SIZE16; - sv = NEWSV(38, 0); - sv_setiv(sv, (IV)ashort); - PUSHs(sv_2mortal(sv)); - } - } - } - break; - case 'v': - case 'n': - case 'S': -#if SHORTSIZE == SIZE16 - along = (strend - s) / SIZE16; -#else - unatint = natint && datumtype == 'S'; - along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); -#endif - if (len > along) - len = along; - if (checksum) { -#if SHORTSIZE != SIZE16 - if (unatint) { - unsigned short aushort; - while (len-- > 0) { - COPYNN(s, &aushort, sizeof(unsigned short)); - s += sizeof(unsigned short); - culong += aushort; - } - } - else -#endif - { - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; -#ifdef HAS_NTOHS - if (datumtype == 'n') - aushort = PerlSock_ntohs(aushort); -#endif -#ifdef HAS_VTOHS - if (datumtype == 'v') - aushort = vtohs(aushort); -#endif - culong += aushort; - } - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); -#if SHORTSIZE != SIZE16 - if (unatint) { - unsigned short aushort; - while (len-- > 0) { - COPYNN(s, &aushort, sizeof(unsigned short)); - s += sizeof(unsigned short); - sv = NEWSV(39, 0); - sv_setiv(sv, (UV)aushort); - PUSHs(sv_2mortal(sv)); - } - } - else -#endif - { - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; - sv = NEWSV(39, 0); -#ifdef HAS_NTOHS - if (datumtype == 'n') - aushort = PerlSock_ntohs(aushort); -#endif -#ifdef HAS_VTOHS - if (datumtype == 'v') - aushort = vtohs(aushort); -#endif - sv_setiv(sv, (UV)aushort); - PUSHs(sv_2mortal(sv)); - } - } - } - break; - case 'i': - along = (strend - s) / sizeof(int); - if (len > along) - len = along; - if (checksum) { - while (len-- > 0) { - Copy(s, &aint, 1, int); - s += sizeof(int); - if (checksum > 32) - cdouble += (NV)aint; - else - culong += aint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - Copy(s, &aint, 1, int); - s += sizeof(int); - sv = NEWSV(40, 0); -#ifdef __osf__ - /* Without the dummy below unpack("i", pack("i",-1)) - * return 0xFFffFFff instead of -1 for Digital Unix V4.0 - * cc with optimization turned on. - * - * The bug was detected in - * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) - * with optimization (-O4) turned on. - * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) - * does not have this problem even with -O4. - * - * This bug was reported as DECC_BUGS 1431 - * and tracked internally as GEM_BUGS 7775. - * - * The bug is fixed in - * Tru64 UNIX V5.0: Compaq C V6.1-006 or later - * UNIX V4.0F support: DEC C V5.9-006 or later - * UNIX V4.0E support: DEC C V5.8-011 or later - * and also in DTK. - * - * See also few lines later for the same bug. - */ - (aint) ? - sv_setiv(sv, (IV)aint) : -#endif - sv_setiv(sv, (IV)aint); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 'I': - along = (strend - s) / sizeof(unsigned int); - if (len > along) - len = along; - if (checksum) { - while (len-- > 0) { - Copy(s, &auint, 1, unsigned int); - s += sizeof(unsigned int); - if (checksum > 32) - cdouble += (NV)auint; - else - culong += auint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - Copy(s, &auint, 1, unsigned int); - s += sizeof(unsigned int); - sv = NEWSV(41, 0); -#ifdef __osf__ - /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) - * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. - * See details few lines earlier. */ - (auint) ? - sv_setuv(sv, (UV)auint) : -#endif - sv_setuv(sv, (UV)auint); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 'l': -#if LONGSIZE == SIZE32 - along = (strend - s) / SIZE32; -#else - along = (strend - s) / (natint ? sizeof(long) : SIZE32); -#endif - if (len > along) - len = along; - if (checksum) { -#if LONGSIZE != SIZE32 - if (natint) { - while (len-- > 0) { - COPYNN(s, &along, sizeof(long)); - s += sizeof(long); - if (checksum > 32) - cdouble += (NV)along; - else - culong += along; - } - } - else -#endif - { - while (len-- > 0) { -#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 - I32 along; -#endif - COPY32(s, &along); -#if LONGSIZE > SIZE32 - if (along > 2147483647) - along -= 4294967296; -#endif - s += SIZE32; - if (checksum > 32) - cdouble += (NV)along; - else - culong += along; - } - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); -#if LONGSIZE != SIZE32 - if (natint) { - while (len-- > 0) { - COPYNN(s, &along, sizeof(long)); - s += sizeof(long); - sv = NEWSV(42, 0); - sv_setiv(sv, (IV)along); - PUSHs(sv_2mortal(sv)); - } - } - else -#endif - { - while (len-- > 0) { -#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 - I32 along; -#endif - COPY32(s, &along); -#if LONGSIZE > SIZE32 - if (along > 2147483647) - along -= 4294967296; -#endif - s += SIZE32; - sv = NEWSV(42, 0); - sv_setiv(sv, (IV)along); - PUSHs(sv_2mortal(sv)); - } - } - } - break; - case 'V': - case 'N': - case 'L': -#if LONGSIZE == SIZE32 - along = (strend - s) / SIZE32; -#else - unatint = natint && datumtype == 'L'; - along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); -#endif - if (len > along) - len = along; - if (checksum) { -#if LONGSIZE != SIZE32 - if (unatint) { - unsigned long aulong; - while (len-- > 0) { - COPYNN(s, &aulong, sizeof(unsigned long)); - s += sizeof(unsigned long); - if (checksum > 32) - cdouble += (NV)aulong; - else - culong += aulong; - } - } - else -#endif - { - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; -#ifdef HAS_NTOHL - if (datumtype == 'N') - aulong = PerlSock_ntohl(aulong); -#endif -#ifdef HAS_VTOHL - if (datumtype == 'V') - aulong = vtohl(aulong); -#endif - if (checksum > 32) - cdouble += (NV)aulong; - else - culong += aulong; - } - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); -#if LONGSIZE != SIZE32 - if (unatint) { - unsigned long aulong; - while (len-- > 0) { - COPYNN(s, &aulong, sizeof(unsigned long)); - s += sizeof(unsigned long); - sv = NEWSV(43, 0); - sv_setuv(sv, (UV)aulong); - PUSHs(sv_2mortal(sv)); - } - } - else -#endif - { - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; -#ifdef HAS_NTOHL - if (datumtype == 'N') - aulong = PerlSock_ntohl(aulong); -#endif -#ifdef HAS_VTOHL - if (datumtype == 'V') - aulong = vtohl(aulong); -#endif - sv = NEWSV(43, 0); - sv_setuv(sv, (UV)aulong); - PUSHs(sv_2mortal(sv)); - } - } - } - break; - case 'p': - along = (strend - s) / sizeof(char*); - if (len > along) - len = along; - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - if (sizeof(char*) > strend - s) - break; - else { - Copy(s, &aptr, 1, char*); - s += sizeof(char*); - } - sv = NEWSV(44, 0); - if (aptr) - sv_setpv(sv, aptr); - PUSHs(sv_2mortal(sv)); - } - break; - case 'w': - EXTEND(SP, len); - EXTEND_MORTAL(len); - { - UV auv = 0; - U32 bytes = 0; - - while ((len > 0) && (s < strend)) { - auv = (auv << 7) | (*s & 0x7f); - /* UTF8_IS_XXXXX not right here - using constant 0x80 */ - if ((U8)(*s++) < 0x80) { - bytes = 0; - sv = NEWSV(40, 0); - sv_setuv(sv, auv); - PUSHs(sv_2mortal(sv)); - len--; - auv = 0; - } - else if (++bytes >= sizeof(UV)) { /* promote to string */ - char *t; - STRLEN n_a; - - sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); - while (s < strend) { - sv = mul128(sv, *s & 0x7f); - if (!(*s++ & 0x80)) { - bytes = 0; - break; - } - } - t = SvPV(sv, n_a); - while (*t == '0') - t++; - sv_chop(sv, t); - PUSHs(sv_2mortal(sv)); - len--; - auv = 0; - } - } - if ((s >= strend) && bytes) - DIE(aTHX_ "Unterminated compressed integer"); - } - break; - case 'P': - EXTEND(SP, 1); - if (sizeof(char*) > strend - s) - break; - else { - Copy(s, &aptr, 1, char*); - s += sizeof(char*); - } - sv = NEWSV(44, 0); - if (aptr) - sv_setpvn(sv, aptr, len); - PUSHs(sv_2mortal(sv)); - break; -#ifdef HAS_QUAD - case 'q': - along = (strend - s) / sizeof(Quad_t); - if (len > along) - len = along; - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - if (s + sizeof(Quad_t) > strend) - aquad = 0; - else { - Copy(s, &aquad, 1, Quad_t); - s += sizeof(Quad_t); - } - sv = NEWSV(42, 0); - if (aquad >= IV_MIN && aquad <= IV_MAX) - sv_setiv(sv, (IV)aquad); - else - sv_setnv(sv, (NV)aquad); - PUSHs(sv_2mortal(sv)); - } - break; - case 'Q': - along = (strend - s) / sizeof(Quad_t); - if (len > along) - len = along; - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - if (s + sizeof(Uquad_t) > strend) - auquad = 0; - else { - Copy(s, &auquad, 1, Uquad_t); - s += sizeof(Uquad_t); - } - sv = NEWSV(43, 0); - if (auquad <= UV_MAX) - sv_setuv(sv, (UV)auquad); - else - sv_setnv(sv, (NV)auquad); - PUSHs(sv_2mortal(sv)); - } - break; -#endif - /* float and double added gnb@melba.bby.oz.au 22/11/89 */ - case 'f': - case 'F': - along = (strend - s) / sizeof(float); - if (len > along) - len = along; - if (checksum) { - while (len-- > 0) { - Copy(s, &afloat, 1, float); - s += sizeof(float); - cdouble += afloat; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - Copy(s, &afloat, 1, float); - s += sizeof(float); - sv = NEWSV(47, 0); - sv_setnv(sv, (NV)afloat); - PUSHs(sv_2mortal(sv)); - } - } - break; - case 'd': - case 'D': - along = (strend - s) / sizeof(double); - if (len > along) - len = along; - if (checksum) { - while (len-- > 0) { - Copy(s, &adouble, 1, double); - s += sizeof(double); - cdouble += adouble; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - Copy(s, &adouble, 1, double); - s += sizeof(double); - sv = NEWSV(48, 0); - sv_setnv(sv, (NV)adouble); - PUSHs(sv_2mortal(sv)); - } - } - 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 (PL_uudmap['M'] == 0) { - int i; - - for (i = 0; i < sizeof(PL_uuemap); i += 1) - PL_uudmap[(U8)PL_uuemap[i]] = i; - /* - * Because ' ' and '`' map to the same value, - * we need to decode them both the same. - */ - PL_uudmap[' '] = 0; - } - - along = (strend - s) * 3 / 4; - sv = NEWSV(42, along); - if (along) - SvPOK_on(sv); - while (s < strend && *s > ' ' && ISUUCHAR(*s)) { - I32 a, b, c, d; - char hunk[4]; - - hunk[3] = '\0'; - len = PL_uudmap[*(U8*)s++] & 077; - while (len > 0) { - if (s < strend && ISUUCHAR(*s)) - a = PL_uudmap[*(U8*)s++] & 077; - else - a = 0; - if (s < strend && ISUUCHAR(*s)) - b = PL_uudmap[*(U8*)s++] & 077; - else - b = 0; - if (s < strend && ISUUCHAR(*s)) - c = PL_uudmap[*(U8*)s++] & 077; - else - c = 0; - if (s < strend && ISUUCHAR(*s)) - d = PL_uudmap[*(U8*)s++] & 077; - else - d = 0; - hunk[0] = (a << 2) | (b >> 4); - hunk[1] = (b << 4) | (c >> 2); - hunk[2] = (c << 6) | d; - sv_catpvn(sv, hunk, (len > 3) ? 3 : len); - len -= 3; - } - if (*s == '\n') - s++; - else if (s[1] == '\n') /* possible checksum byte */ - s += 2; - } - XPUSHs(sv_2mortal(sv)); - break; - } - if (checksum) { - sv = NEWSV(42, 0); - if (strchr("fFdD", datumtype) || - (checksum > 32 && strchr("iIlLNU", datumtype)) ) { - NV trouble; - - adouble = 1.0; - while (checksum >= 16) { - checksum -= 16; - adouble *= 65536.0; - } - while (checksum >= 4) { - checksum -= 4; - adouble *= 16.0; - } - while (checksum--) - adouble *= 2.0; - along = (1 << checksum) - 1; - while (cdouble < 0.0) - cdouble += adouble; - cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; - sv_setnv(sv, cdouble); - } - else { - if (checksum < 32) { - aulong = (1 << checksum) - 1; - culong &= aulong; - } - sv_setuv(sv, (UV)culong); - } - XPUSHs(sv_2mortal(sv)); - checksum = 0; - } - } - if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) - PUSHs(&PL_sv_undef); - RETURN; -} - -STATIC void -S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) -{ - char hunk[5]; - - *hunk = PL_uuemap[len]; - sv_catpvn(sv, hunk, 1); - hunk[4] = '\0'; - while (len > 2) { - hunk[0] = PL_uuemap[(077 & (*s >> 2))]; - hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; - hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; - hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; - sv_catpvn(sv, hunk, 4); - s += 3; - len -= 3; - } - if (len > 0) { - char r = (len > 1 ? s[1] : '\0'); - hunk[0] = PL_uuemap[(077 & (*s >> 2))]; - hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; - hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; - hunk[3] = PL_uuemap[0]; - sv_catpvn(sv, hunk, 4); - } - sv_catpvn(sv, "\n", 1); -} - -STATIC SV * -S_is_an_int(pTHX_ char *s, STRLEN l) -{ - STRLEN n_a; - SV *result = newSVpvn(s, l); - char *result_c = SvPV(result, n_a); /* convenience */ - char *out = result_c; - bool skip = 1; - bool ignore = 0; - - while (*s) { - switch (*s) { - case ' ': - break; - case '+': - if (!skip) { - SvREFCNT_dec(result); - return (NULL); - } - break; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - skip = 0; - if (!ignore) { - *(out++) = *s; - } - break; - case '.': - ignore = 1; - break; - default: - SvREFCNT_dec(result); - return (NULL); - } - s++; - } - *(out++) = '\0'; - SvCUR_set(result, out - result_c); - return (result); -} - -/* pnum must be '\0' terminated */ -STATIC int -S_div128(pTHX_ SV *pnum, bool *done) -{ - STRLEN len; - char *s = SvPV(pnum, len); - int m = 0; - int r = 0; - char *t = s; - - *done = 1; - while (*t) { - int i; - - i = m * 10 + (*t - '0'); - m = i & 0x7F; - r = (i >> 7); /* r < 10 */ - if (r) { - *done = 0; - } - *(t++) = '0' + r; - } - *(t++) = '\0'; - SvCUR_set(pnum, (STRLEN) (t - s)); - return (m); -} - - -PP(pp_pack) -{ - dSP; dMARK; dORIGMARK; dTARGET; - register SV *cat = TARG; - register I32 items; - STRLEN fromlen; - register char *pat = SvPVx(*++MARK, fromlen); - char *patcopy; - register char *patend = pat + fromlen; - register I32 len; - I32 datumtype; - SV *fromstr; - /*SUPPRESS 442*/ - static char null10[] = {0,0,0,0,0,0,0,0,0,0}; - static char *space10 = " "; - - /* These must not be in registers: */ - char achar; - I16 ashort; - int aint; - unsigned int auint; - I32 along; - U32 aulong; -#ifdef HAS_QUAD - Quad_t aquad; - Uquad_t auquad; -#endif - char *aptr; - float afloat; - double adouble; - int commas = 0; -#ifdef PERL_NATINT_PACK - int natint; /* native integer */ -#endif - - items = SP - MARK; - MARK++; - sv_setpvn(cat, "", 0); - patcopy = pat; - while (pat < patend) { - SV *lengthcode = Nullsv; -#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) - datumtype = *pat++ & 0xFF; -#ifdef PERL_NATINT_PACK - natint = 0; -#endif - if (isSPACE(datumtype)) { - patcopy++; - continue; - } -#ifndef PACKED_IS_OCTETS - if (datumtype == 'U' && pat == patcopy+1) - SvUTF8_on(cat); -#endif - if (datumtype == '#') { - while (pat < patend && *pat != '\n') - pat++; - continue; - } - if (*pat == '!') { - char *natstr = "sSiIlL"; - - if (strchr(natstr, datumtype)) { -#ifdef PERL_NATINT_PACK - natint = 1; -#endif - pat++; - } - else - DIE(aTHX_ "'!' allowed only after types %s", natstr); - } - if (*pat == '*') { - len = strchr("@Xxu", datumtype) ? 0 : items; - pat++; - } - else if (isDIGIT(*pat)) { - len = *pat++ - '0'; - while (isDIGIT(*pat)) { - len = (len * 10) + (*pat++ - '0'); - if (len < 0) - DIE(aTHX_ "Repeat count in pack overflows"); - } - } - else - len = 1; - if (*pat == '/') { - ++pat; - if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') - DIE(aTHX_ "/ must be followed by a*, A* or Z*"); - lengthcode = sv_2mortal(newSViv(sv_len(items > 0 - ? *MARK : &PL_sv_no) - + (*pat == 'Z' ? 1 : 0))); - } - switch(datumtype) { - default: - DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); - case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && ckWARN(WARN_PACK)) - Perl_warner(aTHX_ WARN_PACK, - "Invalid type in pack: '%c'", (int)datumtype); - break; - case '%': - DIE(aTHX_ "%% may only be used in unpack"); - case '@': - len -= SvCUR(cat); - if (len > 0) - goto grow; - len = -len; - if (len > 0) - goto shrink; - break; - case 'X': - shrink: - if (SvCUR(cat) < len) - DIE(aTHX_ "X outside of string"); - SvCUR(cat) -= len; - *SvEND(cat) = '\0'; - break; - case 'x': - grow: - while (len >= 10) { - sv_catpvn(cat, null10, 10); - len -= 10; - } - sv_catpvn(cat, null10, len); - break; - case 'A': - case 'Z': - case 'a': - fromstr = NEXTFROM; - aptr = SvPV(fromstr, fromlen); - if (pat[-1] == '*') { - len = fromlen; - if (datumtype == 'Z') - ++len; - } - if (fromlen >= len) { - sv_catpvn(cat, aptr, len); - if (datumtype == 'Z') - *(SvEND(cat)-1) = '\0'; - } - else { - sv_catpvn(cat, aptr, fromlen); - len -= fromlen; - if (datumtype == 'A') { - while (len >= 10) { - sv_catpvn(cat, space10, 10); - len -= 10; - } - sv_catpvn(cat, space10, len); - } - else { - while (len >= 10) { - sv_catpvn(cat, null10, 10); - len -= 10; - } - sv_catpvn(cat, null10, len); - } - } - break; - case 'B': - case 'b': - { - register char *str; - I32 saveitems; - - fromstr = NEXTFROM; - saveitems = items; - str = SvPV(fromstr, fromlen); - if (pat[-1] == '*') - len = fromlen; - aint = SvCUR(cat); - SvCUR(cat) += (len+7)/8; - SvGROW(cat, SvCUR(cat) + 1); - aptr = SvPVX(cat) + aint; - if (len > fromlen) - len = fromlen; - aint = len; - items = 0; - if (datumtype == 'B') { - for (len = 0; len++ < aint;) { - items |= *str++ & 1; - if (len & 7) - items <<= 1; - else { - *aptr++ = items & 0xff; - items = 0; - } - } - } - else { - for (len = 0; len++ < aint;) { - if (*str++ & 1) - items |= 128; - if (len & 7) - items >>= 1; - else { - *aptr++ = items & 0xff; - items = 0; - } - } - } - if (aint & 7) { - if (datumtype == 'B') - items <<= 7 - (aint & 7); - else - items >>= 7 - (aint & 7); - *aptr++ = items & 0xff; - } - str = SvPVX(cat) + SvCUR(cat); - while (aptr <= str) - *aptr++ = '\0'; - - items = saveitems; - } - break; - case 'H': - case 'h': - { - register char *str; - I32 saveitems; - - fromstr = NEXTFROM; - saveitems = items; - str = SvPV(fromstr, fromlen); - if (pat[-1] == '*') - len = fromlen; - aint = SvCUR(cat); - SvCUR(cat) += (len+1)/2; - SvGROW(cat, SvCUR(cat) + 1); - aptr = SvPVX(cat) + aint; - if (len > fromlen) - len = fromlen; - aint = len; - items = 0; - if (datumtype == 'H') { - for (len = 0; len++ < aint;) { - if (isALPHA(*str)) - items |= ((*str++ & 15) + 9) & 15; - else - items |= *str++ & 15; - if (len & 1) - items <<= 4; - else { - *aptr++ = items & 0xff; - items = 0; - } - } - } - else { - for (len = 0; len++ < aint;) { - if (isALPHA(*str)) - items |= (((*str++ & 15) + 9) & 15) << 4; - else - items |= (*str++ & 15) << 4; - if (len & 1) - items >>= 4; - else { - *aptr++ = items & 0xff; - items = 0; - } - } - } - if (aint & 1) - *aptr++ = items & 0xff; - str = SvPVX(cat) + SvCUR(cat); - while (aptr <= str) - *aptr++ = '\0'; - - items = saveitems; - } - break; - case 'C': - case 'c': - while (len-- > 0) { - fromstr = NEXTFROM; - switch (datumtype) { - case 'C': - aint = SvIV(fromstr); - if ((aint < 0 || aint > 255) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ WARN_PACK, - "Character in \"C\" format wrapped"); - achar = aint & 255; - sv_catpvn(cat, &achar, sizeof(char)); - break; - case 'c': - aint = SvIV(fromstr); - if ((aint < -128 || aint > 127) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ WARN_PACK, - "Character in \"c\" format wrapped"); - achar = aint & 255; - sv_catpvn(cat, &achar, sizeof(char)); - break; - } - } - break; - case 'U': - while (len-- > 0) { - fromstr = NEXTFROM; - auint = SvUV(fromstr); - SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); - SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint) - - SvPVX(cat)); - } - *SvEND(cat) = '\0'; - break; - /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ - case 'f': - case 'F': - while (len-- > 0) { - fromstr = NEXTFROM; - afloat = (float)SvNV(fromstr); - sv_catpvn(cat, (char *)&afloat, sizeof (float)); - } - break; - case 'd': - case 'D': - while (len-- > 0) { - fromstr = NEXTFROM; - adouble = (double)SvNV(fromstr); - sv_catpvn(cat, (char *)&adouble, sizeof (double)); - } - break; - case 'n': - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = (I16)SvIV(fromstr); -#ifdef HAS_HTONS - ashort = PerlSock_htons(ashort); -#endif - CAT16(cat, &ashort); - } - break; - case 'v': - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = (I16)SvIV(fromstr); -#ifdef HAS_HTOVS - ashort = htovs(ashort); -#endif - CAT16(cat, &ashort); - } - break; - case 'S': -#if SHORTSIZE != SIZE16 - if (natint) { - unsigned short aushort; - - while (len-- > 0) { - fromstr = NEXTFROM; - aushort = SvUV(fromstr); - sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); - } - } - else -#endif - { - U16 aushort; - - while (len-- > 0) { - fromstr = NEXTFROM; - aushort = (U16)SvUV(fromstr); - CAT16(cat, &aushort); - } - - } - break; - case 's': -#if SHORTSIZE != SIZE16 - if (natint) { - short ashort; - - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = SvIV(fromstr); - sv_catpvn(cat, (char *)&ashort, sizeof(short)); - } - } - else -#endif - { - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = (I16)SvIV(fromstr); - CAT16(cat, &ashort); - } - } - break; - case 'I': - while (len-- > 0) { - fromstr = NEXTFROM; - auint = SvUV(fromstr); - sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); - } - break; - case 'w': - while (len-- > 0) { - fromstr = NEXTFROM; - adouble = Perl_floor(SvNV(fromstr)); - - if (adouble < 0) - DIE(aTHX_ "Cannot compress negative numbers"); - - if ( -#if UVSIZE > 4 && UVSIZE >= NVSIZE - adouble <= 0xffffffff -#else -# ifdef CXUX_BROKEN_CONSTANT_CONVERT - adouble <= UV_MAX_cxux -# else - adouble <= UV_MAX -# endif -#endif - ) - { - char buf[1 + sizeof(UV)]; - char *in = buf + sizeof(buf); - UV auv = U_V(adouble); - - do { - *--in = (auv & 0x7f) | 0x80; - auv >>= 7; - } while (auv); - buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, in, (buf + sizeof(buf)) - in); - } - else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ - char *from, *result, *in; - SV *norm; - STRLEN len; - bool done; - - /* Copy string and check for compliance */ - from = SvPV(fromstr, len); - if ((norm = is_an_int(from, len)) == NULL) - DIE(aTHX_ "can compress only unsigned integer"); - - New('w', result, len, char); - in = result + len; - done = FALSE; - while (!done) - *--in = div128(norm, &done) | 0x80; - result[len - 1] &= 0x7F; /* clear continue bit */ - sv_catpvn(cat, in, (result + len) - in); - Safefree(result); - SvREFCNT_dec(norm); /* free norm */ - } - else if (SvNOKp(fromstr)) { - char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ - char *in = buf + sizeof(buf); - - do { - double next = floor(adouble / 128); - *--in = (unsigned char)(adouble - (next * 128)) | 0x80; - if (in <= buf) /* this cannot happen ;-) */ - DIE(aTHX_ "Cannot compress integer"); - in--; - adouble = next; - } while (adouble > 0); - buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, in, (buf + sizeof(buf)) - in); - } - else - DIE(aTHX_ "Cannot compress non integer"); - } - break; - case 'i': - while (len-- > 0) { - fromstr = NEXTFROM; - aint = SvIV(fromstr); - sv_catpvn(cat, (char*)&aint, sizeof(int)); - } - break; - case 'N': - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); -#ifdef HAS_HTONL - aulong = PerlSock_htonl(aulong); -#endif - CAT32(cat, &aulong); - } - break; - case 'V': - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); -#ifdef HAS_HTOVL - aulong = htovl(aulong); -#endif - CAT32(cat, &aulong); - } - break; - case 'L': -#if LONGSIZE != SIZE32 - if (natint) { - unsigned long aulong; - - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); - sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); - } - } - else -#endif - { - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); - CAT32(cat, &aulong); - } - } - break; - case 'l': -#if LONGSIZE != SIZE32 - if (natint) { - long along; - - while (len-- > 0) { - fromstr = NEXTFROM; - along = SvIV(fromstr); - sv_catpvn(cat, (char *)&along, sizeof(long)); - } - } - else -#endif - { - while (len-- > 0) { - fromstr = NEXTFROM; - along = SvIV(fromstr); - CAT32(cat, &along); - } - } - break; -#ifdef HAS_QUAD - case 'Q': - while (len-- > 0) { - fromstr = NEXTFROM; - auquad = (Uquad_t)SvUV(fromstr); - sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); - } - break; - case 'q': - while (len-- > 0) { - fromstr = NEXTFROM; - aquad = (Quad_t)SvIV(fromstr); - sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); - } - break; -#endif - case 'P': - len = 1; /* assume SV is correct length */ - /* FALL THROUGH */ - case 'p': - while (len-- > 0) { - fromstr = NEXTFROM; - if (fromstr == &PL_sv_undef) - aptr = NULL; - else { - STRLEN n_a; - /* XXX better yet, could spirit away the string to - * a safe spot and hang on to it until the result - * of pack() (and all copies of the result) are - * gone. - */ - if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) - || (SvPADTMP(fromstr) - && !SvREADONLY(fromstr)))) - { - Perl_warner(aTHX_ WARN_PACK, - "Attempt to pack pointer to temporary value"); - } - if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV(fromstr,n_a); - else - aptr = SvPV_force(fromstr,n_a); - } - sv_catpvn(cat, (char*)&aptr, sizeof(char*)); - } - break; - case 'u': - fromstr = NEXTFROM; - aptr = SvPV(fromstr, fromlen); - SvGROW(cat, fromlen * 4 / 3); - if (len <= 1) - len = 45; - else - len = len / 3 * 3; - while (fromlen > 0) { - I32 todo; - - if (fromlen > len) - todo = len; - else - todo = fromlen; - doencodes(cat, aptr, todo); - fromlen -= todo; - aptr += todo; - } - break; - } - } - SvSETMAGIC(cat); - SP = ORIGMARK; - PUSHs(cat); - RETURN; -} -#undef NEXTFROM - - PP(pp_split) { dSP; dTARG; diff --git a/pp_pack.c b/pp_pack.c new file mode 100644 index 0000000000..be6ff6f9ff --- /dev/null +++ b/pp_pack.c @@ -0,0 +1,1825 @@ +/* pp_pack.c + * + * Copyright (c) 1991-2001, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +#include "EXTERN.h" +#define PERL_IN_PP_PACK_C +#include "perl.h" + +/* + * The compiler on Concurrent CX/UX systems has a subtle bug which only + * seems to show up when compiling pp.c - it generates the wrong double + * precision constant value for (double)UV_MAX when used inline in the body + * of the code below, so this makes a static variable up front (which the + * compiler seems to get correct) and uses it in place of UV_MAX below. + */ +#ifdef CXUX_BROKEN_CONSTANT_CONVERT +static double UV_MAX_cxux = ((double)UV_MAX); +#endif + +/* + * Offset for integer pack/unpack. + * + * On architectures where I16 and I32 aren't really 16 and 32 bits, + * which for now are all Crays, pack and unpack have to play games. + */ + +/* + * These values are required for portability of pack() output. + * If they're not right on your machine, then pack() and unpack() + * wouldn't work right anyway; you'll need to apply the Cray hack. + * (I'd like to check them with #if, but you can't use sizeof() in + * the preprocessor.) --??? + */ +/* + The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE + defines are now in config.h. --Andy Dougherty April 1998 + */ +#define SIZE16 2 +#define SIZE32 4 + +/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). + --jhi Feb 1999 */ + +#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 +# define PERL_NATINT_PACK +#endif + +#if LONGSIZE > 4 && defined(_CRAY) +# if BYTEORDER == 0x12345678 +# define OFF16(p) (char*)(p) +# define OFF32(p) (char*)(p) +# else +# if BYTEORDER == 0x87654321 +# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) +# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) +# else + }}}} bad cray byte order +# endif +# endif +# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) +# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) +# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) +# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) +# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) +#else +# define COPY16(s,p) Copy(s, p, SIZE16, char) +# define COPY32(s,p) Copy(s, p, SIZE32, char) +# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) +# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) +# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) +#endif + +STATIC SV * +S_mul128(pTHX_ SV *sv, U8 m) +{ + STRLEN len; + char *s = SvPV(sv, len); + char *t; + U32 i = 0; + + if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ + SV *tmpNew = newSVpvn("0000000000", 10); + + sv_catsv(tmpNew, sv); + SvREFCNT_dec(sv); /* free old sv */ + sv = tmpNew; + s = SvPV(sv, len); + } + t = s + len - 1; + while (!*t) /* trailing '\0'? */ + t--; + while (t > s) { + i = ((*t - '0') << 7) + m; + *(t--) = '0' + (i % 10); + m = i / 10; + } + return (sv); +} + +/* Explosives and implosives. */ + +#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(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') +#endif + + +PP(pp_unpack) +{ + dSP; + dPOPPOPssrl; + I32 start_sp_offset = SP - PL_stack_base; + I32 gimme = GIMME_V; + SV *sv; + STRLEN llen; + STRLEN rlen; + register char *pat = SvPV(left, llen); +#ifdef PACKED_IS_OCTETS + /* Packed side is assumed to be octets - so force downgrade if it + has been UTF-8 encoded by accident + */ + register char *s = SvPVbyte(right, rlen); +#else + register char *s = SvPV(right, rlen); +#endif + char *strend = s + rlen; + char *strbeg = s; + register char *patend = pat + llen; + I32 datumtype; + register I32 len; + register I32 bits = 0; + register char *str; + + /* These must not be in registers: */ + short ashort; + int aint; + long along; +#ifdef HAS_QUAD + Quad_t aquad; +#endif + U16 aushort; + unsigned int auint; + U32 aulong; +#ifdef HAS_QUAD + Uquad_t auquad; +#endif + char *aptr; + float afloat; + double adouble; + I32 checksum = 0; + register U32 culong = 0; + NV cdouble = 0.0; + int commas = 0; + int star; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ + int unatint; /* unsigned native integer */ +#endif + + if (gimme != G_ARRAY) { /* arrange to do first one only */ + /*SUPPRESS 530*/ + for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; + if (strchr("aAZbBhHP", *patend) || *pat == '%') { + patend++; + while (isDIGIT(*patend) || *patend == '*') + patend++; + } + else + patend++; + } + while (pat < patend) { + reparse: + datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif + if (isSPACE(datumtype)) + continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } + if (*pat == '!') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + DIE(aTHX_ "'!' allowed only after types %s", natstr); + } + star = 0; + if (pat >= patend) + len = 1; + else if (*pat == '*') { + len = strend - strbeg; /* long enough */ + pat++; + star = 1; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) { + len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in unpack overflows"); + } + } + else + len = (datumtype != '@'); + redo_switch: + switch(datumtype) { + default: + DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && ckWARN(WARN_UNPACK)) + Perl_warner(aTHX_ WARN_UNPACK, + "Invalid type in unpack: '%c'", (int)datumtype); + break; + case '%': + if (len == 1 && pat[-1] != '1') + len = 16; + checksum = len; + culong = 0; + cdouble = 0; + if (pat < patend) + goto reparse; + break; + case '@': + if (len > strend - strbeg) + DIE(aTHX_ "@ outside of string"); + s = strbeg + len; + break; + case 'X': + if (len > s - strbeg) + DIE(aTHX_ "X outside of string"); + s -= len; + break; + case 'x': + if (len > strend - s) + DIE(aTHX_ "x outside of string"); + s += len; + break; + case '/': + if (start_sp_offset >= SP - PL_stack_base) + DIE(aTHX_ "/ must follow a numeric type"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "/ cannot take a count" ); + len = POPi; + star = 0; + goto redo_switch; + case 'A': + case 'Z': + case 'a': + if (len > strend - s) + len = strend - s; + if (checksum) + goto uchar_checksum; + sv = NEWSV(35, len); + sv_setpvn(sv, s, len); + s += len; + if (datumtype == 'A' || datumtype == 'Z') { + aptr = s; /* borrow register */ + if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ + s = SvPVX(sv); + while (*s) + s++; + } + else { /* 'A' strips both nulls and spaces */ + s = SvPVX(sv) + len - 1; + while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) + s--; + *++s = '\0'; + } + SvCUR_set(sv, s - SvPVX(sv)); + s = aptr; /* unborrow register */ + } + XPUSHs(sv_2mortal(sv)); + break; + case 'B': + case 'b': + if (star || len > (strend - s) * 8) + len = (strend - s) * 8; + if (checksum) { + if (!PL_bitcount) { + Newz(601, PL_bitcount, 256, char); + for (bits = 1; bits < 256; bits++) { + if (bits & 1) PL_bitcount[bits]++; + if (bits & 2) PL_bitcount[bits]++; + if (bits & 4) PL_bitcount[bits]++; + if (bits & 8) PL_bitcount[bits]++; + if (bits & 16) PL_bitcount[bits]++; + if (bits & 32) PL_bitcount[bits]++; + if (bits & 64) PL_bitcount[bits]++; + if (bits & 128) PL_bitcount[bits]++; + } + } + while (len >= 8) { + culong += PL_bitcount[*(unsigned char*)s++]; + len -= 8; + } + if (len) { + bits = *s; + if (datumtype == 'b') { + while (len-- > 0) { + if (bits & 1) culong++; + bits >>= 1; + } + } + else { + while (len-- > 0) { + if (bits & 128) culong++; + bits <<= 1; + } + } + } + break; + } + sv = NEWSV(35, len + 1); + SvCUR_set(sv, len); + SvPOK_on(sv); + str = SvPVX(sv); + if (datumtype == 'b') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) /*SUPPRESS 595*/ + bits >>= 1; + else + bits = *s++; + *str++ = '0' + (bits & 1); + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) + bits <<= 1; + else + bits = *s++; + *str++ = '0' + ((bits & 128) != 0); + } + } + *str = '\0'; + XPUSHs(sv_2mortal(sv)); + break; + case 'H': + case 'h': + if (star || len > (strend - s) * 2) + len = (strend - s) * 2; + sv = NEWSV(35, len + 1); + SvCUR_set(sv, len); + SvPOK_on(sv); + str = SvPVX(sv); + if (datumtype == 'h') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits >>= 4; + else + bits = *s++; + *str++ = PL_hexdigit[bits & 15]; + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits <<= 4; + else + bits = *s++; + *str++ = PL_hexdigit[(bits >> 4) & 15]; + } + } + *str = '\0'; + XPUSHs(sv_2mortal(sv)); + break; + case 'c': + if (len > strend - s) + len = strend - s; + if (checksum) { + while (len-- > 0) { + aint = *s++; + if (aint >= 128) /* fake up signed chars */ + aint -= 256; + culong += aint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + aint = *s++; + if (aint >= 128) /* fake up signed chars */ + aint -= 256; + sv = NEWSV(36, 0); + sv_setiv(sv, (IV)aint); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'C': + if (len > strend - s) + len = strend - s; + if (checksum) { + uchar_checksum: + while (len-- > 0) { + auint = *s++ & 255; + culong += auint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + auint = *s++ & 255; + sv = NEWSV(37, 0); + sv_setiv(sv, (IV)auint); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'U': + if (len > strend - s) + len = strend - s; + if (checksum) { + while (len-- > 0 && s < strend) { + STRLEN alen; + auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); + along = alen; + s += along; + if (checksum > 32) + cdouble += (NV)auint; + else + culong += auint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0 && s < strend) { + STRLEN alen; + auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); + along = alen; + s += along; + sv = NEWSV(37, 0); + sv_setuv(sv, (UV)auint); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 's': +#if SHORTSIZE == SIZE16 + along = (strend - s) / SIZE16; +#else + along = (strend - s) / (natint ? sizeof(short) : SIZE16); +#endif + if (len > along) + len = along; + if (checksum) { +#if SHORTSIZE != SIZE16 + if (natint) { + short ashort; + while (len-- > 0) { + COPYNN(s, &ashort, sizeof(short)); + s += sizeof(short); + culong += ashort; + + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif + s += SIZE16; + culong += ashort; + } + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); +#if SHORTSIZE != SIZE16 + if (natint) { + short ashort; + while (len-- > 0) { + COPYNN(s, &ashort, sizeof(short)); + s += sizeof(short); + sv = NEWSV(38, 0); + sv_setiv(sv, (IV)ashort); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif + s += SIZE16; + sv = NEWSV(38, 0); + sv_setiv(sv, (IV)ashort); + PUSHs(sv_2mortal(sv)); + } + } + } + break; + case 'v': + case 'n': + case 'S': +#if SHORTSIZE == SIZE16 + along = (strend - s) / SIZE16; +#else + unatint = natint && datumtype == 'S'; + along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); +#endif + if (len > along) + len = along; + if (checksum) { +#if SHORTSIZE != SIZE16 + if (unatint) { + unsigned short aushort; + while (len-- > 0) { + COPYNN(s, &aushort, sizeof(unsigned short)); + s += sizeof(unsigned short); + culong += aushort; + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &aushort); + s += SIZE16; +#ifdef HAS_NTOHS + if (datumtype == 'n') + aushort = PerlSock_ntohs(aushort); +#endif +#ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); +#endif + culong += aushort; + } + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); +#if SHORTSIZE != SIZE16 + if (unatint) { + unsigned short aushort; + while (len-- > 0) { + COPYNN(s, &aushort, sizeof(unsigned short)); + s += sizeof(unsigned short); + sv = NEWSV(39, 0); + sv_setiv(sv, (UV)aushort); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &aushort); + s += SIZE16; + sv = NEWSV(39, 0); +#ifdef HAS_NTOHS + if (datumtype == 'n') + aushort = PerlSock_ntohs(aushort); +#endif +#ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); +#endif + sv_setiv(sv, (UV)aushort); + PUSHs(sv_2mortal(sv)); + } + } + } + break; + case 'i': + along = (strend - s) / sizeof(int); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &aint, 1, int); + s += sizeof(int); + if (checksum > 32) + cdouble += (NV)aint; + else + culong += aint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &aint, 1, int); + s += sizeof(int); + sv = NEWSV(40, 0); +#ifdef __osf__ + /* Without the dummy below unpack("i", pack("i",-1)) + * return 0xFFffFFff instead of -1 for Digital Unix V4.0 + * cc with optimization turned on. + * + * The bug was detected in + * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) + * with optimization (-O4) turned on. + * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) + * does not have this problem even with -O4. + * + * This bug was reported as DECC_BUGS 1431 + * and tracked internally as GEM_BUGS 7775. + * + * The bug is fixed in + * Tru64 UNIX V5.0: Compaq C V6.1-006 or later + * UNIX V4.0F support: DEC C V5.9-006 or later + * UNIX V4.0E support: DEC C V5.8-011 or later + * and also in DTK. + * + * See also few lines later for the same bug. + */ + (aint) ? + sv_setiv(sv, (IV)aint) : +#endif + sv_setiv(sv, (IV)aint); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'I': + along = (strend - s) / sizeof(unsigned int); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &auint, 1, unsigned int); + s += sizeof(unsigned int); + if (checksum > 32) + cdouble += (NV)auint; + else + culong += auint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &auint, 1, unsigned int); + s += sizeof(unsigned int); + sv = NEWSV(41, 0); +#ifdef __osf__ + /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) + * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. + * See details few lines earlier. */ + (auint) ? + sv_setuv(sv, (UV)auint) : +#endif + sv_setuv(sv, (UV)auint); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'l': +#if LONGSIZE == SIZE32 + along = (strend - s) / SIZE32; +#else + along = (strend - s) / (natint ? sizeof(long) : SIZE32); +#endif + if (len > along) + len = along; + if (checksum) { +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + COPYNN(s, &along, sizeof(long)); + s += sizeof(long); + if (checksum > 32) + cdouble += (NV)along; + else + culong += along; + } + } + else +#endif + { + while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif + COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif + s += SIZE32; + if (checksum > 32) + cdouble += (NV)along; + else + culong += along; + } + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + COPYNN(s, &along, sizeof(long)); + s += sizeof(long); + sv = NEWSV(42, 0); + sv_setiv(sv, (IV)along); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif + COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif + s += SIZE32; + sv = NEWSV(42, 0); + sv_setiv(sv, (IV)along); + PUSHs(sv_2mortal(sv)); + } + } + } + break; + case 'V': + case 'N': + case 'L': +#if LONGSIZE == SIZE32 + along = (strend - s) / SIZE32; +#else + unatint = natint && datumtype == 'L'; + along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); +#endif + if (len > along) + len = along; + if (checksum) { +#if LONGSIZE != SIZE32 + if (unatint) { + unsigned long aulong; + while (len-- > 0) { + COPYNN(s, &aulong, sizeof(unsigned long)); + s += sizeof(unsigned long); + if (checksum > 32) + cdouble += (NV)aulong; + else + culong += aulong; + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &aulong); + s += SIZE32; +#ifdef HAS_NTOHL + if (datumtype == 'N') + aulong = PerlSock_ntohl(aulong); +#endif +#ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); +#endif + if (checksum > 32) + cdouble += (NV)aulong; + else + culong += aulong; + } + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); +#if LONGSIZE != SIZE32 + if (unatint) { + unsigned long aulong; + while (len-- > 0) { + COPYNN(s, &aulong, sizeof(unsigned long)); + s += sizeof(unsigned long); + sv = NEWSV(43, 0); + sv_setuv(sv, (UV)aulong); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &aulong); + s += SIZE32; +#ifdef HAS_NTOHL + if (datumtype == 'N') + aulong = PerlSock_ntohl(aulong); +#endif +#ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); +#endif + sv = NEWSV(43, 0); + sv_setuv(sv, (UV)aulong); + PUSHs(sv_2mortal(sv)); + } + } + } + break; + case 'p': + along = (strend - s) / sizeof(char*); + if (len > along) + len = along; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + if (sizeof(char*) > strend - s) + break; + else { + Copy(s, &aptr, 1, char*); + s += sizeof(char*); + } + sv = NEWSV(44, 0); + if (aptr) + sv_setpv(sv, aptr); + PUSHs(sv_2mortal(sv)); + } + break; + case 'w': + EXTEND(SP, len); + EXTEND_MORTAL(len); + { + UV auv = 0; + U32 bytes = 0; + + while ((len > 0) && (s < strend)) { + auv = (auv << 7) | (*s & 0x7f); + /* UTF8_IS_XXXXX not right here - using constant 0x80 */ + if ((U8)(*s++) < 0x80) { + bytes = 0; + sv = NEWSV(40, 0); + sv_setuv(sv, auv); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + else if (++bytes >= sizeof(UV)) { /* promote to string */ + char *t; + STRLEN n_a; + + sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); + while (s < strend) { + sv = mul128(sv, *s & 0x7f); + if (!(*s++ & 0x80)) { + bytes = 0; + break; + } + } + t = SvPV(sv, n_a); + while (*t == '0') + t++; + sv_chop(sv, t); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + } + if ((s >= strend) && bytes) + DIE(aTHX_ "Unterminated compressed integer"); + } + break; + case 'P': + EXTEND(SP, 1); + if (sizeof(char*) > strend - s) + break; + else { + Copy(s, &aptr, 1, char*); + s += sizeof(char*); + } + sv = NEWSV(44, 0); + if (aptr) + sv_setpvn(sv, aptr, len); + PUSHs(sv_2mortal(sv)); + break; +#ifdef HAS_QUAD + case 'q': + along = (strend - s) / sizeof(Quad_t); + if (len > along) + len = along; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + if (s + sizeof(Quad_t) > strend) + aquad = 0; + else { + Copy(s, &aquad, 1, Quad_t); + s += sizeof(Quad_t); + } + sv = NEWSV(42, 0); + if (aquad >= IV_MIN && aquad <= IV_MAX) + sv_setiv(sv, (IV)aquad); + else + sv_setnv(sv, (NV)aquad); + PUSHs(sv_2mortal(sv)); + } + break; + case 'Q': + along = (strend - s) / sizeof(Quad_t); + if (len > along) + len = along; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + if (s + sizeof(Uquad_t) > strend) + auquad = 0; + else { + Copy(s, &auquad, 1, Uquad_t); + s += sizeof(Uquad_t); + } + sv = NEWSV(43, 0); + if (auquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else + sv_setnv(sv, (NV)auquad); + PUSHs(sv_2mortal(sv)); + } + break; +#endif + /* float and double added gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + case 'F': + along = (strend - s) / sizeof(float); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &afloat, 1, float); + s += sizeof(float); + cdouble += afloat; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &afloat, 1, float); + s += sizeof(float); + sv = NEWSV(47, 0); + sv_setnv(sv, (NV)afloat); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'd': + case 'D': + along = (strend - s) / sizeof(double); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &adouble, 1, double); + s += sizeof(double); + cdouble += adouble; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &adouble, 1, double); + s += sizeof(double); + sv = NEWSV(48, 0); + sv_setnv(sv, (NV)adouble); + PUSHs(sv_2mortal(sv)); + } + } + 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 (PL_uudmap['M'] == 0) { + int i; + + for (i = 0; i < sizeof(PL_uuemap); i += 1) + PL_uudmap[(U8)PL_uuemap[i]] = i; + /* + * Because ' ' and '`' map to the same value, + * we need to decode them both the same. + */ + PL_uudmap[' '] = 0; + } + + along = (strend - s) * 3 / 4; + sv = NEWSV(42, along); + if (along) + SvPOK_on(sv); + while (s < strend && *s > ' ' && ISUUCHAR(*s)) { + I32 a, b, c, d; + char hunk[4]; + + hunk[3] = '\0'; + len = PL_uudmap[*(U8*)s++] & 077; + while (len > 0) { + if (s < strend && ISUUCHAR(*s)) + a = PL_uudmap[*(U8*)s++] & 077; + else + a = 0; + if (s < strend && ISUUCHAR(*s)) + b = PL_uudmap[*(U8*)s++] & 077; + else + b = 0; + if (s < strend && ISUUCHAR(*s)) + c = PL_uudmap[*(U8*)s++] & 077; + else + c = 0; + if (s < strend && ISUUCHAR(*s)) + d = PL_uudmap[*(U8*)s++] & 077; + else + d = 0; + hunk[0] = (a << 2) | (b >> 4); + hunk[1] = (b << 4) | (c >> 2); + hunk[2] = (c << 6) | d; + sv_catpvn(sv, hunk, (len > 3) ? 3 : len); + len -= 3; + } + if (*s == '\n') + s++; + else if (s[1] == '\n') /* possible checksum byte */ + s += 2; + } + XPUSHs(sv_2mortal(sv)); + break; + } + if (checksum) { + sv = NEWSV(42, 0); + if (strchr("fFdD", datumtype) || + (checksum > 32 && strchr("iIlLNU", datumtype)) ) { + NV trouble; + + adouble = 1.0; + while (checksum >= 16) { + checksum -= 16; + adouble *= 65536.0; + } + while (checksum >= 4) { + checksum -= 4; + adouble *= 16.0; + } + while (checksum--) + adouble *= 2.0; + along = (1 << checksum) - 1; + while (cdouble < 0.0) + cdouble += adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; + sv_setnv(sv, cdouble); + } + else { + if (checksum < 32) { + aulong = (1 << checksum) - 1; + culong &= aulong; + } + sv_setuv(sv, (UV)culong); + } + XPUSHs(sv_2mortal(sv)); + checksum = 0; + } + } + if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) + PUSHs(&PL_sv_undef); + RETURN; +} + +STATIC void +S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) +{ + char hunk[5]; + + *hunk = PL_uuemap[len]; + sv_catpvn(sv, hunk, 1); + hunk[4] = '\0'; + while (len > 2) { + hunk[0] = PL_uuemap[(077 & (*s >> 2))]; + hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; + hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; + hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; + sv_catpvn(sv, hunk, 4); + s += 3; + len -= 3; + } + if (len > 0) { + char r = (len > 1 ? s[1] : '\0'); + hunk[0] = PL_uuemap[(077 & (*s >> 2))]; + hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; + hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; + hunk[3] = PL_uuemap[0]; + sv_catpvn(sv, hunk, 4); + } + sv_catpvn(sv, "\n", 1); +} + +STATIC SV * +S_is_an_int(pTHX_ char *s, STRLEN l) +{ + STRLEN n_a; + SV *result = newSVpvn(s, l); + char *result_c = SvPV(result, n_a); /* convenience */ + char *out = result_c; + bool skip = 1; + bool ignore = 0; + + while (*s) { + switch (*s) { + case ' ': + break; + case '+': + if (!skip) { + SvREFCNT_dec(result); + return (NULL); + } + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + skip = 0; + if (!ignore) { + *(out++) = *s; + } + break; + case '.': + ignore = 1; + break; + default: + SvREFCNT_dec(result); + return (NULL); + } + s++; + } + *(out++) = '\0'; + SvCUR_set(result, out - result_c); + return (result); +} + +/* pnum must be '\0' terminated */ +STATIC int +S_div128(pTHX_ SV *pnum, bool *done) +{ + STRLEN len; + char *s = SvPV(pnum, len); + int m = 0; + int r = 0; + char *t = s; + + *done = 1; + while (*t) { + int i; + + i = m * 10 + (*t - '0'); + m = i & 0x7F; + r = (i >> 7); /* r < 10 */ + if (r) { + *done = 0; + } + *(t++) = '0' + r; + } + *(t++) = '\0'; + SvCUR_set(pnum, (STRLEN) (t - s)); + return (m); +} + + +PP(pp_pack) +{ + dSP; dMARK; dORIGMARK; dTARGET; + register SV *cat = TARG; + register I32 items; + STRLEN fromlen; + register char *pat = SvPVx(*++MARK, fromlen); + char *patcopy; + register char *patend = pat + fromlen; + register I32 len; + I32 datumtype; + SV *fromstr; + /*SUPPRESS 442*/ + static char null10[] = {0,0,0,0,0,0,0,0,0,0}; + static char *space10 = " "; + + /* These must not be in registers: */ + char achar; + I16 ashort; + int aint; + unsigned int auint; + I32 along; + U32 aulong; +#ifdef HAS_QUAD + Quad_t aquad; + Uquad_t auquad; +#endif + char *aptr; + float afloat; + double adouble; + int commas = 0; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ +#endif + + items = SP - MARK; + MARK++; + sv_setpvn(cat, "", 0); + patcopy = pat; + while (pat < patend) { + SV *lengthcode = Nullsv; +#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) + datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif + if (isSPACE(datumtype)) { + patcopy++; + continue; + } +#ifndef PACKED_IS_OCTETS + if (datumtype == 'U' && pat == patcopy+1) + SvUTF8_on(cat); +#endif + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } + if (*pat == '!') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + DIE(aTHX_ "'!' allowed only after types %s", natstr); + } + if (*pat == '*') { + len = strchr("@Xxu", datumtype) ? 0 : items; + pat++; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) { + len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in pack overflows"); + } + } + else + len = 1; + if (*pat == '/') { + ++pat; + if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') + DIE(aTHX_ "/ must be followed by a*, A* or Z*"); + lengthcode = sv_2mortal(newSViv(sv_len(items > 0 + ? *MARK : &PL_sv_no) + + (*pat == 'Z' ? 1 : 0))); + } + switch(datumtype) { + default: + DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, + "Invalid type in pack: '%c'", (int)datumtype); + break; + case '%': + DIE(aTHX_ "%% may only be used in unpack"); + case '@': + len -= SvCUR(cat); + if (len > 0) + goto grow; + len = -len; + if (len > 0) + goto shrink; + break; + case 'X': + shrink: + if (SvCUR(cat) < len) + DIE(aTHX_ "X outside of string"); + SvCUR(cat) -= len; + *SvEND(cat) = '\0'; + break; + case 'x': + grow: + while (len >= 10) { + sv_catpvn(cat, null10, 10); + len -= 10; + } + sv_catpvn(cat, null10, len); + break; + case 'A': + case 'Z': + case 'a': + fromstr = NEXTFROM; + aptr = SvPV(fromstr, fromlen); + if (pat[-1] == '*') { + len = fromlen; + if (datumtype == 'Z') + ++len; + } + if (fromlen >= len) { + sv_catpvn(cat, aptr, len); + if (datumtype == 'Z') + *(SvEND(cat)-1) = '\0'; + } + else { + sv_catpvn(cat, aptr, fromlen); + len -= fromlen; + if (datumtype == 'A') { + while (len >= 10) { + sv_catpvn(cat, space10, 10); + len -= 10; + } + sv_catpvn(cat, space10, len); + } + else { + while (len >= 10) { + sv_catpvn(cat, null10, 10); + len -= 10; + } + sv_catpvn(cat, null10, len); + } + } + break; + case 'B': + case 'b': + { + register char *str; + I32 saveitems; + + fromstr = NEXTFROM; + saveitems = items; + str = SvPV(fromstr, fromlen); + if (pat[-1] == '*') + len = fromlen; + aint = SvCUR(cat); + SvCUR(cat) += (len+7)/8; + SvGROW(cat, SvCUR(cat) + 1); + aptr = SvPVX(cat) + aint; + if (len > fromlen) + len = fromlen; + aint = len; + items = 0; + if (datumtype == 'B') { + for (len = 0; len++ < aint;) { + items |= *str++ & 1; + if (len & 7) + items <<= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (*str++ & 1) + items |= 128; + if (len & 7) + items >>= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 7) { + if (datumtype == 'B') + items <<= 7 - (aint & 7); + else + items >>= 7 - (aint & 7); + *aptr++ = items & 0xff; + } + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) + *aptr++ = '\0'; + + items = saveitems; + } + break; + case 'H': + case 'h': + { + register char *str; + I32 saveitems; + + fromstr = NEXTFROM; + saveitems = items; + str = SvPV(fromstr, fromlen); + if (pat[-1] == '*') + len = fromlen; + aint = SvCUR(cat); + SvCUR(cat) += (len+1)/2; + SvGROW(cat, SvCUR(cat) + 1); + aptr = SvPVX(cat) + aint; + if (len > fromlen) + len = fromlen; + aint = len; + items = 0; + if (datumtype == 'H') { + for (len = 0; len++ < aint;) { + if (isALPHA(*str)) + items |= ((*str++ & 15) + 9) & 15; + else + items |= *str++ & 15; + if (len & 1) + items <<= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (isALPHA(*str)) + items |= (((*str++ & 15) + 9) & 15) << 4; + else + items |= (*str++ & 15) << 4; + if (len & 1) + items >>= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 1) + *aptr++ = items & 0xff; + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) + *aptr++ = '\0'; + + items = saveitems; + } + break; + case 'C': + case 'c': + while (len-- > 0) { + fromstr = NEXTFROM; + switch (datumtype) { + case 'C': + aint = SvIV(fromstr); + if ((aint < 0 || aint > 255) && + ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, + "Character in \"C\" format wrapped"); + achar = aint & 255; + sv_catpvn(cat, &achar, sizeof(char)); + break; + case 'c': + aint = SvIV(fromstr); + if ((aint < -128 || aint > 127) && + ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, + "Character in \"c\" format wrapped"); + achar = aint & 255; + sv_catpvn(cat, &achar, sizeof(char)); + break; + } + } + break; + case 'U': + while (len-- > 0) { + fromstr = NEXTFROM; + auint = SvUV(fromstr); + SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); + SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint) + - SvPVX(cat)); + } + *SvEND(cat) = '\0'; + break; + /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + afloat = (float)SvNV(fromstr); + sv_catpvn(cat, (char *)&afloat, sizeof (float)); + } + break; + case 'd': + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = (double)SvNV(fromstr); + sv_catpvn(cat, (char *)&adouble, sizeof (double)); + } + break; + case 'n': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (I16)SvIV(fromstr); +#ifdef HAS_HTONS + ashort = PerlSock_htons(ashort); +#endif + CAT16(cat, &ashort); + } + break; + case 'v': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (I16)SvIV(fromstr); +#ifdef HAS_HTOVS + ashort = htovs(ashort); +#endif + CAT16(cat, &ashort); + } + break; + case 'S': +#if SHORTSIZE != SIZE16 + if (natint) { + unsigned short aushort; + + while (len-- > 0) { + fromstr = NEXTFROM; + aushort = SvUV(fromstr); + sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); + } + } + else +#endif + { + U16 aushort; + + while (len-- > 0) { + fromstr = NEXTFROM; + aushort = (U16)SvUV(fromstr); + CAT16(cat, &aushort); + } + + } + break; + case 's': +#if SHORTSIZE != SIZE16 + if (natint) { + short ashort; + + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = SvIV(fromstr); + sv_catpvn(cat, (char *)&ashort, sizeof(short)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (I16)SvIV(fromstr); + CAT16(cat, &ashort); + } + } + break; + case 'I': + while (len-- > 0) { + fromstr = NEXTFROM; + auint = SvUV(fromstr); + sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); + } + break; + case 'w': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = Perl_floor(SvNV(fromstr)); + + if (adouble < 0) + DIE(aTHX_ "Cannot compress negative numbers"); + + if ( +#if UVSIZE > 4 && UVSIZE >= NVSIZE + adouble <= 0xffffffff +#else +# ifdef CXUX_BROKEN_CONSTANT_CONVERT + adouble <= UV_MAX_cxux +# else + adouble <= UV_MAX +# endif +#endif + ) + { + char buf[1 + sizeof(UV)]; + char *in = buf + sizeof(buf); + UV auv = U_V(adouble); + + do { + *--in = (auv & 0x7f) | 0x80; + auv >>= 7; + } while (auv); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ + char *from, *result, *in; + SV *norm; + STRLEN len; + bool done; + + /* Copy string and check for compliance */ + from = SvPV(fromstr, len); + if ((norm = is_an_int(from, len)) == NULL) + DIE(aTHX_ "can compress only unsigned integer"); + + New('w', result, len, char); + in = result + len; + done = FALSE; + while (!done) + *--in = div128(norm, &done) | 0x80; + result[len - 1] &= 0x7F; /* clear continue bit */ + sv_catpvn(cat, in, (result + len) - in); + Safefree(result); + SvREFCNT_dec(norm); /* free norm */ + } + else if (SvNOKp(fromstr)) { + char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ + char *in = buf + sizeof(buf); + + do { + double next = floor(adouble / 128); + *--in = (unsigned char)(adouble - (next * 128)) | 0x80; + if (in <= buf) /* this cannot happen ;-) */ + DIE(aTHX_ "Cannot compress integer"); + in--; + adouble = next; + } while (adouble > 0); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else + DIE(aTHX_ "Cannot compress non integer"); + } + break; + case 'i': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = SvIV(fromstr); + sv_catpvn(cat, (char*)&aint, sizeof(int)); + } + break; + case 'N': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); +#ifdef HAS_HTONL + aulong = PerlSock_htonl(aulong); +#endif + CAT32(cat, &aulong); + } + break; + case 'V': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); +#ifdef HAS_HTOVL + aulong = htovl(aulong); +#endif + CAT32(cat, &aulong); + } + break; + case 'L': +#if LONGSIZE != SIZE32 + if (natint) { + unsigned long aulong; + + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); + sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); + CAT32(cat, &aulong); + } + } + break; + case 'l': +#if LONGSIZE != SIZE32 + if (natint) { + long along; + + while (len-- > 0) { + fromstr = NEXTFROM; + along = SvIV(fromstr); + sv_catpvn(cat, (char *)&along, sizeof(long)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + along = SvIV(fromstr); + CAT32(cat, &along); + } + } + break; +#ifdef HAS_QUAD + case 'Q': + while (len-- > 0) { + fromstr = NEXTFROM; + auquad = (Uquad_t)SvUV(fromstr); + sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); + } + break; + case 'q': + while (len-- > 0) { + fromstr = NEXTFROM; + aquad = (Quad_t)SvIV(fromstr); + sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); + } + break; +#endif + case 'P': + len = 1; /* assume SV is correct length */ + /* FALL THROUGH */ + case 'p': + while (len-- > 0) { + fromstr = NEXTFROM; + if (fromstr == &PL_sv_undef) + aptr = NULL; + else { + STRLEN n_a; + /* XXX better yet, could spirit away the string to + * a safe spot and hang on to it until the result + * of pack() (and all copies of the result) are + * gone. + */ + if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) + || (SvPADTMP(fromstr) + && !SvREADONLY(fromstr)))) + { + Perl_warner(aTHX_ WARN_PACK, + "Attempt to pack pointer to temporary value"); + } + if (SvPOK(fromstr) || SvNIOK(fromstr)) + aptr = SvPV(fromstr,n_a); + else + aptr = SvPV_force(fromstr,n_a); + } + sv_catpvn(cat, (char*)&aptr, sizeof(char*)); + } + break; + case 'u': + fromstr = NEXTFROM; + aptr = SvPV(fromstr, fromlen); + SvGROW(cat, fromlen * 4 / 3); + if (len <= 1) + len = 45; + else + len = len / 3 * 3; + while (fromlen > 0) { + I32 todo; + + if (fromlen > len) + todo = len; + else + todo = fromlen; + doencodes(cat, aptr, todo); + fromlen -= todo; + aptr += todo; + } + break; + } + } + SvSETMAGIC(cat); + SP = ORIGMARK; + PUSHs(cat); + RETURN; +} +#undef NEXTFROM + @@ -1089,9 +1089,12 @@ STATIC struct perl_thread * S_init_main_thread(pTHX); #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len); STATIC SV* S_refto(pTHX_ SV* sv); STATIC U32 S_seed(pTHX); +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len); STATIC SV* S_mul128(pTHX_ SV *sv, U8 m); STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l); STATIC int S_div128(pTHX_ SV *pnum, bool *done); @@ -5,10 +5,17 @@ * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - */ - -/* * "I wonder what the Entish is for 'yes' and 'no'," he thought. + * + * + * Manipulation of scalar values (SVs). This file contains the code that + * creates, manipulates and destroys SVs. (Opcode-level functions on SVs + * can be found in the various pp*.c files.) Note that the basic structure + * of an SV is also used to hold the other major Perl data types - AVs, + * HVs, GVs, IO etc. Low-level functions on these other types - such as + * memory allocation and destruction - are handled within this file, while + * higher-level stuff can be found in the individual files av.c, hv.c, + * etc. */ #include "EXTERN.h" @@ -18,12 +25,110 @@ #define FCALL *f #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) -static void do_report_used(pTHXo_ SV *sv); -static void do_clean_objs(pTHXo_ SV *sv); -#ifndef DISABLE_DESTRUCTOR_KLUDGE -static void do_clean_named_objs(pTHXo_ SV *sv); -#endif -static void do_clean_all(pTHXo_ SV *sv); + +/* ============================================================================ + +=head1 Allocation and deallocation of SVs. + +An SV (or AV, HV etc) is in 2 parts: the head and the body. There is only +one type of head, but around 13 body types. Head and body are each +separately allocated. Normally, this allocation is done using arenas, +which are approximately 1K chunks of memory parcelled up into N heads or +bodies. The first slot in each arena is reserved, and is used to hold a +link to the next arena. In the case of heads, the unused first slot +also contains some flags and a note of the number of slots. Snaked through +each arena chain is a linked list of free items; when this becomes empty, +an extra arena is allocated and divided up into N items which are threaded +into the free list. + +The following global variables are associated with arenas: + + PL_sv_arenaroot pointer to list of SV arenas + PL_sv_root pointer to list of free SV structures + + PL_foo_arenaroot pointer to list of foo arenas, + PL_foo_root pointer to list of free foo bodies + ... for foo in xiv, xnv, xrv, xpv etc. + +Note that some of the larger and more rarely used body types (eg xpvio) +are not allocated using arenas, but are instead just malloc()/free()ed as +required. Also, if PURIFY is defined, arenas are abandoned altogether, +with all items individually malloc()ed. In addition, a few SV heads are +not allocated from an arena, but are instead directly created as static +or auto variables, eg PL_sv_undef. + +The SV arena serves the secondary purpose of allowing still-live SVs +to be located and destroyed during final cleanup. + +At the lowest level, the macros new_SV() and del_SV() grab and free +an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() +to return the SV to the free list with error checking.) new_SV() calls +more_sv() / sv_add_arena() to add an extra arena if the free list is empty. +SVs in the free list have their SvTYPE field set to all ones. + +Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc +that allocate and return individual body types. Normally these are mapped +to the arena-maniplulating functions new_xiv()/del_xiv() etc, but may be +instead mapped directly to malloc()/free() if PURIFY is in effect. The +new/del functions remove from, or add to, the appropriate PL_foo_root +list, and call more_xiv() etc to add a new arena if the list is empty. + +It the time of very final cleanup, sv_free_arenas() is called from +perl_destruct() to physically free all the arenas allocated since the +start of the interpreter. Note that this also clears PL_he_arenaroot, +which is otherwise dealt with in hv.c. + +Manipulation of any of the PL_*root pointers is protected by enclosing +LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing +if threads are enabled. + +The function visit() scans the SV arenas list, and calls a specified +function for each SV it finds which is still live - ie which has an SvTYPE +other than all 1's, and a non-zero SvREFCNT. visit() is used by the +following functions (specified as [function that calls visit()] / [function +called by visit() for each SV]): + + sv_report_used() / do_report_used() + dump all remaining SVs (debugging aid) + + sv_clean_objs() / do_clean_objs(),do_clean_named_objs() + Attempt to free all objects pointed to by RVs, + and, unless DISABLE_DESTRUCTOR_KLUDGE is defined, + try to do the same for all objects indirectly + referenced by typeglobs too. Called once from + perl_destruct(), prior to calling sv_clean_all() + below. + + sv_clean_all() / do_clean_all() + SvREFCNT_dec(sv) each remaining SV, possibly + triggering an sv_free(). It also sets the + SVf_BREAK flag on the SV to indicate that the + refcnt has been artificially lowered, and thus + stopping sv_free() from giving spurious warnings + about SVs which unexpectedly have a refcnt + of zero. called repeatedly from perl_destruct() + until there are no SVs left. + +=head2 Summary + +Private API to rest of sv.c + + new_SV(), del_SV(), + + new_XIV(), del_XIV(), + new_XNV(), del_XNV(), + etc + +Public API: + + sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() + + +=cut + +============================================================================ */ + + /* * "A time to plant, and a time to uproot what was planted..." @@ -45,6 +150,9 @@ static void do_clean_all(pTHXo_ SV *sv); ++PL_sv_count; \ } STMT_END + +/* new_SV(): return a new, empty SV head */ + #define new_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ @@ -58,6 +166,9 @@ static void do_clean_all(pTHXo_ SV *sv); SvFLAGS(p) = 0; \ } STMT_END + +/* del_SV(): return an empty SV head to the free list */ + #ifdef DEBUGGING #define del_SV(p) \ @@ -101,6 +212,16 @@ S_del_sv(pTHX_ SV *p) #endif /* DEBUGGING */ + +/* +=for apidoc sv_add_arena + +Given a chunk of memory, link it to the head of the list of arenas, +and split it into a list of free SVs. + +=cut +*/ + void Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { @@ -128,6 +249,8 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) SvFLAGS(sv) = SVTYPEMASK; } +/* make some more SVs by adding another arena */ + /* sv_mutex must be held while calling more_sv() */ STATIC SV* S_more_sv(pTHX) @@ -148,6 +271,8 @@ S_more_sv(pTHX) return sv; } +/* visit(): call the named function for each non-free in SV the arenas. */ + STATIC I32 S_visit(pTHX_ SVFUNC_t f) { @@ -168,12 +293,82 @@ S_visit(pTHX_ SVFUNC_t f) return visited; } +/* called by sv_report_used() for each live SV */ + +static void +do_report_used(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) != SVTYPEMASK) { + PerlIO_printf(Perl_debug_log, "****\n"); + sv_dump(sv); + } +} + +/* +=for apidoc sv_report_used + +Dump the contents of all SVs not yet freed. (Debugging aid). + +=cut +*/ + void Perl_sv_report_used(pTHX) { visit(do_report_used); } +/* called by sv_clean_objs() for each live SV */ + +static void +do_clean_objs(pTHXo_ SV *sv) +{ + SV* rv; + + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv))); + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + } else { + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } + } + + /* XXX Might want to check arrays, etc. */ +} + +/* called by sv_clean_objs() for each live SV */ + +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void +do_clean_named_objs(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { + if ( SvOBJECT(GvSV(sv)) || + (GvAV(sv) && SvOBJECT(GvAV(sv))) || + (GvHV(sv) && SvOBJECT(GvHV(sv))) || + (GvIO(sv) && SvOBJECT(GvIO(sv))) || + (GvCV(sv) && SvOBJECT(GvCV(sv))) ) + { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); + SvREFCNT_dec(sv); + } + } +} +#endif + +/* +=for apidoc sv_clean_objs + +Attempt to destroy all objects not yet freed + +=cut +*/ + void Perl_sv_clean_objs(pTHX) { @@ -186,6 +381,26 @@ Perl_sv_clean_objs(pTHX) PL_in_clean_objs = FALSE; } +/* called by sv_clean_all() for each live SV */ + +static void +do_clean_all(pTHXo_ SV *sv) +{ + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); +} + +/* +=for apidoc sv_clean_all + +Decrement the refcnt of each remaining SV, possibly triggering a +cleanup. This function may have to be called multiple times to free +SVs which are in complex self-referential heirarchies. + +=cut +*/ + I32 Perl_sv_clean_all(pTHX) { @@ -196,6 +411,15 @@ Perl_sv_clean_all(pTHX) return cleaned; } +/* +=for apidoc sv_free_arenas + +Deallocate the memory used by all arenas. Note that all the individual SV +heads and bodies within the arenas must already have been freed. + +=cut +*/ + void Perl_sv_free_arenas(pTHX) { @@ -301,6 +525,14 @@ Perl_sv_free_arenas(pTHX) PL_sv_root = 0; } +/* +=for apidoc report_uninit + +Print appropriate "Use of uninitialized variable" warning + +=cut +*/ + void Perl_report_uninit(pTHX) { @@ -311,6 +543,8 @@ Perl_report_uninit(pTHX) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); } +/* grab a new IV body from the free list, allocating more if necessary */ + STATIC XPVIV* S_new_xiv(pTHX) { @@ -327,6 +561,8 @@ S_new_xiv(pTHX) return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } +/* return an IV body to the free list */ + STATIC void S_del_xiv(pTHX_ XPVIV *p) { @@ -337,6 +573,8 @@ S_del_xiv(pTHX_ XPVIV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of IV bodies */ + STATIC void S_more_xiv(pTHX) { @@ -344,12 +582,12 @@ S_more_xiv(pTHX) register IV* xivend; XPV* ptr; New(705, ptr, 1008/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ + ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ PL_xiv_arenaroot = ptr; /* to keep Purify happy */ xiv = (IV*) ptr; xivend = &xiv[1008 / sizeof(IV) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ + xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ PL_xiv_root = xiv; while (xiv < xivend) { *(IV**)xiv = (IV *)(xiv + 1); @@ -358,6 +596,8 @@ S_more_xiv(pTHX) *(IV**)xiv = 0; } +/* grab a new NV body from the free list, allocating more if necessary */ + STATIC XPVNV* S_new_xnv(pTHX) { @@ -371,6 +611,8 @@ S_new_xnv(pTHX) return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } +/* return an NV body to the free list */ + STATIC void S_del_xnv(pTHX_ XPVNV *p) { @@ -381,6 +623,8 @@ S_del_xnv(pTHX_ XPVNV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of NV bodies */ + STATIC void S_more_xnv(pTHX) { @@ -402,6 +646,8 @@ S_more_xnv(pTHX) *(NV**)xnv = 0; } +/* grab a new struct xrv from the free list, allocating more if necessary */ + STATIC XRV* S_new_xrv(pTHX) { @@ -415,6 +661,8 @@ S_new_xrv(pTHX) return xrv; } +/* return a struct xrv to the free list */ + STATIC void S_del_xrv(pTHX_ XRV *p) { @@ -424,6 +672,8 @@ S_del_xrv(pTHX_ XRV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xrv */ + STATIC void S_more_xrv(pTHX) { @@ -445,6 +695,8 @@ S_more_xrv(pTHX) xrv->xrv_rv = 0; } +/* grab a new struct xpv from the free list, allocating more if necessary */ + STATIC XPV* S_new_xpv(pTHX) { @@ -458,6 +710,8 @@ S_new_xpv(pTHX) return xpv; } +/* return a struct xpv to the free list */ + STATIC void S_del_xpv(pTHX_ XPV *p) { @@ -467,6 +721,8 @@ S_del_xpv(pTHX_ XPV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpv */ + STATIC void S_more_xpv(pTHX) { @@ -485,6 +741,8 @@ S_more_xpv(pTHX) xpv->xpv_pv = 0; } +/* grab a new struct xpviv from the free list, allocating more if necessary */ + STATIC XPVIV* S_new_xpviv(pTHX) { @@ -498,6 +756,8 @@ S_new_xpviv(pTHX) return xpviv; } +/* return a struct xpviv to the free list */ + STATIC void S_del_xpviv(pTHX_ XPVIV *p) { @@ -507,6 +767,8 @@ S_del_xpviv(pTHX_ XPVIV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpviv */ + STATIC void S_more_xpviv(pTHX) { @@ -525,6 +787,8 @@ S_more_xpviv(pTHX) xpviv->xpv_pv = 0; } +/* grab a new struct xpvnv from the free list, allocating more if necessary */ + STATIC XPVNV* S_new_xpvnv(pTHX) { @@ -538,6 +802,8 @@ S_new_xpvnv(pTHX) return xpvnv; } +/* return a struct xpvnv to the free list */ + STATIC void S_del_xpvnv(pTHX_ XPVNV *p) { @@ -547,6 +813,8 @@ S_del_xpvnv(pTHX_ XPVNV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvnv */ + STATIC void S_more_xpvnv(pTHX) { @@ -565,6 +833,8 @@ S_more_xpvnv(pTHX) xpvnv->xpv_pv = 0; } +/* grab a new struct xpvcv from the free list, allocating more if necessary */ + STATIC XPVCV* S_new_xpvcv(pTHX) { @@ -578,6 +848,8 @@ S_new_xpvcv(pTHX) return xpvcv; } +/* return a struct xpvcv to the free list */ + STATIC void S_del_xpvcv(pTHX_ XPVCV *p) { @@ -587,6 +859,8 @@ S_del_xpvcv(pTHX_ XPVCV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvcv */ + STATIC void S_more_xpvcv(pTHX) { @@ -605,6 +879,8 @@ S_more_xpvcv(pTHX) xpvcv->xpv_pv = 0; } +/* grab a new struct xpvav from the free list, allocating more if necessary */ + STATIC XPVAV* S_new_xpvav(pTHX) { @@ -618,6 +894,8 @@ S_new_xpvav(pTHX) return xpvav; } +/* return a struct xpvav to the free list */ + STATIC void S_del_xpvav(pTHX_ XPVAV *p) { @@ -627,6 +905,8 @@ S_del_xpvav(pTHX_ XPVAV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvav */ + STATIC void S_more_xpvav(pTHX) { @@ -645,6 +925,8 @@ S_more_xpvav(pTHX) xpvav->xav_array = 0; } +/* grab a new struct xpvhv from the free list, allocating more if necessary */ + STATIC XPVHV* S_new_xpvhv(pTHX) { @@ -658,6 +940,8 @@ S_new_xpvhv(pTHX) return xpvhv; } +/* return a struct xpvhv to the free list */ + STATIC void S_del_xpvhv(pTHX_ XPVHV *p) { @@ -667,6 +951,8 @@ S_del_xpvhv(pTHX_ XPVHV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvhv */ + STATIC void S_more_xpvhv(pTHX) { @@ -685,6 +971,8 @@ S_more_xpvhv(pTHX) xpvhv->xhv_array = 0; } +/* grab a new struct xpvmg from the free list, allocating more if necessary */ + STATIC XPVMG* S_new_xpvmg(pTHX) { @@ -698,6 +986,8 @@ S_new_xpvmg(pTHX) return xpvmg; } +/* return a struct xpvmg to the free list */ + STATIC void S_del_xpvmg(pTHX_ XPVMG *p) { @@ -707,6 +997,8 @@ S_del_xpvmg(pTHX_ XPVMG *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvmg */ + STATIC void S_more_xpvmg(pTHX) { @@ -725,6 +1017,8 @@ S_more_xpvmg(pTHX) xpvmg->xpv_pv = 0; } +/* grab a new struct xpvlv from the free list, allocating more if necessary */ + STATIC XPVLV* S_new_xpvlv(pTHX) { @@ -738,6 +1032,8 @@ S_new_xpvlv(pTHX) return xpvlv; } +/* return a struct xpvlv to the free list */ + STATIC void S_del_xpvlv(pTHX_ XPVLV *p) { @@ -747,6 +1043,8 @@ S_del_xpvlv(pTHX_ XPVLV *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvlv */ + STATIC void S_more_xpvlv(pTHX) { @@ -765,6 +1063,8 @@ S_more_xpvlv(pTHX) xpvlv->xpv_pv = 0; } +/* grab a new struct xpvbm from the free list, allocating more if necessary */ + STATIC XPVBM* S_new_xpvbm(pTHX) { @@ -778,6 +1078,8 @@ S_new_xpvbm(pTHX) return xpvbm; } +/* return a struct xpvbm to the free list */ + STATIC void S_del_xpvbm(pTHX_ XPVBM *p) { @@ -787,6 +1089,8 @@ S_del_xpvbm(pTHX_ XPVBM *p) UNLOCK_SV_MUTEX; } +/* allocate another arena's worth of struct xpvbm */ + STATIC void S_more_xpvbm(pTHX) { @@ -903,8 +1207,9 @@ S_more_xpvbm(pTHX) /* =for apidoc sv_upgrade -Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See -C<svtype>. +Upgrade an SV to a more complex form. Gnenerally adds a new body type to the +SV, then copies across as much information as possible from the old body. +You genrally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>. =cut */ @@ -1187,6 +1492,15 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) return TRUE; } +/* +=for apidoc sv_backoff + +Remove any string offset. You should normally use the C<SvOOK_off> macro +wrapper instead. + +=cut +*/ + int Perl_sv_backoff(pTHX_ register SV *sv) { @@ -1205,9 +1519,9 @@ Perl_sv_backoff(pTHX_ register SV *sv) /* =for apidoc sv_grow -Expands the character buffer in the SV. This will use C<sv_unref> and will -upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer. -Use C<SvGROW>. +Expands the character buffer in the SV. If necessary, uses C<sv_unref> and +upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. +Use the C<SvGROW> wrapper instead. =cut */ @@ -1264,8 +1578,8 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) /* =for apidoc sv_setiv -Copies an integer into the given SV. Does not handle 'set' magic. See -C<sv_setiv_mg>. +Copies an integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setiv_mg>. =cut */ @@ -1318,8 +1632,8 @@ Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) /* =for apidoc sv_setuv -Copies an unsigned integer into the given SV. Does not handle 'set' magic. -See C<sv_setuv_mg>. +Copies an unsigned integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setuv_mg>. =cut */ @@ -1376,8 +1690,8 @@ Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) /* =for apidoc sv_setnv -Copies a double into the given SV. Does not handle 'set' magic. See -C<sv_setnv_mg>. +Copies a double into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C<sv_setnv_mg>. =cut */ @@ -1426,6 +1740,10 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) SvSETMAGIC(sv); } +/* Print an "isn't numeric" warning, using a cleaned-up, + * printable version of the offending string + */ + STATIC void S_not_a_number(pTHX_ SV *sv) { @@ -1489,9 +1807,9 @@ S_not_a_number(pTHX_ SV *sv) /* =for apidoc looks_like_number -Test if an the content of an SV looks like a number (or is a -number). C<Inf> and C<Infinity> are treated as numbers (so will not -issue a non-numeric warning), even if your atof() doesn't grok them. +Test if the content of an SV looks like a number (or is a number). +C<Inf> and C<Infinity> are treated as numbers (so will not issue a +non-numeric warning), even if your atof() doesn't grok them. =cut */ @@ -1516,17 +1834,20 @@ Perl_looks_like_number(pTHX_ SV *sv) /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ -/* As 64 bit platforms often have an NV that doesn't preserve all bits of +/* + NV_PRESERVES_UV: + + As 64 bit platforms often have an NV that doesn't preserve all bits of an IV (an assumption perl has been based on to date) it becomes necessary to remove the assumption that the NV always carries enough precision to recreate the IV whenever needed, and that the NV is the canonical form. Instead, IV/UV and NV need to be given equal rights. So as to not lose - precision as an side effect of conversion (which would lead to insanity + precision as a side effect of conversion (which would lead to insanity and the dragon(s) in t/op/numconvert.t getting very angry) the intent is 1) to distinguish between IV/UV/NV slots that have cached a valid conversion where precision was lost and IV/UV/NV slots that have a valid conversion which has lost no precision - 2) to ensure that if a numeric conversion to one form is request that + 2) to ensure that if a numeric conversion to one form is requested that would lose precision, the precise conversion (or differently imprecise conversion) is also performed and cached, to prevent requests for different numeric formats on the same SV causing @@ -1541,59 +1862,61 @@ Perl_looks_like_number(pTHX_ SV *sv) SvNOK is true only if the NV value is accurate so - while converting from PV to NV check to see if converting that NV to an + while converting from PV to NV, check to see if converting that NV to an IV(or UV) would lose accuracy over a direct conversion from PV to IV(or UV). If it would, cache both conversions, return NV, but mark SV as IOK NOKp (ie not NOK). - while converting from PV to IV check to see if converting that IV to an + While converting from PV to IV, check to see if converting that IV to an NV would lose accuracy over a direct conversion from PV to NV. If it would, cache both conversions, flag similarly. Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite correctly because if IV & NV were set NV *always* overruled. - Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning - changes - now IV and NV together means that the two are interchangeable + Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning + changes - now IV and NV together means that the two are interchangeable: SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; - The benefit of this is operations such as pp_add know that if SvIOK is - true for both left and right operands, then integer addition can be - used instead of floating point. (for cases where the result won't - overflow) Before, floating point was always used, which could lead to + The benefit of this is that operations such as pp_add know that if + SvIOK is true for both left and right operands, then integer addition + can be used instead of floating point (for cases where the result won't + overflow). Before, floating point was always used, which could lead to loss of precision compared with integer addition. * making IV and NV equal status should make maths accurate on 64 bit platforms * may speed up maths somewhat if pp_add and friends start to use - integers when possible instead of fp. (hopefully the overhead in + integers when possible instead of fp. (Hopefully the overhead in looking for SvIOK and checking for overflow will not outweigh the fp to integer speedup) * will slow down integer operations (callers of SvIV) on "inaccurate" values, as the change from SvIOK to SvIOKp will cause a call into sv_2iv each time rather than a macro access direct to the IV slot * should speed up number->string conversion on integers as IV is - favoured when IV and NV equally accurate + favoured when IV and NV are equally accurate #################################################################### - You had better be using SvIOK_notUV if you want an IV for arithmetic - SvIOK is true if (IV or UV), so you might be getting (IV)SvUV - SvUOK is true iff UV. + You had better be using SvIOK_notUV if you want an IV for arithmetic: + SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. + On the other hand, SvUOK is true iff UV. #################################################################### - Your mileage will vary depending your CPUs relative fp to integer + Your mileage will vary depending your CPU's relative fp to integer performance ratio. */ #ifndef NV_PRESERVES_UV -#define IS_NUMBER_UNDERFLOW_IV 1 -#define IS_NUMBER_UNDERFLOW_UV 2 -#define IS_NUMBER_IV_AND_UV 2 -#define IS_NUMBER_OVERFLOW_IV 4 -#define IS_NUMBER_OVERFLOW_UV 5 +# define IS_NUMBER_UNDERFLOW_IV 1 +# define IS_NUMBER_UNDERFLOW_UV 2 +# define IS_NUMBER_IV_AND_UV 2 +# define IS_NUMBER_OVERFLOW_IV 4 +# define IS_NUMBER_OVERFLOW_UV 5 + +/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ STATIC int -S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype) +S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { @@ -1637,7 +1960,16 @@ S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype) } return IS_NUMBER_OVERFLOW_IV; } -#endif /* NV_PRESERVES_UV*/ +#endif /* !NV_PRESERVES_UV*/ + +/* +=for apidoc sv_2iv + +Return the integer value of an SV, doing any necessary string conversion, +magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. + +=cut +*/ IV Perl_sv_2iv(pTHX_ register SV *sv) @@ -1927,6 +2259,16 @@ Perl_sv_2iv(pTHX_ register SV *sv) return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } +/* +=for apidoc sv_2uv + +Return the unsigned integer value of an SV, doing any necessary string +conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> +macros. + +=cut +*/ + UV Perl_sv_2uv(pTHX_ register SV *sv) { @@ -2197,6 +2539,16 @@ Perl_sv_2uv(pTHX_ register SV *sv) return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } +/* +=for apidoc sv_2nv + +Return the num value of an SV, doing any necessary string or integer +conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> +macros. + +=cut +*/ + NV Perl_sv_2nv(pTHX_ register SV *sv) { @@ -2396,7 +2748,9 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } -/* Caller must validate PVX */ +/* asIV(): extract an integer from the string value of an SV. + * Caller must validate PVX */ + STATIC IV S_asIV(pTHX_ SV *sv) { @@ -2405,7 +2759,7 @@ S_asIV(pTHX_ SV *sv) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer */ + /* It's definitely an integer */ if (numtype & IS_NUMBER_NEG) { if (value < (UV)IV_MIN) return -(IV)value; @@ -2421,6 +2775,9 @@ S_asIV(pTHX_ SV *sv) return I_V(Atof(SvPVX(sv))); } +/* asUV(): extract an unsigned integer from the string value of an SV + * Caller must validate PVX */ + STATIC UV S_asUV(pTHX_ SV *sv) { @@ -2429,7 +2786,7 @@ S_asUV(pTHX_ SV *sv) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer */ + /* It's definitely an integer */ if (!(numtype & IS_NUMBER_NEG)) return value; } @@ -2440,6 +2797,14 @@ S_asUV(pTHX_ SV *sv) return U_V(Atof(SvPVX(sv))); } +/* +=for apidoc sv_2pv_nolen + +Like C<sv_2pv()>, but doesn't return the length too. You should usually +use the macro wrapper C<SvPV_nolen(sv)> instead. +=cut +*/ + char * Perl_sv_2pv_nolen(pTHX_ register SV *sv) { @@ -2447,7 +2812,13 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv) return sv_2pv(sv, &n_a); } -/* We assume that buf is at least TYPE_CHARS(UV) long. */ +/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or + * UV as a string towards the end of buf, and return pointers to start and + * end of it. + * + * We assume that buf is at least TYPE_CHARS(UV) long. + */ + static char * uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) { @@ -2473,12 +2844,28 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } +/* For backwards-compatibility only. sv_2pv() is normally #def'ed to + * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>. + */ + char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { return sv_2pv_flags(sv, lp, SV_GMAGIC); } +/* +=for apidoc sv_2pv_flags + +Returns pointer to the string value of an SV, and sets *lp to its length. +If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string +if necessary. +Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg> +usually end up here too. + +=cut +*/ + char * Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { @@ -2725,6 +3112,17 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } +/* +=for apidoc sv_2pvbyte_nolen + +Return a pointer to the byte-encoded representation of the SV. +May cause the SV to be downgraded from UTF8 as a side-effect. + +Usually accessed via the C<SvPVbyte_nolen> macro. + +=cut +*/ + char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) { @@ -2732,6 +3130,18 @@ Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) return sv_2pvbyte(sv, &n_a); } +/* +=for apidoc sv_2pvbyte + +Return a pointer to the byte-encoded representation of the SV, and set *lp +to its length. May cause the SV to be downgraded from UTF8 as a +side-effect. + +Usually accessed via the C<SvPVbyte> macro. + +=cut +*/ + char * Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { @@ -2739,6 +3149,17 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) return SvPV(sv,*lp); } +/* +=for apidoc sv_2pvutf8_nolen + +Return a pointer to the UTF8-encoded representation of the SV. +May cause the SV to be upgraded to UTF8 as a side-effect. + +Usually accessed via the C<SvPVutf8_nolen> macro. + +=cut +*/ + char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) { @@ -2746,6 +3167,17 @@ Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) return sv_2pvutf8(sv, &n_a); } +/* +=for apidoc sv_2pvutf8 + +Return a pointer to the UTF8-encoded representation of the SV, and set *lp +to its length. May cause the SV to be upgraded to UTF8 as a side-effect. + +Usually accessed via the C<SvPVutf8> macro. + +=cut +*/ + char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { @@ -2753,7 +3185,15 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) return SvPV(sv,*lp); } -/* This function is only called on magical items */ +/* +=for apidoc sv_2bool + +This function is only called on magical items, and is only used by +sv_true() or its macro equivalent. + +=cut +*/ + bool Perl_sv_2bool(pTHX_ register SV *sv) { @@ -2795,7 +3235,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) =for apidoc sv_utf8_upgrade Convert the PV of an SV to its UTF8-encoded form. -Forces the SV to string form it it is not already. +Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. @@ -2812,7 +3252,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv) =for apidoc sv_utf8_upgrade_flags Convert the PV of an SV to its UTF8-encoded form. -Forces the SV to string form it it is not already. +Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and @@ -2954,14 +3394,12 @@ Perl_sv_utf8_encode(pTHX_ register SV *sv) =for apidoc sv_utf8_decode Convert the octets in the PV from UTF-8 to chars. Scan for validity and then -turn of SvUTF8 if needed so that we see characters. Used as a building block +turn off SvUTF8 if needed so that we see characters. Used as a building block for decode_utf8 in Encode.xs =cut */ - - bool Perl_sv_utf8_decode(pTHX_ register SV *sv) { @@ -2969,8 +3407,10 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) U8 *c; U8 *e; - /* The octets may have got themselves encoded - get them back as bytes */ - if (!sv_utf8_downgrade(sv, TRUE)) + /* The octets may have got themselves encoded - get them back as + * bytes + */ + if (!sv_utf8_downgrade(sv, TRUE)) return FALSE; /* it is actually just a matter of turning the utf8 flag on, but @@ -2991,19 +3431,19 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return TRUE; } - -/* Note: sv_setsv() should not be called with a source string that needs - * to be reused, since it may destroy the source string if it is marked - * as temporary. - */ - /* =for apidoc sv_setsv -Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. -The source SV may be destroyed if it is mortal. Does not handle 'set' -magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and -C<sv_setsv_mg>. +Copies the contents of the source SV C<ssv> into the destination SV +C<dsv>. The source SV may be destroyed if it is mortal, so don't use this +function if the source SV needs to be reused. Does not handle 'set' magic. +Loosely speaking, it performs a copy-by-value, obliterating any previous +content of the destination. + +You probably want to use one of the assortment of wrappers, such as +C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and +C<SvSetMagicSV_nosteal>. + =cut */ @@ -3020,11 +3460,21 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) /* =for apidoc sv_setsv_flags -Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. -The source SV may be destroyed if it is mortal. Does not handle 'set' -magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if -appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented -in terms of this function. +Copies the contents of the source SV C<ssv> into the destination SV +C<dsv>. The source SV may be destroyed if it is mortal, so don't use this +function if the source SV needs to be reused. Does not handle 'set' magic. +Loosely speaking, it performs a copy-by-value, obliterating any previous +content of the destination. +If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on +C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are +implemented in terms of this function. + +You probably want to use one of the assortment of wrappers, such as +C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and +C<SvSetMagicSV_nosteal>. + +This is the primary function for copying scalars, and most other +copy-ish functions and macros use this underneath. =cut */ @@ -3376,7 +3826,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvREFCNT(sstr) == 1 && /* and no other references to it? */ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ SvLEN(sstr) && /* and really is a string */ - !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */ + /* and won't be needed again, potentially */ + !(PL_op && PL_op->op_type == OP_AASSIGN)) { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { @@ -3392,16 +3843,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvCUR_set(dstr, SvCUR(sstr)); SvTEMP_off(dstr); - (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); SvTEMP_off(sstr); } - else { /* have to copy actual string */ + else { /* have to copy actual string */ STRLEN len = SvCUR(sstr); - SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ + SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ Move(SvPVX(sstr),SvPVX(dstr),len,char); SvCUR_set(dstr, len); *SvEND(dstr) = '\0'; @@ -3625,6 +4076,17 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len SvSETMAGIC(sv); } +/* +=for apidoc sv_force_normal_flags + +Undo various types of fakery on an SV: if the PV is a shared string, make +a private copy; if we're a ref, stop refing; if we're a glob, downgrade to +an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()> +when unrefing. C<sv_force_normal> calls this function with flags set to 0. + +=cut +*/ + void Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) { @@ -3649,6 +4111,16 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) sv_unglob(sv); } +/* +=for apidoc sv_force_normal + +Undo various types of fakery on an SV: if the PV is a shared string, make +a private copy; if we're a ref, stop refing; if we're a glob, downgrade to +an xpvmg. See also C<sv_force_normal_flags>. + +=cut +*/ + void Perl_sv_force_normal(pTHX_ register SV *sv) { @@ -3661,15 +4133,13 @@ Perl_sv_force_normal(pTHX_ register SV *sv) Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside the string buffer. The C<ptr> becomes the first character of the adjusted -string. +string. Uses the "OOK hack". =cut */ void -Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ - - +Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) { register STRLEN delta; @@ -3880,6 +4350,16 @@ Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) SvSETMAGIC(sv); } +/* +=for apidoc newSV + +Create a new null SV, or if len > 0, create a new empty SVt_PV type SV +with an initial PV allocation of len+1. Normally accessed via the C<NEWSV> +macro. + +=cut +*/ + SV * Perl_newSV(pTHX_ STRLEN len) { @@ -3893,12 +4373,13 @@ Perl_newSV(pTHX_ STRLEN len) return sv; } -/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ - /* =for apidoc sv_magic -Adds magic to an SV. +Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary, +then adds a new magic item of type C<how> to the head of the magic list. + +C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)> =cut */ @@ -3910,10 +4391,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling - /* XXX this used to be !strchr("gBf", how), which seems to - * implicity be equal to !strchr("gBf\0", how), ie \0 matches - * too. I find this suprising, but have hadded PERL_MAGIC_sv - * to the list of things to check - DAPM 19-May-01 */ && how != PERL_MAGIC_regex_global && how != PERL_MAGIC_bm && how != PERL_MAGIC_fm @@ -4086,7 +4563,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam /* =for apidoc sv_unmagic -Removes magic from an SV. +Removes all magic of type C<type> from an SV. =cut */ @@ -4129,7 +4606,10 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) /* =for apidoc sv_rvweaken -Weaken a reference. +Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the +referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and +push a back-reference to this RV onto the array of backreferences +associated with that magic. =cut */ @@ -4154,6 +4634,10 @@ Perl_sv_rvweaken(pTHX_ SV *sv) return sv; } +/* Give tsv backref magic if it hasn't already got it, then push a + * back-reference to sv onto the array associated with the backref magic. + */ + STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv) { @@ -4169,6 +4653,10 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) av_push(av,sv); } +/* delete a back-reference to ourselves from the backref magic associated + * with the SV we point to. + */ + STATIC void S_sv_del_backref(pTHX_ SV *sv) { @@ -4288,6 +4776,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN =for apidoc sv_replace Make the first argument a copy of the second, then delete the original. +The target SV physically takes over ownership of the body of the source SV +and inherits its flags; however, the target keeps any magic it owns, +and any magic in the source is discarded. +Note that this a rather specialist SV copying operation; most of the +time you'll want to use C<sv_setsv> or one of its many macro front-ends. =cut */ @@ -4321,8 +4814,13 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) /* =for apidoc sv_clear -Clear an SV, making it empty. Does not free the memory used by the SV -itself. +Clear an SV: call any destructors, free up any memory used by the body, +and free the body itself. The SV's head is I<not> freed, although +its type is set to all 1's so that it won't inadvertently be assumed +to be live during global destruction etc. +This function should only be called when REFCNT is zero. Most of the time +you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>) +instead. =cut */ @@ -4518,6 +5016,15 @@ Perl_sv_clear(pTHX_ register SV *sv) SvFLAGS(sv) |= SVTYPEMASK; } +/* +=for apidoc sv_newref + +Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper +instead. + +=cut +*/ + SV * Perl_sv_newref(pTHX_ SV *sv) { @@ -4529,7 +5036,10 @@ Perl_sv_newref(pTHX_ SV *sv) /* =for apidoc sv_free -Free the memory used by an SV. +Decrement an SV's reference count, and if it drops to zero, call +C<sv_clear> to invoke destructors and free up any memory used by +the body; finally, deallocate the SV's head itself. +Normally called via a wrapper macro C<SvREFCNT_dec>. =cut */ @@ -4543,6 +5053,8 @@ Perl_sv_free(pTHX_ SV *sv) return; if (SvREFCNT(sv) == 0) { if (SvFLAGS(sv) & SVf_BREAK) + /* this SV's refcnt has been artificially decremented to + * trigger cleanup */ return; if (PL_in_clean_all) /* All is fair */ return; @@ -4580,7 +5092,8 @@ Perl_sv_free(pTHX_ SV *sv) /* =for apidoc sv_len -Returns the length of the string in the SV. See also C<SvCUR>. +Returns the length of the string in the SV. Handles magic and type +coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot. =cut */ @@ -4605,7 +5118,7 @@ Perl_sv_len(pTHX_ register SV *sv) =for apidoc sv_len_utf8 Returns the number of characters in the string in an SV, counting wide -UTF8 bytes as a single character. +UTF8 bytes as a single character. Handles magic and type coercion. =cut */ @@ -4627,6 +5140,18 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) } } +/* +=for apidoc sv_pos_u2b + +Converts the value pointed to by offsetp from a count of UTF8 chars from +the start of the string, to a count of the equivalent number of bytes; if +lenp is non-zero, it does the same to lenp, but this time starting from +the offset, rather than from the start of the string. Handles magic and +type coercion. + +=cut +*/ + void Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { @@ -4658,6 +5183,16 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) return; } +/* +=for apidoc sv_pos_b2u + +Converts the value pointed to by offsetp from a count of bytes from the +start of the string, to a count of the equivalent number of UTF8 chars. +Handles magic and type coercion. + +=cut +*/ + void Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) { @@ -4692,7 +5227,8 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) =for apidoc sv_eq Returns a boolean indicating whether the strings in the two SVs are -identical. +identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will +coerce its args to strings if necessary. =cut */ @@ -4760,7 +5296,8 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the string in C<sv1> is less than, equal to, or greater than the string in -C<sv2>. +C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will +coerce its args to strings if necessary. See also C<sv_cmp_locale>. =cut */ @@ -4830,8 +5367,9 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) /* =for apidoc sv_cmp_locale -Compares the strings in two SVs in a locale-aware manner. See -L</sv_cmp_locale> +Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and +'use bytes' aware, handles get magic, and will coerce its args to strings +if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>. =cut */ @@ -4884,13 +5422,22 @@ Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) return sv_cmp(sv1, sv2); } + #ifdef USE_LOCALE_COLLATE + /* - * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the - * scalar data of the variable transformed to such a format that - * a normal memory comparison can be used to compare the data - * according to the locale settings. - */ +=for apidoc sv_collxfrm + +Add Collate Transform magic to an SV if it doesn't already have it. + +Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the +scalar data of the variable, but transformed to such a format that a normal +memory comparison can be used to compare the data according to the locale +settings. + +=cut +*/ + char * Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { @@ -5235,11 +5782,11 @@ screamer2: return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } - /* =for apidoc sv_inc -Auto-increment of the value in the SV. +Auto-increment of the value in the SV, doing string to numeric conversion +if necessary. Handles 'get' magic. =cut */ @@ -5391,7 +5938,8 @@ Perl_sv_inc(pTHX_ register SV *sv) /* =for apidoc sv_dec -Auto-decrement of the value in the SV. +Auto-decrement of the value in the SV, doing string to numeric conversion +if necessary. Handles 'get' magic. =cut */ @@ -5496,8 +6044,9 @@ Perl_sv_dec(pTHX_ register SV *sv) /* =for apidoc sv_mortalcopy -Creates a new SV which is a copy of the original SV. The new SV is marked -as mortal. +Creates a new SV which is a copy of the original SV (using C<sv_setsv>). +The new SV is marked as mortal. It will be destroyed when the current +context ends. See also C<sv_newmortal> and C<sv_2mortal>. =cut */ @@ -5523,7 +6072,9 @@ Perl_sv_mortalcopy(pTHX_ SV *oldstr) /* =for apidoc sv_newmortal -Creates a new SV which is mortal. The reference count of the SV is set to 1. +Creates a new null SV which is mortal. The reference count of the SV is +set to 1. It will be destroyed when the current context ends. See +also C<sv_mortalcopy> and C<sv_2mortal>. =cut */ @@ -5543,14 +6094,12 @@ Perl_sv_newmortal(pTHX) /* =for apidoc sv_2mortal -Marks an SV as mortal. The SV will be destroyed when the current context -ends. +Marks an existing SV as mortal. The SV will be destroyed when the current +context ends. See also C<sv_newmortal> and C<sv_mortalcopy>. =cut */ -/* same thing without the copying */ - SV * Perl_sv_2mortal(pTHX_ register SV *sv) { @@ -5610,11 +6159,13 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) /* =for apidoc newSVpvn_share -Creates a new SV and populates it with a string from -the string table. Turns on READONLY and FAKE. -The idea here is that as string table is used for shared hash -keys these strings will have SvPVX == HeKEY and hash lookup -will avoid string compare. +Creates a new SV with its SvPVX pointing to a shared string in the string +table. If the string does not already exist in the table, it is created +first. Turns on READONLY and FAKE. The string's hash is stored in the UV +slot of the SV; if the C<hash> parameter is non-zero, that value is used; +otherwise the hash is computed. The idea here is that as the string table +is used for shared hash keys these strings will have SvPVX == HeKEY and +hash lookup will avoid string compare. =cut */ @@ -5650,7 +6201,14 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) return sv; } + #if defined(PERL_IMPLICIT_CONTEXT) + +/* pTHX_ magic can't cope with varargs, so this is a no-context + * version of the main function, (which may itself be aliased to us). + * Don't access this version directly. + */ + SV * Perl_newSVpvf_nocontext(const char* pat, ...) { @@ -5667,7 +6225,7 @@ Perl_newSVpvf_nocontext(const char* pat, ...) /* =for apidoc newSVpvf -Creates a new SV an initialize it with the string formatted like +Creates a new SV and initializes it with the string formatted like C<sprintf>. =cut @@ -5684,6 +6242,8 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) return sv; } +/* backend for newSVpvf() and newSVpvf_nocontext() */ + SV * Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) { @@ -5772,7 +6332,10 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) return sv; } -/* newRV_inc is #defined to newRV in sv.h */ +/* newRV_inc is the offical function name to use now. + * newRV_inc is in fact #defined to newRV in sv.h + */ + SV * Perl_newRV(pTHX_ SV *tmpRef) { @@ -5783,12 +6346,11 @@ Perl_newRV(pTHX_ SV *tmpRef) =for apidoc newSVsv Creates a new SV which is an exact duplicate of the original SV. +(Uses C<sv_setsv>). =cut */ -/* make an exact duplicate of old */ - SV * Perl_newSVsv(pTHX_ register SV *old) { @@ -5812,6 +6374,15 @@ Perl_newSVsv(pTHX_ register SV *old) return sv; } +/* +=for apidoc sv_reset + +Underlying implementation for the C<reset> Perl function. +Note that the perl-level function is vaguely deprecated. + +=cut +*/ + void Perl_sv_reset(pTHX_ register char *s, HV *stash) { @@ -5884,6 +6455,16 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) } } +/* +=for apidoc sv_2io + +Using various gambits, try to get an IO from an SV: the IO slot if its a +GV; or the recursive result if we're an RV; or the IO slot of the symbol +named after the PV if we're a string. + +=cut +*/ + IO* Perl_sv_2io(pTHX_ SV *sv) { @@ -5918,6 +6499,15 @@ Perl_sv_2io(pTHX_ SV *sv) return io; } +/* +=for apidoc sv_2cv + +Using various gambits, try to get a CV from an SV; in addition, try if +possible to set C<*st> and C<*gvp> to the stash and GV associated with it. + +=cut +*/ + CV * Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { @@ -5994,6 +6584,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) =for apidoc sv_true Returns true if the SV has a true value by Perl's rules. +Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may +instead use an in-line version. =cut */ @@ -6024,6 +6616,15 @@ Perl_sv_true(pTHX_ register SV *sv) } } +/* +=for apidoc sv_iv + +A private implementation of the C<SvIVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + +=cut +*/ + IV Perl_sv_iv(pTHX_ register SV *sv) { @@ -6035,6 +6636,15 @@ Perl_sv_iv(pTHX_ register SV *sv) return sv_2iv(sv); } +/* +=for apidoc sv_uv + +A private implementation of the C<SvUVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + +=cut +*/ + UV Perl_sv_uv(pTHX_ register SV *sv) { @@ -6046,6 +6656,15 @@ Perl_sv_uv(pTHX_ register SV *sv) return sv_2uv(sv); } +/* +=for apidoc sv_nv + +A private implementation of the C<SvNVx> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + +=cut +*/ + NV Perl_sv_nv(pTHX_ register SV *sv) { @@ -6054,6 +6673,15 @@ Perl_sv_nv(pTHX_ register SV *sv) return sv_2nv(sv); } +/* +=for apidoc sv_pv + +A private implementation of the C<SvPV_nolen> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + +=cut +*/ + char * Perl_sv_pv(pTHX_ SV *sv) { @@ -6065,6 +6693,15 @@ Perl_sv_pv(pTHX_ SV *sv) return sv_2pv(sv, &n_a); } +/* +=for apidoc sv_pvn + +A private implementation of the C<SvPV> macro for compilers which can't +cope with complex macro expressions. Always use the macro instead. + +=cut +*/ + char * Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) { @@ -6079,6 +6716,8 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) =for apidoc sv_pvn_force Get a sensible string out of the SV somehow. +A private implementation of the C<SvPV_force> macro for compilers which +can't cope with complex macro expressions. Always use the macro instead. =cut */ @@ -6096,6 +6735,8 @@ Get a sensible string out of the SV somehow. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are implemented in terms of this function. +You normally want to use the various wrapper macros instead: see +C<SvPV_force> and C<SvPV_force_nomg> =cut */ @@ -6139,6 +6780,16 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) return SvPVX(sv); } +/* +=for apidoc sv_pvbyte + +A private implementation of the C<SvPVbyte_nolen> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + +=cut +*/ + char * Perl_sv_pvbyte(pTHX_ SV *sv) { @@ -6146,6 +6797,16 @@ Perl_sv_pvbyte(pTHX_ SV *sv) return sv_pv(sv); } +/* +=for apidoc sv_pvbyten + +A private implementation of the C<SvPVbyte> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + +=cut +*/ + char * Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) { @@ -6153,6 +6814,16 @@ Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) return sv_pvn(sv,lp); } +/* +=for apidoc sv_pvbyten_force + +A private implementation of the C<SvPVbytex_force> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + +=cut +*/ + char * Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) { @@ -6160,6 +6831,16 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) return sv_pvn_force(sv,lp); } +/* +=for apidoc sv_pvutf8 + +A private implementation of the C<SvPVutf8_nolen> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + +=cut +*/ + char * Perl_sv_pvutf8(pTHX_ SV *sv) { @@ -6167,6 +6848,16 @@ Perl_sv_pvutf8(pTHX_ SV *sv) return sv_pv(sv); } +/* +=for apidoc sv_pvutf8n + +A private implementation of the C<SvPVutf8> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. + +=cut +*/ + char * Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) { @@ -6177,8 +6868,9 @@ Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) /* =for apidoc sv_pvutf8n_force -Get a sensible UTF8-encoded string out of the SV somehow. See -L</sv_pvn_force>. +A private implementation of the C<SvPVutf8_force> macro for compilers +which can't cope with complex macro expressions. Always use the macro +instead. =cut */ @@ -6480,6 +7172,12 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) return sv; } +/* Downgrades a PVGV to a PVMG. + * + * XXX This function doesn't actually appear to be used anywhere + * DAPM 15-Jun-01 + */ + STATIC void S_sv_unglob(pTHX_ SV *sv) { @@ -6557,12 +7255,26 @@ Perl_sv_unref(pTHX_ SV *sv) sv_unref_flags(sv, 0); } +/* +=for apidoc sv_taint + +Taint an SV. Use C<SvTAINTED_on> instead. +=cut +*/ + void Perl_sv_taint(pTHX_ SV *sv) { sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0); } +/* +=for apidoc sv_untaint + +Untaint an SV. Use C<SvTAINTED_off> instead. +=cut +*/ + void Perl_sv_untaint(pTHX_ SV *sv) { @@ -6573,6 +7285,13 @@ Perl_sv_untaint(pTHX_ SV *sv) } } +/* +=for apidoc sv_tainted + +Test an SV for taintedness. Use C<SvTAINTED> instead. +=cut +*/ + bool Perl_sv_tainted(pTHX_ SV *sv) { @@ -6603,7 +7322,6 @@ Perl_sv_setpviv(pTHX_ SV *sv, IV iv) sv_setpvn(sv, ptr, ebuf - ptr); } - /* =for apidoc sv_setpviv_mg @@ -6624,6 +7342,12 @@ Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) } #if defined(PERL_IMPLICIT_CONTEXT) + +/* pTHX_ magic can't cope with varargs, so this is a no-context + * version of the main function, (which may itself be aliased to us). + * Don't access this version directly. + */ + void Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) { @@ -6634,6 +7358,10 @@ Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) va_end(args); } +/* pTHX_ magic can't cope with varargs, so this is a no-context + * version of the main function, (which may itself be aliased to us). + * Don't access this version directly. + */ void Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) @@ -6664,6 +7392,8 @@ Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) va_end(args); } +/* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */ + void Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) { @@ -6687,6 +7417,8 @@ Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) va_end(args); } +/* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */ + void Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) { @@ -6695,6 +7427,12 @@ Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) } #if defined(PERL_IMPLICIT_CONTEXT) + +/* pTHX_ magic can't cope with varargs, so this is a no-context + * version of the main function, (which may itself be aliased to us). + * Don't access this version directly. + */ + void Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) { @@ -6705,6 +7443,11 @@ Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) va_end(args); } +/* pTHX_ magic can't cope with varargs, so this is a no-context + * version of the main function, (which may itself be aliased to us). + * Don't access this version directly. + */ + void Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) { @@ -6738,6 +7481,8 @@ Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) va_end(args); } +/* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */ + void Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) { @@ -6761,6 +7506,8 @@ Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) va_end(args); } +/* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */ + void Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) { @@ -6774,6 +7521,8 @@ Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) Works like C<vcatpvfn> but copies the text into the SV instead of appending it. +Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>. + =cut */ @@ -6784,6 +7533,8 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } +/* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */ + STATIC I32 S_expect_number(pTHX_ char** pattern) { @@ -6808,6 +7559,8 @@ missing (NULL). When running with taint checks enabled, indicates via C<maybe_tainted> if results are untrustworthy (often due to the use of locales). +Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>. + =cut */ @@ -7541,6 +8294,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } +/* ========================================================================= + +=head1 Cloning an interpreter + +All the macros and functions in this section are for the private use of +the main function, perl_clone(). + +The foo_dup() functions make an exact copy of an existing foo thinngy. +During the course of a cloning, a hash table is used to map old addresses +to new addresses. The table is created and manipulated with the +ptr_table_* functions. + +=cut + +============================================================================*/ + + #if defined(USE_ITHREADS) #if defined(USE_THREADS) @@ -7566,6 +8336,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #define SAVEPV(p) (p ? savepv(p) : Nullch) #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch) +/* duplicate a regexp */ + REGEXP * Perl_re_dup(pTHX_ REGEXP *r) { @@ -7573,6 +8345,8 @@ Perl_re_dup(pTHX_ REGEXP *r) return ReREFCNT_inc(r); } +/* duplicate a filke handle */ + PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type) { @@ -7591,6 +8365,8 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type) return ret; } +/* duplicate a directory handle */ + DIR * Perl_dirp_dup(pTHX_ DIR *dp) { @@ -7600,6 +8376,8 @@ Perl_dirp_dup(pTHX_ DIR *dp) return dp; } +/* duplictate a typeglob */ + GP * Perl_gp_dup(pTHX_ GP *gp) { @@ -7631,6 +8409,8 @@ Perl_gp_dup(pTHX_ GP *gp) return ret; } +/* duplicate a chain of magic */ + MAGIC * Perl_mg_dup(pTHX_ MAGIC *mg) { @@ -7686,6 +8466,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg) return mgret; } +/* create a new pointer-mapping table */ + PTR_TBL_t * Perl_ptr_table_new(pTHX) { @@ -7697,6 +8479,8 @@ Perl_ptr_table_new(pTHX) return tbl; } +/* map an existing pointer using a table */ + void * Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { @@ -7711,6 +8495,8 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) return (void*)NULL; } +/* add a new entry to a pointer-mapping table */ + void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) { @@ -7740,6 +8526,8 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) ptr_table_split(tbl); } +/* double the hash bucket size of an existing ptr table */ + void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) { @@ -7770,6 +8558,8 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) } } +/* remove all the entries from a ptr table */ + void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) { @@ -7804,6 +8594,8 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) tbl->tbl_items = 0; } +/* clear and free a ptr table */ + void Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) { @@ -7819,6 +8611,8 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) char *PL_watch_pvx; #endif +/* attempt to make everything in the typeglob readonly */ + STATIC SV * S_gv_share(pTHX_ SV *sstr) { @@ -7874,6 +8668,8 @@ S_gv_share(pTHX_ SV *sstr) return sstr; /* he_dup() will SvREFCNT_inc() */ } +/* duplicate an SV of any type (including AV, HV etc) */ + SV * Perl_sv_dup(pTHX_ SV *sstr) { @@ -8214,6 +9010,8 @@ dup_pvcv: return dstr; } +/* duplicate a context */ + PERL_CONTEXT * Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) { @@ -8300,6 +9098,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) return ncxs; } +/* duplicate a stack info structure */ + PERL_SI * Perl_si_dup(pTHX_ PERL_SI *si) { @@ -8347,6 +9147,10 @@ Perl_si_dup(pTHX_ PERL_SI *si) #define pv_dup(p) SAVEPV(p) #define svp_dup_inc(p,pp) any_dup(p,pp) +/* map any object to the new equivent - either something in the + * ptr table, or something in the interpreter structure + */ + void * Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) { @@ -8369,6 +9173,8 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) return ret; } +/* duplicate the save stack */ + ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) { @@ -8621,6 +9427,16 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) #include "XSUB.h" #endif +/* +=for apidoc perl_clone + +Create and return a new interpreter by cloning the current one. + +=cut +*/ + +/* XXX the above needs expanding by someone who actually understands it ! */ + PerlInterpreter * perl_clone(PerlInterpreter *proto_perl, UV flags) { @@ -8864,6 +9680,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Tdefstash); PL_curstash = hv_dup(proto_perl->Tcurstash); + PL_nullstash = hv_dup(proto_perl->Inullstash); PL_debstash = hv_dup(proto_perl->Idebstash); PL_globalstash = hv_dup(proto_perl->Iglobalstash); PL_curstname = sv_dup_inc(proto_perl->Icurstname); @@ -9342,59 +10159,3 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* USE_ITHREADS */ -static void -do_report_used(pTHXo_ SV *sv) -{ - if (SvTYPE(sv) != SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "****\n"); - sv_dump(sv); - } -} - -static void -do_clean_objs(pTHXo_ SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv))); - if (SvWEAKREF(sv)) { - sv_del_backref(sv); - SvWEAKREF_off(sv); - SvRV(sv) = 0; - } else { - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -static void -do_clean_named_objs(pTHXo_ SV *sv) -{ - if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { - if ( SvOBJECT(GvSV(sv)) || - (GvAV(sv) && SvOBJECT(GvAV(sv))) || - (GvHV(sv) && SvOBJECT(GvHV(sv))) || - (GvIO(sv) && SvOBJECT(GvIO(sv))) || - (GvCV(sv) && SvOBJECT(GvCV(sv))) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); - SvREFCNT_dec(sv); - } - } -} -#endif - -static void -do_clean_all(pTHXo_ SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); -} - @@ -193,7 +193,8 @@ perform the upgrade if necessary. See C<svtype>. #define SVf_FAKE 0x00100000 /* glob or lexical is just a copy */ #define SVf_OOK 0x00200000 /* has valid offset value */ -#define SVf_BREAK 0x00400000 /* refcnt is artificially low */ +#define SVf_BREAK 0x00400000 /* refcnt is artificially low - used + * by SV's in final arena cleanup */ #define SVf_READONLY 0x00800000 /* may not be modified */ @@ -500,19 +501,19 @@ Unsets the RV status of an SV. Dereferences an RV to return the SV. =for apidoc Am|IV|SvIVX|SV* sv -Returns the integer which is stored in the SV, assuming SvIOK is -true. +Returns the raw value in the SV's IV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C<SvIV()>. =for apidoc Am|UV|SvUVX|SV* sv -Returns the unsigned integer which is stored in the SV, assuming SvIOK is -true. +Returns the raw value in the SV's UV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C<SvUV()>. =for apidoc Am|NV|SvNVX|SV* sv -Returns the double which is stored in the SV, assuming SvNOK is -true. +Returns the raw value in the SV's NV slot, without checks or conversions. +Only use when you are sure SvNOK is true. See also C<SvNV()>. =for apidoc Am|char*|SvPVX|SV* sv -Returns a pointer to the string in the SV. The SV must contain a +Returns a pointer to the physical string in the SV. The SV must contain a string. =for apidoc Am|STRLEN|SvCUR|SV* sv @@ -824,27 +825,89 @@ Taints an SV if tainting is enabled Like <SvPV> but will force the SV into becoming a string (SvPOK). You want force if you are going to update the SvPVX directly. +=for apidoc Am|char*|SvPV_force_nomg|SV* sv|STRLEN len +Like <SvPV> but will force the SV into becoming a string (SvPOK). You want +force if you are going to update the SvPVX directly. Doesn't process magic. + =for apidoc Am|char*|SvPV|SV* sv|STRLEN len Returns a pointer to the string in the SV, or a stringified form of the SV -if the SV does not contain a string. Handles 'get' magic. +if the SV does not contain a string. Handles 'get' magic. See also +C<SvPVx> for a version which guarantees to evaluate sv only once. + +=for apidoc Am|char*|SvPVx|SV* sv|STRLEN len +A version of C<SvPV> which guarantees to evaluate sv only once. =for apidoc Am|char*|SvPV_nolen|SV* sv Returns a pointer to the string in the SV, or a stringified form of the SV if the SV does not contain a string. Handles 'get' magic. =for apidoc Am|IV|SvIV|SV* sv -Coerces the given SV to an integer and returns it. +Coerces the given SV to an integer and returns it. See C<SvIVx> for a +version which guarantees to evaluate sv only once. + +=for apidoc Am|IV|SvIVx|SV* sv +Coerces the given SV to an integer and returns it. Guarantees to evaluate +sv only once. Use the more efficent C<SvIV> otherwise. =for apidoc Am|NV|SvNV|SV* sv -Coerce the given SV to a double and return it. +Coerce the given SV to a double and return it. See C<SvNVx> for a version +which guarantees to evaluate sv only once. + +=for apidoc Am|NV|SvNVx|SV* sv +Coerces the given SV to a double and returns it. Guarantees to evaluate +sv only once. Use the more efficent C<SvNV> otherwise. =for apidoc Am|UV|SvUV|SV* sv -Coerces the given SV to an unsigned integer and returns it. +Coerces the given SV to an unsigned integer and returns it. See C<SvUVx> +for a version which guarantees to evaluate sv only once. + +=for apidoc Am|UV|SvUVx|SV* sv +Coerces the given SV to an unsigned integer and returns it. Guarantees to +evaluate sv only once. Use the more efficent C<SvUV> otherwise. =for apidoc Am|bool|SvTRUE|SV* sv Returns a boolean indicating whether Perl would evaluate the SV as true or false, defined or undefined. Does not handle 'get' magic. +=for apidoc Am|char*|SvPVutf8_force|SV* sv|STRLEN len +Like C<SvPV_force>, but converts sv to uft8 first if necessary. + +=for apidoc Am|char*|SvPVutf8|SV* sv|STRLEN len +Like C<SvPV>, but converts sv to uft8 first if necessary. + +=for apidoc Am|char*|SvPVutf8_nolen|SV* sv|STRLEN len +Like C<SvPV_nolen>, but converts sv to uft8 first if necessary. + +=for apidoc Am|char*|SvPVbyte_force|SV* sv|STRLEN len +Like C<SvPV_force>, but converts sv to byte representation first if necessary. + +=for apidoc Am|char*|SvPVbyte|SV* sv|STRLEN len +Like C<SvPV>, but converts sv to byte representation first if necessary. + +=for apidoc Am|char*|SvPVbyte_nolen|SV* sv|STRLEN len +Like C<SvPV_nolen>, but converts sv to byte representation first if necessary. + +=for apidoc Am|char*|SvPVutf8x_force|SV* sv|STRLEN len +Like C<SvPV_force>, but converts sv to uft8 first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVutf8_force> +otherwise. + +=for apidoc Am|char*|SvPVutf8x|SV* sv|STRLEN len +Like C<SvPV>, but converts sv to uft8 first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVutf8> +otherwise. + +=for apidoc Am|char*|SvPVbytex_force|SV* sv|STRLEN len +Like C<SvPV_force>, but converts sv to byte representation first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVbyte_force> +otherwise. + +=for apidoc Am|char*|SvPVbytex|SV* sv|STRLEN len +Like C<SvPV>, but converts sv to byte representation first if necessary. +Guarantees to evalute sv only once; use the more efficient C<SvPVbyte> +otherwise. + + =cut */ @@ -1089,6 +1152,12 @@ more than once. Calls a non-destructive version of C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments more than once. +=for apidoc Am|void|SvSetMagicSV|SV* dsb|SV* ssv +Like C<SvSetSV>, but does any set magic required afterwards. + +=for apidoc Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv +Like C<SvSetMagicSV>, but does any set magic required afterwards. + =for apidoc Am|char *|SvGROW|SV* sv|STRLEN len Expands the character buffer in the SV so that it has room for the indicated number of bytes (remember to reserve space for an extra trailing diff --git a/lib/locale/latin1 b/t/lib/locale/latin1 index f40f7325e0..f40f7325e0 100644 --- a/lib/locale/latin1 +++ b/t/lib/locale/latin1 diff --git a/lib/locale/utf8 b/t/lib/locale/utf8 index fbbe94fb51..fbbe94fb51 100644 --- a/lib/locale/utf8 +++ b/t/lib/locale/utf8 diff --git a/lib/strict/refs b/t/lib/strict/refs index 10599b0bb2..10599b0bb2 100644 --- a/lib/strict/refs +++ b/t/lib/strict/refs diff --git a/lib/strict/subs b/t/lib/strict/subs index ed4fe7a443..ed4fe7a443 100644 --- a/lib/strict/subs +++ b/t/lib/strict/subs diff --git a/lib/strict/vars b/t/lib/strict/vars index 40b55572b8..40b55572b8 100644 --- a/lib/strict/vars +++ b/t/lib/strict/vars diff --git a/lib/warnings/1global b/t/lib/warnings/1global index 0af80221b2..0af80221b2 100644 --- a/lib/warnings/1global +++ b/t/lib/warnings/1global diff --git a/lib/warnings/2use b/t/lib/warnings/2use index e25d43adbb..e25d43adbb 100644 --- a/lib/warnings/2use +++ b/t/lib/warnings/2use diff --git a/lib/warnings/3both b/t/lib/warnings/3both index a4d9ba806d..a4d9ba806d 100644 --- a/lib/warnings/3both +++ b/t/lib/warnings/3both diff --git a/lib/warnings/4lint b/t/lib/warnings/4lint index 848822dd30..848822dd30 100644 --- a/lib/warnings/4lint +++ b/t/lib/warnings/4lint diff --git a/lib/warnings/5nolint b/t/lib/warnings/5nolint index 56158a20be..56158a20be 100644 --- a/lib/warnings/5nolint +++ b/t/lib/warnings/5nolint diff --git a/lib/warnings/6default b/t/lib/warnings/6default index a8aafeeb22..a8aafeeb22 100644 --- a/lib/warnings/6default +++ b/t/lib/warnings/6default diff --git a/lib/warnings/7fatal b/t/lib/warnings/7fatal index a25fa2c2ea..a25fa2c2ea 100644 --- a/lib/warnings/7fatal +++ b/t/lib/warnings/7fatal diff --git a/lib/warnings/8signal b/t/lib/warnings/8signal index cc1b9d926d..cc1b9d926d 100644 --- a/lib/warnings/8signal +++ b/t/lib/warnings/8signal diff --git a/lib/warnings/9enabled b/t/lib/warnings/9enabled index f5579b2dde..f5579b2dde 100755 --- a/lib/warnings/9enabled +++ b/t/lib/warnings/9enabled diff --git a/lib/warnings/av b/t/lib/warnings/av index 79bd3b7600..79bd3b7600 100644 --- a/lib/warnings/av +++ b/t/lib/warnings/av diff --git a/lib/warnings/doio b/t/lib/warnings/doio index 2a357e2755..2a357e2755 100644 --- a/lib/warnings/doio +++ b/t/lib/warnings/doio diff --git a/lib/warnings/doop b/t/lib/warnings/doop index 5803b44581..5803b44581 100644 --- a/lib/warnings/doop +++ b/t/lib/warnings/doop diff --git a/lib/warnings/gv b/t/lib/warnings/gv index 5ed4eca018..5ed4eca018 100644 --- a/lib/warnings/gv +++ b/t/lib/warnings/gv diff --git a/lib/warnings/hv b/t/lib/warnings/hv index c9eec028f1..c9eec028f1 100644 --- a/lib/warnings/hv +++ b/t/lib/warnings/hv diff --git a/lib/warnings/malloc b/t/lib/warnings/malloc index 2f8b096a51..2f8b096a51 100644 --- a/lib/warnings/malloc +++ b/t/lib/warnings/malloc diff --git a/lib/warnings/mg b/t/lib/warnings/mg index f2243357b3..f2243357b3 100644 --- a/lib/warnings/mg +++ b/t/lib/warnings/mg diff --git a/lib/warnings/op b/t/lib/warnings/op index 2f847ad14c..2f847ad14c 100644 --- a/lib/warnings/op +++ b/t/lib/warnings/op diff --git a/lib/warnings/perl b/t/lib/warnings/perl index 512ee7fb65..512ee7fb65 100644 --- a/lib/warnings/perl +++ b/t/lib/warnings/perl diff --git a/lib/warnings/perlio b/t/lib/warnings/perlio index 18c0dfa89f..18c0dfa89f 100644 --- a/lib/warnings/perlio +++ b/t/lib/warnings/perlio diff --git a/lib/warnings/perly b/t/lib/warnings/perly index afc5dccc72..afc5dccc72 100644 --- a/lib/warnings/perly +++ b/t/lib/warnings/perly diff --git a/lib/warnings/pp b/t/lib/warnings/pp index 62f054a6ee..62f054a6ee 100644 --- a/lib/warnings/pp +++ b/t/lib/warnings/pp diff --git a/lib/warnings/pp_ctl b/t/lib/warnings/pp_ctl index ac01f277b1..ac01f277b1 100644 --- a/lib/warnings/pp_ctl +++ b/t/lib/warnings/pp_ctl diff --git a/lib/warnings/pp_hot b/t/lib/warnings/pp_hot index c5a3790587..c5a3790587 100644 --- a/lib/warnings/pp_hot +++ b/t/lib/warnings/pp_hot diff --git a/lib/warnings/pp_sys b/t/lib/warnings/pp_sys index e30637b0d4..e30637b0d4 100644 --- a/lib/warnings/pp_sys +++ b/t/lib/warnings/pp_sys diff --git a/lib/warnings/regcomp b/t/lib/warnings/regcomp index ceca4410d6..ceca4410d6 100644 --- a/lib/warnings/regcomp +++ b/t/lib/warnings/regcomp diff --git a/lib/warnings/regexec b/t/lib/warnings/regexec index 73696dfb1d..73696dfb1d 100644 --- a/lib/warnings/regexec +++ b/t/lib/warnings/regexec diff --git a/lib/warnings/run b/t/lib/warnings/run index 7a4be20e70..7a4be20e70 100644 --- a/lib/warnings/run +++ b/t/lib/warnings/run diff --git a/lib/warnings/sv b/t/lib/warnings/sv index b3929e2210..b3929e2210 100644 --- a/lib/warnings/sv +++ b/t/lib/warnings/sv diff --git a/lib/warnings/taint b/t/lib/warnings/taint index fd6deed60f..fd6deed60f 100644 --- a/lib/warnings/taint +++ b/t/lib/warnings/taint diff --git a/lib/warnings/toke b/t/lib/warnings/toke index 242b0059fb..242b0059fb 100644 --- a/lib/warnings/toke +++ b/t/lib/warnings/toke diff --git a/lib/warnings/universal b/t/lib/warnings/universal index d9b1883532..d9b1883532 100644 --- a/lib/warnings/universal +++ b/t/lib/warnings/universal diff --git a/lib/warnings/utf8 b/t/lib/warnings/utf8 index 9a7dbafdee..9a7dbafdee 100644 --- a/lib/warnings/utf8 +++ b/t/lib/warnings/utf8 diff --git a/lib/warnings/util b/t/lib/warnings/util index e82d6a6617..e82d6a6617 100644 --- a/lib/warnings/util +++ b/t/lib/warnings/util diff --git a/universal.c b/universal.c index ca69243ca6..75e6c5eae4 100644 --- a/universal.c +++ b/universal.c @@ -305,7 +305,7 @@ XS(XS_UNIVERSAL_VERSION) if (SvNV(req) > SvNV(sv)) Perl_croak(aTHX_ "%s version %s required--this is only version %s", - HvNAME(pkg), SvPV(req,len), SvPV(sv,len)); + HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); } finish: diff --git a/utils/libnetcfg.PL b/utils/libnetcfg.PL index 3418dd11a3..8af49912fe 100644 --- a/utils/libnetcfg.PL +++ b/utils/libnetcfg.PL @@ -35,14 +35,74 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; +=head1 NAME + +libnetcfg - configure libnet + +=head1 DESCRIPTION + +The libnetcfg utility can be be used to configure the libnet. +Starting from perl 5.8 libnet is part of the standard Perl +distribution, but the libnetcfg can be be used for any libnet +installation. + +=head1 USAGE + +Without arguments libnetcfg displays the current configuration. + + $ libnetcfg + # old config ./libnet.cfg + daytime_hosts ntp1.none.such + ftp_int_passive 0 + ftp_testhost ftp.funet.fi + inet_domain none.such + nntp_hosts nntp.none.such + ph_hosts + pop3_hosts pop.none.such + smtp_hosts smtp.none.such + snpp_hosts + test_exist 1 + test_hosts 1 + time_hosts ntp.none.such + # ./libnetcfg5.7.1 -h for help + $ + +It tells where the old configuration file was found (if found). + +The C<-h> option will show a usage message. + +To change the configuration you will need to use either the C<-c> or +the C<-d> options. + +The default name of the old configuration file is by default +"libnet.cfg", unless otherwise specified using the -i option, and it +is searched from your module path, C<-i oldfile>. + +The default name of new configuration file is "libnet.cfg", and by +default it is written to the current directory, unless otherwise +specified using the -o option, C<-o newfile>. + +=head1 SEE ALSO + +L<Net::Config>, L<Net::libnetFAQ> + +=head1 AUTHORS + +Graham Barr, the original Configure script of libnet. + +Jarkko Hietaniemi, conversion into libnet cfg for inclusion into Perl 5.8. + +=cut + # $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $ use strict; use IO::File; use Getopt::Std; use ExtUtils::MakeMaker qw(prompt); +use File::Spec; -use vars qw($opt_d $opt_o); +use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i); ## ## @@ -51,7 +111,7 @@ use vars qw($opt_d $opt_o); my %cfg = (); my @cfg = (); -my($libnet_cfg,$msg,$ans,$def,$have_old); +my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old); ## ## @@ -268,17 +328,20 @@ sub default_hostname ## ## -getopts('do:'); +getopts('dcho:i:'); + +$libnet_cfg_in = "libnet.cfg" + unless(defined($libnet_cfg_in = $opt_i)); -$libnet_cfg = "libnet.cfg" - unless(defined($libnet_cfg = $opt_o)); +$libnet_cfg_out = "libnet.cfg" + unless(defined($libnet_cfg_out = $opt_o)); my %oldcfg = (); $Net::Config::CONFIGURE = 1; # Suppress load of user overrides -if( -f $libnet_cfg ) +if( -f $libnet_cfg_in ) { - %oldcfg = ( %{ do $libnet_cfg } ); + %oldcfg = ( %{ do $libnet_cfg_in } ); } elsif (eval { require Net::Config }) { @@ -288,6 +351,59 @@ elsif (eval { require Net::Config }) map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg; +#--------------------------------------------------------------------------- + +if ($opt_h) { + print <<EOU; +$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h] +Without options, the old configuration is shown. + + -c change the configuration + -d use defaults from the old config (implies -c, non-interactive) + -i use a specific file as the old config file + -o use a specific file as the new config file + -h show this help + +The default name of the old configuration file is by default +"libnet.cfg", unless otherwise specified using the -i option, and it +is searched from your module path. + +The default name of new configuration file is "libnet.cfg", and by +default it is written to the current directory, unless otherwise +specified using the -o option. + +EOU + exit(0); +} + +#--------------------------------------------------------------------------- + +{ + my $oldcfgfile; + my @inc; + push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB}; + push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB}; + push @inc, @INC; + for (@inc) { + my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in); + if (-f $trycfgfile && -r $trycfgfile) { + $oldcfgfile = $trycfgfile; + last; + } + } + print "# old config $oldcfgfile\n" if defined $oldcfgfile; + for (sort keys %oldcfg) { + printf "%-20s %s\n", $_, + ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_}; + } + unless ($opt_c || $opt_d) { + print "# $0 -h for help\n"; + exit(0); + } +} + +#--------------------------------------------------------------------------- + $oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'}; $oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'}; @@ -595,10 +711,10 @@ print "\n"; #--------------------------------------------------------------------------- -my $fh = IO::File->new($libnet_cfg, "w") or - die "Cannot create `$libnet_cfg': $!"; +my $fh = IO::File->new($libnet_cfg_out, "w") or + die "Cannot create `$libnet_cfg_out': $!"; -print "Writing $libnet_cfg\n"; +print "Writing $libnet_cfg_out\n"; print $fh "{\n"; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index f3b5d4dbbc..022dcccabf 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -267,16 +267,16 @@ FULLLIBS2 = $(LIBS2)|$(THRLIBS1)|$(THRLIBS2) #### End of system configuration section. #### -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c -c1 = hv.c mg.c locale.c miniperlmain.c numeric.c op.c perl.c perlapi.c perlio.c -c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c -c3 = sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c +c1 = mg.c locale.c miniperlmain.c numeric.c op.c perl.c perlapi.c perlio.c +c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sys.c regcomp.c regexec.c +c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c c = $(c0) $(c1) $(c2) $(c3) obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mg$(O) miniperlmain$(O) numeric$(O) obj2 = op$(O) perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) -obj3 = pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) +obj3 = pp_pack$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) obj4 = universal$(O) utf8$(O) util$(O) vms$(O) xsutils$(O) obj = $(obj0) $(obj1) $(obj2) $(obj3) $(obj4) @@ -1166,6 +1166,7 @@ pp_ctl$(O) : pp_ctl.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) $(CC) $(CORECFLAGS) $(MMS$SOURCE) pp_hot$(O) : pp_hot.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h $(CC) $(CORECFLAGS) $(MMS$SOURCE) +pp_pack$(O) : pp_pack.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h pp_sys$(O) : pp_sys.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h $(CC) $(CORECFLAGS) $(MMS$SOURCE) regcomp$(O) : regcomp.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h intern.h regcomp.h regnodes.h diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 3c6b437b99..bc1183f483 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -54,29 +54,29 @@ typedef union { #line 54 "perly.c" #define YYERRCODE 256 static short yylhs[] = { -1, - 54, 0, 8, 6, 9, 7, 10, 10, 10, 11, - 11, 11, 11, 24, 24, 24, 24, 24, 24, 24, - 14, 14, 14, 13, 13, 42, 42, 12, 12, 12, - 12, 12, 12, 12, 26, 26, 27, 27, 28, 29, - 30, 31, 32, 53, 53, 1, 1, 1, 1, 1, - 2, 38, 38, 46, 55, 3, 4, 5, 39, 40, - 40, 44, 44, 44, 45, 45, 41, 41, 56, 56, - 58, 57, 15, 15, 15, 25, 25, 25, 36, 36, - 36, 36, 36, 36, 36, 36, 59, 36, 37, 37, + 0, 9, 7, 6, 10, 8, 11, 11, 11, 12, + 12, 12, 12, 25, 25, 25, 25, 25, 25, 25, + 15, 15, 15, 14, 14, 43, 43, 13, 13, 13, + 13, 13, 13, 13, 27, 27, 28, 28, 29, 30, + 31, 32, 33, 54, 54, 1, 1, 1, 1, 1, + 2, 39, 39, 47, 55, 3, 4, 5, 40, 41, + 41, 45, 45, 45, 46, 46, 42, 42, 56, 56, + 58, 57, 16, 16, 16, 26, 26, 26, 37, 37, + 37, 37, 37, 37, 37, 37, 59, 37, 38, 38, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 51, 51, 51, 51, 51, 51, + 51, 51, 52, 52, 52, 52, 52, 53, 53, 53, + 53, 53, 53, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 49, 49, 49, 49, 49, 49, 49, 49, 49, - 49, 49, 49, 49, 50, 50, 50, 50, 50, 50, - 50, 50, 51, 51, 51, 51, 51, 52, 52, 52, - 52, 52, 52, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 47, 47, 48, 48, 48, 48, - 48, 33, 33, 34, 34, 34, 43, 23, 18, 19, - 20, 21, 22, 35, 35, 35, 35, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 48, 48, 49, 49, 49, 49, + 49, 34, 34, 35, 35, 35, 44, 24, 19, 20, + 21, 22, 23, 36, 36, 36, 36, }; static short yylen[] = { 2, - 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, + 2, 4, 0, 0, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 3, 0, 2, 6, 7, 7, 0, 2, 8, 8, 10, 9, 8, 11, 3, 0, 1, 0, 1, 1, 1, @@ -97,10 +97,10 @@ static short yylen[] = { 2, 1, 0, 1, 0, 1, 2, 1, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, }; -static short yydefred[] = { 1, +static short yydefred[] = { 4, 0, 7, 0, 45, 58, 56, 0, 56, 56, 8, 46, 9, 11, 48, 0, 47, 49, 50, 0, 0, - 0, 70, 71, 0, 14, 4, 173, 0, 0, 154, + 0, 70, 71, 0, 14, 3, 173, 0, 0, 154, 0, 168, 0, 57, 57, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -108,8 +108,8 @@ static short yydefred[] = { 1, 0, 0, 0, 0, 0, 146, 148, 0, 0, 0, 0, 174, 140, 134, 135, 136, 137, 52, 0, 59, 0, 69, 0, 0, 7, 194, 197, 196, 195, 0, - 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, - 4, 0, 0, 0, 0, 0, 163, 0, 0, 0, + 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 163, 0, 0, 0, 0, 85, 0, 192, 0, 129, 0, 0, 0, 0, 0, 0, 0, 179, 181, 180, 0, 188, 0, 0, 0, 0, 0, 0, 0, 0, 124, 0, 0, 0, @@ -118,14 +118,14 @@ static short yydefred[] = { 1, 0, 0, 0, 0, 0, 0, 0, 119, 120, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 13, 0, 51, 61, 0, 0, 0, 0, 83, 0, 0, - 87, 0, 0, 0, 0, 0, 0, 0, 4, 167, + 87, 0, 0, 0, 0, 0, 0, 0, 3, 167, 169, 0, 0, 0, 0, 0, 0, 0, 126, 0, 158, 178, 0, 0, 175, 0, 0, 123, 27, 0, 0, 19, 0, 0, 0, 0, 73, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 90, 0, 0, 101, 0, 0, 0, 0, 0, 0, 0, 156, 0, 0, 0, - 0, 0, 0, 3, 0, 0, 171, 0, 0, 0, + 0, 0, 0, 2, 0, 0, 171, 0, 0, 0, 42, 0, 43, 0, 0, 0, 0, 187, 0, 0, 36, 41, 0, 0, 0, 170, 186, 86, 0, 130, 0, 132, 0, 125, 177, 65, 0, 0, 0, 0, @@ -140,12 +140,12 @@ static short yydefred[] = { 1, 0, 33, 0, 23, }; static short yydgoto[] = { 1, - 10, 11, 20, 104, 19, 95, 370, 98, 359, 3, - 12, 13, 70, 375, 285, 72, 73, 74, 75, 76, - 77, 78, 79, 291, 81, 292, 281, 283, 286, 294, - 282, 284, 122, 214, 100, 82, 257, 89, 91, 194, - 327, 156, 289, 271, 225, 14, 83, 137, 84, 85, - 86, 87, 15, 2, 16, 17, 18, 93, 278, + 10, 11, 20, 104, 19, 2, 95, 370, 98, 359, + 3, 12, 13, 70, 375, 285, 72, 73, 74, 75, + 76, 77, 78, 79, 291, 81, 292, 281, 283, 286, + 294, 282, 284, 122, 214, 100, 82, 257, 89, 91, + 194, 327, 156, 289, 271, 225, 14, 83, 137, 84, + 85, 86, 87, 15, 16, 17, 18, 93, 278, }; static short yysindex[] = { 0, 0, 0, -132, 0, 0, 0, -51, 0, 0, 0, @@ -232,11 +232,11 @@ static short yyrindex[] = { 0, 0, 0, 179, 0, }; static short yygindex[] = { 0, - 0, 0, 196, 425, 0, -2, 0, 37, 634, -94, - 0, 0, 0, -323, -15, 2445, 0, 999, 414, 417, - 0, 0, 0, 463, -43, 0, 0, 321, -198, 103, - 147, 280, -91, -185, 1, 0, 0, 0, 464, -44, - 222, 338, 0, -179, 0, 0, 0, 0, 0, 0, + 0, 0, 196, 425, 0, 0, -2, 0, 37, 634, + -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414, + 417, 0, 0, 0, 463, -43, 0, 0, 321, -198, + 103, 147, 280, -91, -185, 1, 0, 0, 0, 464, + -44, 222, 338, 0, -179, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; #define YYTABLESIZE 4568 @@ -265,7 +265,7 @@ static short yytable[] = { 71, 307, 21, 180, 226, 21, 21, 21, 345, 21, 350, 21, 21, 65, 21, 272, 96, 162, 163, 121, 298, 97, 162, 163, 270, 121, 304, 310, 21, 312, 313, - 306, 26, 21, 26, 26, 253, 2, 162, 163, 113, + 306, 26, 21, 26, 26, 253, 1, 162, 163, 113, 113, 113, 113, 162, 163, 308, 113, 314, 113, 367, 163, 110, 162, 163, 60, 75, 75, 75, 75, 21, 162, 163, 75, 162, 163, 381, 330, 113, 113, 44, @@ -1183,10 +1183,10 @@ static char *yyname[] = { }; static char *yyrule[] = { "$accept : prog", -"$$1 :", -"prog : $$1 lineseq", +"prog : progstart lineseq", "block : '{' remember lineseq '}'", "remember :", +"progstart :", "mblock : '{' mremember lineseq '}'", "mremember :", "lineseq :", @@ -1253,8 +1253,8 @@ static char *yyrule[] = { "subbody : ';'", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", -"$$2 :", -"use : USE startsub $$2 WORD WORD listexpr ';'", +"$$1 :", +"use : USE startsub $$1 WORD WORD listexpr ';'", "expr : expr ANDOP expr", "expr : expr OROP expr", "expr : argexpr", @@ -1269,8 +1269,8 @@ static char *yyrule[] = { "listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", "listop : FUNC '(' listexprcom ')'", -"$$3 :", -"listop : LSTOPSUB startanonsub block $$3 listexpr", +"$$2 :", +"listop : LSTOPSUB startanonsub block $$2 listexpr", "method : METHOD", "method : scalar", "subscripted : star '{' expr ';' '}'", @@ -1396,7 +1396,7 @@ static char *yyrule[] = { #define YYMAXDEPTH 500 #endif #endif -#line 789 "perly.y" +#line 793 "perly.y" /* PROGRAM */ /* more stuff added to make perly_c.diff easier to apply */ @@ -1406,7 +1406,7 @@ static char *yyrule[] = { #endif #define yyparse() Perl_yyparse(pTHX) -#line 1481 "perly.c" +#line 1409 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1436,9 +1436,9 @@ yyparse() ysave->oldyychar = yychar; ysave->oldyyval = yyval; ysave->oldyylval = yylval; - + #if YYDEBUG - if (yys = getenv("YYDEBUG")) + if ((yys = getenv("YYDEBUG"))) { yyn = *yys; if (yyn >= '0' && yyn <= '9') @@ -1466,7 +1466,7 @@ yyparse() *yyssp = yystate = 0; yyloop: - if (yyn = yydefred[yystate]) goto yyreduce; + if ((yyn = yydefred[yystate])) goto yyreduce; if (yychar < 0) { if ((yychar = yylex()) < 0) yychar = 0; @@ -1501,7 +1501,7 @@ yyloop: ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } @@ -1554,7 +1554,7 @@ yyinrecovery: ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } @@ -1602,59 +1602,59 @@ yyreduce: switch (yyn) { case 1: -#line 130 "perly.y" -{ -#if defined(YYDEBUG) && defined(DEBUGGING) - yydebug = (DEBUG_p_TEST); -#endif - PL_expect = XSTATE; yyval.ival = block_start(TRUE); - } +#line 131 "perly.y" +{ yyval.ival = yyvsp[-1].ival; newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); } break; case 2: -#line 137 "perly.y" -{ newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); } -break; -case 3: -#line 142 "perly.y" +#line 136 "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 148 "perly.y" +case 3: +#line 142 "perly.y" { yyval.ival = block_start(TRUE); } break; +case 4: +#line 146 "perly.y" +{ +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (DEBUG_p_TEST); +#endif + PL_expect = XSTATE; yyval.ival = block_start(TRUE); + } +break; case 5: -#line 152 "perly.y" +#line 156 "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 158 "perly.y" +#line 162 "perly.y" { yyval.ival = block_start(FALSE); } break; case 7: -#line 163 "perly.y" +#line 167 "perly.y" { yyval.opval = Nullop; } break; case 8: -#line 165 "perly.y" +#line 169 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 9: -#line 167 "perly.y" +#line 171 "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 175 "perly.y" +#line 179 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; case 12: -#line 178 "perly.y" +#line 182 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1665,75 +1665,75 @@ case 12: PL_expect = XSTATE; } break; case 13: -#line 187 "perly.y" +#line 191 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); PL_expect = XSTATE; } break; case 14: -#line 193 "perly.y" +#line 197 "perly.y" { yyval.opval = Nullop; } break; case 15: -#line 195 "perly.y" +#line 199 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 16: -#line 197 "perly.y" +#line 201 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 17: -#line 199 "perly.y" +#line 203 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 18: -#line 201 "perly.y" +#line 205 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 19: -#line 203 "perly.y" +#line 207 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; case 20: -#line 205 "perly.y" +#line 209 "perly.y" { yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival, Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); } break; case 21: -#line 211 "perly.y" +#line 215 "perly.y" { yyval.opval = Nullop; } break; case 22: -#line 213 "perly.y" +#line 217 "perly.y" { (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); } break; case 23: -#line 215 "perly.y" +#line 219 "perly.y" { PL_copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); PL_hints |= HINT_BLOCK_SCOPE; } break; case 24: -#line 222 "perly.y" +#line 226 "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 226 "perly.y" +#line 230 "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 233 "perly.y" +#line 237 "perly.y" { yyval.opval = Nullop; } break; case 27: -#line 235 "perly.y" +#line 239 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 28: -#line 240 "perly.y" +#line 244 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1741,7 +1741,7 @@ case 28: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 29: -#line 246 "perly.y" +#line 250 "perly.y" { PL_copline = yyvsp[-6].ival; yyval.opval = block_end(yyvsp[-4].ival, newSTATEOP(0, yyvsp[-7].pval, @@ -1749,23 +1749,23 @@ case 29: yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); } break; case 30: -#line 252 "perly.y" +#line 256 "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 255 "perly.y" +#line 259 "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 259 "perly.y" +#line 263 "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 263 "perly.y" +#line 267 "perly.y" { OP *forop; PL_copline = yyvsp[-9].ival; forop = newSTATEOP(0, yyvsp[-10].pval, @@ -1782,97 +1782,97 @@ case 33: yyval.opval = block_end(yyvsp[-7].ival, forop); } break; case 34: -#line 278 "perly.y" +#line 282 "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 285 "perly.y" +#line 289 "perly.y" { yyval.opval = Nullop; } break; case 37: -#line 291 "perly.y" +#line 295 "perly.y" { (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: -#line 297 "perly.y" +#line 301 "perly.y" { yyval.opval = invert(scalar(yyvsp[0].opval)); } break; case 40: -#line 302 "perly.y" +#line 306 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 41: -#line 306 "perly.y" +#line 310 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 42: -#line 310 "perly.y" +#line 314 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 43: -#line 314 "perly.y" +#line 318 "perly.y" { yyval.opval = yyvsp[0].opval; intro_my(); } break; case 44: -#line 319 "perly.y" +#line 323 "perly.y" { yyval.pval = Nullch; } break; case 46: -#line 325 "perly.y" +#line 329 "perly.y" { yyval.ival = 0; } break; case 47: -#line 327 "perly.y" +#line 331 "perly.y" { yyval.ival = 0; } break; case 48: -#line 329 "perly.y" +#line 333 "perly.y" { yyval.ival = 0; } break; case 49: -#line 331 "perly.y" +#line 335 "perly.y" { yyval.ival = 0; } break; case 50: -#line 333 "perly.y" +#line 337 "perly.y" { yyval.ival = 0; } break; case 51: -#line 337 "perly.y" +#line 341 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 52: -#line 340 "perly.y" +#line 344 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 53: -#line 341 "perly.y" +#line 345 "perly.y" { yyval.opval = Nullop; } break; case 54: -#line 346 "perly.y" +#line 350 "perly.y" { newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 55: -#line 351 "perly.y" +#line 355 "perly.y" { newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 56: -#line 355 "perly.y" +#line 359 "perly.y" { yyval.ival = start_subparse(FALSE, 0); } break; case 57: -#line 359 "perly.y" +#line 363 "perly.y" { yyval.ival = start_subparse(FALSE, CVf_ANON); } break; case 58: -#line 363 "perly.y" +#line 367 "perly.y" { yyval.ival = start_subparse(TRUE, 0); } break; case 59: -#line 367 "perly.y" +#line 371 "perly.y" { STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT") || strEQ(name, "CHECK")) @@ -1880,305 +1880,305 @@ case 59: yyval.opval = yyvsp[0].opval; } break; case 60: -#line 376 "perly.y" +#line 380 "perly.y" { yyval.opval = Nullop; } break; case 62: -#line 382 "perly.y" +#line 386 "perly.y" { yyval.opval = Nullop; } break; case 63: -#line 384 "perly.y" +#line 388 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 64: -#line 386 "perly.y" +#line 390 "perly.y" { yyval.opval = Nullop; } break; case 65: -#line 391 "perly.y" +#line 395 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 66: -#line 393 "perly.y" +#line 397 "perly.y" { yyval.opval = Nullop; } break; case 67: -#line 397 "perly.y" +#line 401 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 68: -#line 398 "perly.y" +#line 402 "perly.y" { yyval.opval = Nullop; PL_expect = XSTATE; } break; case 69: -#line 402 "perly.y" +#line 406 "perly.y" { package(yyvsp[-1].opval); } break; case 70: -#line 404 "perly.y" +#line 408 "perly.y" { package(Nullop); } break; case 71: -#line 408 "perly.y" +#line 412 "perly.y" { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } break; case 72: -#line 410 "perly.y" +#line 414 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 73: -#line 415 "perly.y" +#line 419 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 74: -#line 417 "perly.y" +#line 421 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 76: -#line 423 "perly.y" +#line 427 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 77: -#line 425 "perly.y" +#line 429 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 79: -#line 431 "perly.y" +#line 435 "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 80: -#line 434 "perly.y" +#line 438 "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 81: -#line 437 "perly.y" +#line 441 "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 82: -#line 442 "perly.y" +#line 446 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, scalar(yyvsp[-2].opval), newUNOP(OP_METHOD, 0, yyvsp[0].opval))); } break; case 83: -#line 446 "perly.y" +#line 450 "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 84: -#line 451 "perly.y" +#line 455 "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 85: -#line 456 "perly.y" +#line 460 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 86: -#line 458 "perly.y" +#line 462 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 87: -#line 460 "perly.y" +#line 464 "perly.y" { yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); } break; case 88: -#line 462 "perly.y" +#line 466 "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 91: -#line 476 "perly.y" +#line 480 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); } break; case 92: -#line 478 "perly.y" +#line 482 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 93: -#line 480 "perly.y" +#line 484 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 94: -#line 484 "perly.y" +#line 488 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 95: -#line 488 "perly.y" +#line 492 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 96: -#line 491 "perly.y" +#line 495 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 97: -#line 496 "perly.y" +#line 500 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); PL_expect = XOPERATOR; } break; case 98: -#line 501 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 99: -#line 504 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 100: -#line 509 "perly.y" +#line 513 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-3].opval)))); } break; case 101: -#line 513 "perly.y" +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-2].opval))); } break; case 102: -#line 519 "perly.y" +#line 523 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 103: -#line 521 "perly.y" +#line 525 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 104: -#line 523 "perly.y" +#line 527 "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 105: -#line 527 "perly.y" +#line 531 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 106: -#line 529 "perly.y" +#line 533 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 107: -#line 531 "perly.y" +#line 535 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 108: -#line 533 "perly.y" +#line 537 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 109: -#line 535 "perly.y" +#line 539 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 110: -#line 537 "perly.y" +#line 541 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 111: -#line 539 "perly.y" +#line 543 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 112: -#line 541 "perly.y" +#line 545 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 113: -#line 543 "perly.y" +#line 547 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 114: -#line 545 "perly.y" +#line 549 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 115: -#line 550 "perly.y" +#line 554 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 116: -#line 552 "perly.y" +#line 556 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 117: -#line 554 "perly.y" +#line 558 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 118: -#line 556 "perly.y" +#line 560 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 119: -#line 558 "perly.y" +#line 562 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 120: -#line 561 "perly.y" +#line 565 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 121: -#line 564 "perly.y" +#line 568 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 122: -#line 567 "perly.y" +#line 571 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 123: -#line 574 "perly.y" +#line 578 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 124: -#line 576 "perly.y" +#line 580 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 125: -#line 578 "perly.y" +#line 582 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 126: -#line 580 "perly.y" +#line 584 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 127: -#line 582 "perly.y" +#line 586 "perly.y" { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 128: -#line 588 "perly.y" +#line 592 "perly.y" { yyval.opval = dofile(yyvsp[0].opval); } break; case 129: -#line 590 "perly.y" +#line 594 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 130: -#line 592 "perly.y" +#line 596 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2188,7 +2188,7 @@ case 130: )),Nullop)); dep();} break; case 131: -#line 600 "perly.y" +#line 604 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2199,76 +2199,76 @@ case 131: )))); dep();} break; case 132: -#line 609 "perly.y" +#line 613 "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 133: -#line 613 "perly.y" +#line 617 "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 138: -#line 625 "perly.y" +#line 629 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 139: -#line 627 "perly.y" +#line 631 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 140: -#line 629 "perly.y" +#line 633 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 141: -#line 631 "perly.y" +#line 635 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 142: -#line 633 "perly.y" +#line 637 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 143: -#line 635 "perly.y" +#line 639 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 144: -#line 637 "perly.y" +#line 641 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 145: -#line 639 "perly.y" +#line 643 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 146: -#line 641 "perly.y" +#line 645 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 147: -#line 643 "perly.y" +#line 647 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 148: -#line 645 "perly.y" +#line 649 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 149: -#line 647 "perly.y" +#line 651 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 150: -#line 649 "perly.y" +#line 653 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 151: -#line 651 "perly.y" +#line 655 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 152: -#line 653 "perly.y" +#line 657 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2276,7 +2276,7 @@ case 152: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 153: -#line 659 "perly.y" +#line 663 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2285,179 +2285,179 @@ case 153: PL_expect = XOPERATOR; } break; case 154: -#line 666 "perly.y" +#line 670 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 155: -#line 668 "perly.y" +#line 672 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 156: -#line 670 "perly.y" +#line 674 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 157: -#line 672 "perly.y" +#line 676 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 158: -#line 675 "perly.y" +#line 679 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 159: -#line 678 "perly.y" +#line 682 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; } break; case 160: -#line 681 "perly.y" +#line 685 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 161: -#line 683 "perly.y" +#line 687 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 162: -#line 685 "perly.y" +#line 689 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 163: -#line 687 "perly.y" +#line 691 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 164: -#line 689 "perly.y" +#line 693 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 165: -#line 691 "perly.y" +#line 695 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 166: -#line 694 "perly.y" +#line 698 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 167: -#line 696 "perly.y" +#line 700 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 168: -#line 698 "perly.y" +#line 702 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 169: -#line 701 "perly.y" +#line 705 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 170: -#line 703 "perly.y" +#line 707 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 171: -#line 705 "perly.y" +#line 709 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 172: -#line 707 "perly.y" +#line 711 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 175: -#line 714 "perly.y" +#line 718 "perly.y" { yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); } break; case 176: -#line 716 "perly.y" +#line 720 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 177: -#line 721 "perly.y" +#line 725 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 178: -#line 723 "perly.y" +#line 727 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 179: -#line 725 "perly.y" +#line 729 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 180: -#line 727 "perly.y" +#line 731 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 181: -#line 729 "perly.y" +#line 733 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 182: -#line 734 "perly.y" +#line 738 "perly.y" { yyval.opval = Nullop; } break; case 183: -#line 736 "perly.y" +#line 740 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 184: -#line 740 "perly.y" +#line 744 "perly.y" { yyval.opval = Nullop; } break; case 185: -#line 742 "perly.y" +#line 746 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 186: -#line 744 "perly.y" +#line 748 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 187: -#line 750 "perly.y" +#line 754 "perly.y" { PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 188: -#line 754 "perly.y" +#line 758 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 189: -#line 758 "perly.y" +#line 762 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 190: -#line 762 "perly.y" +#line 766 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 191: -#line 766 "perly.y" +#line 770 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 192: -#line 770 "perly.y" +#line 774 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 193: -#line 774 "perly.y" +#line 778 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 194: -#line 779 "perly.y" +#line 783 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 195: -#line 781 "perly.y" +#line 785 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 196: -#line 783 "perly.y" +#line 787 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 197: -#line 786 "perly.y" +#line 790 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2477 "perly.c" +#line 2459 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -2512,7 +2512,7 @@ to state %d\n", *yyssp, yystate); ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE); ysave->yyss = Renew(yyss, yystacksize, short); if (!yyvs || !yyss) - goto yyoverflow; + goto yyoverflow; yyssp = yyss + yyps_index; yyvsp = yyvs + yypv_index; } diff --git a/vos/Changes b/vos/Changes index 6a39bcdc95..640db49d81 100644 --- a/vos/Changes +++ b/vos/Changes @@ -10,6 +10,7 @@ For 5.7.1: the header, because the perl distribution resets all dates to the same value. Update "Changes". + Update "perl.bind". For 5.7: Updated "build.cm" to build perl using either the alpha or GA diff --git a/vos/Makefile b/vos/Makefile new file mode 100644 index 0000000000..ad19bfe5bb --- /dev/null +++ b/vos/Makefile @@ -0,0 +1,21 @@ +# +# This Makefile can be used to update the config.alpha.h and +# config.ga.h files *in UNIX* (in VOS the configure_perl.cm +# is used). Update the config.*.def files appropriately when +# you add new symbols to Configure. If you don't know VOS, +# most of the time a safe guess for a symbol is 'undef'. +# + +all: config.alpha.h config.ga.h + +config.alpha.h: config.alpha.def ../config_h.SH ../mv-if-diff + cp config.alpha.def config.def + perl config.pl + sh ../mv-if-diff config.h.new config.alpha.h + rm -f config.def config.h.new + +config.ga.h: config.ga.def ../config_h.SH ../mv-if-diff + cp config.ga.def config.def + perl config.pl + sh ../mv-if-diff config.h.new config.ga.h + rm -f config.def config.h.new diff --git a/vos/build.cm b/vos/build.cm index ec9e58997e..ea3649975a 100644 --- a/vos/build.cm +++ b/vos/build.cm @@ -109,10 +109,14 @@ &if (command_status) ^= 0 &then &return !&compiler& <<hv.c &diag& &cpu& &cflags& -o hv&s& &if (command_status) ^= 0 &then &return +!&compiler& <<locale.c &diag& &cpu& &cflags& -o locale&s& +&if (command_status) ^= 0 &then &return & !&compiler& <<malloc.c &diag& &cpu& &cflags& -o malloc&s& & &if (command_status) ^= 0 &then &return !&compiler& <<mg.c &diag& &cpu& &cflags& -o mg&s& &if (command_status) ^= 0 &then &return +!&compiler& <<numeric.c &diag& &cpu& &cflags& -o numeric&s& +&if (command_status) ^= 0 &then &return !&compiler& <<op.c &diag& &cpu& &cflags& -o op&s& &if (command_status) ^= 0 &then &return & @@ -148,6 +152,8 @@ &if (command_status) ^= 0 &then &return !&compiler& <<pp_hot.c &diag& &cpu& &cflags& -o pp_hot&s& &if (command_status) ^= 0 &then &return +!&compiler& <<pp_pack.c &diag& &cpu& &cflags& -o pp_pack&s& +&if (command_status) ^= 0 &then &return !&compiler& <<pp_sys.c &diag& &cpu& &cflags& -o pp_sys&s& &if (command_status) ^= 0 &then &return !&compiler& <<regcomp.c &diag& &cpu& &cflags& -o regcomp&s& diff --git a/vos/config.alpha.def b/vos/config.alpha.def index 5d437d85a6..23196501c3 100644 --- a/vos/config.alpha.def +++ b/vos/config.alpha.def @@ -484,6 +484,7 @@ $stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' $stdio_cnt='((fp)->_cnt)' $stdio_ptr='((fp)->_ptr)' $stdio_stream_array='_iob' +$targetarch='undef' $timetype='time_t' $u16size='2' $u16type='unsigned short' diff --git a/vos/config.alpha.h b/vos/config.alpha.h index f610d327eb..54dfc0c7fe 100644 --- a/vos/config.alpha.h +++ b/vos/config.alpha.h @@ -121,26 +121,6 @@ */ /*#define HAS_DLERROR /**/ -/* SETUID_SCRIPTS_ARE_SECURE_NOW: - * This symbol, if defined, indicates that the bug that prevents - * setuid scripts from being secure is not present in this kernel. - */ -/* DOSUID: - * This symbol, if defined, indicates that the C program should - * check the script that it is executing for setuid/setgid bits, and - * attempt to emulate setuid/setgid on systems that have disabled - * setuid #! scripts because the kernel can't do it securely. - * It is up to the package designer to make sure that this emulation - * is done securely. Among other things, it should do an fstat on - * the script it just opened to make sure it really is a setuid/setgid - * script, it should make sure the arguments passed correspond exactly - * to the argument on the #! line, and it should not trust any - * subprocesses to which it must pass the filename rather than the - * file descriptor of the script to be executed. - */ -#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ -/*#define DOSUID /**/ - /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. @@ -918,17 +898,6 @@ */ #define I_VALUES /**/ -/* I_STDARG: - * This symbol, if defined, indicates that <stdarg.h> exists and should - * be included. - */ -/* I_VARARGS: - * This symbol, if defined, indicates to the C program that it should - * include <varargs.h>. - */ -#define I_STDARG /**/ -/*#define I_VARARGS /**/ - /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. @@ -3237,12 +3206,18 @@ * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ +/* USE_REENTRANT_API: + * This symbol, if defined, indicates that Perl should + * try to use the various _r versions of library functions. + * This is extremely experimental. + */ /*#define USE_5005THREADS /**/ /*#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API /**/ +/*#define USE_REENTRANT_API /**/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. @@ -3334,6 +3309,49 @@ #define PERL_XS_APIVERSION "5.00563" #define PERL_PM_APIVERSION "5.005" +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* USE_CROSS_COMPILE: + * This symbol, if defined, indicates that Perl is being cross-compiled. + */ +/* PERL_TARGETARCH: + * This symbol, if defined, indicates the target architecture + * Perl has been cross-compiled to. Undefined if not a cross-compile. + */ +#ifndef USE_CROSS_COMPILE +/*#define USE_CROSS_COMPILE /**/ +#define PERL_TARGETARCH "undef" /**/ +#endif + /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up diff --git a/vos/config.ga.def b/vos/config.ga.def index 7ad9bd0a8e..9a0a02cf98 100644 --- a/vos/config.ga.def +++ b/vos/config.ga.def @@ -484,6 +484,7 @@ $stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' $stdio_cnt='((fp)->_cnt)' $stdio_ptr='((fp)->_ptr)' $stdio_stream_array='_iob' +$targetarch='undef' $timetype='time_t' $u16size='2' $u16type='unsigned short' diff --git a/vos/config.ga.h b/vos/config.ga.h index 791d9374ee..8c4dd35376 100644 --- a/vos/config.ga.h +++ b/vos/config.ga.h @@ -121,26 +121,6 @@ */ /*#define HAS_DLERROR /**/ -/* SETUID_SCRIPTS_ARE_SECURE_NOW: - * This symbol, if defined, indicates that the bug that prevents - * setuid scripts from being secure is not present in this kernel. - */ -/* DOSUID: - * This symbol, if defined, indicates that the C program should - * check the script that it is executing for setuid/setgid bits, and - * attempt to emulate setuid/setgid on systems that have disabled - * setuid #! scripts because the kernel can't do it securely. - * It is up to the package designer to make sure that this emulation - * is done securely. Among other things, it should do an fstat on - * the script it just opened to make sure it really is a setuid/setgid - * script, it should make sure the arguments passed correspond exactly - * to the argument on the #! line, and it should not trust any - * subprocesses to which it must pass the filename rather than the - * file descriptor of the script to be executed. - */ -#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ -/*#define DOSUID /**/ - /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. @@ -918,17 +898,6 @@ */ #define I_VALUES /**/ -/* I_STDARG: - * This symbol, if defined, indicates that <stdarg.h> exists and should - * be included. - */ -/* I_VARARGS: - * This symbol, if defined, indicates to the C program that it should - * include <varargs.h>. - */ -#define I_STDARG /**/ -/*#define I_VARARGS /**/ - /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. @@ -3237,12 +3206,18 @@ * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ +/* USE_REENTRANT_API: + * This symbol, if defined, indicates that Perl should + * try to use the various _r versions of library functions. + * This is extremely experimental. + */ /*#define USE_5005THREADS /**/ /*#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif /*#define OLD_PTHREADS_API /**/ +/*#define USE_REENTRANT_API /**/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. @@ -3334,6 +3309,49 @@ #define PERL_XS_APIVERSION "5.00563" #define PERL_PM_APIVERSION "5.005" +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* USE_CROSS_COMPILE: + * This symbol, if defined, indicates that Perl is being cross-compiled. + */ +/* PERL_TARGETARCH: + * This symbol, if defined, indicates the target architecture + * Perl has been cross-compiled to. Undefined if not a cross-compile. + */ +#ifndef USE_CROSS_COMPILE +/*#define USE_CROSS_COMPILE /**/ +#define PERL_TARGETARCH "undef" /**/ +#endif + /* HAS_DBMINIT_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the dbminit() function. Otherwise, it is up diff --git a/vos/perl.bind b/vos/perl.bind index 1e77e5a6de..e301fe0f46 100644 --- a/vos/perl.bind +++ b/vos/perl.bind @@ -11,7 +11,9 @@ modules: miniperlmain, globals, gv, hv, + locale, mg, + numeric, op, perl, perlapi, @@ -20,6 +22,7 @@ modules: miniperlmain, pp, pp_ctl, pp_hot, + pp_pack, pp_sys, regcomp, regexec, diff --git a/win32/Makefile b/win32/Makefile index 3418338906..38458ace80 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -501,7 +501,9 @@ MICROCORE_SRC = \ ..\globals.c \
..\gv.c \
..\hv.c \
+ ..\locale.c \
..\mg.c \
+ ..\numeric.c \
..\op.c \
..\perl.c \
..\perlapi.c \
@@ -509,6 +511,7 @@ MICROCORE_SRC = \ ..\pp.c \
..\pp_ctl.c \
..\pp_hot.c \
+ ..\pp_pack.c \
..\pp_sys.c \
..\regcomp.c \
..\regexec.c \
diff --git a/win32/makefile.mk b/win32/makefile.mk index 3fd644f39f..f99b4ce668 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -652,7 +652,9 @@ MICROCORE_SRC = \ ..\globals.c \
..\gv.c \
..\hv.c \
+ ..\locale.c \
..\mg.c \
+ ..\numeric.c \
..\op.c \
..\perl.c \
..\perlapi.c \
@@ -660,6 +662,7 @@ MICROCORE_SRC = \ ..\pp.c \
..\pp_ctl.c \
..\pp_hot.c \
+ ..\pp_pack.c \
..\pp_sys.c \
..\regcomp.c \
..\regexec.c \
@@ -671,8 +674,6 @@ MICROCORE_SRC = \ ..\universal.c \
..\utf8.c \
..\util.c \
- ..\numeric.c \
- ..\locale.c \
..\xsutils.c
EXTRACORE_SRC += perllib.c
|